diff options
Diffstat (limited to 'contrib/perl5/ext')
159 files changed, 15607 insertions, 3655 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index 75dcfb3..4512d91 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -6,15 +6,15 @@ # License or the Artistic License, as specified in the README file. # package B; -require DynaLoader; +use XSLoader (); require Exporter; -@ISA = qw(Exporter DynaLoader); -@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname +@ISA = qw(Exporter); +@EXPORT_OK = qw(minus_c ppname class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object + main_root main_start main_cv svref_2object opnumber amagic_generation walkoptree walkoptree_slow walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info init_av); - +sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @B::NULL::ISA = 'B::SV'; @@ -38,10 +38,9 @@ use strict; @B::UNOP::ISA = 'B::OP'; @B::BINOP::ISA = 'B::UNOP'; @B::LOGOP::ISA = 'B::UNOP'; -@B::CONDOP::ISA = 'B::UNOP'; @B::LISTOP::ISA = 'B::BINOP'; @B::SVOP::ISA = 'B::OP'; -@B::GVOP::ISA = 'B::OP'; +@B::PADOP::ISA = 'B::OP'; @B::PVOP::ISA = 'B::OP'; @B::CVOP::ISA = 'B::OP'; @B::LOOP::ISA = 'B::LISTOP'; @@ -65,10 +64,6 @@ sub debug { walkoptree_debug($value); } -# sub OPf_KIDS; -# add to .xs for perl5.002 -sub OPf_KIDS () { 4 } - sub class { my $obj = shift; my $name = ref $obj; @@ -81,7 +76,7 @@ sub parents { \@parents } # For debugging sub peekop { my $op = shift; - return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr); + return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); } sub walkoptree_slow { @@ -112,6 +107,11 @@ sub timing_info { } my %symtable; + +sub clearsym { + %symtable = (); +} + sub savesym { my ($obj, $value) = @_; # warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug @@ -135,37 +135,26 @@ sub walkoptree_exec { } savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); $op->$method($level); - $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) { + $ppname = $op->name; + if ($ppname =~ + /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/) + { print $prefix, uc($1), " => {\n"; walkoptree_exec($op->other, $method, $level + 1); print $prefix, "}\n"; - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($ppname eq "match" || $ppname eq "subst") { my $pmreplstart = $op->pmreplstart; if ($$pmreplstart) { print $prefix, "PMREPLSTART => {\n"; walkoptree_exec($pmreplstart, $method, $level + 1); print $prefix, "}\n"; } - } elsif ($ppname eq "pp_substcont") { + } elsif ($ppname eq "substcont") { print $prefix, "SUBSTCONT => {\n"; walkoptree_exec($op->other->pmreplstart, $method, $level + 1); print $prefix, "}\n"; $op = $op->other; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - print $prefix, "TRUE => {\n"; - walkoptree_exec($op->true, $method, $level + 1); - print $prefix, "}\n"; - $op = $op->false; - redo; - } elsif ($ppname eq "pp_range") { - print $prefix, "TRUE => {\n"; - walkoptree_exec($op->true, $method, $level + 1); - print $prefix, "}\n", $prefix, "FALSE => {\n"; - walkoptree_exec($op->false, $method, $level + 1); - print $prefix, "}\n"; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($ppname eq "enterloop") { print $prefix, "REDO => {\n"; walkoptree_exec($op->redoop, $method, $level + 1); print $prefix, "}\n", $prefix, "NEXT => {\n"; @@ -173,7 +162,7 @@ sub walkoptree_exec { print $prefix, "}\n", $prefix, "LAST => {\n"; walkoptree_exec($op->lastop, $method, $level + 1); print $prefix, "}\n"; - } elsif ($ppname eq "pp_subst") { + } elsif ($ppname eq "subst") { my $replstart = $op->pmreplstart; if ($$replstart) { print $prefix, "SUBST => {\n"; @@ -187,9 +176,12 @@ sub walkoptree_exec { sub walksymtable { my ($symref, $method, $recurse, $prefix) = @_; my $sym; + my $ref; no strict 'vars'; local(*glob); - while (($sym, *glob) = each %$symref) { + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) { + *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; if ($sym ne "main::" && &$recurse($sym)) { @@ -267,7 +259,7 @@ sub walksymtable { } } -bootstrap B; +XSLoader::load 'B'; 1; @@ -428,6 +420,10 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =over 4 +=item is_empty + +This method returns TRUE if the GP field of the GV is NULL. + =item NAME =item STASH @@ -450,6 +446,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item LINE +=item FILE + =item FILEGV =item GvREFCNT @@ -518,7 +516,7 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item GV -=item FILEGV +=item FILE =item DEPTH @@ -556,8 +554,8 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =head2 OP-RELATED CLASSES -B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP, -B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP. +B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP, +B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP. These classes correspond in the obvious way to the underlying C structures of similar names. The inheritance hierarchy mimics the underlying C "inheritance". Access @@ -572,9 +570,14 @@ leading "class indication" prefix removed (op_). =item sibling +=item name + +This returns the op name as a string (e.g. "add", "rv2av"). + =item ppaddr -This returns the function name as a string (e.g. pp_add, pp_rv2av). +This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]", +"PL_ppaddr[OP_RV2AV]"). =item desc @@ -617,16 +620,6 @@ This returns the op description from the global C PL_op_desc array =back -=head2 B::CONDOP METHODS - -=over 4 - -=item true - -=item false - -=back - =head2 B::LISTOP METHOD =over 4 @@ -661,13 +654,15 @@ This returns the op description from the global C PL_op_desc array =item sv +=item gv + =back -=head2 B::GVOP METHOD +=head2 B::PADOP METHOD =over 4 -=item gv +=item padix =back @@ -699,7 +694,7 @@ This returns the op description from the global C PL_op_desc array =item stash -=item filegv +=item file =item cop_seq @@ -751,6 +746,10 @@ Returns the SV object corresponding to the C variable C<sv_yes>. Returns the SV object corresponding to the C variable C<sv_no>. +=item amagic_generation + +Returns the SV object corresponding to the C variable C<amagic_generation>. + =item walkoptree(OP, METHOD) Does a tree-walk of the syntax tree based at OP and calls METHOD on @@ -817,11 +816,6 @@ preceding the first "::". This is used to turn "B::UNOP" into In a perl compiled for threads, this returns a list of the special per-thread threadsv variables. -=item byteload_fh(FILEHANDLE) - -Load the contents of FILEHANDLE as bytecode. See documentation for -the B<Bytecode> module in F<B::Backend> for how to generate bytecode. - =back =head1 AUTHOR diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 6610ae8..9e29855 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -7,18 +7,18 @@ * */ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "INTERN.h" #ifdef PERL_OBJECT -#undef op_name -#undef opargs -#undef op_desc -#define op_name (pPerl->Perl_get_op_names()) -#define opargs (pPerl->Perl_get_opargs()) -#define op_desc (pPerl->Perl_get_op_descs()) +#undef PL_op_name +#undef PL_opargs +#undef PL_op_desc +#define PL_op_name (get_op_names()) +#define PL_opargs (get_opargs()) +#define PL_op_desc (get_op_descs()) #endif #ifdef PerlIO @@ -53,15 +53,14 @@ typedef enum { OPc_UNOP, /* 2 */ OPc_BINOP, /* 3 */ OPc_LOGOP, /* 4 */ - OPc_CONDOP, /* 5 */ - OPc_LISTOP, /* 6 */ - OPc_PMOP, /* 7 */ - OPc_SVOP, /* 8 */ - OPc_GVOP, /* 9 */ - OPc_PVOP, /* 10 */ - OPc_CVOP, /* 11 */ - OPc_LOOP, /* 12 */ - OPc_COP /* 13 */ + OPc_LISTOP, /* 5 */ + OPc_PMOP, /* 6 */ + OPc_SVOP, /* 7 */ + OPc_PADOP, /* 8 */ + OPc_PVOP, /* 9 */ + OPc_CVOP, /* 10 */ + OPc_LOOP, /* 11 */ + OPc_COP /* 12 */ } opclass; static char *opclassnames[] = { @@ -70,11 +69,10 @@ static char *opclassnames[] = { "B::UNOP", "B::BINOP", "B::LOGOP", - "B::CONDOP", "B::LISTOP", "B::PMOP", "B::SVOP", - "B::GVOP", + "B::PADOP", "B::PVOP", "B::CVOP", "B::LOOP", @@ -83,8 +81,10 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ +static SV *specialsv_list[4]; + static opclass -cc_opclass(OP *o) +cc_opclass(pTHX_ OP *o) { if (!o) return OPc_NULL; @@ -95,7 +95,12 @@ cc_opclass(OP *o) if (o->op_type == OP_SASSIGN) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); - switch (opargs[o->op_type] & OA_CLASS_MASK) { +#ifdef USE_ITHREADS + if (o->op_type == OP_GV || o->op_type == OP_GVSV || o->op_type == OP_AELEMFAST) + return OPc_PADOP; +#endif + + switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: return OPc_BASEOP; @@ -108,9 +113,6 @@ cc_opclass(OP *o) case OA_LOGOP: return OPc_LOGOP; - case OA_CONDOP: - return OPc_CONDOP; - case OA_LISTOP: return OPc_LISTOP; @@ -120,11 +122,19 @@ cc_opclass(OP *o) case OA_SVOP: return OPc_SVOP; - case OA_GVOP: - return OPc_GVOP; + case OA_PADOP: + return OPc_PADOP; - case OA_PVOP: - return OPc_PVOP; + case OA_PVOP_OR_SVOP: + /* + * Character translations (tr///) are usually a PVOP, keeping a + * pointer to a table of shorts used to look up translations. + * Under utf8, however, a simple table isn't practical; instead, + * the OP is an SVOP, and the SV is a reference to a swash + * (i.e., an RV pointing to an HV). + */ + return (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) + ? OPc_SVOP : OPc_PVOP; case OA_LOOP: return OPc_LOOP; @@ -150,11 +160,14 @@ cc_opclass(OP *o) * return OPc_UNOP so that walkoptree can find our children. If * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set * (no argument to the operator) it's an OP; with OPf_REF set it's - * a GVOP (and op_gv is the GV for the filehandle argument). + * an SVOP (and op_sv is the GV for the filehandle argument). */ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP : - (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP); - +#ifdef USE_ITHREADS + (o->op_flags & OPf_REF) ? OPc_PADOP : OPc_BASEOP); +#else + (o->op_flags & OPf_REF) ? OPc_SVOP : OPc_BASEOP); +#endif case OA_LOOPEXOP: /* * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a @@ -173,47 +186,47 @@ cc_opclass(OP *o) return OPc_PVOP; } warn("can't determine class of operator %s, assuming BASEOP\n", - op_name[o->op_type]); + PL_op_name[o->op_type]); return OPc_BASEOP; } static char * -cc_opclassname(OP *o) +cc_opclassname(pTHX_ OP *o) { - return opclassnames[cc_opclass(o)]; + return opclassnames[cc_opclass(aTHX_ o)]; } static SV * -make_sv_object(SV *arg, SV *sv) +make_sv_object(pTHX_ SV *arg, SV *sv) { char *type = 0; IV iv; - for (iv = 0; iv < sizeof(PL_specialsv_list)/sizeof(SV*); iv++) { - if (sv == PL_specialsv_list[iv]) { + for (iv = 0; iv < sizeof(specialsv_list)/sizeof(SV*); iv++) { + if (sv == specialsv_list[iv]) { type = "B::SPECIAL"; break; } } if (!type) { type = svclassnames[SvTYPE(sv)]; - iv = (IV)sv; + iv = PTR2IV(sv); } sv_setiv(newSVrv(arg, type), iv); return arg; } static SV * -make_mg_object(SV *arg, MAGIC *mg) +make_mg_object(pTHX_ SV *arg, MAGIC *mg) { - sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg); + sv_setiv(newSVrv(arg, "B::MAGIC"), PTR2IV(mg)); return arg; } static SV * -cstring(SV *sv) +cstring(pTHX_ SV *sv) { - SV *sstr = newSVpv("", 0); + SV *sstr = newSVpvn("", 0); STRLEN len; char *s; @@ -264,9 +277,9 @@ cstring(SV *sv) } static SV * -cchar(SV *sv) +cchar(pTHX_ SV *sv) { - SV *sstr = newSVpv("'", 0); + SV *sstr = newSVpvn("'", 1); STRLEN n_a; char *s = SvPV(sv, n_a); @@ -303,76 +316,8 @@ cchar(SV *sv) return sstr; } -#ifdef INDIRECT_BGET_MACROS -void freadpv(U32 len, void *data) -{ - New(666, pv.xpv_pv, len, char); - fread(pv.xpv_pv, 1, len, (FILE*)data); - pv.xpv_len = len; - pv.xpv_cur = len - 1; -} - -void byteload_fh(InputStream fp) -{ - struct bytestream bs; - bs.data = fp; - bs.fgetc = (int(*) _((void*)))fgetc; - bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; - bs.freadpv = freadpv; - byterun(bs); -} - -static int fgetc_fromstring(void *data) -{ - char **strp = (char **)data; - return *(*strp)++; -} - -static int fread_fromstring(char *argp, size_t elemsize, size_t nelem, - void *data) -{ - char **strp = (char **)data; - size_t len = elemsize * nelem; - - memcpy(argp, *strp, len); - *strp += len; - return (int)len; -} - -static void freadpv_fromstring(U32 len, void *data) -{ - char **strp = (char **)data; - - New(666, pv.xpv_pv, len, char); - memcpy(pv.xpv_pv, *strp, len); - pv.xpv_len = len; - pv.xpv_cur = len - 1; - *strp += len; -} - -void byteload_string(char *str) -{ - struct bytestream bs; - bs.data = &str; - bs.fgetc = fgetc_fromstring; - bs.fread = fread_fromstring; - bs.freadpv = freadpv_fromstring; - byterun(bs); -} -#else -void byteload_fh(InputStream fp) -{ - byterun(fp); -} - -void byteload_string(char *str) -{ - croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string"); -} -#endif /* INDIRECT_BGET_MACROS */ - void -walkoptree(SV *opsv, char *method) +walkoptree(pTHX_ SV *opsv, char *method) { dSP; OP *o; @@ -380,7 +325,7 @@ walkoptree(SV *opsv, char *method) if (!SvROK(opsv)) croak("opsv is not a reference"); opsv = sv_mortalcopy(opsv); - o = (OP*)SvIV((SV*)SvRV(opsv)); + o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv))); if (walkoptree_debug) { PUSHMARK(sp); XPUSHs(opsv); @@ -395,8 +340,8 @@ walkoptree(SV *opsv, char *method) OP *kid; for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) { /* Use the same opsv. Rely on methods not to mess it up. */ - sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid); - walkoptree(opsv, method); + sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid)); + walkoptree(aTHX_ opsv, method); } } } @@ -405,11 +350,10 @@ typedef OP *B__OP; typedef UNOP *B__UNOP; typedef BINOP *B__BINOP; typedef LOGOP *B__LOGOP; -typedef CONDOP *B__CONDOP; typedef LISTOP *B__LISTOP; typedef PMOP *B__PMOP; typedef SVOP *B__SVOP; -typedef GVOP *B__GVOP; +typedef PADOP *B__PADOP; typedef PVOP *B__PVOP; typedef LOOP *B__LOOP; typedef COP *B__COP; @@ -435,12 +379,21 @@ MODULE = B PACKAGE = B PREFIX = B_ PROTOTYPES: DISABLE BOOT: - INIT_SPECIALSV_LIST; +{ + HV *stash = gv_stashpvn("B", 1, TRUE); + AV *export_ok = perl_get_av("B::EXPORT_OK",TRUE); + specialsv_list[0] = Nullsv; + specialsv_list[1] = &PL_sv_undef; + specialsv_list[2] = &PL_sv_yes; + specialsv_list[3] = &PL_sv_no; +#include "defsubs.h" +} #define B_main_cv() PL_main_cv #define B_init_av() PL_initav #define B_main_root() PL_main_root #define B_main_start() PL_main_start +#define B_amagic_generation() PL_amagic_generation #define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv)) #define B_sv_undef() &PL_sv_undef #define B_sv_yes() &PL_sv_yes @@ -458,6 +411,9 @@ B_main_root() B::OP B_main_start() +long +B_amagic_generation() + B::AV B_comppadlist() @@ -477,6 +433,8 @@ void walkoptree(opsv, method) SV * opsv char * method + CODE: + walkoptree(aTHX_ opsv, method); int walkoptree_debug(...) @@ -487,20 +445,7 @@ walkoptree_debug(...) OUTPUT: RETVAL -int -byteload_fh(fp) - InputStream fp - CODE: - byteload_fh(fp); - RETVAL = 1; - OUTPUT: - RETVAL - -void -byteload_string(str) - char * str - -#define address(sv) (IV)sv +#define address(sv) PTR2IV(sv) IV address(sv) @@ -514,7 +459,28 @@ svref_2object(sv) croak("argument is not a reference"); RETVAL = (SV*)SvRV(sv); OUTPUT: - RETVAL + RETVAL + +void +opnumber(name) +char * name +CODE: +{ + int i; + IV result = -1; + ST(0) = sv_newmortal(); + if (strncmp(name,"pp_",3) == 0) + name += 3; + for (i = 0; i < PL_maxo; i++) + { + if (strcmp(name, PL_op_name[i]) == 0) + { + result = i; + break; + } + } + sv_setiv(ST(0),result); +} void ppname(opnum) @@ -523,7 +489,7 @@ ppname(opnum) ST(0) = sv_newmortal(); if (opnum >= 0 && opnum < PL_maxo) { sv_setpvn(ST(0), "pp_", 3); - sv_catpv(ST(0), op_name[opnum]); + sv_catpv(ST(0), PL_op_name[opnum]); } void @@ -533,11 +499,10 @@ hash(sv) char *s; STRLEN len; U32 hash = 0; - char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */ + char hexhash[19]; /* must fit "0xffffffffffffffff" plus trailing \0 */ s = SvPV(sv, len); - while (len--) - hash = hash * 33 + *s++; - sprintf(hexhash, "0x%x", hash); + PERL_HASH(hash, s, len); + sprintf(hexhash, "0x%"UVxf, (UV)hash); ST(0) = sv_2mortal(newSVpv(hexhash, 0)); #define cast_I32(foo) (I32)foo @@ -553,10 +518,18 @@ minus_c() SV * cstring(sv) SV * sv + CODE: + RETVAL = cstring(aTHX_ sv); + OUTPUT: + RETVAL SV * cchar(sv) SV * sv + CODE: + RETVAL = cchar(aTHX_ sv); + OUTPUT: + RETVAL void threadsv_names() @@ -567,13 +540,13 @@ threadsv_names() EXTEND(sp, len); for (i = 0; i < len; i++) - PUSHs(sv_2mortal(newSVpv(&PL_threadsv_names[i], 1))); + PUSHs(sv_2mortal(newSVpvn(&PL_threadsv_names[i], 1))); #endif #define OP_next(o) o->op_next #define OP_sibling(o) o->op_sibling -#define OP_desc(o) op_desc[o->op_type] +#define OP_desc(o) PL_op_desc[o->op_type] #define OP_targ(o) o->op_targ #define OP_type(o) o->op_type #define OP_seq(o) o->op_seq @@ -591,18 +564,32 @@ OP_sibling(o) B::OP o char * -OP_ppaddr(o) +OP_name(o) B::OP o CODE: ST(0) = sv_newmortal(); - sv_setpvn(ST(0), "pp_", 3); - sv_catpv(ST(0), op_name[o->op_type]); + sv_setpv(ST(0), PL_op_name[o->op_type]); + + +char * +OP_ppaddr(o) + B::OP o + PREINIT: + int i; + SV *sv = sv_newmortal(); + CODE: + sv_setpvn(sv, "PL_ppaddr[OP_", 13); + sv_catpv(sv, PL_op_name[o->op_type]); + for (i=13; i<SvCUR(sv); ++i) + SvPVX(sv)[i] = toUPPER(SvPVX(sv)[i]); + sv_catpv(sv, "]"); + ST(0) = sv; char * OP_desc(o) B::OP o -U16 +PADOFFSET OP_targ(o) B::OP o @@ -646,19 +633,6 @@ B::OP LOGOP_other(o) B::LOGOP o -#define CONDOP_true(o) o->op_true -#define CONDOP_false(o) o->op_false - -MODULE = B PACKAGE = B::CONDOP PREFIX = CONDOP_ - -B::OP -CONDOP_true(o) - B::CONDOP o - -B::OP -CONDOP_false(o) - B::CONDOP o - #define LISTOP_children(o) o->op_children MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ @@ -687,10 +661,10 @@ PMOP_pmreplroot(o) if (o->op_type == OP_PUSHRE) { sv_setiv(newSVrv(ST(0), root ? svclassnames[SvTYPE((SV*)root)] : "B::SV"), - (IV)root); + PTR2IV(root)); } else { - sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root); + sv_setiv(newSVrv(ST(0), cc_opclassname(aTHX_ root)), PTR2IV(root)); } B::OP @@ -719,23 +693,38 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) o->op_sv +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ - B::SV SVOP_sv(o) B::SVOP o -#define GVOP_gv(o) o->op_gv +B::GV +SVOP_gv(o) + B::SVOP o + +#define PADOP_padix(o) o->op_padix +#define PADOP_sv(o) (o->op_padix ? PL_curpad[o->op_padix] : Nullsv) +#define PADOP_gv(o) ((o->op_padix \ + && SvTYPE(PL_curpad[o->op_padix]) == SVt_PVGV) \ + ? (GV*)PL_curpad[o->op_padix] : Nullgv) + +MODULE = B PACKAGE = B::PADOP PREFIX = PADOP_ -MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_ +PADOFFSET +PADOP_padix(o) + B::PADOP o +B::SV +PADOP_sv(o) + B::PADOP o B::GV -GVOP_gv(o) - B::GVOP o +PADOP_gv(o) + B::PADOP o MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_ @@ -770,11 +759,13 @@ LOOP_lastop(o) B::LOOP o #define COP_label(o) o->cop_label -#define COP_stash(o) o->cop_stash -#define COP_filegv(o) o->cop_filegv +#define COP_stashpv(o) CopSTASHPV(o) +#define COP_stash(o) CopSTASH(o) +#define COP_file(o) CopFILE(o) #define COP_cop_seq(o) o->cop_seq #define COP_arybase(o) o->cop_arybase -#define COP_line(o) o->cop_line +#define COP_line(o) CopLINE(o) +#define COP_warnings(o) o->cop_warnings MODULE = B PACKAGE = B::COP PREFIX = COP_ @@ -782,12 +773,16 @@ char * COP_label(o) B::COP o +char * +COP_stashpv(o) + B::COP o + B::HV COP_stash(o) B::COP o -B::GV -COP_filegv(o) +char * +COP_file(o) B::COP o U32 @@ -802,6 +797,10 @@ U16 COP_line(o) B::COP o +B::SV +COP_warnings(o) + B::COP o + MODULE = B PACKAGE = B::SV PREFIX = Sv U32 @@ -822,6 +821,11 @@ IV SvIVX(sv) B::IV sv +UV +SvUVX(sv) + B::IV sv + + MODULE = B PACKAGE = B::IV #define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv)) @@ -844,12 +848,16 @@ packiv(sv) * reach this code anyway (unless sizeof(IV) > 8 but then * everything else breaks too so I'm not fussed at the moment). */ - wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4)); +#ifdef UV_IS_QUAD + wp[0] = htonl(((UV)iv) >> (sizeof(UV)*4)); +#else + wp[0] = htonl(((U32)iv) >> (sizeof(UV)*4)); +#endif wp[1] = htonl(iv & 0xffffffff); - ST(0) = sv_2mortal(newSVpv((char *)wp, 8)); + ST(0) = sv_2mortal(newSVpvn((char *)wp, 8)); } else { U32 w = htonl((U32)SvIVX(sv)); - ST(0) = sv_2mortal(newSVpv((char *)&w, 4)); + ST(0) = sv_2mortal(newSVpvn((char *)&w, 4)); } MODULE = B PACKAGE = B::NV PREFIX = Sv @@ -877,6 +885,14 @@ SvPV(sv) ST(0) = sv_newmortal(); sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv)); +STRLEN +SvLEN(sv) + B::PV sv + +STRLEN +SvCUR(sv) + B::PV sv + MODULE = B PACKAGE = B::PVMG PREFIX = Sv void @@ -885,7 +901,7 @@ SvMAGIC(sv) MAGIC * mg = NO_INIT PPCODE: for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) - XPUSHs(make_mg_object(sv_newmortal(), mg)); + XPUSHs(make_mg_object(aTHX_ sv_newmortal(), mg)); MODULE = B PACKAGE = B::PVMG @@ -898,6 +914,7 @@ SvSTASH(sv) #define MgTYPE(mg) mg->mg_type #define MgFLAGS(mg) mg->mg_flags #define MgOBJ(mg) mg->mg_obj +#define MgLENGTH(mg) mg->mg_len MODULE = B PACKAGE = B::MAGIC PREFIX = Mg @@ -921,13 +938,23 @@ B::SV MgOBJ(mg) B::MAGIC mg +I32 +MgLENGTH(mg) + B::MAGIC mg + void MgPTR(mg) B::MAGIC mg CODE: ST(0) = sv_newmortal(); - if (mg->mg_ptr) - sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); + if (mg->mg_ptr){ + if (mg->mg_len >= 0){ + sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len); + } else { + if (mg->mg_len == HEf_SVKEY) + sv_setsv(ST(0),newRV((SV*)mg->mg_ptr)); + } + } MODULE = B PACKAGE = B::PVLV PREFIX = Lv @@ -969,7 +996,7 @@ BmTABLE(sv) CODE: str = SvPV(sv, len); /* Boyer-Moore table is just after string and its safety-margin \0 */ - ST(0) = sv_2mortal(newSVpv(str + len + 1, 256)); + ST(0) = sv_2mortal(newSVpvn(str + len + 1, 256)); MODULE = B PACKAGE = B::GV PREFIX = Gv @@ -977,7 +1004,15 @@ void GvNAME(gv) B::GV gv CODE: - ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv))); + ST(0) = sv_2mortal(newSVpvn(GvNAME(gv), GvNAMELEN(gv))); + +bool +is_empty(gv) + B::GV gv + CODE: + RETVAL = GvGP(gv) == Null(GP*); + OUTPUT: + RETVAL B::HV GvSTASH(gv) @@ -1019,6 +1054,10 @@ U16 GvLINE(gv) B::GV gv +char * +GvFILE(gv) + B::GV gv + B::GV GvFILEGV(gv) B::GV gv @@ -1113,7 +1152,7 @@ AvARRAY(av) SV **svp = AvARRAY(av); I32 i; for (i = 0; i <= AvFILL(av); i++) - XPUSHs(make_sv_object(sv_newmortal(), svp[i])); + XPUSHs(make_sv_object(aTHX_ sv_newmortal(), svp[i])); } MODULE = B PACKAGE = B::AV @@ -1140,8 +1179,8 @@ B::GV CvGV(cv) B::CV cv -B::GV -CvFILEGV(cv) +char * +CvFILE(cv) B::CV cv long @@ -1160,7 +1199,7 @@ void CvXSUB(cv) B::CV cv CODE: - ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv))); + ST(0) = sv_2mortal(newSViv(PTR2IV(CvXSUB(cv)))); void @@ -1213,7 +1252,7 @@ HvARRAY(hv) (void)hv_iterinit(hv); EXTEND(sp, HvKEYS(hv) * 2); while (sv = hv_iternextsv(hv, &key, &len)) { - PUSHs(newSVpv(key, len)); - PUSHs(make_sv_object(sv_newmortal(), sv)); + PUSHs(newSVpvn(key, len)); + PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } } diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm index f3e57a1..bc0eda9 100644 --- a/contrib/perl5/ext/B/B/Asmdata.pm +++ b/contrib/perl5/ext/B/B/Asmdata.pm @@ -1,5 +1,5 @@ # -# Copyright (c) 1996-1998 Malcolm Beattie +# Copyright (c) 1996-1999 Malcolm Beattie # # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. @@ -12,9 +12,9 @@ package B::Asmdata; use Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); -use vars qw(%insn_data @insn_name @optype @specialsv_name); +our(%insn_data, @insn_name, @optype, @specialsv_name); -@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP); +@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); @specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); # XXX insn_data is initialised this way because with a large @@ -42,7 +42,7 @@ $insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"]; $insn_data{xpv} = [18, \&PUT_none, "GET_none"]; $insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"]; $insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [21, \&PUT_double, "GET_double"]; +$insn_data{xnv} = [21, \&PUT_NV, "GET_NV"]; $insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"]; $insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"]; $insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"]; @@ -68,11 +68,11 @@ $insn_data{xcv_stash} = [44, \&PUT_svindex, "GET_svindex"]; $insn_data{xcv_start} = [45, \&PUT_opindex, "GET_opindex"]; $insn_data{xcv_root} = [46, \&PUT_opindex, "GET_opindex"]; $insn_data{xcv_gv} = [47, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_filegv} = [48, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_file} = [48, \&PUT_pvcontents, "GET_pvcontents"]; $insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"]; $insn_data{xcv_padlist} = [50, \&PUT_svindex, "GET_svindex"]; $insn_data{xcv_outside} = [51, \&PUT_svindex, "GET_svindex"]; -$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"]; +$insn_data{xcv_flags} = [52, \&PUT_U16, "GET_U16"]; $insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"]; $insn_data{av_push} = [54, \&PUT_svindex, "GET_svindex"]; $insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"]; @@ -95,7 +95,7 @@ $insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"]; $insn_data{gp_av} = [72, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_hv} = [73, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_cv} = [74, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_filegv} = [75, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_file} = [75, \&PUT_pvcontents, "GET_pvcontents"]; $insn_data{gp_io} = [76, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_form} = [77, \&PUT_svindex, "GET_svindex"]; $insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"]; @@ -113,32 +113,31 @@ $insn_data{op_private} = [89, \&PUT_U8, "GET_U8"]; $insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"]; $insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"]; $insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_true} = [93, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_false} = [94, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"]; -$insn_data{op_pmreplroot} = [96, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplrootgv} = [97, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplstart} = [98, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [99, \&PUT_opindex, "GET_opindex"]; -$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"]; -$insn_data{op_sv} = [103, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_gv} = [104, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [108, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [109, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{cop_stash} = [111, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"]; -$insn_data{main_start} = [116, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [117, \&PUT_opindex, "GET_opindex"]; -$insn_data{curpad} = [118, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_children} = [93, \&PUT_U32, "GET_U32"]; +$insn_data{op_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmnext} = [97, \&PUT_opindex, "GET_opindex"]; +$insn_data{pregcomp} = [98, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pmflags} = [99, \&PUT_U16, "GET_U16"]; +$insn_data{op_pmpermflags} = [100, \&PUT_U16, "GET_U16"]; +$insn_data{op_sv} = [101, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_padix} = [102, \&PUT_U32, "GET_U32"]; +$insn_data{op_pv} = [103, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pv_tr} = [104, \&PUT_op_tr_array, "GET_op_tr_array"]; +$insn_data{op_redoop} = [105, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_nextop} = [106, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_lastop} = [107, \&PUT_opindex, "GET_opindex"]; +$insn_data{cop_label} = [108, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_stashpv} = [109, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_file} = [110, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_seq} = [111, \&PUT_U32, "GET_U32"]; +$insn_data{cop_arybase} = [112, \&PUT_I32, "GET_I32"]; +$insn_data{cop_line} = [113, \&PUT_U16, "GET_U16"]; +$insn_data{cop_warnings} = [114, \&PUT_svindex, "GET_svindex"]; +$insn_data{main_start} = [115, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_root} = [116, \&PUT_opindex, "GET_opindex"]; +$insn_data{curpad} = [117, \&PUT_svindex, "GET_svindex"]; my ($insn_name, $insn_data); while (($insn_name, $insn_data) = each %insn_data) { diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm index 06e00ad..6c51a9a 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -52,6 +52,7 @@ sub B::Asmdata::PUT_U8 { sub B::Asmdata::PUT_U16 { pack("n", $_[0]) } sub B::Asmdata::PUT_U32 { pack("N", $_[0]) } sub B::Asmdata::PUT_I32 { pack("N", $_[0]) } +sub B::Asmdata::PUT_NV { sprintf("%lf\0", $_[0]) } sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } diff --git a/contrib/perl5/ext/B/B/Bblock.pm b/contrib/perl5/ext/B/B/Bblock.pm index a54431b..fe7fc52 100644 --- a/contrib/perl5/ext/B/B/Bblock.pm +++ b/contrib/perl5/ext/B/B/Bblock.pm @@ -4,7 +4,9 @@ use Exporter (); @EXPORT_OK = qw(find_leaders); use B qw(peekop walkoptree walkoptree_exec - main_root main_start svref_2object); + main_root main_start svref_2object + OPf_SPECIAL OPf_STACKED ); + use B::Terse; use strict; @@ -18,11 +20,18 @@ sub mark_leader { } } +sub remove_sortblock{ + foreach (keys %$bblock){ + my $leader=$$bblock{$_}; + delete $$bblock{$_} if( $leader == 0); + } +} sub find_leaders { my ($root, $start) = @_; $bblock = {}; - mark_leader($start); - walkoptree($root, "mark_if_leader"); + mark_leader($start) if ( ref $start ne "B::NULL" ); + walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; + remove_sortblock(); return $bblock; } @@ -81,25 +90,32 @@ sub B::LOOP::mark_if_leader { sub B::LOGOP::mark_if_leader { my $op = shift; - my $ppaddr = $op->ppaddr; + my $opname = $op->name; mark_leader($op->next); - if ($ppaddr eq "pp_entertry") { + if ($opname eq "entertry") { mark_leader($op->other->next); } else { mark_leader($op->other); } } -sub B::CONDOP::mark_if_leader { +sub B::LISTOP::mark_if_leader { my $op = shift; + my $first=$op->first; + $first=$first->next while ($first->name eq "null"); + mark_leader($op->first) unless (exists( $bblock->{$$first})); mark_leader($op->next); - mark_leader($op->true); - mark_leader($op->false); + if ($op->name eq "sort" and $op->flags & OPf_SPECIAL + and $op->flags & OPf_STACKED){ + my $root=$op->first->sibling->first; + my $leader=$root->first; + $bblock->{$$leader} = 0; + } } sub B::PMOP::mark_if_leader { my $op = shift; - if ($op->ppaddr ne "pp_pushre") { + if ($op->name ne "pushre") { my $replroot = $op->pmreplroot; if ($$replroot) { mark_leader($replroot); @@ -113,6 +129,7 @@ sub B::PMOP::mark_if_leader { sub compile { my @options = @_; + B::clearsym(); if (@options) { return sub { my $objname; @@ -134,7 +151,6 @@ sub compile { # The ops pointed at by nextop, redoop and lastop->op_next of a LOOP # The ops pointed at by op_next and op_other of a LOGOP, except # for pp_entertry which has op_next and op_other->op_next -# The ops pointed at by op_true and op_false of a CONDOP # The op pointed at by op_pmreplstart of a PMOP # The op pointed at by op_other->op_pmreplstart of pp_substcont? # [The op after a pp_return] Omit @@ -153,7 +169,9 @@ B::Bblock - Walk basic blocks =head1 DESCRIPTION -See F<ext/B/README>. +This module is used by the B::CC back end. It walks "basic blocks". +A basic block is a series of operations which is known to execute from +start to finish, with no possiblity of branching or halting. =head1 AUTHOR diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm index 0c5a58d..27003b6 100644 --- a/contrib/perl5/ext/B/B/Bytecode.pm +++ b/contrib/perl5/ext/B/B/Bytecode.pm @@ -11,7 +11,9 @@ use Carp; use IO::File; use B qw(minus_c main_cv main_root main_start comppadlist - class peekop walkoptree svref_2object cstring walksymtable); + class peekop walkoptree svref_2object cstring walksymtable + SVf_POK SVp_POK SVf_IOK SVp_IOK + ); use B::Asmdata qw(@optype @specialsv_name); use B::Assembler qw(assemble_fh); @@ -23,11 +25,11 @@ for ($i = 0; $i < @optype; $i++) { # Following is SVf_POK|SVp_POK # XXX Shouldn't be hardwired -sub POK () { 0x04040000 } +sub POK () { SVf_POK|SVp_POK } -# Following is SVf_IOK|SVp_OK +# Following is SVf_IOK|SVp_IOK # XXX Shouldn't be hardwired -sub IOK () { 0x01010000 } +sub IOK () { SVf_IOK|SVp_IOK } my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); my $assembler_pid; @@ -191,7 +193,7 @@ sub B::OP::bytecode { ldop($ix); print "op_next $nextix\n"; print "op_sibling $sibix\n" unless $strip_syntree; - printf "op_type %s\t# %d\n", $op->ppaddr, $type; + printf "op_type %s\t# %d\n", "pp_" . $op->name, $type; printf("op_seq %d\n", $op->seq) unless $omit_seq; if ($type || !$compress_nullops) { printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", @@ -224,13 +226,11 @@ sub B::SVOP::bytecode { $sv->bytecode; } -sub B::GVOP::bytecode { +sub B::PADOP::bytecode { my $op = shift; - my $gv = $op->gv; - my $gvix = $gv->objix; + my $padix = $op->padix; $op->B::OP::bytecode; - print "op_gv $gvix\n"; - $gv->bytecode; + print "op_padix $padix\n"; } sub B::PVOP::bytecode { @@ -241,7 +241,7 @@ sub B::PVOP::bytecode { # This would be easy except that OP_TRANS uses a PVOP to store an # endian-dependent array of 256 shorts instead of a plain string. # - if ($op->ppaddr eq "pp_trans") { + if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness print "op_pv_tr ", join(",", @shorts), "\n"; } else { @@ -258,14 +258,6 @@ sub B::BINOP::bytecode { } } -sub B::CONDOP::bytecode { - my $op = shift; - my $trueix = $op->true->objix; - my $falseix = $op->false->objix; - $op->B::UNOP::bytecode; - print "op_true $trueix\nop_false $falseix\n"; -} - sub B::LISTOP::bytecode { my $op = shift; my $children = $op->children; @@ -286,26 +278,27 @@ sub B::LOOP::bytecode { sub B::COP::bytecode { my $op = shift; - my $stash = $op->stash; - my $stashix = $stash->objix; - my $filegv = $op->filegv; - my $filegvix = $filegv->objix; + my $stashpv = $op->stashpv; + my $file = $op->file; my $line = $op->line; + my $warnings = $op->warnings; + my $warningsix = $warnings->objix; if ($debug_bc) { - printf "# line %s:%d\n", $filegv->SV->PV, $line; + printf "# line %s:%d\n", $file, $line; } $op->B::OP::bytecode; - printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase; + printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; newpv %s cop_label -cop_stash $stashix +newpv %s +cop_stashpv cop_seq %d -cop_filegv $filegvix +newpv %s +cop_file cop_arybase %d cop_line $line +cop_warnings $warningsix EOT - $filegv->bytecode; - $stash->bytecode; } sub B::PMOP::bytecode { @@ -313,7 +306,7 @@ sub B::PMOP::bytecode { my $replroot = $op->pmreplroot; my $replrootix = $replroot->objix; my $replstartix = $op->pmreplstart->objix; - my $ppaddr = $op->ppaddr; + my $opname = $op->name; # pmnext is corrupt in some PMOPs (see misc.t for example) #my $pmnextix = $op->pmnext->objix; @@ -321,14 +314,14 @@ sub B::PMOP::bytecode { # OP_PUSHRE (a mutated version of OP_MATCH for the regexp # argument to a split) stores a GV in op_pmreplroot instead # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { + if ($opname eq "pushre") { $replroot->bytecode; } else { walkoptree($replroot, "bytecode"); } } $op->B::LISTOP::bytecode; - if ($ppaddr eq "pp_pushre") { + if ($opname eq "pushre") { printf "op_pmreplrootgv $replrootix\n"; } else { print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; @@ -395,7 +388,8 @@ sub B::PVIV::bytecode { } sub B::PVNV::bytecode { - my ($sv, $flag) = @_; + my $sv = shift; + my $flag = shift || 0; # The $flag argument is passed through PVMG::bytecode by BM::bytecode # and AV::bytecode and indicates special handling. $flag = 1 is used by # BM::bytecode and means that we should ensure we save the whole B-M @@ -469,18 +463,23 @@ sub B::GV::bytecode { return if saved($gv); my $ix = $gv->objix; mark_saved($gv); - my $gvname = $gv->NAME; - my $name = cstring($gv->STASH->NAME . "::" . $gvname); - my $egv = $gv->EGV; - my $egvix = $egv->objix; ldsv($ix); - printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE; + printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; sv_flags 0x%x xgv_flags 0x%x -gp_line %d EOT my $refcnt = $gv->REFCNT; printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + return if $gv->is_empty; + printf <<"EOT", $gv->LINE, pvstring($gv->FILE); +gp_line %d +newpv %s +gp_file +EOT + my $gvname = $gv->NAME; + my $name = cstring($gv->STASH->NAME . "::" . $gvname); + my $egv = $gv->EGV; + my $egvix = $egv->objix; my $gvrefcnt = $gv->GvREFCNT; printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; if ($gvrefcnt > 1 && $ix != $egvix) { @@ -488,7 +487,7 @@ EOT } else { if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { my $i; - my @subfield_names = qw(SV AV HV CV FILEGV FORM IO); + my @subfield_names = qw(SV AV HV CV FORM IO); my @subfields = map($gv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Reset sv register for $gv @@ -571,7 +570,7 @@ sub B::CV::bytecode { my $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; - my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE); + my @subfield_names = qw(ROOT START STASH GV PADLIST OUTSIDE); my @subfields = map($cv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Save OP tree from CvROOT (first element of @subfields) @@ -584,7 +583,8 @@ sub B::CV::bytecode { for ($i = 0; $i < @ixes; $i++) { printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS; + printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; + printf "newpv %s\nxcv_file\n", pvstring($cv->FILE); # Now save all the subfields (except for CvROOT which was handled # above) and CvSTART (now the initial element of @subfields). shift @subfields; # bye-bye CvSTART @@ -653,7 +653,7 @@ sub bytecompile_main { walkoptree(main_root, "bytecode"); warn "done main program, now walking symbol table\n" if $debug_bc; my ($pack, %exclude); - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars + foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol SelectSaver blib Cwd)) { @@ -707,6 +707,10 @@ sub compile { $arg ||= shift @options; open(OUT, ">$arg") or return "$arg: $!\n"; binmode OUT; + } elsif ($opt eq "a") { + $arg ||= shift @options; + open(OUT, ">>$arg") or return "$arg: $!\n"; + binmode OUT; } elsif ($opt eq "D") { $arg ||= shift @options; foreach $arg (split(//, $arg)) { @@ -816,6 +820,10 @@ extra arguments, it saves the main program. Output to filename instead of STDOUT. +=item B<-afilename> + +Append output to filename. + =item B<--> Force end of options. @@ -889,13 +897,16 @@ C<main_root> and C<curpad> are omitted. =head1 EXAMPLES - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + + perl -MO=Bytecode,-S foo.pl > foo.S + assemble foo.S > foo.plc - perl -MO=Bytecode,-S foo.pl > foo.S - assemble foo.S > foo.plc - byteperl foo.plc +Note that C<assemble> lives in the C<B> subdirectory of your perl +library directory. The utility called perlcc may also be used to +help make use of this compiler. - perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm + perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm =head1 BUGS diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index e695cc2..d0c8159 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -5,34 +5,75 @@ # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. # +package B::C::Section; +use B (); +use base B::Section; + +sub new +{ + my $class = shift; + my $o = $class->SUPER::new(@_); + push(@$o,[]); + return $o; +} + +sub add +{ + my $section = shift; + push(@{$section->[-1]},@_); +} + +sub index +{ + my $section = shift; + return scalar(@{$section->[-1]})-1; +} + +sub output +{ + my ($section, $fh, $format) = @_; + my $sym = $section->symtable || {}; + my $default = $section->default; + foreach (@{$section->[-1]}) + { + s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; + printf $fh $format, $_; + } +} + package B::C; use Exporter (); @ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main - init_sections set_callback save_unused_subs objsym); +@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused + init_sections set_callback save_unused_subs objsym save_context); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av); + threadsv_names main_cv init_av opnumber amagic_generation + AVf_REAL HEf_SVKEY); use B::Asmdata qw(@specialsv_name); use FileHandle; use Carp; use strict; +use Config; my $hv_index = 0; my $gv_index = 0; my $re_index = 0; my $pv_index = 0; my $anonsub_index = 0; +my $initsub_index = 0; my %symtable; +my %xsub; my $warn_undefined_syms; my $verbose; -my @unused_sub_packages; +my %unused_sub_packages; my $nullop_count; -my $pv_copy_on_grow; +my $pv_copy_on_grow = 0; my ($debug_cops, $debug_av, $debug_cv, $debug_mg); +my $max_string_len; my @threadsv_names; BEGIN { @@ -40,11 +81,11 @@ BEGIN { } # Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, - $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, +my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, + $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, - $xrvsect, $xpvbmsect, $xpviosect, $bootstrap); + $xrvsect, $xpvbmsect, $xpviosect ); sub walk_and_save_optree; my $saveoptree_callback = \&walk_and_save_optree; @@ -66,11 +107,9 @@ sub walk_and_save_optree { # to "know" that op_seq is a U16 and use 65535. Ugh. my $op_seq = 65535; -sub AVf_REAL () { 1 } - -# XXX This shouldn't really be hardcoded here but it saves -# looking up the name of every BASEOP in B::OP -sub OP_THREADSV () { 345 } +# Look this up here so we can do just a number compare +# rather than looking up the name of every BASEOP in B::OP +my $OP_THREADSV = opnumber('threadsv'); sub savesym { my ($obj, $value) = @_; @@ -98,10 +137,11 @@ sub getsym { } sub savepv { - my $pv = shift; + my $pv = shift; + $pv = '' unless defined $pv; # Is this sane ? my $pvsym = 0; my $pvmax = 0; - if ($pv_copy_on_grow) { + if ($pv_copy_on_grow) { my $cstring = cstring($pv); if ($cstring ne "0") { # sic $pvsym = sprintf("pv%d", $pv_index++); @@ -115,17 +155,21 @@ sub savepv { sub B::OP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $type = $op->type; $nullop_count++ unless $type; - if ($type == OP_THREADSV) { + if ($type == $OP_THREADSV) { # saves looking up ppaddr but it's a bit naughty to hard code this $init->add(sprintf("(void)find_threadsv(%s);", cstring($threadsv_names[$op->targ]))); } - $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, + $opsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x", + ${$op->next}, ${$op->sibling}, $op->targ, $type, $op_seq, $op->flags, $op->private)); - savesym($op, sprintf("&op_list[%d]", $opsect->index)); + my $ix = $opsect->index; + $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "&op_list[$ix]"); } sub B::FAKEOP::new { @@ -135,10 +179,12 @@ sub B::FAKEOP::new { sub B::FAKEOP::save { my ($op, $level) = @_; - $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x", - $op->next, $op->sibling, $op->ppaddr, $op->targ, + $opsect->add(sprintf("%s, %s, NULL, %u, %u, %u, 0x%x, 0x%x", + $op->next, $op->sibling, $op->targ, $op->type, $op_seq, $op->flags, $op->private)); - return sprintf("&op_list[%d]", $opsect->index); + my $ix = $opsect->index; + $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + return "&op_list[$ix]"; } sub B::FAKEOP::next { $_[0]->{"next"} || 0 } @@ -151,114 +197,139 @@ sub B::FAKEOP::private { $_[0]->{private} || 0 } sub B::UNOP::save { my ($op, $level) = @_; - $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $unopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first})); - savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index)); + my $ix = $unopsect->index; + $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&unop_list[$ix]"); } sub B::BINOP::save { my ($op, $level) = @_; - $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $binopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last})); - savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index)); + my $ix = $binopsect->index; + $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&binop_list[$ix]"); } sub B::LISTOP::save { my ($op, $level) = @_; - $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $listopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children)); - savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index)); + my $ix = $listopsect->index; + $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&listop_list[$ix]"); } sub B::LOGOP::save { my ($op, $level) = @_; - $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $logopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->other})); - savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index)); -} - -sub B::CONDOP::save { - my ($op, $level) = @_; - $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, - $op->targ, $op->type, $op_seq, $op->flags, - $op->private, ${$op->first}, ${$op->true}, - ${$op->false})); - savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index)); + my $ix = $logopsect->index; + $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&logop_list[$ix]"); } sub B::LOOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", # peekop($op->redoop), peekop($op->nextop), # peekop($op->lastop)); # debug - $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children, ${$op->redoop}, ${$op->nextop}, ${$op->lastop})); - savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index)); + my $ix = $loopsect->index; + $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&loop_list[$ix]"); } sub B::PVOP::save { my ($op, $level) = @_; - $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $pvopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, cstring($op->pv))); - savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index)); + my $ix = $pvopsect->index; + $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + savesym($op, "(OP*)&pvop_list[$ix]"); } sub B::SVOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $svsym = $op->sv->save; - $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + $svopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, Nullsv", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, - $op->private, "(SV*)$svsym")); - savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index)); + $op->private)); + my $ix = $svopsect->index; + $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + $init->add("svop_list[$ix].op_sv = (SV*)$svsym;"); + savesym($op, "(OP*)&svop_list[$ix]"); } -sub B::GVOP::save { +sub B::PADOP::save { my ($op, $level) = @_; - my $gvsym = $op->gv->save; - $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + my $sym = objsym($op); + return $sym if defined $sym; + $padopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, 0", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private)); - $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym)); - savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index)); + $init->add(sprintf("padop_list[%d].op_ppaddr = %s;", $padopsect->index, $op->ppaddr)); + my $ix = $padopsect->index; + $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); + savesym($op, "(OP*)&padop_list[$ix]"); } sub B::COP::save { my ($op, $level) = @_; - my $gvsym = $op->filegv->save; - my $stashsym = $op->stash->save; - warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV) + my $sym = objsym($op); + return $sym if defined $sym; + warn sprintf("COP: line %d file %s\n", $op->line, $op->file) if $debug_cops; - $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u", - ${$op->next}, ${$op->sibling}, $op->ppaddr, + $copsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, cstring($op->label), $op->cop_seq, $op->arybase, $op->line)); - my $copix = $copsect->index; - $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym), - sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym)); - savesym($op, "(OP*)&cop_list[$copix]"); + my $ix = $copsect->index; + $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); + $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)), + sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv))); + savesym($op, "(OP*)&cop_list[$ix]"); } sub B::PMOP::save { my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; my $replroot = $op->pmreplroot; my $replstart = $op->pmreplstart; my $replrootfield = sprintf("s\\_%x", $$replroot); @@ -269,7 +340,7 @@ sub B::PMOP::save { # OP_PUSHRE (a mutated version of OP_MATCH for the regexp # argument to a split) stores a GV in op_pmreplroot instead # of a substitution syntax tree. We don't want to walk that... - if ($ppaddr eq "pp_pushre") { + if ($op->name eq "pushre") { $gvsym = $replroot->save; # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug $replrootfield = 0; @@ -280,13 +351,14 @@ sub B::PMOP::save { # pmnext handling is broken in perl itself, I think. Bad op_pmnext # fields aren't noticed in perl's runtime (unless you try reset) but we # segfault when trying to dereference it to find op->op_pmnext->op_type - $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", - ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ, + $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + ${$op->next}, ${$op->sibling}, $op->targ, $op->type, $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last}, $op->children, $replrootfield, $replstartfield, $op->pmflags, $op->pmpermflags,)); my $pm = sprintf("pmop_list[%d]", $pmopsect->index); + $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr)); my $re = $op->precomp; if (defined($re)) { my $resym = sprintf("re%d", $re_index++); @@ -297,7 +369,7 @@ sub B::PMOP::save { if ($gvsym) { $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); } - savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index)); + savesym($op, "(OP*)&$pm"); } sub B::SPECIAL::save { @@ -319,10 +391,11 @@ sub B::NULL::save { return $sym if defined $sym; # warn "Saving SVt_NULL SV\n"; # debug # debug - #if ($$sv == 0) { - # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; - #} - $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS)); + if ($$sv == 0) { + warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; + return savesym($sv, "Nullsv /* XXX */"); + } + $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -332,7 +405,7 @@ sub B::IV::save { return $sym if defined $sym; $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -340,12 +413,35 @@ sub B::NV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX)); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; + $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } +sub savepvn { + my ($dest,$pv) = @_; + my @res; + if (defined $max_string_len && length($pv) > $max_string_len) { + push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1); + my $offset = 0; + while (length $pv) { + my $str = substr $pv, 0, $max_string_len, ''; + push @res, sprintf("Copy(%s,$dest+$offset,%u,char);", + cstring($str), length($str)); + $offset += length $str; + } + push @res, sprintf("%s[%u] = '\\0';", $dest, $offset); + } + else { + push @res, sprintf("%s = savepvn(%s, %u);", $dest, + cstring($pv), length($pv)); + } + return @res; +} + sub B::PVLV::save { my ($sv) = @_; my $sym = objsym($sv); @@ -358,10 +454,10 @@ sub B::PVLV::save { $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", - $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvlvsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv", + $xpvlvsect->index), $pv)); } $sv->save_magic; return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); @@ -376,10 +472,10 @@ sub B::PVIV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX)); $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", - $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvivsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv", + $xpvivsect->index), $pv)); } return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -388,16 +484,19 @@ sub B::PVNV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - my $pv = $sv->PV; + my $pv = $sv->PV; + $pv = '' unless defined $pv; my $len = length($pv); my ($pvsym, $pvmax) = savepv($pv); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", - $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); + $pvsym, $len, $pvmax, $sv->IVX, $val)); $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", - $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);", - $xpvnvsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv", + $xpvnvsect->index), $pv)); } return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -412,10 +511,10 @@ sub B::BM::save { $len, $len + 258, $sv->IVX, $sv->NVX, $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", - $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); $sv->save_magic; - $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvbmsect->index, cstring($pv), $len), + $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv", + $xpvbmsect->index), $pv), sprintf("xpvbm_list[%d].xpv_cur = %u;", $xpvbmsect->index, $len - 257)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); @@ -430,10 +529,10 @@ sub B::PV::save { my ($pvsym, $pvmax) = savepv($pv); $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax)); $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", - $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv", + $xpvsect->index), $pv)); } return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -448,10 +547,10 @@ sub B::PVMG::save { $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX)); $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", - $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); if (!$pv_copy_on_grow) { - $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);", - $xpvmgsect->index, cstring($pv), $len)); + $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv", + $xpvmgsect->index), $pv)); } $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); $sv->save_magic; @@ -462,6 +561,7 @@ sub B::PVMG::save_magic { my ($sv) = @_; #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug my $stash = $sv->SvSTASH; + $stash->save; if ($$stash) { warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) if $debug_mg; @@ -469,19 +569,27 @@ sub B::PVMG::save_magic { $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); } my @mgchain = $sv->MAGIC; - my ($mg, $type, $obj, $ptr); + my ($mg, $type, $obj, $ptr,$len,$ptrsv); foreach $mg (@mgchain) { $type = $mg->TYPE; $obj = $mg->OBJ; $ptr = $mg->PTR; - my $len = defined($ptr) ? length($ptr) : 0; + $len=$mg->LENGTH; if ($debug_mg) { warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", class($sv), $$sv, class($obj), $$obj, cchar($type), cstring($ptr)); } - $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", + $obj->save; + if ($len == HEf_SVKEY){ + #The pointer is an SV* + $ptrsv=svref_2object($ptr)->save; + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", + $$sv, $$obj, cchar($type),$ptrsv,$len)); + }else{ + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", $$sv, $$obj, cchar($type),cstring($ptr),$len)); + } } } @@ -489,9 +597,11 @@ sub B::RV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xrvsect->add($sv->RV->save); + my $rv = $sv->RV->save; + $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/; + $xrvsect->add($rv); $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", - $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); + $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); } @@ -516,7 +626,7 @@ sub try_autoload { } } } - +sub Dummy_initxs{}; sub B::CV::save { my ($cv) = @_; my $sym = objsym($cv); @@ -525,18 +635,43 @@ sub B::CV::save { return $sym; } # Reserve a place in svsect and xpvcvsect and record indices + my $gv = $cv->GV; + my ($cvname, $cvstashname); + if ($$gv){ + $cvname = $gv->NAME; + $cvstashname = $gv->STASH->NAME; + } + my $root = $cv->ROOT; + my $cvxsub = $cv->XSUB; + #INIT is removed from the symbol table, so this call must come + # from PL_initav->save. Re-bootstrapping will push INIT back in + # so nullop should be sent. + if ($cvxsub && ($cvname ne "INIT")) { + my $egv = $gv->EGV; + my $stashname = $egv->STASH->NAME; + if ($cvname eq "bootstrap") + { + my $file = $gv->FILE; + $decl->add("/* bootstrap $file */"); + warn "Bootstrap $stashname $file\n"; + $xsub{$stashname}='Dynamic'; + # $xsub{$stashname}='Static' unless $xsub{$stashname}; + return qq/NULL/; + } + warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv; + return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/; + } + if ($cvxsub && $cvname eq "INIT") { + no strict 'refs'; + return svref_2object(\&Dummy_initxs)->save; + } my $sv_ix = $svsect->index + 1; $svsect->add("svix$sv_ix"); my $xpvcv_ix = $xpvcvsect->index + 1; $xpvcvsect->add("xpvcvix$xpvcv_ix"); # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() $sym = savesym($cv, "&sv_list[$sv_ix]"); - warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv; - my $gv = $cv->GV; - my $cvstashname = $gv->STASH->NAME; - my $cvname = $gv->NAME; - my $root = $cv->ROOT; - my $cvxsub = $cv->XSUB; + warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv; if (!$$root && !$cvxsub) { if (try_autoload($cvstashname, $cvname)) { # Recalculate root and xsub @@ -564,6 +699,10 @@ sub B::CV::save { $ppname .= ($stashname eq "main") ? $gvname : "$stashname\::$gvname"; $ppname =~ s/::/__/g; + if ($gvname eq "INIT"){ + $ppname .= "_$initsub_index"; + $initsub_index++; + } } } if (!$ppname) { @@ -581,28 +720,19 @@ sub B::CV::save { $$padlist, $$cv) if $debug_cv; } } - elsif ($cvxsub) { - $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY); - # Try to find out canonical name of XSUB function from EGV. - # XXX Doesn't work for XSUBs with PREFIX set (or anyone who - # calls newXS() manually with weird arguments). - my $egv = $gv->EGV; - my $stashname = $egv->STASH->NAME; - $stashname =~ s/::/__/g; - $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME); - $decl->add("void $xsub _((CV*));"); - } else { warn sprintf("No definition for sub %s::%s (unable to autoload)\n", $cvstashname, $cvname); # debug - } - $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x", + } + $pv = '' unless defined $pv; # Avoid use of undef warnings + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS)); if (${$cv->OUTSIDE} == ${main_cv()}){ $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); + $init->add(sprintf("SvREFCNT_inc(PL_main_cv);")); } if ($$gv) { @@ -611,13 +741,7 @@ sub B::CV::save { warn sprintf("done saving GV 0x%x for CV 0x%x\n", $$gv, $$cv) if $debug_cv; } - my $filegv = $cv->FILEGV; - if ($$filegv) { - $filegv->save; - $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv)); - warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n", - $$filegv, $$cv) if $debug_cv; - } + $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE))); my $stash = $cv->STASH; if ($$stash) { $stash->save; @@ -626,7 +750,7 @@ sub B::CV::save { $$stash, $$cv) if $debug_cv; } $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", - $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS)); + $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS)); return $sym; } @@ -641,24 +765,31 @@ sub B::GV::save { $sym = savesym($gv, "gv_list[$ix]"); #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug } + my $is_empty = $gv->is_empty; my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); #warn "GV name is $name\n"; # debug - my $egv = $gv->EGV; my $egvsym; - if ($$gv != $$egv) { - #warn(sprintf("EGV name is %s, saving it now\n", - # $egv->STASH->NAME . "::" . $egv->NAME)); # debug - $egvsym = $egv->save; + unless ($is_empty) { + my $egv = $gv->EGV; + if ($$gv != $$egv) { + #warn(sprintf("EGV name is %s, saving it now\n", + # $egv->STASH->NAME . "::" . $egv->NAME)); # debug + $egvsym = $egv->save; + } } $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);], sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS), - sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS), - sprintf("GvLINE($sym) = %u;", $gv->LINE)); + sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS)); + $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty; + # Shouldn't need to do save_magic since gv_fetchpv handles that #$gv->save_magic; my $refcnt = $gv->REFCNT + 1; $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1; + + return $sym if $is_empty; + my $gvrefcnt = $gv->GvREFCNT; if ($gvrefcnt > 1) { $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); @@ -672,45 +803,51 @@ sub B::GV::save { # warn "GV::save saving subfields\n"; # debug my $gvsv = $gv->SV; if ($$gvsv) { + $gvsv->save; $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); # warn "GV::save \$$name\n"; # debug - $gvsv->save; } my $gvav = $gv->AV; if ($$gvav) { + $gvav->save; $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); # warn "GV::save \@$name\n"; # debug - $gvav->save; } my $gvhv = $gv->HV; if ($$gvhv) { + $gvhv->save; $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); # warn "GV::save \%$name\n"; # debug - $gvhv->save; } my $gvcv = $gv->CV; - if ($$gvcv) { - $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv)); -# warn "GV::save &$name\n"; # debug - $gvcv->save; - } - my $gvfilegv = $gv->FILEGV; - if ($$gvfilegv) { - $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv)); -# warn "GV::save GvFILEGV(*$name)\n"; # debug - $gvfilegv->save; - } + if ($$gvcv) { + my $origname=cstring($gvcv->GV->EGV->STASH->NAME . + "::" . $gvcv->GV->EGV->NAME); + if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias + # must save as a 'stub' so newXS() has a CV to populate + $init->add("{ CV *cv;"); + $init->add("\tcv=perl_get_cv($origname,TRUE);"); + $init->add("\tGvCV($sym)=cv;"); + $init->add("\tSvREFCNT_inc((SV *)cv);"); + $init->add("}"); + } else { + $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save)); +# warn "GV::save &$name\n"; # debug + } + } + $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE))); +# warn "GV::save GvFILE(*$name)\n"; # debug my $gvform = $gv->FORM; if ($$gvform) { + $gvform->save; $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); # warn "GV::save GvFORM(*$name)\n"; # debug - $gvform->save; } my $gvio = $gv->IO; if ($$gvio) { + $gvio->save; $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); # warn "GV::save GvIO(*$name)\n"; # debug - $gvio->save; } } return $sym; @@ -723,7 +860,7 @@ sub B::AV::save { $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", $avflags)); $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", - $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS)); + $xpvavsect->index, $av->REFCNT , $av->FLAGS)); my $sv_list_index = $svsect->index; my $fill = $av->FILL; $av->save_magic; @@ -789,7 +926,7 @@ sub B::HV::save { $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", $hv->MAX, $hv->RITER)); $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", - $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS)); + $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); my $sv_list_index = $svsect->index; my @contents = $hv->ARRAY; if (@contents) { @@ -802,9 +939,12 @@ sub B::HV::save { my ($key, $value) = splice(@contents, 0, 2); $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", cstring($key),length($key),$value, hash($key))); +# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", +# cstring($key),length($key),$value, 0)); } $init->add("}"); } + $hv->save_magic(); return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); } @@ -813,6 +953,7 @@ sub B::IO::save { my $sym = objsym($io); return $sym if defined $sym; my $pv = $io->PV; + $pv = '' unless defined $pv; my $len = length($pv); $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", $len, $len+1, $io->IVX, $io->NVX, $io->LINES, @@ -821,7 +962,7 @@ sub B::IO::save { cstring($io->BOTTOM_NAME), $io->SUBPROCESS, cchar($io->IoTYPE), $io->IoFLAGS)); $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", - $xpviosect->index, $io->REFCNT + 1, $io->FLAGS)); + $xpviosect->index, $io->REFCNT , $io->FLAGS)); $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); my ($field, $fsym); foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { @@ -848,11 +989,10 @@ sub output_all { my $init_name = shift; my $section; my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, - $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect, - $cvopsect, $loopsect, $copsect, $svsect, $xpvsect, + $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect, + $loopsect, $copsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); - $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n"); $symsect->output(\*STDOUT, "#define %s\n"); print "\n"; output_declarations(); @@ -881,6 +1021,8 @@ sub output_all { static int $init_name() { dTHR; + dTARG; + djSP; EOT $init->output(\*STDOUT, "\t%s\n"); print "\treturn 0;\n}\n"; @@ -915,18 +1057,18 @@ typedef struct { HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) _((CV*)); + void (*xcv_xsub) (CV*); void * xcv_xsubany; GV * xcv_gv; - GV * xcv_filegv; - long xcv_depth; /* >= 2 indicates recursive call */ + char * xcv_file; + long xcv_depth; /* >= 2 indicates recursive call */ AV * xcv_padlist; CV * xcv_outside; #ifdef USE_THREADS perl_mutex *xcv_mutexp; struct perl_thread *xcv_owner; /* current owner thread */ #endif /* USE_THREADS */ - U8 xcv_flags; + cv_flags_t xcv_flags; } XPVCV_or_similar; #define ANYINIT(i) i #else @@ -948,15 +1090,16 @@ sub output_boilerplate { print <<'EOT'; #include "EXTERN.h" #include "perl.h" -#ifndef PATCHLEVEL -#include "patchlevel.h" -#endif +#include "XSUB.h" /* Workaround for mapstart: the only op which needs a different ppaddr */ -#undef pp_mapstart -#define pp_mapstart pp_grepstart +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart +#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); -static void xs_init _((void)); +static void xs_init (pTHX); +static void dl_init (pTHX); static PerlInterpreter *my_perl; EOT } @@ -964,28 +1107,20 @@ EOT sub output_main { print <<'EOT'; int -#ifndef CAN_PROTOTYPE -main(argc, argv, env) -int argc; -char **argv; -char **env; -#else /* def(CAN_PROTOTYPE) */ main(int argc, char **argv, char **env) -#endif /* def(CAN_PROTOTYPE) */ { int exitstatus; int i; char **fakeargv; - PERL_SYS_INIT(&argc,&argv); + PERL_SYS_INIT3(&argc,&argv,&env); - perl_init_i18nl10n(1); - if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) exit(1); perl_construct( my_perl ); + PL_perl_destruct_level = 0; } #ifdef CSH @@ -1021,22 +1156,84 @@ main(int argc, char **argv, char **env) exitstatus = perl_init(); if (exitstatus) exit( exitstatus ); + dl_init(aTHX); exitstatus = perl_run( my_perl ); perl_destruct( my_perl ); perl_free( my_perl ); + PERL_SYS_TERM(); + exit( exitstatus ); } +/* yanked from perl.c */ static void -xs_init() +xs_init(pTHX) { -} + char *file = __FILE__; + dTARG; + djSP; +EOT + print "\n#ifdef USE_DYNAMIC_LOADING"; + print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; + print "\n#endif\n" ; + # delete $xsub{'DynaLoader'}; + delete $xsub{'UNIVERSAL'}; + print("/* bootstrapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + print "#ifdef DYNALOADER_BOOTSTRAP\n"; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_DynaLoader(aTHX_ NULL);\n"; + print qq/\tSPAGAIN;\n/; + print "#endif\n"; + foreach my $stashname (keys %xsub){ + if ($xsub{$stashname} ne 'Dynamic') { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end bootstrapping code */\n"); + print "}\n"; + +print <<'EOT'; +static void +dl_init(pTHX) +{ + char *file = __FILE__; + dTARG; + djSP; EOT + print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + foreach my $stashname (@DynaLoader::dl_modules) { + warn "Loaded $stashname\n"; + if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; + print qq/\tPUTBACK;\n/; + print "#ifdef DYNALOADER_BOOTSTRAP\n"; + warn "bootstrapping $stashname added to xs_init\n"; + print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; + print "\n#else\n"; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; + print "#endif\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); + print "}\n"; } - sub dump_symtable { # For debugging my ($sym, $val); @@ -1056,107 +1253,174 @@ sub save_object { sub Dummy_BootStrap { } -sub B::GV::savecv { - my $gv = shift; - my $cv = $gv->CV; - my $name = $gv->NAME; - if ($$cv) { - if ($name eq "bootstrap" && $cv->XSUB) { - my $file = $cv->FILEGV->SV->PV; - $bootstrap->add($file); - my $name = $gv->STASH->NAME.'::'.$name; - no strict 'refs'; - *{$name} = \&Dummy_BootStrap; - $cv = $gv->CV; - } - if ($debug_cv) { - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $gv->STASH->NAME, $name, $$cv, $$gv); - } - my $package=$gv->STASH->NAME; - # This seems to undo all the ->isa and prefix stuff we do below - # so disable again for now - if (0 && ! grep(/^$package$/,@unused_sub_packages)){ - warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) - if $debug_cv; - return ; +sub B::GV::savecv +{ + my $gv = shift; + my $package=$gv->STASH->NAME; + my $name = $gv->NAME; + my $cv = $gv->CV; + my $sv = $gv->SV; + my $av = $gv->AV; + my $hv = $gv->HV; + + # We may be looking at this package just because it is a branch in the + # symbol table which is on the path to a package which we need to save + # e.g. this is 'Getopt' and we need to save 'Getopt::Long' + # + return unless ($unused_sub_packages{$package}); + return unless ($$cv || $$av || $$sv || $$hv); + $gv->save; +} + +sub mark_package +{ + my $package = shift; + unless ($unused_sub_packages{$package}) + { + no strict 'refs'; + $unused_sub_packages{$package} = 1; + if (defined @{$package.'::ISA'}) + { + foreach my $isa (@{$package.'::ISA'}) + { + if ($isa eq 'DynaLoader') + { + unless (defined(&{$package.'::bootstrap'})) + { + warn "Forcing bootstrap of $package\n"; + eval { $package->bootstrap }; + } + } +# else + { + unless ($unused_sub_packages{$isa}) + { + warn "$isa saved (it is in $package\'s \@ISA)\n"; + mark_package($isa); + } + } } - $gv->save; } - elsif ($name eq 'ISA') - { - $gv->save; - } - + } + return 1; +} + +sub should_save +{ + no strict qw(vars refs); + my $package = shift; + $package =~ s/::$//; + return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. + # warn "Considering $package\n";#debug + foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) + { + # If this package is a prefix to something we are saving, traverse it + # but do not mark it for saving if it is not already + # e.g. to get to Getopt::Long we need to traverse Getopt but need + # not save Getopt + return 1 if ($u =~ /^$package\:\:/); + } + if (exists $unused_sub_packages{$package}) + { + # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; + delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; + return $unused_sub_packages{$package}; + } + # Omit the packages which we use (and which cause grief + # because of fancy "goto &$AUTOLOAD" stuff). + # XXX Surely there must be a nicer way to do this. + if ($package eq "FileHandle" || $package eq "Config" || + $package eq "SelectSaver" || $package =~/^(B|IO)::/) + { + delete_unsaved_hashINC($package); + return $unused_sub_packages{$package} = 0; + } + # Now see if current package looks like an OO class this is probably too strong. + foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) + { + if ($package->can($m)) + { + warn "$package has method $m: saving package\n";#debug + return mark_package($package); + } + } + delete_unsaved_hashINC($package); + return $unused_sub_packages{$package} = 0; +} +sub delete_unsaved_hashINC{ + my $packname=shift; + $packname =~ s/\:\:/\//g; + $packname .= '.pm'; +# warn "deleting $packname" if $INC{$packname} ;# debug + delete $INC{$packname}; +} +sub walkpackages +{ + my ($symref, $recurse, $prefix) = @_; + my $sym; + my $ref; + no strict 'vars'; + local(*glob); + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) + { + *glob = $ref; + if ($sym =~ /::$/) + { + $sym = $prefix . $sym; + if ($sym ne "main::" && &$recurse($sym)) + { + walkpackages(\%glob, $recurse, $sym); + } + } + } } +sub save_unused_subs +{ + no strict qw(refs); + &descend_marked_unused; + warn "Prescan\n"; + walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); + warn "Saving methods\n"; + walksymtable(\%{"main::"}, "savecv", \&should_save); +} -sub save_unused_subs { - my %search_pack; - map { $search_pack{$_} = 1 } @_; - @unused_sub_packages=@_; - no strict qw(vars refs); - walksymtable(\%{"main::"}, "savecv", sub { - my $package = shift; - $package =~ s/::$//; - return 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. - #warn "Considering $package\n";#debug - return 1 if exists $search_pack{$package}; - #sub try for a partial match - if (grep(/^$package\:\:/,@unused_sub_packages)){ - return 1; - } - #warn " (nothing explicit)\n";#debug - # Omit the packages which we use (and which cause grief - # because of fancy "goto &$AUTOLOAD" stuff). - # XXX Surely there must be a nicer way to do this. - if ($package eq "FileHandle" - || $package eq "Config" - || $package eq "SelectSaver") { - return 0; - } - foreach my $u (keys %search_pack) { - if ($package =~ /^${u}::/) { - warn "$package starts with $u\n"; - return 1 - } - if ($package->isa($u)) { - warn "$package isa $u\n"; - return 1 - } - return 1 if $package->isa($u); - } - foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { - if (defined(&{$package."::$m"})) { - warn "$package has method $m: -u$package assumed\n";#debug - push @unused_sub_package, $package; - return 1; - } - } - return 0; - }); +sub save_context +{ + my $curpad_nam = (comppadlist->ARRAY)[0]->save; + my $curpad_sym = (comppadlist->ARRAY)[1]->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; + $init->add( "PL_curpad = AvARRAY($curpad_sym);", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;" ); } +sub descend_marked_unused { + foreach my $pack (keys %unused_sub_packages) + { + mark_package($pack); + } +} + sub save_main { + warn "Starting compile\n"; warn "Walking tree\n"; - my $curpad_nam = (comppadlist->ARRAY)[0]->save; - my $curpad_sym = (comppadlist->ARRAY)[1]->save; - my $init_av = init_av->save; - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; + seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output walkoptree(main_root, "save"); warn "done main optree, walking symtable for extras\n" if $debug_cv; - save_unused_subs(@unused_sub_packages); - + save_unused_subs(); + my $init_av = init_av->save; $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = $init_av;", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "PL_initav = (AV *) $init_av;"); + save_context(); warn "Writing output\n"; output_boilerplate(); print "\n"; @@ -1168,7 +1432,7 @@ sub save_main { sub init_sections { my @sections = (init => \$init, decl => \$decl, sym => \$symsect, binop => \$binopsect, condop => \$condopsect, - cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect, + cop => \$copsect, padop => \$padopsect, listop => \$listopsect, logop => \$logopsect, loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, @@ -1177,11 +1441,17 @@ sub init_sections { xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, xrv => \$xrvsect, xpvbm => \$xpvbmsect, - xpvio => \$xpviosect, bootstrap => \$bootstrap); + xpvio => \$xpviosect); my ($name, $sectref); while (($name, $sectref) = splice(@sections, 0, 2)) { - $$sectref = new B::Section $name, \%symtable, 0; + $$sectref = new B::C::Section $name, \%symtable, 0; } +} + +sub mark_unused +{ + my ($arg,$val) = @_; + $unused_sub_packages{$arg} = $val; } sub compile { @@ -1226,7 +1496,7 @@ sub compile { $verbose = 1; } elsif ($opt eq "u") { $arg ||= shift @options; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "f") { $arg ||= shift @options; if ($arg eq "cog") { @@ -1241,6 +1511,8 @@ sub compile { # Optimisations for -O1 $pv_copy_on_grow = 1; } + } elsif ($opt eq "l") { + $max_string_len = $arg; } } init_sections(); @@ -1356,6 +1628,15 @@ No copy-on-grow. Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently, B<-O1> and higher set B<-fcog>. +=item B<-llimit> + +Some C compilers impose an arbitrary limit on the length of string +constants (e.g. 2048 characters for Microsoft Visual C++). The +B<-llimit> options tells the C backend not to generate string literals +exceeding that limit. + +=back + =head1 EXAMPLES perl -MO=C,-ofoo.c foo.pl @@ -1365,7 +1646,7 @@ Note that C<cc_harness> lives in the C<B> subdirectory of your perl library directory. The utility called C<perlcc> may also be used to help make use of this compiler. - perl -MO=C,-v,-DcA bar.pl > /dev/null + perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null =head1 BUGS diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index d200d70..c5ca2a3 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -6,36 +6,22 @@ # License or the Artistic License, as specified in the README file. # package B::CC; +use Config; use strict; use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info); -use B::C qw(save_unused_subs objsym init_sections + timing_info init_av sv_undef amagic_generation + OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL + OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV + OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR + CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK + ); +use B::C qw(save_unused_subs objsym init_sections mark_unused output_all output_boilerplate output_main); use B::Bblock qw(find_leaders); use B::Stackobj qw(:types :flags); # These should probably be elsewhere # Flags for $op->flags -sub OPf_LIST () { 1 } -sub OPf_KNOW () { 2 } -sub OPf_MOD () { 32 } -sub OPf_STACKED () { 64 } -sub OPf_SPECIAL () { 128 } -# op-specific flags for $op->private -sub OPpASSIGN_BACKWARDS () { 64 } -sub OPpLVAL_INTRO () { 128 } -sub OPpDEREF_AV () { 32 } -sub OPpDEREF_HV () { 64 } -sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV } -sub OPpFLIP_LINENUM () { 64 } -sub G_ARRAY () { 1 } -# cop.h -sub CXt_NULL () { 0 } -sub CXt_SUB () { 1 } -sub CXt_EVAL () { 2 } -sub CXt_LOOP () { 3 } -sub CXt_SUBST () { 4 } -sub CXt_BLOCK () { 5 } my $module; # module name (when compiled with -m) my %done; # hash keyed by $$op of leaders of basic blocks @@ -66,6 +52,9 @@ my %skip_stack; # Hash of PP names which don't need write_back_stack my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals my %ignore_op; # Hash of ops which do nothing except returning op_next +my %need_curcop; # Hash of ops which need PL_curcop + +my %lexstate; #state of padsvs at the start of a bblock BEGIN { foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { @@ -73,11 +62,6 @@ BEGIN { } } -my @unused_sub_packages; # list of packages (given by -u options) to search - # explicitly and save every sub we find there, even - # if apparently unused (could be only referenced from - # an eval "" or from a $SIG{FOO} = "bar"). - my ($module_name); my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); @@ -111,12 +95,17 @@ sub init_hash { map { $_ => 1 } @_ } # %skip_lexicals = init_hash qw(pp_enter pp_enterloop); %skip_invalidate = init_hash qw(pp_enter pp_enterloop); +%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller + pp_reset pp_rv2cv pp_entereval pp_require pp_dofile + pp_entertry pp_enterloop pp_enteriter pp_entersub + pp_enter pp_method); sub debug { if ($debug_runtime) { warn(@_); } else { - runtime(map { chomp; "/* $_ */"} @_); + my @tmp=@_; + runtime(map { chomp; "/* $_ */"} @tmp); } } @@ -139,7 +128,7 @@ sub output_runtime { print qq(#include "cc_runtime.h"\n); foreach $ppdata (@pp_list) { my ($name, $runtime, $declare) = @$ppdata; - print "\nstatic\nPP($name)\n{\n"; + print "\nstatic\nCCPP($name)\n{\n"; my ($type, $varlist, $line); while (($type, $varlist) = each %$declare) { print "\t$type ", join(", ", @$varlist), ";\n"; @@ -167,7 +156,7 @@ sub init_pp { declare("SV", "**svp"); map { declare("SV", "*$_") } qw(sv src dst left right); declare("MAGIC", "*mg"); - $decl->add("static OP * $ppname _((ARGSproto));"); + $decl->add("static OP * $ppname (pTHX);"); debug "init_pp: $ppname\n" if $debug_queue; } @@ -200,7 +189,7 @@ sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } -sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" } +sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } @@ -208,7 +197,7 @@ sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } sub pop_bool { if (@stack) { - return ((pop @stack)->as_numeric); + return ((pop @stack)->as_bool); } else { # Careful: POPs has an auto-decrement and SvTRUE evaluates # its argument more than once. @@ -228,6 +217,32 @@ sub write_back_lexicals { } } +sub save_or_restore_lexical_state { + my $bblock=shift; + unless( exists $lexstate{$bblock}){ + foreach my $lex (@pad) { + next unless ref($lex); + ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ; + } + } + else { + foreach my $lex (@pad) { + next unless ref($lex); + my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ; + next if ( $old_flags eq $lex->{flags}); + if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){ + $lex->write_back; + } + if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){ + $lex->load_double; + } + if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){ + $lex->load_int; + } + } + } +} + sub write_back_stack { my $obj; return unless @stack; @@ -350,8 +365,9 @@ sub dopoptoloop { sub dopoptolabel { my $label = shift; my $cxix = $#cxstack; - while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP - && $cxstack[$cxix]->{label} ne $label) { + while ($cxix >= 0 && + ($cxstack[$cxix]->{type} != CXt_LOOP || + $cxstack[$cxix]->{label} ne $label)) { $cxix--; } debug "dopoptolabel: returning $cxix" if $debug_cxstack; @@ -360,7 +376,7 @@ sub dopoptolabel { sub error { my $format = shift; - my $file = $curcop->[0]->filegv->SV->PV; + my $file = $curcop->[0]->file; my $line = $curcop->[0]->line; $errors++; if (@_) { @@ -416,12 +432,22 @@ sub load_pad { } $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, "i_$name", "d_$name"); - declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name"); - declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name"); + debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; } } +sub declare_pad { + my $ix; + for ($ix = 1; $ix <= $#pad; $ix++) { + my $type = $pad[$ix]->{type}; + declare("IV", $type == T_INT ? + sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int; + declare("double", $type == T_DOUBLE ? + sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double; + + } +} # # Debugging stuff # @@ -461,7 +487,7 @@ sub doop { sub gimme { my $op = shift; my $flags = $op->flags; - return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()"); + return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); } # @@ -476,10 +502,12 @@ sub pp_null { sub pp_stub { my $op = shift; my $gimme = gimme($op); - if ($gimme != 1) { + if ($gimme != G_ARRAY) { + my $obj= new B::Stackobj::Const(sv_undef); + push(@stack, $obj); # XXX Change to push a constant sv_undef Stackobj onto @stack - write_back_stack(); - runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); + #write_back_stack(); + #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); } return $op->next; } @@ -499,8 +527,10 @@ sub pp_and { if (@stack >= 1) { my $bool = pop_bool(); write_back_stack(); - runtime(sprintf("if (!$bool) goto %s;", label($next))); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); } else { + save_or_restore_lexical_state($$next); runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), "*sp--;"); } @@ -513,11 +543,13 @@ sub pp_or { reload_lexicals(); unshift(@bblock_todo, $next); if (@stack >= 1) { - my $obj = pop @stack; + my $bool = pop_bool @stack; write_back_stack(); - runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }", - $obj->as_numeric, $obj->as_sv, label($next))); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", + $bool, label($next))); } else { + save_or_restore_lexical_state($$next); runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), "*sp--;"); } @@ -526,13 +558,14 @@ sub pp_or { sub pp_cond_expr { my $op = shift; - my $false = $op->false; + my $false = $op->next; unshift(@bblock_todo, $false); reload_lexicals(); my $bool = pop_bool(); write_back_stack(); + save_or_restore_lexical_state($$false); runtime(sprintf("if (!$bool) goto %s;", label($false))); - return $op->true; + return $op->other; } sub pp_padsv { @@ -555,9 +588,16 @@ sub pp_padsv { sub pp_const { my $op = shift; my $sv = $op->sv; - my $obj = $constobj{$$sv}; - if (!defined($obj)) { - $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); + my $obj; + # constant could be in the pad (under useithreads) + if ($$sv) { + $obj = $constobj{$$sv}; + if (!defined($obj)) { + $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); + } + } + else { + $obj = $pad[$op->targ]; } push(@stack, $obj); return $op->next; @@ -567,7 +607,7 @@ sub pp_nextstate { my $op = shift; $curcop->load($op); @stack = (); - debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno; + debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno; runtime("TAINT_NOT;") unless $omit_taint; runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); if ($freetmps_each_bblock || $freetmps_each_loop) { @@ -584,18 +624,58 @@ sub pp_dbstate { return default_pp($op); } -sub pp_rv2gv { $curcop->write_back; default_pp(@_) } -sub pp_bless { $curcop->write_back; default_pp(@_) } -sub pp_repeat { $curcop->write_back; default_pp(@_) } +#default_pp will handle this: +#sub pp_bless { $curcop->write_back; default_pp(@_) } +#sub pp_repeat { $curcop->write_back; default_pp(@_) } # The following subs need $curcop->write_back if we decide to support arybase: # pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice -sub pp_sort { $curcop->write_back; default_pp(@_) } -sub pp_caller { $curcop->write_back; default_pp(@_) } -sub pp_reset { $curcop->write_back; default_pp(@_) } +#sub pp_caller { $curcop->write_back; default_pp(@_) } +#sub pp_reset { $curcop->write_back; default_pp(@_) } + +sub pp_rv2gv{ + my $op =shift; + $curcop->write_back; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + if ($op->private & OPpDEREF) { + $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;")); + $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", + $op->first->type)); + } + return $op->next; +} +sub pp_sort { + my $op = shift; + my $ppname = $op->ppaddr; + if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){ + #this indicates the sort BLOCK Array case + #ugly surgery required. + my $root=$op->first->sibling->first; + my $start=$root->first; + $op->first->save; + $op->first->sibling->save; + $root->save; + my $sym=$start->save; + my $fakeop=cc_queue("pp_sort".$$op,$root,$start); + $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop)); + } + $curcop->write_back; + write_back_lexicals(); + write_back_stack(); + doop($op); + return $op->next; +} sub pp_gv { my $op = shift; - my $gvsym = $op->gv->save; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } write_back_stack(); runtime("XPUSHs((SV*)$gvsym);"); return $op->next; @@ -603,7 +683,13 @@ sub pp_gv { sub pp_gvsv { my $op = shift; - my $gvsym = $op->gv->save; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } write_back_stack(); if ($op->private & OPpLVAL_INTRO) { runtime("XPUSHs(save_scalar($gvsym));"); @@ -615,7 +701,13 @@ sub pp_gvsv { sub pp_aelemfast { my $op = shift; - my $gvsym = $op->gv->save; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } my $ix = $op->private; my $flag = $op->flags & OPf_MOD; write_back_stack(); @@ -666,11 +758,15 @@ sub numeric_binop { } } else { if ($force_int) { + my $rightruntime = new B::Pseudoreg ("IV", "riv"); + runtime(sprintf("$$rightruntime = %s;",$right)); runtime(sprintf("sv_setiv(TOPs, %s);", - &$operator("TOPi", $right))); + &$operator("TOPi", $$rightruntime))); } else { + my $rightruntime = new B::Pseudoreg ("double", "rnv"); + runtime(sprintf("$$rightruntime = %s;",$right)); runtime(sprintf("sv_setnv(TOPs, %s);", - &$operator("TOPn", $right))); + &$operator("TOPn",$$rightruntime))); } } } else { @@ -694,6 +790,60 @@ sub numeric_binop { return $op->next; } +sub pp_ncmp { + my ($op) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_numeric(); + if (@stack >= 1) { + my $left = top_numeric(); + runtime sprintf("if (%s > %s){",$left,$right); + $stack[-1]->set_int(1); + $stack[-1]->write_back(); + runtime sprintf("}else if (%s < %s ) {",$left,$right); + $stack[-1]->set_int(-1); + $stack[-1]->write_back(); + runtime sprintf("}else if (%s == %s) {",$left,$right); + $stack[-1]->set_int(0); + $stack[-1]->write_back(); + runtime sprintf("}else {"); + $stack[-1]->set_sv("&PL_sv_undef"); + runtime "}"; + } else { + my $rightruntime = new B::Pseudoreg ("double", "rnv"); + runtime(sprintf("$$rightruntime = %s;",$right)); + runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime); + runtime sprintf("sv_setiv(TOPs,1);"); + runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime); + runtime sprintf("sv_setiv(TOPs,-1);"); + runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime); + runtime sprintf("sv_setiv(TOPs,0);"); + runtime sprintf(qq/}else {/); + runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;"); + runtime "}"; + } + } else { + my $targ = $pad[$op->targ]; + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + runtime sprintf("if (%s > %s){",$$left,$$right); + $targ->set_int(1); + $targ->write_back(); + runtime sprintf("}else if (%s < %s ) {",$$left,$$right); + $targ->set_int(-1); + $targ->write_back(); + runtime sprintf("}else if (%s == %s) {",$$left,$$right); + $targ->set_int(0); + $targ->write_back(); + runtime sprintf("}else {"); + $targ->set_sv("&PL_sv_undef"); + runtime "}"; + push(@stack, $targ); + } + return $op->next; +} + sub sv_binop { my ($op, $operator, $flags) = @_; if ($op->flags & OPf_STACKED) { @@ -789,7 +939,6 @@ BEGIN { my $modulo_op = infix_op("%"); my $lshift_op = infix_op("<<"); my $rshift_op = infix_op(">>"); - my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" }; my $scmp_op = prefix_op("sv_cmp"); my $seq_op = prefix_op("sv_eq"); my $sne_op = prefix_op("!sv_eq"); @@ -808,12 +957,11 @@ BEGIN { # XXX The standard perl PP code has extra handling for # some special case arguments of these operators. # - sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) } - sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) } - sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) } + sub pp_add { numeric_binop($_[0], $plus_op) } + sub pp_subtract { numeric_binop($_[0], $minus_op) } + sub pp_multiply { numeric_binop($_[0], $multiply_op) } sub pp_divide { numeric_binop($_[0], $divide_op) } sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's - sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) } sub pp_left_shift { int_binop($_[0], $lshift_op) } sub pp_right_shift { int_binop($_[0], $rshift_op) } @@ -857,7 +1005,7 @@ sub pp_sassign { ($src, $dst) = ($dst, $src) if $backwards; my $type = $src->{type}; if ($type == T_INT) { - $dst->set_int($src->as_int); + $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); } elsif ($type == T_DOUBLE) { $dst->set_numeric($src->as_numeric); } else { @@ -870,7 +1018,11 @@ sub pp_sassign { my $type = $src->{type}; runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); if ($type == T_INT) { - runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + if ($src->{flags} & VALID_UNSIGNED){ + runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); + }else{ + runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + } } elsif ($type == T_DOUBLE) { runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); } else { @@ -887,7 +1039,7 @@ sub pp_sassign { } elsif ($type == T_DOUBLE) { $dst->set_double("SvNV(sv)"); } else { - runtime("SvSetSV($dst->{sv}, sv);"); + runtime("SvSetMagicSV($dst->{sv}, sv);"); $dst->invalidate; } } @@ -922,6 +1074,7 @@ sub pp_preinc { return $op->next; } + sub pp_pushmark { my $op = shift; write_back_stack(); @@ -933,7 +1086,7 @@ sub pp_list { my $op = shift; write_back_stack(); my $gimme = gimme($op); - if ($gimme == 1) { # sic + if ($gimme == G_ARRAY) { # sic runtime("POPMARK;"); # need this even though not a "full" pp_list } else { runtime("PP_LIST($gimme);"); @@ -943,16 +1096,31 @@ sub pp_list { sub pp_entersub { my $op = shift; + $curcop->write_back; write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); my $sym = doop($op); runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); - runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);"); runtime("SPAGAIN;}"); $know_op = 0; invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_formline { + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + # See comment in pp_grepwhile to see why! + $init->add("((LISTOP*)$sym)->op_first = $sym;"); + runtime("if (PL_op == ((LISTOP*)($sym))->op_first){"); + save_or_restore_lexical_state(${$op->first}); + runtime( sprintf("goto %s;",label($op->first))); + runtime("}"); + return $op->next; +} sub pp_goto{ @@ -969,7 +1137,16 @@ sub pp_enterwrite { my $op = shift; pp_entersub($op); } - +sub pp_leavesub{ + my $op = shift; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){"); + runtime("\tPUTBACK;return 0;"); + runtime("}"); + doop($op); + return $op->next; +} sub pp_leavewrite { my $op = shift; write_back_lexicals(REGISTER|TEMPORARY); @@ -977,7 +1154,7 @@ sub pp_leavewrite { my $sym = doop($op); # XXX Is this the right way to distinguish between it returning # CvSTART(cv) (via doform) and pop_return()? - runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);"); + #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); runtime("SPAGAIN;"); $know_op = 0; invalidate_lexicals(REGISTER|TEMPORARY); @@ -991,6 +1168,7 @@ sub doeval { write_back_stack(); my $sym = loadop($op); my $ppaddr = $op->ppaddr; + #runtime(qq/printf("$ppaddr type eval\n");/); runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); $know_op = 1; invalidate_lexicals(REGISTER|TEMPORARY); @@ -998,9 +1176,24 @@ sub doeval { } sub pp_entereval { doeval(@_) } -sub pp_require { doeval(@_) } sub pp_dofile { doeval(@_) } +#pp_require is protected by pp_entertry, so no protection for it. +sub pp_require { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;}"); + $know_op = 1; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + + sub pp_entertry { my $op = shift; $curcop->write_back; @@ -1008,12 +1201,19 @@ sub pp_entertry { write_back_stack(); my $sym = doop($op); my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); - declare("Sigjmp_buf", $jmpbuf); + declare("JMPENV", $jmpbuf); runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); invalidate_lexicals(REGISTER|TEMPORARY); return $op->next; } +sub pp_leavetry{ + my $op=shift; + default_pp($op); + runtime("PP_LEAVETRY;"); + return $op->next; +} + sub pp_grepstart { my $op = shift; if ($need_freetmps && $freetmps_each_loop) { @@ -1021,7 +1221,14 @@ sub pp_grepstart { $need_freetmps = 0; } write_back_stack(); - doop($op); + my $sym= doop($op); + my $next=$op->next; + $next->save; + my $nexttonext=$next->next; + $nexttonext->save; + save_or_restore_lexical_state($$nexttonext); + runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", + label($nexttonext))); return $op->next->other; } @@ -1032,7 +1239,16 @@ sub pp_mapstart { $need_freetmps = 0; } write_back_stack(); - doop($op); + # pp_mapstart can return either op_next->op_next or op_next->op_other and + # we need to be able to distinguish the two at runtime. + my $sym= doop($op); + my $next=$op->next; + $next->save; + my $nexttonext=$next->next; + $nexttonext->save; + save_or_restore_lexical_state($$nexttonext); + runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", + label($nexttonext))); return $op->next->other; } @@ -1049,6 +1265,7 @@ sub pp_grepwhile { # around that, we hack op_next to be our own op (purely because we # know it's a non-NULL pointer and can't be the same as op_other). $init->add("((LOGOP*)$sym)->op_next = $sym;"); + save_or_restore_lexical_state($$next); runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); $know_op = 0; return $op->other; @@ -1063,7 +1280,7 @@ sub pp_return { write_back_lexicals(REGISTER|TEMPORARY); write_back_stack(); doop($op); - runtime("PUTBACK;", "return (PL_op)?PL_op->op_next:0;"); + runtime("PUTBACK;", "return PL_op;"); $know_op = 0; return $op->next; } @@ -1077,30 +1294,31 @@ sub nyi { sub pp_range { my $op = shift; my $flags = $op->flags; - if (!($flags & OPf_KNOW)) { + if (!($flags & OPf_WANT)) { error("context of range unknown at compile-time"); } write_back_lexicals(); write_back_stack(); - if (!($flags & OPf_LIST)) { + unless (($flags & OPf_WANT)== OPf_WANT_LIST) { # We need to save our UNOP structure since pp_flop uses # it to find and adjust out targ. We don't need it ourselves. $op->save; + save_or_restore_lexical_state(${$op->other}); runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", - $op->targ, label($op->false)); - unshift(@bblock_todo, $op->false); + $op->targ, label($op->other)); + unshift(@bblock_todo, $op->other); } - return $op->true; + return $op->next; } sub pp_flip { my $op = shift; my $flags = $op->flags; - if (!($flags & OPf_KNOW)) { + if (!($flags & OPf_WANT)) { error("context of flip unknown at compile-time"); } - if ($flags & OPf_LIST) { - return $op->first->false; + if (($flags & OPf_WANT)==OPf_WANT_LIST) { + return $op->first->other; } write_back_lexicals(); write_back_stack(); @@ -1116,9 +1334,10 @@ sub pp_flip { if ($op->flags & OPf_SPECIAL) { runtime("sv_setiv(PL_curpad[$ix], 1);"); } else { + save_or_restore_lexical_state(${$op->first->other}); runtime("\tsv_setiv(PL_curpad[$ix], 0);", "\tsp--;", - sprintf("\tgoto %s;", label($op->first->false))); + sprintf("\tgoto %s;", label($op->first->other))); } runtime("}", qq{sv_setpv(PL_curpad[$ix], "");}, @@ -1187,6 +1406,7 @@ sub pp_next { default_pp($op); my $nextop = $cxstack[$cxix]->{nextop}; push(@bblock_todo, $nextop); + save_or_restore_lexical_state($$nextop); runtime(sprintf("goto %s;", label($nextop))); return $op->next; } @@ -1210,6 +1430,7 @@ sub pp_redo { default_pp($op); my $redoop = $cxstack[$cxix]->{redoop}; push(@bblock_todo, $redoop); + save_or_restore_lexical_state($$redoop); runtime(sprintf("goto %s;", label($redoop))); return $op->next; } @@ -1238,6 +1459,7 @@ sub pp_last { default_pp($op); my $lastop = $cxstack[$cxix]->{lastop}->next; push(@bblock_todo, $lastop); + save_or_restore_lexical_state($$lastop); runtime(sprintf("goto %s;", label($lastop))); return $op->next; } @@ -1249,6 +1471,7 @@ sub pp_subst { my $sym = doop($op); my $replroot = $op->pmreplroot; if ($$replroot) { + save_or_restore_lexical_state($$replroot); runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", $sym, label($replroot)); $op->pmreplstart->save; @@ -1264,11 +1487,12 @@ sub pp_substcont { write_back_stack(); doop($op); my $pmop = $op->other; - warn sprintf("substcont: op = %s, pmop = %s\n", - peekop($op), peekop($pmop));#debug -# my $pmopsym = objsym($pmop); + # warn sprintf("substcont: op = %s, pmop = %s\n", + # peekop($op), peekop($pmop));#debug +# my $pmopsym = objsym($pmop); my $pmopsym = $pmop->save; # XXX can this recurse? - warn "pmopsym = $pmopsym\n";#debug +# warn "pmopsym = $pmopsym\n";#debug + save_or_restore_lexical_state(${$pmop->pmreplstart}); runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", $pmopsym, label($pmop->pmreplstart)); invalidate_lexicals(); @@ -1277,7 +1501,10 @@ sub pp_substcont { sub default_pp { my $op = shift; - my $ppname = $op->ppaddr; + my $ppname = "pp_" . $op->name; + if ($curcop and $need_curcop{$ppname}){ + $curcop->write_back; + } write_back_lexicals() unless $skip_lexicals{$ppname}; write_back_stack() unless $skip_stack{$ppname}; doop($op); @@ -1291,7 +1518,7 @@ sub default_pp { sub compile_op { my $op = shift; - my $ppname = $op->ppaddr; + my $ppname = "pp_" . $op->name; if (exists $ignore_op{$ppname}) { return $op->next; } @@ -1313,6 +1540,7 @@ sub compile_op { sub compile_bblock { my $op = shift; #warn "compile_bblock: ", peekop($op), "\n"; # debug + save_or_restore_lexical_state($$op); write_label($op); $know_op = 0; do { @@ -1326,15 +1554,26 @@ sub compile_bblock { sub cc { my ($name, $root, $start, @padlist) = @_; my $op; + if($done{$$start}){ + #warn "repeat=>".ref($start)."$name,\n";#debug + $decl->add(sprintf("#define $name %s",$done{$$start})); + return; + } init_pp($name); load_pad(@padlist); + %lexstate=(); B::Pseudoreg->new_scope; @cxstack = (); if ($debug_timings) { warn sprintf("Basic block analysis at %s\n", timing_info); } $leaders = find_leaders($root, $start); - @bblock_todo = ($start, values %$leaders); + my @leaders= keys %$leaders; + if ($#leaders > -1) { + @bblock_todo = ($start, values %$leaders) ; + } else{ + runtime("return PL_op?PL_op->op_next:0;"); + } if ($debug_timings) { warn sprintf("Compilation at %s\n", timing_info); } @@ -1344,7 +1583,7 @@ sub cc { next if !defined($op) || !$$op || $done{$$op}; #warn "...compiling it\n"; # debug do { - $done{$$op} = 1; + $done{$$op} = $name; $op = compile_bblock($op); if ($need_freetmps && $freetmps_each_bblock) { runtime("FREETMPS;"); @@ -1356,14 +1595,16 @@ sub cc { $need_freetmps = 0; } if (!$$op) { - runtime("PUTBACK;","return (PL_op)?PL_op->op_next:0;"); + runtime("PUTBACK;","return PL_op;"); } elsif ($done{$$op}) { + save_or_restore_lexical_state($$op); runtime(sprintf("goto %s;", label($op))); } } if ($debug_timings) { warn sprintf("Saving runtime at %s\n", timing_info); } + declare_pad(@padlist) ; save_runtime(); } @@ -1387,20 +1628,32 @@ sub cc_obj { sub cc_main { my @comppadlist = comppadlist->ARRAY; - my $curpad_nam = $comppadlist[0]->save; - my $curpad_sym = $comppadlist[1]->save; + my $curpad_nam = $comppadlist[0]->save; + my $curpad_sym = $comppadlist[1]->save; + my $init_av = init_av->save; my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - save_unused_subs(@unused_sub_packages); + # Do save_unused_subs before saving inc_hv + save_unused_subs(); cc_recurse(); + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; return if $errors; if (!defined($module)) { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), "PL_main_start = $start;", "PL_curpad = AvARRAY($curpad_sym);", + "PL_initav = (AV *) $init_av;", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;", + ); + } + seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output output_boilerplate(); print "\n"; output_all("perl_init"); @@ -1419,11 +1672,11 @@ XS(boot_$cmodule) perl_init(); ENTER; SAVETMPS; - SAVESPTR(PL_curpad); - SAVESPTR(PL_op); + SAVEVPTR(PL_curpad); + SAVEVPTR(PL_op); PL_curpad = AvARRAY($curpad_sym); PL_op = $start; - pp_main(ARGS); + pp_main(aTHX); FREETMPS; LEAVE; ST(0) = &PL_sv_yes; @@ -1459,7 +1712,7 @@ sub compile { $module_name = $arg; } elsif ($opt eq "u") { $arg ||= shift @options; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "f") { $arg ||= shift @options; my $value = $arg !~ s/^no-//; @@ -1485,7 +1738,7 @@ sub compile { } elsif ($opt eq "m") { $arg ||= shift @options; $module = $arg; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "p") { $arg ||= shift @options; $patchlevel = $arg; diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm index 7754a5a..ae7a973 100644 --- a/contrib/perl5/ext/B/B/Debug.pm +++ b/contrib/perl5/ext/B/B/Debug.pm @@ -39,13 +39,6 @@ sub B::LOGOP::debug { printf "\top_other\t0x%x\n", ${$op->other}; } -sub B::CONDOP::debug { - my ($op) = @_; - $op->B::UNOP::debug(); - printf "\top_true\t0x%x\n", ${$op->true}; - printf "\top_false\t0x%x\n", ${$op->false}; -} - sub B::LISTOP::debug { my ($op) = @_; $op->B::BINOP::debug(); @@ -67,16 +60,15 @@ sub B::PMOP::debug { sub B::COP::debug { my ($op) = @_; $op->B::OP::debug(); - my ($filegv) = $op->filegv; - printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line; + printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase, $op->line, ${$op->warnings}; cop_label %s - cop_stash 0x%x - cop_filegv 0x%x + cop_stashpv %s + cop_file %s cop_seq %d cop_arybase %d cop_line %d + cop_warnings 0x%x EOT - $filegv->debug; } sub B::SVOP::debug { @@ -92,11 +84,10 @@ sub B::PVOP::debug { printf "\top_pv\t\t0x%x\n", $op->pv; } -sub B::GVOP::debug { +sub B::PADOP::debug { my ($op) = @_; $op->B::OP::debug(); - printf "\top_gv\t\t0x%x\n", ${$op->gv}; - $op->gv->debug; + printf "\top_padix\t\t%ld\n", $op->padix; } sub B::CVOP::debug { @@ -184,14 +175,14 @@ sub B::CV::debug { my ($start) = $sv->START; my ($root) = $sv->ROOT; my ($padlist) = $sv->PADLIST; + my ($file) = $sv->FILE; my ($gv) = $sv->GV; - my ($filegv) = $sv->FILEGV; - printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; + printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}; STASH 0x%x START 0x%x ROOT 0x%x GV 0x%x - FILEGV 0x%x + FILE %s DEPTH %d PADLIST 0x%x OUTSIDE 0x%x @@ -199,7 +190,6 @@ EOT $start->debug if $start; $root->debug if $root; $gv->debug if $gv; - $filegv->debug if $filegv; $padlist->debug if $padlist; } @@ -226,7 +216,7 @@ sub B::GV::debug { my ($av) = $gv->AV; my ($cv) = $gv->CV; $gv->B::SV::debug; - printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS; + printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; NAME %s STASH %s (0x%x) SV 0x%x @@ -238,7 +228,7 @@ sub B::GV::debug { CV 0x%x CVGEN %d LINE %d - FILEGV 0x%x + FILE %s GvFLAGS 0x%x EOT $sv->debug if $sv; @@ -253,6 +243,7 @@ sub B::SPECIAL::debug { sub compile { my $order = shift; + B::clearsym(); if ($order eq "exec") { return sub { walkoptree_exec(main_start, "debug") } } else { diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm index 5e0bd1d..cd53c11 100644 --- a/contrib/perl5/ext/B/B/Deparse.pm +++ b/contrib/perl5/ext/B/B/Deparse.pm @@ -1,5 +1,5 @@ # B::Deparse.pm -# Copyright (c) 1998 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -7,9 +7,17 @@ # but essentially none of his code remains. package B::Deparse; -use Carp 'cluck'; -use B qw(class main_root main_start main_cv svref_2object); -$VERSION = 0.56; +use Carp 'cluck', 'croak'; +use Config; +use B qw(class main_root main_start main_cv svref_2object opnumber + OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST + OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL + OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE + OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY + SVf_IOK SVf_NOK SVf_ROK SVf_POK + PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE + PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); +$VERSION = 0.59; use strict; # Changes between 0.50 and 0.51: @@ -26,17 +34,17 @@ use strict; # Changes between 0.51 and 0.52: # - added pp_threadsv (special variables under USE_THREADS) # - added documentation -# Changes between 0.52 and 0.53 +# Changes between 0.52 and 0.53: # - many changes adding precedence contexts and associativity # - added `-p' and `-s' output style options # - various other minor fixes -# Changes between 0.53 and 0.54 +# Changes between 0.53 and 0.54: # - added support for new `for (1..100)' optimization, # thanks to Gisle Aas -# Changes between 0.54 and 0.55 +# Changes between 0.54 and 0.55: # - added support for new qr// construct # - added support for new pp_regcreset OP -# Changes between 0.55 and 0.56 +# Changes between 0.55 and 0.56: # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t # - fixed $# on non-lexicals broken in last big rewrite # - added temporary fix for change in opcode of OP_STRINGIFY @@ -50,17 +58,51 @@ use strict; # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' # - added semicolons at the ends of blocks # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 +# Changes between 0.56 and 0.561: +# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) +# - used new B.pm symbolic constants (done by Nick Ing-Simmons) +# Changes between 0.561 and 0.57: +# - stylistic changes to symbolic constant stuff +# - handled scope in s///e replacement code +# - added unquote option for expanding "" into concats, etc. +# - split method and proto parts of pp_entersub into separate functions +# - various minor cleanups +# Changes after 0.57: +# - added parens in \&foo (patch by Albert Dvornik) +# Changes between 0.57 and 0.58: +# - fixed `0' statements that weren't being printed +# - added methods for use from other programs +# (based on patches from James Duncan and Hugo van der Sanden) +# - added -si and -sT to control indenting (also based on a patch from Hugo) +# - added -sv to print something else instead of '???' +# - preliminary version of utf8 tr/// handling +# Changes after 0.58: +# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) +# - added support for Hugo's new OP_SETSTATE (like nextstate) +# Changes between 0.58 and 0.59 +# - added support for Chip's OP_METHOD_NAMED +# - added support for Ilya's OPpTARGET_MY optimization +# - elided arrows before `()' subscripts when possible # Todo: +# - finish tr/// changes +# - add option for even more parens (generalize \&foo change) # - {} around variables in strings ("${var}letters") # base/lex.t 25-27 # comp/term.t 11 -# - generate symbolic constants directly from core source # - left/right context +# - recognize `use utf8', `use integer', etc +# - treat top-level block specially for incremental output +# - interpret in high bit chars in string as utf8 \x{...} (when?) +# - copy comments (look at real text with $^P?) # - avoid semis in one-statement blocks # - associativity of &&=, ||=, ?: # - ',' => '=>' (auto-unquote?) # - break long lines ("\r" as discretionary break?) +# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. +# - more style options: brace style, hex vs. octal, quotes, ... +# - print big ints as hex/octal instead of decimal (heuristic?) +# - handle `my $x if 0'? # - include values of variables (e.g. set in BEGIN) # - coordinate with Data::Dumper (both directions? see previous) # - version using op_next instead of op_first/sibling? @@ -103,7 +145,11 @@ use strict; # # parens: -p # linenums: -l +# unquote: -q # cuddle: ` ' or `\n', depending on -sC +# indent_size: -si +# use_tabs: -sT +# ex_const: -sv # A little explanation of how precedence contexts and associativity # work: @@ -182,13 +228,10 @@ sub next_todo { return "format $name =\n" . $self->deparse_format($ent->[1]->FORM). "\n"; } else { - return "sub $name " . - $self->deparse_sub($ent->[1]->CV); + return "sub $name " . $self->deparse_sub($ent->[1]->CV); } } -sub OPf_KIDS () { 4 } - sub walk_tree { my($op, $sub) = @_; $sub->($op); @@ -208,19 +251,20 @@ sub walk_sub { return if !$op or null $op; walk_tree($op, sub { my $op = shift; - if ($op->ppaddr eq "pp_gv") { - if ($op->next->ppaddr eq "pp_entersub") { - next if $self->{'subs_done'}{$ {$op->gv}}++; - next if class($op->gv->CV) eq "SPECIAL"; - $self->todo($op->gv, $op->gv->CV, 0); - $self->walk_sub($op->gv->CV); - } elsif ($op->next->ppaddr eq "pp_enterwrite" - or ($op->next->ppaddr eq "pp_rv2gv" - and $op->next->next->ppaddr eq "pp_enterwrite")) { - next if $self->{'forms_done'}{$ {$op->gv}}++; - next if class($op->gv->FORM) eq "SPECIAL"; - $self->todo($op->gv, $op->gv->FORM, 1); - $self->walk_sub($op->gv->FORM); + if ($op->name eq "gv") { + my $gv = $self->maybe_padgv($op); + if ($op->next->name eq "entersub") { + next if $self->{'subs_done'}{$$gv}++; + next if class($gv->CV) eq "SPECIAL"; + $self->todo($gv, $gv->CV, 0); + $self->walk_sub($gv->CV); + } elsif ($op->next->name eq "enterwrite" + or ($op->next->name eq "rv2gv" + and $op->next->next->name eq "enterwrite")) { + next if $self->{'forms_done'}{$$gv}++; + next if class($gv->FORM) eq "SPECIAL"; + $self->todo($gv, $gv->FORM, 1); + $self->walk_sub($gv->FORM); } } }); @@ -279,37 +323,57 @@ sub style_opts { while (length($opt = substr($opts, 0, 1))) { if ($opt eq "C") { $self->{'cuddle'} = " "; + $opts = substr($opts, 1); + } elsif ($opt eq "i") { + $opts =~ s/^i(\d+)//; + $self->{'indent_size'} = $1; + } elsif ($opt eq "T") { + $self->{'use_tabs'} = 1; + $opts = substr($opts, 1); + } elsif ($opt eq "v") { + $opts =~ s/^v([^.]*)(.|$)//; + $self->{'ex_const'} = $1; } - $opts = substr($opts, 1); } } +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->{'subs_todo'} = []; + $self->{'curstash'} = "main"; + $self->{'cuddle'} = "\n"; + $self->{'indent_size'} = 4; + $self->{'use_tabs'} = 0; + $self->{'ex_const'} = "'???'"; + while (my $arg = shift @_) { + if (substr($arg, 0, 2) eq "-u") { + $self->stash_subs(substr($arg, 2)); + } elsif ($arg eq "-p") { + $self->{'parens'} = 1; + } elsif ($arg eq "-l") { + $self->{'linenums'} = 1; + } elsif ($arg eq "-q") { + $self->{'unquote'} = 1; + } elsif (substr($arg, 0, 2) eq "-s") { + $self->style_opts(substr $arg, 2); + } + } + return $self; +} + sub compile { my(@args) = @_; return sub { - my $self = bless {}; - my $arg; - $self->{'subs_todo'} = []; + my $self = B::Deparse->new(@args); $self->stash_subs("main"); $self->{'curcv'} = main_cv; - $self->{'curstash'} = "main"; - $self->{'cuddle'} = "\n"; - while ($arg = shift @args) { - if (substr($arg, 0, 2) eq "-u") { - $self->stash_subs(substr($arg, 2)); - } elsif ($arg eq "-p") { - $self->{'parens'} = 1; - } elsif ($arg eq "-l") { - $self->{'linenums'} = 1; - } elsif (substr($arg, 0, 2) eq "-s") { - $self->style_opts(substr $arg, 2); - } - } $self->walk_sub(main_cv, main_start); print $self->print_protos; @{$self->{'subs_todo'}} = - sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; - print indent($self->deparse(main_root, 0)), "\n" unless null main_root; + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; + print $self->indent($self->deparse(main_root, 0)), "\n" + unless null main_root; my @text; while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; @@ -318,25 +382,38 @@ sub compile { } } +sub coderef2text { + my $self = shift; + my $sub = shift; + croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE"; + return $self->indent($self->deparse_sub(svref_2object($sub))); +} + sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; - my $meth = $op->ppaddr; +# return $self->$ {\("pp_" . $op->name)}($op, $cx); + my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); } sub indent { + my $self = shift; my $txt = shift; my @lines = split(/\n/, $txt); my $leader = ""; + my $level = 0; my $line; for $line (@lines) { - if (substr($line, 0, 1) eq "\t") { - $leader = $leader . " "; - $line = substr($line, 1); - } elsif (substr($line, 0, 1) eq "\b") { - $leader = substr($leader, 0, length($leader) - 4); + my $cmd = substr($line, 0, 1); + if ($cmd eq "\t" or $cmd eq "\b") { + $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; + if ($self->{'use_tabs'}) { + $leader = "\t" x ($level / 8) . " " x ($level % 8); + } else { + $leader = " " x $level; + } $line = substr($line, 1); } if (substr($line, 0, 1) eq "\f") { @@ -349,8 +426,6 @@ sub indent { return join("\n", @lines); } -sub SVf_POK () {0x40000} - sub deparse_sub { my $self = shift; my $cv = shift; @@ -382,7 +457,7 @@ sub deparse_format { $op = $op->sibling; # skip nextstate my @exprs; $kid = $op->first->sibling; # skip pushmark - push @text, $kid->sv->PV; + push @text, $self->const_sv($kid)->PV; $kid = $kid->sibling; for (; not null $kid; $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 0); @@ -393,47 +468,38 @@ sub deparse_format { return join("", @text) . "."; } -# the aassign in-common check messes up SvCUR (always setting it -# to a value >= 100), but it's probably safe to assume there -# won't be any NULs in the names of my() variables. (with -# stash variables, I wouldn't be so sure) -sub padname_fix { - my $str = shift; - $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; - return $str; -} - sub is_scope { my $op = shift; - return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope" - || $op->ppaddr eq "pp_lineseq" - || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP" - && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter")); + return $op->name eq "leave" || $op->name eq "scope" + || $op->name eq "lineseq" + || ($op->name eq "null" && class($op) eq "UNOP" + && (is_scope($op->first) || $op->first->name eq "enter")); } sub is_state { - my $name = $_[0]->ppaddr; - return $name eq "pp_nextstate" || $name eq "pp_dbstate"; + my $name = $_[0]->name; + return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; } sub is_miniwhile { # check for one-line loop (`foo() while $y--') my $op = shift; return (!null($op) and null($op->sibling) - and $op->ppaddr eq "pp_null" and class($op) eq "UNOP" - and (($op->first->ppaddr =~ /^pp_(and|or)$/ - and $op->first->first->sibling->ppaddr eq "pp_lineseq") - or ($op->first->ppaddr eq "pp_lineseq" + and $op->name eq "null" and class($op) eq "UNOP" + and (($op->first->name =~ /^(and|or)$/ + and $op->first->first->sibling->name eq "lineseq") + or ($op->first->name eq "lineseq" and not null $op->first->first->sibling - and $op->first->first->sibling->ppaddr eq "pp_unstack") + and $op->first->first->sibling->name eq "unstack") )); } sub is_scalar { my $op = shift; - return ($op->ppaddr eq "pp_rv2sv" or - $op->ppaddr eq "pp_padsv" or - $op->ppaddr eq "pp_gv" or # only in array/hash constructs - !null($op->first) && $op->first->ppaddr eq "pp_gvsv"); + return ($op->name eq "rv2sv" or + $op->name eq "padsv" or + $op->name eq "gv" or # only in array/hash constructs + $op->flags & OPf_KIDS && !null($op->first) + && $op->first->name eq "gvsv"); } sub maybe_parens { @@ -483,18 +549,28 @@ sub maybe_parens_func { } } -sub OPp_LVAL_INTRO () { 128 } - sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; - if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { return $self->maybe_parens_func("local", $text, $cx, 16); } else { return $text; } } +sub maybe_targmy { + my $self = shift; + my($op, $cx, $func, @args) = @_; + if ($op->private & OPpTARGET_MY) { + my $var = $self->padname($op->targ); + my $val = $func->($self, $op, 7, @args); + return $self->maybe_parens("$var = $val", $cx, 7); + } else { + return $func->($self, $op, $cx, @args); + } +} + sub padname_sv { my $self = shift; my $targ = shift; @@ -504,7 +580,7 @@ sub padname_sv { sub maybe_my { my $self = shift; my($op, $cx, $text) = @_; - if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { return $self->maybe_parens_func("my", $text, $cx, 16); } else { return $text; @@ -606,10 +682,10 @@ sub pp_leave { $kid = $op->first->sibling; # skip enter if (is_miniwhile($kid)) { my $top = $kid->first; - my $name = $top->ppaddr; - if ($name eq "pp_and") { + my $name = $top->name; + if ($name eq "and") { $name = "while"; - } elsif ($name eq "pp_or") { + } elsif ($name eq "or") { $name = "until"; } else { # no conditional -> while 1 or until 0 return $self->deparse($top->first, 1) . " while 1"; @@ -628,7 +704,7 @@ sub pp_leave { last if null $kid; } $expr .= $self->deparse($kid, 0); - push @exprs, $expr if $expr; + push @exprs, $expr if length $expr; } if ($cx > 0) { # inside an expression return "do { " . join(";\n", @exprs) . " }"; @@ -650,7 +726,7 @@ sub pp_scope { last if null $kid; } $expr .= $self->deparse($kid, 0); - push @exprs, $expr if $expr; + push @exprs, $expr if length $expr; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) return "do { " . join(";\n", @exprs) . " }"; @@ -696,19 +772,20 @@ sub pp_nextstate { and $seq > $self->{'subs_todo'}[0][0]) { push @text, $self->next_todo; } - my $stash = $op->stash->NAME; + my $stash = $op->stashpv; if ($stash ne $self->{'curstash'}) { push @text, "package $stash;\n"; $self->{'curstash'} = $stash; } if ($self->{'linenums'}) { push @text, "\f#line " . $op->line . - ' "' . substr($op->filegv->NAME, 2), qq'"\n'; + ' "' . $op->file, qq'"\n'; } return join("", @text); } sub pp_dbstate { pp_nextstate(@_) } +sub pp_setstate { pp_nextstate(@_) } sub pp_unstack { return "" } # see also leaveloop @@ -721,9 +798,9 @@ sub baseop { sub pp_stub { baseop(@_, "()") } sub pp_wantarray { baseop(@_, "wantarray") } sub pp_fork { baseop(@_, "fork") } -sub pp_wait { baseop(@_, "wait") } -sub pp_getppid { baseop(@_, "getppid") } -sub pp_time { baseop(@_, "time") } +sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } +sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } +sub pp_time { maybe_targmy(@_, \&baseop, "time") } sub pp_tms { baseop(@_, "times") } sub pp_ghostent { baseop(@_, "gethostent") } sub pp_gnetent { baseop(@_, "getnetent") } @@ -757,18 +834,19 @@ sub pfixop { sub pp_preinc { pfixop(@_, "++", 23) } sub pp_predec { pfixop(@_, "--", 23) } -sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) } -sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) } +sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } sub pp_i_preinc { pfixop(@_, "++", 23) } sub pp_i_predec { pfixop(@_, "--", 23) } -sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) } -sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) } -sub pp_complement { pfixop(@_, "~", 21) } +sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } +sub pp_complement { maybe_targmy(@_. \&pfixop, "~", 21) } -sub pp_negate { +sub pp_negate { maybe_targmy(@_, \&real_negate) } +sub real_negate { my $self = shift; my($op, $cx) = @_; - if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) { + if ($op->first->name =~ /^(i_)?negate$/) { # avoid --$x $self->pfixop($op, $cx, "-", 21.5); } else { @@ -787,11 +865,9 @@ sub pp_not { } } -sub OPf_SPECIAL () { 128 } - sub unop { my $self = shift; - my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my($op, $cx, $name) = @_; my $kid; if ($op->flags & OPf_KIDS) { $kid = $op->first; @@ -801,36 +877,31 @@ sub unop { } } -sub pp_chop { unop(@_, "chop") } -sub pp_chomp { unop(@_, "chomp") } -sub pp_schop { unop(@_, "chop") } -sub pp_schomp { unop(@_, "chomp") } +sub pp_chop { maybe_targmy(@_, \&unop, "chop") } +sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } +sub pp_schop { maybe_targmy(@_, \&unop, "chop") } +sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } sub pp_defined { unop(@_, "defined") } sub pp_undef { unop(@_, "undef") } sub pp_study { unop(@_, "study") } sub pp_ref { unop(@_, "ref") } sub pp_pos { maybe_local(@_, unop(@_, "pos")) } -sub pp_sin { unop(@_, "sin") } -sub pp_cos { unop(@_, "cos") } -sub pp_rand { unop(@_, "rand") } +sub pp_sin { maybe_targmy(@_, \&unop, "sin") } +sub pp_cos { maybe_targmy(@_, \&unop, "cos") } +sub pp_rand { maybe_targmy(@_, \&unop, "rand") } sub pp_srand { unop(@_, "srand") } -sub pp_exp { unop(@_, "exp") } -sub pp_log { unop(@_, "log") } -sub pp_sqrt { unop(@_, "sqrt") } -sub pp_int { unop(@_, "int") } -sub pp_hex { unop(@_, "hex") } -sub pp_oct { unop(@_, "oct") } -sub pp_abs { unop(@_, "abs") } - -sub pp_length { unop(@_, "length") } -sub pp_ord { unop(@_, "ord") } -sub pp_chr { unop(@_, "chr") } -sub pp_ucfirst { unop(@_, "ucfirst") } -sub pp_lcfirst { unop(@_, "lcfirst") } -sub pp_uc { unop(@_, "uc") } -sub pp_lc { unop(@_, "lc") } -sub pp_quotemeta { unop(@_, "quotemeta") } +sub pp_exp { maybe_targmy(@_, \&unop, "exp") } +sub pp_log { maybe_targmy(@_, \&unop, "log") } +sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } +sub pp_int { maybe_targmy(@_, \&unop, "int") } +sub pp_hex { maybe_targmy(@_, \&unop, "hex") } +sub pp_oct { maybe_targmy(@_, \&unop, "oct") } +sub pp_abs { maybe_targmy(@_, \&unop, "abs") } + +sub pp_length { maybe_targmy(@_, \&unop, "length") } +sub pp_ord { maybe_targmy(@_, \&unop, "ord") } +sub pp_chr { maybe_targmy(@_, \&unop, "chr") } sub pp_each { unop(@_, "each") } sub pp_values { unop(@_, "values") } @@ -856,19 +927,19 @@ sub pp_tell { unop(@_, "tell") } sub pp_getsockname { unop(@_, "getsockname") } sub pp_getpeername { unop(@_, "getpeername") } -sub pp_chdir { unop(@_, "chdir") } -sub pp_chroot { unop(@_, "chroot") } +sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } +sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } sub pp_readlink { unop(@_, "readlink") } -sub pp_rmdir { unop(@_, "rmdir") } +sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } sub pp_readdir { unop(@_, "readdir") } sub pp_telldir { unop(@_, "telldir") } sub pp_rewinddir { unop(@_, "rewinddir") } sub pp_closedir { unop(@_, "closedir") } -sub pp_getpgrp { unop(@_, "getpgrp") } +sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } sub pp_localtime { unop(@_, "localtime") } sub pp_gmtime { unop(@_, "gmtime") } sub pp_alarm { unop(@_, "alarm") } -sub pp_sleep { unop(@_, "sleep") } +sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } sub pp_dofile { unop(@_, "do") } sub pp_entereval { unop(@_, "eval") } @@ -894,8 +965,6 @@ sub pp_exists { $cx, 16); } -sub OPpSLICE () { 64 } - sub pp_delete { my $self = shift; my($op, $cx) = @_; @@ -911,15 +980,13 @@ sub pp_delete { } } -sub OPp_CONST_BARE () { 64 } - sub pp_require { my $self = shift; my($op, $cx) = @_; - if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const" - and $op->first->private & OPp_CONST_BARE) + if (class($op) eq "UNOP" and $op->first->name eq "const" + and $op->first->private & OPpCONST_BARE) { - my $name = $op->first->sv->PV; + my $name = $self->const_sv($op->first)->PV; $name =~ s[/][::]g; $name =~ s/\.pm//g; return "require($name)"; @@ -943,20 +1010,19 @@ sub pp_scalar { sub padval { my $self = shift; my $targ = shift; + #cluck "curcv was undef" unless $self->{curcv}; return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ]; } -sub OPf_REF () { 16 } - sub pp_refgen { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - if ($kid->ppaddr eq "pp_null") { + if ($kid->name eq "null") { $kid = $kid->first; - if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") { - my($pre, $post) = @{{"pp_anonlist" => ["[","]"], - "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}}; + if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { + my($pre, $post) = @{{"anonlist" => ["[","]"], + "anonhash" => ["{","}"]}->{$kid->name}}; my($expr, @exprs); $kid = $kid->first->sibling; # skip pushmark for (; !null($kid); $kid = $kid->sibling) { @@ -965,16 +1031,25 @@ sub pp_refgen { } return $pre . join(", ", @exprs) . $post; } elsif (!null($kid->sibling) and - $kid->sibling->ppaddr eq "pp_anoncode") { + $kid->sibling->name eq "anoncode") { return "sub " . $self->deparse_sub($self->padval($kid->sibling->targ)); - } elsif ($kid->ppaddr eq "pp_pushmark" - and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/ - and not $kid->sibling->flags & OPf_REF) { - # The @a in \(@a) isn't in ref context, but only when the - # parens are there. - return "\\(" . $self->deparse($kid->sibling, 1) . ")"; - } + } elsif ($kid->name eq "pushmark") { + my $sib_name = $kid->sibling->name; + if ($sib_name =~ /^(pad|rv2)[ah]v$/ + and not $kid->sibling->flags & OPf_REF) + { + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + return "\\(" . $self->deparse($kid->sibling, 1) . ")"; + } elsif ($sib_name eq 'entersub') { + my $text = $self->deparse($kid->sibling, 1); + # Always show parens for \(&func()), but only with -p otherwise + $text = "($text)" if $self->{'parens'} + or $kid->sibling->private & OPpENTERSUB_AMPER; + return "\\$text"; + } + } } $self->pfixop($op, $cx, "\\", 20); } @@ -985,13 +1060,31 @@ sub pp_readline { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh> - if ($kid->ppaddr eq "pp_rv2gv") { - $kid = $kid->first; - } + $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> return "<" . $self->deparse($kid, 1) . ">"; } +# Unary operators that can occur as pseudo-listops inside double quotes +sub dq_unop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + # If there's more than one kid, the first is an ex-pushmark. + $kid = $kid->sibling if not null $kid->sibling; + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + } +} + +sub pp_ucfirst { dq_unop(@_, "ucfirst") } +sub pp_lcfirst { dq_unop(@_, "lcfirst") } +sub pp_uc { dq_unop(@_, "uc") } +sub pp_lc { dq_unop(@_, "lc") } +sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } + sub loopex { my $self = shift; my ($op, $cx, $name) = @_; @@ -1019,7 +1112,7 @@ sub ftst { # Genuine `-X' filetests are exempt from the LLAFR, but not # l?stat(); for the sake of clarity, give'em all parens return $self->maybe_parens_unop($name, $op->first, $cx); - } elsif (class($op) eq "GVOP") { + } elsif (class($op) eq "SVOP") { return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); } else { # I don't think baseop filetests ever survive ck_ftst, but... return $name; @@ -1059,19 +1152,17 @@ sub pp_ftbinary { ftst(@_, "-B") } sub SWAP_CHILDREN () { 1 } sub ASSIGN () { 2 } # has OP= variant -sub OPf_STACKED () { 64 } - my(%left, %right); sub assoc_class { my $op = shift; - my $name = $op->ppaddr; - if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") { + my $name = $op->name; + if ($name eq "concat" and $op->first->name eq "concat") { # avoid spurious `=' -- see comment in pp_concat - return "pp_concat"; + return "concat"; } - if ($name eq "pp_null" and class($op) eq "UNOP" - and $op->first->ppaddr =~ /^pp_(and|x?or)$/ + if ($name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|x?or)$/ and null $op->first->sibling) { # Like all conditional constructs, OP_ANDs and OP_ORs are topped @@ -1088,25 +1179,25 @@ sub assoc_class { # $a + $b + $c is equivalent to ($a + $b) + $c BEGIN { - %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19, - 'pp_divide' => 19, 'pp_i_divide' => 19, - 'pp_modulo' => 19, 'pp_i_modulo' => 19, - 'pp_repeat' => 19, - 'pp_add' => 18, 'pp_i_add' => 18, - 'pp_subtract' => 18, 'pp_i_subtract' => 18, - 'pp_concat' => 18, - 'pp_left_shift' => 17, 'pp_right_shift' => 17, - 'pp_bit_and' => 13, - 'pp_bit_or' => 12, 'pp_bit_xor' => 12, - 'pp_and' => 3, - 'pp_or' => 2, 'pp_xor' => 2, + %left = ('multiply' => 19, 'i_multiply' => 19, + 'divide' => 19, 'i_divide' => 19, + 'modulo' => 19, 'i_modulo' => 19, + 'repeat' => 19, + 'add' => 18, 'i_add' => 18, + 'subtract' => 18, 'i_subtract' => 18, + 'concat' => 18, + 'left_shift' => 17, 'right_shift' => 17, + 'bit_and' => 13, + 'bit_or' => 12, 'bit_xor' => 12, + 'and' => 3, + 'or' => 2, 'xor' => 2, ); } sub deparse_binop_left { my $self = shift; my($op, $left, $prec) = @_; - if ($left{assoc_class($op)} + if ($left{assoc_class($op)} && $left{assoc_class($left)} and $left{assoc_class($op)} == $left{assoc_class($left)}) { return $self->deparse($left, $prec - .00001); @@ -1119,27 +1210,27 @@ sub deparse_binop_left { # $a = $b = $c is equivalent to $a = ($b = $c) BEGIN { - %right = ('pp_pow' => 22, - 'pp_sassign=' => 7, 'pp_aassign=' => 7, - 'pp_multiply=' => 7, 'pp_i_multiply=' => 7, - 'pp_divide=' => 7, 'pp_i_divide=' => 7, - 'pp_modulo=' => 7, 'pp_i_modulo=' => 7, - 'pp_repeat=' => 7, - 'pp_add=' => 7, 'pp_i_add=' => 7, - 'pp_subtract=' => 7, 'pp_i_subtract=' => 7, - 'pp_concat=' => 7, - 'pp_left_shift=' => 7, 'pp_right_shift=' => 7, - 'pp_bit_and=' => 7, - 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7, - 'pp_andassign' => 7, - 'pp_orassign' => 7, + %right = ('pow' => 22, + 'sassign=' => 7, 'aassign=' => 7, + 'multiply=' => 7, 'i_multiply=' => 7, + 'divide=' => 7, 'i_divide=' => 7, + 'modulo=' => 7, 'i_modulo=' => 7, + 'repeat=' => 7, + 'add=' => 7, 'i_add=' => 7, + 'subtract=' => 7, 'i_subtract=' => 7, + 'concat=' => 7, + 'left_shift=' => 7, 'right_shift=' => 7, + 'bit_and=' => 7, + 'bit_or=' => 7, 'bit_xor=' => 7, + 'andassign' => 7, + 'orassign' => 7, ); } sub deparse_binop_right { my $self = shift; my($op, $right, $prec) = @_; - if ($right{assoc_class($op)} + if ($right{assoc_class($op)} && $right{assoc_class($right)} and $right{assoc_class($op)} == $right{assoc_class($right)}) { return $self->deparse($right, $prec - .00001); @@ -1166,23 +1257,23 @@ sub binop { return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); } -sub pp_add { binop(@_, "+", 18, ASSIGN) } -sub pp_multiply { binop(@_, "*", 19, ASSIGN) } -sub pp_subtract { binop(@_, "-",18, ASSIGN) } -sub pp_divide { binop(@_, "/", 19, ASSIGN) } -sub pp_modulo { binop(@_, "%", 19, ASSIGN) } -sub pp_i_add { binop(@_, "+", 18, ASSIGN) } -sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) } -sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) } -sub pp_i_divide { binop(@_, "/", 19, ASSIGN) } -sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) } -sub pp_pow { binop(@_, "**", 22, ASSIGN) } - -sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) } -sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) } -sub pp_bit_and { binop(@_, "&", 13, ASSIGN) } -sub pp_bit_or { binop(@_, "|", 12, ASSIGN) } -sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) } +sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } +sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } +sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } + +sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } +sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } +sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } +sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } +sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } sub pp_eq { binop(@_, "==", 14) } sub pp_ne { binop(@_, "!=", 14) } @@ -1213,14 +1304,15 @@ sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) } # `.' is special because concats-of-concats are optimized to save copying # by making all but the first concat stacked. The effect is as if the # programmer had written `($a . $b) .= $c', except legal. -sub pp_concat { +sub pp_concat { maybe_targmy(@_, \&real_concat) } +sub real_concat { my $self = shift; my($op, $cx) = @_; my $left = $op->first; my $right = $op->last; my $eq = ""; my $prec = 18; - if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") { + if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { $eq = "="; $prec = 7; } @@ -1301,7 +1393,10 @@ sub logop { } sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } -sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } +sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } + +# xor is syntactically a logop, but it's really a binop (contrary to +# old versions of opcode.pl). Syntax is what matters here. sub pp_xor { logop(@_, "xor", 2, "", 0, "") } sub logassignop { @@ -1339,20 +1434,20 @@ sub listop { } sub pp_bless { listop(@_, "bless") } -sub pp_atan2 { listop(@_, "atan2") } +sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } sub pp_substr { maybe_local(@_, listop(@_, "substr")) } sub pp_vec { maybe_local(@_, listop(@_, "vec")) } -sub pp_index { listop(@_, "index") } -sub pp_rindex { listop(@_, "rindex") } -sub pp_sprintf { listop(@_, "sprintf") } +sub pp_index { maybe_targmy(@_, \&listop, "index") } +sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } +sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } sub pp_formline { listop(@_, "formline") } # see also deparse_format -sub pp_crypt { listop(@_, "crypt") } +sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } sub pp_unpack { listop(@_, "unpack") } sub pp_pack { listop(@_, "pack") } -sub pp_join { listop(@_, "join") } +sub pp_join { maybe_targmy(@_, \&listop, "join") } sub pp_splice { listop(@_, "splice") } -sub pp_push { listop(@_, "push") } -sub pp_unshift { listop(@_, "unshift") } +sub pp_push { maybe_targmy(@_, \&listop, "push") } +sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } sub pp_reverse { listop(@_, "reverse") } sub pp_warn { listop(@_, "warn") } sub pp_die { listop(@_, "die") } @@ -1375,7 +1470,7 @@ sub pp_recv { listop(@_, "recv") } sub pp_seek { listop(@_, "seek") } sub pp_fcntl { listop(@_, "fcntl") } sub pp_ioctl { listop(@_, "ioctl") } -sub pp_flock { listop(@_, "flock") } +sub pp_flock { maybe_targmy(@_, \&listop, "flock") } sub pp_socket { listop(@_, "socket") } sub pp_sockpair { listop(@_, "sockpair") } sub pp_bind { listop(@_, "bind") } @@ -1385,23 +1480,23 @@ sub pp_accept { listop(@_, "accept") } sub pp_shutdown { listop(@_, "shutdown") } sub pp_gsockopt { listop(@_, "getsockopt") } sub pp_ssockopt { listop(@_, "setsockopt") } -sub pp_chown { listop(@_, "chown") } -sub pp_unlink { listop(@_, "unlink") } -sub pp_chmod { listop(@_, "chmod") } -sub pp_utime { listop(@_, "utime") } -sub pp_rename { listop(@_, "rename") } -sub pp_link { listop(@_, "link") } -sub pp_symlink { listop(@_, "symlink") } -sub pp_mkdir { listop(@_, "mkdir") } +sub pp_chown { maybe_targmy(@_, \&listop, "chown") } +sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } +sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } +sub pp_utime { maybe_targmy(@_, \&listop, "utime") } +sub pp_rename { maybe_targmy(@_, \&listop, "rename") } +sub pp_link { maybe_targmy(@_, \&listop, "link") } +sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } +sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } sub pp_open_dir { listop(@_, "opendir") } sub pp_seekdir { listop(@_, "seekdir") } -sub pp_waitpid { listop(@_, "waitpid") } -sub pp_system { listop(@_, "system") } -sub pp_exec { listop(@_, "exec") } -sub pp_kill { listop(@_, "kill") } -sub pp_setpgrp { listop(@_, "setpgrp") } -sub pp_getpriority { listop(@_, "getpriority") } -sub pp_setpriority { listop(@_, "setpriority") } +sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } +sub pp_system { maybe_targmy(@_, \&listop, "system") } +sub pp_exec { maybe_targmy(@_, \&listop, "exec") } +sub pp_kill { maybe_targmy(@_, \&listop, "kill") } +sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } +sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } +sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } sub pp_shmget { listop(@_, "shmget") } sub pp_shmctl { listop(@_, "shmctl") } sub pp_shmread { listop(@_, "shmread") } @@ -1442,10 +1537,10 @@ sub pp_truncate { my(@exprs); my $parens = ($cx >= 5) || $self->{'parens'}; my $kid = $op->first->sibling; - my($fh, $len); + my $fh; if ($op->flags & OPf_SPECIAL) { # $kid is an OP_CONST - $fh = $kid->sv->PV; + $fh = $self->const_sv($kid)->PV; } else { $fh = $self->deparse($kid, 6); $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; @@ -1456,7 +1551,6 @@ sub pp_truncate { } else { return "truncate $fh, $len"; } - } sub indirop { @@ -1480,8 +1574,7 @@ sub indirop { $expr = $self->deparse($kid, 6); push @exprs, $expr; } - return $self->maybe_parens_func($name, - $indir . join(", ", @exprs), + return $self->maybe_parens_func($name, $indir . join(", ", @exprs), $cx, 5); } @@ -1497,7 +1590,7 @@ sub mapop { $kid = $kid->first->sibling; # skip a pushmark my $code = $kid->first; # skip a null if (is_scope $code) { - $code = "{" . $self->deparse($code, 1) . "} "; + $code = "{" . $self->deparse($code, 0) . "} "; } else { $code = $self->deparse($code, 24) . ", "; } @@ -1523,15 +1616,15 @@ sub pp_list { # This assumes that no other private flags equal 128, and that # OPs that store things other than flags in their op_private, # like OP_AELEMFAST, won't be immediate children of a list. - unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef") + unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef") { $local = ""; # or not last; } - if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my() + if ($lop->name =~ /^pad[ash]v$/) { # my() ($local = "", last) if $local eq "local"; $local = "my"; - } elsif ($lop->ppaddr ne "pp_undef") { # local() + } elsif ($lop->name ne "undef") { # local() ($local = "", last) if $local eq "my"; $local = "local"; } @@ -1540,7 +1633,7 @@ sub pp_list { return $self->deparse($kid, $cx) if null $kid->sibling and not $local; for (; !null($kid); $kid = $kid->sibling) { if ($local) { - if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") { + if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { $lop = $kid->first; } else { $lop = $kid; @@ -1575,10 +1668,10 @@ sub pp_cond_expr { } $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif + if ($false->name eq "lineseq") { # braces w/o scope => elsif my $head = "if ($cond) {\n\t$true\n\b}"; my @elsifs; - while (!null($false) and $false->ppaddr eq "pp_lineseq") { + while (!null($false) and $false->name eq "lineseq") { my $newop = $false->first->sibling->first; my $newcond = $newop->first; my $newtrue = $newcond->sibling; @@ -1607,13 +1700,13 @@ sub pp_leaveloop { local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; - if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop + if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) } else { $bare = 1; } - } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach + } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; if ($enter->flags & OPf_STACKED @@ -1638,20 +1731,20 @@ sub pp_leaveloop { $var = "my " . $var; } } - } elsif ($var->ppaddr eq "pp_rv2gv") { + } elsif ($var->name eq "rv2gv") { $var = $self->pp_rv2sv($var, 1); - } elsif ($var->ppaddr eq "pp_gv") { + } elsif ($var->name eq "gv") { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER - } elsif ($kid->ppaddr eq "pp_null") { # while/until + } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"pp_and" => "while", "pp_or" => "until"} - ->{$kid->ppaddr}; + my $name = {"and" => "while", "or" => "until"} + ->{$kid->name}; $head = "$name (" . $self->deparse($kid->first, 1) . ") "; $kid = $kid->first->sibling; - } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty + } elsif ($kid->name eq "stub") { # bare and empty return "{;}"; # {} could be a hashref } # The third-to-last kid is the continue block if the pointer used @@ -1663,15 +1756,14 @@ sub pp_leaveloop { # (because it's a nulled out nextstate in a scope), in which # case the head's next is advanced past the null but the nextop's # isn't, so we need to try nextop->next. - my($cont, $precont); + my $precont; + my $cont = $kid->first; if ($bare) { - $cont = $kid->first; while (!null($cont->sibling)) { $precont = $cont; $cont = $cont->sibling; } } else { - $cont = $kid->first; while (!null($cont->sibling->sibling->sibling)) { $precont = $cont; $cont = $cont->sibling; @@ -1708,30 +1800,29 @@ sub pp_leavetry { return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; } -sub OP_CONST () { 5 } - -# XXX need a better way to do this -sub OP_STRINGIFY () { $] > 5.004_72 ? 67 : 65 } +BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } +BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } sub pp_null { my $self = shift; my($op, $cx) = @_; if (class($op) eq "OP") { - return "'???'" if $op->targ == OP_CONST; # old value is lost - } elsif ($op->first->ppaddr eq "pp_pushmark") { + # old value is lost + return $self->{'ex_const'} if $op->targ == OP_CONST; + } elsif ($op->first->name eq "pushmark") { return $self->pp_list($op, $cx); - } elsif ($op->first->ppaddr eq "pp_enter") { + } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { return $self->dquote($op); } elsif (!null($op->first->sibling) and - $op->first->sibling->ppaddr eq "pp_readline" and + $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 7) . " = " . $self->deparse($op->first->sibling, 7), $cx, 7); } elsif (!null($op->first->sibling) and - $op->first->sibling->ppaddr eq "pp_trans" and + $op->first->sibling->name eq "trans" and $op->first->sibling->flags & OPf_STACKED) { return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " . $self->deparse($op->first->sibling, 20), @@ -1741,6 +1832,16 @@ sub pp_null { } } +# the aassign in-common check messes up SvCUR (always setting it +# to a value >= 100), but it's probably safe to assume there +# won't be any NULs in the names of my() variables. (with +# stash variables, I wouldn't be so sure) +sub padname_fix { + my $str = shift; + $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1; + return $str; +} + sub padname { my $self = shift; my $targ = shift; @@ -1778,22 +1879,37 @@ sub pp_threadsv { return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } +sub maybe_padgv { + my $self = shift; + my $op = shift; + my $gv; + if ($Config{useithreads}) { + $gv = $self->padval($op->padix); + } + else { + $gv = $op->gv; + } + return $gv; +} + sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv)); + my $gv = $self->maybe_padgv($op); + return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - return $self->gv_name($op->gv); + my $gv = $self->maybe_padgv($op); + return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $op->gv; + my $gv = $self->maybe_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -1813,7 +1929,7 @@ sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } sub pp_av2arylen { my $self = shift; my($op, $cx) = @_; - if ($op->first->ppaddr eq "pp_padav") { + if ($op->first->name eq "padav") { return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); } else { return $self->maybe_local($op, $cx, @@ -1828,23 +1944,41 @@ sub pp_rv2av { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - if ($kid->ppaddr eq "pp_const") { # constant list - my $av = $kid->sv; + if ($kid->name eq "const") { # constant list + my $av = $self->const_sv($kid); return "(" . join(", ", map(const($_), $av->ARRAY)) . ")"; } else { return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); } } +sub is_subscriptable { + my $op = shift; + if ($op->name =~ /^[ahg]elem/) { + return 1; + } elsif ($op->name eq "entersub") { + my $kid = $op->first; + return 0 unless null $kid->sibling; + $kid = $kid->first; + $kid = $kid->sibling until null $kid->sibling; + return 0 if is_scope($kid); + $kid = $kid->first; + return 0 if $kid->name eq "gv"; + return 0 if is_scalar($kid); + return is_subscriptable($kid); + } else { + return 0; + } +} sub elem { my $self = shift; my ($op, $cx, $left, $right, $padname) = @_; my($array, $idx) = ($op->first, $op->first->sibling); - unless ($array->ppaddr eq $padname) { # Maybe this has been fixed + unless ($array->name eq $padname) { # Maybe this has been fixed $array = $array->first; # skip rv2av (or ex-rv2av in _53+) } - if ($array->ppaddr eq $padname) { + if ($array->name eq $padname) { $array = $self->padany($array); } elsif (is_scope($array)) { # ${expr}[0] $array = "{" . $self->deparse($array, 0) . "}"; @@ -1852,8 +1986,7 @@ sub elem { $array = $self->deparse($array, 24); } else { # $x[20][3]{hi} or expr->[20] - my $arrow; - $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/; + my $arrow = is_subscriptable($array) ? "" : "->"; return $self->deparse($array, 24) . $arrow . $left . $self->deparse($idx, 1) . $right; } @@ -1861,15 +1994,15 @@ sub elem { return "\$" . $array . $left . $idx . $right; } -sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) } -sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) } +sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } +sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } sub pp_gelem { my $self = shift; my($op, $cx) = @_; my($glob, $part) = ($op->first, $op->last); $glob = $glob->first; # skip rv2gv - $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug + $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug my $scope = is_scope($glob); $glob = $self->deparse($glob, 0); $part = $self->deparse($part, 1); @@ -1889,16 +2022,16 @@ sub slice { } $array = $last; $array = $array->first - if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null"; + if $array->name eq $regname or $array->name eq "null"; if (is_scope($array)) { $array = "{" . $self->deparse($array, 0) . "}"; - } elsif ($array->ppaddr eq $padname) { + } elsif ($array->name eq $padname) { $array = $self->padany($array); } else { $array = $self->deparse($array, 24); } $kid = $op->first->sibling; # skip pushmark - if ($kid->ppaddr eq "pp_list") { + if ($kid->name eq "list") { $kid = $kid->first->sibling; # skip list, pushmark for (; !null $kid; $kid = $kid->sibling) { push @elems, $self->deparse($kid, 6); @@ -1910,10 +2043,8 @@ sub slice { return "\@" . $array . $left . $list . $right; } -sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", - "pp_rv2av", "pp_padav")) } -sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", - "pp_rv2hv", "pp_padhv")) } +sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } +sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } sub pp_lslice { my $self = shift; @@ -1926,48 +2057,153 @@ sub pp_lslice { return "($list)" . "[$idx]"; } -sub OPpENTERSUB_AMPER () { 8 } - -sub OPf_WANT () { 3 } -sub OPf_WANT_VOID () { 1 } -sub OPf_WANT_SCALAR () { 2 } -sub OPf_WANT_LIST () { 2 } - sub want_scalar { my $op = shift; return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; } -sub pp_entersub { +sub want_list { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_LIST; +} + +sub method { my $self = shift; my($op, $cx) = @_; - my $prefix = ""; - my $amper = ""; - my $proto = undef; - my $simple = 0; - my($kid, $args, @exprs); - if (not null $op->first->sibling) { # method - $kid = $op->first->sibling; # skip pushmark - my $obj = $self->deparse($kid, 24); + my $kid = $op->first->sibling; # skip pushmark + my($meth, $obj, @exprs); + if ($kid->name eq "list" and want_list $kid) { + # When an indirect object isn't a bareword but the args are in + # parens, the parens aren't part of the method syntax (the LLAFR + # doesn't apply), but they make a list with OPf_PARENS set that + # doesn't get flattened by the append_elem that adds the method, + # making a (object, arg1, arg2, ...) list where the object + # usually is. This can be distinguished from + # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an + # object) because in the later the list is in scalar context + # as the left side of -> always is, while in the former + # the list is in list context as method arguments always are. + # (Good thing there aren't method prototypes!) + $meth = $kid->sibling; + $kid = $kid->first->sibling; # skip pushmark + $obj = $kid; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + } else { + $obj = $kid; $kid = $kid->sibling; for (; not null $kid->sibling; $kid = $kid->sibling) { push @exprs, $self->deparse($kid, 6); } - my $meth = $kid->first; - if ($meth->ppaddr eq "pp_const") { - $meth = $meth->sv->PV; # needs to be bare + $meth = $kid; + } + $obj = $self->deparse($obj, 24); + if ($meth->name eq "method_named") { + $meth = $self->const_sv($meth)->PV; + } else { + $meth = $meth->first; + if ($meth->name eq "const") { + # As of 5.005_58, this case is probably obsoleted by the + # method_named case above + $meth = $self->const_sv($meth)->PV; # needs to be bare } else { $meth = $self->deparse($meth, 1); } - $args = join(", ", @exprs); - $kid = $obj . "->" . $meth; - if ($args) { - return $kid . "(" . $args . ")"; # parens mandatory + } + my $args = join(", ", @exprs); + $kid = $obj . "->" . $meth; + if ($args) { + return $kid . "(" . $args . ")"; # parens mandatory + } else { + return $kid; + } +} + +# returns "&" if the prototype doesn't match the args, +# or ("", $args_after_prototype_demunging) if it does. +sub check_proto { + my $self = shift; + my($proto, @args) = @_; + my($arg, $real); + my $doneok = 0; + my @reals; + # An unbackslashed @ or % gobbles up the rest of the args + $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/; + while ($proto) { + $proto =~ s/^ *([\\]?[\$\@&%*]|;)//; + my $chr = $1; + if ($chr eq "") { + return "&" if @args; + } elsif ($chr eq ";") { + $doneok = 1; + } elsif ($chr eq "@" or $chr eq "%") { + push @reals, map($self->deparse($_, 6), @args); + @args = (); } else { - return $kid; # toke.c fakes parens - } + $arg = shift @args; + last unless $arg; + if ($chr eq "\$") { + if (want_scalar $arg) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "&") { + if ($arg->name =~ /^(s?refgen|undef)$/) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "*") { + if ($arg->name =~ /^s?refgen$/ + and $arg->first->first->name eq "rv2gv") + { + $real = $arg->first->first; # skip refgen, null + if ($real->first->name eq "gv") { + push @reals, $self->deparse($real, 6); + } else { + push @reals, $self->deparse($real->first, 6); + } + } else { + return "&"; + } + } elsif (substr($chr, 0, 1) eq "\\") { + $chr = substr($chr, 1); + if ($arg->name =~ /^s?refgen$/ and + !null($real = $arg->first) and + ($chr eq "\$" && is_scalar($real->first) + or ($chr eq "\@" + && $real->first->sibling->name + =~ /^(rv2|pad)av$/) + or ($chr eq "%" + && $real->first->sibling->name + =~ /^(rv2|pad)hv$/) + #or ($chr eq "&" # This doesn't work + # && $real->first->name eq "rv2cv") + or ($chr eq "*" + && $real->first->name eq "rv2gv"))) + { + push @reals, $self->deparse($real, 6); + } else { + return "&"; + } + } + } } - # else, not a method + return "&" if $proto and !$doneok; # too few args and no `;' + return "&" if @args; # too many args + return ("", join ", ", @reals); +} + +sub pp_entersub { + my $self = shift; + my($op, $cx) = @_; + return $self->method($op, $cx) unless null $op->first->sibling; + my $prefix = ""; + my $amper = ""; + my($kid, @exprs); if ($op->flags & OPf_SPECIAL) { $prefix = "do "; } elsif ($op->private & OPpENTERSUB_AMPER) { @@ -1978,97 +2214,30 @@ sub pp_entersub { for (; not null $kid->sibling; $kid = $kid->sibling) { push @exprs, $kid; } + my $simple = 0; + my $proto = undef; if (is_scope($kid)) { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; - } elsif ($kid->first->ppaddr eq "pp_gv") { - my $gv = $kid->first->gv; + } elsif ($kid->first->name eq "gv") { + my $gv = $self->maybe_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } - $simple = 1; + $simple = 1; # only calls of named functions can be prototyped $kid = $self->deparse($kid, 24); } elsif (is_scalar $kid->first) { $amper = "&"; $kid = $self->deparse($kid, 24); } else { $prefix = ""; - $kid = $self->deparse($kid, 24) . "->"; + my $arrow = is_subscriptable($kid->first) ? "" : "->"; + $kid = $self->deparse($kid, 24) . $arrow; } + my $args; if (defined $proto and not $amper) { - my($arg, $real); - my $doneok = 0; - my @args = @exprs; - my @reals; - my $p = $proto; - $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/; - while ($p) { - $p =~ s/^ *([\\]?[\$\@&%*]|;)//; - my $chr = $1; - if ($chr eq "") { - undef $proto if @args; - } elsif ($chr eq ";") { - $doneok = 1; - } elsif ($chr eq "@" or $chr eq "%") { - push @reals, map($self->deparse($_, 6), @args); - @args = (); - } else { - $arg = shift @args; - last unless $arg; - if ($chr eq "\$") { - if (want_scalar $arg) { - push @reals, $self->deparse($arg, 6); - } else { - undef $proto; - } - } elsif ($chr eq "&") { - if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) { - push @reals, $self->deparse($arg, 6); - } else { - undef $proto; - } - } elsif ($chr eq "*") { - if ($arg->ppaddr =~ /^pp_s?refgen$/ - and $arg->first->first->ppaddr eq "pp_rv2gv") - { - $real = $arg->first->first; # skip refgen, null - if ($real->first->ppaddr eq "pp_gv") { - push @reals, $self->deparse($real, 6); - } else { - push @reals, $self->deparse($real->first, 6); - } - } else { - undef $proto; - } - } elsif (substr($chr, 0, 1) eq "\\") { - $chr = substr($chr, 1); - if ($arg->ppaddr =~ /^pp_s?refgen$/ and - !null($real = $arg->first) and - ($chr eq "\$" && is_scalar($real->first) - or ($chr eq "\@" - && $real->first->sibling->ppaddr - =~ /^pp_(rv2|pad)av$/) - or ($chr eq "%" - && $real->first->sibling->ppaddr - =~ /^pp_(rv2|pad)hv$/) - #or ($chr eq "&" # This doesn't work - # && $real->first->ppaddr eq "pp_rv2cv") - or ($chr eq "*" - && $real->first->ppaddr eq "pp_rv2gv"))) - { - push @reals, $self->deparse($real, 6); - } else { - undef $proto; - } - } - } - } - undef $proto if $p and !$doneok; - undef $proto if @args; - $args = join(", ", @reals); - $amper = ""; - unless (defined $proto) { - $amper = "&"; + ($amper, $args) = $self->check_proto($proto, @exprs); + if ($amper eq "&") { $args = join(", ", map($self->deparse($_, 6), @exprs)); } } else { @@ -2146,6 +2315,7 @@ sub balanced_delim { } elsif ($c eq $close) { $cnt--; if ($cnt < 0) { + # qq()() isn't ")(" $fail = 1; last; } @@ -2175,14 +2345,10 @@ sub single_delim { } } -sub SVf_IOK () {0x10000} -sub SVf_NOK () {0x20000} -sub SVf_ROK () {0x80000} - sub const { my $sv = shift; if (class($sv) eq "SPECIAL") { - return ('undef', '1', '0')[$$sv-1]; + return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no } elsif ($sv->FLAGS & SVf_IOK) { return $sv->IV; } elsif ($sv->FLAGS & SVf_NOK) { @@ -2191,43 +2357,52 @@ sub const { return "\\(" . const($sv->RV) . ")"; # constant folded } else { my $str = $sv->PV; - if ($str =~ /[^ -~]/) { # ASCII + if ($str =~ /[^ -~]/) { # ASCII for non-printing return single_delim("qq", '"', uninterp escape_str unback $str); } else { - $str =~ s/\\/\\\\/g; - return single_delim("q", "'", $str); + return single_delim("q", "'", unback $str); } } } +sub const_sv { + my $self = shift; + my $op = shift; + my $sv = $op->sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + sub pp_const { my $self = shift; my($op, $cx) = @_; -# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting -# return $op->sv->PV; +# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting +# return $self->const_sv($op)->PV; # } - return const($op->sv); + my $sv = $self->const_sv($op); + return const($sv); } sub dq { my $self = shift; my $op = shift; - my $type = $op->ppaddr; - if ($type eq "pp_const") { - return uninterp(escape_str(unback($op->sv->PV))); - } elsif ($type eq "pp_concat") { + my $type = $op->name; + if ($type eq "const") { + return uninterp(escape_str(unback($self->const_sv($op)->PV))); + } elsif ($type eq "concat") { return $self->dq($op->first) . $self->dq($op->last); - } elsif ($type eq "pp_uc") { + } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_lc") { + } elsif ($type eq "lc") { return '\L' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_ucfirst") { + } elsif ($type eq "ucfirst") { return '\u' . $self->dq($op->first->sibling); - } elsif ($type eq "pp_lcfirst") { + } elsif ($type eq "lcfirst") { return '\l' . $self->dq($op->first->sibling); - } elsif ($type eq "pp_quotemeta") { + } elsif ($type eq "quotemeta") { return '\Q' . $self->dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_join") { + } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); @@ -2243,13 +2418,15 @@ sub pp_backtick { sub dquote { my $self = shift; - my $op = shift; - # skip ex-stringify, pushmark - return single_delim("qq", '"', $self->dq($op->first->sibling)); + my($op, $cx) = shift; + my $kid = $op->first->sibling; # skip ex-stringify, pushmark + return $self->deparse($kid, $cx) if $self->{'unquote'}; + $self->maybe_targmy($kid, $cx, + sub {single_delim("qq", '"', $self->dq($_[1]))}); } -# OP_STRINGIFY is a listop, but it only ever has one arg (?) -sub pp_stringify { dquote(@_) } +# OP_STRINGIFY is a listop, but it only ever has one arg +sub pp_stringify { maybe_targmy(@_, \&dquote) } # tr/// and s/// (and tr[][], tr[]//, tr###, etc) # note that tr(from)/to/ is OK, but not tr/from/(to) @@ -2316,7 +2493,8 @@ sub collapse { if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and $chars[$c + 2] == $tr + 2) { - for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {} + for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) + {} $str .= "-"; $str .= pchr($chars[$c]); } @@ -2324,14 +2502,12 @@ sub collapse { return $str; } -sub OPpTRANS_SQUASH () { 16 } -sub OPpTRANS_DELETE () { 32 } -sub OPpTRANS_COMPLEMENT () { 64 } +# XXX This has trouble with hyphens in the replacement (tr/bac/-AC/), +# and backslashes. -sub pp_trans { - my $self = shift; - my($op, $cx) = @_; - my(@table) = unpack("s256", $op->pv); +sub tr_decode_byte { + my($table, $flags) = @_; + my(@table) = unpack("s256", $table); my($c, $tr, @from, @to, @delfrom, $delhyphen); if ($table[ord "-"] != -1 and $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) @@ -2353,10 +2529,8 @@ sub pp_trans { push @delfrom, $c; } } - my $flags; @from = (@from, @delfrom); - if ($op->private & OPpTRANS_COMPLEMENT) { - $flags .= "c"; + if ($flags & OPpTRANS_COMPLEMENT) { my @newfrom = (); my %from; @from{@from} = (1) x @from; @@ -2365,16 +2539,136 @@ sub pp_trans { } @from = @newfrom; } - if ($op->private & OPpTRANS_DELETE) { - $flags .= "d"; - } else { + unless ($flags & OPpTRANS_DELETE) { pop @to while $#to and $to[$#to] == $to[$#to -1]; } - $flags .= "s" if $op->private & OPpTRANS_SQUASH; my($from, $to); $from = collapse(@from); $to = collapse(@to); $from .= "-" if $delhyphen; + return ($from, $to); +} + +sub tr_chr { + my $x = shift; + if ($x == ord "-") { + return "\\-"; + } else { + return chr $x; + } +} + +# XXX This doesn't yet handle all cases correctly either + +sub tr_decode_utf8 { + my($swash_hv, $flags) = @_; + my %swash = $swash_hv->ARRAY; + my $final = undef; + $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; + my $none = $swash{"NONE"}->IV; + my $extra = $none + 1; + my(@from, @delfrom, @to); + my $line; + foreach $line (split /\n/, $swash{'LIST'}->PV) { + my($min, $max, $result) = split(/\t/, $line); + $min = hex $min; + if (length $max) { + $max = hex $max; + } else { + $max = $min; + } + $result = hex $result; + if ($result == $extra) { + push @delfrom, [$min, $max]; + } else { + push @from, [$min, $max]; + push @to, [$result, $result + $max - $min]; + } + } + for my $i (0 .. $#from) { + if ($from[$i][0] == ord '-') { + unshift @from, splice(@from, $i, 1); + unshift @to, splice(@to, $i, 1); + last; + } elsif ($from[$i][1] == ord '-') { + $from[$i][1]--; + $to[$i][1]--; + unshift @from, ord '-'; + unshift @to, ord '-'; + last; + } + } + for my $i (0 .. $#delfrom) { + if ($delfrom[$i][0] == ord '-') { + push @delfrom, splice(@delfrom, $i, 1); + last; + } elsif ($delfrom[$i][1] == ord '-') { + $delfrom[$i][1]--; + push @delfrom, ord '-'; + last; + } + } + if (defined $final and $to[$#to][1] != $final) { + push @to, [$final, $final]; + } + push @from, @delfrom; + if ($flags & OPpTRANS_COMPLEMENT) { + my @newfrom; + my $next = 0; + for my $i (0 .. $#from) { + push @newfrom, [$next, $from[$i][0] - 1]; + $next = $from[$i][1] + 1; + } + @from = (); + for my $range (@newfrom) { + if ($range->[0] <= $range->[1]) { + push @from, $range; + } + } + } + my($from, $to, $diff); + for my $chunk (@from) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $from .= tr_chr($chunk->[0]); + } + } + for my $chunk (@to) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $to .= tr_chr($chunk->[0]); + } + } + #$final = sprintf("%04x", $final) if defined $final; + #$none = sprintf("%04x", $none) if defined $none; + #$extra = sprintf("%04x", $extra) if defined $extra; + #print STDERR "final: $final\n none: $none\nextra: $extra\n"; + #print STDERR $swash{'LIST'}->PV; + return (escape_str($from), escape_str($to)); +} + +sub pp_trans { + my $self = shift; + my($op, $cx) = @_; + my($from, $to); + if (class($op) eq "PVOP") { + ($from, $to) = tr_decode_byte($op->pv, $op->private); + } else { # class($op) eq "SVOP" + ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private); + } + my $flags = ""; + $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT; + $flags .= "d" if $op->private & OPpTRANS_DELETE; + $to = "" if $from eq $to and $flags eq ""; + $flags .= "s" if $op->private & OPpTRANS_SQUASH; return "tr" . double_delim($from, $to) . $flags; } @@ -2382,22 +2676,22 @@ sub pp_trans { sub re_dq { my $self = shift; my $op = shift; - my $type = $op->ppaddr; - if ($type eq "pp_const") { - return uninterp($op->sv->PV); - } elsif ($type eq "pp_concat") { + my $type = $op->name; + if ($type eq "const") { + return uninterp($self->const_sv($op)->PV); + } elsif ($type eq "concat") { return $self->re_dq($op->first) . $self->re_dq($op->last); - } elsif ($type eq "pp_uc") { + } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_lc") { + } elsif ($type eq "lc") { return '\L' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_ucfirst") { + } elsif ($type eq "ucfirst") { return '\u' . $self->re_dq($op->first->sibling); - } elsif ($type eq "pp_lcfirst") { + } elsif ($type eq "lcfirst") { return '\l' . $self->re_dq($op->first->sibling); - } elsif ($type eq "pp_quotemeta") { + } elsif ($type eq "quotemeta") { return '\Q' . $self->re_dq($op->first->sibling) . '\E'; - } elsif ($type eq "pp_join") { + } elsif ($type eq "join") { return $self->deparse($op->last, 26); # was join($", @ary) } else { return $self->deparse($op, 26); @@ -2408,26 +2702,11 @@ sub pp_regcomp { my $self = shift; my($op, $cx) = @_; my $kid = $op->first; - $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe"; - $kid = $kid->first if $kid->ppaddr eq "pp_regcreset"; + $kid = $kid->first if $kid->name eq "regcmaybe"; + $kid = $kid->first if $kid->name eq "regcreset"; return $self->re_dq($kid); } -sub OPp_RUNTIME () { 64 } - -sub PMf_ONCE () { 0x2 } -sub PMf_SKIPWHITE () { 0x10 } -sub PMf_CONST () { 0x40 } -sub PMf_KEEP () { 0x80 } -sub PMf_GLOBAL () { 0x100 } -sub PMf_CONTINUE () { 0x200 } -sub PMf_EVAL () { 0x400 } -sub PMf_LOCALE () { 0x800 } -sub PMf_MULTILINE () { 0x1000 } -sub PMf_SINGLELINE () { 0x2000 } -sub PMf_FOLD () { 0x4000 } -sub PMf_EXTENDED () { 0x8000 } - # osmic acid -- see osmium tetroxide my %matchwords; @@ -2522,11 +2801,15 @@ sub pp_subst { $kid = $kid->sibling; } else { $repl = $op->pmreplroot->first; # skip substcont - while ($repl->ppaddr eq "pp_entereval") { + while ($repl->name eq "entereval") { $repl = $repl->first; $flags .= "e"; } - $repl = $self->dq($repl); + if ($op->pmflags & PMf_EVAL) { + $repl = $self->deparse($repl, 0); + } else { + $repl = $self->dq($repl); + } } if (null $kid) { $re = re_uninterp(escape_str($op->precomp)); @@ -2559,7 +2842,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl> +B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>] + I<prog.pl> =head1 DESCRIPTION @@ -2584,6 +2868,11 @@ the '-MO=Deparse', separated by a comma but not any white space. =over 4 +=item B<-l> + +Add '#line' declarations to the output based on the line and file +locations of the original code. + =item B<-p> Print extra parentheses. Without this option, B::Deparse includes @@ -2607,29 +2896,44 @@ C<B::Deparse,-p> will print which probably isn't what you intended (the C<'???'> is a sign that perl optimized away a constant value). +=item B<-q> + +Expand double-quoted strings into the corresponding combinations of +concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For +instance, print + + print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; + +as + + print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' + . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); + +Note that the expanded form represents the way perl handles such +constructions internally -- this option actually turns off the reverse +translation that B::Deparse usually does. On the other hand, note that +C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value +of $y into a string before doing the assignment. + =item B<-u>I<PACKAGE> Normally, B::Deparse deparses the main code of a program, all the subs called by the main program (and all the subs called by them, recursively), and any other subs in the main:: package. To include subs in other packages that aren't called directly, such as AUTOLOAD, -DESTROY, other subs called automatically by perl, and methods, which -aren't resolved to subs until runtime, use the B<-u> option. The +DESTROY, other subs called automatically by perl, and methods (which +aren't resolved to subs until runtime), use the B<-u> option. The argument to B<-u> is the name of a package, and should follow directly after the 'u'. Multiple B<-u> options may be given, separated by commas. Note that unlike some other backends, B::Deparse doesn't (yet) try to guess automatically when B<-u> is needed -- you must invoke it yourself. -=item B<-l> - -Add '#line' declarations to the output based on the line and file -locations of the original code. - =item B<-s>I<LETTERS> -Tweak the style of B::Deparse's output. At the moment, only one style -option is implemented: +Tweak the style of B::Deparse's output. The letters should follow +directly after the 's', with no space or punctuation. The following +options are available: =over 4 @@ -2654,17 +2958,85 @@ instead of The default is not to cuddle. +=item B<i>I<NUMBER> + +Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. + +=item B<T> + +Use tabs for each 8 columns of indent. The default is to use only spaces. +For instance, if the style options are B<-si4T>, a line that's indented +3 times will be preceded by one tab and four spaces; if the options were +B<-si8T>, the same line would be preceded by three tabs. + +=item B<v>I<STRING>B<.> + +Print I<STRING> for the value of a constant that can't be determined +because it was optimized away (mnemonic: this happens when a constant +is used in B<v>oid context). The end of the string is marked by a period. +The string should be a valid perl expression, generally a constant. +Note that unless it's a number, it probably needs to be quoted, and on +a command line quotes need to be protected from the shell. Some +conventional values include 0, 1, 42, '', 'foo', and +'Useless use of constant omitted' (which may need to be +B<-sv"'Useless use of constant omitted'."> +or something similar depending on your shell). The default is '???'. +If you're using B::Deparse on a module or other file that's require'd, +you shouldn't use a value that evaluates to false, since the customary +true constant at the end of a module will be in void context when the +file is compiled as a main program. + =back =back +=head1 USING B::Deparse AS A MODULE + +=head2 Synopsis + + use B::Deparse; + $deparse = B::Deparse->new("-p", "-sC"); + $body = $deparse->coderef2text(\&func); + eval "sub func $body"; # the inverse operation + +=head2 Description + +B::Deparse can also be used on a sub-by-sub basis from other perl +programs. + +=head2 new + + $deparse = B::Deparse->new(OPTIONS) + +Create an object to store the state of a deparsing operation and any +options. The options are the same as those that can be given on the +command line (see L</OPTIONS>); options that are separated by commas +after B<-MO=Deparse> should be given as separate strings. Some +options, like B<-u>, don't make sense for a single subroutine, so +don't pass them. + +=head2 coderef2text + + $body = $deparse->coderef2text(\&func) + $body = $deparse->coderef2text(sub ($$) { ... }) + +Return source code for the body of a subroutine (a block, optionally +preceded by a prototype in parens), given a reference to the +sub. Because a subroutine can have no names, or more than one name, +this method doesn't return a complete subroutine definition -- if you +want to eval the result, you should prepend "sub subname ", or "sub " +for an anonymous function constructor. Unless the sub was defined in +the main:: package, the code will include a package declaration. + =head1 BUGS See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant <alias@mcs.com>, based on an earlier version by -Malcolm Beattie <mbeattie@sable.ox.ac.uk>. +Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier +version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with +contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van +der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons. =cut diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index 4a008a3..d054a2d 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -52,6 +52,20 @@ sub GET_objindex { return unpack("N", $str); } +sub GET_opindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading opindex" unless length($str) == 4; + return unpack("N", $str); +} + +sub GET_svindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading svindex" unless length($str) == 4; + return unpack("N", $str); +} + sub GET_strconst { my $fh = shift; my ($str, $c); diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm index d34bd77..ed0d07d 100644 --- a/contrib/perl5/ext/B/B/Lint.pm +++ b/contrib/perl5/ext/B/B/Lint.pm @@ -116,13 +116,9 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents); - -# Constants (should probably be elsewhere) -sub G_ARRAY () { 1 } -sub OPf_LIST () { 1 } -sub OPf_KNOW () { 2 } -sub OPf_STACKED () { 64 } +use B qw(walkoptree_slow main_root walksymtable svref_2object parents + OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY + ); my $file = "unknown"; # shadows current filename my $line = 0; # shadows current line number @@ -133,8 +129,8 @@ my %check; my %implies_ok_context; BEGIN { map($implies_ok_context{$_}++, - qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice - pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete)); + qw(scalar av2arylen aelem aslice helem hslice + keys values hslice defined undef delete)); } # Lint checks turned on by default @@ -165,8 +161,8 @@ sub warning { sub gimme { my $op = shift; my $flags = $op->flags; - if ($flags & OPf_KNOW) { - return(($flags & OPf_LIST) ? 1 : 0); + if ($flags & OPf_WANT) { + return(($flags & OPf_WANT_LIST) ? 1 : 0); } return undef; } @@ -175,8 +171,8 @@ sub B::OP::lint {} sub B::COP::lint { my $op = shift; - if ($op->ppaddr eq "pp_nextstate") { - $file = $op->filegv->SV->PV; + if ($op->name eq "nextstate") { + $file = $op->file; $line = $op->line; $curstash = $op->stash->NAME; } @@ -184,24 +180,24 @@ sub B::COP::lint { sub B::UNOP::lint { my $op = shift; - my $ppaddr = $op->ppaddr; - if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) { + my $opname = $op->name; + if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { my $parent = parents->[0]; - my $pname = $parent->ppaddr; + my $pname = $parent->name; return if gimme($op) || $implies_ok_context{$pname}; # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" # null out the parent so we have to check for a parent of pp_null and # a grandparent of pp_enteriter or pp_delete - if ($pname eq "pp_null") { - my $gpname = parents->[1]->ppaddr; - return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete"; + if ($pname eq "null") { + my $gpname = parents->[1]->name; + return if $gpname eq "enteriter" || $gpname eq "delete"; } warning("Implicit scalar context for %s in %s", - $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc); + $opname eq "rv2av" ? "array" : "hash", $parent->desc); } - if ($check{private_names} && $ppaddr eq "pp_method") { + if ($check{private_names} && $opname eq "method") { my $methop = $op->first; - if ($methop->ppaddr eq "pp_const") { + if ($methop->name eq "const") { my $method = $methop->sv->PV; if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { warning("Illegal reference to private method name $method"); @@ -213,14 +209,12 @@ sub B::UNOP::lint { sub B::PMOP::lint { my $op = shift; if ($check{implicit_read}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) { + if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { warning('Implicit match on $_'); } } if ($check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) { + if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { warning('Implicit substitution on $_'); } } @@ -229,34 +223,35 @@ sub B::PMOP::lint { sub B::LOOP::lint { my $op = shift; if ($check{implicit_read} || $check{implicit_write}) { - my $ppaddr = $op->ppaddr; - if ($ppaddr eq "pp_enteriter") { + if ($op->name eq "enteriter") { my $last = $op->last; - if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") { + if ($last->name eq "gv" && $last->gv->NAME eq "_") { warning('Implicit use of $_ in foreach'); } } } } -sub B::GVOP::lint { +sub B::SVOP::lint { my $op = shift; - if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv" + if ($check{dollar_underscore} && $op->name eq "gvsv" && $op->gv->NAME eq "_") { warning('Use of $_'); } if ($check{private_names}) { - my $ppaddr = $op->ppaddr; - my $gv = $op->gv; - if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv") - && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) - { - warning('Illegal reference to private name %s', $gv->NAME); + my $opname = $op->name; + if ($opname eq "gv" || $opname eq "gvsv") { + my $gv = $op->gv; + if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { + warning('Illegal reference to private name %s', $gv->NAME); + } } } if ($check{undefined_subs}) { - if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") { + if ($op->name eq "gv" + && $op->next->name eq "entersub") + { my $gv = $op->gv; my $subname = $gv->STASH->NAME . "::" . $gv->NAME; no strict 'refs'; @@ -266,7 +261,7 @@ sub B::GVOP::lint { } } } - if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") { + if ($check{regexp_variables} && $op->name eq "gvsv") { my $name = $op->gv->NAME; if ($name =~ /^[&'`]$/) { warning('Use of regexp variable $%s', $name); diff --git a/contrib/perl5/ext/B/B/Stackobj.pm b/contrib/perl5/ext/B/B/Stackobj.pm index eea966c..0db3e33 100644 --- a/contrib/perl5/ext/B/B/Stackobj.pm +++ b/contrib/perl5/ext/B/B/Stackobj.pm @@ -5,34 +5,35 @@ # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. # -package B::Stackobj; +package B::Stackobj; use Exporter (); @ISA = qw(Exporter); -@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT +@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); %EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], flags => [qw(VALID_INT VALID_DOUBLE VALID_SV - REGISTER TEMPORARY)]); + VALID_UNSIGNED REGISTER TEMPORARY)]); use Carp qw(confess); use strict; -use B qw(class); - -# Perl internal constants that I should probably define elsewhere. -sub SVf_IOK () { 0x10000 } -sub SVf_NOK () { 0x20000 } +use B qw(class SVf_IOK SVf_NOK SVf_IVisUV); # Types sub T_UNKNOWN () { 0 } sub T_DOUBLE () { 1 } sub T_INT () { 2 } +sub T_SPECIAL () { 3 } # Flags sub VALID_INT () { 0x01 } -sub VALID_DOUBLE () { 0x02 } -sub VALID_SV () { 0x04 } -sub REGISTER () { 0x08 } # no implicit write-back when calling subs -sub TEMPORARY () { 0x10 } # no implicit write-back needed at all +sub VALID_UNSIGNED () { 0x02 } +sub VALID_DOUBLE () { 0x04 } +sub VALID_SV () { 0x08 } +sub REGISTER () { 0x10 } # no implicit write-back when calling subs +sub TEMPORARY () { 0x20 } # no implicit write-back needed at all +sub SAVE_INT () { 0x40 } #if int part needs to be saved at all +sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all + # # Callback for runtime code generation @@ -47,7 +48,7 @@ sub runtime { &$runtime_callback(@_) } sub write_back { confess "stack object does not implement write_back" } -sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) } +sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) } sub as_sv { my $obj = shift; @@ -62,7 +63,7 @@ sub as_int { my $obj = shift; if (!($obj->{flags} & VALID_INT)) { $obj->load_int; - $obj->{flags} |= VALID_INT; + $obj->{flags} |= VALID_INT|SAVE_INT; } return $obj->{iv}; } @@ -71,7 +72,7 @@ sub as_double { my $obj = shift; if (!($obj->{flags} & VALID_DOUBLE)) { $obj->load_double; - $obj->{flags} |= VALID_DOUBLE; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; } return $obj->{nv}; } @@ -81,6 +82,17 @@ sub as_numeric { return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; } +sub as_bool { + my $obj=shift; + if ($obj->{flags} & VALID_INT ){ + return $obj->{iv}; + } + if ($obj->{flags} & VALID_DOUBLE ){ + return $obj->{nv}; + } + return sprintf("(SvTRUE(%s))", $obj->as_sv) ; +} + # # Debugging methods # @@ -126,17 +138,18 @@ sub minipeek { # set_numeric and set_sv are only invoked on legal lvalues. # sub set_int { - my ($obj, $expr) = @_; + my ($obj, $expr,$unsigned) = @_; runtime("$obj->{iv} = $expr;"); $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); - $obj->{flags} |= VALID_INT; + $obj->{flags} |= VALID_INT|SAVE_INT; + $obj->{flags} |= VALID_UNSIGNED if $unsigned; } sub set_double { my ($obj, $expr) = @_; runtime("$obj->{nv} = $expr;"); $obj->{flags} &= ~(VALID_SV | VALID_INT); - $obj->{flags} |= VALID_DOUBLE; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; } sub set_numeric { @@ -162,6 +175,8 @@ sub set_sv { @B::Stackobj::Padsv::ISA = 'B::Stackobj'; sub B::Stackobj::Padsv::new { my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; + $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; + $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; bless { type => $type, flags => VALID_SV | $extra_flags, @@ -178,14 +193,23 @@ sub B::Stackobj::Padsv::load_int { } else { runtime("$obj->{iv} = SvIV($obj->{sv});"); } - $obj->{flags} |= VALID_INT; + $obj->{flags} |= VALID_INT|SAVE_INT; } sub B::Stackobj::Padsv::load_double { my $obj = shift; $obj->write_back; runtime("$obj->{nv} = SvNV($obj->{sv});"); - $obj->{flags} |= VALID_DOUBLE; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; +} +sub B::Stackobj::Padsv::save_int { + my $obj = shift; + return $obj->{flags} & SAVE_INT; +} + +sub B::Stackobj::Padsv::save_double { + my $obj = shift; + return $obj->{flags} & SAVE_DOUBLE; } sub B::Stackobj::Padsv::write_back { @@ -193,7 +217,11 @@ sub B::Stackobj::Padsv::write_back { my $flags = $obj->{flags}; return if $flags & VALID_SV; if ($flags & VALID_INT) { - runtime("sv_setiv($obj->{sv}, $obj->{iv});"); + if ($flags & VALID_UNSIGNED ){ + runtime("sv_setuv($obj->{sv}, $obj->{iv});"); + }else{ + runtime("sv_setiv($obj->{sv}, $obj->{iv});"); + } } elsif ($flags & VALID_DOUBLE) { runtime("sv_setnv($obj->{sv}, $obj->{nv});"); } else { @@ -213,17 +241,26 @@ sub B::Stackobj::Const::new { flags => 0, sv => $sv # holds the SV object until write_back happens }, $class; - my $svflags = $sv->FLAGS; - if ($svflags & SVf_IOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_INT; - $obj->{nv} = $obj->{iv} = $sv->IV; - } elsif ($svflags & SVf_NOK) { - $obj->{flags} = VALID_INT|VALID_DOUBLE; - $obj->{type} = T_DOUBLE; - $obj->{iv} = $obj->{nv} = $sv->NV; - } else { - $obj->{type} = T_UNKNOWN; + if ( ref($sv) eq "B::SPECIAL" ){ + $obj->{type}= T_SPECIAL; + }else{ + my $svflags = $sv->FLAGS; + if ($svflags & SVf_IOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_INT; + if ($svflags & SVf_IVisUV){ + $obj->{flags} |= VALID_UNSIGNED; + $obj->{nv} = $obj->{iv} = $sv->UVX; + }else{ + $obj->{nv} = $obj->{iv} = $sv->IV; + } + } elsif ($svflags & SVf_NOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_DOUBLE; + $obj->{iv} = $obj->{nv} = $sv->NV; + } else { + $obj->{type} = T_UNKNOWN; + } } return $obj; } @@ -238,13 +275,21 @@ sub B::Stackobj::Const::write_back { sub B::Stackobj::Const::load_int { my $obj = shift; - $obj->{iv} = int($obj->{sv}->PV); + if (ref($obj->{sv}) eq "B::RV"){ + $obj->{iv} = int($obj->{sv}->RV->PV); + }else{ + $obj->{iv} = int($obj->{sv}->PV); + } $obj->{flags} |= VALID_INT; } sub B::Stackobj::Const::load_double { my $obj = shift; - $obj->{nv} = $obj->{sv}->PV + 0.0; + if (ref($obj->{sv}) eq "B::RV"){ + $obj->{nv} = $obj->{sv}->RV->PV + 0.0; + }else{ + $obj->{nv} = $obj->{sv}->PV + 0.0; + } $obj->{flags} |= VALID_DOUBLE; } diff --git a/contrib/perl5/ext/B/B/Stash.pm b/contrib/perl5/ext/B/B/Stash.pm new file mode 100644 index 0000000..0a3543e --- /dev/null +++ b/contrib/perl5/ext/B/B/Stash.pm @@ -0,0 +1,42 @@ +# Stash.pm -- show what stashes are loaded +# vishalb@hotmail.com +package B::Stash; + +BEGIN { %Seen = %INC } + +CHECK { + my @arr=scan($main::{"main::"}); + @arr=map{s/\:\:$//;$_;} @arr; + print "-umain,-u", join (",-u",@arr) ,"\n"; +} +sub scan{ + my $start=shift; + my $prefix=shift; + $prefix = '' unless defined $prefix; + my @return; + foreach my $key ( keys %{$start}){ +# print $prefix,$key,"\n"; + if ($key =~ /::$/){ + unless ($start eq ${$start}{$key} or $key eq "B::" ){ + push @return, $key unless omit($prefix.$key); + foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ + push @return, "$key".$subscan; + } + } + } + } + return @return; +} +sub omit{ + my $module = shift; + my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 , + "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); + return 1 if $omit{$module}; + if ($module eq "IO::" or $module eq "IO::Handle::"){ + $module =~ s/::/\//g; + return 1 unless $INC{$module}; + } + + return 0; +} +1; diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm index 93757f3..66b5cfc 100644 --- a/contrib/perl5/ext/B/B/Terse.pm +++ b/contrib/perl5/ext/B/B/Terse.pm @@ -17,6 +17,7 @@ sub terse { sub compile { my $order = shift; my @options = @_; + B::clearsym(); if (@options) { return sub { my $objname; @@ -53,10 +54,9 @@ sub B::SVOP::terse { $op->sv->terse(0); } -sub B::GVOP::terse { +sub B::PADOP::terse { my ($op, $level) = @_; - print indent($level), peekop($op), " "; - $op->gv->terse(0); + print indent($level), peekop($op), " ", $op->padix, "\n"; } sub B::PMOP::terse { @@ -78,7 +78,7 @@ sub B::COP::terse { if ($label) { $label = " label ".cstring($label); } - print indent($level), peekop($op), $label, "\n"; + print indent($level), peekop($op), $label || "", "\n"; } sub B::PV::terse { diff --git a/contrib/perl5/ext/B/B/Xref.pm b/contrib/perl5/ext/B/B/Xref.pm index 0102856..b4078b8 100644 --- a/contrib/perl5/ext/B/B/Xref.pm +++ b/contrib/perl5/ext/B/B/Xref.pm @@ -85,11 +85,10 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(peekop class comppadlist main_start svref_2object walksymtable); - -# Constants (should probably be elsewhere) -sub OPpLVAL_INTRO () { 128 } -sub SVf_POK () { 0x40000 } +use Config; +use B qw(peekop class comppadlist main_start svref_2object walksymtable + OPpLVAL_INTRO SVf_POK + ); sub UNKNOWN { ["?", "?", "?"] } @@ -135,17 +134,28 @@ sub process { sub load_pad { my $padlist = shift; - my ($namelistav, @namelist, $ix); + my ($namelistav, $vallistav, @namelist, $ix); @pad = (); return if class($padlist) eq "SPECIAL"; - ($namelistav) = $padlist->ARRAY; + ($namelistav,$vallistav) = $padlist->ARRAY; @namelist = $namelistav->ARRAY; for ($ix = 1; $ix < @namelist; $ix++) { my $namesv = $namelist[$ix]; next if class($namesv) eq "SPECIAL"; - my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/; + my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; $pad[$ix] = ["(lexical)", $type, $name]; } + if ($Config{useithreads}) { + my (@vallist); + @vallist = $vallistav->ARRAY; + for ($ix = 1; $ix < @vallist; $ix++) { + my $valsv = $vallist[$ix]; + next unless class($valsv) eq "GV"; + # these pad GVs don't have corresponding names, so same @pad + # array can be used without collisions + $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; + } + } } sub xref { @@ -155,28 +165,24 @@ sub xref { last if $done{$$op}++; warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; warn peekop($op), "\n" if $debug_op; - my $ppname = $op->ppaddr; - if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) { + my $opname = $op->name; + if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { xref($op->other); - } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") { + } elsif ($opname eq "match" || $opname eq "subst") { xref($op->pmreplstart); - } elsif ($ppname eq "pp_substcont") { + } elsif ($opname eq "substcont") { xref($op->other->pmreplstart); $op = $op->other; redo; - } elsif ($ppname eq "pp_cond_expr") { - # pp_cond_expr never returns op_next - xref($op->true); - $op = $op->false; - redo; - } elsif ($ppname eq "pp_enterloop") { + } elsif ($opname eq "enterloop") { xref($op->redoop); xref($op->nextop); xref($op->lastop); - } elsif ($ppname eq "pp_subst") { + } elsif ($opname eq "subst") { xref($op->pmreplstart); } else { no strict 'refs'; + my $ppname = "pp_$opname"; &$ppname($op) if defined(&$ppname); } } @@ -207,7 +213,7 @@ sub xref_main { sub pp_nextstate { my $op = shift; - $file = $op->filegv->SV->PV; + $file = $op->file; $line = $op->line; $top = UNKNOWN; } @@ -235,23 +241,45 @@ sub pp_rv2gv { deref($top, "*"); } sub pp_gvsv { my $op = shift; - my $gv = $op->gv; - $top = [$gv->STASH->NAME, '$', $gv->NAME]; + my $gv; + if ($Config{useithreads}) { + $top = $pad[$op->padix]; + $top = UNKNOWN unless $top; + $top->[1] = '$'; + } + else { + $gv = $op->gv; + $top = [$gv->STASH->NAME, '$', $gv->NAME]; + } process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } sub pp_gv { my $op = shift; - my $gv = $op->gv; - $top = [$gv->STASH->NAME, "*", $gv->NAME]; + my $gv; + if ($Config{useithreads}) { + $top = $pad[$op->padix]; + $top = UNKNOWN unless $top; + $top->[1] = '*'; + } + else { + $gv = $op->gv; + $top = [$gv->STASH->NAME, "*", $gv->NAME]; + } process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); } sub pp_const { my $op = shift; my $sv = $op->sv; - $top = ["?", "", - (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; + # constant could be in the pad (under useithreads) + if ($$sv) { + $top = ["?", "", + (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"]; + } + else { + $top = $pad[$op->targ]; + } } sub pp_method { @@ -278,7 +306,7 @@ sub B::GV::xref { my $cv = $gv->CV; if ($$cv) { #return if $done{$$cv}++; - $file = $gv->FILEGV->SV->PV; + $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); push(@todo, $cv); @@ -286,7 +314,7 @@ sub B::GV::xref { my $form = $gv->FORM; if ($$form) { return if $done{$$form}++; - $file = $gv->FILEGV->SV->PV; + $file = $gv->FILE; $line = $gv->LINE; process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); } @@ -296,7 +324,7 @@ sub xref_definitions { my ($pack, %exclude); return if $nodefs; $subname = "(definitions)"; - foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS + foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS strict vars FileHandle Exporter Carp)) { $exclude{$pack."::"} = 1; } diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index 80e5e1b..cb9696b 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -16,31 +16,21 @@ if ($^O eq 'MSWin32') { WriteMakefile( NAME => "B", VERSION => "a5", - MAN3PODS => {}, + PL_FILES => { 'defsubs_h.PL' => 'defsubs.h' }, + MAN3PODS => {}, clean => { - FILES => "perl$e byteperl$e *$o B.c *~" + FILES => "perl$e *$o B.c defsubs.h *~" } -); +); -sub MY::post_constants { - "\nLIBS = $Config{libs}\n" -} +package MY; -# Leave out doing byteperl for now. Probably should be built in the -# core directory or somewhere else rather than here -#sub MY::top_targets { -# my $self = shift; -# my $targets = $self->MM::top_targets(); -# $targets =~ s/^(all ::.*)$/$1 byteperl$e/m; -# return <<"EOT" . $targets; +sub post_constants { + "\nLIBS = $Config::Config{libs}\n" +} -# -# byteperl is *not* a standard perl+XSUB executable. It's a special -# program for running standalone bytecode executables. It isn't an XSUB -# at the moment because a standlone Perl program needs to set up curpad -# which is overwritten on exit from an XSUB. -# -#byteperl$e : byteperl$o B$o \$(PERL_SRC)/byterun$o -# \$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS) -#EOT -#} +sub postamble { +' +B$(OBJ_EXT) : defsubs.h +' +} diff --git a/contrib/perl5/ext/B/NOTES b/contrib/perl5/ext/B/NOTES index ee10ba0..89d03ba 100644 --- a/contrib/perl5/ext/B/NOTES +++ b/contrib/perl5/ext/B/NOTES @@ -161,8 +161,8 @@ O module it should return a sub ref (usually a closure) to perform the actual compilation. When O regains control, it ensures that the "-c" option is forced (so that the program being compiled doesn't - end up running) and registers an END block to call back the sub ref + end up running) and registers a CHECK block to call back the sub ref returned from the backend's compile(). Perl then continues by parsing prog.pl (just as it would with "perl -c prog.pl") and after - doing so, assuming there are no parse-time errors, the END block + doing so, assuming there are no parse-time errors, the CHECK block of O gets called and the actual backend compilation happens. Phew. diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm index ad391a3..352f8d4 100644 --- a/contrib/perl5/ext/B/O.pm +++ b/contrib/perl5/ext/B/O.pm @@ -11,7 +11,7 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; - eval 'END { &$compilesub() }'; + eval 'CHECK { &$compilesub() }'; } else { die $compilesub; } @@ -59,7 +59,7 @@ C<B::Backend> module and calls the C<compile> function in that package, passing it OPTIONS. That function is expected to return a sub reference which we'll call CALLBACK. Next, the "compile-only" flag is switched on (equivalent to the command-line option C<-c>) -and an END block is registered which calls CALLBACK. Thus the main +and a CHECK block is registered which calls CALLBACK. Thus the main Perl program mentioned on the command-line is read in, parsed and compiled into internal syntax tree form. Since the C<-c> flag is set, the program does not start running (excepting BEGIN blocks of diff --git a/contrib/perl5/ext/B/defsubs_h.PL b/contrib/perl5/ext/B/defsubs_h.PL new file mode 100644 index 0000000..80ef936 --- /dev/null +++ b/contrib/perl5/ext/B/defsubs_h.PL @@ -0,0 +1,35 @@ +# Do not remove the following line; MakeMaker relies on it to identify +# this file as a template for defsubs.h +# Extracting defsubs.h (with variable substitutions) +#!perl +my ($out) = __FILE__ =~ /(^.*)\.PL/i; +$out =~ s/_h$/.h/; +open(OUT,">$out") || die "Cannot open $file:$!"; +print "Extracting $out...\n"; +foreach my $const (qw(AVf_REAL + HEf_SVKEY + SVf_IOK SVf_IVisUV SVf_NOK SVf_POK + SVf_ROK SVp_IOK SVp_POK )) + { + doconst($const); + } +foreach my $file (qw(op.h cop.h)) + { + open(OPH,"../../$file") || die "Cannot open ../../$file:$!"; + while (<OPH>) + { + doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/); + } + close(OPH); + } +close(OUT); + +sub doconst +{ + my $sym = shift; + my $l = length($sym); + print OUT <<"END"; + newCONSTSUB(stash,"$sym",newSViv($sym)); + av_push(export_ok,newSVpvn("$sym",$l)); +END +} diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop index 183d541..e0cb8ff 100644 --- a/contrib/perl5/ext/B/ramblings/flip-flop +++ b/contrib/perl5/ext/B/ramblings/flip-flop @@ -1,21 +1,24 @@ PP(pp_range) { if (GIMME == G_ARRAY) - return cCONDOP->op_true; - return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true; + return NORMAL; + if (SvTRUEx(PAD_SV(PL_op->op_targ))) + return cLOGOP->op_other; + else + return NORMAL; } -pp_range is a CONDOP. -In array context, it just returns op_true. +pp_range is a LOGOP. +In array context, it just returns op_next. In scalar context it checks the truth of targ and returns -op_false if true, op_true if false. +op_other if true, op_next if false. flip is an UNOP. -It "looks after" its child which is always a pp_range CONDOP. -In array context, it just returns the child's op_false. +It "looks after" its child which is always a pp_range LOGOP. +In array context, it just returns the child's op_other. In scalar context, there are three possible outcomes: (1) set child's targ to 1, our targ to 1 and return op_next. - (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false. + (2) set child's targ to 1, our targ to 0, sp-- and return child's op_other. (3) Blank targ and TOPs and return op_next. Case 1 happens for a "..." with a matching lineno... or true TOPs. Case 2 happens for a ".." with a matching lineno... or true TOPs. @@ -37,14 +40,14 @@ Case 3 happens for a non-matching lineno or false TOPs. /* range */ if (SvTRUE(curpad[op->op_targ])) - goto label(op_false); -/* op_true */ + goto label(op_other); +/* op_next */ ... /* flip */ -/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */ +/* For "..." returns op_next. For ".." returns op_next or op_first->op_other */ /* end of basic block */ goto out; -label(range op_false): +label(range op_other): ... /* flop */ out: diff --git a/contrib/perl5/ext/B/ramblings/runtime.porting b/contrib/perl5/ext/B/ramblings/runtime.porting index 4699b25..d58b011 100644 --- a/contrib/perl5/ext/B/ramblings/runtime.porting +++ b/contrib/perl5/ext/B/ramblings/runtime.porting @@ -33,8 +33,10 @@ glob 5 2 do_readline readline 8 2 do_readline rcatline 8 2 regcmaybe 8 1 +regcreset 8 1 regcomp 8 9 pregcomp match 8 10 +qr 8 1 subst 8 10 substcont 8 7 trans 7 4 do_trans @@ -170,6 +172,7 @@ orassign 7 3 modifies flow of control method 8 5 entersub 10 7 leavesub 10 5 +leavesublv caller 2 8 warn 9 3 die 9 3 @@ -212,6 +215,7 @@ leavewrite 4 5 prtf 4 4 do_sprintf print 8 6 sysopen 8 2 +sysseek 8 2 sysread 8 4 syswrite 8 4 pp_send send 8 4 @@ -347,4 +351,7 @@ sgrent egrent getlogin syscall -
\ No newline at end of file +lock 6 1 +threadsv 6 2 unused if not USE_THREADS +setstate 1 1 currently unused anywhere +method_named 10 2 diff --git a/contrib/perl5/ext/B/typemap b/contrib/perl5/ext/B/typemap index 7206a6a..bafba1c 100644 --- a/contrib/perl5/ext/B/typemap +++ b/contrib/perl5/ext/B/typemap @@ -4,11 +4,10 @@ B::OP T_OP_OBJ B::UNOP T_OP_OBJ B::BINOP T_OP_OBJ B::LOGOP T_OP_OBJ -B::CONDOP T_OP_OBJ B::LISTOP T_OP_OBJ B::PMOP T_OP_OBJ B::SVOP T_OP_OBJ -B::GVOP T_OP_OBJ +B::PADOP T_OP_OBJ B::PVOP T_OP_OBJ B::CVOP T_OP_OBJ B::LOOP T_OP_OBJ @@ -31,12 +30,13 @@ B::IO T_SV_OBJ B::MAGIC T_MG_OBJ SSize_t T_IV STRLEN T_IV +PADOFFSET T_UV INPUT T_OP_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; + $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") @@ -44,7 +44,7 @@ T_OP_OBJ T_SV_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; + $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") @@ -52,18 +52,18 @@ T_SV_OBJ T_MG_OBJ if (SvROK($arg)) { IV tmp = SvIV((SV*)SvRV($arg)); - $var = ($type) tmp; + $var = INT2PTR($type,tmp); } else croak(\"$var is not a reference\") OUTPUT T_OP_OBJ - sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var); + sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var)); T_SV_OBJ - make_sv_object(($arg), (SV*)($var)); + make_sv_object(aTHX_ ($arg), (SV*)($var)); T_MG_OBJ - sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var); + sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.pm b/contrib/perl5/ext/ByteLoader/ByteLoader.pm new file mode 100644 index 0000000..286d746 --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/ByteLoader.pm @@ -0,0 +1,40 @@ +package ByteLoader; + +use XSLoader (); + +$VERSION = 0.03; + +XSLoader::load 'ByteLoader', $VERSION; + +# Preloaded methods go here. + +1; +__END__ + +=head1 NAME + +ByteLoader - load byte compiled perl code + +=head1 SYNOPSIS + + use ByteLoader 0.03; + <byte code> + + use ByteLoader 0.03; + <byte code> + +=head1 DESCRIPTION + +This module is used to load byte compiled perl code. It uses the source +filter mechanism to read the byte code and insert it into the compiled +code at the appropriate point. + +=head1 AUTHOR + +Tom Hughes <tom@compton.nu> based on the ideas of Tim Bunce and others. + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.xs b/contrib/perl5/ext/ByteLoader/ByteLoader.xs new file mode 100644 index 0000000..7c3746b --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/ByteLoader.xs @@ -0,0 +1,79 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "byterun.h" + +static int +xgetc(PerlIO *io) +{ + dTHX; + return PerlIO_getc(io); +} + +static int +xfread(char *buf, size_t size, size_t n, PerlIO *io) +{ + dTHX; + int i = PerlIO_read(io, buf, n * size); + if (i > 0) + i /= size; + return i; +} + +static void +freadpv(U32 len, void *data, XPV *pv) +{ + dTHX; + New(666, pv->xpv_pv, len, char); + PerlIO_read((PerlIO*)data, (void*)pv->xpv_pv, len); + pv->xpv_len = len; + pv->xpv_cur = len - 1; +} + +static I32 +byteloader_filter(pTHXo_ int idx, SV *buf_sv, int maxlen) +{ + dTHR; + OP *saveroot = PL_main_root; + OP *savestart = PL_main_start; + struct bytestream bs; + + bs.data = PL_rsfp; + bs.pfgetc = (int(*) (void*))xgetc; + bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread; + bs.pfreadpv = freadpv; + + byterun(aTHXo_ bs); + + if (PL_in_eval) { + OP *o; + + PL_eval_start = PL_main_start; + + o = newSVOP(OP_CONST, 0, newSViv(1)); + PL_eval_root = newLISTOP(OP_LINESEQ, 0, PL_main_root, o); + PL_main_root->op_next = o; + PL_eval_root = newUNOP(OP_LEAVEEVAL, 0, PL_eval_root); + o->op_next = PL_eval_root; + + PL_main_root = saveroot; + PL_main_start = savestart; + } + + return 0; +} + +MODULE = ByteLoader PACKAGE = ByteLoader + +PROTOTYPES: ENABLE + +void +import(...) + PPCODE: + filter_add(byteloader_filter, NULL); + +void +unimport(...) + PPCODE: + filter_del(byteloader_filter); diff --git a/contrib/perl5/ext/ByteLoader/Makefile.PL b/contrib/perl5/ext/ByteLoader/Makefile.PL new file mode 100644 index 0000000..c3cfcc7 --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/Makefile.PL @@ -0,0 +1,9 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'ByteLoader', + VERSION_FROM => 'ByteLoader.pm', + XSPROTOARG => '-noprototypes', + MAN3PODS => {}, # Pods will be built by installman. + OBJECT => 'byterun$(OBJ_EXT) ByteLoader$(OBJ_EXT)', +); diff --git a/contrib/perl5/ext/ByteLoader/bytecode.h b/contrib/perl5/ext/ByteLoader/bytecode.h new file mode 100644 index 0000000..1621fed --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/bytecode.h @@ -0,0 +1,161 @@ +typedef char *pvcontents; +typedef char *strconst; +typedef U32 PV; +typedef char *op_tr_array; +typedef int comment_t; +typedef SV *svindex; +typedef OP *opindex; +typedef IV IV64; + +#define BGET_FREAD(argp, len, nelem) \ + bs.pfread((char*)(argp),(len),(nelem),bs.data) +#define BGET_FGETC() bs.pfgetc(bs.data) + +#define BGET_U32(arg) \ + BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg) +#define BGET_I32(arg) \ + BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg) +#define BGET_U16(arg) \ + BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg) +#define BGET_U8(arg) arg = BGET_FGETC() + +#define BGET_PV(arg) STMT_START { \ + BGET_U32(arg); \ + if (arg) \ + bs.pfreadpv(arg, bs.data, &bytecode_pv); \ + else { \ + bytecode_pv.xpv_pv = 0; \ + bytecode_pv.xpv_len = 0; \ + bytecode_pv.xpv_cur = 0; \ + } \ + } STMT_END + +#ifdef BYTELOADER_LOG_COMMENTS +# define BGET_comment_t(arg) \ + STMT_START { \ + char buf[1024]; \ + int i = 0; \ + do { \ + arg = BGET_FGETC(); \ + buf[i++] = (char)arg; \ + } while (arg != '\n' && arg != EOF); \ + buf[i] = '\0'; \ + PerlIO_printf(PerlIO_stderr(), "%s", buf); \ + } STMT_END +#else +# define BGET_comment_t(arg) \ + do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF) +#endif + +/* + * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV + * machines such that 32-bit machine compilers don't whine about the shift + * count being too high even though the code is never reached there. + */ +#define BGET_IV64(arg) STMT_START { \ + U32 hi, lo; \ + BGET_U32(hi); \ + BGET_U32(lo); \ + if (sizeof(IV) == 8) \ + arg = ((IV)hi << (sizeof(IV)*4) | (IV)lo); \ + else if (((I32)hi == -1 && (I32)lo < 0) \ + || ((I32)hi == 0 && (I32)lo >= 0)) { \ + arg = (I32)lo; \ + } \ + else { \ + bytecode_iv_overflows++; \ + arg = 0; \ + } \ + } STMT_END + +#define BGET_op_tr_array(arg) do { \ + unsigned short *ary; \ + int i; \ + New(666, ary, 256, unsigned short); \ + BGET_FREAD(ary, 256, 2); \ + for (i = 0; i < 256; i++) \ + ary[i] = PerlSock_ntohs(ary[i]); \ + arg = (char *) ary; \ + } while (0) + +#define BGET_pvcontents(arg) arg = bytecode_pv.xpv_pv +#define BGET_strconst(arg) STMT_START { \ + for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \ + arg = PL_tokenbuf; \ + } STMT_END + +#define BGET_NV(arg) STMT_START { \ + char *str; \ + BGET_strconst(str); \ + arg = Atof(str); \ + } STMT_END + +#define BGET_objindex(arg, type) STMT_START { \ + U32 ix; \ + BGET_U32(ix); \ + arg = (type)bytecode_obj_list[ix]; \ + } STMT_END +#define BGET_svindex(arg) BGET_objindex(arg, svindex) +#define BGET_opindex(arg) BGET_objindex(arg, opindex) + +#define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg] + +#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg +#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg +#define BSET_gp_share(sv, arg) STMT_START { \ + gp_free((GV*)sv); \ + GvGP(sv) = GvGP(arg); \ + } STMT_END + +#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV) +#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE) +#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0) +#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bytecode_pv.xpv_cur +#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg) +#define BSET_xpv(sv) do { \ + SvPV_set(sv, bytecode_pv.xpv_pv); \ + SvCUR_set(sv, bytecode_pv.xpv_cur); \ + SvLEN_set(sv, bytecode_pv.xpv_len); \ + } while (0) +#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg) + +#define BSET_av_push(sv, arg) av_push((AV*)sv, arg) +#define BSET_hv_store(sv, arg) \ + hv_store((HV*)sv, bytecode_pv.xpv_pv, bytecode_pv.xpv_cur, arg, 0) +#define BSET_pv_free(pv) Safefree(pv.xpv_pv) +#define BSET_pregcomp(o, arg) \ + ((PMOP*)o)->op_pmregexp = arg ? \ + CALLREGCOMP(aTHX_ arg, arg + bytecode_pv.xpv_cur, ((PMOP*)o)) : 0 +#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg) +#define BSET_newop(o, arg) ((o = (OP*)safemalloc(optype_size[arg])), \ + memzero((char*)o,optype_size[arg])) +#define BSET_newopn(o, arg) STMT_START { \ + OP *oldop = o; \ + BSET_newop(o, arg); \ + oldop->op_next = o; \ + } STMT_END + +#define BSET_ret(foo) return + +/* + * Kludge special-case workaround for OP_MAPSTART + * which needs the ppaddr for OP_GREPSTART. Blech. + */ +#define BSET_op_type(o, arg) STMT_START { \ + o->op_type = arg; \ + if (arg == OP_MAPSTART) \ + arg = OP_GREPSTART; \ + o->op_ppaddr = PL_ppaddr[arg]; \ + } STMT_END +#define BSET_op_ppaddr(o, arg) Perl_croak(aTHX_ "op_ppaddr not yet implemented") +#define BSET_curpad(pad, arg) STMT_START { \ + PL_comppad = (AV *)arg; \ + pad = AvARRAY(arg); \ + } STMT_END +#define BSET_cop_file(cop, arg) CopFILE_set(cop,arg) +#define BSET_cop_line(cop, arg) CopLINE_set(cop,arg) +#define BSET_cop_stashpv(cop, arg) CopSTASHPV_set(cop,arg) + +#define BSET_OBJ_STORE(obj, ix) \ + (I32)ix > bytecode_obj_list_fill ? \ + bset_obj_store(aTHXo_ obj, (I32)ix) : (bytecode_obj_list[ix] = obj) diff --git a/contrib/perl5/ext/ByteLoader/byterun.c b/contrib/perl5/ext/ByteLoader/byterun.c new file mode 100644 index 0000000..a1044ab --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/byterun.c @@ -0,0 +1,899 @@ +/* + * Copyright (c) 1996-1999 Malcolm Beattie + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ +/* + * This file is autogenerated from bytecode.pl. Changes made here will be lost. + */ + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#define NO_XSLOCKS +#include "XSUB.h" + +#ifdef PERL_OBJECT +#undef CALL_FPTR +#define CALL_FPTR(fptr) (pPerl->*fptr) +#undef PL_ppaddr +#define PL_ppaddr (*get_ppaddr()) +#endif + +#include "byterun.h" +#include "bytecode.h" + + +static int optype_size[] = { + sizeof(OP), + sizeof(UNOP), + sizeof(BINOP), + sizeof(LOGOP), + sizeof(LISTOP), + sizeof(PMOP), + sizeof(SVOP), + sizeof(PADOP), + sizeof(PVOP), + sizeof(LOOP), + sizeof(COP) +}; + +static SV *specialsv_list[4]; + +static int bytecode_iv_overflows = 0; +static SV *bytecode_sv; +static XPV bytecode_pv; +static void **bytecode_obj_list; +static I32 bytecode_obj_list_fill = -1; + +void * +bset_obj_store(pTHXo_ void *obj, I32 ix) +{ + if (ix > bytecode_obj_list_fill) { + if (bytecode_obj_list_fill == -1) + New(666, bytecode_obj_list, ix + 1, void*); + else + Renew(bytecode_obj_list, ix + 1, void*); + bytecode_obj_list_fill = ix; + } + bytecode_obj_list[ix] = obj; + return obj; +} + +void +byterun(pTHXo_ struct bytestream bs) +{ + dTHR; + int insn; + + specialsv_list[0] = Nullsv; + specialsv_list[1] = &PL_sv_undef; + specialsv_list[2] = &PL_sv_yes; + specialsv_list[3] = &PL_sv_no; + + while ((insn = BGET_FGETC()) != EOF) { + switch (insn) { + case INSN_COMMENT: /* 35 */ + { + comment_t arg; + BGET_comment_t(arg); + arg = arg; + break; + } + case INSN_NOP: /* 10 */ + { + break; + } + case INSN_RET: /* 0 */ + { + BSET_ret(none); + break; + } + case INSN_LDSV: /* 1 */ + { + svindex arg; + BGET_svindex(arg); + bytecode_sv = arg; + break; + } + case INSN_LDOP: /* 2 */ + { + opindex arg; + BGET_opindex(arg); + PL_op = arg; + break; + } + case INSN_STSV: /* 3 */ + { + U32 arg; + BGET_U32(arg); + BSET_OBJ_STORE(bytecode_sv, arg); + break; + } + case INSN_STOP: /* 4 */ + { + U32 arg; + BGET_U32(arg); + BSET_OBJ_STORE(PL_op, arg); + break; + } + case INSN_LDSPECSV: /* 5 */ + { + U8 arg; + BGET_U8(arg); + BSET_ldspecsv(bytecode_sv, arg); + break; + } + case INSN_NEWSV: /* 6 */ + { + U8 arg; + BGET_U8(arg); + BSET_newsv(bytecode_sv, arg); + break; + } + case INSN_NEWOP: /* 7 */ + { + U8 arg; + BGET_U8(arg); + BSET_newop(PL_op, arg); + break; + } + case INSN_NEWOPN: /* 8 */ + { + U8 arg; + BGET_U8(arg); + BSET_newopn(PL_op, arg); + break; + } + case INSN_NEWPV: /* 9 */ + { + PV arg; + BGET_PV(arg); + break; + } + case INSN_PV_CUR: /* 11 */ + { + STRLEN arg; + BGET_U32(arg); + bytecode_pv.xpv_cur = arg; + break; + } + case INSN_PV_FREE: /* 12 */ + { + BSET_pv_free(bytecode_pv); + break; + } + case INSN_SV_UPGRADE: /* 13 */ + { + char arg; + BGET_U8(arg); + BSET_sv_upgrade(bytecode_sv, arg); + break; + } + case INSN_SV_REFCNT: /* 14 */ + { + U32 arg; + BGET_U32(arg); + SvREFCNT(bytecode_sv) = arg; + break; + } + case INSN_SV_REFCNT_ADD: /* 15 */ + { + I32 arg; + BGET_I32(arg); + BSET_sv_refcnt_add(SvREFCNT(bytecode_sv), arg); + break; + } + case INSN_SV_FLAGS: /* 16 */ + { + U32 arg; + BGET_U32(arg); + SvFLAGS(bytecode_sv) = arg; + break; + } + case INSN_XRV: /* 17 */ + { + svindex arg; + BGET_svindex(arg); + SvRV(bytecode_sv) = arg; + break; + } + case INSN_XPV: /* 18 */ + { + BSET_xpv(bytecode_sv); + break; + } + case INSN_XIV32: /* 19 */ + { + I32 arg; + BGET_I32(arg); + SvIVX(bytecode_sv) = arg; + break; + } + case INSN_XIV64: /* 20 */ + { + IV64 arg; + BGET_IV64(arg); + SvIVX(bytecode_sv) = arg; + break; + } + case INSN_XNV: /* 21 */ + { + NV arg; + BGET_NV(arg); + SvNVX(bytecode_sv) = arg; + break; + } + case INSN_XLV_TARGOFF: /* 22 */ + { + STRLEN arg; + BGET_U32(arg); + LvTARGOFF(bytecode_sv) = arg; + break; + } + case INSN_XLV_TARGLEN: /* 23 */ + { + STRLEN arg; + BGET_U32(arg); + LvTARGLEN(bytecode_sv) = arg; + break; + } + case INSN_XLV_TARG: /* 24 */ + { + svindex arg; + BGET_svindex(arg); + LvTARG(bytecode_sv) = arg; + break; + } + case INSN_XLV_TYPE: /* 25 */ + { + char arg; + BGET_U8(arg); + LvTYPE(bytecode_sv) = arg; + break; + } + case INSN_XBM_USEFUL: /* 26 */ + { + I32 arg; + BGET_I32(arg); + BmUSEFUL(bytecode_sv) = arg; + break; + } + case INSN_XBM_PREVIOUS: /* 27 */ + { + U16 arg; + BGET_U16(arg); + BmPREVIOUS(bytecode_sv) = arg; + break; + } + case INSN_XBM_RARE: /* 28 */ + { + U8 arg; + BGET_U8(arg); + BmRARE(bytecode_sv) = arg; + break; + } + case INSN_XFM_LINES: /* 29 */ + { + I32 arg; + BGET_I32(arg); + FmLINES(bytecode_sv) = arg; + break; + } + case INSN_XIO_LINES: /* 30 */ + { + long arg; + BGET_I32(arg); + IoLINES(bytecode_sv) = arg; + break; + } + case INSN_XIO_PAGE: /* 31 */ + { + long arg; + BGET_I32(arg); + IoPAGE(bytecode_sv) = arg; + break; + } + case INSN_XIO_PAGE_LEN: /* 32 */ + { + long arg; + BGET_I32(arg); + IoPAGE_LEN(bytecode_sv) = arg; + break; + } + case INSN_XIO_LINES_LEFT: /* 33 */ + { + long arg; + BGET_I32(arg); + IoLINES_LEFT(bytecode_sv) = arg; + break; + } + case INSN_XIO_TOP_NAME: /* 34 */ + { + pvcontents arg; + BGET_pvcontents(arg); + IoTOP_NAME(bytecode_sv) = arg; + break; + } + case INSN_XIO_TOP_GV: /* 36 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&IoTOP_GV(bytecode_sv) = arg; + break; + } + case INSN_XIO_FMT_NAME: /* 37 */ + { + pvcontents arg; + BGET_pvcontents(arg); + IoFMT_NAME(bytecode_sv) = arg; + break; + } + case INSN_XIO_FMT_GV: /* 38 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&IoFMT_GV(bytecode_sv) = arg; + break; + } + case INSN_XIO_BOTTOM_NAME: /* 39 */ + { + pvcontents arg; + BGET_pvcontents(arg); + IoBOTTOM_NAME(bytecode_sv) = arg; + break; + } + case INSN_XIO_BOTTOM_GV: /* 40 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&IoBOTTOM_GV(bytecode_sv) = arg; + break; + } + case INSN_XIO_SUBPROCESS: /* 41 */ + { + short arg; + BGET_U16(arg); + IoSUBPROCESS(bytecode_sv) = arg; + break; + } + case INSN_XIO_TYPE: /* 42 */ + { + char arg; + BGET_U8(arg); + IoTYPE(bytecode_sv) = arg; + break; + } + case INSN_XIO_FLAGS: /* 43 */ + { + char arg; + BGET_U8(arg); + IoFLAGS(bytecode_sv) = arg; + break; + } + case INSN_XCV_STASH: /* 44 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&CvSTASH(bytecode_sv) = arg; + break; + } + case INSN_XCV_START: /* 45 */ + { + opindex arg; + BGET_opindex(arg); + CvSTART(bytecode_sv) = arg; + break; + } + case INSN_XCV_ROOT: /* 46 */ + { + opindex arg; + BGET_opindex(arg); + CvROOT(bytecode_sv) = arg; + break; + } + case INSN_XCV_GV: /* 47 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&CvGV(bytecode_sv) = arg; + break; + } + case INSN_XCV_FILE: /* 48 */ + { + pvcontents arg; + BGET_pvcontents(arg); + CvFILE(bytecode_sv) = arg; + break; + } + case INSN_XCV_DEPTH: /* 49 */ + { + long arg; + BGET_I32(arg); + CvDEPTH(bytecode_sv) = arg; + break; + } + case INSN_XCV_PADLIST: /* 50 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&CvPADLIST(bytecode_sv) = arg; + break; + } + case INSN_XCV_OUTSIDE: /* 51 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&CvOUTSIDE(bytecode_sv) = arg; + break; + } + case INSN_XCV_FLAGS: /* 52 */ + { + U16 arg; + BGET_U16(arg); + CvFLAGS(bytecode_sv) = arg; + break; + } + case INSN_AV_EXTEND: /* 53 */ + { + SSize_t arg; + BGET_I32(arg); + BSET_av_extend(bytecode_sv, arg); + break; + } + case INSN_AV_PUSH: /* 54 */ + { + svindex arg; + BGET_svindex(arg); + BSET_av_push(bytecode_sv, arg); + break; + } + case INSN_XAV_FILL: /* 55 */ + { + SSize_t arg; + BGET_I32(arg); + AvFILLp(bytecode_sv) = arg; + break; + } + case INSN_XAV_MAX: /* 56 */ + { + SSize_t arg; + BGET_I32(arg); + AvMAX(bytecode_sv) = arg; + break; + } + case INSN_XAV_FLAGS: /* 57 */ + { + U8 arg; + BGET_U8(arg); + AvFLAGS(bytecode_sv) = arg; + break; + } + case INSN_XHV_RITER: /* 58 */ + { + I32 arg; + BGET_I32(arg); + HvRITER(bytecode_sv) = arg; + break; + } + case INSN_XHV_NAME: /* 59 */ + { + pvcontents arg; + BGET_pvcontents(arg); + HvNAME(bytecode_sv) = arg; + break; + } + case INSN_HV_STORE: /* 60 */ + { + svindex arg; + BGET_svindex(arg); + BSET_hv_store(bytecode_sv, arg); + break; + } + case INSN_SV_MAGIC: /* 61 */ + { + char arg; + BGET_U8(arg); + BSET_sv_magic(bytecode_sv, arg); + break; + } + case INSN_MG_OBJ: /* 62 */ + { + svindex arg; + BGET_svindex(arg); + SvMAGIC(bytecode_sv)->mg_obj = arg; + break; + } + case INSN_MG_PRIVATE: /* 63 */ + { + U16 arg; + BGET_U16(arg); + SvMAGIC(bytecode_sv)->mg_private = arg; + break; + } + case INSN_MG_FLAGS: /* 64 */ + { + U8 arg; + BGET_U8(arg); + SvMAGIC(bytecode_sv)->mg_flags = arg; + break; + } + case INSN_MG_PV: /* 65 */ + { + pvcontents arg; + BGET_pvcontents(arg); + BSET_mg_pv(SvMAGIC(bytecode_sv), arg); + break; + } + case INSN_XMG_STASH: /* 66 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&SvSTASH(bytecode_sv) = arg; + break; + } + case INSN_GV_FETCHPV: /* 67 */ + { + strconst arg; + BGET_strconst(arg); + BSET_gv_fetchpv(bytecode_sv, arg); + break; + } + case INSN_GV_STASHPV: /* 68 */ + { + strconst arg; + BGET_strconst(arg); + BSET_gv_stashpv(bytecode_sv, arg); + break; + } + case INSN_GP_SV: /* 69 */ + { + svindex arg; + BGET_svindex(arg); + GvSV(bytecode_sv) = arg; + break; + } + case INSN_GP_REFCNT: /* 70 */ + { + U32 arg; + BGET_U32(arg); + GvREFCNT(bytecode_sv) = arg; + break; + } + case INSN_GP_REFCNT_ADD: /* 71 */ + { + I32 arg; + BGET_I32(arg); + BSET_gp_refcnt_add(GvREFCNT(bytecode_sv), arg); + break; + } + case INSN_GP_AV: /* 72 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&GvAV(bytecode_sv) = arg; + break; + } + case INSN_GP_HV: /* 73 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&GvHV(bytecode_sv) = arg; + break; + } + case INSN_GP_CV: /* 74 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&GvCV(bytecode_sv) = arg; + break; + } + case INSN_GP_FILE: /* 75 */ + { + pvcontents arg; + BGET_pvcontents(arg); + GvFILE(bytecode_sv) = arg; + break; + } + case INSN_GP_IO: /* 76 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&GvIOp(bytecode_sv) = arg; + break; + } + case INSN_GP_FORM: /* 77 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&GvFORM(bytecode_sv) = arg; + break; + } + case INSN_GP_CVGEN: /* 78 */ + { + U32 arg; + BGET_U32(arg); + GvCVGEN(bytecode_sv) = arg; + break; + } + case INSN_GP_LINE: /* 79 */ + { + line_t arg; + BGET_U16(arg); + GvLINE(bytecode_sv) = arg; + break; + } + case INSN_GP_SHARE: /* 80 */ + { + svindex arg; + BGET_svindex(arg); + BSET_gp_share(bytecode_sv, arg); + break; + } + case INSN_XGV_FLAGS: /* 81 */ + { + U8 arg; + BGET_U8(arg); + GvFLAGS(bytecode_sv) = arg; + break; + } + case INSN_OP_NEXT: /* 82 */ + { + opindex arg; + BGET_opindex(arg); + PL_op->op_next = arg; + break; + } + case INSN_OP_SIBLING: /* 83 */ + { + opindex arg; + BGET_opindex(arg); + PL_op->op_sibling = arg; + break; + } + case INSN_OP_PPADDR: /* 84 */ + { + strconst arg; + BGET_strconst(arg); + BSET_op_ppaddr(PL_op->op_ppaddr, arg); + break; + } + case INSN_OP_TARG: /* 85 */ + { + PADOFFSET arg; + BGET_U32(arg); + PL_op->op_targ = arg; + break; + } + case INSN_OP_TYPE: /* 86 */ + { + OPCODE arg; + BGET_U16(arg); + BSET_op_type(PL_op, arg); + break; + } + case INSN_OP_SEQ: /* 87 */ + { + U16 arg; + BGET_U16(arg); + PL_op->op_seq = arg; + break; + } + case INSN_OP_FLAGS: /* 88 */ + { + U8 arg; + BGET_U8(arg); + PL_op->op_flags = arg; + break; + } + case INSN_OP_PRIVATE: /* 89 */ + { + U8 arg; + BGET_U8(arg); + PL_op->op_private = arg; + break; + } + case INSN_OP_FIRST: /* 90 */ + { + opindex arg; + BGET_opindex(arg); + cUNOP->op_first = arg; + break; + } + case INSN_OP_LAST: /* 91 */ + { + opindex arg; + BGET_opindex(arg); + cBINOP->op_last = arg; + break; + } + case INSN_OP_OTHER: /* 92 */ + { + opindex arg; + BGET_opindex(arg); + cLOGOP->op_other = arg; + break; + } + case INSN_OP_CHILDREN: /* 93 */ + { + U32 arg; + BGET_U32(arg); + cLISTOP->op_children = arg; + break; + } + case INSN_OP_PMREPLROOT: /* 94 */ + { + opindex arg; + BGET_opindex(arg); + cPMOP->op_pmreplroot = arg; + break; + } + case INSN_OP_PMREPLROOTGV: /* 95 */ + { + svindex arg; + BGET_svindex(arg); + *(SV**)&cPMOP->op_pmreplroot = arg; + break; + } + case INSN_OP_PMREPLSTART: /* 96 */ + { + opindex arg; + BGET_opindex(arg); + cPMOP->op_pmreplstart = arg; + break; + } + case INSN_OP_PMNEXT: /* 97 */ + { + opindex arg; + BGET_opindex(arg); + *(OP**)&cPMOP->op_pmnext = arg; + break; + } + case INSN_PREGCOMP: /* 98 */ + { + pvcontents arg; + BGET_pvcontents(arg); + BSET_pregcomp(PL_op, arg); + break; + } + case INSN_OP_PMFLAGS: /* 99 */ + { + U16 arg; + BGET_U16(arg); + cPMOP->op_pmflags = arg; + break; + } + case INSN_OP_PMPERMFLAGS: /* 100 */ + { + U16 arg; + BGET_U16(arg); + cPMOP->op_pmpermflags = arg; + break; + } + case INSN_OP_SV: /* 101 */ + { + svindex arg; + BGET_svindex(arg); + cSVOP->op_sv = arg; + break; + } + case INSN_OP_PADIX: /* 102 */ + { + PADOFFSET arg; + BGET_U32(arg); + cPADOP->op_padix = arg; + break; + } + case INSN_OP_PV: /* 103 */ + { + pvcontents arg; + BGET_pvcontents(arg); + cPVOP->op_pv = arg; + break; + } + case INSN_OP_PV_TR: /* 104 */ + { + op_tr_array arg; + BGET_op_tr_array(arg); + cPVOP->op_pv = arg; + break; + } + case INSN_OP_REDOOP: /* 105 */ + { + opindex arg; + BGET_opindex(arg); + cLOOP->op_redoop = arg; + break; + } + case INSN_OP_NEXTOP: /* 106 */ + { + opindex arg; + BGET_opindex(arg); + cLOOP->op_nextop = arg; + break; + } + case INSN_OP_LASTOP: /* 107 */ + { + opindex arg; + BGET_opindex(arg); + cLOOP->op_lastop = arg; + break; + } + case INSN_COP_LABEL: /* 108 */ + { + pvcontents arg; + BGET_pvcontents(arg); + cCOP->cop_label = arg; + break; + } + case INSN_COP_STASHPV: /* 109 */ + { + pvcontents arg; + BGET_pvcontents(arg); + BSET_cop_stashpv(cCOP, arg); + break; + } + case INSN_COP_FILE: /* 110 */ + { + pvcontents arg; + BGET_pvcontents(arg); + BSET_cop_file(cCOP, arg); + break; + } + case INSN_COP_SEQ: /* 111 */ + { + U32 arg; + BGET_U32(arg); + cCOP->cop_seq = arg; + break; + } + case INSN_COP_ARYBASE: /* 112 */ + { + I32 arg; + BGET_I32(arg); + cCOP->cop_arybase = arg; + break; + } + case INSN_COP_LINE: /* 113 */ + { + line_t arg; + BGET_U16(arg); + BSET_cop_line(cCOP, arg); + break; + } + case INSN_COP_WARNINGS: /* 114 */ + { + svindex arg; + BGET_svindex(arg); + cCOP->cop_warnings = arg; + break; + } + case INSN_MAIN_START: /* 115 */ + { + opindex arg; + BGET_opindex(arg); + PL_main_start = arg; + break; + } + case INSN_MAIN_ROOT: /* 116 */ + { + opindex arg; + BGET_opindex(arg); + PL_main_root = arg; + break; + } + case INSN_CURPAD: /* 117 */ + { + svindex arg; + BGET_svindex(arg); + BSET_curpad(PL_curpad, arg); + break; + } + default: + Perl_croak(aTHX_ "Illegal bytecode instruction %d\n", insn); + /* NOTREACHED */ + } + } +} diff --git a/contrib/perl5/ext/ByteLoader/byterun.h b/contrib/perl5/ext/ByteLoader/byterun.h new file mode 100644 index 0000000..f0de6b4 --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/byterun.h @@ -0,0 +1,161 @@ +/* + * Copyright (c) 1996-1999 Malcolm Beattie + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ +/* + * This file is autogenerated from bytecode.pl. Changes made here will be lost. + */ +struct bytestream { + void *data; + int (*pfgetc)(void *); + int (*pfread)(char *, size_t, size_t, void *); + void (*pfreadpv)(U32, void *, XPV *); +}; + +enum { + INSN_RET, /* 0 */ + INSN_LDSV, /* 1 */ + INSN_LDOP, /* 2 */ + INSN_STSV, /* 3 */ + INSN_STOP, /* 4 */ + INSN_LDSPECSV, /* 5 */ + INSN_NEWSV, /* 6 */ + INSN_NEWOP, /* 7 */ + INSN_NEWOPN, /* 8 */ + INSN_NEWPV, /* 9 */ + INSN_NOP, /* 10 */ + INSN_PV_CUR, /* 11 */ + INSN_PV_FREE, /* 12 */ + INSN_SV_UPGRADE, /* 13 */ + INSN_SV_REFCNT, /* 14 */ + INSN_SV_REFCNT_ADD, /* 15 */ + INSN_SV_FLAGS, /* 16 */ + INSN_XRV, /* 17 */ + INSN_XPV, /* 18 */ + INSN_XIV32, /* 19 */ + INSN_XIV64, /* 20 */ + INSN_XNV, /* 21 */ + INSN_XLV_TARGOFF, /* 22 */ + INSN_XLV_TARGLEN, /* 23 */ + INSN_XLV_TARG, /* 24 */ + INSN_XLV_TYPE, /* 25 */ + INSN_XBM_USEFUL, /* 26 */ + INSN_XBM_PREVIOUS, /* 27 */ + INSN_XBM_RARE, /* 28 */ + INSN_XFM_LINES, /* 29 */ + INSN_XIO_LINES, /* 30 */ + INSN_XIO_PAGE, /* 31 */ + INSN_XIO_PAGE_LEN, /* 32 */ + INSN_XIO_LINES_LEFT, /* 33 */ + INSN_XIO_TOP_NAME, /* 34 */ + INSN_COMMENT, /* 35 */ + INSN_XIO_TOP_GV, /* 36 */ + INSN_XIO_FMT_NAME, /* 37 */ + INSN_XIO_FMT_GV, /* 38 */ + INSN_XIO_BOTTOM_NAME, /* 39 */ + INSN_XIO_BOTTOM_GV, /* 40 */ + INSN_XIO_SUBPROCESS, /* 41 */ + INSN_XIO_TYPE, /* 42 */ + INSN_XIO_FLAGS, /* 43 */ + INSN_XCV_STASH, /* 44 */ + INSN_XCV_START, /* 45 */ + INSN_XCV_ROOT, /* 46 */ + INSN_XCV_GV, /* 47 */ + INSN_XCV_FILE, /* 48 */ + INSN_XCV_DEPTH, /* 49 */ + INSN_XCV_PADLIST, /* 50 */ + INSN_XCV_OUTSIDE, /* 51 */ + INSN_XCV_FLAGS, /* 52 */ + INSN_AV_EXTEND, /* 53 */ + INSN_AV_PUSH, /* 54 */ + INSN_XAV_FILL, /* 55 */ + INSN_XAV_MAX, /* 56 */ + INSN_XAV_FLAGS, /* 57 */ + INSN_XHV_RITER, /* 58 */ + INSN_XHV_NAME, /* 59 */ + INSN_HV_STORE, /* 60 */ + INSN_SV_MAGIC, /* 61 */ + INSN_MG_OBJ, /* 62 */ + INSN_MG_PRIVATE, /* 63 */ + INSN_MG_FLAGS, /* 64 */ + INSN_MG_PV, /* 65 */ + INSN_XMG_STASH, /* 66 */ + INSN_GV_FETCHPV, /* 67 */ + INSN_GV_STASHPV, /* 68 */ + INSN_GP_SV, /* 69 */ + INSN_GP_REFCNT, /* 70 */ + INSN_GP_REFCNT_ADD, /* 71 */ + INSN_GP_AV, /* 72 */ + INSN_GP_HV, /* 73 */ + INSN_GP_CV, /* 74 */ + INSN_GP_FILE, /* 75 */ + INSN_GP_IO, /* 76 */ + INSN_GP_FORM, /* 77 */ + INSN_GP_CVGEN, /* 78 */ + INSN_GP_LINE, /* 79 */ + INSN_GP_SHARE, /* 80 */ + INSN_XGV_FLAGS, /* 81 */ + INSN_OP_NEXT, /* 82 */ + INSN_OP_SIBLING, /* 83 */ + INSN_OP_PPADDR, /* 84 */ + INSN_OP_TARG, /* 85 */ + INSN_OP_TYPE, /* 86 */ + INSN_OP_SEQ, /* 87 */ + INSN_OP_FLAGS, /* 88 */ + INSN_OP_PRIVATE, /* 89 */ + INSN_OP_FIRST, /* 90 */ + INSN_OP_LAST, /* 91 */ + INSN_OP_OTHER, /* 92 */ + INSN_OP_CHILDREN, /* 93 */ + INSN_OP_PMREPLROOT, /* 94 */ + INSN_OP_PMREPLROOTGV, /* 95 */ + INSN_OP_PMREPLSTART, /* 96 */ + INSN_OP_PMNEXT, /* 97 */ + INSN_PREGCOMP, /* 98 */ + INSN_OP_PMFLAGS, /* 99 */ + INSN_OP_PMPERMFLAGS, /* 100 */ + INSN_OP_SV, /* 101 */ + INSN_OP_PADIX, /* 102 */ + INSN_OP_PV, /* 103 */ + INSN_OP_PV_TR, /* 104 */ + INSN_OP_REDOOP, /* 105 */ + INSN_OP_NEXTOP, /* 106 */ + INSN_OP_LASTOP, /* 107 */ + INSN_COP_LABEL, /* 108 */ + INSN_COP_STASHPV, /* 109 */ + INSN_COP_FILE, /* 110 */ + INSN_COP_SEQ, /* 111 */ + INSN_COP_ARYBASE, /* 112 */ + INSN_COP_LINE, /* 113 */ + INSN_COP_WARNINGS, /* 114 */ + INSN_MAIN_START, /* 115 */ + INSN_MAIN_ROOT, /* 116 */ + INSN_CURPAD, /* 117 */ + MAX_INSN = 117 +}; + +enum { + OPt_OP, /* 0 */ + OPt_UNOP, /* 1 */ + OPt_BINOP, /* 2 */ + OPt_LOGOP, /* 3 */ + OPt_LISTOP, /* 4 */ + OPt_PMOP, /* 5 */ + OPt_SVOP, /* 6 */ + OPt_PADOP, /* 7 */ + OPt_PVOP, /* 8 */ + OPt_LOOP, /* 9 */ + OPt_COP /* 10 */ +}; + +extern void byterun(pTHXo_ struct bytestream bs); + +#define INIT_SPECIALSV_LIST STMT_START { \ + PL_specialsv_list[0] = Nullsv; \ + PL_specialsv_list[1] = &PL_sv_undef; \ + PL_specialsv_list[2] = &PL_sv_yes; \ + PL_specialsv_list[3] = &PL_sv_no; \ + } STMT_END diff --git a/contrib/perl5/ext/ByteLoader/hints/sunos.pl b/contrib/perl5/ext/ByteLoader/hints/sunos.pl new file mode 100644 index 0000000..3faf498 --- /dev/null +++ b/contrib/perl5/ext/ByteLoader/hints/sunos.pl @@ -0,0 +1,2 @@ +$self->{CCFLAGS} = $Config{ccflags} . ' -DNEED_FGETC_PROTOTYPE -DNEED_FREAD_PROTOTYPE'; + diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes index 2fab919..95eb487 100644 --- a/contrib/perl5/ext/DB_File/Changes +++ b/contrib/perl5/ext/DB_File/Changes @@ -230,5 +230,64 @@ * Updated the message that db-recno.t prints when tests 51, 53 or 55 fail. 1.65 6th March 1999 + * Fixed a bug in the recno PUSH logic. * The BOOT version check now needs 2.3.4 when using Berkeley DB version 2 + +1.66 15th March 1999 + + * Added DBM Filter code + +1.67 6th June 1999 + + * Added DBM Filter documentation to DB_File.pm + + * Fixed DBM Filter code to work with 5.004 + + * A few instances of newSVpvn were used in 1.66. This isn't available in + Perl 5.004_04 or earlier. Replaced with newSVpv. + +1.68 22nd July 1999 + + * Merged changes from 5.005_58 + + * Fixed a bug in R_IBEFORE & R_IAFTER procesing in Berkeley DB + 2 databases. + + * Added some of the examples in the POD into the test harness. + +1.69 3rd August 1999 + + * fixed a bug in push -- DB_APPEND wasn't working properly. + + * Fixed the R_SETCURSOR bug introduced in 1.68 + + * Added a new Perl variable $DB_File::db_ver + +1.70 4th August 1999 + + * Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + + * Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + +1.71 7th September 1999 + + * Fixed a bug that prevented 1.70 from compiling under win32 + + * Updated to support Berkeley DB 3.x + + * Updated dbinfo for Berkeley DB 3.x file formats. + +1.72 16th January 2000 + + * Added hints/sco.pl + + * The module will now use XSLoader when it is available. When it + isn't it will use DynaLoader. + + * The locking section in DB_File.pm has been discredited. Many thanks + to David Harris for spotting the underlying problem, contributing + the updates to the documentation and writing DB_File::Lock (available + on CPAN). diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm index e5759ff..00b24b9 100644 --- a/contrib/perl5/ext/DB_File/DB_File.pm +++ b/contrib/perl5/ext/DB_File/DB_File.pm @@ -1,10 +1,10 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 6th March 1999 -# version 1.65 +# last modified 16th January 2000 +# version 1.72 # -# Copyright (c) 1995-9 Paul Marquess. All rights reserved. +# Copyright (c) 1995-2000 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -141,11 +141,13 @@ sub TIEHASH package DB_File ; use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version) ; +use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO + $db_version $use_XSLoader + ) ; use Carp; -$VERSION = "1.65" ; +$VERSION = "1.72" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -155,8 +157,18 @@ $DB_RECNO = new DB_File::RECNOINFO ; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +BEGIN { + $use_XSLoader = 1 ; + eval { require XSLoader } ; + + if ($@) { + $use_XSLoader = 0 ; + require DynaLoader; + @ISA = qw(DynaLoader); + } +} + +push @ISA, qw(Tie::Hash Exporter); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO @@ -196,7 +208,7 @@ sub AUTOLOAD { ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -219,19 +231,10 @@ eval { push(@EXPORT, @O); }; -## import borrowed from IO::File -## exports Fcntl constants if available. -#sub import { -# my $pkg = shift; -# my $callpkg = caller; -# Exporter::export $pkg, $callpkg, @_; -# eval { -# require Fcntl; -# Exporter::export 'Fcntl', $callpkg, '/^O_/'; -# }; -#} - -bootstrap DB_File $VERSION; +if ($use_XSLoader) + { XSLoader::load("DB_File", $VERSION)} +else + { bootstrap DB_File $VERSION } # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. @@ -408,6 +411,12 @@ DB_File - Perl5 access to Berkeley DB version 1.x $a = $X->shift; $X->unshift(list); + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + untie %hash ; untie @array ; @@ -415,10 +424,10 @@ DB_File - Perl5 access to Berkeley DB version 1.x B<DB_File> is a module which allows Perl programs to make use of the facilities provided by Berkeley DB version 1.x (if you have a newer -version of DB, see L<Using DB_File with Berkeley DB version 2>). It is -assumed that you have a copy of the Berkeley DB manual pages at hand -when reading this documentation. The interface defined here mirrors the -Berkeley DB interface closely. +version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>). +It is assumed that you have a copy of the Berkeley DB manual pages at +hand when reading this documentation. The interface defined here +mirrors the Berkeley DB interface closely. Berkeley DB is a C library which provides a consistent interface to a number of database formats. B<DB_File> provides an interface to all @@ -459,32 +468,28 @@ number. =back -=head2 Using DB_File with Berkeley DB version 2 +=head2 Using DB_File with Berkeley DB version 2 or 3 Although B<DB_File> is intended to be used with Berkeley DB version 1, -it can also be used with version 2. In this case the interface is +it can also be used with version 2.or 3 In this case the interface is limited to the functionality provided by Berkeley DB 1.x. Anywhere the -version 2 interface differs, B<DB_File> arranges for it to work like -version 1. This feature allows B<DB_File> scripts that were built with -version 1 to be migrated to version 2 without any changes. +version 2 or 3 interface differs, B<DB_File> arranges for it to work +like version 1. This feature allows B<DB_File> scripts that were built +with version 1 to be migrated to version 2 or 3 without any changes. If you want to make use of the new features available in Berkeley DB -2.x, use the Perl module B<BerkeleyDB> instead. - -At the time of writing this document the B<BerkeleyDB> module is still -alpha quality (the version number is < 1.0), and so unsuitable for use -in any serious development work. Once its version number is >= 1.0, it -is considered stable enough for real work. +2.x or greater, use the Perl module B<BerkeleyDB> instead. -B<Note:> The database file format has changed in Berkeley DB version 2. -If you cannot recreate your databases, you must dump any existing -databases with the C<db_dump185> utility that comes with Berkeley DB. -Once you have rebuilt DB_File to use Berkeley DB version 2, your +B<Note:> The database file format has changed in both Berkeley DB +version 2 and 3. If you cannot recreate your databases, you must dump +any existing databases with the C<db_dump185> utility that comes with +Berkeley DB. +Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your databases can be recreated using C<db_load>. Refer to the Berkeley DB documentation for further details. -Please read L<"COPYRIGHT"> before using version 2.x of Berkeley DB with -DB_File. +Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley +DB with DB_File. =head2 Interface to Berkeley DB @@ -664,6 +669,7 @@ contents of the database. use DB_File ; use vars qw( %h $k $v ) ; + unlink "fruit" ; tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH or die "Cannot open file 'fruit': $!\n"; @@ -723,6 +729,7 @@ insensitive compare function will be used. # specify the Perl sub that will do the comparison $DB_BTREE->{'compare'} = \&Compare ; + unlink "tree" ; tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE or die "Cannot open file 'tree': $!\n" ; @@ -799,7 +806,7 @@ code: # iterate through the associative array # and print each key/value pair. - foreach (keys %h) + foreach (sort keys %h) { print "$_ -> $h{$_}\n" } untie %h ; @@ -901,6 +908,19 @@ particular value occurred in the BTREE. So assuming the database created above, we can use C<get_dup> like this: + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + my $cnt = $x->get_dup("Wall") ; print "Wall occurred $cnt times\n" ; @@ -908,7 +928,7 @@ this: print "Larry is there\n" if $hash{'Larry'} ; print "There are $hash{'Brick'} Brick Walls\n" ; - my @list = $x->get_dup("Wall") ; + my @list = sort $x->get_dup("Wall") ; print "Wall => [@list]\n" ; @list = $x->get_dup("Smith") ; @@ -931,7 +951,7 @@ and it will print: $status = $X->find_dup($key, $value) ; -This method checks for the existance of a specific key/value pair. If the +This method checks for the existence of a specific key/value pair. If the pair exists, the cursor is left pointing to the pair and the method returns 0. Otherwise the method returns a non-zero value. @@ -961,7 +981,7 @@ Assuming the database from the previous example: prints this - Larry Wall is there + Larry Wall is there Harry Wall is not there @@ -973,7 +993,7 @@ This method deletes a specific key/value pair. It returns 0 if they exist and have been deleted successfully. Otherwise the method returns a non-zero value. -Again assuming the existance of the C<tree> database +Again assuming the existence of the C<tree> database use strict ; use DB_File ; @@ -1053,7 +1073,7 @@ and print the first matching key/value pair given a partial key. $st == 0 ; $st = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } + { print "$key -> $value\n" } print "\nPARTIAL MATCH\n" ; @@ -1126,8 +1146,11 @@ L<Extra RECNO Methods> for a workaround). use strict ; use DB_File ; + my $filename = "text" ; + unlink $filename ; + my @h ; - tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO + tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO or die "Cannot open file 'text': $!\n" ; # Add a few key/value pairs to the file @@ -1160,7 +1183,7 @@ Here is the output from the script: The array contains 5 entries popped black - unshifted white + shifted white Element 1 Exists with value blue The last element is green The 2nd last element is yellow @@ -1466,8 +1489,8 @@ R_CURSOR is the only valid flag at present. Returns the file descriptor for the underlying database. -See L<Locking Databases> for an example of how to make use of the -C<fd> method to lock your database. +See L<Locking: The Trouble with fd> for an explanation for why you should +not use C<fd> to lock your database. =item B<$status = $X-E<gt>seq($key, $value, $flags) ;> @@ -1488,67 +1511,262 @@ R_RECNOSYNC is the only valid flag at present. =back -=head1 HINTS AND TIPS +=head1 DBM FILTERS +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a +DBM database. -=head2 Locking Databases +There are four methods associated with DBM Filters. All work identically, +and each is used to install (or uninstall) a single DBM Filter. Each +expects a single parameter, namely a reference to a sub. The only +difference between them is the place that the filter is installed. -Concurrent access of a read-write database by several parties requires -them all to use some kind of locking. Here's an example of Tom's that -uses the I<fd> method to get the file descriptor, and then a careful -open() to give something Perl will flock() for you. Run this repeatedly -in the background to watch the locks granted in proper order. +To summarise: - use DB_File; +=over 5 - use strict; +=item B<filter_store_key> - sub LOCK_SH { 1 } - sub LOCK_EX { 2 } - sub LOCK_NB { 4 } - sub LOCK_UN { 8 } +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. - my($oldval, $fd, $db, %db, $value, $key); +=item B<filter_store_value> - $key = shift || 'default'; - $value = shift || 'magic'; +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. - $value .= " $$"; - $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) - || die "dbcreat /tmp/foo.db $!"; - $fd = $db->fd; - print "$$: db fd is $fd\n"; - open(DB_FH, "+<&=$fd") || die "dup $!"; +=item B<filter_fetch_key> +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. - unless (flock (DB_FH, LOCK_SH | LOCK_NB)) { - print "$$: CONTENTION; can't read during write update! - Waiting for read lock ($!) ...."; - unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" } - } - print "$$: Read lock granted\n"; +=item B<filter_fetch_value> - $oldval = $db{$key}; - print "$$: Old value was $oldval\n"; - flock(DB_FH, LOCK_UN); +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. - unless (flock (DB_FH, LOCK_EX | LOCK_NB)) { - print "$$: CONTENTION; must have exclusive lock! - Waiting for write lock ($!) ...."; - unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" } - } +=back - print "$$: Write lock granted\n"; - $db{$key} = $value; - $db->sync; # to flush - sleep 10; +You can use any combination of the methods, from none, to all four. +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database +that you need to share with a third-party C application. The C application +assumes that I<all> keys and values are NULL terminated. Unfortunately +when Perl writes to DBM databases it doesn't use NULL termination, so +your Perl application will have to manage NULL termination itself. When +you write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + + use strict ; + use DB_File ; + + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "soemthing" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + + use strict ; + use DB_File ; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 HINTS AND TIPS + + +=head2 Locking: The Trouble with fd + +Until version 1.72 of this module, the recommended technique for locking +B<DB_File> databases was to flock the filehandle returned from the "fd" +function. Unfortunately this technique has been shown to be fundamentally +flawed (Kudos to David Harris for tracking this down). Use it at your own +peril! + +The locking technique went like this. + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + open(DB_FH, "+<&=$fd") || die "dup $!"; + flock (DB_FH, LOCK_EX) || die "flock: $!"; + ... + $db{"Tom"} = "Jerry" ; + ... flock(DB_FH, LOCK_UN); undef $db; untie %db; close(DB_FH); - print "$$: Updated db to $key=$value\n"; + +In simple terms, this is what happens: + +=over 5 + +=item 1. + +Use "tie" to open the database. + +=item 2. + +Lock the database with fd & flock. + +=item 3. + +Read & Write to the database. + +=item 4. + +Unlock and close the database. + +=back + +Here is the crux of the problem. A side-effect of opening the B<DB_File> +database in step 2 is that an initial block from the database will get +read from disk and cached in memory. + +To see why this is a problem, consider what can happen when two processes, +say "A" and "B", both want to update the same B<DB_File> database +using the locking steps outlined above. Assume process "A" has already +opened the database and has a write lock, but it hasn't actually updated +the database yet (it has finished step 2, but not started step 3 yet). Now +process "B" tries to open the same database - step 1 will succeed, +but it will block on step 2 until process "A" releases the lock. The +important thing to notice here is that at this point in time both +processes will have cached identical initial blocks from the database. + +Now process "A" updates the database and happens to change some of the +data held in the initial buffer. Process "A" terminates, flushing +all cached data to disk and releasing the database lock. At this point +the database on disk will correctly reflect the changes made by process +"A". + +With the lock released, process "B" can now continue. It also updates the +database and unfortunately it too modifies the data that was in its +initial buffer. Once that data gets flushed to disk it will overwrite +some/all of the changes process "A" made to the database. + +The result of this scenario is at best a database that doesn't contain +what you expect. At worst the database will corrupt. + +The above won't happen every time competing process update the same +B<DB_File> database, but it does illustrate why the technique should +not be used. + +=head2 Safe ways to lock a database + +Starting with version 2.x, Berkeley DB has internal support for locking. +The companion module to this one, B<BerkeleyDB>, provides an interface +to this locking functionality. If you are serious about locking +Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. + +If using B<BerkeleyDB> isn't an option, there are a number of modules +available on CPAN that can be used to implement locking. Each one +implements locking differently and has different goals in mind. It is +therefore worth knowing the difference, so that you can pick the right +one for your application. Here are the three locking wrappers: + +=over 5 + +=item B<Tie::DB_Lock> + +A B<DB_File> wrapper which creates copies of the database file for +read access, so that you have a kind of a multiversioning concurrent read +system. However, updates are still serial. Use for databases where reads +may be lengthy and consistency problems may occur. + +=item B<Tie::DB_LockFile> + +A B<DB_File> wrapper that has the ability to lock and unlock the database +while it is being used. Avoids the tie-before-flock problem by simply +re-tie-ing the database when you get or drop a lock. Because of the +flexibility in dropping and re-acquiring the lock in the middle of a +session, this can be massaged into a system that will work with long +updates and/or reads if the application follows the hints in the POD +documentation. + +=item B<DB_File::Lock> + +An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile +before tie-ing the database and drops the lock after the untie. Allows +one to use the same lockfile for multiple databases to avoid deadlock +problems, if desired. Use for databases where updates are reads are +quick and simple flock locking semantics are enough. + +=back =head2 Sharing Databases With C Applications @@ -1557,7 +1775,7 @@ shared by both a Perl and a C application. The vast majority of problems that are reported in this area boil down to the fact that C strings are NULL terminated, whilst Perl strings are -not. +not. See L<DBM FILTERS> for a generic way to work around this problem. Here is a real example. Netscape 2.0 keeps a record of the locations you visit along with the time you last visited them in a DB_HASH database. @@ -1654,7 +1872,7 @@ C<%x>, and C<$X> above hold a reference to the object. The call to untie() will destroy the first, but C<$X> still holds a valid reference, so the destructor will not get called and the database file F<tst.fil> will remain open. The fact that Berkeley DB then reports the -attempt to open a database that is alreday open via the catch-all +attempt to open a database that is already open via the catch-all "Invalid argument" doesn't help. If you run the script with the C<-w> flag the error message becomes: @@ -1746,6 +1964,19 @@ double quotes, like this: Although it might seem like a real pain, it is really worth the effort of having a C<use strict> in all your scripts. +=head1 REFERENCES + +Articles that are either about B<DB_File> or make use of it. + +=over 5 + +=item 1. + +I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), +Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 + +=back + =head1 HISTORY Moved to the Changes file. @@ -1768,13 +1999,12 @@ date, so the most recent version can always be found on CPAN (see L<perlmod/CPAN> for details), in the directory F<modules/by-module/DB_File>. -This version of B<DB_File> will work with either version 1.x or 2.x of -Berkeley DB, but is limited to the functionality provided by version 1. +This version of B<DB_File> will work with either version 1.x, 2.x or +3.x of Berkeley DB, but is limited to the functionality provided by +version 1. -The official web site for Berkeley DB is -F<http://www.sleepycat.com/db>. The ftp equivalent is -F<ftp.sleepycat.com:/pub>. Both versions 1 and 2 of Berkeley DB are -available there. +The official web site for Berkeley DB is F<http://www.sleepycat.com>. +All versions of Berkeley DB are available there. Alternatively, Berkeley DB version 1 is available at your nearest CPAN archive in F<src/misc/db.1.85.tar.gz>. @@ -1785,7 +2015,7 @@ compile properly on IRIX 5.3. =head1 COPYRIGHT -Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program +Copyright (c) 1995-1999 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -1794,7 +2024,7 @@ makes use of, namely Berkeley DB, is not. Berkeley DB has its own copyright and its own license. Please take the time to read it. Here are are few words taken from the Berkeley DB FAQ (at -http://www.sleepycat.com) regarding the license: +F<http://www.sleepycat.com>) regarding the license: Do I have to license DB to use it in Perl scripts? @@ -1811,7 +2041,8 @@ Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. =head1 SEE ALSO -L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>, +L<dbmfilter> =head1 AUTHOR diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs index 94113eb..2b76bab 100644 --- a/contrib/perl5/ext/DB_File/DB_File.xs +++ b/contrib/perl5/ext/DB_File/DB_File.xs @@ -3,12 +3,12 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 6th March 1999 - version 1.65 + last modified 16th January 2000 + version 1.72 All comments/suggestions/problems are welcome - Copyright (c) 1995-9 Paul Marquess. All rights reserved. + Copyright (c) 1995-2000 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -65,8 +65,23 @@ to fix a flag mapping problem with O_RDONLY on the Hurd 1.65 - Fixed a bug in the PUSH logic. Added BOOT check that using 2.3.4 or greater - - + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. + 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE + merged in the 5.005_58 changes + 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. + Fixed the R_SETCURSOR bug introduced in 1.68 + Added a new Perl variable $DB_File::db_ver + 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + Rewrote push + 1.72 - No change to DB_File.xs */ @@ -75,10 +90,10 @@ #include "XSUB.h" #ifndef PERL_VERSION -#include "patchlevel.h" -#define PERL_REVISION 5 -#define PERL_VERSION PATCHLEVEL -#define PERL_SUBVERSION SUBVERSION +# include "patchlevel.h" +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION #endif #if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) @@ -88,6 +103,11 @@ #endif +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(defgv) +#endif + /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be * shortly #included by the <db.h>) __attribute__ to the possibly * already defined __attribute__, for example by GNUC or by Perl. */ @@ -98,33 +118,65 @@ be defined here. This clashes with a field name in db.h, so get rid of it. */ #ifdef op -#undef op +# undef op +#endif + +#ifdef COMPAT185 +# include <db_185.h> +#else +# include <db.h> +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + +#ifndef newSVpvn +# define newSVpvn(a,b) newSVpv(a,b) #endif -#include <db.h> #include <fcntl.h> /* #define TRACE */ +#define DBM_FILTERING + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif +#define DBT_clear(x) Zero(&x, 1, DBT) ; #ifdef DB_VERSION_MAJOR +#if DB_VERSION_MAJOR == 2 +# define BERKELEY_DB_1_OR_2 +#endif + /* map version 2 features & constants onto their version 1 equivalent */ #ifdef DB_Prefix_t -#undef DB_Prefix_t +# undef DB_Prefix_t #endif #define DB_Prefix_t size_t #ifdef DB_Hash_t -#undef DB_Hash_t +# undef DB_Hash_t #endif #define DB_Hash_t u_int32_t /* DBTYPE stays the same */ /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ -typedef DB_INFO INFO ; +#if DB_VERSION_MAJOR == 2 + typedef DB_INFO INFO ; +#else /* DB_VERSION_MAJOR > 2 */ +# define DB_FIXEDLEN (0x8000) +#endif /* DB_VERSION_MAJOR == 2 */ /* version 2 has db_recno_t in place of recno_t */ typedef db_recno_t recno_t; @@ -138,11 +190,18 @@ typedef db_recno_t recno_t; #define R_NEXT DB_NEXT #define R_NOOVERWRITE DB_NOOVERWRITE #define R_PREV DB_PREV -#define R_SETCURSOR 0 + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define R_SETCURSOR 0x800000 +#else +# define R_SETCURSOR (-100) +#endif + #define R_RECNOSYNC 0 #define R_FIXEDLEN DB_FIXEDLEN #define R_DUP DB_DUP + #define db_HA_hash h_hash #define db_HA_ffactor h_ffactor #define db_HA_nelem h_nelem @@ -177,13 +236,15 @@ typedef db_recno_t recno_t; #define DB_flags(x, v) x |= v #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -#define flagSet(flags, bitmask) ((flags) & (bitmask)) +# define flagSet(flags, bitmask) ((flags) & (bitmask)) #else -#define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) +# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) #endif #else /* db version 1.x */ +#define BERKELEY_DB_1_OR_2 + typedef union INFO { HASHINFO hash ; RECNOINFO recno ; @@ -192,17 +253,17 @@ typedef union INFO { #ifdef mDB_Prefix_t -#ifdef DB_Prefix_t -#undef DB_Prefix_t -#endif -#define DB_Prefix_t mDB_Prefix_t +# ifdef DB_Prefix_t +# undef DB_Prefix_t +# endif +# define DB_Prefix_t mDB_Prefix_t #endif #ifdef mDB_Hash_t -#ifdef DB_Hash_t -#undef DB_Hash_t -#endif -#define DB_Hash_t mDB_Hash_t +# ifdef DB_Hash_t +# undef DB_Hash_t +# endif +# define DB_Hash_t mDB_Hash_t #endif #define db_HA_hash hash.hash @@ -248,20 +309,21 @@ typedef union INFO { #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) #ifdef DB_VERSION_MAJOR -#define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0) +#define db_DESTROY(db) ( db->cursor->c_close(db->cursor),\ + (db->dbp->close)(db->dbp, 0) ) #define db_close(db) ((db->dbp)->close)(db->dbp, 0) #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ ? ((db->cursor)->c_del)(db->cursor, 0) \ : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) -#else +#else /* ! DB_VERSION_MAJOR */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_close(db) ((db->dbp)->close)(db->dbp) #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) -#endif +#endif /* ! DB_VERSION_MAJOR */ #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) @@ -273,32 +335,70 @@ typedef struct { SV * prefix ; SV * hash ; int in_memory ; +#ifdef BERKELEY_DB_1_OR_2 INFO info ; +#endif #ifdef DB_VERSION_MAJOR DBC * cursor ; #endif +#ifdef DBM_FILTERING + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; +#endif /* DBM_FILTERING */ + } DB_File_type; typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; +#ifdef DBM_FILTERING + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + +#else + +#define ckFilter(arg,type, name) + +#endif /* DBM_FILTERING */ + #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) -#define OutputValue(arg, name) \ - { if (RETVAL == 0) { \ - my_sv_setpvn(arg, name.data, name.size) ; \ - } \ +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ } -#define OutputKey(arg, name) \ - { if (RETVAL == 0) \ - { \ - if (db->type != DB_RECNO) { \ - my_sv_setpvn(arg, name.data, name.size); \ - } \ - else \ - sv_setiv(arg, (I32)*(I32*)name.data - 1); \ - } \ +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ } @@ -311,26 +411,57 @@ static DBTKEY empty ; #ifdef DB_VERSION_MAJOR static int +#ifdef CAN_PROTOTYPE +db_put(DB_File db, DBTKEY key, DBT value, u_int flags) +#else db_put(db, key, value, flags) DB_File db ; DBTKEY key ; DBT value ; u_int flags ; - +#endif { int status ; - if (flagSet(flags, R_CURSOR)) { - status = ((db->cursor)->c_del)(db->cursor, 0); - if (status != 0) - return status ; - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 - flags &= ~R_CURSOR ; + if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { + DBC * temp_cursor ; + DBT l_key, l_value; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) #else - flags &= ~DB_OPFLAGS_MASK ; + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) #endif + return (-1) ; + + memset(&l_key, 0, sizeof(l_key)); + l_key.data = key.data; + l_key.size = key.size; + memset(&l_value, 0, sizeof(l_value)); + l_value.data = value.data; + l_value.size = value.size; + + if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { + (void)temp_cursor->c_close(temp_cursor); + return (-1); + } + status = temp_cursor->c_put(temp_cursor, &key, &value, flags); + (void)temp_cursor->c_close(temp_cursor); + + return (status) ; + } + + + if (flagSet(flags, R_CURSOR)) { + return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); + } + + if (flagSet(flags, R_SETCURSOR)) { + if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) + return -1 ; + return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); + } return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; @@ -339,42 +470,19 @@ u_int flags ; #endif /* DB_VERSION_MAJOR */ -static void -GetVersionInfo() -{ - SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ; -#ifdef DB_VERSION_MAJOR - int Major, Minor, Patch ; - - (void)db_version(&Major, &Minor, &Patch) ; - - /* check that libdb is recent enough -- we need 2.3.4 or greater */ - if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) - croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", - Major, Minor, Patch) ; - -#if PERL_VERSION > 3 - sv_setpvf(ver_sv, "%d.%d", Major, Minor) ; -#else - { - char buffer[40] ; - sprintf(buffer, "%d.%d", Major, Minor) ; - sv_setpv(ver_sv, buffer) ; - } -#endif - -#else - sv_setiv(ver_sv, 1) ; -#endif - -} - static int +#ifdef CAN_PROTOTYPE +btree_compare(const DBT *key1, const DBT *key2) +#else btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; +#endif { +#ifdef dTHX + dTHX; +#endif dSP ; void * data1, * data2 ; int retval ; @@ -383,6 +491,7 @@ const DBT * key2 ; data1 = key1->data ; data2 = key2->data ; +#ifndef newSVpvn /* As newSVpv will assume that the data pointer is a null terminated C string if the size parameter is 0, make sure that data points to an empty string if the length is 0 @@ -391,14 +500,15 @@ const DBT * key2 ; data1 = "" ; if (key2->size == 0) data2 = "" ; +#endif ENTER ; SAVETMPS; PUSHMARK(SP) ; EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpv(data1,key1->size))); - PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; count = perl_call_sv(CurrentDB->compare, G_SCALAR); @@ -418,10 +528,17 @@ const DBT * key2 ; } static DB_Prefix_t +#ifdef CAN_PROTOTYPE +btree_prefix(const DBT *key1, const DBT *key2) +#else btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; +#endif { +#ifdef dTHX + dTHX; +#endif dSP ; void * data1, * data2 ; int retval ; @@ -430,6 +547,7 @@ const DBT * key2 ; data1 = key1->data ; data2 = key2->data ; +#ifndef newSVpvn /* As newSVpv will assume that the data pointer is a null terminated C string if the size parameter is 0, make sure that data points to an empty string if the length is 0 @@ -438,14 +556,15 @@ const DBT * key2 ; data1 = "" ; if (key2->size == 0) data2 = "" ; +#endif ENTER ; SAVETMPS; PUSHMARK(SP) ; EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpv(data1,key1->size))); - PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; count = perl_call_sv(CurrentDB->prefix, G_SCALAR); @@ -465,16 +584,25 @@ const DBT * key2 ; } static DB_Hash_t +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, size_t size) +#else hash_cb(data, size) const void * data ; size_t size ; +#endif { +#ifdef dTHX + dTHX; +#endif dSP ; int retval ; int count ; +#ifndef newSVpvn if (size == 0) data = "" ; +#endif /* DGH - Next two lines added to fix corrupted stack problem */ ENTER ; @@ -482,7 +610,7 @@ size_t size ; PUSHMARK(SP) ; - XPUSHs(sv_2mortal(newSVpv((char*)data,size))); + XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); PUTBACK ; count = perl_call_sv(CurrentDB->hash, G_SCALAR); @@ -502,11 +630,15 @@ size_t size ; } -#ifdef TRACE +#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) static void +#ifdef CAN_PROTOTYPE +PrintHash(INFO *hash) +#else PrintHash(hash) INFO * hash ; +#endif { printf ("HASH Info\n") ; printf (" hash = %s\n", @@ -520,8 +652,12 @@ INFO * hash ; } static void +#ifdef CAN_PROTOTYPE +PrintRecno(INFO *recno) +#else PrintRecno(recno) INFO * recno ; +#endif { printf ("RECNO Info\n") ; printf (" flags = %d\n", recno->db_RE_flags) ; @@ -534,8 +670,12 @@ INFO * recno ; } static void +#ifdef CAN_PROTOTYPE +PrintBtree(INFO *btree) +#else PrintBtree(btree) INFO * btree ; +#endif { printf ("BTREE Info\n") ; printf (" compare = %s\n", @@ -562,15 +702,19 @@ INFO * btree ; static I32 +#ifdef CAN_PROTOTYPE +GetArrayLength(pTHX_ DB_File db) +#else GetArrayLength(db) DB_File db ; +#endif { DBT key ; DBT value ; int RETVAL ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; RETVAL = do_SEQ(db, key, value, R_LAST) ; if (RETVAL == 0) RETVAL = *(I32 *)key.data ; @@ -581,13 +725,17 @@ DB_File db ; } static recno_t +#ifdef CAN_PROTOTYPE +GetRecnoKey(pTHX_ DB_File db, I32 value) +#else GetRecnoKey(db, value) DB_File db ; I32 value ; +#endif { if (value < 0) { /* Get the length of the array */ - I32 length = GetArrayLength(db) ; + I32 length = GetArrayLength(aTHX_ db) ; /* check for attempt to write before start of array */ if (length + value + 1 <= 0) @@ -601,14 +749,22 @@ I32 value ; return value ; } + static DB_File +#ifdef CAN_PROTOTYPE +ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) +#else ParseOpenInfo(isHASH, name, flags, mode, sv) int isHASH ; char * name ; int flags ; int mode ; SV * sv ; +#endif { + +#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ + SV ** svp; HV * action ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; @@ -620,6 +776,11 @@ SV * sv ; Zero(RETVAL, 1, DB_File_type) ; /* Default to HASH */ +#ifdef DBM_FILTERING + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = +#endif /* DBM_FILTERING */ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; @@ -864,25 +1025,275 @@ SV * sv ; } #else + +#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 + RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; +#else RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif /* DB_LIBRARY_COMPATIBILITY_API */ + #endif return (RETVAL) ; -} +#else /* Berkeley DB Version > 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB * dbp ; + STRLEN n_a; + int status ; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ +#ifdef DBM_FILTERING + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = +#endif /* DBM_FILTERING */ + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; + + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + + status = db_create(&RETVAL->dbp, NULL,0) ; + /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ + if (status) { + RETVAL->dbp = NULL ; + return (RETVAL) ; + } + dbp = RETVAL->dbp ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + + if (sv_isa(sv, "DB_File::HASHINFO")) + { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + + RETVAL->type = DB_HASH ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + (void)dbp->set_h_hash(dbp, hash_cb) ; + RETVAL->hash = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "ffactor", 7, FALSE); + if (svp) + (void)dbp->set_h_ffactor(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "nelem", 5, FALSE); + if (svp) + (void)dbp->set_h_nelem(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "bsize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, SvIV(*svp)); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, SvIV(*svp)) ; + + PrintHash(info) ; + } + else if (sv_isa(sv, "DB_File::BTREEINFO")) + { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + + RETVAL->type = DB_BTREE ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_compare(dbp, btree_compare) ; + RETVAL->compare = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_prefix(dbp, btree_prefix) ; + RETVAL->prefix = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) + (void)dbp->set_flags(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, SvIV(*svp)) ; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + int fixed = FALSE ; + + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) { + int flags = SvIV(*svp) ; + /* remove FIXDLEN, if present */ + if (flags & DB_FIXEDLEN) { + fixed = TRUE ; + flags &= ~DB_FIXEDLEN ; + } + } + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) { + status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + } + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) { + status = dbp->set_pagesize(dbp, SvIV(*svp)) ; + } + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) { + status = dbp->set_lorder(dbp, SvIV(*svp)) ; + } + + svp = hv_fetch(action, "bval", 4, FALSE); + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (fixed) { + status = dbp->set_re_pad(dbp, value) ; + } + else { + status = dbp->set_re_delim(dbp, value) ; + } + + } + + if (fixed) { + svp = hv_fetch(action, "reclen", 6, FALSE); + if (svp) { + u_int32_t len = (u_int32_t)SvIV(*svp) ; + status = dbp->set_re_len(dbp, len) ; + } + } + + if (name != NULL) { + status = dbp->set_re_source(dbp, name) ; + name = NULL ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; + name = (char*) n_a ? ptr : NULL ; + } + else + name = NULL ; + + + status = dbp->set_flags(dbp, DB_RENUMBER) ; + + if (flags){ + (void)dbp->set_flags(dbp, flags) ; + } + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 3.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, + Flags, mode) ; + /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ + + if (status == 0) + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; + /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + + if (status) + RETVAL->dbp = NULL ; + + } + + return (RETVAL) ; + +#endif /* Berkeley DB Version > 2 */ + +} /* ParseOpenInfo */ -static int -not_here(s) -char *s; -{ - croak("DB_File::%s not implemented on this architecture", s); - return -1; -} static double +#ifdef CAN_PROTOTYPE +constant(char *name, int arg) +#else constant(name, arg) char *name; int arg; +#endif { errno = 0; switch (*name) { @@ -1115,11 +1526,11 @@ MODULE = DB_File PACKAGE = DB_File PREFIX = db_ BOOT: { - GetVersionInfo() ; + __getBerkeleyDBInfo() ; + DBT_clear(empty) ; empty.data = &zero ; empty.size = sizeof(recno_t) ; - DBT_flags(empty) ; } double @@ -1146,7 +1557,7 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H if (items == 6) sv = ST(5) ; - RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ; + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; if (RETVAL->dbp == NULL) RETVAL = NULL ; } @@ -1165,7 +1576,17 @@ db_DESTROY(db) SvREFCNT_dec(db->compare) ; if (db->prefix) SvREFCNT_dec(db->prefix) ; - Safefree(db) ; +#ifdef DBM_FILTERING + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; +#endif /* DBM_FILTERING */ + safefree(db) ; #ifdef DB_VERSION_MAJOR if (RETVAL > 0) RETVAL = -1 ; @@ -1189,7 +1610,7 @@ db_EXISTS(db, key) { DBT value ; - DBT_flags(value) ; + DBT_clear(value) ; CurrentDB = db ; RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; } @@ -1205,7 +1626,7 @@ db_FETCH(db, key, flags=0) { DBT value ; - DBT_flags(value) ; + DBT_clear(value) ; CurrentDB = db ; /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ RETVAL = db_get(db, key, value, flags) ; @@ -1231,8 +1652,8 @@ db_FIRSTKEY(db) DBTKEY key ; DBT value ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; RETVAL = do_SEQ(db, key, value, R_FIRST) ; ST(0) = sv_newmortal(); @@ -1247,7 +1668,7 @@ db_NEXTKEY(db, key) { DBT value ; - DBT_flags(value) ; + DBT_clear(value) ; CurrentDB = db ; RETVAL = do_SEQ(db, key, value, R_NEXT) ; ST(0) = sv_newmortal(); @@ -1271,8 +1692,8 @@ unshift(db, ...) DB * Db = db->dbp ; STRLEN n_a; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; #ifdef DB_VERSION_MAJOR /* get the first value */ @@ -1309,8 +1730,8 @@ pop(db) DBTKEY key ; DBT value ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; /* First get the final value */ @@ -1336,8 +1757,8 @@ shift(db) DBT value ; DBTKEY key ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; /* get the first value */ RETVAL = do_SEQ(db, key, value, R_FIRST) ; @@ -1365,50 +1786,44 @@ push(db, ...) DB * Db = db->dbp ; int i ; STRLEN n_a; + int keyval ; DBT_flags(key) ; DBT_flags(value) ; CurrentDB = db ; -#ifdef DB_VERSION_MAJOR - RETVAL = 0 ; - key = empty ; - for (i = 1 ; i < items ; ++i) - { - value.data = SvPV(ST(i), n_a) ; - value.size = n_a ; - RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ; - if (RETVAL != 0) - break; - } -#else /* Set the Cursor to the Last element */ RETVAL = do_SEQ(db, key, value, R_LAST) ; +#ifndef DB_VERSION_MAJOR if (RETVAL >= 0) +#endif { - if (RETVAL == 1) - key = empty ; - for (i = items - 1 ; i > 0 ; --i) + if (RETVAL == 0) + keyval = *(int*)key.data ; + else + keyval = 0 ; + for (i = 1 ; i < items ; ++i) { value.data = SvPV(ST(i), n_a) ; value.size = n_a ; - RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ; + ++ keyval ; + key.data = &keyval ; + key.size = sizeof(int) ; + RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; if (RETVAL != 0) break; } } -#endif } OUTPUT: RETVAL - I32 length(db) DB_File db ALIAS: FETCHSIZE = 1 CODE: CurrentDB = db ; - RETVAL = GetArrayLength(db) ; + RETVAL = GetArrayLength(aTHX_ db) ; OUTPUT: RETVAL @@ -1443,7 +1858,7 @@ db_get(db, key, value, flags=0) u_int flags CODE: CurrentDB = db ; - DBT_flags(value) ; + DBT_clear(value) ; RETVAL = db_get(db, key, value, flags) ; #ifdef DB_VERSION_MAJOR if (RETVAL > 0) @@ -1518,7 +1933,7 @@ db_seq(db, key, value, flags) u_int flags CODE: CurrentDB = db ; - DBT_flags(value) ; + DBT_clear(value) ; RETVAL = db_seq(db, key, value, flags); #ifdef DB_VERSION_MAJOR if (RETVAL > 0) @@ -1531,3 +1946,56 @@ db_seq(db, key, value, flags) key value +#ifdef DBM_FILTERING + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = NULL ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + +SV * +filter_fetch_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; + +#endif /* DBM_FILTERING */ diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL index 1a13e0b..cac6578 100644 --- a/contrib/perl5/ext/DB_File/Makefile.PL +++ b/contrib/perl5/ext/DB_File/Makefile.PL @@ -14,7 +14,15 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. #INC => '-I/usr/local/include', VERSION_FROM => 'DB_File.pm', + OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', XSPROTOARG => '-noprototypes', - DEFINE => "$OS2", + DEFINE => $OS2 || "", ); +sub MY::postamble { + ' +version$(OBJ_EXT): version.c + +' ; +} + diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo index 24a7944..701ac61 100644 --- a/contrib/perl5/ext/DB_File/dbinfo +++ b/contrib/perl5/ext/DB_File/dbinfo @@ -4,8 +4,8 @@ # a database file # # Author: Paul Marquess <Paul.Marquess@btinternet.com> -# Version: 1.01 -# Date 16th April 1998 +# Version: 1.02 +# Date 20th August 1999 # # Copyright (c) 1998 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -19,7 +19,7 @@ use strict ; my %Data = ( 0x053162 => { - Type => "Btree", + Type => "Btree", Versions => { 1 => "Unknown (older than 1.71)", @@ -27,18 +27,27 @@ my %Data = 3 => "1.71 -> 1.85, 1.86", 4 => "Unknown", 5 => "2.0.0 -> 2.3.0", - 6 => "2.3.1 or greater", + 6 => "2.3.1 -> 2.7.7", + 7 => "3.0.0 or greater", } }, 0x061561 => { - Type => "Hash", + Type => "Hash", Versions => { 1 => "Unknown (older than 1.71)", 2 => "1.71 -> 1.85", 3 => "1.86", 4 => "2.0.0 -> 2.1.0", - 5 => "2.2.6 or greater", + 5 => "2.2.6 -> 2.7.7", + 6 => "3.0.0 or greater", + } + }, + 0x042253 => { + Type => "Queue", + Versions => + { + 1 => "3.0.0 or greater", } }, ) ; diff --git a/contrib/perl5/ext/DB_File/hints/sco.pl b/contrib/perl5/ext/DB_File/hints/sco.pl new file mode 100644 index 0000000..ff60440 --- /dev/null +++ b/contrib/perl5/ext/DB_File/hints/sco.pl @@ -0,0 +1,2 @@ +# osr5 needs to explicitly link against libc to pull in some static symbols +$self->{LIBS} = ['-ldb -lc'] if $Config{'osvers'} =~ '3\.2v5\.0\..' ; diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap index 994ba27..41a24f4 100644 --- a/contrib/perl5/ext/DB_File/typemap +++ b/contrib/perl5/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # # written by Paul Marquess <Paul.Marquess@btinternet.com> -# last modified 21st February 1999 -# version 1.65 +# last modified 7th September 1999 +# version 1.71 # #################################### DB SECTION # @@ -15,21 +15,23 @@ DBTKEY T_dbtkeydatum INPUT T_dbtkeydatum + ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; if (db->type != DB_RECNO) { $var.data = SvPV($arg, PL_na); $var.size = (int)PL_na; - DBT_flags($var); } else { - Value = GetRecnoKey(db, SvIV($arg)) ; + Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; $var.data = & Value; $var.size = (int)sizeof(recno_t); - DBT_flags($var); } T_dbtdatum + ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; $var.data = SvPV($arg, PL_na); $var.size = (int)PL_na; - DBT_flags($var); + OUTPUT diff --git a/contrib/perl5/ext/DB_File/version.c b/contrib/perl5/ext/DB_File/version.c new file mode 100644 index 0000000..f8c6cac --- /dev/null +++ b/contrib/perl5/ext/DB_File/version.c @@ -0,0 +1,71 @@ +/* + + version.c -- Perl 5 interface to Berkeley DB + + written by Paul Marquess <Paul.Marquess@btinternet.com> + last modified 16th January 2000 + version 1.72 + + All comments/suggestions/problems are welcome + + Copyright (c) 1995-2000 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + Changes: + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + 1.72 - No change. + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <db.h> + +void +__getBerkeleyDBInfo() +{ + SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; + SV * ver_sv = perl_get_sv("DB_File::db_ver", GV_ADD|GV_ADDMULTI) ; + SV * compat_sv = perl_get_sv("DB_File::db_185_compat", GV_ADD|GV_ADDMULTI) ; + +#ifdef DB_VERSION_MAJOR + int Major, Minor, Patch ; + + (void)db_version(&Major, &Minor, &Patch) ; + + /* Check that the versions of db.h and libdb.a are the same */ + if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR + || Patch != DB_VERSION_PATCH) + croak("\nDB_File needs compatible versions of libdb & db.h\n\tyou have db.h version %d.%d.%d and libdb version %d.%d.%d\n", + DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, + Major, Minor, Patch) ; + + /* check that libdb is recent enough -- we need 2.3.4 or greater */ + if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; + + { + char buffer[40] ; + sprintf(buffer, "%d.%d", Major, Minor) ; + sv_setpv(version_sv, buffer) ; + sprintf(buffer, "%d.%03d%03d", Major, Minor, Patch) ; + sv_setpv(ver_sv, buffer) ; + } + +#else /* ! DB_VERSION_MAJOR */ + sv_setiv(version_sv, 1) ; + sv_setiv(ver_sv, 1) ; +#endif /* ! DB_VERSION_MAJOR */ + +#ifdef COMPAT185 + sv_setiv(compat_sv, 1) ; +#else /* ! COMPAT185 */ + sv_setiv(compat_sv, 0) ; +#endif /* ! COMPAT185 */ + +} diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes index 9a96eda..161aba9 100644 --- a/contrib/perl5/ext/Data/Dumper/Changes +++ b/contrib/perl5/ext/Data/Dumper/Changes @@ -6,6 +6,21 @@ HISTORY - public release history for Data::Dumper =over 8 +=item 2.11 (unreleased) + +C<0> is now dumped as such, not as C<'0'>. + +qr// objects are now dumped correctly (provided a post-5.005_58) +overload.pm exists). + +Implemented $Data::Dumper::Maxdepth, which was on the Todo list. +Thanks to John Nolan <jpnolan@Op.Net>. + +=item 2.101 (30 Apr 1999) + +Minor release to sync with version in 5.005_03. Fixes dump of +dummy coderefs. + =item 2.10 (31 Oct 1998) Bugfixes for dumping related undef values, globs, and better double diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm index b1fd2b7..93b87f9 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.pm +++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm @@ -9,22 +9,22 @@ package Data::Dumper; -$VERSION = $VERSION = '2.101'; +$VERSION = '2.101'; #$| = 1; -require 5.004; +require 5.005_64; require Exporter; -require DynaLoader; +use XSLoader (); require overload; use Carp; -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); @EXPORT = qw(Dumper); @EXPORT_OK = qw(DumperX); -bootstrap Data::Dumper; +XSLoader::load 'Data::Dumper'; # module vars and their defaults $Indent = 2 unless defined $Indent; @@ -39,7 +39,7 @@ $Deepcopy = 0 unless defined $Deepcopy; $Quotekeys = 1 unless defined $Quotekeys; $Bless = "bless" unless defined $Bless; #$Expdepth = 0 unless defined $Expdepth; -#$Maxdepth = 0 unless defined $Maxdepth; +$Maxdepth = 0 unless defined $Maxdepth; # # expects an arrayref of values to be dumped. @@ -74,7 +74,7 @@ sub new { quotekeys => $Quotekeys, # quote hash keys 'bless' => $Bless, # keyword to use for "bless" # expdepth => $Expdepth, # cutoff depth for explicit dumping -# maxdepth => $Maxdepth, # depth beyond which we give up + maxdepth => $Maxdepth, # depth beyond which we give up }; if ($Indent > 0) { @@ -146,11 +146,17 @@ sub Names { sub DESTROY {} +sub Dump { + return &Dumpxs + unless $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}); + return &Dumpperl; +} + # # dump the refs in the current dumper object. # expects same args as new() if called via package name. # -sub Dump { +sub Dumpperl { my($s) = shift; my(@out, $val, $name); my($i) = 0; @@ -214,14 +220,13 @@ sub _dump { if ($type) { # prep it, if it looks like an object - if ($type =~ /[a-z_:]/) { - my $freezer = $s->{freezer}; - $val->$freezer() if $freezer && UNIVERSAL::can($val, $freezer); + if (my $freezer = $s->{freezer}) { + $val->$freezer() if UNIVERSAL::can($val, $freezer); } ($realpack, $realtype, $id) = (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/); - + # if it has a name, we need to either look it up, or keep a tab # on it so we know when we hit it later if (defined($name) and length($name)) { @@ -231,7 +236,7 @@ sub _dump { if ($s->{purity} and $s->{level} > 0) { $out = ($realtype eq 'HASH') ? '{}' : ($realtype eq 'ARRAY') ? '[]' : - "''" ; + 'do{my $o}' ; push @post, $name . " = " . $s->{seen}{$id}[0]; } else { @@ -259,14 +264,33 @@ sub _dump { } } - $s->{level}++; - $ipad = $s->{xpad} x $s->{level}; + if ($realpack and $realpack eq 'Regexp') { + $out = "$val"; + $out =~ s,/,\\/,g; + return "qr/$out/"; + } + + # If purity is not set and maxdepth is set, then check depth: + # if we have reached maximum depth, return the string + # representation of the thing we are currently examining + # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). + if (!$s->{purity} + and $s->{maxdepth} > 0 + and $s->{level} >= $s->{maxdepth}) + { + return qq['$val']; + } - if ($realpack) { # we have a blessed ref + # we have a blessed ref + if ($realpack) { $out = $s->{'bless'} . '( '; $blesspad = $s->{apad}; $s->{apad} .= ' ' if ($s->{indent} >= 2); } + + $s->{level}++; + $ipad = $s->{xpad} x $s->{level}; + if ($realtype eq 'SCALAR') { if ($realpack) { @@ -389,7 +413,7 @@ sub _dump { elsif (!defined($val)) { $out .= "undef"; } - elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number + elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})$/) { # safe decimal number $out .= $val; } else { # string @@ -422,9 +446,7 @@ sub Dumper { return Data::Dumper->Dump([@_]); } -# -# same, only calls the XS version -# +# compat stub sub DumperX { return Data::Dumper->Dumpxs([@_], []); } @@ -511,6 +533,12 @@ sub Bless { defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; } +sub Maxdepth { + my($s, $v) = @_; + defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; +} + + # used by qquote below my %esc = ( "\a" => "\\a", @@ -526,25 +554,35 @@ my %esc = ( sub qquote { local($_) = shift; s/([\\\"\@\$])/\\$1/g; - return qq("$_") unless /[^\040-\176]/; # fast exit + return qq("$_") unless + /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit my $high = shift || ""; s/([\a\b\t\n\f\r\e])/$esc{$1}/g; - # no need for 3 digits in escape for these - s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; - - s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; - if ($high eq "iso8859") { - s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; - } elsif ($high eq "utf8") { -# use utf8; -# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; - } elsif ($high eq "8bit") { - # leave it as it is - } else { - s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg; + if (ord('^')==94) { # ascii + # no need for 3 digits in escape for these + s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; + s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; + # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- + if ($high eq "iso8859") { + s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; + } elsif ($high eq "utf8") { +# use utf8; +# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } elsif ($high eq "8bit") { + # leave it as it is + } else { + s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; + } } + else { # ebcdic + s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} + {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; + s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} + {'\\'.sprintf('%03o',ord($1))}eg; + } + return qq("$_"); } @@ -653,12 +691,6 @@ of strings corresponding to the supplied values. The second form, for convenience, simply calls the C<new> method on its arguments before dumping the object immediately. -=item I<$OBJ>->Dumpxs I<or> I<PACKAGE>->Dumpxs(I<ARRAYREF [>, I<ARRAYREF]>) - -This method is available if you were able to compile and install the XSUB -extension to C<Data::Dumper>. It is exactly identical to the C<Dump> method -above, only about 4 to 5 times faster, since it is written entirely in C. - =item I<$OBJ>->Seen(I<[HASHREF]>) Queries or adds to the internal table of already encountered references. @@ -702,12 +734,6 @@ configuration options below. The values will be named C<$VAR>I<n> in the output, where I<n> is a numeric suffix. Will return a list of strings in an array context. -=item DumperX(I<LIST>) - -Identical to the C<Dumper()> function above, but this calls the XSUB -implementation. Only available if you were able to compile and install -the XSUB extensions in C<Data::Dumper>. - =back =head2 Configuration Variables or Methods @@ -763,8 +789,8 @@ When set, enables the use of double quotes for representing string values. Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe" characters will be backslashed, and unprintable characters will be output as quoted octal integers. Since setting this variable imposes a performance -penalty, the default is 0. The C<Dumpxs()> method does not honor this -flag yet. +penalty, the default is 0. C<Dump()> will run slower if this flag is set, +since the fast XSUB implementation doesn't support it yet. =item $Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>) @@ -814,6 +840,14 @@ builtin operator used to create objects. A function with the specified name should exist, and should accept the same arguments as the builtin. Default is C<bless>. +=item $Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<[NEWVAL]>) + +Can be set to a positive integer that specifies the depth beyond which +which we don't venture into a structure. Has no effect when +C<Data::Dumper::Purity> is set. (Useful in debugger when we often don't +want to see more than enough). Default is 0, which means there is +no maximum depth. + =back =head2 Exports @@ -847,7 +881,7 @@ distribution for more examples.) $boo = [ 1, [], "abcd", \*foo, {1 => 'a', 023 => 'b', 0x45 => 'c'}, \\"p\q\'r", $foo, $fuz]; - + ######## # simple usage ######## @@ -868,12 +902,12 @@ distribution for more examples.) $Data::Dumper::Useqq = 1; # print strings in double quotes print Dumper($boo); - - + + ######## # recursive structures ######## - + @c = ('c'); $c = \@c; $b = {}; @@ -882,37 +916,52 @@ distribution for more examples.) $b->{b} = $a->[1]; $b->{c} = $a->[2]; print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]); - - + + $Data::Dumper::Purity = 1; # fill in the holes for eval print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b - - + + $Data::Dumper::Deepcopy = 1; # avoid cross-refs print Data::Dumper->Dump([$b, $a], [qw(*b a)]); - - + + $Data::Dumper::Purity = 0; # avoid cross-refs print Data::Dumper->Dump([$b, $a], [qw(*b a)]); - - + + ######## + # deep structures + ######## + + $a = "pearl"; + $b = [ $a ]; + $c = { 'b' => $b }; + $d = [ $c ]; + $e = { 'd' => $d }; + $f = { 'e' => $e }; + print Data::Dumper->Dump([$f], [qw(f)]); + + $Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down + print Data::Dumper->Dump([$f], [qw(f)]); + + ######## # object-oriented usage ######## - + $d = Data::Dumper->new([$a,$b], [qw(a b)]); $d->Seen({'*c' => $c}); # stash a ref without printing it $d->Indent(3); print $d->Dump; $d->Reset->Purity(0); # empty the seen cache print join "----\n", $d->Dump; - - + + ######## # persistence ######## - + package Foo; sub new { bless { state => 'awake' }, shift } sub Freeze { @@ -921,7 +970,7 @@ distribution for more examples.) $s->{state} = 'asleep'; return bless $s, 'Foo::ZZZ'; } - + package Foo::ZZZ; sub Thaw { my $s = shift; @@ -929,7 +978,7 @@ distribution for more examples.) $s->{state} = 'awake'; return bless $s, 'Foo'; } - + package Foo; use Data::Dumper; $a = Foo->new; @@ -940,12 +989,12 @@ distribution for more examples.) print $c; $d = eval $c; print Data::Dumper->Dump([$d], ['d']); - - + + ######## # symbol substitution (useful for recreating CODE refs) ######## - + sub foo { print "foo speaking\n" } *other = \&foo; $bar = [ \&other ]; @@ -974,15 +1023,15 @@ to have, you can use the C<Seen> method to pre-seed the internal reference table and make the dumped output point to them, instead. See L<EXAMPLES> above. -The C<Useqq> flag is not honored by C<Dumpxs()> (it always outputs -strings in single quotes). +The C<Useqq> flag makes Dump() run slower, since the XSUB implementation +does not support it. SCALAR objects have the weirdest looking C<bless> workaround. =head1 AUTHOR -Gurusamy Sarathy gsar@umich.edu +Gurusamy Sarathy gsar@activestate.com Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. This program is free software; you can redistribute it and/or @@ -991,7 +1040,7 @@ modify it under the same terms as Perl itself. =head1 VERSION -Version 2.10 (31 Oct 1998) +Version 2.11 (unreleased) =head1 SEE ALSO diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs index a3da110..990ea74 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.xs +++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs @@ -1,10 +1,14 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +#ifndef PERL_VERSION #include "patchlevel.h" +#define PERL_VERSION PATCHLEVEL +#endif -#if PATCHLEVEL < 5 +#if PERL_VERSION < 5 # ifndef PL_sv_undef # define PL_sv_undef sv_undef # endif @@ -16,14 +20,15 @@ # endif #endif -static I32 num_q _((char *s, STRLEN slen)); -static I32 esc_q _((char *dest, char *src, STRLEN slen)); -static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n)); -static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval, - HV *seenhv, AV *postav, I32 *levelp, I32 indent, - SV *pad, SV *xpad, SV *apad, SV *sep, - SV *freezer, SV *toaster, - I32 purity, I32 deepcopy, I32 quotekeys, SV *bless)); +static I32 num_q (char *s, STRLEN slen); +static I32 esc_q (char *dest, char *src, STRLEN slen); +static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n); +static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, + HV *seenhv, AV *postav, I32 *levelp, I32 indent, + SV *pad, SV *xpad, SV *apad, SV *sep, + SV *freezer, SV *toaster, + I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, + I32 maxdepth); /* does a string need to be protected? */ static I32 @@ -40,11 +45,12 @@ TOP: } if (isIDFIRST(*s)) { while (*++s) - if (!isALNUM(*s)) + if (!isALNUM(*s)) { if (*s == ':') goto TOP; else return 1; + } } else return 1; @@ -92,7 +98,7 @@ esc_q(register char *d, register char *s, register STRLEN slen) /* append a repeated string to an SV */ static SV * -sv_x(SV *sv, register char *str, STRLEN len, I32 n) +sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n) { if (sv == Nullsv) sv = newSVpvn("", 0); @@ -123,10 +129,10 @@ sv_x(SV *sv, register char *str, STRLEN len, I32 n) * efficiency raisins.) Ugggh! */ static I32 -DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, +DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity, - I32 deepcopy, I32 quotekeys, SV *bless) + I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth) { char tmpbuf[128]; U32 i; @@ -196,7 +202,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, else if (realtype == SVt_PVAV) sv_catpvn(retval, "[]", 2); else - sv_catpvn(retval, "''", 2); + sv_catpvn(retval, "do{my $o}", 9); postentry = newSVpvn(name, namelen); sv_catpvn(postentry, " = ", 3); sv_catsv(postentry, othername); @@ -248,11 +254,39 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvREFCNT_dec(seenentry); } } - - (*levelp)++; - ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp); - if (realpack) { /* we have a blessed ref */ + if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) { + STRLEN rlen; + char *rval = SvPV(val, rlen); + char *slash = strchr(rval, '/'); + sv_catpvn(retval, "qr/", 3); + while (slash) { + sv_catpvn(retval, rval, slash-rval); + sv_catpvn(retval, "\\/", 2); + rlen -= slash-rval+1; + rval = slash+1; + slash = strchr(rval, '/'); + } + sv_catpvn(retval, rval, rlen); + sv_catpvn(retval, "/", 1); + return 1; + } + + /* If purity is not set and maxdepth is set, then check depth: + * if we have reached maximum depth, return the string + * representation of the thing we are currently examining + * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). + */ + if (!purity && maxdepth > 0 && *levelp >= maxdepth) { + STRLEN vallen; + char *valstr = SvPV(val,vallen); + sv_catpvn(retval, "'", 1); + sv_catpvn(retval, valstr, vallen); + sv_catpvn(retval, "'", 1); + return 1; + } + + if (realpack) { /* we have a blessed ref */ STRLEN blesslen; char *blessstr = SvPV(bless, blesslen); sv_catpvn(retval, blessstr, blesslen); @@ -260,26 +294,31 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (indent >= 2) { blesspad = apad; apad = newSVsv(apad); - sv_x(apad, " ", 1, blesslen+2); + sv_x(aTHX_ apad, " ", 1, blesslen+2); } } + (*levelp)++; + ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp); + if (realtype <= SVt_PVBM) { /* scalar ref */ SV *namesv = newSVpvn("${", 2); sv_catpvn(namesv, name, namelen); sv_catpvn(namesv, "}", 1); if (realpack) { /* blessed */ sv_catpvn(retval, "do{\\(my $o = ", 13); - DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, + DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless); + freezer, toaster, purity, deepcopy, quotekeys, bless, + maxdepth); sv_catpvn(retval, ")}", 2); } /* plain */ else { sv_catpvn(retval, "\\", 1); - DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, + DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless); + freezer, toaster, purity, deepcopy, quotekeys, bless, + maxdepth); } SvREFCNT_dec(namesv); } @@ -288,9 +327,10 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, sv_catpvn(namesv, name, namelen); sv_catpvn(namesv, "}", 1); sv_catpvn(retval, "\\", 1); - DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, + DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless); + freezer, toaster, purity, deepcopy, quotekeys, bless, + maxdepth); SvREFCNT_dec(namesv); } else if (realtype == SVt_PVAV) { @@ -345,7 +385,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, ilen = inamelen; sv_setiv(ixsv, ix); - (void) sprintf(iname+ilen, "%ld", ix); + (void) sprintf(iname+ilen, "%"IVdf, (IV)ix); ilen = strlen(iname); iname[ilen++] = ']'; iname[ilen] = '\0'; if (indent >= 3) { @@ -356,14 +396,15 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, } sv_catsv(retval, totpad); sv_catsv(retval, ipad); - DD_dump(elem, iname, ilen, retval, seenhv, postav, + DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless); + freezer, toaster, purity, deepcopy, quotekeys, bless, + maxdepth); if (ix < ixmax) sv_catpvn(retval, ",", 1); } if (ixmax >= 0) { - SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1); + SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1); sv_catsv(retval, totpad); sv_catsv(retval, opad); SvREFCNT_dec(opad); @@ -462,16 +503,17 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, else newapad = apad; - DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv, + DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv, postav, levelp, indent, pad, xpad, newapad, sep, - freezer, toaster, purity, deepcopy, quotekeys, bless); + freezer, toaster, purity, deepcopy, quotekeys, bless, + maxdepth); SvREFCNT_dec(sname); Safefree(nkey); if (indent >= 2) SvREFCNT_dec(newapad); } if (i) { - SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1); + SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1); sv_catsv(retval, totpad); sv_catsv(retval, opad); SvREFCNT_dec(opad); @@ -543,7 +585,7 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (SvIOK(val)) { STRLEN len; i = SvIV(val); - (void) sprintf(tmpbuf, "%d", i); + (void) sprintf(tmpbuf, "%"IVdf, (IV)i); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); } @@ -599,12 +641,12 @@ DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, SvCUR(newapad) = 0; if (indent >= 2) - (void)sv_x(newapad, " ", 1, SvCUR(postentry)); + (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry)); - DD_dump(e, SvPVX(nname), SvCUR(nname), postentry, + DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry, seenhv, postav, &nlevel, indent, pad, xpad, newapad, sep, freezer, toaster, purity, - deepcopy, quotekeys, bless); + deepcopy, quotekeys, bless, maxdepth); SvREFCNT_dec(e); } } @@ -664,28 +706,22 @@ Data_Dumper_Dumpxs(href, ...) SV **svp; SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname; SV *freezer, *toaster, *bless; - I32 purity, deepcopy, quotekeys; + I32 purity, deepcopy, quotekeys, maxdepth = 0; char tmpbuf[1024]; I32 gimme = GIMME; if (!SvROK(href)) { /* call new to get an object first */ - SV *valarray; - SV *namearray; - - if (items == 3) { - valarray = ST(1); - namearray = ST(2); - } - else - croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)"); + if (items < 2) + croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])"); ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(href); - XPUSHs(sv_2mortal(newSVsv(valarray))); - XPUSHs(sv_2mortal(newSVsv(namearray))); + XPUSHs(sv_2mortal(newSVsv(ST(1)))); + if (items >= 3) + XPUSHs(sv_2mortal(newSVsv(ST(2)))); PUTBACK; i = perl_call_method("new", G_SCALAR); SPAGAIN; @@ -747,6 +783,8 @@ Data_Dumper_Dumpxs(href, ...) quotekeys = SvTRUE(*svp); if ((svp = hv_fetch(hv, "bless", 5, FALSE))) bless = *svp; + if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) + maxdepth = SvIV(*svp); postav = newAV(); if (todumpav) @@ -795,13 +833,13 @@ Data_Dumper_Dumpxs(href, ...) STRLEN nchars = 0; sv_setpvn(name, "$", 1); sv_catsv(name, varname); - (void) sprintf(tmpbuf, "%ld", i+1); + (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1)); nchars = strlen(tmpbuf); sv_catpvn(name, tmpbuf, nchars); } if (indent >= 2) { - SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3); + SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3); newapad = newSVsv(apad); sv_catsv(newapad, tmpsv); SvREFCNT_dec(tmpsv); @@ -809,10 +847,10 @@ Data_Dumper_Dumpxs(href, ...) else newapad = apad; - DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv, + DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv, postav, &level, indent, pad, xpad, newapad, sep, freezer, toaster, purity, deepcopy, quotekeys, - bless); + bless, maxdepth); if (indent >= 2) SvREFCNT_dec(newapad); diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo index 7dcd40b..bd76e65 100644 --- a/contrib/perl5/ext/Data/Dumper/Todo +++ b/contrib/perl5/ext/Data/Dumper/Todo @@ -8,12 +8,6 @@ The following functionality will be supported in the next few releases. =over 4 -=item $Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<NEWVAL>) - -Depth beyond which we don't venture into a structure. Has no effect when -C<Data::Dumper::Purity> is set. (useful in debugger when we often don't -want to see more than enough). - =item $Data::Dumper::Expdepth I<or> $I<OBJ>->Expdepth(I<NEWVAL>) Dump contents explicitly up to a certain depth and then use names for diff --git a/contrib/perl5/ext/Devel/DProf/Changes b/contrib/perl5/ext/Devel/DProf/Changes new file mode 100644 index 0000000..216498b --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/Changes @@ -0,0 +1,176 @@ +1999 Jan 8 + + Ilya Zakharevich: + Newer perls: Add PERL_POLLUTE and dTHR. + +1998 Nov 10 +This version of DProf should work with older Perls too, but to get +full benefits some patches to 5.004_55 are needed. Patches take effect +after new version of Perl is installed, and DProf recompiled. + +Without these patches the overhead of DProf is too big, thus the statistic +may be very skewed. + +Oct 98: + Ilya Zakharevich: + DProf.xs + - correct defstash to PL_defstash + - nonlocal exits work + dprofpp + - nonlocal exits work + DProf.pm + - documentation updated + t/test6.* + - added + +Nov-Dec 97: + Jason E. Holt and Ilya Zakharevich: + DProf.xs + - will not wait until completion to write the output, size of buffer + regulated by PERL_DPROF_BUFFER, default 2**14 words; + + Ilya Zakharevich: + dprofpp + - smarter in fixing garbled profiles; + - subtracts DProf output overhead, and suggested profiler overhead; + - new options -A, -R, -g subroutine, -S; + - handles 'goto' too; + DProf.xs + - 7x denser output (time separated from name, ids for subs); + - outputs report-write overhead; + - optional higher-resolution (currently OS/2 only, cannot grok VMS code); + - outputs suggested profiler overhead; + - handles 'goto' too; + - handles PERL_DPROF_TICKS (on OS/2, VMS may be easily modified too) + +Jun 14, 97 andreas koenig adds the compatibility notes to the README +and lets the Makefile.PL die on $] < 5.004. + +Jun 06, 97 andreas koenig applies a patch by gurusamy sarathy because +Dean is not available for comments at that time. The patch is available +from CPAN in the authors/id/GSAR directory for inspection. + +Sep 30, 96 dmr + DProf.xs + - added Ilya's patches to fix "&bar as &bar(@_)" bug. This also fixes + the coredumps people have seen when using this with 5.003+. + DProf.pm + - updated manpage + t/bug.t + - moved to test5 + Makefile.PL + - remove special case for bug.t + +Jun 26, 96 dmr + dprofpp.PL + - smarter r.e. to find VERSION in Makefile (for MM5.27). + DProf.pm + - updated manpage + DProf.xs + - keep pid of profiled process, if process forks then only the + parent is profiled. Added test4 for this. + +Mar 2, 96 dmr + README + - updated + dprofpp + - updated manpage, point to DProf for raw profile description. + DProf.pm + - update manpage, update raw profile description with XS_VERSION. + - update manpage for AUTOLOAD changes. + DProf.xs + - smart handling of &AUTOLOAD--looks in $AUTOLOAD for the sub name. + this fixes one problem with corrupt profiles. + +Feb 5, 96 dmr + dprofpp + - updated manpage + - added -E/-I for exclusive/inclusive times + - added DPROFPP_OPTS -- lazily + - added -p/-Q for profile-then-analyze + - added version check + dprofpp.PL + - pull dprofpp's version id from the makefile + DProf.pm + - added version to bootstrap + - updated doc + - updated doc, DProf and -w are now friendly to each other + DProf.xs + - using savepv + - added Tim's patch to check for DBsub, avoids -MDevel::DProf coredump + - turn off warnings during newXS("DB::sub") + tests + - added Tim's patch to ignore Loader::import in results + - added Tim's patch to aid readability of test?.v output + + +-- from those days when I kept a unique changelog for each module -- + +# Devel::DProf - a Perl code profiler +# 31oct95 +# +# changes/bugs fixed since 5apr95 version -dmr: +# -added VMS patches from CharlesB. +# -now open ./tmon.out in BOOT. +# changes/bugs fixed since 2apr95 version -dmr: +# -now mallocing an extra byte for the \0 :) +# changes/bugs fixed since 01mar95 version -dmr: +# -stringified code ref is used for name of anonymous sub. +# -include stash name with stringified code ref. +# -use perl.c's DBsingle and DBsub. +# -now using croak() and warn(). +# -print "timer is on" before turning timer on. +# -use safefree() instead of free(). +# -rely on PM to provide full path name to tmon.out. +# -print errno if unable to write tmon.out. +# changes/bugs fixed since 03feb95 version -dmr: +# -comments +# changes/bugs fixed since 31dec94 version -dmr: +# -added patches from AndyD. +# + +# Devel::DProf - a Perl code profiler +# 31oct95 +# +# changes/bugs fixed since 05apr95 version -dmr: +# - VMS-related prob; now let tmon.out name be handled in XS. +# changes/bugs fixed since 01mar95 version -dmr: +# - record $pwd and build pathname for tmon.out +# changes/bugs fixed since 03feb95 version -dmr: +# - fixed some doc bugs +# - added require 5.000 +# - added -w note to bugs section of pod +# changes/bugs fixed since 31dec94 version -dmr: +# - podified +# + + +# dprofpp - display perl profile data +# 31oct95 +# +# changes/bugs fixed since 7oct95 version -dmr: +# - PL'd +# changes/bugs fixed since 5apr95 version -dmr: +# - touch up handling of exit timestamps. +# - suggests -F when exit timestamps are missing. +# - added compressed execution tree patches from AchimB, put under -t. +# now -z is the default action; user+system time. +# - doc changes. +# changes/bugs fixed since 10feb95 version -dmr: +# - summary info is printed by default, opt_c is gone. +# - fixed some doc bugs +# - changed name to dprofpp +# changes/bugs fixed since 03feb95 version -dmr: +# - fixed division by zero. +# - replace many local()s with my(). +# - now prints user+system times by default +# now -u prints user time, -U prints unsorted. +# - fixed documentation +# - fixed output, to clarify that times are given in seconds. +# - can now fake exit timestamps if the profile is garbled. +# changes/bugs fixed since 17jun94 version -dmr: +# - podified. +# - correct old documentation flaws. +# - added AndyD's patches. +# + diff --git a/contrib/perl5/ext/Devel/DProf/DProf.pm b/contrib/perl5/ext/Devel/DProf/DProf.pm new file mode 100644 index 0000000..38082fc --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/DProf.pm @@ -0,0 +1,196 @@ +require 5.005_64; + +=head1 NAME + +Devel::DProf - a Perl code profiler + +=head1 SYNOPSIS + + perl5 -d:DProf test.pl + +=head1 DESCRIPTION + +The Devel::DProf package is a Perl code profiler. This will collect +information on the execution time of a Perl script and of the subs in that +script. This information can be used to determine which subroutines are +using the most time and which subroutines are being called most often. This +information can also be used to create an execution graph of the script, +showing subroutine relationships. + +To profile a Perl script run the perl interpreter with the B<-d> debugging +switch. The profiler uses the debugging hooks. So to profile script +F<test.pl> the following command should be used: + + perl5 -d:DProf test.pl + +When the script terminates (or when the output buffer is filled) the +profiler will dump the profile information to a file called +F<tmon.out>. A tool like I<dprofpp> can be used to interpret the +information which is in that profile. The following command will +print the top 15 subroutines which used the most time: + + dprofpp + +To print an execution graph of the subroutines in the script use the +following command: + + dprofpp -T + +Consult L<dprofpp> for other options. + +=head1 PROFILE FORMAT + +The old profile is a text file which looks like this: + + #fOrTyTwO + $hz=100; + $XS_VERSION='DProf 19970606'; + # All values are given in HZ + $rrun_utime=2; $rrun_stime=0; $rrun_rtime=7 + PART2 + + 26 28 566822884 DynaLoader::import + - 26 28 566822884 DynaLoader::import + + 27 28 566822885 main::bar + - 27 28 566822886 main::bar + + 27 28 566822886 main::baz + + 27 28 566822887 main::bar + - 27 28 566822888 main::bar + [....] + +The first line is the magic number. The second line is the hertz value, or +clock ticks, of the machine where the profile was collected. The third line +is the name and version identifier of the tool which created the profile. +The fourth line is a comment. The fifth line contains three variables +holding the user time, system time, and realtime of the process while it was +being profiled. The sixth line indicates the beginning of the sub +entry/exit profile section. + +The columns in B<PART2> are: + + sub entry(+)/exit(-) mark + app's user time at sub entry/exit mark, in ticks + app's system time at sub entry/exit mark, in ticks + app's realtime at sub entry/exit mark, in ticks + fully-qualified sub name, when possible + +With newer perls another format is used, which may look like this: + + #fOrTyTwO + $hz=10000; + $XS_VERSION='DProf 19971213'; + # All values are given in HZ + $over_utime=5917; $over_stime=0; $over_rtime=5917; + $over_tests=10000; + $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284; + $total_marks=6; + + PART2 + @ 406 0 406 + & 2 main bar + + 2 + @ 456 0 456 + - 2 + @ 1 0 1 + & 3 main baz + + 3 + @ 141 0 141 + + 2 + @ 141 0 141 + - 2 + @ 1 0 1 + & 4 main foo + + 4 + @ 142 0 142 + + & Devel::DProf::write + @ 5 0 5 + - & Devel::DProf::write + +(with high value of $ENV{PERL_DPROF_TICKS}). + +New C<$over_*> values show the measured overhead of making $over_tests +calls to the profiler These values are used by the profiler to +subtract the overhead from the runtimes. + +The lines starting with C<@> mark time passed from the previous C<@> +line. The lines starting with C<&> introduce new subroutine I<id> and +show the package and the subroutine name of this id. Lines starting +with C<+>, C<-> and C<*> mark entering and exit of subroutines by +I<id>s, and C<goto &subr>. + +The I<old-style> C<+>- and C<->-lines are used to mark the overhead +related to writing to profiler-output file. + +=head1 AUTOLOAD + +When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the +C<$AUTOLOAD> variable to find the real name of the sub being called. See +L<perlsub/"Autoloading">. + +=head1 ENVIRONMENT + +C<PERL_DPROF_BUFFER> sets size of output buffer in words. Defaults to 2**14. + +C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where +a replacement for times() is used. Defaults to the value of C<HZ> macro. + +C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file. If not set, +defaults to tmon.out. + +=head1 BUGS + +Builtin functions cannot be measured by Devel::DProf. + +With a newer Perl DProf relies on the fact that the numeric slot of +$DB::sub contains an address of a subroutine. Excessive manipulation +of this variable may overwrite this slot, as in + + $DB::sub = 'current_sub'; + ... + $addr = $DB::sub + 0; + +will set this numeric slot to numeric value of the string +C<current_sub>, i.e., to C<0>. This will cause a segfault on the exit +from this subroutine. Note that the first assignment above does not +change the numeric slot (it will I<mark> it as invalid, but will not +write over it). + +Mail bug reports and feature requests to the perl5-porters mailing list at +F<E<lt>perl5-porters@perl.orgE<gt>>. + +=head1 SEE ALSO + +L<perl>, L<dprofpp>, times(2) + +=cut + +# This sub is needed for calibration. +package Devel::DProf; + +sub NONESUCH_noxs { + return $Devel::DProf::VERSION; +} + +package DB; + +# +# As of perl5.003_20, &DB::sub stub is not needed (some versions +# even had problems if stub was redefined with XS version). +# + +# disable DB single-stepping +BEGIN { $single = 0; } + +# This sub is needed during startup. +sub DB { +# print "nonXS DBDB\n"; +} + +use XSLoader (); + +# Underscore to allow older Perls to access older version from CPAN +$Devel::DProf::VERSION = '20000000.00_00'; # this version not authorized by + # Dean Roehrich. See "Changes" file. + +XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION; + +1; diff --git a/contrib/perl5/ext/Devel/DProf/DProf.xs b/contrib/perl5/ext/Devel/DProf/DProf.xs new file mode 100644 index 0000000..31e984f --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/DProf.xs @@ -0,0 +1,689 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* For older Perls */ +#ifndef dTHR +# define dTHR int dummy_thr +#endif /* dTHR */ + +/*#define DBG_SUB 1 */ +/*#define DBG_TIMER 1 */ + +#ifdef DBG_SUB +# define DBG_SUB_NOTIFY(A,B) warn(A, B) +#else +# define DBG_SUB_NOTIFY(A,B) /* nothing */ +#endif + +#ifdef DBG_TIMER +# define DBG_TIMER_NOTIFY(A) warn(A) +#else +# define DBG_TIMER_NOTIFY(A) /* nothing */ +#endif + +/* HZ == clock ticks per second */ +#ifdef VMS +# define HZ ((I32)CLK_TCK) +# define DPROF_HZ HZ +# include <starlet.h> /* prototype for sys$gettim() */ +# define Times(ptr) (dprof_times(aTHX_ ptr)) +#else +# ifndef HZ +# ifdef CLK_TCK +# define HZ ((I32)CLK_TCK) +# else +# define HZ 60 +# endif +# endif +# ifdef OS2 /* times() has significant overhead */ +# define Times(ptr) (dprof_times(aTHX_ ptr)) +# define INCL_DOSPROFILE +# define INCL_DOSERRORS +# include <os2.h> +# define toLongLong(arg) (*(long long*)&(arg)) +# define DPROF_HZ g_dprof_ticks +# else +# define Times(ptr) (times(ptr)) +# define DPROF_HZ HZ +# endif +#endif + +XS(XS_Devel__DProf_END); /* used by prof_mark() */ + +/* Everything is built on times(2). See its manpage for a description + * of the timings. + */ + +union prof_any { + clock_t tms_utime; /* cpu time spent in user space */ + clock_t tms_stime; /* cpu time spent in system */ + clock_t realtime; /* elapsed real time, in ticks */ + char *name; + U32 id; + opcode ptype; +}; + +typedef union prof_any PROFANY; + +typedef struct { + U32 dprof_ticks; + char* out_file_name; /* output file (defaults to tmon.out) */ + PerlIO* fp; /* pointer to tmon.out file */ + long TIMES_LOCATION; /* Where in the file to store the time totals */ + int SAVE_STACK; /* How much data to buffer until end of run */ + int prof_pid; /* pid of profiled process */ + struct tms prof_start; + struct tms prof_end; + clock_t rprof_start; /* elapsed real time ticks */ + clock_t rprof_end; + clock_t wprof_u; + clock_t wprof_s; + clock_t wprof_r; + clock_t otms_utime; + clock_t otms_stime; + clock_t orealtime; + PROFANY* profstack; + int profstack_max; + int profstack_ix; + HV* cv_hash; + U32 total; + U32 lastid; + U32 default_perldb; + U32 depth; +#ifdef OS2 + ULONG frequ; + long long start_cnt; +#endif +#ifdef PERL_IMPLICIT_CONTEXT +# define register + pTHX; +# undef register +#endif +} prof_state_t; + +prof_state_t g_prof_state; + +#define g_dprof_ticks g_prof_state.dprof_ticks +#define g_out_file_name g_prof_state.out_file_name +#define g_fp g_prof_state.fp +#define g_TIMES_LOCATION g_prof_state.TIMES_LOCATION +#define g_SAVE_STACK g_prof_state.SAVE_STACK +#define g_prof_pid g_prof_state.prof_pid +#define g_prof_start g_prof_state.prof_start +#define g_prof_end g_prof_state.prof_end +#define g_rprof_start g_prof_state.rprof_start +#define g_rprof_end g_prof_state.rprof_end +#define g_wprof_u g_prof_state.wprof_u +#define g_wprof_s g_prof_state.wprof_s +#define g_wprof_r g_prof_state.wprof_r +#define g_otms_utime g_prof_state.otms_utime +#define g_otms_stime g_prof_state.otms_stime +#define g_orealtime g_prof_state.orealtime +#define g_profstack g_prof_state.profstack +#define g_profstack_max g_prof_state.profstack_max +#define g_profstack_ix g_prof_state.profstack_ix +#define g_cv_hash g_prof_state.cv_hash +#define g_total g_prof_state.total +#define g_lastid g_prof_state.lastid +#define g_default_perldb g_prof_state.default_perldb +#define g_depth g_prof_state.depth +#ifdef PERL_IMPLICIT_CONTEXT +# define g_THX g_prof_state.aTHX +#endif +#ifdef OS2 +# define g_frequ g_prof_state.frequ +# define g_start_cnt g_prof_state.start_cnt +#endif + +clock_t +dprof_times(pTHX_ struct tms *t) +{ +#ifdef OS2 + ULONG rc; + QWORD cnt; + STRLEN n_a; + + if (!g_frequ) { + if (CheckOSError(DosTmrQueryFreq(&g_frequ))) + croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a)); + else + g_frequ = g_frequ/DPROF_HZ; /* count per tick */ + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", + SvPV(perl_get_sv("!",TRUE), n_a)); + g_start_cnt = toLongLong(cnt); + } + + if (CheckOSError(DosTmrQueryTime(&cnt))) + croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a)); + t->tms_stime = 0; + return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ); +#else /* !OS2 */ +# ifdef VMS + clock_t retval; + /* Get wall time and convert to 10 ms intervals to + * produce the return value dprof expects */ +# if defined(__DECC) && defined (__ALPHA) +# include <ints.h> + uint64 vmstime; + _ckvmssts(sys$gettim(&vmstime)); + vmstime /= 100000; + retval = vmstime & 0x7fffffff; +# else + /* (Older hw or ccs don't have an atomic 64-bit type, so we + * juggle 32-bit ints (and a float) to produce a time_t result + * with minimal loss of information.) */ + long int vmstime[2],remainder,divisor = 100000; + _ckvmssts(sys$gettim((unsigned long int *)vmstime)); + vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ + _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); +# endif + /* Fill in the struct tms using the CRTL routine . . .*/ + times((tbuffer_t *)t); + return (clock_t) retval; +# else /* !VMS && !OS2 */ + return times(t); +# endif +#endif +} + +static void +prof_dumpa(pTHX_ opcode ptype, U32 id) +{ + if (ptype == OP_LEAVESUB) { + PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id); + } + else if(ptype == OP_ENTERSUB) { + PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id); + } + else if(ptype == OP_GOTO) { + PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id); + } + else if(ptype == OP_DIE) { + PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id); + } + else { + PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype); + } +} + +static void +prof_dumps(pTHX_ U32 id, char *pname, char *gname) +{ + PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname); +} + +static void +prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime) +{ + PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime); +} + +static void +prof_dump_until(pTHX_ long ix) +{ + long base = 0; + struct tms t1, t2; + clock_t realtime1, realtime2; + + realtime1 = Times(&t1); + + while (base < ix) { + opcode ptype = g_profstack[base++].ptype; + if (ptype == OP_TIME) { + long tms_utime = g_profstack[base++].tms_utime; + long tms_stime = g_profstack[base++].tms_stime; + long realtime = g_profstack[base++].realtime; + + prof_dumpt(aTHX_ tms_utime, tms_stime, realtime); + } + else if (ptype == OP_GV) { + U32 id = g_profstack[base++].id; + char *pname = g_profstack[base++].name; + char *gname = g_profstack[base++].name; + + prof_dumps(aTHX_ id, pname, gname); + } + else { + U32 id = g_profstack[base++].id; + prof_dumpa(aTHX_ ptype, id); + } + } + PerlIO_flush(g_fp); + realtime2 = Times(&t2); + if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime + || t1.tms_stime != t2.tms_stime) { + g_wprof_r += realtime2 - realtime1; + g_wprof_u += t2.tms_utime - t1.tms_utime; + g_wprof_s += t2.tms_stime - t1.tms_stime; + + PerlIO_printf(g_fp,"+ & Devel::DProf::write\n"); + PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)(t2.tms_utime - t1.tms_utime), + (IV)(t2.tms_stime - t1.tms_stime), + (IV)(realtime2 - realtime1)); + PerlIO_printf(g_fp,"- & Devel::DProf::write\n"); + g_otms_utime = t2.tms_utime; + g_otms_stime = t2.tms_stime; + g_orealtime = realtime2; + PerlIO_flush(g_fp); + } +} + +static void +prof_mark(pTHX_ opcode ptype) +{ + struct tms t; + clock_t realtime, rdelta, udelta, sdelta; + char *name, *pv; + char *hvname; + STRLEN len; + SV *sv; + U32 id; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + + if (g_SAVE_STACK) { + if (g_profstack_ix + 5 > g_profstack_max) { + g_profstack_max = g_profstack_max * 3 / 2; + Renew(g_profstack, g_profstack_max, PROFANY); + } + } + + realtime = Times(&t); + rdelta = realtime - g_orealtime; + udelta = t.tms_utime - g_otms_utime; + sdelta = t.tms_stime - g_otms_stime; + if (rdelta || udelta || sdelta) { + if (g_SAVE_STACK) { + g_profstack[g_profstack_ix++].ptype = OP_TIME; + g_profstack[g_profstack_ix++].tms_utime = udelta; + g_profstack[g_profstack_ix++].tms_stime = sdelta; + g_profstack[g_profstack_ix++].realtime = rdelta; + } + else { /* Write it to disk now so's not to eat up core */ + if (g_prof_pid == (int)getpid()) { + prof_dumpt(aTHX_ udelta, sdelta, rdelta); + PerlIO_flush(g_fp); + } + } + g_orealtime = realtime; + g_otms_stime = t.tms_stime; + g_otms_utime = t.tms_utime; + } + + { + SV **svp; + char *gname, *pname; + CV *cv; + + cv = INT2PTR(CV*,SvIVX(Sub)); + svp = hv_fetch(g_cv_hash, (char*)&cv, sizeof(CV*), TRUE); + if (!SvOK(*svp)) { + GV *gv = CvGV(cv); + + sv_setiv(*svp, id = ++g_lastid); + pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) + ? HvNAME(GvSTASH(gv)) + : "(null)"); + gname = GvNAME(gv); + if (CvXSUB(cv) == XS_Devel__DProf_END) + return; + if (g_SAVE_STACK) { /* Store it for later recording -JH */ + g_profstack[g_profstack_ix++].ptype = OP_GV; + g_profstack[g_profstack_ix++].id = id; + g_profstack[g_profstack_ix++].name = pname; + g_profstack[g_profstack_ix++].name = gname; + } + else { /* Write it to disk now so's not to eat up core */ + /* Only record the parent's info */ + if (g_prof_pid == (int)getpid()) { + prof_dumps(aTHX_ id, pname, gname); + PerlIO_flush(g_fp); + } + else + PL_perldb = 0; /* Do not debug the kid. */ + } + } + else { + id = SvIV(*svp); + } + } + + g_total++; + if (g_SAVE_STACK) { /* Store it for later recording -JH */ + g_profstack[g_profstack_ix++].ptype = ptype; + g_profstack[g_profstack_ix++].id = id; + + /* Only record the parent's info */ + if (g_SAVE_STACK < g_profstack_ix) { + if (g_prof_pid == (int)getpid()) + prof_dump_until(aTHX_ g_profstack_ix); + else + PL_perldb = 0; /* Do not debug the kid. */ + g_profstack_ix = 0; + } + } + else { /* Write it to disk now so's not to eat up core */ + + /* Only record the parent's info */ + if (g_prof_pid == (int)getpid()) { + prof_dumpa(aTHX_ ptype, id); + PerlIO_flush(g_fp); + } + else + PL_perldb = 0; /* Do not debug the kid. */ + } +} + +#ifdef PL_NEEDED +# define defstash PL_defstash +#endif + +/* Counts overhead of prof_mark and extra XS call. */ +static void +test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s) +{ + dTHR; + CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE); + int i, j, k = 0; + HV *oldstash = PL_curstash; + struct tms t1, t2; + clock_t realtime1, realtime2; + U32 ototal = g_total; + U32 ostack = g_SAVE_STACK; + U32 operldb = PL_perldb; + + g_SAVE_STACK = 1000000; + realtime1 = Times(&t1); + + while (k < 2) { + i = 0; + /* Disable debugging of perl_call_sv on second pass: */ + PL_curstash = (k == 0 ? PL_defstash : PL_debstash); + PL_perldb = g_default_perldb; + while (++i <= 100) { + j = 0; + g_profstack_ix = 0; /* Do not let the stack grow */ + while (++j <= 100) { +/* prof_mark(aTHX_ OP_ENTERSUB); */ + + PUSHMARK(PL_stack_sp); + perl_call_sv((SV*)cv, G_SCALAR); + PL_stack_sp--; +/* prof_mark(aTHX_ OP_LEAVESUB); */ + } + } + PL_curstash = oldstash; + if (k == 0) { /* Put time with debugging */ + realtime2 = Times(&t2); + *r = realtime2 - realtime1; + *u = t2.tms_utime - t1.tms_utime; + *s = t2.tms_stime - t1.tms_stime; + } + else { /* Subtract time without debug */ + realtime1 = Times(&t1); + *r -= realtime1 - realtime2; + *u -= t1.tms_utime - t2.tms_utime; + *s -= t1.tms_stime - t2.tms_stime; + } + k++; + } + g_total = ototal; + g_SAVE_STACK = ostack; + PL_perldb = operldb; +} + +static void +prof_recordheader(pTHX) +{ + clock_t r, u, s; + + /* g_fp is opened in the BOOT section */ + PerlIO_printf(g_fp, "#fOrTyTwO\n"); + PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ); + PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION); + PerlIO_printf(g_fp, "# All values are given in HZ\n"); + test_time(aTHX_ &r, &u, &s); + PerlIO_printf(g_fp, + "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)u, (IV)s, (IV)r); + PerlIO_printf(g_fp, "$over_tests=10000;\n"); + + g_TIMES_LOCATION = PerlIO_tell(g_fp); + + /* Pad with whitespace. */ + /* This should be enough even for very large numbers. */ + PerlIO_printf(g_fp, "%*s\n", 240 , ""); + + PerlIO_printf(g_fp, "\n"); + PerlIO_printf(g_fp, "PART2\n"); + + PerlIO_flush(g_fp); +} + +static void +prof_record(pTHX) +{ + /* g_fp is opened in the BOOT section */ + + /* Now that we know the runtimes, fill them in at the recorded + location -JH */ + + clock_t r, u, s; + + if (g_SAVE_STACK) { + prof_dump_until(aTHX_ g_profstack_ix); + } + PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET); + /* Write into reserved 240 bytes: */ + PerlIO_printf(g_fp, + "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";", + /* The (IV) casts are one possibility: + * the Painfully Correct Way would be to + * have Clock_t_f. */ + (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u), + (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s), + (IV)(g_rprof_end-g_rprof_start-g_wprof_r)); + PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total); + + PerlIO_close(g_fp); +} + +#define NONESUCH() + +static void +check_depth(pTHX_ void *foo) +{ + U32 need_depth = (U32)foo; + if (need_depth != g_depth) { + if (need_depth > g_depth) { + warn("garbled call depth when profiling"); + } + else { + I32 marks = g_depth - need_depth; + +/* warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */ + while (marks--) { + prof_mark(aTHX_ OP_DIE); + } + g_depth = need_depth; + } + } +} + +#define for_real +#ifdef for_real + +XS(XS_DB_sub) +{ + dXSARGS; + dORIGMARK; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + +#ifdef PERL_IMPLICIT_CONTEXT + /* profile only the interpreter that loaded us */ + if (g_THX != aTHX) { + PUSHMARK(ORIGMARK); + perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + } + else +#endif + { + HV *oldstash = PL_curstash; + + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); + + SAVEDESTRUCTOR_X(check_depth, (void*)g_depth); + g_depth++; + + prof_mark(aTHX_ OP_ENTERSUB); + PUSHMARK(ORIGMARK); + perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + prof_mark(aTHX_ OP_LEAVESUB); + g_depth--; + } + return; +} + +XS(XS_DB_goto) +{ +#ifdef PERL_IMPLICIT_CONTEXT + if (g_THX == aTHX) +#endif + { + prof_mark(aTHX_ OP_GOTO); + return; + } +} + +#endif /* for_real */ + +#ifdef testing + + MODULE = Devel::DProf PACKAGE = DB + + void + sub(...) + PPCODE: + { + dORIGMARK; + HV *oldstash = PL_curstash; + SV *Sub = GvSV(PL_DBsub); /* name of current sub */ + /* SP -= items; added by xsubpp */ + DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub)); + + sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ + + prof_mark(aTHX_ OP_ENTERSUB); + PUSHMARK(ORIGMARK); + + PL_curstash = PL_debstash; /* To disable debugging of perl_call_sv */ + perl_call_sv(Sub, GIMME); + PL_curstash = oldstash; + + prof_mark(aTHX_ OP_LEAVESUB); + SPAGAIN; + /* PUTBACK; added by xsubpp */ + } + +#endif /* testing */ + +MODULE = Devel::DProf PACKAGE = Devel::DProf + +void +END() +PPCODE: + { + if (PL_DBsub) { + /* maybe the process forked--we want only + * the parent's profile. + */ + if ( +#ifdef PERL_IMPLICIT_CONTEXT + g_THX == aTHX && +#endif + g_prof_pid == (int)getpid()) + { + g_rprof_end = Times(&g_prof_end); + DBG_TIMER_NOTIFY("Profiler timer is off.\n"); + prof_record(aTHX); + } + } + } + +void +NONESUCH() + +BOOT: + { + g_TIMES_LOCATION = 42; + g_SAVE_STACK = 1<<14; + g_profstack_max = 128; +#ifdef PERL_IMPLICIT_CONTEXT + g_THX = aTHX; +#endif + + /* Before we go anywhere make sure we were invoked + * properly, else we'll dump core. + */ + if (!PL_DBsub) + croak("DProf: run perl with -d to use DProf.\n"); + + /* When we hook up the XS DB::sub we'll be redefining + * the DB::sub from the PM file. Turn off warnings + * while we do this. + */ + { + I32 warn_tmp = PL_dowarn; + PL_dowarn = 0; + newXS("DB::sub", XS_DB_sub, file); + newXS("DB::goto", XS_DB_goto, file); + PL_dowarn = warn_tmp; + } + + sv_setiv(PL_DBsingle, 0); /* disable DB single-stepping */ + + { + char *buffer = getenv("PERL_DPROF_BUFFER"); + + if (buffer) { + g_SAVE_STACK = atoi(buffer); + } + + buffer = getenv("PERL_DPROF_TICKS"); + + if (buffer) { + g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */ + } + else { + g_dprof_ticks = HZ; + } + + buffer = getenv("PERL_DPROF_OUT_FILE_NAME"); + g_out_file_name = savepv(buffer ? buffer : "tmon.out"); + } + + if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL) + croak("DProf: unable to write '%s', errno = %d\n", + g_out_file_name, errno); + + g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO; + g_cv_hash = newHV(); + g_prof_pid = (int)getpid(); + + New(0, g_profstack, g_profstack_max, PROFANY); + prof_recordheader(aTHX); + DBG_TIMER_NOTIFY("Profiler timer is on.\n"); + g_orealtime = g_rprof_start = Times(&g_prof_start); + g_otms_utime = g_prof_start.tms_utime; + g_otms_stime = g_prof_start.tms_stime; + PL_perldb = g_default_perldb; + } diff --git a/contrib/perl5/ext/Devel/DProf/Makefile.PL b/contrib/perl5/ext/Devel/DProf/Makefile.PL new file mode 100644 index 0000000..667cc52 --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/Makefile.PL @@ -0,0 +1,17 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Devel::DProf', + DISTNAME => 'DProf', + VERSION_FROM => 'DProf.pm', + clean => { 'FILES' => 'tmon.out t/tmon.out t/err'}, + XSPROTOARG => '-noprototypes', + DEFINE => '-DPERLDBf_NONAME=0x40 -DPERLDBf_GOTO=0x80 ' + .'-DG_NODEBUG=32 -DPL_NEEDED', + dist => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, +); diff --git a/contrib/perl5/ext/Devel/DProf/Todo b/contrib/perl5/ext/Devel/DProf/Todo new file mode 100644 index 0000000..0e00347 --- /dev/null +++ b/contrib/perl5/ext/Devel/DProf/Todo @@ -0,0 +1,13 @@ +- work on test suite. +- localize the depth to guard against non-local exits. +Current overhead (with PERLDBf_NONAME) wrt non-debugging run (estimates): + 8% extra call frame on DB::sub + 7% output of subroutine data + 70% output of timing data (on OS/2, 35% with custom dprof_times()) +(Additional 17% are spent to write the output, but they are counted + and subtracted.) + +With compensation for DProf overhead all but some odd 12% are subtracted ?! + +- Calculate overhead/count for XS calls and Perl calls separately. +- goto &XSUB in pp_ctl.c; diff --git a/contrib/perl5/ext/Devel/Peek/Changes b/contrib/perl5/ext/Devel/Peek/Changes new file mode 100644 index 0000000..e143f87 --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Changes @@ -0,0 +1,64 @@ +0.3: Some functions return SV * now. +0.4: Hashes dumped recursively. + Additional fields for CV added. +0.5: Prototypes for functions supported. + Strings are consostently in quotes now. + Name changed to Devel::Peek (former ExtUtils::Peek). +0.7: + New function mstat added. + Docs added (thanks to Dean Roehrich). + +0.8: + Exports Dump and mstat. + Docs list more details. + Arrays print addresses of SV. + CV: STASH renamed to COMP_STASH. The package of GV is printed now. + Updated for newer overloading implementation (but will not report + packages with overloading). +0.81: + Implements and exports DeadCode(). + Buglet in the definition of mstat for malloc-less perl corrected. +0.82: + New style PADless CV allowed. +0.83: + DumpArray added. + Compatible with PerlIO. + When calculating junk inside subs, divide by refcount. +0.84: + Indented output. +0.85: + By Gisle Aas: format SvPVX, print magic (but not unrefcounted mg_obj); + A lot of new fields stolen from sv_dump(); +0.86: + By Gisle Aas: + - Updated the documentation. + - Move string printer to it's own function: fprintpv() + - Use it to print PVs, HV keys, MG_PTR + - Don't print IV for hashes as KEY is the same field + - Tag GvSTASH as "GvSTASH" in order to not confuse it with + the other STASH field, e.g. Dump(bless \*foo, "bar") +0.87: + Extra indentation of SvRV. + AMAGIC removed. + Head of OOK data printed too. +0.88: + PADLIST and OUTSIDE of CVs itemized. + Prints the value of the hash of HV keys. + Changes by Gisle: do not print both if AvARRAY == AvALLOC; + print hash fill statistics. +0.89: + Changes by Gisle: optree dump. +0.90: + DumpWithOP, DumpProg exported. + Better indent for AV, HV elts. + Address of SV printed. + Corrected Zero code which was causing segfaults. +0.91: + Compiles, runs test under 5.005beta2. + Update DEBUGGING_MSTATS-less MSTATS. +0.92: + Should compile without MYMALLOC too. +0.94: + Had problems with HEf_SVKEY magic. +0.95: + Added "hash quality" output to estimate Perl's hash functions. diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL new file mode 100644 index 0000000..3c6dbf5 --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => "Devel::Peek", + VERSION_FROM => 'Peek.pm', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, +); diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm new file mode 100644 index 0000000..080251b --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Peek.pm @@ -0,0 +1,432 @@ +# Devel::Peek - A data debugging tool for the XS programmer +# The documentation is after the __END__ + +package Devel::Peek; + +# Underscore to allow older Perls to access older version from CPAN +$VERSION = '1.00_01'; + +require Exporter; +use XSLoader (); + +@ISA = qw(Exporter); +@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); +%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); + +XSLoader::load 'Devel::Peek'; + +sub DumpWithOP ($;$) { + local($Devel::Peek::dump_ops)=1; + my $depth = @_ > 1 ? $_[1] : 4 ; + Dump($_[0],$depth); +} + +1; +__END__ + +=head1 NAME + +Devel::Peek - A data debugging tool for the XS programmer + +=head1 SYNOPSIS + + use Devel::Peek; + Dump( $a ); + Dump( $a, 5 ); + DumpArray( 5, $a, $b, ... ); + mstat "Point 5"; + +=head1 DESCRIPTION + +Devel::Peek contains functions which allows raw Perl datatypes to be +manipulated from a Perl script. This is used by those who do XS programming +to check that the data they are sending from C to Perl looks as they think +it should look. The trick, then, is to know what the raw datatype is +supposed to look like when it gets to Perl. This document offers some tips +and hints to describe good and bad raw data. + +It is very possible that this document will fall far short of being useful +to the casual reader. The reader is expected to understand the material in +the first few sections of L<perlguts>. + +Devel::Peek supplies a C<Dump()> function which can dump a raw Perl +datatype, and C<mstat("marker")> function to report on memory usage +(if perl is compiled with corresponding option). The function +DeadCode() provides statistics on the data "frozen" into inactive +C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and +C<SvREFCNT_dec()> which can query, increment, and decrement reference +counts on SVs. This document will take a passive, and safe, approach +to data debugging and for that it will describe only the C<Dump()> +function. For format of output of mstats() see +L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. + +Function C<DumpArray()> allows dumping of multiple values (useful when you +need to analize returns of functions). + +The global variable $Devel::Peek::pv_limit can be set to limit the +number of character printed in various string values. Setting it to 0 +means no limit. + +=head1 EXAMPLES + +The following examples don't attempt to show everything as that would be a +monumental task, and, frankly, we don't want this manpage to be an internals +document for Perl. The examples do demonstrate some basics of the raw Perl +datatypes, and should suffice to get most determined people on their way. +There are no guidewires or safety nets, nor blazed trails, so be prepared to +travel alone from this point and on and, if at all possible, don't fall into +the quicksand (it's bad for business). + +Oh, one final bit of advice: take L<perlguts> with you. When you return we +expect to see it well-thumbed. + +=head2 A simple scalar string + +Let's begin by looking a simple scalar which is holding a string. + + use Devel::Peek; + $a = "hello"; + Dump $a; + +The output: + + SV = PVIV(0xbc288) + REFCNT = 1 + FLAGS = (POK,pPOK) + IV = 0 + PV = 0xb2048 "hello"\0 + CUR = 5 + LEN = 6 + +This says C<$a> is an SV, a scalar. The scalar is a PVIV, a string. +Its reference count is 1. It has the C<POK> flag set, meaning its +current PV field is valid. Because POK is set we look at the PV item +to see what is in the scalar. The \0 at the end indicate that this +PV is properly NUL-terminated. +If the FLAGS had been IOK we would look +at the IV item. CUR indicates the number of characters in the PV. +LEN indicates the number of bytes requested for the PV (one more than +CUR, in this case, because LEN includes an extra byte for the +end-of-string marker). + +=head2 A simple scalar number + +If the scalar contains a number the raw SV will be leaner. + + use Devel::Peek; + $a = 42; + Dump $a; + +The output: + + SV = IV(0xbc818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV, a scalar. The scalar is an IV, a number. Its +reference count is 1. It has the C<IOK> flag set, meaning it is currently +being evaluated as a number. Because IOK is set we look at the IV item to +see what is in the scalar. + +=head2 A simple scalar with an extra reference + +If the scalar from the previous example had an extra reference: + + use Devel::Peek; + $a = 42; + $b = \$a; + Dump $a; + +The output: + + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Notice that this example differs from the previous example only in its +reference count. Compare this to the next example, where we dump C<$b> +instead of C<$a>. + +=head2 A reference to a simple scalar + +This shows what a reference looks like when it references a simple scalar. + + use Devel::Peek; + $a = 42; + $b = \$a; + Dump $b; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xbab08 + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Starting from the top, this says C<$b> is an SV. The scalar is an RV, a +reference. It has the C<ROK> flag set, meaning it is a reference. Because +ROK is set we have an RV item rather than an IV or PV. Notice that Dump +follows the reference and shows us what C<$b> was referencing. We see the +same C<$a> that we found in the previous example. + +Note that the value of C<RV> coincides with the numbers we see when we +stringify $b. The addresses inside RV() and IV() are addresses of +C<X***> structure which holds the current state of an C<SV>. This +address may change during lifetime of an SV. + +=head2 A reference to an array + +This shows what a reference to an array looks like. + + use Devel::Peek; + $a = [42]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV and that it is an RV. That RV points to +another SV which is a PVAV, an array. The array has one element, +element zero, which is another SV. The field C<FILL> above indicates +the last element in the array, similar to C<$#$a>. + +If C<$a> pointed to an array of two elements then we would see the +following. + + use Devel::Peek 'Dump'; + $a = [42,24]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + Elt No. 1 0xb5680 + SV = IV(0xbe818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 24 + +Note that C<Dump> will not report I<all> the elements in the array, +only several first (depending on how deep it already went into the +report tree). + +=head2 A reference to a hash + +The following shows the raw form of a reference to a hash. + + use Devel::Peek; + $a = {hello=>42}; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVHV(0xbd448) + REFCNT = 1 + FLAGS = () + NV = 0 + ARRAY = 0xbd748 + KEYS = 1 + FILL = 1 + MAX = 7 + RITER = -1 + EITER = 0x0 + Elt "hello" => 0xbaaf0 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a +hash. Fields RITER and EITER are used by C<L<each>>. + +=head2 Dumping a large array or hash + +The C<Dump()> function, by default, dumps up to 4 elements from a +toplevel array or hash. This number can be increased by supplying a +second argument to the function. + + use Devel::Peek; + $a = [10,11,12,13,14]; + Dump $a; + +Notice that C<Dump()> prints only elements 10 through 13 in the above code. +The following code will print all of the elements. + + use Devel::Peek 'Dump'; + $a = [10,11,12,13,14]; + Dump $a, 5; + +=head2 A reference to an SV which holds a C pointer + +This is what you really need to know as an XS programmer, of course. When +an XSUB returns a pointer to a C structure that pointer is stored in an SV +and a reference to that SV is placed on the XSUB stack. So the output from +an XSUB which uses something like the T_PTROBJ map might look something like +this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (OBJECT,IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + STASH = 0xc1d10 "CookBookB::Opaque" + +This shows that we have an SV which is an RV. That RV points at another +SV. In this case that second SV is a PVMG, a blessed scalar. Because it is +blessed it has the C<OBJECT> flag set. Note that an SV which holds a C +pointer also has the C<IOK> flag set. The C<STASH> is set to the package +name which this SV was blessed into. + +The output from an XSUB which uses something like the T_PTRREF map, which +doesn't bless the object, might look something like this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + +=head2 A reference to a subroutine + +Looks like this: + + SV = RV(0x798ec) + REFCNT = 1 + FLAGS = (TEMP,ROK) + RV = 0x1d453c + SV = PVCV(0x1c768c) + REFCNT = 2 + FLAGS = () + IV = 0 + NV = 0 + COMP_STASH = 0x31068 "main" + START = 0xb20e0 + ROOT = 0xbece0 + XSUB = 0x0 + XSUBANY = 0 + GVGV::GV = 0x1d44e8 "MY" :: "top_targets" + FILE = "(eval 5)" + DEPTH = 0 + PADLIST = 0x1c9338 + +This shows that + +=over + +=item * + +the subroutine is not an XSUB (since C<START> and C<ROOT> are +non-zero, and C<XSUB> is zero); + +=item * + +that it was compiled in the package C<main>; + +=item * + +under the name C<MY::top_targets>; + +=item * + +inside a 5th eval in the program; + +=item * + +it is not currently executed (see C<DEPTH>); + +=item * + +it has no prototype (C<PROTOTYPE> field is missing). + +=back + +=head1 EXPORTS + +C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and +C<DumpProg> by default. Additionally available C<SvREFCNT>, +C<SvREFCNT_inc> and C<SvREFCNT_dec>. + +=head1 BUGS + +Readers have been known to skip important parts of L<perlguts>, causing much +frustration for all. + +=head1 AUTHOR + +Ilya Zakharevich ilya@math.ohio-state.edu + +Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Author of this software makes no claim whatsoever about suitability, +reliability, edability, editability or usability of this product, and +should not be kept liable for any damage resulting from the use of +it. If you can use it, you are in luck, if not, I should not be kept +responsible. Keep a handy copy of your backup tape at hand. + +=head1 SEE ALSO + +L<perlguts>, and L<perlguts>, again. + +=cut diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs new file mode 100644 index 0000000..9837e9c --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Peek.xs @@ -0,0 +1,218 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +SV * +DeadCode(pTHX) +{ +#ifdef PURIFY + return Nullsv; +#else + SV* sva; + SV* sv, *dbg; + SV* ret = newRV_noinc((SV*)newAV()); + register SV* svend; + int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; + + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) == SVt_PVCV) { + CV *cv = (CV*)sv; + AV* padlist = CvPADLIST(cv), *argav; + SV** svp; + SV** pad; + int i = 0, j, levelm, totm = 0, levelref, totref = 0; + int levels, tots = 0, levela, tota = 0, levelas, totas = 0; + int dumpit = 0; + + if (CvXSUB(sv)) { + continue; /* XSUB */ + } + if (!CvGV(sv)) { + continue; /* file-level scope. */ + } + if (!CvROOT(cv)) { + /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ + continue; /* autoloading stub. */ + } + do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); + if (CvDEPTH(cv)) { + PerlIO_printf(Perl_debug_log, " busy\n"); + continue; + } + svp = AvARRAY(padlist); + while (++i <= AvFILL(padlist)) { /* Depth. */ + SV **args; + + pad = AvARRAY((AV*)svp[i]); + argav = (AV*)pad[0]; + if (!argav || (SV*)argav == &PL_sv_undef) { + PerlIO_printf(Perl_debug_log, " closure-template\n"); + continue; + } + args = AvARRAY(argav); + levelm = levels = levelref = levelas = 0; + levela = sizeof(SV*) * (AvMAX(argav) + 1); + if (AvREAL(argav)) { + for (j = 0; j < AvFILL(argav); j++) { + if (SvROK(args[j])) { + PerlIO_printf(Perl_debug_log, " ref in args!\n"); + levelref++; + } + /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ + else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { + levelas += SvLEN(args[j])/SvREFCNT(args[j]); + } + } + } + for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ + if (SvROK(pad[j])) { + levelref++; + do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); + dumpit = 1; + } + /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ + else if (SvTYPE(pad[j]) >= SVt_PVAV) { + if (!SvPADMY(pad[j])) { + levelref++; + do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); + dumpit = 1; + } + } + else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { + int db_len = SvLEN(pad[j]); + SV *db_sv = pad[j]; + levels++; + levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); + /* Dump(pad[j],4); */ + } + } + PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", + i, levelref, levelm, levels, levela, levelas); + totm += levelm; + tota += levela; + totas += levelas; + tots += levels; + totref += levelref; + if (dumpit) + do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); + } + if (AvFILL(padlist) > 1) { + PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", + totref, totm, tots, tota, totas); + } + tref += totref; + tm += totm; + ts += tots; + ta += tota; + tas += totas; + } + } + } + PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); + + return ret; +#endif /* !PURIFY */ +} + +#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ + || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) +# define mstat(str) dump_mstats(str) +#else +# define mstat(str) \ + PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); +#endif + +#define _CvGV(cv) \ + (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ + ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) + +MODULE = Devel::Peek PACKAGE = Devel::Peek + +void +mstat(str="Devel::Peek::mstat: ") +char *str + +void +Dump(sv,lim=4) +SV * sv +I32 lim +PPCODE: +{ + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + PL_dumpindent = save_dumpindent; +} + +void +DumpArray(lim,...) +I32 lim +PPCODE: +{ + long i; + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + + for (i=1; i<items; i++) { + PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); + do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + } + PL_dumpindent = save_dumpindent; +} + +void +DumpProg() +PPCODE: +{ + warn("dumpindent is %d", PL_dumpindent); + if (PL_main_root) + op_dump(PL_main_root); +} + +I32 +SvREFCNT(sv) +SV * sv + +# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. + +SV * +SvREFCNT_inc(sv) +SV * sv +PPCODE: +{ + RETVAL = SvREFCNT_inc(sv); + PUSHs(RETVAL); +} + +# PPCODE needed since by default it is void + +SV * +SvREFCNT_dec(sv) +SV * sv +PPCODE: +{ + SvREFCNT_dec(sv); + PUSHs(sv); +} + +SV * +DeadCode() +CODE: + RETVAL = DeadCode(aTHX); +OUTPUT: + RETVAL + +MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ + +SV * +_CvGV(cv) + SV *cv diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL index cf7d708..e0eb604 100644 --- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL +++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL @@ -3,7 +3,7 @@ use Config; sub to_string { my ($value) = @_; - $value =~ s/\\/\\\\'/g; + $value =~ s/\\/\\\\/g; $value =~ s/'/\\'/g; return "'$value'"; } @@ -28,7 +28,7 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -$VERSION = $VERSION = "1.03"; # avoid typo warning +$VERSION = "1.04"; # avoid typo warning require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; @@ -72,12 +72,13 @@ print OUT <<'EOT'; # See dl_expandspec() for more details. Should be harmless but # inefficient to define on systems that don't need it. $do_expand = $Is_VMS = $^O eq 'VMS'; +$Is_MacOS = $^O eq 'MacOS'; @dl_require_symbols = (); # names of symbols we need @dl_resolve_using = (); # names of files to link with @dl_library_path = (); # path to look for files -@dl_librefs = (); # things we have loaded -@dl_modules = (); # Modules we have loaded +#@dl_librefs = (); # things we have loaded +#@dl_modules = (); # Modules we have loaded # This is a fix to support DLD's unfortunate desire to relink -lc @dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; @@ -93,12 +94,24 @@ print OUT "push(\@dl_library_path, split(' ', ", print OUT <<'EOT'; -# Add to @dl_library_path any extra directories we can gather from -# environment variables. So far LD_LIBRARY_PATH is the only known -# variable used for this purpose. Others may be added later. +# Add to @dl_library_path any extra directories we can gather +# from environment variables. +if ($Is_MacOS) { + push(@dl_library_path, split(/,/, $ENV{LD_LIBRARY_PATH})) + if exists $ENV{LD_LIBRARY_PATH}; +} else { + push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}})) + if exists $Config::Config{ldlibpthname} && + $Config::Config{ldlibpthname} ne '' && + exists $ENV{$Config::Config{ldlibpthname}} ;; + push(@dl_library_path, split(/:/, $ENV{$Config::Config{ldlibpthname}})) + if exists $Config::Config{ldlibpthname} && + $Config::Config{ldlibpthname} ne '' && + exists $ENV{$Config::Config{ldlibpthname}} ;; +# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH. push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) - if $ENV{LD_LIBRARY_PATH}; - + if exists $ENV{LD_LIBRARY_PATH}; +} # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && @@ -116,6 +129,14 @@ if ($dl_debug) { sub croak { require Carp; Carp::croak(@_) } +sub bootstrap_inherit { + my $module = $_[0]; + local *isa = *{"$module\::ISA"}; + local @isa = (@isa, 'DynaLoader'); + # Cannot goto due to delocalization. Will report errors on a wrong line? + bootstrap(@_); +} + # The bootstrap function cannot be autoloaded (without complications) # so we define it here: @@ -145,18 +166,27 @@ sub bootstrap { # It may also edit @modparts if required. $modfname = &mod2fname(\@modparts) if defined &mod2fname; - my $modpname = join('/',@modparts); + my $modpname = join(($Is_MacOS ? ':' : '/'),@modparts); print STDERR "DynaLoader::bootstrap for $module ", - "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug; + ($Is_MacOS + ? "(auto/$modpname/$modfname.$dl_dlext)\n" : + "(:auto:$modpname:$modfname.$dl_dlext)\n") + if $dl_debug; foreach (@INC) { chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS; - my $dir = "$_/auto/$modpname"; + my $dir; + if ($Is_MacOS) { + chop $_ if /:$/; + $dir = "$_:auto:$modpname"; + } else { + $dir = "$_/auto/$modpname"; + } next unless -d $dir; # skip over uninteresting directories # check for common cases to avoid autoload of dl_findfile - my $try = "$dir/$modfname.$dl_dlext"; + my $try = $Is_MacOS ? "$dir:$modfname.$dl_dlext" : "$dir/$modfname.$dl_dlext"; last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); # no luck here, save dir for possible later dl_findfile search @@ -168,6 +198,7 @@ sub bootstrap { croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") unless $file; # wording similar to error from 'require' + $file = uc($file) if $Is_VMS && $Config{d_vms_case_sensitive_symbols}; my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @dl_require_symbols = ($bootname); @@ -176,7 +207,7 @@ sub bootstrap { # The .bs file can be used to configure @dl_resolve_using etc to # match the needs of the individual module on this architecture. my $bs = $file; - $bs =~ s/(\.\w+)?$/\.bs/; # look for .bs 'beside' the library + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library if (-s $bs) { # only read file if it's not empty print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; eval { do $bs; }; @@ -191,7 +222,7 @@ sub bootstrap { # it executed. my $libref = dl_load_file($file, $module->dl_load_flags) or - croak("Can't load '$file' for module $module: ".dl_error()."\n"); + croak("Can't load '$file' for module $module: ".dl_error()); push(@dl_librefs,$libref); # record loaded object @@ -251,6 +282,12 @@ print OUT <<'EOT'; last arg unless wantarray; next; } + elsif ($Is_MacOS) { + if (m/:/ && -f $_) { + push(@found,$_); + last arg unless wantarray; + } + } elsif (m:/: && -f $_ && !$do_expand) { push(@found,$_); last arg unless wantarray; @@ -261,6 +298,30 @@ print OUT <<'EOT'; # Using a -L prefix is the preferred option (faster and more robust) if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + if ($Is_MacOS) { + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m/:/ && -d $_) { push(@dirs, $_); next; } + # Only files should get this far... + my(@names, $name); # what filenames to look for + s/^-l//; + push(@names, $_); + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + $dir =~ s/^([^:]+)$/:$1/; + $dir =~ s/:$//; + foreach $name (@names) { + my($file) = "$dir:$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + if (-f $file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + next; + } + # Otherwise we try to try to spot directories by a heuristic # (this is a more complicated issue than it first appears) if (m:/: && -d $_) { push(@dirs, $_); next; } @@ -350,7 +411,7 @@ sub dl_find_symbol_anywhere DynaLoader - Dynamically load C libraries into Perl code -dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules +dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_unload_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules =head1 SYNOPSIS @@ -402,6 +463,7 @@ DynaLoader Interface Summary $symref = dl_find_symbol_anywhere($symbol) Perl $libref = dl_load_file($filename, $flags) C + $status = dl_unload_file($libref) C $symref = dl_find_symbol($libref, $symbol) C @symbols = dl_undef_symbols() C dl_install_xsub($name, $symref [, $filename]) C @@ -579,6 +641,42 @@ current values of @dl_require_symbols and @dl_resolve_using if required. Linux, and is a common choice when providing a "wrapper" on other mechanisms as is done in the OS/2 port.) +=item dl_unload_file() + +Syntax: + + $status = dl_unload_file($libref) + +Dynamically unload $libref, which must be an opaque 'library reference' as +returned from dl_load_file. Returns one on success and zero on failure. + +This function is optional and may not necessarily be provided on all platforms. +If it is defined, it is called automatically when the interpreter exits for +every shared object or library loaded by DynaLoader::bootstrap. All such +library references are stored in @dl_librefs by DynaLoader::Bootstrap as it +loads the libraries. The files are unloaded in last-in, first-out order. + +This unloading is usually necessary when embedding a shared-object perl (e.g. +one configured with -Duseshrplib) within a larger application, and the perl +interpreter is created and destroyed several times within the lifetime of the +application. In this case it is possible that the system dynamic linker will +unload and then subsequently reload the shared libperl without relocating any +references to it from any files DynaLoaded by the previous incarnation of the +interpreter. As a result, any shared objects opened by DynaLoader may point to +a now invalid 'ghost' of the libperl shared object, causing apparently random +memory corruption and crashes. This behaviour is most commonly seen when using +Apache and mod_perl built with the APXS mechanism. + + SunOS: dlclose($libref) + HP-UX: ??? + Linux: ??? + NeXT: ??? + VMS: ??? + +(The dlclose() function is also used by Solaris and some versions of +Linux, and is a common choice when providing a "wrapper" on other +mechanisms as is done in the OS/2 port.) + =item dl_loadflags() Syntax: diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL index 2141fde..83cbd77 100644 --- a/contrib/perl5/ext/DynaLoader/Makefile.PL +++ b/contrib/perl5/ext/DynaLoader/Makefile.PL @@ -8,14 +8,19 @@ WriteMakefile( SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'DynaLoader_pm.PL', - PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'}, - PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, - clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, + PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm', + 'XSLoader_pm.PL'=>'XSLoader.pm'}, + PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm', + 'XSLoader.pm' => '$(INST_LIBDIR)/XSLoader.pm'}, + depend => {'DynaLoader.o' => 'dlutils.c'}, + clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm ' . + 'XSLoader.pm'}, ); sub MY::postamble { ' DynaLoader.xs: $(DLSRC) + $(RM_F) $@ $(CP) $? $@ # Perform very simple tests just to check for major gaffs. diff --git a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL new file mode 100644 index 0000000..8cdfd63 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL @@ -0,0 +1,158 @@ +use Config; + +sub to_string { + my ($value) = @_; + $value =~ s/\\/\\\\/g; + $value =~ s/'/\\'/g; + return "'$value'"; +} + +unlink "XSLoader.pm" if -f "XSLoader.pm"; +open OUT, ">XSLoader.pm" or die $!; +print OUT <<'EOT'; +# Generated from XSLoader.pm.PL (resolved %Config::Config value) + +package XSLoader; + +# And Gandalf said: 'Many folk like to know beforehand what is to +# be set on the table; but those who have laboured to prepare the +# feast like to keep their secret; for wonder makes the words of +# praise louder.' + +# (Quote from Tolkien sugested by Anno Siegel.) +# +# See pod text at end of file for documentation. +# See also ext/DynaLoader/README in source tree for other information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +$VERSION = "0.01"; # avoid typo warning + +# enable debug/trace messages from DynaLoader perl code +# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +EOT + +print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ; + +print OUT <<'EOT'; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +package DynaLoader; +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_load_file); +package XSLoader; + +1; # End of main code + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub load { + package DynaLoader; + + my($module) = $_[0]; + + # work with static linking too + my $b = "$module\::bootstrap"; + goto &$b if defined &$b; + + goto retry unless $module and defined &dl_load_file; + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + +EOT + +print OUT <<'EOT' if defined &DynaLoader::mod2fname; + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &mod2fname(\@modparts) if defined &mod2fname; + +EOT + +print OUT <<'EOT'; + my $modpname = join('/',@modparts); + my $modlibname = (caller())[1]; + my $c = @modparts; + $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename + my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; + +# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; + + my $bs = $file; + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + + goto retry if not -f $file or -s $bs; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, 0) or do { + require Carp; + Carp::croak("Can't load '$file' for module $module: " . dl_error()); + }; + push(@dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { + require Carp; + Carp::croak("Can't find '$bootname' symbol in $file\n"); + }; + + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + push(@dl_modules, $module); # record loaded module + + # See comment block above + return &$xs(@_); + + retry: + require DynaLoader; + goto &DynaLoader::bootstrap_inherit; +} + +__END__ + +=head1 NAME + +XSLoader - Dynamically load C libraries into Perl code + +=head1 SYNOPSIS + + package YourPackage; + use XSLoader; + + XSLoader::load 'YourPackage', @args; + +=head1 DESCRIPTION + +This module defines a standard I<simplified> interface to the dynamic +linking mechanisms available on many platforms. Its primary purpose is +to implement cheap automatic dynamic loading of Perl modules. + +For more complicated interface see L<DynaLoader>. + +=head1 AUTHOR + +Ilya Zakharevich: extraction from DynaLoader. + +=cut +EOT + +close OUT or die $!; + diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs index ea50408..35242ed 100644 --- a/contrib/perl5/ext/DynaLoader/dl_aix.xs +++ b/contrib/perl5/ext/DynaLoader/dl_aix.xs @@ -20,6 +20,15 @@ #include "perl.h" #include "XSUB.h" +/* When building as a 64-bit binary on AIX, define this to get the + * correct structure definitions. Also determines the field-name + * macros and gates some logic in readEntries(). -- Steven N. Hirsch + * <hirschs@btv.ibm.com> */ +#ifdef USE_64_BIT_ALL +# define __XCOFF64__ +# define __XCOFF32__ +#endif + #include <stdio.h> #include <errno.h> #include <string.h> @@ -29,6 +38,39 @@ #include <a.out.h> #include <ldfcn.h> +#ifdef USE_64_BIT_ALL +# define AIX_SCNHDR SCNHDR_64 +# define AIX_LDHDR LDHDR_64 +# define AIX_LDSYM LDSYM_64 +# define AIX_LDHDRSZ LDHDRSZ_64 +#else +# define AIX_SCNHDR SCNHDR +# define AIX_LDHDR LDHDR +# define AIX_LDSYM LDSYM +# define AIX_LDHDRSZ LDHDRSZ +#endif + +/* When using Perl extensions written in C++ the longer versions + * of load() and unload() from libC and libC_r need to be used, + * otherwise statics in the extensions won't get initialized right. + * -- Stephanie Beals <bealzy@us.ibm.com> */ + +/* Older AIX C compilers cannot deal with C++ double-slash comments in + the ibmcxx and/or xlC includes. Since we only need a single file, + be more fine-grained about what's included <hirschs@btv.ibm.com> */ +#ifdef USE_libC /* The define comes, when it comes, from hints/aix.pl. */ +# define LOAD loadAndInit +# define UNLOAD terminateAndUnload +# if defined(USE_xlC_load_h) +# include "/usr/lpp/xlC/include/load.h" +# elif defined(USE_ibmcxx_load_h) +# include "/usr/ibmcxx/include/load.h" +# endif +#else +# define LOAD load +# define UNLOAD unload +#endif + /* * AIX 4.3 does remove some useful definitions from ldfcn.h. Define * these here to compensate for that lossage. @@ -77,19 +119,18 @@ typedef struct Module { * We keep a list of all loaded modules to be able to call the fini * handlers at atexit() time. */ -static ModulePtr modList; +static ModulePtr modList; /* XXX threaded */ /* * The last error from one of the dl* routines is kept in static * variables here. Each error is returned only once to the caller. */ -static char errbuf[BUFSIZ]; -static int errvalid; +static char errbuf[BUFSIZ]; /* XXX threaded */ +static int errvalid; /* XXX threaded */ static void caterr(char *); static int readExports(ModulePtr); static void terminate(void); -static void *findMain(void); static char *strerror_failed = "(strerror failed)"; static char *strerror_r_failed = "(strerror_r failed)"; @@ -104,7 +145,7 @@ char *strerrorcat(char *str, int err) { if (buf == 0) return 0; - if (strerror_r(err, buf, sizeof(buf)) == 0) + if (strerror_r(err, buf, BUFSIZ) == 0) msg = buf; else msg = strerror_r_failed; @@ -132,7 +173,7 @@ char *strerrorcpy(char *str, int err) { if (buf == 0) return 0; - if (strerror_r(err, buf, sizeof(buf)) == 0) + if (strerror_r(err, buf, BUFSIZ) == 0) msg = buf; else msg = strerror_r_failed; @@ -154,17 +195,16 @@ char *strerrorcpy(char *str, int err) { /* ARGSUSED */ void *dlopen(char *path, int mode) { + dTHX; register ModulePtr mp; - static void *mainModule; + static int inited; /* XXX threaded */ /* * Upon the first call register a terminate handler that will - * close all libraries. Also get a reference to the main module - * for use with loadbind. + * close all libraries. */ - if (!mainModule) { - if ((mainModule = findMain()) == NULL) - return NULL; + if (!inited) { + inited++; atexit(terminate); } /* @@ -190,11 +230,19 @@ void *dlopen(char *path, int mode) safefree(mp); return NULL; } + /* * load should be declared load(const char *...). Thus we * cast the path to a normal char *. Ugly. */ - if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + if ((mp->entry = (void *)LOAD((char *)path, +#ifdef L_LIBPATH_EXEC + L_LIBPATH_EXEC | +#endif + L_NOAUTODEFER, + NULL)) == NULL) { + int saverrno = errno; + safefree(mp->name); safefree(mp); errvalid++; @@ -206,27 +254,34 @@ void *dlopen(char *path, int mode) * can be further described by querying the loader about * the last error. */ - if (errno == ENOEXEC) { - char *tmp[BUFSIZ/sizeof(char *)]; - if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) - strerrorcpy(errbuf, errno); + if (saverrno == ENOEXEC) { + char *moreinfo[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, moreinfo, sizeof(moreinfo)) == -1) + strerrorcpy(errbuf, saverrno); else { char **p; - for (p = tmp; *p; p++) + for (p = moreinfo; *p; p++) caterr(*p); } } else - strerrorcat(errbuf, errno); + strerrorcat(errbuf, saverrno); return NULL; } mp->refCnt = 1; mp->next = modList; modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { + /* + * Assume anonymous exports come from the module this dlopen + * is linked into, that holds true as long as dlopen and all + * of the perl core are in the same shared object. + */ + if (loadbind(0, (void *)dlopen, mp->entry) == -1) { + int saverrno = errno; + dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); - strerrorcat(errbuf, errno); + strerrorcat(errbuf, saverrno); return NULL; } if (readExports(mp) == -1) { @@ -311,7 +366,7 @@ int dlclose(void *handle) if (--mp->refCnt > 0) return 0; - result = unload(mp->entry); + result = UNLOAD(mp->entry); if (result == -1) { errvalid++; strerrorcpy(errbuf, errno); @@ -364,11 +419,12 @@ void *calloc(size_t ne, size_t sz) */ static int readExports(ModulePtr mp) { + dTHX; LDFILE *ldp = NULL; - SCNHDR sh; - LDHDR *lhp; + AIX_SCNHDR sh; + AIX_LDHDR *lhp; char *ldbuf; - LDSYM *ls; + AIX_LDSYM *ls; int i; ExportPtr ep; @@ -412,7 +468,7 @@ static int readExports(ModulePtr mp) } /* * Traverse the list of loaded modules. The entry point - * returned by load() does actually point to the data + * returned by LOAD() does actually point to the data * segment origin. */ lp = (struct ld_info *)buf; @@ -434,7 +490,11 @@ static int readExports(ModulePtr mp) return -1; } } +#ifdef USE_64_BIT_ALL + if (TYPE(ldp) != U803XTOCMAGIC) { +#else if (TYPE(ldp) != U802TOCMAGIC) { +#endif errvalid++; strcpy(errbuf, "readExports: bad magic"); while(ldclose(ldp) == FAILURE) @@ -482,8 +542,8 @@ static int readExports(ModulePtr mp) ; return -1; } - lhp = (LDHDR *)ldbuf; - ls = (LDSYM *)(ldbuf+LDHDRSZ); + lhp = (AIX_LDHDR *)ldbuf; + ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); /* * Count the number of exports to include in our export table. */ @@ -507,15 +567,19 @@ static int readExports(ModulePtr mp) * the entry point we got from load. */ ep = mp->exports; - ls = (LDSYM *)(ldbuf+LDHDRSZ); + ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); for (i = lhp->l_nsyms; i; i--, ls++) { char *symname; if (!LDR_EXPORT(*ls)) continue; +#ifndef USE_64_BIT_ALL if (ls->l_zeroes == 0) +#endif symname = ls->l_offset+lhp->l_stoff+ldbuf; +#ifndef USE_64_BIT_ALL else symname = ls->l_name; +#endif ep->name = savepv(symname); ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); ep++; @@ -526,56 +590,10 @@ static int readExports(ModulePtr mp) return 0; } -/* - * Find the main modules entry point. This is used as export pointer - * for loadbind() to be able to resolve references to the main part. - */ -static void * findMain(void) -{ - struct ld_info *lp; - char *buf; - int size = 4*1024; - int i; - void *ret; - - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - return NULL; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - safefree(buf); - size += 4*1024; - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - return NULL; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - safefree(buf); - return NULL; - } - /* - * The first entry is the main module. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - ret = lp->ldinfo_dataorg; - safefree(buf); - return ret; -} - /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: @@ -597,15 +615,15 @@ static void * findMain(void) static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -613,16 +631,16 @@ dl_load_file(filename, flags=0) char * filename int flags CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, 1) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -630,15 +648,15 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -655,9 +673,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_beos.xs b/contrib/perl5/ext/DynaLoader/dl_beos.xs index 42a27cb..705c8bc 100644 --- a/contrib/perl5/ext/DynaLoader/dl_beos.xs +++ b/contrib/perl5/ext/DynaLoader/dl_beos.xs @@ -18,15 +18,15 @@ #include "dlutils.c" /* SaveError() etc */ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -45,16 +45,16 @@ dl_load_file(filename, flags=0) strcpy(path, filename); } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", path, flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", path, flags)); bogo = load_add_on(path); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (bogo < 0) { - SaveError("%s", strerror(bogo)); - PerlIO_printf(PerlIO_stderr(), "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); + SaveError(aTHX_ "%s", strerror(bogo)); + PerlIO_printf(Perl_debug_log, "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); } else { RETVAL = (void *) bogo; - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); } free(path); } @@ -67,23 +67,23 @@ dl_find_symbol(libhandle, symbolname) status_t retcode; void *adr = 0; #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif RETVAL = NULL; - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); retcode = get_image_symbol((image_id) libhandle, symbolname, B_SYMBOL_TYPE_TEXT, (void **) &adr); RETVAL = adr; - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) { - SaveError("%s", strerror(retcode)) ; - PerlIO_printf(PerlIO_stderr(), "retcode = %p (%s)\n", retcode, strerror(retcode)); + SaveError(aTHX_ "%s", strerror(retcode)) ; + PerlIO_printf(Perl_debug_log, "retcode = %p (%s)\n", retcode, strerror(retcode)); } else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -100,9 +100,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", perl_name, (unsigned long) symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_dld.xs b/contrib/perl5/ext/DynaLoader/dl_dld.xs index 2443ab0..d8fad2a 100644 --- a/contrib/perl5/ext/DynaLoader/dl_dld.xs +++ b/contrib/perl5/ext/DynaLoader/dl_dld.xs @@ -48,12 +48,12 @@ static AV *dl_resolve_using = Nullav; static AV *dl_require_symbols = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { int dlderr; - dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); - dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); #ifdef __linux__ dlderr = dld_init("/proc/self/exe"); if (dlderr) { @@ -61,8 +61,8 @@ dl_private_init() dlderr = dld_init(dld_find_executable(PL_origargv[0])); if (dlderr) { char *msg = dld_strerror(dlderr); - SaveError("dld_init(%s) failed: %s", PL_origargv[0], msg); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); + SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", LastError)); } #ifdef __linux__ } @@ -85,40 +85,40 @@ dl_load_file(filename, flags=0) GV *gv; CODE: RETVAL = filename; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - croak("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_croak(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); max = AvFILL(dl_require_symbols); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym)); if (dlderr = dld_create_reference(sym)) { - SaveError("dld_create_reference(%s): %s", sym, + SaveError(aTHX_ "dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { - SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); + SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; } max = AvFILL(dl_resolve_using); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym)); if (dlderr = dld_link(sym)) { - SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) - sv_setiv(ST(0), (IV)RETVAL); + sv_setiv(ST(0), PTR2IV(RETVAL)); void * @@ -126,16 +126,16 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = (void *)dld_get_func(symbolname); /* if RETVAL==NULL we should try looking for a non-function symbol */ - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ; else - sv_setiv(ST(0), (IV)RETVAL); + sv_setiv(ST(0), PTR2IV(RETVAL)); void @@ -160,9 +160,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs index 2459205..8e4936d 100644 --- a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs +++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs @@ -1,15 +1,17 @@ /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: - * 15th July 1994 - Added code to explicitly save any error messages. - * 3rd August 1994 - Upgraded to v3 spec. - * 9th August 1994 - Changed to use IV - * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, - * basic FreeBSD support, removed ClearError + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd + * files when the interpreter exits * */ @@ -37,6 +39,17 @@ RTLD_LAZY (==2) on Solaris 2. + dlclose + ------- + int + dlclose(handle) + void * handle; + + This function takes the handle returned by a previous invocation of + dlopen and closes the associated dynamic object file. It returns zero + on success, and non-zero on failure. + + dlsym ------ void * @@ -57,7 +70,7 @@ Returns a null-terminated string which describes the last error that occurred with either dlopen or dlsym. After each call to dlerror the error message will be reset to a null pointer. The - SaveError function is used to save the error as soo as it happens. + SaveError function is used to save the error as soon as it happens. Return Types @@ -131,24 +144,35 @@ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * dl_load_file(filename, flags=0) char * filename int flags - PREINIT: + PREINIT: int mode = RTLD_LAZY; - CODE: + CODE: +{ +#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) + char pathbuf[PATH_MAX + 2]; + if (*filename != '/' && strchr(filename, '/')) { + if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { + strcat(pathbuf, "/"); + strcat(pathbuf, filename); + filename = pathbuf; + } + } +#endif #ifdef RTLD_NOW if (dl_nonlazy) mode = RTLD_NOW; @@ -157,16 +181,30 @@ dl_load_file(filename, flags=0) #ifdef RTLD_GLOBAL mode |= RTLD_GLOBAL; #else - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); #endif - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); +} + + +int +dl_unload_file(libref) + void * libref + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + RETVAL = (dlclose(libref) == 0 ? 1 : 0); + if (!RETVAL) + SaveError(aTHX_ "%s", dlerror()) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); + OUTPUT: + RETVAL void * @@ -175,19 +213,19 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -204,9 +242,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", perl_name, (unsigned long) symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_dyld.xs b/contrib/perl5/ext/DynaLoader/dl_dyld.xs new file mode 100644 index 0000000..688e474 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_dyld.xs @@ -0,0 +1,226 @@ +/* dl_dyld.xs + * + * Platform: Darwin (Mac OS) + * Author: Wilfredo Sanchez <wsanchez@apple.com> + * Based on: dl_next.xs by Paul Marquess + * Based on: dl_dlopen.xs by Anno Siegel + * Created: Aug 15th, 1994 + * + */ + +/* + And Gandalf said: 'Many folk like to know beforehand what is to + be set on the table; but those who have laboured to prepare the + feast like to keep their secret; for wonder makes the words of + praise louder.' +*/ + +/* Porting notes: + +dl_dyld.xs is based on dl_next.xs by Anno Siegel. + +dl_next.xs is in turn a port from dl_dlopen.xs by Paul Marquess. It +should not be used as a base for further ports though it may be used +as an example for how dl_dlopen.xs can be ported to other platforms. + +The method used here is just to supply the sun style dlopen etc. +functions in terms of NeXT's/Apple's dyld. The xs code proper is +unchanged from Paul's original. + +The port could use some streamlining. For one, error handling could +be simplified. + +This should be useable as a replacement for dl_next.xs, but it has not +been tested on NeXT platforms. + + Wilfredo Sanchez + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define DL_LOADONCEONLY + +#include "dlutils.c" /* SaveError() etc */ + +#undef environ +#undef bool +#import <mach-o/dyld.h> + +static char * dl_last_error = (char *) 0; +static AV *dl_resolve_using = Nullav; + +static char *dlerror() +{ + return dl_last_error; +} + +int dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +enum dyldErrorSource +{ + OFImage, +}; + +static void TranslateError + (const char *path, enum dyldErrorSource type, int number) +{ + dTHX; + char *error; + unsigned int index; + static char *OFIErrorStrings[] = + { + "%s(%d): Object Image Load Failure\n", + "%s(%d): Object Image Load Success\n", + "%s(%d): Not an recognisable object file\n", + "%s(%d): No valid architecture\n", + "%s(%d): Object image has an invalid format\n", + "%s(%d): Invalid access (permissions?)\n", + "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", + }; +#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) + + switch (type) + { + case OFImage: + index = number; + if (index > NUM_OFI_ERRORS - 1) + index = NUM_OFI_ERRORS - 1; + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); + break; + + default: + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", + path, number, type); + break; + } + safefree(dl_last_error); + dl_last_error = savepv(error); +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int dyld_result; + NSObjectFileImage ofile; + NSModule handle = NULL; + + dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); + if (dyld_result != NSObjectFileImageSuccess) + TranslateError(path, OFImage, dyld_result); + else + { + // NSLinkModule will cause the run to abort on any link error's + // not very friendly but the error recovery functionality is limited. + handle = NSLinkModule(ofile, path, TRUE); + } + + return handle; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + void *addr; + + if (NSIsSymbolNameDefined(symbol)) + addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); + else + addr = NULL; + + return addr; +} + + + +/* ----- code from dl_dlopen.xs below here ----- */ + + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(aTHX); + + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + int mode = 1; + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); + RETVAL = dlopen(filename, mode) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",dlerror()) ; + else + sv_setiv( ST(0), PTR2IV(RETVAL) ); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + symbolname = Perl_form_nocontext("_%s", symbolname); + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",dlerror()) ; + else + sv_setiv( ST(0), PTR2IV(RETVAL) ); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", + perl_name, symref)); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_hpux.xs b/contrib/perl5/ext/DynaLoader/dl_hpux.xs index a82e0ea..582c047 100644 --- a/contrib/perl5/ext/DynaLoader/dl_hpux.xs +++ b/contrib/perl5/ext/DynaLoader/dl_hpux.xs @@ -33,16 +33,16 @@ static AV *dl_resolve_using = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -53,9 +53,9 @@ dl_load_file(filename, flags=0) shl_t obj = NULL; int i, max, bind_type; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); if (dl_nonlazy) { bind_type = BIND_IMMEDIATE|BIND_VERBOSE; } else { @@ -76,23 +76,23 @@ dl_load_file(filename, flags=0) max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s) (dependent)\n", sym)); obj = shl_load(sym, bind_type, 0L); if (obj == NULL) { goto end; } } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type, 0L); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) - SaveError("%s",Strerror(errno)); + SaveError(aTHX_ "%s",Strerror(errno)); else - sv_setiv( ST(0), (IV)obj); + sv_setiv( ST(0), PTR2IV(obj) ); void * @@ -104,9 +104,9 @@ dl_find_symbol(libhandle, symbolname) void *symaddr = NULL; int status; #ifdef __hp9000s300 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); @@ -114,17 +114,17 @@ dl_find_symbol(libhandle, symbolname) errno = 0; status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(PROCEDURE) = %x\n", symaddr)); if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(DATA) = %x\n", symaddr)); } if (status == -1) { - SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { - sv_setiv( ST(0), (IV)symaddr); + sv_setiv( ST(0), PTR2IV(symaddr) ); } @@ -142,9 +142,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs index 4cc07ec..7d27901 100644 --- a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs +++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs @@ -33,16 +33,16 @@ typedef struct { static AV *dl_resolve_using = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * dl_load_file(filename, flags=0) @@ -53,10 +53,10 @@ dl_load_file(filename, flags=0) p_mpe_dld obj = NULL; int i; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename, + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename, flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s ",filename); obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld)); memzero(obj, sizeof(t_mpe_dld)); @@ -68,13 +68,13 @@ flags)); else sprintf(obj->filename," %s ",filename); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", obj)); ST(0) = sv_newmortal() ; if (obj == NULL) - SaveError("%s",Strerror(errno)); + SaveError(aTHX_"%s",Strerror(errno)); else - sv_setiv( ST(0), (IV)obj); + sv_setiv( ST(0), PTR2IV(obj) ); void * dl_find_symbol(libhandle, symbolname) @@ -86,7 +86,7 @@ dl_find_symbol(libhandle, symbolname) char symname[PATH_MAX + 3]; void * symaddr = NULL; int status; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); ST(0) = sv_newmortal() ; errno = 0; @@ -95,12 +95,12 @@ dl_find_symbol(libhandle, symbolname) HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1, 0, &datalen, 1, 0, 0); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status)); if (status != 0) { - SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + SaveError(aTHX_"%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { - sv_setiv( ST(0), (IV)symaddr); + sv_setiv( ST(0), PTR2IV(symaddr) ); } void @@ -115,9 +115,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * dl_error() diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs index dfa8a3e..b8c19f2 100644 --- a/contrib/perl5/ext/DynaLoader/dl_next.xs +++ b/contrib/perl5/ext/DynaLoader/dl_next.xs @@ -72,6 +72,7 @@ enum dyldErrorSource static void TranslateError (const char *path, enum dyldErrorSource type, int number) { + dTHX; char *error; unsigned int index; static char *OFIErrorStrings[] = @@ -92,11 +93,11 @@ static void TranslateError index = number; if (index > NUM_OFI_ERRORS - 1) index = NUM_OFI_ERRORS - 1; - error = form(OFIErrorStrings[index], path, number); + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); break; default: - error = form("%s(%d): Totally unknown error type %d\n", + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", path, number, type); break; } @@ -209,7 +210,7 @@ char *symbol; NXStream *nxerr = OpenError(); unsigned long symref = 0; - if (!rld_lookup(nxerr, form("_%s", symbol), &symref)) + if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref)) TransferError(nxerr); CloseError(nxerr); return (void*) symref; @@ -222,16 +223,16 @@ char *symbol; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); @@ -242,16 +243,16 @@ dl_load_file(filename, flags=0) PREINIT: int mode = 1; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); if (flags & 0x01) - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -260,19 +261,19 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #if NS_TARGET_MAJOR >= 4 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void @@ -289,9 +290,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dl_vmesa.xs b/contrib/perl5/ext/DynaLoader/dl_vmesa.xs new file mode 100644 index 0000000..8595e44 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/dl_vmesa.xs @@ -0,0 +1,175 @@ +/* dl_vmesa.xs + * + * Platform: VM/ESA, possibly others which use dllload etc. + * Author: Neale Ferguson (neale@mailbox.tabnsw.com.au) + * Created: 23rd Septemer, 1998 + * + * + */ + +/* Porting notes: + + + Definition of VM/ESA dynamic Linking functions + ============================================== + In order to make this implementation easier to understand here is a + quick definition of the VM/ESA Dynamic Linking functions which are + used here. + + dlopen + ------ + void * + dlopen(const char *path) + + This function takes the name of a dynamic object file and returns + a descriptor which can be used by dlsym later. It returns NULL on + error. + + + dllsym + ------ + void * + dlsym(void *handle, char *symbol) + + Takes the handle returned from dlopen and the name of a symbol to + get the address of. If the symbol was found a pointer is + returned. It returns NULL on error. + + dlerror + ------- + char * dlerror() + + Returns a null-terminated string which describes the last error + that occurred with the other dll functions. After each call to + dlerror the error message will be reset to a null pointer. The + SaveError function is used to save the error as soo as it happens. + + + Return Types + ============ + In this implementation the two functions, dl_load_file & + dl_find_symbol, return void *. This is because the underlying SunOS + dynamic linker calls also return void *. This is not necessarily + the case for all architectures. For example, some implementation + will want to return a char * for dl_load_file. + + If void * is not appropriate for your architecture, you will have to + change the void * to whatever you require. If you are not certain of + how Perl handles C data types, I suggest you start by consulting + Dean Roerich's Perl 5 API document. Also, have a look in the typemap + file (in the ext directory) for a fairly comprehensive list of types + that are already supported. If you are completely stuck, I suggest you + post a message to perl5-porters, comp.lang.perl.misc or if you are really + desperate to me. + + Remember when you are making any changes that the return value from + dl_load_file is used as a parameter in the dl_find_symbol + function. Also the return value from find_symbol is used as a parameter + to install_xsub. + + + Dealing with Error Messages + ============================ + In order to make the handling of dynamic linking errors as generic as + possible you should store any error messages associated with your + implementation with the StoreError function. + + In the case of VM/ESA the function dlerror returns the error message + associated with the last dynamic link error. As the VM/ESA dynamic + linker functions return NULL on error every call to a VM/ESA dynamic + dynamic link routine is coded like this + + RETVAL = dlopen(filename) ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",dlerror()) ; + + Note that SaveError() takes a printf format string. Use a "%s" as + the first parameter if the error may contain and % characters. + +*/ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <dll.h> + + +#include "dlutils.c" /* SaveError() etc */ + + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(aTHX); + + +void * +dl_load_file(filename, flags=0) + char * filename + int flags + CODE: + if (flags & 0x01) + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); + RETVAL = dlopen(filename) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",dlerror()) ; + else + sv_setiv( ST(0), PTR2IV(RETVAL) ); + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + RETVAL = dlsym(libhandle, symbolname); + DLDEBUG(2, PerlIO_printf(Perl_debug_log, + " symbolref = %lx\n", (unsigned long) RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError(aTHX_ "%s",dlerror()) ; + else + sv_setiv( ST(0), PTR2IV(RETVAL) ); + + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + void * symref + char * filename + CODE: + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", + perl_name, (unsigned long) symref)); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs index 08fd2f3..d7a1f86 100644 --- a/contrib/perl5/ext/DynaLoader/dl_vms.xs +++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs @@ -65,6 +65,12 @@ static AV *dl_require_symbols = Nullav; #include <ssdef.h> #include <starlet.h> +#if defined(VMS_WE_ARE_CASE_SENSITIVE) +#define DL_CASE_SENSITIVE 1<<4 +#else +#define DL_CASE_SENSITIVE 0 +#endif + typedef unsigned long int vmssts; struct libref { @@ -112,6 +118,7 @@ dl_set_error(sts,stv) vmssts stv; { vmssts vec[3]; + dTHX; vec[0] = stv ? 2 : 1; vec[1] = sts; vec[2] = stv; @@ -121,12 +128,13 @@ dl_set_error(sts,stv) static unsigned int findsym_handler(void *sig, void *mech) { + dTHX; unsigned long int myvec[8],args, *usig = (unsigned long int *) sig; /* Be paranoid and assume signal vector passed in might be readonly */ myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; while (--args) myvec[args] = usig[args]; _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "findsym_handler: received\n\t%s\n",LastError)); return SS$_CONTINUE; } @@ -140,16 +148,16 @@ my_find_image_symbol(struct dsc$descriptor_s *imgname, { unsigned long int retsts; VAXC$ESTABLISH(findsym_handler); - retsts = lib$find_image_symbol(imgname,symname,entry,defspec); + retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE); return retsts; } static void -dl_private_init() +dl_private_init(pTHX) { - dl_generic_private_init(); - dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + dl_generic_private_init(aTHX); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4); /* Set up the static control blocks for dl_expand_filespec() */ dlfab = cc$rms_fab; dlnam = cc$rms_nam; @@ -162,7 +170,7 @@ dl_private_init() MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void dl_expandspec(filespec) @@ -177,11 +185,11 @@ dl_expandspec(filespec) dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_expand_filespec(%s):\n",vmsspec)); /* On the first pass, just parse the specification string */ dlnam.nam$b_nop = NAM$M_SYNCHK; sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; @@ -194,7 +202,7 @@ dl_expandspec(filespec) dlnam.nam$b_type + dlnam.nam$b_ver); deflen += dlnam.nam$b_type + dlnam.nam$b_ver; memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsplit filespec: name = %.*s, default = %.*s\n", dlnam.nam$b_name,vmsspec,deflen,defspec)); /* . . . and go back to expand it */ dlnam.nam$b_nop = 0; @@ -202,7 +210,7 @@ dl_expandspec(filespec) dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; @@ -210,14 +218,14 @@ dl_expandspec(filespec) else { /* Now find the actual file */ sts = sys$search(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$search = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", + ST(0) = sv_2mortal(newSVpvn(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } @@ -228,6 +236,7 @@ dl_load_file(filespec, flags) char * filespec int flags PREINIT: + dTHX; char vmsspec[NAM$C_MAXRSS]; SV *reqSV, **reqSVhndl; STRLEN deflen; @@ -244,16 +253,16 @@ dl_load_file(filespec, flags) void (*entry)(); CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filespec,flags)); specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tVMS-ified filespec is %s\n", specdsc.dsc$a_pointer)); New(1399,dlptr,1,struct libref); dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; sts = sys$filescan(&specdsc,namlst,0); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; @@ -269,21 +278,21 @@ dl_load_file(filespec, flags) memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlibref = name: %s, defspec: %.*s\n", dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n")); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t$dl_require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(dlptr->name),&symdsc, &entry,&(dlptr->defspec)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); @@ -298,7 +307,7 @@ dl_load_file(filespec, flags) ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSViv((IV) dlptr)); + ST(0) = sv_2mortal(newSViv(PTR2IV(dlptr))); } @@ -313,19 +322,19 @@ dl_find_symbol(librefptr,symname) void (*entry)(); vmssts sts; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n", + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_find_dymbol(%.*s,%.*s):\n", thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, symdsc.dsc$w_length,symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(thislib.name),&symdsc, &entry,&(thislib.defspec)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { /* error message already saved by findsym_handler */ ST(0) = &PL_sv_undef; } - else ST(0) = sv_2mortal(newSViv((IV) entry)); + else ST(0) = sv_2mortal(newSViv(PTR2IV(entry))); void @@ -341,9 +350,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/contrib/perl5/ext/DynaLoader/dlutils.c b/contrib/perl5/ext/DynaLoader/dlutils.c index bfa1f78..9d88f5f 100644 --- a/contrib/perl5/ext/DynaLoader/dlutils.c +++ b/contrib/perl5/ext/DynaLoader/dlutils.c @@ -3,6 +3,9 @@ * Currently this file is simply #included into dl_*.xs/.c files. * It should really be split into a dlutils.h and dlutils.c * + * Modified: + * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd + * files when the interpreter exits */ @@ -18,46 +21,77 @@ static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ #ifdef DEBUGGING -static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +static int dl_debug = 0; /* value copied from $DynaLoader::dl_debug */ #define DLDEBUG(level,code) if (dl_debug>=level) { code; } #else #define DLDEBUG(level,code) #endif +/* Close all dlopen'd files */ static void -dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */ +dl_unload_all_files(pTHXo_ void *unused) +{ + CV *sub; + AV *dl_librefs; + SV *dl_libref; + + if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) { + dl_librefs = get_av("DynaLoader::dl_librefs", FALSE); + while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(dl_libref)); + PUTBACK; + call_sv((SV*)sub, G_DISCARD | G_NODEBUG); + FREETMPS; + LEAVE; + } + } +} + + +static void +dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */ { char *perl_dl_nonlazy; #ifdef DEBUGGING - dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); + SV *sv = get_sv("DynaLoader::dl_debug", 0); + dl_debug = sv ? SvIV(sv) : 0; #endif if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); if (dl_nonlazy) - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); #ifdef DL_LOADONCEONLY if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ #endif +#ifdef DL_UNLOAD_ALL_AT_EXIT + call_atexit(&dl_unload_all_files, (void*)0); +#endif } /* SaveError() takes printf style args and saves the result in LastError */ static void -SaveError(CPERLarg_ char* pat, ...) +SaveError(pTHXo_ char* pat, ...) { va_list args; + SV *msv; char *message; - int len; + STRLEN len; /* This code is based on croak/warn, see mess() in util.c */ va_start(args, pat); - message = mess(pat, &args); + msv = vmess(pat, &args); va_end(args); - len = strlen(message) + 1 ; /* include terminating null char */ + message = SvPV(msv,len); + len++; /* include terminating null char */ /* Allocate some memory for the error message */ if (LastError) @@ -67,6 +101,6 @@ SaveError(CPERLarg_ char* pat, ...) /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",LastError)); } diff --git a/contrib/perl5/ext/DynaLoader/hints/aix.pl b/contrib/perl5/ext/DynaLoader/hints/aix.pl new file mode 100644 index 0000000..7dde941 --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/aix.pl @@ -0,0 +1,10 @@ +# See dl_aix.xs for details. +use Config; +if ($Config{libs} =~ /-lC/ && -f '/lib/libC.a') { + $self->{CCFLAGS} = $Config{ccflags} . ' -DUSE_libC'; + if (-f '/usr/ibmcxx/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_ibmcxx_load_h'; + } elsif (-f '/usr/lpp/xlC/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_xlC_load_h'; + } +} diff --git a/contrib/perl5/ext/DynaLoader/hints/linux.pl b/contrib/perl5/ext/DynaLoader/hints/linux.pl new file mode 100644 index 0000000..06f4f4c --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/linux.pl @@ -0,0 +1,4 @@ +# XXX Configure test needed. +# Some Linux releases like to hide their <nlist.h> +$self->{CCFLAGS} = $Config{ccflags} . ' -I/usr/include/libelf' + if -f "/usr/include/libelf/nlist.h"; diff --git a/contrib/perl5/ext/DynaLoader/hints/openbsd.pl b/contrib/perl5/ext/DynaLoader/hints/openbsd.pl new file mode 100644 index 0000000..aeaa92c --- /dev/null +++ b/contrib/perl5/ext/DynaLoader/hints/openbsd.pl @@ -0,0 +1,3 @@ +# XXX Configure test needed? +# Some OpenBSDs seem to have a dlopen() that won't accept relative paths +$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL index c1f26fc..df68dc3 100644 --- a/contrib/perl5/ext/Errno/Errno_pm.PL +++ b/contrib/perl5/ext/Errno/Errno_pm.PL @@ -180,8 +180,9 @@ use Exporter (); use Config; use strict; -\$Config{'myarchname'} eq "$Config{'myarchname'}" or - die "Errno architecture ($Config{'myarchname'}) does not match executable architecture (\$Config{'myarchname'})"; +"\$Config{'archname'}-\$Config{'osvers'}" eq +"$Config{'archname'}-$Config{'osvers'}" or + die "Errno architecture ($Config{'archname'}-$Config{'osvers'}) does not match executable architecture (\$Config{'archname'}-\$Config{'osvers'})"; \$VERSION = "$VERSION"; \@ISA = qw(Exporter); @@ -230,13 +231,14 @@ sub TIEHASH { bless [] } sub FETCH { my ($self, $errname) = @_; my $proto = prototype("Errno::$errname"); + my $errno = ""; if (defined($proto) && $proto eq "") { no strict 'refs'; - return $! == &$errname; + $errno = &$errname; + $errno = 0 unless $! == $errno; } - require Carp; - Carp::confess("No errno $errname"); -} + return $errno; +} sub STORE { require Carp; @@ -251,13 +253,12 @@ sub NEXTKEY { while(($k,$v) = each %Errno::) { my $proto = prototype("Errno::$k"); last if (defined($proto) && $proto eq ""); - } $k } sub FIRSTKEY { - my $s = scalar keys %Errno::; + my $s = scalar keys %Errno::; # initialize iterator goto &NEXTKEY; } @@ -286,11 +287,11 @@ C<Errno> defines and conditionally exports all the error constants defined in your system C<errno.h> include file. It has a single export tag, C<:POSIX>, which will export all POSIX defined error numbers. -C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero -value only if C<$!> is set to that value, eg +C<Errno> also makes C<%!> magic such that each element of C<%!> has a +non-zero value only if C<$!> is set to that value. For example: use Errno; - + unless (open(FH, "/fangorn/spouse")) { if ($!{ENOENT}) { warn "Get a wife!\n"; @@ -299,6 +300,20 @@ value only if C<$!> is set to that value, eg } } +If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}> +returns C<"">. You may use C<exists $!{EFOO}> to check whether the +constant is available on the system. + +=head1 CAVEATS + +Importing a particular constant may not be very portable, because the +import will fail on platforms that do not have that constant. A more +portable way to set C<$!> to a valid value is to use: + + if (exists &Errno::EFOO) { + $! = &Errno::EFOO; + } + =head1 AUTHOR Graham Barr <gbarr@pobox.com> diff --git a/contrib/perl5/ext/Fcntl/Fcntl.pm b/contrib/perl5/ext/Fcntl/Fcntl.pm index f1edb8e..92103a1 100644 --- a/contrib/perl5/ext/Fcntl/Fcntl.pm +++ b/contrib/perl5/ext/Fcntl/Fcntl.pm @@ -37,55 +37,99 @@ applications the newer versions of these constants are suggested (O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK, O_SYNC, O_TRUNC). -Please refer to your native fcntl() and open() documentation to see -what constants are implemented in your system. +For ease of use also the SEEK_* constants (for seek() and sysseek(), +e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are +available for import. They can be imported either separately or using +the tags C<:seek> and C<:mode>. + +Please refer to your native fcntl(2), open(2), fseek(3), lseek(2) +(equal to Perl's seek() and sysseek(), respectively), and chmod(2) +documentation to see what constants are implemented in your system. + +See L<perlopentut> to learn about the uses of the O_* constants +with sysopen(). + +See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants. + +See L<perlfunc/stat> about the S_I* constants. =cut -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD); require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); $VERSION = "1.03"; # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = qw( FD_CLOEXEC + F_ALLOCSP + F_ALLOCSP64 + F_COMPAT + F_DUP2FD F_DUPFD F_EXLCK + F_FREESP + F_FREESP64 + F_FSYNC + F_FSYNC64 F_GETFD F_GETFL F_GETLK + F_GETLK64 F_GETOWN + F_NODNY F_POSIX + F_RDACC + F_RDDNY F_RDLCK + F_RWACC + F_RWDNY F_SETFD F_SETFL F_SETLK + F_SETLK64 F_SETLKW + F_SETLKW64 F_SETOWN + F_SHARE F_SHLCK F_UNLCK + F_UNSHARE + F_WRACC + F_WRDNY F_WRLCK O_ACCMODE + O_ALIAS O_APPEND O_ASYNC O_BINARY O_CREAT O_DEFER + O_DIRECT + O_DIRECTORY O_DSYNC O_EXCL O_EXLOCK + O_LARGEFILE O_NDELAY O_NOCTTY + O_NOFOLLOW + O_NOINHERIT O_NONBLOCK + O_RANDOM + O_RAW O_RDONLY O_RDWR + O_RSRC O_RSYNC + O_SEQUENTIAL O_SHLOCK O_SYNC + O_TEMPORARY O_TEXT O_TRUNC O_WRONLY @@ -97,28 +141,69 @@ $VERSION = "1.03"; FASYNC FCREAT FDEFER + FDSYNC FEXCL + FLARGEFILE FNDELAY FNONBLOCK + FRSYNC FSYNC FTRUNC LOCK_EX LOCK_NB LOCK_SH LOCK_UN + S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IREAD S_IWRITE S_IEXEC + &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO + &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE + SEEK_SET + SEEK_CUR + SEEK_END ); # Named groups of exports %EXPORT_TAGS = ( 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], - 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FEXCL - FNDELAY FNONBLOCK FSYNC FTRUNC)], + 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE + FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)], + 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)], + 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IREAD S_IWRITE S_IEXEC + S_ISREG S_ISDIR S_ISLNK S_ISSOCK + S_ISBLK S_ISCHR S_ISFIFO + S_ISWHT S_ISENFMT + S_IFMT S_IMODE + )], ); +sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() } +sub S_IMODE { $_[0] & 07777 } + +sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() } +sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() } +sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() } +sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() } +sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() } +sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() } +sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() } +sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() } +sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } + sub AUTOLOAD { (my $constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -132,6 +217,6 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap Fcntl $VERSION; +XSLoader::load 'Fcntl', $VERSION; 1; diff --git a/contrib/perl5/ext/Fcntl/Fcntl.xs b/contrib/perl5/ext/Fcntl/Fcntl.xs index 5149444..b597e03 100644 --- a/contrib/perl5/ext/Fcntl/Fcntl.xs +++ b/contrib/perl5/ext/Fcntl/Fcntl.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -14,6 +15,10 @@ #endif #endif +#ifdef I_UNISTD +#include <unistd.h> +#endif + /* This comment is a kludge to get metaconfig to see the symbols VAL_O_NONBLOCK VAL_EAGAIN @@ -40,8 +45,40 @@ constant(char *name, int arg) { errno = 0; switch (*name) { + case '_': + if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ +#ifdef S_IFMT + return S_IFMT; +#else + goto not_there; +#endif + break; case 'F': if (strnEQ(name, "F_", 2)) { + if (strEQ(name, "F_ALLOCSP")) +#ifdef F_ALLOCSP + return F_ALLOCSP; +#else + goto not_there; +#endif + if (strEQ(name, "F_ALLOCSP64")) +#ifdef F_ALLOCSP64 + return F_ALLOCSP64; +#else + goto not_there; +#endif + if (strEQ(name, "F_COMPAT")) +#ifdef F_COMPAT + return F_COMPAT; +#else + goto not_there; +#endif + if (strEQ(name, "F_DUP2FD")) +#ifdef F_DUP2FD + return F_DUP2FD; +#else + goto not_there; +#endif if (strEQ(name, "F_DUPFD")) #ifdef F_DUPFD return F_DUPFD; @@ -54,6 +91,30 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_FREESP")) +#ifdef F_FREESP + return F_FREESP; +#else + goto not_there; +#endif + if (strEQ(name, "F_FREESP64")) +#ifdef F_FREESP64 + return F_FREESP64; +#else + goto not_there; +#endif + if (strEQ(name, "F_FSYNC")) +#ifdef F_FSYNC + return F_FSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "F_FSYNC64")) +#ifdef F_FSYNC64 + return F_FSYNC64; +#else + goto not_there; +#endif if (strEQ(name, "F_GETFD")) #ifdef F_GETFD return F_GETFD; @@ -72,24 +133,60 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_GETLK64")) +#ifdef F_GETLK64 + return F_GETLK64; +#else + goto not_there; +#endif if (strEQ(name, "F_GETOWN")) #ifdef F_GETOWN return F_GETOWN; #else goto not_there; #endif + if (strEQ(name, "F_NODNY")) +#ifdef F_NODNY + return F_NODNY; +#else + goto not_there; +#endif if (strEQ(name, "F_POSIX")) #ifdef F_POSIX return F_POSIX; #else goto not_there; #endif + if (strEQ(name, "F_RDACC")) +#ifdef F_RDACC + return F_RDACC; +#else + goto not_there; +#endif + if (strEQ(name, "F_RDDNY")) +#ifdef F_RDDNY + return F_RDDNY; +#else + goto not_there; +#endif if (strEQ(name, "F_RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif + if (strEQ(name, "F_RWACC")) +#ifdef F_RWACC + return F_RWACC; +#else + goto not_there; +#endif + if (strEQ(name, "F_RWDNY")) +#ifdef F_RWDNY + return F_RWDNY; +#else + goto not_there; +#endif if (strEQ(name, "F_SETFD")) #ifdef F_SETFD return F_SETFD; @@ -108,18 +205,36 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_SETLK64")) +#ifdef F_SETLK64 + return F_SETLK64; +#else + goto not_there; +#endif if (strEQ(name, "F_SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif + if (strEQ(name, "F_SETLKW64")) +#ifdef F_SETLKW64 + return F_SETLKW64; +#else + goto not_there; +#endif if (strEQ(name, "F_SETOWN")) #ifdef F_SETOWN return F_SETOWN; #else goto not_there; #endif + if (strEQ(name, "F_SHARE")) +#ifdef F_SHARE + return F_SHARE; +#else + goto not_there; +#endif if (strEQ(name, "F_SHLCK")) #ifdef F_SHLCK return F_SHLCK; @@ -132,6 +247,24 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_UNSHARE")) +#ifdef F_UNSHARE + return F_UNSHARE; +#else + goto not_there; +#endif + if (strEQ(name, "F_WRACC")) +#ifdef F_WRACC + return F_WRACC; +#else + goto not_there; +#endif + if (strEQ(name, "F_WRDNY")) +#ifdef F_WRDNY + return F_WRDNY; +#else + goto not_there; +#endif if (strEQ(name, "F_WRLCK")) #ifdef F_WRLCK return F_WRLCK; @@ -171,12 +304,24 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "FDSYNC")) +#ifdef FDSYNC + return FDSYNC; +#else + goto not_there; +#endif if (strEQ(name, "FEXCL")) #ifdef FEXCL return FEXCL; #else goto not_there; #endif + if (strEQ(name, "FLARGEFILE")) +#ifdef FLARGEFILE + return FLARGEFILE; +#else + goto not_there; +#endif if (strEQ(name, "FNDELAY")) #ifdef FNDELAY return FNDELAY; @@ -189,6 +334,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "FRSYNC")) +#ifdef FRSYNC + return FRSYNC; +#else + goto not_there; +#endif if (strEQ(name, "FSYNC")) #ifdef FSYNC return FSYNC; @@ -271,6 +422,18 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_DIRECT")) +#ifdef O_DIRECT + return O_DIRECT; +#else + goto not_there; +#endif + if (strEQ(name, "O_DIRECTORY")) +#ifdef O_DIRECTORY + return O_DIRECTORY; +#else + goto not_there; +#endif if (strEQ(name, "O_DSYNC")) #ifdef O_DSYNC return O_DSYNC; @@ -289,6 +452,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_LARGEFILE")) +#ifdef O_LARGEFILE + return O_LARGEFILE; +#else + goto not_there; +#endif if (strEQ(name, "O_NDELAY")) #ifdef O_NDELAY return O_NDELAY; @@ -301,12 +470,36 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_NOFOLLOW")) +#ifdef O_NOFOLLOW + return O_NOFOLLOW; +#else + goto not_there; +#endif + if (strEQ(name, "O_NOINHERIT")) +#ifdef O_NOINHERIT + return O_NOINHERIT; +#else + goto not_there; +#endif if (strEQ(name, "O_NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif + if (strEQ(name, "O_RANDOM")) +#ifdef O_RANDOM + return O_RANDOM; +#else + goto not_there; +#endif + if (strEQ(name, "O_RAW")) +#ifdef O_RAW + return O_RAW; +#else + goto not_there; +#endif if (strEQ(name, "O_RDONLY")) #ifdef O_RDONLY return O_RDONLY; @@ -325,6 +518,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_SEQUENTIAL")) +#ifdef O_SEQUENTIAL + return O_SEQUENTIAL; +#else + goto not_there; +#endif if (strEQ(name, "O_SHLOCK")) #ifdef O_SHLOCK return O_SHLOCK; @@ -337,6 +536,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_TEMPORARY")) +#ifdef O_TEMPORARY + return O_TEMPORARY; +#else + goto not_there; +#endif if (strEQ(name, "O_TEXT")) #ifdef O_TEXT return O_TEXT; @@ -355,9 +560,214 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_ALIAS")) +#ifdef O_ALIAS + return O_ALIAS; +#else + goto not_there; +#endif + if (strEQ(name, "O_RSRC")) +#ifdef O_RSRC + return O_RSRC; +#else + goto not_there; +#endif } else goto not_there; break; + case 'S': + switch (name[1]) { + case '_': + if (strEQ(name, "S_ISUID")) +#ifdef S_ISUID + return S_ISUID; +#else + goto not_there; +#endif + if (strEQ(name, "S_ISGID")) +#ifdef S_ISGID + return S_ISGID; +#else + goto not_there; +#endif + if (strEQ(name, "S_ISVTX")) +#ifdef S_ISVTX + return S_ISVTX; +#else + goto not_there; +#endif + if (strEQ(name, "S_ISTXT")) +#ifdef S_ISTXT + return S_ISTXT; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFREG")) +#ifdef S_IFREG + return S_IFREG; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFDIR")) +#ifdef S_IFDIR + return S_IFDIR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFLNK")) +#ifdef S_IFLNK + return S_IFLNK; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFSOCK")) +#ifdef S_IFSOCK + return S_IFSOCK; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFBLK")) +#ifdef S_IFBLK + return S_IFBLK; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFCHR")) +#ifdef S_IFCHR + return S_IFCHR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFIFO")) +#ifdef S_IFIFO + return S_IFIFO; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFWHT")) +#ifdef S_IFWHT + return S_IFWHT; +#else + goto not_there; +#endif + if (strEQ(name, "S_ENFMT")) +#ifdef S_ENFMT + return S_ENFMT; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRUSR")) +#ifdef S_IRUSR + return S_IRUSR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWUSR")) +#ifdef S_IWUSR + return S_IWUSR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IXUSR")) +#ifdef S_IXUSR + return S_IXUSR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRWXU")) +#ifdef S_IRWXU + return S_IRWXU; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRGRP")) +#ifdef S_IRGRP + return S_IRGRP; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWGRP")) +#ifdef S_IWGRP + return S_IWGRP; +#else + goto not_there; +#endif + if (strEQ(name, "S_IXGRP")) +#ifdef S_IXGRP + return S_IXGRP; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRWXG")) +#ifdef S_IRWXG + return S_IRWXG; +#else + goto not_there; +#endif + if (strEQ(name, "S_IROTH")) +#ifdef S_IROTH + return S_IROTH; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWOTH")) +#ifdef S_IWOTH + return S_IWOTH; +#else + goto not_there; +#endif + if (strEQ(name, "S_IXOTH")) +#ifdef S_IXOTH + return S_IXOTH; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRWXO")) +#ifdef S_IRWXO + return S_IRWXO; +#else + goto not_there; +#endif + if (strEQ(name, "S_IREAD")) +#ifdef S_IREAD + return S_IREAD; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWRITE")) +#ifdef S_IWRITE + return S_IWRITE; +#else + goto not_there; +#endif + if (strEQ(name, "S_IEXEC")) +#ifdef S_IEXEC + return S_IEXEC; +#else + goto not_there; +#endif + break; + case 'E': + if (strEQ(name, "SEEK_CUR")) +#ifdef SEEK_CUR + return SEEK_CUR; +#else + return 1; +#endif + if (strEQ(name, "SEEK_END")) +#ifdef SEEK_END + return SEEK_END; +#else + return 2; +#endif + if (strEQ(name, "SEEK_SET")) +#ifdef SEEK_SET + return SEEK_SET; +#else + return 0; +#endif + break; + } } errno = EINVAL; return 0; diff --git a/contrib/perl5/ext/File/Glob/Changes b/contrib/perl5/ext/File/Glob/Changes new file mode 100644 index 0000000..e246c6d --- /dev/null +++ b/contrib/perl5/ext/File/Glob/Changes @@ -0,0 +1,47 @@ +Revision history for Perl extension File::Glob + +0.00 Tue Dec 17 10:51:33 1996 + - original version; created by h2xs 1.16 + +0.90 Tue Dec 17 13:58:32 MST 1996 + - implemented first pass access to glob(3), + but it's clumsy and it looks like it leaks + memory. + +0.91 Thu Sep 4 08:43:55 CDT 1997 + - included CORE/config.h portability macros + - s/glob/bsd_glob/ to avoid calling and including the + system's glob stuff + - added GLOB_DEBUG for (surprise!) glob debugging + - tainted all filenames returned from &Glob::BSD::glob + +0.92 Tue Sep 30 08:31:57 CDT 1997 + - only use lstat if HAS_LSTAT is defined + - renamed the glob flags to GLOB_* + - added GLOB_CSH convenience macro for csh(1) globbing + These changes thanks to Hans Mulder <hansm@icgned.nl> + - fixed an incompatibility with csh(1) globbing where a + pattern like {A*,b,c} wouldn't expand properly + - various compatibility changes + - fixed and added tests + +0.93 Wed Jul 1 10:39:47 CDT 1998 + - renamed module to File::BSDGlob + - enabled 'globally' import directive to override the core + glob + - added Sarathy's tests for File::DosGlob +0.99 Tue Oct 12 06:42:02 PDT 1999 + - renamed module to File::Glob for incorporation into the + Perl source distribution + - ansified prototypes + - s/struct stat/Stat_t/ + - split on spaces to make <*.c *.h> work (for compatibility) +0.991 Tue Oct 26 09:48:00 BST 1999 + - Add case-insensitive matching (GLOB_NOCASE) + - Make glob_csh case insensitive by default on Win32, VMS, + OS/2, DOS, RISC OS, and Mac OS + - Add support for :case and :nocase tags + - Hack to make patterns like C:* work on DOSISH systems + - Add support for either \ or / as separators on DOSISH systems + - Limit effect of \ as a quoting operator on DOSISH systems to + when it precedes one of []{}-~\ (to minimise backslashitis). diff --git a/contrib/perl5/ext/File/Glob/Glob.pm b/contrib/perl5/ext/File/Glob/Glob.pm new file mode 100644 index 0000000..4b7e54b --- /dev/null +++ b/contrib/perl5/ext/File/Glob/Glob.pm @@ -0,0 +1,378 @@ +package File::Glob; + +use strict; +use Carp; +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, + $AUTOLOAD, $DEFAULT_FLAGS); + +require Exporter; +use XSLoader (); +require AutoLoader; + +@ISA = qw(Exporter AutoLoader); + +@EXPORT_OK = qw( + csh_glob + glob + GLOB_ABEND + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE +); + +%EXPORT_TAGS = ( + 'glob' => [ qw( + GLOB_ABEND + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE + glob + ) ], +); + +$VERSION = '0.991'; + +sub import { + my $i = 1; + while ($i < @_) { + if ($_[$i] =~ /^:(case|nocase|globally)$/) { + splice(@_, $i, 1); + $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; + $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; + if ($1 eq 'globally') { + no warnings; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; + } + next; + } + ++$i; + } + goto &Exporter::import; +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined File::Glob macro $constname"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +XSLoader::load 'File::Glob', $VERSION; + +# Preloaded methods go here. + +sub GLOB_ERROR { + return constant('GLOB_ERROR', 0); +} + +sub GLOB_CSH () { GLOB_BRACE() | GLOB_NOMAGIC() | GLOB_QUOTE() | GLOB_TILDE() } + +$DEFAULT_FLAGS = GLOB_CSH(); +if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { + $DEFAULT_FLAGS |= GLOB_NOCASE(); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +sub glob { + my ($pat,$flags) = @_; + $flags = $DEFAULT_FLAGS if @_ < 2; + return doglob($pat,$flags); +} + +## borrowed heavily from gsar's File::DosGlob +my %iter; +my %entries; + +sub csh_glob { + my $pat = shift; + my $cxix = shift; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + if ($pat =~ /\s/) { + # XXX this is needed for compatibility with the csh + # implementation in Perl. Need to support a flag + # to disable this behavior. + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + if (@pat) { + $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; + } + else { + $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; + } + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +1; +__END__ + +=head1 NAME + +File::Glob - Perl extension for BSD glob routine + +=head1 SYNOPSIS + + use File::Glob ':glob'; + @list = glob('*.[ch]'); + $homedir = glob('~gnat', GLOB_TILDE | GLOB_ERR); + if (GLOB_ERROR) { + # an error occurred reading $homedir + } + + ## override the core glob (core glob() does this automatically + ## by default anyway, since v5.6.0) + use File::Glob ':globally'; + my @sources = <*.{c,h,y}> + + ## override the core glob, forcing case sensitivity + use File::Glob qw(:globally :case); + my @sources = <*.{c,h,y}> + + ## override the core glob forcing case insensitivity + use File::Glob qw(:globally :nocase); + my @sources = <*.{c,h,y}> + +=head1 DESCRIPTION + +File::Glob implements the FreeBSD glob(3) routine, which is a superset +of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). The +glob() routine takes a mandatory C<pattern> argument, and an optional +C<flags> argument, and returns a list of filenames matching the +pattern, with interpretation of the pattern modified by the C<flags> +variable. The POSIX defined flags are: + +=over 4 + +=item C<GLOB_ERR> + +Force glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily glob() continues to find matches. + +=item C<GLOB_MARK> + +Each pathname that is a directory that matches the pattern has a slash +appended. + +=item C<GLOB_NOCASE> + +By default, file names are assumed to be case sensitive; this flag +makes glob() treat case differences as not significant. + +=item C<GLOB_NOCHECK> + +If the pattern does not match any pathname, then glob() returns a list +consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect +is present in the pattern returned. + +=item C<GLOB_NOSORT> + +By default, the pathnames are sorted in ascending ASCII order; this +flag prevents that sorting (speeding up glob()). + +=back + +The FreeBSD extensions to the POSIX standard are the following flags: + +=over 4 + +=item C<GLOB_BRACE> + +Pre-process the string to expand C<{pat,pat,...}> strings like csh(1). +The pattern '{}' is left unexpanded for historical reasons (and csh(1) +does the same thing to ease typing of find(1) patterns). + +=item C<GLOB_NOMAGIC> + +Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not +contain any of the special characters "*", "?" or "[". C<NOMAGIC> is +provided to simplify implementing the historic csh(1) globbing +behaviour and should probably not be used anywhere else. + +=item C<GLOB_QUOTE> + +Use the backslash ('\') character for quoting: every occurrence of a +backslash followed by a character in the pattern is replaced by that +character, avoiding any special interpretation of the character. +(But see below for exceptions on DOSISH systems). + +=item C<GLOB_TILDE> + +Expand patterns that start with '~' to user name home directories. + +=item C<GLOB_CSH> + +For convenience, C<GLOB_CSH> is a synonym for +C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE>. + +=back + +The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD +extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been +implemented in the Perl version because they involve more complex +interaction with the underlying C structures. + +=head1 DIAGNOSTICS + +glob() returns a list of matching paths, possibly zero length. If an +error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be +set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, +or one of the following values otherwise: + +=over 4 + +=item C<GLOB_NOSPACE> + +An attempt to allocate memory failed. + +=item C<GLOB_ABEND> + +The glob was stopped because an error was encountered. + +=back + +In the case where glob() has found some matching paths, but is +interrupted by an error, glob() will return a list of filenames B<and> +set &File::Glob::ERROR. + +Note that glob() deviates from POSIX and FreeBSD glob(3) behaviour by +not considering C<ENOENT> and C<ENOTDIR> as errors - glob() will +continue processing despite those errors, unless the C<GLOB_ERR> flag is +set. + +Be aware that all filenames returned from File::Glob are tainted. + +=head1 NOTES + +=over 4 + +=item * + +If you want to use multiple patterns, e.g. C<glob "a* b*">, you should +probably throw them in a set as in C<glob "{a*,b*}>. This is because +the argument to glob isn't subjected to parsing by the C shell. Remember +that you can use a backslash to escape things. + +=item * + +On DOSISH systems, backslash is a valid directory separator character. +In this case, use of backslash as a quoting character (via GLOB_QUOTE) +interferes with the use of backslash as a directory separator. The +best (simplest, most portable) solution is to use forward slashes for +directory separators, and backslashes for quoting. However, this does +not match "normal practice" on these systems. As a concession to user +expectation, therefore, backslashes (under GLOB_QUOTE) only quote the +glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. +All other backslashes are passed through unchanged. + +=item * + +Win32 users should use the real slash. If you really want to use +backslashes, consider using Sarathy's File::DosGlob, which comes with +the standard Perl distribution. + +=back + +=head1 AUTHOR + +The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>, +and is released under the artistic license. Further modifications were +made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt> and Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>. The C glob code has the +following copyright: + + Copyright (c) 1989, 1993 The Regents of the University of California. + All rights reserved. + + This code is derived from software contributed to Berkeley by + Guido van Rossum. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +=cut diff --git a/contrib/perl5/ext/File/Glob/Glob.xs b/contrib/perl5/ext/File/Glob/Glob.xs new file mode 100644 index 0000000..e01ae7e --- /dev/null +++ b/contrib/perl5/ext/File/Glob/Glob.xs @@ -0,0 +1,209 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "bsd_glob.h" + +static int GLOB_ERROR = 0; + +static int +not_here(char *s) +{ + croak("%s not implemented on this architecture", s); + return -1; +} + + +static double +constant(char *name, int arg) +{ + errno = 0; + if (strlen(name) <= 5) + goto not_there; + switch (*(name+5)) { + case 'A': + if (strEQ(name, "GLOB_ABEND")) +#ifdef GLOB_ABEND + return GLOB_ABEND; +#else + goto not_there; +#endif + if (strEQ(name, "GLOB_ALTDIRFUNC")) +#ifdef GLOB_ALTDIRFUNC + return GLOB_ALTDIRFUNC; +#else + goto not_there; +#endif + break; + case 'B': + if (strEQ(name, "GLOB_BRACE")) +#ifdef GLOB_BRACE + return GLOB_BRACE; +#else + goto not_there; +#endif + break; + case 'C': + break; + case 'D': + break; + case 'E': + if (strEQ(name, "GLOB_ERR")) +#ifdef GLOB_ERR + return GLOB_ERR; +#else + goto not_there; +#endif + if (strEQ(name, "GLOB_ERROR")) + return GLOB_ERROR; + break; + case 'F': + break; + case 'G': + break; + case 'H': + break; + case 'I': + break; + case 'J': + break; + case 'K': + break; + case 'L': + break; + case 'M': + if (strEQ(name, "GLOB_MARK")) +#ifdef GLOB_MARK + return GLOB_MARK; +#else + goto not_there; +#endif + break; + case 'N': + if (strEQ(name, "GLOB_NOCASE")) +#ifdef GLOB_NOCASE + return GLOB_NOCASE; +#else + goto not_there; +#endif + if (strEQ(name, "GLOB_NOCHECK")) +#ifdef GLOB_NOCHECK + return GLOB_NOCHECK; +#else + goto not_there; +#endif + if (strEQ(name, "GLOB_NOMAGIC")) +#ifdef GLOB_NOMAGIC + return GLOB_NOMAGIC; +#else + goto not_there; +#endif + if (strEQ(name, "GLOB_NOSORT")) +#ifdef GLOB_NOSORT + return GLOB_NOSORT; +#else + goto not_there; +#endif + if (strEQ(name, "GLOB_NOSPACE")) +#ifdef GLOB_NOSPACE + return GLOB_NOSPACE; +#else + goto not_there; +#endif + break; + case 'O': + break; + case 'P': + break; + case 'Q': + if (strEQ(name, "GLOB_QUOTE")) +#ifdef GLOB_QUOTE + return GLOB_QUOTE; +#else + goto not_there; +#endif + break; + case 'R': + break; + case 'S': + break; + case 'T': + if (strEQ(name, "GLOB_TILDE")) +#ifdef GLOB_TILDE + return GLOB_TILDE; +#else + goto not_there; +#endif + break; + case 'U': + break; + case 'V': + break; + case 'W': + break; + case 'X': + break; + case 'Y': + break; + case 'Z': + break; + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +#ifdef WIN32 +#define errfunc NULL +#else +int +errfunc(const char *foo, int bar) { + return !(bar == ENOENT || bar == ENOTDIR); +} +#endif + +MODULE = File::Glob PACKAGE = File::Glob + +void +doglob(pattern,...) + char *pattern +PROTOTYPE: $;$ +PREINIT: + glob_t pglob; + int i; + int retval; + int flags = 0; + SV *tmp; +PPCODE: + { + /* allow for optional flags argument */ + if (items > 1) { + flags = (int) SvIV(ST(1)); + } + + /* call glob */ + retval = bsd_glob(pattern, flags, errfunc, &pglob); + GLOB_ERROR = retval; + + /* return any matches found */ + EXTEND(sp, pglob.gl_pathc); + for (i = 0; i < pglob.gl_pathc; i++) { + /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */ + tmp = sv_2mortal(newSVpvn(pglob.gl_pathv[i], + strlen(pglob.gl_pathv[i]))); + TAINT; + SvTAINT(tmp); + PUSHs(tmp); + } + + bsd_globfree(&pglob); + } + +double +constant(name,arg) + char *name + int arg +PROTOTYPE: $$ diff --git a/contrib/perl5/ext/File/Glob/Makefile.PL b/contrib/perl5/ext/File/Glob/Makefile.PL new file mode 100644 index 0000000..98781c9 --- /dev/null +++ b/contrib/perl5/ext/File/Glob/Makefile.PL @@ -0,0 +1,21 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'File::Glob', + VERSION_FROM => 'Glob.pm', + MAN3PODS => {}, # Pods will be built by installman. + OBJECT => 'bsd_glob$(OBJ_EXT) Glob$(OBJ_EXT)', + +## uncomment for glob debugging (will cause make test to fail) +# DEFINE => '-DGLOB_DEBUG', +# OPTIMIZE => '-g', +); +use Config; +sub MY::cflags { + package MY; + my $inherited = shift->SUPER::cflags(@_); + if ($Config::Config{archname} =~ /^aix/ and + $Config::Config{use64bitall} eq 'define') { + $inherited =~ s/\s-O\d?//m; + } + $inherited; +} diff --git a/contrib/perl5/ext/File/Glob/TODO b/contrib/perl5/ext/File/Glob/TODO new file mode 100644 index 0000000..ef2547f --- /dev/null +++ b/contrib/perl5/ext/File/Glob/TODO @@ -0,0 +1,21 @@ +Some issues left to take care of: + + o sane ~ handling on non-Unix platforms + + Currently on non-Unix, when the glob code encounters a tilde glob + (.e.g ~user/foo or ~/.cshrc), it simply returns that pattern + without doing any expansion (meaning perl will weed it out since a + file of that name isn't likely to exist). + + Please, if you have strong feelings about how tilde expansion + should be done on your favorite non-Unix platform(s), submit a + patch. + + o path separator handling + + Guido's code contains the assumption that the path separator is one + character (byte, probably) in length. Win32 doesn't object to the + true slash as a separator. I imagine MacPerl could change the SEP + cpp #define to ":". I have no idea what it is for VMS. Again, if + you have ideas and especially patches, please feel free to share + them. diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.c b/contrib/perl5/ext/File/Glob/bsd_glob.c new file mode 100644 index 0000000..62bfe4f --- /dev/null +++ b/contrib/perl5/ext/File/Glob/bsd_glob.c @@ -0,0 +1,945 @@ +/* + * Copyright (c) 1989, 1993 + * The Regents of the University of California. All rights reserved. + * + * This code is derived from software contributed to Berkeley by + * Guido van Rossum. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + */ + +#if defined(LIBC_SCCS) && !defined(lint) +static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; +#endif /* LIBC_SCCS and not lint */ + +/* + * glob(3) -- a superset of the one defined in POSIX 1003.2. + * + * The [!...] convention to negate a range is supported (SysV, Posix, ksh). + * + * Optional extra services, controlled by flags not defined by POSIX: + * + * GLOB_QUOTE: + * Escaping convention: \ inhibits any special meaning the following + * character might have (except \ at end of string is retained). + * GLOB_MAGCHAR: + * Set in gl_flags if pattern contained a globbing character. + * GLOB_NOMAGIC: + * Same as GLOB_NOCHECK, but it will only append pattern if it did + * not contain any magic characters. [Used in csh style globbing] + * GLOB_ALTDIRFUNC: + * Use alternately specified directory access functions. + * GLOB_TILDE: + * expand ~user/foo to the /home/dir/of/user/foo + * GLOB_BRACE: + * expand {1,2}{a,b} to 1a 1b 2a 2b + * gl_matchc: + * Number of matches in the current invocation of glob. + */ + +#include <EXTERN.h> +#include <perl.h> +#include <XSUB.h> + +#include "bsd_glob.h" +#ifdef I_PWD +# include <pwd.h> +#else +#ifdef HAS_PASSWD + struct passwd *getpwnam(char *); + struct passwd *getpwuid(Uid_t); +#endif +#endif + +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN 1024 +# endif +#endif + +#define BG_DOLLAR '$' +#define BG_DOT '.' +#define BG_EOS '\0' +#define BG_LBRACKET '[' +#define BG_NOT '!' +#define BG_QUESTION '?' +#define BG_QUOTE '\\' +#define BG_RANGE '-' +#define BG_RBRACKET ']' +#define BG_SEP '/' +#ifdef DOSISH +#define BG_SEP2 '\\' +#endif +#define BG_STAR '*' +#define BG_TILDE '~' +#define BG_UNDERSCORE '_' +#define BG_LBRACE '{' +#define BG_RBRACE '}' +#define BG_SLASH '/' +#define BG_COMMA ',' + +#ifndef GLOB_DEBUG + +#define M_QUOTE 0x8000 +#define M_PROTECT 0x4000 +#define M_MASK 0xffff +#define M_ASCII 0x00ff + +typedef U16 Char; + +#else + +#define M_QUOTE 0x80 +#define M_PROTECT 0x40 +#define M_MASK 0xff +#define M_ASCII 0x7f + +typedef U8 Char; + +#endif /* !GLOB_DEBUG */ + + +#define CHAR(c) ((Char)((c)&M_ASCII)) +#define META(c) ((Char)((c)|M_QUOTE)) +#define M_ALL META('*') +#define M_END META(']') +#define M_NOT META('!') +#define M_ONE META('?') +#define M_RNG META('-') +#define M_SET META('[') +#define ismeta(c) (((c)&M_QUOTE) != 0) + + +static int compare(const void *, const void *); +static int ci_compare(const void *, const void *); +static void g_Ctoc(const Char *, char *); +static int g_lstat(Char *, Stat_t *, glob_t *); +static DIR *g_opendir(Char *, glob_t *); +static Char *g_strchr(Char *, int); +#ifdef notdef +static Char *g_strcat(Char *, const Char *); +#endif +static int g_stat(Char *, Stat_t *, glob_t *); +static int glob0(const Char *, glob_t *); +static int glob1(Char *, glob_t *); +static int glob2(Char *, Char *, Char *, glob_t *); +static int glob3(Char *, Char *, Char *, Char *, glob_t *); +static int globextend(const Char *, glob_t *); +static const Char * globtilde(const Char *, Char *, glob_t *); +static int globexp1(const Char *, glob_t *); +static int globexp2(const Char *, const Char *, glob_t *, int *); +static int match(Char *, Char *, Char *, int); +#ifdef GLOB_DEBUG +static void qprintf(const char *, Char *); +#endif /* GLOB_DEBUG */ + +#ifdef PERL_IMPLICIT_CONTEXT +static Direntry_t * my_readdir(DIR*); + +static Direntry_t * +my_readdir(DIR *d) +{ + return PerlDir_read(d); +} +#else +#define my_readdir readdir +#endif + +int +bsd_glob(const char *pattern, int flags, + int (*errfunc)(const char *, int), glob_t *pglob) +{ + const U8 *patnext; + int c; + Char *bufnext, *bufend, patbuf[MAXPATHLEN+1]; + + patnext = (U8 *) pattern; + if (!(flags & GLOB_APPEND)) { + pglob->gl_pathc = 0; + pglob->gl_pathv = NULL; + if (!(flags & GLOB_DOOFFS)) + pglob->gl_offs = 0; + } + pglob->gl_flags = flags & ~GLOB_MAGCHAR; + pglob->gl_errfunc = errfunc; + pglob->gl_matchc = 0; + + bufnext = patbuf; + bufend = bufnext + MAXPATHLEN; +#ifdef DOSISH + /* Nasty hack to treat patterns like "C:*" correctly. In this + * case, the * should match any file in the current directory + * on the C: drive. However, the glob code does not treat the + * colon specially, so it looks for files beginning "C:" in + * the current directory. To fix this, change the pattern to + * add an explicit "./" at the start (just after the drive + * letter and colon - ie change to "C:./*"). + */ + if (isalpha(pattern[0]) && pattern[1] == ':' && + pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && + bufend - bufnext > 4) { + *bufnext++ = pattern[0]; + *bufnext++ = ':'; + *bufnext++ = '.'; + *bufnext++ = BG_SEP; + patnext += 2; + } +#endif + if (flags & GLOB_QUOTE) { + /* Protect the quoted characters. */ + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + if (c == BG_QUOTE) { +#ifdef DOSISH + /* To avoid backslashitis on Win32, + * we only treat \ as a quoting character + * if it precedes one of the + * metacharacters []-{}~\ + */ + if ((c = *patnext++) != '[' && c != ']' && + c != '-' && c != '{' && c != '}' && + c != '~' && c != '\\') { +#else + if ((c = *patnext++) == BG_EOS) { +#endif + c = BG_QUOTE; + --patnext; + } + *bufnext++ = c | M_PROTECT; + } + else + *bufnext++ = c; + } + else + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + *bufnext++ = c; + *bufnext = BG_EOS; + + if (flags & GLOB_BRACE) + return globexp1(patbuf, pglob); + else + return glob0(patbuf, pglob); +} + +/* + * Expand recursively a glob {} pattern. When there is no more expansion + * invoke the standard globbing routine to glob the rest of the magic + * characters + */ +static int globexp1(const Char *pattern, glob_t *pglob) +{ + const Char* ptr = pattern; + int rv; + + /* Protect a single {}, for find(1), like csh */ + if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) + return glob0(pattern, pglob); + + while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) + if (!globexp2(ptr, pattern, pglob, &rv)) + return rv; + + return glob0(pattern, pglob); +} + + +/* + * Recursive brace globbing helper. Tries to expand a single brace. + * If it succeeds then it invokes globexp1 with the new pattern. + * If it fails then it tries to glob the rest of the pattern and returns. + */ +static int globexp2(const Char *ptr, const Char *pattern, + glob_t *pglob, int *rv) +{ + int i; + Char *lm, *ls; + const Char *pe, *pm, *pl; + Char patbuf[MAXPATHLEN + 1]; + + /* copy part up to the brace */ + for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++) + continue; + ls = lm; + + /* Find the balanced brace */ + for (i = 0, pe = ++ptr; *pe; pe++) + if (*pe == BG_LBRACKET) { + /* Ignore everything between [] */ + for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) + continue; + if (*pe == BG_EOS) { + /* + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE + */ + pe = pm; + } + } + else if (*pe == BG_LBRACE) + i++; + else if (*pe == BG_RBRACE) { + if (i == 0) + break; + i--; + } + + /* Non matching braces; just glob the pattern */ + if (i != 0 || *pe == BG_EOS) { + *rv = glob0(patbuf, pglob); + return 0; + } + + for (i = 0, pl = pm = ptr; pm <= pe; pm++) + switch (*pm) { + case BG_LBRACKET: + /* Ignore everything between [] */ + for (pl = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) + continue; + if (*pm == BG_EOS) { + /* + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE + */ + pm = pl; + } + break; + + case BG_LBRACE: + i++; + break; + + case BG_RBRACE: + if (i) { + i--; + break; + } + /* FALLTHROUGH */ + case BG_COMMA: + if (i && *pm == BG_COMMA) + break; + else { + /* Append the current string */ + for (lm = ls; (pl < pm); *lm++ = *pl++) + continue; + /* + * Append the rest of the pattern after the + * closing brace + */ + for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS;) + continue; + + /* Expand the current pattern */ +#ifdef GLOB_DEBUG + qprintf("globexp2:", patbuf); +#endif /* GLOB_DEBUG */ + *rv = globexp1(patbuf, pglob); + + /* move after the comma, to the next string */ + pl = pm + 1; + } + break; + + default: + break; + } + *rv = 0; + return 0; +} + + + +/* + * expand tilde from the passwd file. + */ +static const Char * +globtilde(const Char *pattern, Char *patbuf, glob_t *pglob) +{ + struct passwd *pwd; + char *h; + const Char *p; + Char *b; + + if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) + return pattern; + + /* Copy up to the end of the string or / */ + for (p = pattern + 1, h = (char *) patbuf; *p && *p != BG_SLASH; + *h++ = *p++) + continue; + + *h = BG_EOS; + + if (((char *) patbuf)[0] == BG_EOS) { + /* + * handle a plain ~ or ~/ by expanding $HOME + * first and then trying the password file + */ + if ((h = getenv("HOME")) == NULL) { +#ifdef HAS_PASSWD + if ((pwd = getpwuid(getuid())) == NULL) + return pattern; + else + h = pwd->pw_dir; +#else + return pattern; +#endif + } + } + else { + /* + * Expand a ~user + */ +#ifdef HAS_PASSWD + if ((pwd = getpwnam((char*) patbuf)) == NULL) + return pattern; + else + h = pwd->pw_dir; +#else + return pattern; +#endif + } + + /* Copy the home directory */ + for (b = patbuf; *h; *b++ = *h++) + continue; + + /* Append the rest of the pattern */ + while ((*b++ = *p++) != BG_EOS) + continue; + + return patbuf; +} + + +/* + * The main glob() routine: compiles the pattern (optionally processing + * quotes), calls glob1() to do the real pattern matching, and finally + * sorts the list (unless unsorted operation is requested). Returns 0 + * if things went well, nonzero if errors occurred. It is not an error + * to find no matches. + */ +static int +glob0(const Char *pattern, glob_t *pglob) +{ + const Char *qpat, *qpatnext; + int c, err, oldflags, oldpathc; + Char *bufnext, patbuf[MAXPATHLEN+1]; + + qpat = globtilde(pattern, patbuf, pglob); + qpatnext = qpat; + oldflags = pglob->gl_flags; + oldpathc = pglob->gl_pathc; + bufnext = patbuf; + + /* We don't need to check for buffer overflow any more. */ + while ((c = *qpatnext++) != BG_EOS) { + switch (c) { + case BG_LBRACKET: + c = *qpatnext; + if (c == BG_NOT) + ++qpatnext; + if (*qpatnext == BG_EOS || + g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { + *bufnext++ = BG_LBRACKET; + if (c == BG_NOT) + --qpatnext; + break; + } + *bufnext++ = M_SET; + if (c == BG_NOT) + *bufnext++ = M_NOT; + c = *qpatnext++; + do { + *bufnext++ = CHAR(c); + if (*qpatnext == BG_RANGE && + (c = qpatnext[1]) != BG_RBRACKET) { + *bufnext++ = M_RNG; + *bufnext++ = CHAR(c); + qpatnext += 2; + } + } while ((c = *qpatnext++) != BG_RBRACKET); + pglob->gl_flags |= GLOB_MAGCHAR; + *bufnext++ = M_END; + break; + case BG_QUESTION: + pglob->gl_flags |= GLOB_MAGCHAR; + *bufnext++ = M_ONE; + break; + case BG_STAR: + pglob->gl_flags |= GLOB_MAGCHAR; + /* collapse adjacent stars to one, + * to avoid exponential behavior + */ + if (bufnext == patbuf || bufnext[-1] != M_ALL) + *bufnext++ = M_ALL; + break; + default: + *bufnext++ = CHAR(c); + break; + } + } + *bufnext = BG_EOS; +#ifdef GLOB_DEBUG + qprintf("glob0:", patbuf); +#endif /* GLOB_DEBUG */ + + if ((err = glob1(patbuf, pglob)) != 0) { + pglob->gl_flags = oldflags; + return(err); + } + + /* + * If there was no match we are going to append the pattern + * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified + * and the pattern did not contain any magic characters + * GLOB_NOMAGIC is there just for compatibility with csh. + */ + if (pglob->gl_pathc == oldpathc && + ((pglob->gl_flags & GLOB_NOCHECK) || + ((pglob->gl_flags & GLOB_NOMAGIC) && + !(pglob->gl_flags & GLOB_MAGCHAR)))) + { +#ifdef GLOB_DEBUG + printf("calling globextend from glob0\n"); +#endif /* GLOB_DEBUG */ + pglob->gl_flags = oldflags; + return(globextend(qpat, pglob)); + } + else if (!(pglob->gl_flags & GLOB_NOSORT)) + qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, + pglob->gl_pathc - oldpathc, sizeof(char *), + (pglob->gl_flags & GLOB_NOCASE) ? ci_compare : compare); + pglob->gl_flags = oldflags; + return(0); +} + +static int +ci_compare(const void *p, const void *q) +{ + const char *pp = *(const char **)p; + const char *qq = *(const char **)q; + while (*pp && *qq) { + if (tolower(*pp) != tolower(*qq)) + break; + ++pp; + ++qq; + } + return (tolower(*pp) - tolower(*qq)); +} + +static int +compare(const void *p, const void *q) +{ + return(strcmp(*(char **)p, *(char **)q)); +} + +static int +glob1(Char *pattern, glob_t *pglob) +{ + Char pathbuf[MAXPATHLEN+1]; + + /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ + if (*pattern == BG_EOS) + return(0); + return(glob2(pathbuf, pathbuf, pattern, pglob)); +} + +/* + * The functions glob2 and glob3 are mutually recursive; there is one level + * of recursion for each segment in the pattern that contains one or more + * meta characters. + */ +static int +glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) +{ + Stat_t sb; + Char *p, *q; + int anymeta; + + /* + * Loop over pattern segments until end of pattern or until + * segment with meta character found. + */ + for (anymeta = 0;;) { + if (*pattern == BG_EOS) { /* End of pattern? */ + *pathend = BG_EOS; + + if (g_lstat(pathbuf, &sb, pglob)) + return(0); + + if (((pglob->gl_flags & GLOB_MARK) && + pathend[-1] != BG_SEP +#ifdef DOSISH + && pathend[-1] != BG_SEP2 +#endif + ) && (S_ISDIR(sb.st_mode) + || (S_ISLNK(sb.st_mode) && + (g_stat(pathbuf, &sb, pglob) == 0) && + S_ISDIR(sb.st_mode)))) { + *pathend++ = BG_SEP; + *pathend = BG_EOS; + } + ++pglob->gl_matchc; +#ifdef GLOB_DEBUG + printf("calling globextend from glob2\n"); +#endif /* GLOB_DEBUG */ + return(globextend(pathbuf, pglob)); + } + + /* Find end of next segment, copy tentatively to pathend. */ + q = pathend; + p = pattern; + while (*p != BG_EOS && *p != BG_SEP +#ifdef DOSISH + && *p != BG_SEP2 +#endif + ) { + if (ismeta(*p)) + anymeta = 1; + *q++ = *p++; + } + + if (!anymeta) { /* No expansion, do next segment. */ + pathend = q; + pattern = p; + while (*pattern == BG_SEP +#ifdef DOSISH + || *pattern == BG_SEP2 +#endif + ) + *pathend++ = *pattern++; + } else /* Need expansion, recurse. */ + return(glob3(pathbuf, pathend, pattern, p, pglob)); + } + /* NOTREACHED */ +} + +static int +glob3(Char *pathbuf, Char *pathend, Char *pattern, + Char *restpattern, glob_t *pglob) +{ + register Direntry_t *dp; + DIR *dirp; + int err; + int nocase; + char buf[MAXPATHLEN]; + + /* + * The readdirfunc declaration can't be prototyped, because it is + * assigned, below, to two functions which are prototyped in glob.h + * and dirent.h as taking pointers to differently typed opaque + * structures. + */ + Direntry_t *(*readdirfunc)(); + + *pathend = BG_EOS; + errno = 0; + +#ifdef VMS + { + Char *q = pathend; + if (q - pathbuf > 5) { + q -= 5; + if (q[0] == '.' && tolower(q[1]) == 'd' && tolower(q[2]) == 'i' + && tolower(q[3]) == 'r' && q[4] == '/') + { + q[0] = '/'; + q[1] = BG_EOS; + pathend = q+1; + } + } + } +#endif + if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { + /* TODO: don't call for ENOENT or ENOTDIR? */ + if (pglob->gl_errfunc) { + g_Ctoc(pathbuf, buf); + if (pglob->gl_errfunc(buf, errno) || + (pglob->gl_flags & GLOB_ERR)) + return (GLOB_ABEND); + } + return(0); + } + + err = 0; + nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); + + /* Search directory for matching names. */ + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + readdirfunc = pglob->gl_readdir; + else + readdirfunc = my_readdir; + while ((dp = (*readdirfunc)(dirp))) { + register U8 *sc; + register Char *dc; + + /* Initial BG_DOT must be matched literally. */ + if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) + continue; + for (sc = (U8 *) dp->d_name, dc = pathend; + (*dc++ = *sc++) != BG_EOS;) + continue; + if (!match(pathend, pattern, restpattern, nocase)) { + *pathend = BG_EOS; + continue; + } + err = glob2(pathbuf, --dc, restpattern, pglob); + if (err) + break; + } + + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + (*pglob->gl_closedir)(dirp); + else + PerlDir_close(dirp); + return(err); +} + + +/* + * Extend the gl_pathv member of a glob_t structure to accomodate a new item, + * add the new item, and update gl_pathc. + * + * This assumes the BSD realloc, which only copies the block when its size + * crosses a power-of-two boundary; for v7 realloc, this would cause quadratic + * behavior. + * + * Return 0 if new item added, error code if memory couldn't be allocated. + * + * Invariant of the glob_t structure: + * Either gl_pathc is zero and gl_pathv is NULL; or gl_pathc > 0 and + * gl_pathv points to (gl_offs + gl_pathc + 1) items. + */ +static int +globextend(const Char *path, glob_t *pglob) +{ + register char **pathv; + register int i; + char *copy; + const Char *p; + +#ifdef GLOB_DEBUG + printf("Adding "); + for (p = path; *p; p++) + (void)printf("%c", CHAR(*p)); + printf("\n"); +#endif /* GLOB_DEBUG */ + + if (pglob->gl_pathv) + pathv = Renew(pglob->gl_pathv, + (2 + pglob->gl_pathc + pglob->gl_offs),char*); + else + New(0,pathv,(2 + pglob->gl_pathc + pglob->gl_offs),char*); + if (pathv == NULL) + return(GLOB_NOSPACE); + + if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) { + /* first time around -- clear initial gl_offs items */ + pathv += pglob->gl_offs; + for (i = pglob->gl_offs; --i >= 0; ) + *--pathv = NULL; + } + pglob->gl_pathv = pathv; + + for (p = path; *p++;) + continue; + New(0, copy, p-path, char); + if (copy != NULL) { + g_Ctoc(path, copy); + pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; + } + pathv[pglob->gl_offs + pglob->gl_pathc] = NULL; + return(copy == NULL ? GLOB_NOSPACE : 0); +} + + +/* + * pattern matching function for filenames. Each occurrence of the * + * pattern causes a recursion level. + */ +static int +match(register Char *name, register Char *pat, register Char *patend, int nocase) +{ + int ok, negate_range; + Char c, k; + + while (pat < patend) { + c = *pat++; + switch (c & M_MASK) { + case M_ALL: + if (pat == patend) + return(1); + do + if (match(name, pat, patend, nocase)) + return(1); + while (*name++ != BG_EOS); + return(0); + case M_ONE: + if (*name++ == BG_EOS) + return(0); + break; + case M_SET: + ok = 0; + if ((k = *name++) == BG_EOS) + return(0); + if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) + ++pat; + while (((c = *pat++) & M_MASK) != M_END) + if ((*pat & M_MASK) == M_RNG) { + if (nocase) { + if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) + ok = 1; + } else { + if (c <= k && k <= pat[1]) + ok = 1; + } + pat += 2; + } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) + ok = 1; + if (ok == negate_range) + return(0); + break; + default: + k = *name++; + if (nocase ? (tolower(k) != tolower(c)) : (k != c)) + return(0); + break; + } + } + return(*name == BG_EOS); +} + +/* Free allocated data belonging to a glob_t structure. */ +void +bsd_globfree(glob_t *pglob) +{ + register int i; + register char **pp; + + if (pglob->gl_pathv != NULL) { + pp = pglob->gl_pathv + pglob->gl_offs; + for (i = pglob->gl_pathc; i--; ++pp) + if (*pp) + Safefree(*pp); + Safefree(pglob->gl_pathv); + } +} + +static DIR * +g_opendir(register Char *str, glob_t *pglob) +{ + char buf[MAXPATHLEN]; + + if (!*str) + strcpy(buf, "."); + else + g_Ctoc(str, buf); + + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_opendir)(buf)); + else + return(PerlDir_open(buf)); +} + +static int +g_lstat(register Char *fn, Stat_t *sb, glob_t *pglob) +{ + char buf[MAXPATHLEN]; + + g_Ctoc(fn, buf); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_lstat)(buf, sb)); +#ifdef HAS_LSTAT + return(PerlLIO_lstat(buf, sb)); +#else + return(PerlLIO_stat(buf, sb)); +#endif /* HAS_LSTAT */ +} + +static int +g_stat(register Char *fn, Stat_t *sb, glob_t *pglob) +{ + char buf[MAXPATHLEN]; + + g_Ctoc(fn, buf); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_stat)(buf, sb)); + return(PerlLIO_stat(buf, sb)); +} + +static Char * +g_strchr(Char *str, int ch) +{ + do { + if (*str == ch) + return (str); + } while (*str++); + return (NULL); +} + +#ifdef notdef +static Char * +g_strcat(Char *dst, const Char *src) +{ + Char *sdst = dst; + + while (*dst++) + continue; + --dst; + while((*dst++ = *src++) != BG_EOS) + continue; + + return (sdst); +} +#endif + +static void +g_Ctoc(register const Char *str, char *buf) +{ + register char *dc; + + for (dc = buf; (*dc++ = *str++) != BG_EOS;) + continue; +} + +#ifdef GLOB_DEBUG +static void +qprintf(const char *str, register Char *s) +{ + register Char *p; + + (void)printf("%s:\n", str); + for (p = s; *p; p++) + (void)printf("%c", CHAR(*p)); + (void)printf("\n"); + for (p = s; *p; p++) + (void)printf("%c", *p & M_PROTECT ? '"' : ' '); + (void)printf("\n"); + for (p = s; *p; p++) + (void)printf("%c", ismeta(*p) ? '_' : ' '); + (void)printf("\n"); +} +#endif /* GLOB_DEBUG */ diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.h b/contrib/perl5/ext/File/Glob/bsd_glob.h new file mode 100644 index 0000000..10d1de5 --- /dev/null +++ b/contrib/perl5/ext/File/Glob/bsd_glob.h @@ -0,0 +1,82 @@ +/* + * Copyright (c) 1989, 1993 + * The Regents of the University of California. All rights reserved. + * + * This code is derived from software contributed to Berkeley by + * Guido van Rossum. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. Neither the name of the University nor the names of its contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + * + * @(#)glob.h 8.1 (Berkeley) 6/2/93 + */ + +#ifndef _BSD_GLOB_H_ +#define _BSD_GLOB_H_ + +/* #include <sys/cdefs.h> */ + +typedef struct { + int gl_pathc; /* Count of total paths so far. */ + int gl_matchc; /* Count of paths matching pattern. */ + int gl_offs; /* Reserved at beginning of gl_pathv. */ + int gl_flags; /* Copy of flags parameter to glob. */ + char **gl_pathv; /* List of paths matching pattern. */ + /* Copy of errfunc parameter to glob. */ + int (*gl_errfunc)(const char *, int); + + /* + * Alternate filesystem access methods for glob; replacement + * versions of closedir(3), readdir(3), opendir(3), stat(2) + * and lstat(2). + */ + void (*gl_closedir)(void *); + Direntry_t *(*gl_readdir)(void *); + void *(*gl_opendir)(const char *); + int (*gl_lstat)(const char *, Stat_t *); + int (*gl_stat)(const char *, Stat_t *); +} glob_t; + +#define GLOB_APPEND 0x0001 /* Append to output from previous call. */ +#define GLOB_DOOFFS 0x0002 /* Use gl_offs. */ +#define GLOB_ERR 0x0004 /* Return on error. */ +#define GLOB_MARK 0x0008 /* Append / to matching directories. */ +#define GLOB_NOCHECK 0x0010 /* Return pattern itself if nothing matches. */ +#define GLOB_NOSORT 0x0020 /* Don't sort. */ + +#define GLOB_ALTDIRFUNC 0x0040 /* Use alternately specified directory funcs. */ +#define GLOB_BRACE 0x0080 /* Expand braces ala csh. */ +#define GLOB_MAGCHAR 0x0100 /* Pattern had globbing characters. */ +#define GLOB_NOMAGIC 0x0200 /* GLOB_NOCHECK without magic chars (csh). */ +#define GLOB_QUOTE 0x0400 /* Quote special chars with \. */ +#define GLOB_TILDE 0x0800 /* Expand tilde names from the passwd file. */ +#define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */ + +#define GLOB_NOSPACE (-1) /* Malloc call failed. */ +#define GLOB_ABEND (-2) /* Unignored error. */ + +int bsd_glob(const char *, int, int (*)(const char *, int), glob_t *); +void bsd_globfree(glob_t *); + +#endif /* !_BSD_GLOB_H_ */ diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm index 09df437..ab866ee 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.pm +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.pm @@ -33,21 +33,21 @@ The available functions and the gdbm/perl interface need to be documented. =head1 SEE ALSO -L<perl(1)>, L<DB_File(3)>. +L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. =cut package GDBM_File; use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); +our($VERSION, @ISA, @EXPORT, $AUTOLOAD); require Carp; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Tie::Hash Exporter); @EXPORT = qw( GDBM_CACHESIZE GDBM_FAST @@ -59,14 +59,14 @@ require DynaLoader; GDBM_WRITER ); -$VERSION = "1.00"; +$VERSION = "1.03"; sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -78,7 +78,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap GDBM_File $VERSION; +XSLoader::load 'GDBM_File', $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs index ac1ca8c..870f056 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.xs +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.xs @@ -5,20 +5,40 @@ #include <gdbm.h> #include <fcntl.h> -typedef GDBM_FILE GDBM_File; +typedef struct { + GDBM_FILE dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } GDBM_File_type; + +typedef GDBM_File_type * GDBM_File ; +typedef datum datum_key ; +typedef datum datum_value ; + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } -#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ -#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \ - gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func) -#define gdbm_FETCH(db,key) gdbm_fetch(db,key) -#define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags) -#define gdbm_DELETE(db,key) gdbm_delete(db,key) -#define gdbm_FIRSTKEY(db) gdbm_firstkey(db) -#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key) -#define gdbm_EXISTS(db,key) gdbm_exists(db,key) -typedef datum gdatum; +#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */ typedef void (*FATALFUNC)(); @@ -29,6 +49,21 @@ not_here(char *s) return -1; } +/* GDBM allocates the datum with system malloc() and expects the user + * to free() it. So we either have to free() it immediately, or have + * perl free() it when it deallocates the SV, depending on whether + * perl uses malloc()/free() or not. */ +static void +output_datum(pTHX_ SV *arg, char *str, int size) +{ +#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC)) + sv_usepvn(arg, str, size); +#else + sv_setpvn(arg, str, size); + safesysfree(str); +#endif +} + /* Versions of gdbm prior to 1.7x might not have the gdbm_sync, gdbm_exists, and gdbm_setopt functions. Apparently Slackware (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991). @@ -174,7 +209,23 @@ gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) int read_write int mode FATALFUNC fatal_func + CODE: + { + GDBM_FILE dbp ; + RETVAL = NULL ; + if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) { + RETVAL = (GDBM_File)safemalloc(sizeof(GDBM_File_type)) ; + Zero(RETVAL, 1, GDBM_File_type) ; + RETVAL->dbp = dbp ; + } + + } + OUTPUT: + RETVAL + + +#define gdbm_close(db) gdbm_close(db->dbp) void gdbm_close(db) GDBM_File db @@ -185,17 +236,20 @@ gdbm_DESTROY(db) GDBM_File db CODE: gdbm_close(db); + safefree(db); -gdatum +#define gdbm_FETCH(db,key) gdbm_fetch(db->dbp,key) +datum_value gdbm_FETCH(db, key) GDBM_File db - datum key + datum_key key +#define gdbm_STORE(db,key,value,flags) gdbm_store(db->dbp,key,value,flags) int gdbm_STORE(db, key, value, flags = GDBM_REPLACE) GDBM_File db - datum key - datum value + datum_key key + datum_value value int flags CLEANUP: if (RETVAL) { @@ -203,37 +257,43 @@ gdbm_STORE(db, key, value, flags = GDBM_REPLACE) croak("No write permission to gdbm file"); croak("gdbm store returned %d, errno %d, key \"%.*s\"", RETVAL,errno,key.dsize,key.dptr); - /* gdbm_clearerr(db); */ } +#define gdbm_DELETE(db,key) gdbm_delete(db->dbp,key) int gdbm_DELETE(db, key) GDBM_File db - datum key + datum_key key -gdatum +#define gdbm_FIRSTKEY(db) gdbm_firstkey(db->dbp) +datum_key gdbm_FIRSTKEY(db) GDBM_File db -gdatum +#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db->dbp,key) +datum_key gdbm_NEXTKEY(db, key) GDBM_File db - datum key + datum_key key +#define gdbm_reorganize(db) gdbm_reorganize(db->dbp) int gdbm_reorganize(db) GDBM_File db +#define gdbm_sync(db) gdbm_sync(db->dbp) void gdbm_sync(db) GDBM_File db +#define gdbm_EXISTS(db,key) gdbm_exists(db->dbp,key) int gdbm_EXISTS(db, key) GDBM_File db - datum key + datum_key key +#define gdbm_setopt(db,optflag, optval, optlen) gdbm_setopt(db->dbp,optflag, optval, optlen) int gdbm_setopt (db, optflag, optval, optlen) GDBM_File db @@ -241,3 +301,55 @@ gdbm_setopt (db, optflag, optval, optlen) int &optval int optlen + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = NULL ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + + +SV * +filter_fetch_key(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + GDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; + diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap index 317a8f3..4f79ae3 100644 --- a/contrib/perl5/ext/GDBM_File/typemap +++ b/contrib/perl5/ext/GDBM_File/typemap @@ -2,8 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM -gdatum T_GDATUM +datum_key T_DATUM_K +datum_value T_DATUM_V NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ @@ -13,15 +13,20 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; -T_GDATUM - UNIMPLEMENTED OUTPUT -T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); +T_DATUM_K + output_datum(aTHX_ $arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V + output_datum(aTHX_ $arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/contrib/perl5/ext/IO/ChangeLog b/contrib/perl5/ext/IO/ChangeLog new file mode 100644 index 0000000..c45e785 --- /dev/null +++ b/contrib/perl5/ext/IO/ChangeLog @@ -0,0 +1,318 @@ +For more recent changes, see the Perl Changes* file(s). + +Change 173 on 1998/07/14 by <gbarr@pobox.com> (Graham Barr) + + IO::Socket + - Added method connected + + IO.xs + - Added check that file * is not null + + t/io_udp.t + - Added check for connected + - Made change to catch recv not returning the address, and added a fix to + ensure test does not hang + + t/io_sock.t + - Added check for connected. + +Change 137 on 1998/05/21 by <gbarr@pobox.com> (Graham Barr) + + IO::Socket::INET + - Added checks to all peer* and host* methods for undef + +Change 134 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr) + + t/io_sock.t + - fix race condition on Solaris & SunOS + + IO::Handle + - Applied patch from Gisle Aas <gisle@aas.no> for + documentation update + - Applied patch from Kuma <tgy@chocobo.org> + changed input_line_number to be on a per-handle basis. + + IO::File + - Applied patch from Gisle Aas <gisle@aas.no> for + documentation update + + IO::Seekable + - Applied patch from Gisle Aas <gisle@aas.no> for + documentation update + added sysseek + + IO, IO::Socket::INET + - documentation update + + IO.xs + - Applied patch from Gisle Aas <gisle@aas.no> for + blocking + +Change 133 on 1998/05/09 by <gbarr@pobox.com> (Graham Barr) + + t/io_sock.t + - Added checks for blocking() + +Sun Apr 12 1998 <gbarr@pobox.com> (Graham Barr) + + IO.xs + - enclosed newCONSTSUB in #ifdef as _64 now defines it. + +Thu Mar 19 1998 <gbarr@pobox.com> (Graham Barr) + + All + - Changed copyright/distribution policy back to be the same as perl + +Sun Feb 15 1998 <gbarr@pobox.com> (Graham Barr) + + IO::Socket + - Fix to ->accept, accept() returns false on error not undef. + +*** Release 1.19 + +Thu Feb 5 1998 <gbarr@pobox.com> (Graham Barr) + + All + - change copyright notice + + IO::Socket::INET + - changed configure to accept PeerHost and LocalHost as well as the + PeerAddr and LocalAddr arguments. + +Mon Feb 2 1998 <gbarr@pobox.com> (Graham Barr) + + IO::Handle + - Added printflush so that flush.pl can be depreciated + + IO::Socket + - Remove C<use Config> statement as it was not needed + +Tue Jan 27 1998 <gbarr@pobox.com> (Graham Barr) + + IO::Socket::INET + - removed carp if $^W + +*** Patch 1.1804 + +Sat Jan 17 1998 <gbarr@pobox.com> (Graham Barr) + + t/io_sock.t + - Replaced C<Listen => 0> with C<LocalAddr => 'localhost'> + + IO/Socket/INET.pm + - Modified the MultiHomed code. Now each address for a given host has + a timeout of C<Timeout>. + - added _get_addr method for doing hostname lookups. Now Net::DNS can be + use by sub-classing IO::Socket::INET, Thanks Gisle Aas + + t/io_multihomed.t + - new test added. Thanks Gisle Aas. + +*** Patch 1.1803 + +Mon Nov 17 1997 <gbarr@pobox.com> (Graham Barr) + + poll.c + - Added #ifdef I_* tests + + IO::Socket + - Changed initialization of @domain2pkg to fix problem of Domain option + not working + - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no> + + IO::Socket::INET + - Change default proto to getprotobyname instead of 'tcp' constant string + - Added patch for multi-homed hosts, Thanks to Gisle Aas <gisle@aas.no> + + t/io_sock.t + - Change to test fix for Domain problem fixed in IO::Socket and be + more comprehensive, Thanks to Gisle Aas <gisle@aas.no> + + t/io_unix.t + - New test, Thanks to Gisle Aas <gisle@aas.no> + +*** Patch 1.1802 + +Wed Nov 12 1997 <gbarr@pobox.com> (Graham Barr) + + t/io_poll.t + - test 4 made an assumption that was not portable, fixed. + +*** Patch 1.1801 + +Wed Oct 22 1997 <gbarr@pobox.com> (Graham Barr) + + IO.xs + - change #ifdef's to allow compilation with 5.002 + + IO::Socket + - Fix to ensure that socket is not returned as non-blocking + unless the user asks for it + + t/io_udp.t + - Fix to stop endless loop + +*** Release 1.18 + +Mon Oct 13 1997 <gbarr@pobox.com> (Graham Barr) + + IO.xs, IO::Handle + - 1.17 broke compatability with 5.003, small tweaks to restore + compatability + + t/io_const.t + - Added new test to ensure backwards compatability with constants + is not broken + +Wed Oct 8 1997 <gbarr@pobox.com> (Graham Barr) + + IO.xs + - Added #define's to cope with argument changes to start_subparse + from 5.003_22, _23 and _24 + + IO::Select + - Renamed has_error to be has_exception which is more correct, + has_error is a wrapper around has_exception with a warning if + $^W is set. + + Makefile.PL + - Remove 'linkext' option to WriteMakefile so that static linking + should work properly, cannot remember why I added it. + +Sun Oct 5 1997 <gbarr@pobox.com> (Graham Barr) + + IO::Pipe + - GLOB assignment does not copy the fileno while under -T + added checks for undefined fileno, and added fdopen + - reader and write can now be called as static methods + + Makefile.PL + - Attempt to locate <poll.h> and define I_POLL if found + +*** Release 1.17 + +Fri Sep 26 1997 <gbarr@pobox.com> (Graham Barr) + + IO.xs + - Fix bug in _poll for ANSI C compilers + + IO::Socket + - Split IO::Socket::INET and IO::Socket::UNIX into separate files + + IO::File + - Patch to open() for when file is in current directory. + +*** Release 1.16 + +Mon 15 Sep 1997 <gbarr@pobox.com> Graham Barr + + o New modules + - IO::Dir + - IO::Poll + + o IO::Socket + - Changed new to call autoflush on the new socket + - IO::Socket::INET->new now accepts a single argument + - IO::Socket::INET default to protocol 'tcp' + + o IO::File + - Added doc for new_tmpfile + + o IO::Handle + - Removed use of AutoLoader for constants, constants are + now defined as constant XS subs + - Added fsync, but will not be avaliable for use + unless HAS_FSYNC is defined, perls configure does not define + this yet. + - Moved bootstrap of IO.xs to IO.pm. IO::Handle no longer + contains an AUTOLOAD sub in it's ISA hier + + o IO::Seekable + - Remove clearerr, as it is defined in IO.xs + + o IO.xs + - Patched IO.xs with patch from Chip for setvbuf warning + - Added XS sub "constant" for backwards compatability + + o Misc + - Fixed IO::Socket::configure, it was not passing $arg to domain + specific package + - Changed all $fh variables in IO::Handle to $io and all $fh + variables in IO::Socket to $sock as Chip suggested + - Fixed usage messages to be consistant + +*** Release 1.15 + +Sun 19 Jan 1997 <bodg@tiuk.ti.com> Graham Barr + + o Updated PODs for IO::Handle and IO::File + o Modified IO.xs so that DESTROY gets called on IO::File + objects that were created with IO::File->new_tmpfile + o Modified the domain2pkg code in IO::Socket so that it + does not use blessd refs + o Created a new package IO::Pipe::End so that pipe specific + stuff can be moved out of IO::Handle. + o Added Ilya's OS/2 changes to Pipe.pm and io_pipe.t + + o These changes happened somtime before the release of 1.15 + - added shutdown to IO::Socket + - modified connect to not use alarm + - modified accept and connect to use IO::Select + +*** Release 1.14 + +Tue 24 Dec 1996 <bodg@tiuk.ti.com> Graham Barr + + o Updated to patches in perl core dist. + o Added C<use strict> to all modules + o Modified t/io_sock.t, hopefully the race condition has gone + o Added close statements to reader/writer in IO::Pipe + o IO::Handle::syswrite was calling sysread, fixed :-) + +*** Release 1.12 + +Thu 19 Sep 1996 <bodg@tiuk.ti.com> Graham Barr + + o Modified IO.xs so that it will compile with pre perlio version + of perl (ie pre perl5.003_02) + o Modified IO::Socket::send so not to pass 4 arguments to send + if the socket is connected + +*** Release 1.10 + +Mon 11 Sep 1996 <bodg@tiuk.ti.com> Graham Barr + + o Fixed a bug in IO::Socket which caused DESTROY to be called + on a partly initialised connection + o Changed IO.xs to use Perlio + o Modified usage message to report correct package + o Added IO::File::new changes from Chip, to allow PERM to be passed + o Added sysread and syswrite methods to IO::Handle + o Updated documentation + o Fixed a bug in IO::Select that caused a hang if the last handle + was removed. + o Added count method to IO::Select + o Renamed and modified tests so that they can be copied into the + perl distribution + o Added fcntl and ioctl methods to IO::Handle + +Thu 25 Jul 1996 <bodg@tiuk.ti.com> Graham Barr + + o It is now not necessary to call the domain sub-classes of + IO::Socket. when connect is called it notes the domain. + Domain specific methods, which are normally non-critical, are + called via this note-ing. + o Added methods to IO::Socket to retrieve the domain, type and + protocol of a given socket + +Tue 23 Jul 1996 <bodg@tiuk.ti.com> Graham Barr + + o IO::Socket::connect changed how we do timeouts, as it did not work + + o IO::Handle::new_from_fd removed method call to _ref_fd, which was + a leftover from FileHandle + +Fri 28 Jun 1996 <bodg@tiuk.ti.com> Graham Barr + + o Modified IO::Socket::UNIX::configure to default to using a socket + type of SOCK_STREAM if no type is specified. diff --git a/contrib/perl5/ext/IO/IO.pm b/contrib/perl5/ext/IO/IO.pm index 4d4c81c..0087530 100644 --- a/contrib/perl5/ext/IO/IO.pm +++ b/contrib/perl5/ext/IO/IO.pm @@ -2,6 +2,24 @@ package IO; +use XSLoader (); +use Carp; + +$VERSION = "1.20"; +XSLoader::load 'IO', $VERSION; + +sub import { + shift; + my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir); + + eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l) + or croak $@; +} + +1; + +__END__ + =head1 NAME IO - load various IO modules @@ -20,17 +38,10 @@ Currently this includes: IO::File IO::Pipe IO::Socket + IO::Dir For more information on any of these modules, please see its respective documentation. =cut -use IO::Handle; -use IO::Seekable; -use IO::File; -use IO::Pipe; -use IO::Socket; - -1; - diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs index 300581e..1b79cfd 100644 --- a/contrib/perl5/ext/IO/IO.xs +++ b/contrib/perl5/ext/IO/IO.xs @@ -1,20 +1,20 @@ +/* + * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + */ + +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" - +#include "poll.h" #ifdef I_UNISTD # include <unistd.h> #endif -#ifdef I_FCNTL -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#define _NO_OLDNAMES -#endif +#if defined(I_FCNTL) || defined(HAS_FCNTL) # include <fcntl.h> -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#undef _NO_OLDNAMES -#endif - #endif #ifdef PerlIO @@ -28,6 +28,12 @@ typedef FILE * InputStream; typedef FILE * OutputStream; #endif +#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags) + +#ifndef gv_stashpvn +#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) +#endif + static int not_here(char *s) { @@ -35,56 +41,99 @@ not_here(char *s) return -1; } -static bool -constant(char *name, IV *pval) -{ - switch (*name) { - case '_': - if (strEQ(name, "_IOFBF")) -#ifdef _IOFBF - { *pval = _IOFBF; return TRUE; } -#else - return FALSE; -#endif - if (strEQ(name, "_IOLBF")) -#ifdef _IOLBF - { *pval = _IOLBF; return TRUE; } -#else - return FALSE; -#endif - if (strEQ(name, "_IONBF")) -#ifdef _IONBF - { *pval = _IONBF; return TRUE; } -#else - return FALSE; + +#ifndef PerlIO +#define PerlIO_fileno(f) fileno(f) #endif - break; - case 'S': - if (strEQ(name, "SEEK_SET")) -#ifdef SEEK_SET - { *pval = SEEK_SET; return TRUE; } + +static int +io_blocking(InputStream f, int block) +{ + int RETVAL; + if(!f) { + errno = EBADF; + return -1; + } +#if defined(HAS_FCNTL) + RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0); + if (RETVAL >= 0) { + int mode = RETVAL; +#ifdef O_NONBLOCK + /* POSIX style */ +#if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK + /* Ooops has O_NDELAY too - make sure we don't + * get SysV behaviour by mistake. */ + + /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY + * after a successful F_SETFL of an O_NONBLOCK. */ + RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1; + + if (block >= 0) { + if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) { + int ret; + mode = (mode & ~O_NDELAY) | O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else + if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) { + int ret; + mode &= ~(O_NONBLOCK | O_NDELAY); + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + } #else - return FALSE; -#endif - if (strEQ(name, "SEEK_CUR")) -#ifdef SEEK_CUR - { *pval = SEEK_CUR; return TRUE; } + /* Standard POSIX */ + RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; + + if ((block == 0) && !(mode & O_NONBLOCK)) { + int ret; + mode |= O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else if ((block > 0) && (mode & O_NONBLOCK)) { + int ret; + mode &= ~O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } +#endif #else - return FALSE; + /* Not POSIX - better have O_NDELAY or we can't cope. + * for BSD-ish machines this is an acceptable alternative + * for SysV we can't tell "would block" from EOF but that is + * the way SysV is... + */ + RETVAL = RETVAL & O_NDELAY ? 0 : 1; + + if ((block == 0) && !(mode & O_NDELAY)) { + int ret; + mode |= O_NDELAY; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else if ((block > 0) && (mode & O_NDELAY)) { + int ret; + mode &= ~O_NDELAY; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } #endif - if (strEQ(name, "SEEK_END")) -#ifdef SEEK_END - { *pval = SEEK_END; return TRUE; } + } + return RETVAL; #else - return FALSE; + return -1; #endif - break; - } - - return FALSE; } - MODULE = IO PACKAGE = IO::Seekable PREFIX = f SV * @@ -110,9 +159,9 @@ fsetpos(handle, pos) InputStream handle SV * pos CODE: - char *p; - STRLEN n_a; - if (handle && (p = SvPVx(pos, n_a)) && n_a == sizeof(Fpos_t)) + char *p; + STRLEN len; + if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) #ifdef PerlIO RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); #else @@ -144,24 +193,63 @@ new_tmpfile(packname = "IO::File") if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { ST(0) = sv_2mortal(newRV((SV*)gv)); sv_bless(ST(0), gv_stashpv(packname, TRUE)); - SvREFCNT_dec(gv); /* undo increment in newRV() */ + SvREFCNT_dec(gv); /* undo increment in newRV() */ } else { ST(0) = &PL_sv_undef; SvREFCNT_dec(gv); } +MODULE = IO PACKAGE = IO::Poll + +void +_poll(timeout,...) + int timeout; +PPCODE: +{ +#ifdef HAS_POLL + int nfd = (items - 1) / 2; + SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd)); + struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv); + int i,j,ret; + for(i=1, j=0 ; j < nfd ; j++) { + fds[j].fd = SvIV(ST(i)); + i++; + fds[j].events = SvIV(ST(i)); + i++; + fds[j].revents = 0; + } + if((ret = poll(fds,nfd,timeout)) >= 0) { + for(i=1, j=0 ; j < nfd ; j++) { + sv_setiv(ST(i), fds[j].fd); i++; + sv_setiv(ST(i), fds[j].revents); i++; + } + } + SvREFCNT_dec(tmpsv); + XSRETURN_IV(ret); +#else + not_here("IO::Poll::poll"); +#endif +} + +MODULE = IO PACKAGE = IO::Handle PREFIX = io_ + +void +io_blocking(handle,blk=-1) + InputStream handle + int blk +PROTOTYPE: $;$ +CODE: +{ + int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0); + if(ret >= 0) + XSRETURN_IV(ret); + else + XSRETURN_UNDEF; +} + MODULE = IO PACKAGE = IO::Handle PREFIX = f -SV * -constant(name) - char * name - CODE: - IV i; - if (constant(name, &i)) - ST(0) = sv_2mortal(newSViv(i)); - else - ST(0) = &PL_sv_undef; int ungetc(handle, c) @@ -274,8 +362,7 @@ setvbuf(handle, buf, type, size) int type int size CODE: -/* Should check HAS_SETVBUF once Configure tests for that */ -#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF) if (!handle) /* Try input stream. */ handle = IoIFP(sv_2io(ST(0))); if (handle) @@ -291,3 +378,84 @@ setvbuf(handle, buf, type, size) RETVAL +SysRet +fsync(handle) + OutputStream handle + CODE: +#ifdef HAS_FSYNC + if(handle) + RETVAL = fsync(PerlIO_fileno(handle)); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::sync"); +#endif + OUTPUT: + RETVAL + + +BOOT: +{ + HV *stash; + /* + * constant subs for IO::Poll + */ + stash = gv_stashpvn("IO::Poll", 8, TRUE); +#ifdef POLLIN + newCONSTSUB(stash,"POLLIN",newSViv(POLLIN)); +#endif +#ifdef POLLPRI + newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI)); +#endif +#ifdef POLLOUT + newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT)); +#endif +#ifdef POLLRDNORM + newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM)); +#endif +#ifdef POLLWRNORM + newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM)); +#endif +#ifdef POLLRDBAND + newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND)); +#endif +#ifdef POLLWRBAND + newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND)); +#endif +#ifdef POLLNORM + newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM)); +#endif +#ifdef POLLERR + newCONSTSUB(stash,"POLLERR", newSViv(POLLERR)); +#endif +#ifdef POLLHUP + newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP)); +#endif +#ifdef POLLNVAL + newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL)); +#endif + /* + * constant subs for IO::Handle + */ + stash = gv_stashpvn("IO::Handle", 10, TRUE); +#ifdef _IOFBF + newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF)); +#endif +#ifdef _IOLBF + newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF)); +#endif +#ifdef _IONBF + newCONSTSUB(stash,"_IONBF", newSViv(_IONBF)); +#endif +#ifdef SEEK_SET + newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET)); +#endif +#ifdef SEEK_CUR + newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR)); +#endif +#ifdef SEEK_END + newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END)); +#endif +} diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL index 6a2d50d..095d7c2 100644 --- a/contrib/perl5/ext/IO/Makefile.PL +++ b/contrib/perl5/ext/IO/Makefile.PL @@ -1,8 +1,9 @@ use ExtUtils::MakeMaker; +use Config qw(%Config); + WriteMakefile( - NAME => 'IO', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'lib/IO/Handle.pm', - XS_VERSION => 1.15 + VERSION_FROM => "IO.pm", + NAME => "IO", + OBJECT => '$(O_FILES)', + MAN3PODS => {}, # Pods will be built by installman. ); diff --git a/contrib/perl5/ext/IO/README b/contrib/perl5/ext/IO/README index e855afa..191d550 100644 --- a/contrib/perl5/ext/IO/README +++ b/contrib/perl5/ext/IO/README @@ -1,4 +1,5 @@ -This directory contains files from the IO distribution maintained by -Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify -any files in this directory then please forward him a patch for only -the files in this directory. +This directory contains files from the IO distribution created by +Graham Barr. It is currently maintained by the Perl Porters as part +of the Perl source distribution. If you find that you have to modify +any files in this directory then please forward them a patch at +<perl5-porters@perl.org>. diff --git a/contrib/perl5/ext/IO/lib/IO/Dir.pm b/contrib/perl5/ext/IO/lib/IO/Dir.pm new file mode 100644 index 0000000..1fa07ed --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Dir.pm @@ -0,0 +1,239 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Dir; + +use 5.003_26; + +use strict; +use Carp; +use Symbol; +use Exporter; +use IO::File; +our(@ISA, $VERSION, @EXPORT_OK); +use Tie::Hash; +use File::stat; + +@ISA = qw(Tie::Hash Exporter); +$VERSION = "1.03"; +@EXPORT_OK = qw(DIR_UNLINK); + +sub DIR_UNLINK () { 1 } + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]'; + my $class = shift; + my $dh = gensym; + if (@_) { + IO::Dir::open($dh, $_[0]) + or return undef; + } + bless $dh, $class; +} + +sub DESTROY { + my ($dh) = @_; + closedir($dh); +} + +sub open { + @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; + my ($dh, $dirname) = @_; + return undef + unless opendir($dh, $dirname); + ${*$dh}{io_dir_path} = $dirname; + 1; +} + +sub close { + @_ == 1 or croak 'usage: $dh->close()'; + my ($dh) = @_; + closedir($dh); +} + +sub read { + @_ == 1 or croak 'usage: $dh->read()'; + my ($dh) = @_; + readdir($dh); +} + +sub seek { + @_ == 2 or croak 'usage: $dh->seek(POS)'; + my ($dh,$pos) = @_; + seekdir($dh,$pos); +} + +sub tell { + @_ == 1 or croak 'usage: $dh->tell()'; + my ($dh) = @_; + telldir($dh); +} + +sub rewind { + @_ == 1 or croak 'usage: $dh->rewind()'; + my ($dh) = @_; + rewinddir($dh); +} + +sub TIEHASH { + my($class,$dir,$options) = @_; + + my $dh = $class->new($dir) + or return undef; + + $options ||= 0; + + ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK; + $dh; +} + +sub FIRSTKEY { + my($dh) = @_; + $dh->rewind; + scalar $dh->read; +} + +sub NEXTKEY { + my($dh) = @_; + scalar $dh->read; +} + +sub EXISTS { + my($dh,$key) = @_; + -e ${*$dh}{io_dir_path} . "/" . $key; +} + +sub FETCH { + my($dh,$key) = @_; + &lstat(${*$dh}{io_dir_path} . "/" . $key); +} + +sub STORE { + my($dh,$key,$data) = @_; + my($atime,$mtime) = ref($data) ? @$data : ($data,$data); + my $file = ${*$dh}{io_dir_path} . "/" . $key; + unless(-e $file) { + my $io = IO::File->new($file,O_CREAT | O_RDWR); + $io->close if $io; + } + utime($atime,$mtime, $file); +} + +sub DELETE { + my($dh,$key) = @_; + # Only unlink if unlink-ing is enabled + my $file = ${*$dh}{io_dir_path} . "/" . $key; + + return 0 + unless ${*$dh}{io_dir_unlink}; + + -d $file + ? rmdir($file) + : unlink($file); +} + +1; + +__END__ + +=head1 NAME + +IO::Dir - supply object methods for directory handles + +=head1 SYNOPSIS + + use IO::Dir; + $d = new IO::Dir "."; + if (defined $d) { + while (defined($_ = $d->read)) { something($_); } + $d->rewind; + while (defined($_ = $d->read)) { something_else($_); } + undef $d; + } + + tie %dir, IO::Dir, "."; + foreach (keys %dir) { + print $_, " " , $dir{$_}->size,"\n"; + } + +=head1 DESCRIPTION + +The C<IO::Dir> package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C<IO::Dir> provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C<new> is the constuctor for C<IO::Dir> objects. It accepts one optional +argument which, if given, C<new> will pass to C<open> + +=back + +The following methods are wrappers for the directory related functions built +into perl (the trailing `dir' has been removed from the names). See L<perlfunc> +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C<IO::Dir> also provides a interface to reading directories via a tied +HASH. The tied HASH extends the interface beyond just the directory +reading routines by the use of C<lstat>, from the C<File::stat> package, +C<unlink>, C<rmdir> and C<utime>. + +=over 4 + +=item tie %hash, IO::Dir, DIRNAME [, OPTIONS ] + +=back + +The keys of the HASH will be the names of the entries in the directory. +Reading a value from the hash will be the result of calling +C<File::stat::lstat>. Deleting an element from the hash will call C<unlink> +providing that C<DIR_UNLINK> is passed in the C<OPTIONS>. + +Assigning to an entry in the HASH will cause the time stamps of the file +to be modified. If the file does not exist then it will be created. Assigning +a single integer to a HASH element will cause both the access and +modification times to be changed to that value. Alternatively a reference to +an array of two values can be passed. The first array element will be used to +set the access time and the second element will be used to set the modification +time. + +=head1 SEE ALSO + +L<File::stat> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/contrib/perl5/ext/IO/lib/IO/File.pm b/contrib/perl5/ext/IO/lib/IO/File.pm index de7fabc..569c280 100644 --- a/contrib/perl5/ext/IO/lib/IO/File.pm +++ b/contrib/perl5/ext/IO/lib/IO/File.pm @@ -49,7 +49,7 @@ these classes with methods that are specific to file handles. =over 4 -=item new ([ ARGS ] ) +=item new ( FILENAME [,MODE [,PERMS]] ) Creates a C<IO::File>. If it receives any parameters, they are passed to the method C<open>; if the open fails, the object is destroyed. Otherwise, @@ -72,20 +72,21 @@ Otherwise, it is returned to the caller. =item open( FILENAME [,MODE [,PERMS]] ) C<open> accepts one, two or three parameters. With one parameter, -it is just a front end for the built-in C<open> function. With two +it is just a front end for the built-in C<open> function. With two or three parameters, the first parameter is a filename that may include whitespace or other special characters, and the second parameter is the open mode, optionally followed by a file permission value. If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) -or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic -Perl C<open> operator. +or a ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator (but protects any special characters). If C<IO::File::open> is given a numeric mode, it passes that mode and the optional permissions value to the Perl C<sysopen> operator. -For convenience, C<IO::File::import> tries to import the O_XXX -constants from the Fcntl module. If dynamic loading is not available, -this may fail, but the rest of IO::File will still work. +The permissions default to 0666. + +For convenience, C<IO::File> exports the O_XXX constants from the +Fcntl module, if this module is available. =back @@ -98,24 +99,24 @@ L<IO::Seekable> =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. =cut -require 5.000; +require 5.005_64; use strict; -use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +our($VERSION, @EXPORT, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; use IO::Seekable; +use File::Spec; require Exporter; -require DynaLoader; -@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); +@ISA = qw(IO::Handle IO::Seekable Exporter); -$VERSION = "1.06021"; +$VERSION = "1.08"; @EXPORT = @IO::Seekable::EXPORT; @@ -127,7 +128,6 @@ eval { push(@EXPORT, @O); }; - ################################################ ## Constructor ## @@ -158,7 +158,9 @@ sub open { defined $perms or $perms = 0666; return sysopen($fh, $file, $mode, $perms); } - $file = './' . $file if $file =~ m{\A[^\\/\w]}; + if (! File::Spec->file_name_is_absolute($file)) { + $file = File::Spec->catfile(File::Spec->curdir(),$file); + } $file = IO::Handle::_open_mode_string($mode) . " $file\0"; } open($fh, $file); diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm index 7927641..930df55 100644 --- a/contrib/perl5/ext/IO/lib/IO/Handle.pm +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -9,21 +9,21 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; - $fh = new IO::Handle; - if ($fh->fdopen(fileno(STDIN),"r")) { - print $fh->getline; - $fh->close; + $io = new IO::Handle; + if ($io->fdopen(fileno(STDIN),"r")) { + print $io->getline; + $io->close; } - $fh = new IO::Handle; - if ($fh->fdopen(fileno(STDOUT),"w")) { - $fh->print("Some text\n"); + $io = new IO::Handle; + if ($io->fdopen(fileno(STDOUT),"w")) { + $io->print("Some text\n"); } use IO::Handle '_IOLBF'; - $fh->setvbuf($buffer_var, _IOLBF, 1024); + $io->setvbuf($buffer_var, _IOLBF, 1024); - undef $fh; # automatically closes the file if it's open + undef $io; # automatically closes the file if it's open autoflush STDOUT 1; @@ -36,9 +36,7 @@ in the IO hierarchy. If you are reading this documentation, looking for a replacement for the C<FileHandle> package, then I suggest you read the documentation -for C<IO::File> - -A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package) +for C<IO::File> too. =head1 CONSTRUCTOR @@ -63,87 +61,123 @@ See L<perlfunc> for complete descriptions of each of the following supported C<IO::Handle> methods, which are just front ends for the corresponding built-in functions: - close - fileno - getc - eof - read - truncate - stat - print - printf - sysread - syswrite + $io->close + $io->eof + $io->fileno + $io->format_write( [FORMAT_NAME] ) + $io->getc + $io->read ( BUF, LEN, [OFFSET] ) + $io->print ( ARGS ) + $io->printf ( FMT, [ARGS] ) + $io->stat + $io->sysread ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, LEN, [OFFSET] ) + $io->truncate ( LEN ) See L<perlvar> for complete descriptions of each of the following -supported C<IO::Handle> methods: +supported C<IO::Handle> methods. All of them return the previous +value of the attribute and takes an optional single argument that when +given will set the value. If no argument is given the previous value +is unchanged (except for $io->autoflush will actually turn ON +autoflush by default). - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - format_write + $io->autoflush ( [BOOL] ) $| + $io->format_page_number( [NUM] ) $% + $io->format_lines_per_page( [NUM] ) $= + $io->format_lines_left( [NUM] ) $- + $io->format_name( [STR] ) $~ + $io->format_top_name( [STR] ) $^ + $io->input_line_number( [NUM]) $. + +The following methods are not supported on a per-filehandle basis. + + IO::Handle->format_line_break_characters( [STR] ) $: + IO::Handle->format_formfeed( [STR]) $^L + IO::Handle->output_field_separator( [STR] ) $, + IO::Handle->output_record_separator( [STR] ) $\ + + IO::Handle->input_record_separator( [STR] ) $/ Furthermore, for doing normal I/O you might need these: =over -=item $fh->fdopen ( FD, MODE ) +=item $io->fdopen ( FD, MODE ) C<fdopen> is like an ordinary C<open> except that its first parameter is not a filename but rather a file handle name, a IO::Handle object, or a file descriptor number. -=item $fh->opened +=item $io->opened Returns true if the object is currently a valid file descriptor. -=item $fh->getline +=item $io->getline -This works like <$fh> described in L<perlop/"I/O Operators"> +This works like <$io> described in L<perlop/"I/O Operators"> except that it's more readable and can be safely called in an array context but still returns just one line. -=item $fh->getlines +=item $io->getlines -This works like <$fh> when called in an array context to +This works like <$io> when called in an array context to read all the remaining lines in a file, except that it's more readable. It will also croak() if accidentally called in a scalar context. -=item $fh->ungetc ( ORD ) +=item $io->ungetc ( ORD ) Pushes a character with the given ordinal value back onto the given -handle's input stream. +handle's input stream. Only one character of pushback per handle is +guaranteed. -=item $fh->write ( BUF, LEN [, OFFSET }\] ) +=item $io->write ( BUF, LEN [, OFFSET ] ) This C<write> is like C<write> found in C, that is it is the opposite of read. The wrapper for the perl C<write> function is called C<format_write>. -=item $fh->flush - -Flush the given handle's buffer. - -=item $fh->error +=item $io->error Returns a true value if the given handle has experienced any errors since it was opened or since the last call to C<clearerr>. -=item $fh->clearerr +=item $io->clearerr Clear the given handle's error indicator. +=item $io->sync + +C<sync> synchronizes a file's in-memory state with that on the +physical medium. C<sync> does not operate at the perlio api level, but +operates on the file descriptor, this means that any data held at the +perlio api level will not be synchronized. To synchronize data that is +buffered at the perlio api level you must use the flush method. C<sync> +is not implemented on all platforms. See L<fsync(3c)>. + +=item $io->flush + +C<flush> causes perl to flush any buffered data at the perlio api level. +Any unread data in the buffer will be discarded, and any unwritten data +will be written to the underlying file descriptor. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C<IO::Handle> object. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C<blocking> will turn on non-blocking IO if +C<BOOL> is false, and turn it off if C<BOOL> is true. + +C<blocking> will return the value of the previous setting, or the +current setting if C<BOOL> is not given. + +If an error occurs C<blocking> will return undef and C<$!> will be set. + =back + If the C functions setbuf() and/or setvbuf() are available, then C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering policy for an IO::Handle. The calling sequences for the Perl functions @@ -152,7 +186,7 @@ C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter specifies a scalar variable to use as a buffer. WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called -again, or memory corruption may result! Note that you need to import +again, or memory corruption may result! Note that you need to import the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Lastly, there is a special method for working under B<-T> and setuid/gid @@ -160,7 +194,7 @@ scripts: =over -=item $fh->untaint +=item $io->untaint Marks the object as taint-clean, and as such data read from it will also be considered taint-clean. Note that this is a very trusting action to @@ -171,7 +205,8 @@ vulnerability should be kept in mind. =head1 NOTE -A C<IO::Handle> object is a GLOB reference. Some modules that +A C<IO::Handle> object is a reference to a symbol/GLOB reference (see +the C<Symbol> package). Some modules that inherit from C<IO::Handle> may want to keep object related variables in the hash table part of the GLOB. In an attempt to prevent modules trampling on each other I propose the that any such module should prefix @@ -193,22 +228,22 @@ class from C<IO::Handle> and inherit those methods. =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> =cut -require 5.000; +require 5.005_64; use strict; -use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +our($VERSION, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; +use IO (); # Load the XS module require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1505"; -$XS_VERSION = "1.15"; +$VERSION = "1.21"; @EXPORT_OK = qw( autoflush @@ -230,6 +265,9 @@ $XS_VERSION = "1.15"; getline getlines + printflush + flush + SEEK_SET SEEK_CUR SEEK_END @@ -238,30 +276,6 @@ $XS_VERSION = "1.15"; _IONBF ); - -################################################ -## Interaction with the XS. -## - -require DynaLoader; -@IO::ISA = qw(DynaLoader); -bootstrap IO $XS_VERSION; - -sub AUTOLOAD { - if ($AUTOLOAD =~ /::(_?[a-z])/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD - } - my $constname = $AUTOLOAD; - $constname =~ s/.*:://; - my $val = constant($constname); - defined $val or croak "$constname is not a valid IO::Handle macro"; - no strict 'refs'; - *$AUTOLOAD = sub { $val }; - goto &$AUTOLOAD; -} - - ################################################ ## Constructors, destructors. ## @@ -269,18 +283,18 @@ sub AUTOLOAD { sub new { my $class = ref($_[0]) || $_[0] || "IO::Handle"; @_ == 1 or croak "usage: new $class"; - my $fh = gensym; - bless $fh, $class; + my $io = gensym; + bless $io, $class; } sub new_from_fd { my $class = ref($_[0]) || $_[0] || "IO::Handle"; @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; - my $fh = gensym; + my $io = gensym; shift; - IO::Handle::fdopen($fh, @_) + IO::Handle::fdopen($io, @_) or return undef; - bless $fh, $class; + bless $io, $class; } # @@ -307,8 +321,8 @@ sub _open_mode_string { } sub fdopen { - @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; - my ($fh, $fd, $mode) = @_; + @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; + my ($io, $fd, $mode) = @_; local(*GLOB); if (ref($fd) && "".$fd =~ /GLOB\(/o) { @@ -321,15 +335,15 @@ sub fdopen { $fd = "=$fd"; } - open($fh, _open_mode_string($mode) . '&' . $fd) - ? $fh : undef; + open($io, _open_mode_string($mode) . '&' . $fd) + ? $io : undef; } sub close { - @_ == 1 or croak 'usage: $fh->close()'; - my($fh) = @_; + @_ == 1 or croak 'usage: $io->close()'; + my($io) = @_; - close($fh); + close($io); } ################################################ @@ -340,39 +354,39 @@ sub close { # select sub opened { - @_ == 1 or croak 'usage: $fh->opened()'; + @_ == 1 or croak 'usage: $io->opened()'; defined fileno($_[0]); } sub fileno { - @_ == 1 or croak 'usage: $fh->fileno()'; + @_ == 1 or croak 'usage: $io->fileno()'; fileno($_[0]); } sub getc { - @_ == 1 or croak 'usage: $fh->getc()'; + @_ == 1 or croak 'usage: $io->getc()'; getc($_[0]); } sub eof { - @_ == 1 or croak 'usage: $fh->eof()'; + @_ == 1 or croak 'usage: $io->eof()'; eof($_[0]); } sub print { - @_ or croak 'usage: $fh->print([ARGS])'; + @_ or croak 'usage: $io->print(ARGS)'; my $this = shift; print $this @_; } sub printf { - @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; my $this = shift; printf $this @_; } sub getline { - @_ == 1 or croak 'usage: $fh->getline'; + @_ == 1 or croak 'usage: $io->getline()'; my $this = shift; return scalar <$this>; } @@ -380,41 +394,43 @@ sub getline { *gets = \&getline; # deprecated sub getlines { - @_ == 1 or croak 'usage: $fh->getline()'; + @_ == 1 or croak 'usage: $io->getlines()'; wantarray or - croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; my $this = shift; return <$this>; } sub truncate { - @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + @_ == 2 or croak 'usage: $io->truncate(LEN)'; truncate($_[0], $_[1]); } sub read { - @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; read($_[0], $_[1], $_[2], $_[3] || 0); } sub sysread { - @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; sysread($_[0], $_[1], $_[2], $_[3] || 0); } sub write { - @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; local($\) = ""; + $_[2] = length($_[1]) unless defined $_[2]; print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); } sub syswrite { - @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; + $_[2] = length($_[1]) unless defined $_[2]; syswrite($_[0], $_[1], $_[2], $_[3] || 0); } sub stat { - @_ == 1 or croak 'usage: $fh->stat()'; + @_ == 1 or croak 'usage: $io->stat()'; stat($_[0]); } @@ -423,32 +439,39 @@ sub stat { ## sub autoflush { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $old = new SelectSaver qualify($_[0], caller); my $prev = $|; $| = @_ > 1 ? $_[1] : 1; $prev; } sub output_field_separator { + carp "output_field_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $,; $, = $_[1] if @_ > 1; $prev; } sub output_record_separator { + carp "output_record_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $\; $\ = $_[1] if @_ > 1; $prev; } sub input_record_separator { + carp "input_record_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $/; $/ = $_[1] if @_ > 1; $prev; } sub input_line_number { - # localizing $. doesn't work as advertised. grrrrrr. + local $.; + my $tell = tell qualify($_[0], caller) if ref($_[0]); my $prev = $.; $. = $_[1] if @_ > 1; $prev; @@ -490,50 +513,82 @@ sub format_top_name { } sub format_line_break_characters { + carp "format_line_break_characters is not supported on a per-handle basis" + if ref($_[0]); my $prev = $:; $: = $_[1] if @_ > 1; $prev; } sub format_formfeed { + carp "format_formfeed is not supported on a per-handle basis" + if ref($_[0]); my $prev = $^L; $^L = $_[1] if @_ > 1; $prev; } sub formline { - my $fh = shift; + my $io = shift; my $picture = shift; local($^A) = $^A; local($\) = ""; formline($picture, @_); - print $fh $^A; + print $io $^A; } sub format_write { - @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; if (@_ == 2) { - my ($fh, $fmt) = @_; - my $oldfmt = $fh->format_name($fmt); - CORE::write($fh); - $fh->format_name($oldfmt); + my ($io, $fmt) = @_; + my $oldfmt = $io->format_name($fmt); + CORE::write($io); + $io->format_name($oldfmt); } else { CORE::write($_[0]); } } +# XXX undocumented sub fcntl { - @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );'; - my ($fh, $op, $val) = @_; - my $r = fcntl($fh, $op, $val); - defined $r && $r eq "0 but true" ? 0 : $r; + @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; + my ($io, $op) = @_; + return fcntl($io, $op, $_[2]); } +# XXX undocumented sub ioctl { - @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );'; - my ($fh, $op, $val) = @_; - my $r = ioctl($fh, $op, $val); - defined $r && $r eq "0 but true" ? 0 : $r; + @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; + my ($io, $op) = @_; + return ioctl($io, $op, $_[2]); +} + +# this sub is for compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just chech defined(&CONSTANT_NAME) + +sub constant { + no strict 'refs'; + my $name = shift; + (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) + ? &{$name}() : undef; +} + + +# so that flush.pl can be depriciated + +sub printflush { + my $io = shift; + my $old = new SelectSaver qualify($io, caller) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } } 1; diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm index 23c51b0..27b5ad0 100644 --- a/contrib/perl5/ext/IO/lib/IO/Pipe.pm +++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm @@ -1,20 +1,20 @@ # IO::Pipe.pm # -# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or +# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package IO::Pipe; -require 5.000; +require 5.005_64; use IO::Handle; use strict; -use vars qw($VERSION); +our($VERSION); use Carp; use Symbol; -$VERSION = "1.0902"; +$VERSION = "1.121"; sub new { my $type = shift; @@ -65,7 +65,7 @@ sub _doit { } bless $io, "IO::Handle"; $io->fdopen($fh, $mode); - $fh->close; + $fh->close; if ($do_spawn) { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT @@ -88,8 +88,12 @@ sub _doit { } sub reader { - @_ >= 1 or croak 'usage: $pipe->reader()'; + @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + my $fh = ${*$me}[0]; my $pid = $me->_doit(0, $fh, @_) if(@_); @@ -97,6 +101,8 @@ sub reader { close ${*$me}[1]; bless $me, ref($fh); *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"r") + unless defined($me->fileno); bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -105,8 +111,12 @@ sub reader { } sub writer { - @_ >= 1 or croak 'usage: $pipe->writer()'; + @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + my $fh = ${*$me}[1]; my $pid = $me->_doit(1, $fh, @_) if(@_); @@ -114,6 +124,8 @@ sub writer { close ${*$me}[0]; bless $me, ref($fh); *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"w") + unless defined($me->fileno); bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -123,7 +135,7 @@ sub writer { package IO::Pipe::End; -use vars qw(@ISA); +our(@ISA); @ISA = qw(IO::Handle); @@ -143,7 +155,7 @@ __END__ =head1 NAME -IO::pipe - supply object methods for pipes +IO::Pipe - supply object methods for pipes =head1 SYNOPSIS @@ -228,12 +240,13 @@ L<IO::Handle> =head1 AUTHOR -Graham Barr <bodg@tiuk.ti.com> +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT -Copyright (c) 1996 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. =cut diff --git a/contrib/perl5/ext/IO/lib/IO/Poll.pm b/contrib/perl5/ext/IO/lib/IO/Poll.pm new file mode 100644 index 0000000..687664b --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Poll.pm @@ -0,0 +1,205 @@ +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Poll; + +use strict; +use IO::Handle; +use Exporter (); +our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); + +@ISA = qw(Exporter); +$VERSION = "0.01"; + +@EXPORT = qw(poll); + +@EXPORT_OK = qw( + POLLIN + POLLPRI + POLLOUT + POLLRDNORM + POLLWRNORM + POLLRDBAND + POLLWRBAND + POLLNORM + POLLERR + POLLHUP + POLLNVAL +); + +sub new { + my $class = shift; + + my $self = bless [{},{}], $class; + + $self; +} + +sub mask { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + if(@_) { + my $mask = shift; + $self->[0]{$fd} ||= {}; + if($mask) { + $self->[0]{$fd}{$io} = $mask; + } + else { + delete $self->[0]{$fd}{$io}; + } + } + elsif(exists $self->[0]{$fd}{$io}) { + return $self->[0]{$fd}{$io}; + } + return; +} + + +sub poll { + my($self,$timeout) = @_; + + $self->[1] = {}; + + my($fd,$ref); + my @poll = (); + + while(($fd,$ref) = each %{$self->[0]}) { + my $events = 0; + map { $events |= $_ } values %{$ref}; + push(@poll,$fd, $events); + } + + my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; + + return $ret + unless $ret > 0; + + while(@poll) { + my($fd,$got) = splice(@poll,0,2); + $self->[1]{$fd} = $got + if $got; + } + + return $ret; +} + +sub events { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + + exists $self->[1]{$fd} && exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & $self->[0]{$fd}{$io} + : 0; +} + +sub remove { + my $self = shift; + my $io = shift; + $self->mask($io,0); +} + +sub handles { + my $self = shift; + + return map { keys %$_ } values %{$self->[0]} + unless(@_); + + my $events = shift || 0; + my($fd,$ev,$io,$mask); + my @handles = (); + + while(($fd,$ev) = each %{$self->[1]}) { + if($ev & $events) { + while(($io,$mask) = each %{$self->[0][$fd]}) { + push(@handles, $io) + if $events & $mask; + } + } + } + return @handles; +} + +1; + +__END__ + +=head1 NAME + +IO::Poll - Object interface to system poll call + +=head1 SYNOPSIS + + use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); + + $poll = new IO::Poll; + + $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); + $poll->mask($output_handle => POLLWRNORM); + + $poll->poll($timeout); + + $ev = $poll->events($input); + +=head1 DESCRIPTION + +C<IO::Poll> is a simple interface to the system level poll routine. + +=head1 METHODS + +=over 4 + +=item mask ( IO [, EVENT_MASK ] ) + +If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the +list of file descriptors and the next call to poll will check for +any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be +removed from the list of file descriptors. + +If EVENT_MASK is not given then the return value will be the current +event mask value for IO. + +=item poll ( [ TIMEOUT ] ) + +Call the system level poll routine. If TIMEOUT is not specified then the +call will block. Returns the number of handles which had events +happen, or -1 on error. + +=item events ( IO ) + +Returns the event mask which represents the events that happend on IO +during the last call to C<poll>. + +=item remove ( IO ) + +Remove IO from the list of file descriptors for the next poll. + +=item handles( [ EVENT_MASK ] ) + +Returns a list of handles. If EVENT_MASK is not given then a list of all +handles known will be returned. If EVENT_MASK is given then a list +of handles will be returned which had one of the events specified by +EVENT_MASK happen during the last call ti C<poll> + +=back + +=head1 SEE ALSO + +L<poll(2)>, L<IO::Handle>, L<IO::Select> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm index 86154c5..e09d48b 100644 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -19,16 +19,17 @@ be inherited by other C<IO::Handle> based objects. It provides methods which allow seeking of the file descriptors. If the C functions fgetpos() and fsetpos() are available, then -C<IO::File::getpos> returns an opaque value that represents the -current position of the IO::File, and C<IO::File::setpos> uses +C<$io-E<lt>getpos> returns an opaque value that represents the +current position of the IO::File, and C<$io-E<gt>setpos(POS)> uses that value to return to a previously visited position. See L<perlfunc> for complete descriptions of each of the following supported C<IO::Seekable> methods, which are just front ends for the corresponding built-in functions: - seek - tell + $io->seek( POS, WHENCE ) + $io->sysseek( POS, WHENCE ) + $io->tell =head1 SEE ALSO @@ -39,29 +40,37 @@ L<IO::File> =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> +Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> =cut -require 5.000; +require 5.005_64; use Carp; use strict; -use vars qw($VERSION @EXPORT @ISA); -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +our($VERSION, @EXPORT, @ISA); +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C<use POSIX; use IO::File;> :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); require Exporter; @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); @ISA = qw(Exporter); -$VERSION = "1.06"; +$VERSION = "1.08"; sub seek { - @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; seek($_[0], $_[1], $_[2]); } +sub sysseek { + @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; + sysseek($_[0], $_[1], $_[2]); +} + sub tell { - @_ == 1 or croak 'usage: $fh->tell()'; + @_ == 1 or croak 'usage: $io->tell()'; tell($_[0]); } diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm index dea684a..df92b04 100644 --- a/contrib/perl5/ext/IO/lib/IO/Select.pm +++ b/contrib/perl5/ext/IO/lib/IO/Select.pm @@ -1,163 +1,17 @@ # IO::Select.pm # -# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -# software; you can redistribute it and/or modify it under the same terms -# as Perl itself. +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Select; -=head1 NAME - -IO::Select - OO interface to the select system call - -=head1 SYNOPSIS - - use IO::Select; - - $s = IO::Select->new(); - - $s->add(\*STDIN); - $s->add($some_handle); - - @ready = $s->can_read($timeout); - - @ready = IO::Select->new(@handles)->read(0); - -=head1 DESCRIPTION - -The C<IO::Select> package implements an object approach to the system C<select> -function call. It allows the user to see what IO handles, see L<IO::Handle>, -are ready for reading, writing or have an error condition pending. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HANDLES ] ) - -The constructor creates a new object and optionally initialises it with a set -of handles. - -=back - -=head1 METHODS - -=over 4 - -=item add ( HANDLES ) - -Add the list of handles to the C<IO::Select> object. It is these values that -will be returned when an event occurs. C<IO::Select> keeps these values in a -cache which is indexed by the C<fileno> of the handle, so if more than one -handle with the same C<fileno> is specified then only the last one is cached. - -Each handle can be an C<IO::Handle> object, an integer or an array -reference where the first element is a C<IO::Handle> or an integer. - -=item remove ( HANDLES ) - -Remove all the given handles from the object. This method also works -by the C<fileno> of the handles. So the exact handles that were added -need not be passed, just handles that have an equivalent C<fileno> - -=item exists ( HANDLE ) - -Returns a true value (actually the handle itself) if it is present. -Returns undef otherwise. - -=item handles - -Return an array of all registered handles. - -=item can_read ( [ TIMEOUT ] ) - -Return an array of handles that are ready for reading. C<TIMEOUT> is -the maximum amount of time to wait before returning an empty list. If -C<TIMEOUT> is not given and any handles are registered then the call -will block. - -=item can_write ( [ TIMEOUT ] ) - -Same as C<can_read> except check for handles that can be written to. - -=item has_error ( [ TIMEOUT ] ) - -Same as C<can_read> except check for handles that have an error -condition, for example EOF. - -=item count () - -Returns the number of handles that the object will check for when -one of the C<can_> methods is called or the object is passed to -the C<select> static method. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) - -C<select> is a static method, that is you call it with the package -name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> -or C<IO::Select> objects. C<TIMEOUT> is optional and has the same -effect as for the core select call. - -The result will be an array of 3 elements, each a reference to an array -which will hold the handles that are ready for reading, writing and have -error conditions respectively. Upon error an empty array is returned. - -=back - -=head1 EXAMPLE - -Here is a short example which shows how C<IO::Select> could be used -to write a server which communicates with several sockets while also -listening for more connections on a listen socket - - use IO::Select; - use IO::Socket; - - $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); - $sel = new IO::Select( $lsn ); - - while(@ready = $sel->can_read) { - foreach $fh (@ready) { - if($fh == $lsn) { - # Create a new socket - $new = $lsn->accept; - $sel->add($new); - } - else { - # Process socket - - # Maybe we have finished with the socket - $sel->remove($fh); - $fh->close; - } - } - } - -=head1 AUTHOR - -Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> - -=head1 COPYRIGHT - -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. - -=cut - use strict; +use warnings::register; use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.10"; +$VERSION = "1.14"; @ISA = qw(Exporter); # This is only so we can do version checking @@ -193,7 +47,9 @@ sub remove sub exists { my $vec = shift; - $vec->[$vec->_fileno(shift) + FIRST_FD]; + my $fno = $vec->_fileno(shift); + return undef unless defined $fno; + $vec->[$fno + FIRST_FD]; } @@ -261,7 +117,7 @@ sub can_write : (); } -sub has_error +sub has_exception { my $vec = shift; my $timeout = shift; @@ -272,6 +128,13 @@ sub has_error : (); } +sub has_error +{ + warnings::warn("Call to depreciated method 'has_error', use 'has_exception'") + if warnings::enabled(); + goto &has_exception; +} + sub count { my $vec = shift; @@ -369,3 +232,149 @@ sub handles } 1; +__END__ + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->read(0); + +=head1 DESCRIPTION + +The C<IO::Select> package implements an object approach to the system C<select> +function call. It allows the user to see what IO handles, see L<IO::Handle>, +are ready for reading, writing or have an error condition pending. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HANDLES ] ) + +The constructor creates a new object and optionally initialises it with a set +of handles. + +=back + +=head1 METHODS + +=over 4 + +=item add ( HANDLES ) + +Add the list of handles to the C<IO::Select> object. It is these values that +will be returned when an event occurs. C<IO::Select> keeps these values in a +cache which is indexed by the C<fileno> of the handle, so if more than one +handle with the same C<fileno> is specified then only the last one is cached. + +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is a C<IO::Handle> or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> + +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + +=item can_read ( [ TIMEOUT ] ) + +Return an array of handles that are ready for reading. C<TIMEOUT> is +the maximum amount of time to wait before returning an empty list. If +C<TIMEOUT> is not given and any handles are registered then the call +will block. + +=item can_write ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that can be written to. + +=item has_exception ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an exception +condition, for example pending out-of-band data. + +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) + +C<select> is a static method, that is you call it with the package +name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> +or C<IO::Select> objects. C<TIMEOUT> is optional and has the same +effect as for the core select call. + +The result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and have +error conditions respectively. Upon error an empty array is returned. + +=back + +=head1 EXAMPLE + +Here is a short example which shows how C<IO::Select> could be used +to write a server which communicates with several sockets while also +listening for more connections on a listen socket + + use IO::Select; + use IO::Socket; + + $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $lsn ); + + while(@ready = $sel->can_read) { + foreach $fh (@ready) { + if($fh == $lsn) { + # Create a new socket + $new = $lsn->accept; + $sel->add($new); + } + else { + # Process socket + + # Maybe we have finished with the socket + $sel->remove($fh); + $fh->close; + } + } + } + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm index 2b4bc49..6884f02 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -1,129 +1,29 @@ # IO::Socket.pm # -# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights -# reserved. This program is free software; you can redistribute it and/or +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package IO::Socket; -=head1 NAME - -IO::Socket - Object interface to socket communications - -=head1 SYNOPSIS - - use IO::Socket; - -=head1 DESCRIPTION - -C<IO::Socket> provides an object interface to creating and using sockets. It -is built upon the L<IO::Handle> interface and inherits all the methods defined -by L<IO::Handle>. - -C<IO::Socket> only defines methods for those operations which are common to all -types of socket. Operations which are specified to a socket in a particular -domain have methods defined in sub classes of C<IO::Socket> - -C<IO::Socket> will export all functions (and constants) defined by L<Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket>, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. -C<new> only looks for one key C<Domain> which tells new which domain -the socket will be in. All other arguments will be passed to the -configuration method of the package for that domain, See below. - -C<IO::Socket>s will be in autoflush mode after creation. Note that -versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04) -did not do this. So if you need backward compatibility, you should -set autoflush explicitly. - -=back - -=head1 METHODS - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Socket> methods, which are just front ends for the -corresponding built-in functions: - - socket - socketpair - bind - listen - accept - send - recv - peername (getpeername) - sockname (getsockname) - -Some methods take slightly different arguments to those defined in L<perlfunc> -in attempt to make the interface more flexible. These are - -=over 4 - -=item accept([PKG]) - -perform the system call C<accept> on the socket and return a new object. The -new object will be created in the same class as the listen socket, unless -C<PKG> is specified. This object can be used to communicate with the client -that was trying to connect. In a scalar context the new socket is returned, -or undef upon failure. In an array context a two-element array is returned -containing the new socket and the peer address, the list will -be empty upon failure. - -Additional methods that are provided are - -=item timeout([VAL]) - -Set or get the timeout value associated with this socket. If called without -any arguments then the current setting is returned. If called with an argument -the current setting is changed and the previous value returned. - -=item sockopt(OPT [, VAL]) - -Unified method to both set and get options in the SOL_SOCKET level. If called -with one argument then getsockopt is called, otherwise setsockopt is called. - -=item sockdomain - -Returns the numerical number for the socket domain type. For example, for -a AF_INET socket the value of &AF_INET will be returned. - -=item socktype +require 5.005_64; -Returns the numerical number for the socket type. For example, for -a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. - -=item protocol - -Returns the numerical number for the protocol being used on the socket, if -known. If the protocol is unknown, as with an AF_UNIX socket, zero -is returned. - -=back - -=cut - - -require 5.000; - -use Config; use IO::Handle; use Socket 1.3; use Carp; use strict; -use vars qw(@ISA $VERSION); +our(@ISA, $VERSION); use Exporter; +use Errno; + +# legacy + +require IO::Socket::INET; +require IO::Socket::UNIX if ($^O ne 'epoc'); @ISA = qw(IO::Handle); -$VERSION = "1.1603"; +$VERSION = "1.26"; sub import { my $pkg = shift; @@ -133,16 +33,17 @@ sub import { sub new { my($class,%arg) = @_; - my $fh = $class->SUPER::new(); - $fh->autoflush; + my $sock = $class->SUPER::new(); - ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + $sock->autoflush(1); - return scalar(%arg) ? $fh->configure(\%arg) - : $fh; + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $sock->configure(\%arg) + : $sock; } -my @domain2pkg = (); +my @domain2pkg; sub register_domain { my($p,$d) = @_; @@ -150,7 +51,7 @@ sub register_domain { } sub configure { - my($fh,$arg) = @_; + my($sock,$arg) = @_; my $domain = delete $arg->{Domain}; croak 'IO::Socket: Cannot configure a generic socket' @@ -160,150 +61,167 @@ sub configure { unless defined $domain2pkg[$domain]; croak "IO::Socket: Cannot configure socket in domain '$domain'" - unless ref($fh) eq "IO::Socket"; + unless ref($sock) eq "IO::Socket"; - bless($fh, $domain2pkg[$domain]); - $fh->configure($arg); + bless($sock, $domain2pkg[$domain]); + $sock->configure($arg); } sub socket { - @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; - my($fh,$domain,$type,$protocol) = @_; + @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; + my($sock,$domain,$type,$protocol) = @_; - socket($fh,$domain,$type,$protocol) or + socket($sock,$domain,$type,$protocol) or return undef; - ${*$fh}{'io_socket_domain'} = $domain; - ${*$fh}{'io_socket_type'} = $type; - ${*$fh}{'io_socket_proto'} = $protocol; + ${*$sock}{'io_socket_domain'} = $domain; + ${*$sock}{'io_socket_type'} = $type; + ${*$sock}{'io_socket_proto'} = $protocol; - $fh; + $sock; } sub socketpair { - @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; + @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; my($class,$domain,$type,$protocol) = @_; - my $fh1 = $class->new(); - my $fh2 = $class->new(); + my $sock1 = $class->new(); + my $sock2 = $class->new(); - socketpair($fh1,$fh2,$domain,$type,$protocol) or + socketpair($sock1,$sock2,$domain,$type,$protocol) or return (); - ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; - ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; + ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; + ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; - ($fh1,$fh2); + ($sock1,$sock2); } sub connect { - @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)'; - my $fh = shift; - my $addr = @_ == 1 ? shift : sockaddr_in(@_); - my $timeout = ${*$fh}{'io_socket_timeout'}; - local($SIG{ALRM}) = $timeout ? sub { undef $fh; } - : $SIG{ALRM} || 'DEFAULT'; - - eval { - croak 'connect: Bad address' - if(@_ == 2 && !defined $_[1]); - - if($timeout) { - defined $Config{d_alarm} && defined alarm($timeout) or - $timeout = 0; - } - - my $ok = connect($fh, $addr); - - alarm(0) - if($timeout); + @_ == 2 or croak 'usage: $sock->connect(NAME)'; + my $sock = shift; + my $addr = shift; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $err; + my $blocking; + $blocking = $sock->blocking(0) if $timeout; + + if (!connect($sock, $addr)) { + if ($timeout && $!{EINPROGRESS}) { + require IO::Select; + + my $sel = new IO::Select $sock; + + if (!$sel->can_write($timeout)) { + $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + $@ = "connect: timeout"; + } + elsif(!connect($sock,$addr) && not $!{EISCONN}) { + # Some systems refuse to re-connect() to + # an already open socket and set errno to EISCONN. + $err = $!; + $@ = "connect: $!"; + } + } + else { + $err = $!; + $@ = "connect: $!"; + } + } - croak "connect: timeout" - unless defined $fh; + $sock->blocking(1) if $blocking; - undef $fh unless $ok; - }; + $! = $err if $err; - $fh; + $err ? undef : $sock; } sub bind { - @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; - my $fh = shift; - my $addr = @_ == 1 ? shift : sockaddr_in(@_); + @_ == 2 or croak 'usage: $sock->bind(NAME)'; + my $sock = shift; + my $addr = shift; - return bind($fh, $addr) ? $fh - : undef; + return bind($sock, $addr) ? $sock + : undef; } sub listen { - @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; - my($fh,$queue) = @_; + @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; + my($sock,$queue) = @_; $queue = 5 unless $queue && $queue > 0; - return listen($fh, $queue) ? $fh - : undef; + return listen($sock, $queue) ? $sock + : undef; } sub accept { - @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; - my $fh = shift; - my $pkg = shift || $fh; - my $timeout = ${*$fh}{'io_socket_timeout'}; + @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; + my $sock = shift; + my $pkg = shift || $sock; + my $timeout = ${*$sock}{'io_socket_timeout'}; my $new = $pkg->new(Timeout => $timeout); my $peer = undef; - eval { - if($timeout) { - my $fdset = ""; - vec($fdset, $fh->fileno,1) = 1; - croak "accept: timeout" - unless select($fdset,undef,undef,$timeout); - } - $peer = accept($new,$fh); - }; - - return wantarray ? defined $peer ? ($new, $peer) - : () - : defined $peer ? $new - : undef; + if($timeout) { + require IO::Select; + + my $sel = new IO::Select $sock; + + unless ($sel->can_read($timeout)) { + $@ = 'accept: timeout'; + $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + return; + } + } + + $peer = accept($new,$sock) + or return; + + return wantarray ? ($new, $peer) + : $new; } sub sockname { - @_ == 1 or croak 'usage: $fh->sockname()'; + @_ == 1 or croak 'usage: $sock->sockname()'; getsockname($_[0]); } sub peername { - @_ == 1 or croak 'usage: $fh->peername()'; - my($fh) = @_; - getpeername($fh) - || ${*$fh}{'io_socket_peername'} + @_ == 1 or croak 'usage: $sock->peername()'; + my($sock) = @_; + getpeername($sock) + || ${*$sock}{'io_socket_peername'} || undef; } +sub connected { + @_ == 1 or croak 'usage: $sock->connected()'; + my($sock) = @_; + getpeername($sock); +} + sub send { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; - my $fh = $_[0]; + @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; + my $sock = $_[0]; my $flags = $_[2] || 0; - my $peer = $_[3] || $fh->peername; + my $peer = $_[3] || $sock->peername; croak 'send: Cannot determine peer address' unless($peer); - my $r = defined(getpeername($fh)) - ? send($fh, $_[1], $flags) - : send($fh, $_[1], $flags, $peer); + my $r = defined(getpeername($sock)) + ? send($sock, $_[1], $flags) + : send($sock, $_[1], $flags, $peer); # remember who we send to, if it was sucessful - ${*$fh}{'io_socket_peername'} = $peer + ${*$sock}{'io_socket_peername'} = $peer if(@_ == 4 && defined $r); $r; } sub recv { - @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; + @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; my $sock = $_[0]; my $len = $_[2]; my $flags = $_[3] || 0; @@ -312,16 +230,21 @@ sub recv { ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); } +sub shutdown { + @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; + my($sock, $how) = @_; + shutdown($sock, $how); +} sub setsockopt { - @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; + @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; setsockopt($_[0],$_[1],$_[2],$_[3]); } my $intsize = length(pack("i",0)); sub getsockopt { - @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; + @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; my $r = getsockopt($_[0],$_[1],$_[2]); # Just a guess $r = unpack("i", $r) @@ -330,399 +253,176 @@ sub getsockopt { } sub sockopt { - my $fh = shift; - @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) - : $fh->setsockopt(SOL_SOCKET,@_); + my $sock = shift; + @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) + : $sock->setsockopt(SOL_SOCKET,@_); } sub timeout { - @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; - my($fh,$val) = @_; - my $r = ${*$fh}{'io_socket_timeout'} || undef; + @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; + my($sock,$val) = @_; + my $r = ${*$sock}{'io_socket_timeout'} || undef; - ${*$fh}{'io_socket_timeout'} = 0 + $val + ${*$sock}{'io_socket_timeout'} = 0 + $val if(@_ == 2); $r; } sub sockdomain { - @_ == 1 or croak 'usage: $fh->sockdomain()'; - my $fh = shift; - ${*$fh}{'io_socket_domain'}; + @_ == 1 or croak 'usage: $sock->sockdomain()'; + my $sock = shift; + ${*$sock}{'io_socket_domain'}; } sub socktype { - @_ == 1 or croak 'usage: $fh->socktype()'; - my $fh = shift; - ${*$fh}{'io_socket_type'} + @_ == 1 or croak 'usage: $sock->socktype()'; + my $sock = shift; + ${*$sock}{'io_socket_type'} } sub protocol { - @_ == 1 or croak 'usage: $fh->protocol()'; - my($fh) = @_; - ${*$fh}{'io_socket_protocol'}; + @_ == 1 or croak 'usage: $sock->protocol()'; + my($sock) = @_; + ${*$sock}{'io_socket_proto'}; } -=head1 SUB-CLASSES - -=cut - -## -## AF_INET -## - -package IO::Socket::INET; - -use strict; -use vars qw(@ISA); -use Socket; -use Carp; -use Exporter; - -@ISA = qw(IO::Socket); - -IO::Socket::INET->register_domain( AF_INET ); - -my %socket_type = ( tcp => SOCK_STREAM, - udp => SOCK_DGRAM, - icmp => SOCK_RAW, - ); - -=head2 IO::Socket::INET - -C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket -and some related methods. The constructor can take the following options - - PeerAddr Remote host address <hostname>[:<port>] - PeerPort Remote port or service <service>[(<no>)] | <no> - LocalAddr Local host bind address hostname[:port] - LocalPort Local host bind port <service>[(<no>)] | <no> - Proto Protocol name (or number) "tcp" | "udp" | ... - Type Socket type SOCK_STREAM | SOCK_DGRAM | ... - Listen Queue size for listen - Reuse Set SO_REUSEADDR before binding - Timeout Timeout value for various operations - +1; -If C<Listen> is defined then a listen socket is created, else if the -socket type, which is derived from the protocol, is SOCK_STREAM then -connect() is called. +__END__ -The C<PeerAddr> can be a hostname or the IP-address on the -"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic -service name. The service name might be followed by a number in -parenthesis which is used if the service is not known by the system. -The C<PeerPort> specification can also be embedded in the C<PeerAddr> -by preceding it with a ":". - -If C<Proto> is not given and you specify a symbolic C<PeerPort> port, -then the constructor will try to derive C<Proto> from the service -name. As a last resort C<Proto> "tcp" is assumed. The C<Type> -parameter will be deduced from C<Proto> if not specified. +=head1 NAME -If the constructor is only passed a single argument, it is assumed to -be a C<PeerAddr> specification. +IO::Socket - Object interface to socket communications -Examples: +=head1 SYNOPSIS - $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', - PeerPort => 'http(80)', - Proto => 'tcp'); + use IO::Socket; - $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); +=head1 DESCRIPTION - $sock = IO::Socket::INET->new(Listen => 5, - LocalAddr => 'localhost', - LocalPort => 9000, - Proto => 'tcp'); +C<IO::Socket> provides an object interface to creating and using sockets. It +is built upon the L<IO::Handle> interface and inherits all the methods defined +by L<IO::Handle>. - $sock = IO::Socket::INET->new('127.0.0.1:25'); +C<IO::Socket> only defines methods for those operations which are common to all +types of socket. Operations which are specified to a socket in a particular +domain have methods defined in sub classes of C<IO::Socket> +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. -=head2 METHODS +=head1 CONSTRUCTOR =over 4 -=item sockaddr () - -Return the address part of the sockaddr structure for the socket - -=item sockport () - -Return the port number that the socket is using on the local host - -=item sockhost () - -Return the address part of the sockaddr structure for the socket in a -text form xx.xx.xx.xx - -=item peeraddr () - -Return the address part of the sockaddr structure for the socket on -the peer host +=item new ( [ARGS] ) -=item peerport () +Creates an C<IO::Socket>, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. +C<new> only looks for one key C<Domain> which tells new which domain +the socket will be in. All other arguments will be passed to the +configuration method of the package for that domain, See below. -Return the port number for the socket on the peer host. + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE -=item peerhost () +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. -Return the address part of the sockaddr structure for the socket on the -peer host in a text form xx.xx.xx.xx + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE =back -=cut - -sub new -{ - my $class = shift; - unshift(@_, "PeerAddr") if @_ == 1; - return $class->SUPER::new(@_); -} - -sub _sock_info { - my($addr,$port,$proto) = @_; - my @proto = (); - my @serv = (); - - $port = $1 - if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); - - if(defined $proto) { - @proto = $proto =~ m,\D, ? getprotobyname($proto) - : getprotobynumber($proto); - - $proto = $proto[2] || undef; - } - - if(defined $port) { - $port =~ s,\((\d+)\)$,,; - - my $defport = $1 || undef; - my $pnum = ($port =~ m,^(\d+)$,)[0]; - - @serv= getservbyname($port, $proto[0] || "") - if($port =~ m,\D,); - - $port = $pnum || $serv[2] || $defport || undef; - - $proto = (getprotobyname($serv[3]))[2] || undef - if @serv && !$proto; - } - - return ($addr || undef, - $port || undef, - $proto || undef - ); -} - -sub _error { - my $fh = shift; - $@ = join("",ref($fh),": ",@_); - carp $@ if $^W; - close($fh) - if(defined fileno($fh)); - return undef; -} - -sub configure { - my($fh,$arg) = @_; - my($lport,$rport,$laddr,$raddr,$proto,$type); - - - ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, - $arg->{LocalPort}, - $arg->{Proto}); - - $laddr = defined $laddr ? inet_aton($laddr) - : INADDR_ANY; - - return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'") - unless(defined $laddr); - - unless(exists $arg->{Listen}) { - ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, - $arg->{PeerPort}, - $proto); - } - - if(defined $raddr) { - $raddr = inet_aton($raddr); - return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'") - unless(defined $raddr); - } - - $proto ||= (getprotobyname "tcp")[2]; - return _error($fh,'Cannot determine protocol') - unless($proto); - - my $pname = (getprotobynumber($proto))[0]; - $type = $arg->{Type} || $socket_type{$pname}; - - $fh->socket(AF_INET, $type, $proto) or - return _error($fh,"$!"); - - if ($arg->{Reuse}) { - $fh->sockopt(SO_REUSEADDR,1) or - return _error($fh); - } - - $fh->bind($lport || 0, $laddr) or - return _error($fh,"$!"); - - if(exists $arg->{Listen}) { - $fh->listen($arg->{Listen} || 5) or - return _error($fh,"$!"); - } - else { - return _error($fh,'Cannot determine remote port') - unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); - - if($type == SOCK_STREAM || defined $raddr) { - return _error($fh,'Bad peer address') - unless(defined $raddr); - - $fh->connect($rport,$raddr) or - return _error($fh,"$!"); - } - } - - $fh; -} - -sub sockaddr { - @_ == 1 or croak 'usage: $fh->sockaddr()'; - my($fh) = @_; - (sockaddr_in($fh->sockname))[1]; -} - -sub sockport { - @_ == 1 or croak 'usage: $fh->sockport()'; - my($fh) = @_; - (sockaddr_in($fh->sockname))[0]; -} - -sub sockhost { - @_ == 1 or croak 'usage: $fh->sockhost()'; - my($fh) = @_; - inet_ntoa($fh->sockaddr); -} - -sub peeraddr { - @_ == 1 or croak 'usage: $fh->peeraddr()'; - my($fh) = @_; - (sockaddr_in($fh->peername))[1]; -} - -sub peerport { - @_ == 1 or croak 'usage: $fh->peerport()'; - my($fh) = @_; - (sockaddr_in($fh->peername))[0]; -} +=head1 METHODS -sub peerhost { - @_ == 1 or croak 'usage: $fh->peerhost()'; - my($fh) = @_; - inet_ntoa($fh->peeraddr); -} +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Socket> methods, which are just front ends for the +corresponding built-in functions: -## -## AF_UNIX -## + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + shutdown -package IO::Socket::UNIX; +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are -use strict; -use vars qw(@ISA $VERSION); -use Socket; -use Carp; -use Exporter; +=over 4 -@ISA = qw(IO::Socket); +=item accept([PKG]) -IO::Socket::UNIX->register_domain( AF_UNIX ); +perform the system call C<accept> on the socket and return a new object. The +new object will be created in the same class as the listen socket, unless +C<PKG> is specified. This object can be used to communicate with the client +that was trying to connect. In a scalar context the new socket is returned, +or undef upon failure. In an array context a two-element array is returned +containing the new socket and the peer address; the list will +be empty upon failure. -=head2 IO::Socket::UNIX +=item socketpair(DOMAIN, TYPE, PROTOCOL) -C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket -and some related methods. The constructor can take the following options +Call C<socketpair> and return a list of two sockets created, or an +empty list on failure. - Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) - Local Path to local fifo - Peer Path to peer fifo - Listen Create a listen socket +=back -=head2 METHODS +Additional methods that are provided are: =over 4 -=item hostpath() +=item timeout([VAL]) -Returns the pathname to the fifo at the local end +Set or get the timeout value associated with this socket. If called without +any arguments then the current setting is returned. If called with an argument +the current setting is changed and the previous value returned. -=item peerpath() +=item sockopt(OPT [, VAL]) -Returns the pathname to the fifo at the peer end +Unified method to both set and get options in the SOL_SOCKET level. If called +with one argument then getsockopt is called, otherwise setsockopt is called. -=back +=item sockdomain -=cut +Returns the numerical number for the socket domain type. For example, for +a AF_INET socket the value of &AF_INET will be returned. -sub configure { - my($fh,$arg) = @_; - my($bport,$cport); +=item socktype - my $type = $arg->{Type} || SOCK_STREAM; +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. - $fh->socket(AF_UNIX, $type, 0) or - return undef; +=item protocol - if(exists $arg->{Local}) { - my $addr = sockaddr_un($arg->{Local}); - $fh->bind($addr) or - return undef; - } - if(exists $arg->{Listen}) { - $fh->listen($arg->{Listen} || 5) or - return undef; - } - elsif(exists $arg->{Peer}) { - my $addr = sockaddr_un($arg->{Peer}); - $fh->connect($addr) or - return undef; - } +Returns the numerical number for the protocol being used on the socket, if +known. If the protocol is unknown, as with an AF_UNIX socket, zero +is returned. - $fh; -} +=item connected -sub hostpath { - @_ == 1 or croak 'usage: $fh->hostpath()'; - my $n = $_[0]->sockname || return undef; - (sockaddr_un($n))[0]; -} +If the socket is in a connected state the the peer address is returned. +If the socket is not in a connected state then undef will be returned. -sub peerpath { - @_ == 1 or croak 'usage: $fh->peerpath()'; - my $n = $_[0]->peername || return undef; - (sockaddr_un($n))[0]; -} +=back =head1 SEE ALSO -L<Socket>, L<IO::Handle> +L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> =head1 AUTHOR -Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT -Copyright (c) 1996 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. =cut - -1; # Keep require happy diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm new file mode 100644 index 0000000..27a3d4d --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm @@ -0,0 +1,406 @@ +# IO::Socket::INET.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket::INET; + +use strict; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; +use Exporter; +use Errno; + +@ISA = qw(IO::Socket); +$VERSION = "1.25"; + +my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + icmp => SOCK_RAW + ); + +sub new { + my $class = shift; + unshift(@_, "PeerAddr") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub _sock_info { + my($addr,$port,$proto) = @_; + my @proto = (); + my @serv = (); + + $port = $1 + if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); + + if(defined $proto) { + if (@proto = ( $proto =~ m,\D, + ? getprotobyname($proto) + : getprotobynumber($proto)) + ) { + $proto = $proto[2] || undef; + } + else { + $@ = "Bad protocol '$proto'"; + return; + } + } + + if(defined $port) { + $port =~ s,\((\d+)\)$,,; + + my $defport = $1 || undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + if ($port =~ m,\D,) { + unless (@serv = getservbyname($port, $proto[0] || "")) { + $@ = "Bad service '$port'"; + return; + } + } + + $port = $pnum || $serv[2] || $defport || undef; + + $proto = (getprotobyname($serv[3]))[2] || undef + if @serv && !$proto; + } + + return ($addr || undef, + $port || undef, + $proto || undef + ); +} + +sub _error { + my $sock = shift; + my $err = shift; + { + local($!); + $@ = join("",ref($sock),": ",@_); + close($sock) + if(defined fileno($sock)); + } + $! = $err; + return undef; +} + +sub _get_addr { + my($sock,$addr_str, $multi) = @_; + my @addr; + if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) { + (undef, undef, undef, undef, @addr) = gethostbyname($addr_str); + } else { + my $h = inet_aton($addr_str); + push(@addr, $h) if defined $h; + } + @addr; +} + +sub configure { + my($sock,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + $arg->{LocalAddr} = $arg->{LocalHost} + if exists $arg->{LocalHost} && !exists $arg->{LocalAddr}; + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}) + or return _error($sock, $!, $@); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + $arg->{PeerAddr} = $arg->{PeerHost} + if exists $arg->{PeerHost} && !exists $arg->{PeerAddr}; + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto) + or return _error($sock, $!, $@); + } + + $proto ||= (getprotobyname('tcp'))[2]; + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{$pname}; + + my @raddr = (); + + if(defined $raddr) { + @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed}); + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless @raddr; + } + + while(1) { + + $sock->socket(AF_INET, $type, $proto) or + return _error($sock, $!, "$!"); + + if ($arg->{Reuse}) { + $sock->sockopt(SO_REUSEADDR,1) or + return _error($sock, $!, "$!"); + } + + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { + $sock->bind($lport || 0, $laddr) or + return _error($sock, $!, "$!"); + } + + if(exists $arg->{Listen}) { + $sock->listen($arg->{Listen} || 5) or + return _error($sock, $!, "$!"); + last; + } + + # don't try to connect unless we're given a PeerAddr + last unless exists($arg->{PeerAddr}); + + $raddr = shift @raddr; + + return _error($sock, $EINVAL, 'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); + + last + unless($type == SOCK_STREAM || defined $raddr); + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless defined $raddr; + +# my $timeout = ${*$sock}{'io_socket_timeout'}; +# my $before = time() if $timeout; + + if ($sock->connect(pack_sockaddr_in($rport, $raddr))) { +# ${*$sock}{'io_socket_timeout'} = $timeout; + return $sock; + } + + return _error($sock, $!, "Timeout") + unless @raddr; + +# if ($timeout) { +# my $new_timeout = $timeout - (time() - $before); +# return _error($sock, +# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL), +# "Timeout") if $new_timeout <= 0; +# ${*$sock}{'io_socket_timeout'} = $new_timeout; +# } + + } + + $sock; +} + +sub connect { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_)); +} + +sub bind { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_)) +} + +sub sockaddr { + @_ == 1 or croak 'usage: $sock->sockaddr()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub sockport { + @_ == 1 or croak 'usage: $sock->sockport()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub sockhost { + @_ == 1 or croak 'usage: $sock->sockhost()'; + my($sock) = @_; + my $addr = $sock->sockaddr; + $addr ? inet_ntoa($addr) : undef; +} + +sub peeraddr { + @_ == 1 or croak 'usage: $sock->peeraddr()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub peerport { + @_ == 1 or croak 'usage: $sock->peerport()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub peerhost { + @_ == 1 or croak 'usage: $sock->peerhost()'; + my($sock) = @_; + my $addr = $sock->peeraddr; + $addr ? inet_ntoa($addr) : undef; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket::INET - Object interface for AF_INET domain sockets + +=head1 SYNOPSIS + + use IO::Socket::INET; + +=head1 DESCRIPTION + +C<IO::Socket::INET> provides an object interface to creating and using sockets +in the AF_INET domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::INET> object, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::INET> provides. + + + PeerAddr Remote host address <hostname>[:<port>] + PeerHost Synonym for PeerAddr + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalHost Synonym for LocalAddr + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name (or number) "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + Reuse Set SO_REUSEADDR before binding + Timeout Timeout value for various operations + MultiHomed Try all adresses for multi-homed hosts + + +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. + +Although it is not illegal, the use of C<MultiHomed> on a socket +which is in non-blocking mode is of little use. This is because the +first connect will never fail with a timeout as the connaect call +will not block. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +If C<Proto> is not given and you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Proto> from the service +name. As a last resort C<Proto> "tcp" is assumed. The C<Type> +parameter will be deduced from C<Proto> if not specified. + +If the constructor is only passed a single argument, it is assumed to +be a C<PeerAddr> specification. + +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => 'http(80)', + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); + + $sock = IO::Socket::INET->new('127.0.0.1:25'); + + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head2 METHODS + +=over 4 + +=item sockaddr () + +Return the address part of the sockaddr structure for the socket + +=item sockport () + +Return the port number that the socket is using on the local host + +=item sockhost () + +Return the address part of the sockaddr structure for the socket in a +text form xx.xx.xx.xx + +=item peeraddr () + +Return the address part of the sockaddr structure for the socket on +the peer host + +=item peerport () + +Return the port number for the socket on the peer host. + +=item peerhost () + +Return the address part of the sockaddr structure for the socket on the +peer host in a text form xx.xx.xx.xx + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm new file mode 100644 index 0000000..d083f48 --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm @@ -0,0 +1,143 @@ +# IO::Socket::UNIX.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket::UNIX; + +use strict; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; + +@ISA = qw(IO::Socket); +$VERSION = "1.20"; + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +sub new { + my $class = shift; + unshift(@_, "Peer") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub configure { + my($sock,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $sock->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $sock->bind($addr) or + return undef; + } + if(exists $arg->{Listen}) { + $sock->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $sock->connect($addr) or + return undef; + } + + $sock; +} + +sub hostpath { + @_ == 1 or croak 'usage: $sock->hostpath()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $sock->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +1; # Keep require happy + +__END__ + +=head1 NAME + +IO::Socket::UNIX - Object interface for AF_UNIX domain sockets + +=head1 SYNOPSIS + + use IO::Socket::UNIX; + +=head1 DESCRIPTION + +C<IO::Socket::UNIX> provides an object interface to creating and using sockets +in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::UNIX> object, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::UNIX> provides. + + Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) + Local Path to local fifo + Peer Path to peer fifo + Listen Create a listen socket + +If the constructor is only passed a single argument, it is assumed to +be a C<Peer> specification. + + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head1 METHODS + +=over 4 + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/contrib/perl5/ext/IO/poll.c b/contrib/perl5/ext/IO/poll.c new file mode 100644 index 0000000..024c52f --- /dev/null +++ b/contrib/perl5/ext/IO/poll.c @@ -0,0 +1,135 @@ +/* + * poll.c + * + * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + * + * For systems that do not have the poll() system call (for example Linux + * kernels < v2.1.23) try to emulate it as closely as possible using select() + * + */ + +#include "EXTERN.h" +#include "perl.h" +#include "poll.h" +#ifdef I_SYS_TIME +# include <sys/time.h> +#endif +#ifdef I_TIME +# include <time.h> +#endif +#include <sys/types.h> +#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */ +# include <sys/socket.h> +#endif +#include <sys/stat.h> +#include <errno.h> + +#ifdef HAS_SELECT +#ifdef I_SYS_SELECT +#include <sys/select.h> +#endif +#endif + +#ifdef EMULATE_POLL_WITH_SELECT + +# define POLL_CAN_READ (POLLIN | POLLRDNORM ) +# define POLL_CAN_WRITE (POLLOUT | POLLWRNORM | POLLWRBAND ) +# define POLL_HAS_EXCP (POLLRDBAND | POLLPRI ) + +# define POLL_EVENTS_MASK (POLL_CAN_READ | POLL_CAN_WRITE | POLL_HAS_EXCP) + +int +poll(struct pollfd *fds, unsigned long nfds, int timeout) +{ + int i,err; + fd_set rfd,wfd,efd,ifd; + struct timeval timebuf; + struct timeval *tbuf = (struct timeval *)0; + int n = 0; + int count; + + FD_ZERO(&ifd); + +again: + + FD_ZERO(&rfd); + FD_ZERO(&wfd); + FD_ZERO(&efd); + + for(i = 0 ; i < nfds ; i++) { + int events = fds[i].events; + int fd = fds[i].fd; + + fds[i].revents = 0; + + if(fd < 0 || FD_ISSET(fd, &ifd)) + continue; + + if(fd > n) + n = fd; + + if(events & POLL_CAN_READ) + FD_SET(fd, &rfd); + + if(events & POLL_CAN_WRITE) + FD_SET(fd, &wfd); + + if(events & POLL_HAS_EXCP) + FD_SET(fd, &efd); + } + + if(timeout >= 0) { + timebuf.tv_sec = timeout / 1000; + timebuf.tv_usec = (timeout % 1000) * 1000; + tbuf = &timebuf; + } + + err = select(n+1,&rfd,&wfd,&efd,tbuf); + + if(err < 0) { +#ifdef HAS_FSTAT + if(errno == EBADF) { + for(i = 0 ; i < nfds ; i++) { + struct stat buf; + if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) { + FD_SET(fds[i].fd, &ifd); + goto again; + } + } + } +#endif /* HAS_FSTAT */ + return err; + } + + count = 0; + + for(i = 0 ; i < nfds ; i++) { + int revents = (fds[i].events & POLL_EVENTS_MASK); + int fd = fds[i].fd; + + if(fd < 0) + continue; + + if(FD_ISSET(fd, &ifd)) + revents = POLLNVAL; + else { + if(!FD_ISSET(fd, &rfd)) + revents &= ~POLL_CAN_READ; + + if(!FD_ISSET(fd, &wfd)) + revents &= ~POLL_CAN_WRITE; + + if(!FD_ISSET(fd, &efd)) + revents &= ~POLL_HAS_EXCP; + } + + if((fds[i].revents = revents) != 0) + count++; + } + + return count; +} + +#endif /* EMULATE_POLL_WITH_SELECT */ diff --git a/contrib/perl5/ext/IO/poll.h b/contrib/perl5/ext/IO/poll.h new file mode 100644 index 0000000..4055b49 --- /dev/null +++ b/contrib/perl5/ext/IO/poll.h @@ -0,0 +1,55 @@ +/* + * poll.h + * + * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + * + */ + +#ifndef POLL_H +# define POLL_H + +#if (defined(HAS_POLL) && defined(I_POLL)) || defined(POLLWRBAND) +# include <poll.h> +#else +#ifdef HAS_SELECT + + +/* We shall emulate poll using select */ + +#define EMULATE_POLL_WITH_SELECT + +typedef struct pollfd { + int fd; + short events; + short revents; +} pollfd_t; + +#define POLLIN 0x0001 +#define POLLPRI 0x0002 +#define POLLOUT 0x0004 +#define POLLRDNORM 0x0040 +#define POLLWRNORM POLLOUT +#define POLLRDBAND 0x0080 +#define POLLWRBAND 0x0100 +#define POLLNORM POLLRDNORM + +/* Return ONLY events (NON testable) */ + +#define POLLERR 0x0008 +#define POLLHUP 0x0010 +#define POLLNVAL 0x0020 + +int poll (struct pollfd *, unsigned long, int); + +#ifndef HAS_POLL +# define HAS_POLL +#endif + +#endif /* HAS_SELECT */ + +#endif /* I_POLL */ + +#endif /* POLL_H */ + diff --git a/contrib/perl5/ext/IPC/SysV/Msg.pm b/contrib/perl5/ext/IPC/SysV/Msg.pm index a739ca2..120a5b2 100644 --- a/contrib/perl5/ext/IPC/SysV/Msg.pm +++ b/contrib/perl5/ext/IPC/SysV/Msg.pm @@ -90,14 +90,14 @@ sub rcv { msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or return; my $type; - ($type,$_[0]) = unpack("L a*",$buf); + ($type,$_[0]) = unpack("l! a*",$buf); $type; } sub snd { @_ <= 4 && @_ >= 3 or croak '$msg->snd( TYPE, BUF, FLAGS )'; my $self = shift; - msgsnd($$self,pack("L a*",$_[0],$_[1]), $_[2] || 0); + msgsnd($$self,pack("l! a*",$_[0],$_[1]), $_[2] || 0); } @@ -111,17 +111,17 @@ IPC::Msg - SysV Msg IPC object class =head1 SYNOPSIS - use IPC::SysV qw(IPC_PRIVATE S_IRWXU S_IRWXG S_IRWXO); + use IPC::SysV qw(IPC_PRIVATE S_IRWXU); use IPC::Msg; - - $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO); - - $msg->snd(pack("L a*",$msgtype,$msg)); - + + $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU); + + $msg->snd(pack("l! a*",$msgtype,$msg)); + $msg->rcv($buf,256); - + $ds = $msg->stat; - + $msg->remove; =head1 DESCRIPTION @@ -157,8 +157,8 @@ Returns the system message queue identifier. =item rcv ( BUF, LEN [, TYPE [, FLAGS ]] ) -Read a message from the queue. Returns the type of the message read. See -L<msgrcv> +Read a message from the queue. Returns the type of the message read. +See L<msgrcv>. The BUF becomes tainted. =item remove diff --git a/contrib/perl5/ext/IPC/SysV/Semaphore.pm b/contrib/perl5/ext/IPC/SysV/Semaphore.pm index 464eb0b..faf7411 100644 --- a/contrib/perl5/ext/IPC/SysV/Semaphore.pm +++ b/contrib/perl5/ext/IPC/SysV/Semaphore.pm @@ -155,19 +155,19 @@ IPC::Semaphore - SysV Semaphore IPC object class use IPC::SysV qw(IPC_PRIVATE S_IRWXU IPC_CREAT); use IPC::Semaphore; - + $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | IPC_CREAT); - + $sem->setall( (0) x 10); - + @sem = $sem->getall; - + $ncnt = $sem->getncnt; - + $zcnt = $sem->getzcnt; - + $ds = $sem->stat; - + $sem->remove; =head1 DESCRIPTION diff --git a/contrib/perl5/ext/IPC/SysV/SysV.pm b/contrib/perl5/ext/IPC/SysV/SysV.pm index eb24593..bebb8fd 100644 --- a/contrib/perl5/ext/IPC/SysV/SysV.pm +++ b/contrib/perl5/ext/IPC/SysV/SysV.pm @@ -74,11 +74,15 @@ C<IPC::SysV> defines and conditionally exports all the constants defined in your system include files which are needed by the SysV IPC calls. +=over + =item ftok( PATH, ID ) Return a key based on PATH and ID, which can be used as a key for C<msgget>, C<semget> and C<shmget>. See L<ftok> +=back + =head1 SEE ALSO L<IPC::Msg>, L<IPC::Semaphore>, L<ftok> diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs index ecd5270..38062e0 100644 --- a/contrib/perl5/ext/IPC/SysV/SysV.xs +++ b/contrib/perl5/ext/IPC/SysV/SysV.xs @@ -19,7 +19,7 @@ # endif # include <sys/shm.h> # ifndef HAS_SHMAT_PROTOTYPE - extern Shmat_t shmat _((int, char *, int)); + extern Shmat_t shmat (int, char *, int); # endif # if defined(__sparc__) && (defined(__NetBSD__) || defined(__OpenBSD__)) # undef SHMLBA /* not static: determined at boot time */ @@ -30,7 +30,7 @@ /* Required to get 'struct pte' for SHMLBA on ULTRIX. */ #if defined(__ultrix) || defined(__ultrix__) || defined(ultrix) -# include <machine/pte.h> +#include <machine/pte.h> #endif /* Required in BSDI to get PAGE_SIZE definition for SHMLBA. @@ -69,7 +69,7 @@ PPCODE: sv = *av_fetch(list,1,TRUE); ds.msg_perm.gid = SvIV(sv); sv = *av_fetch(list,4,TRUE); ds.msg_perm.mode = SvIV(sv); sv = *av_fetch(list,6,TRUE); ds.msg_qbytes = SvIV(sv); - ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds))); + ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds))); XSRETURN(1); #else croak("System V msgxxx is not implemented on this machine"); @@ -185,7 +185,7 @@ PPCODE: ds.sem_otime = SvIV(*sv_ptr); if((sv_ptr = av_fetch(list,7,TRUE)) && (sv = *sv_ptr)) ds.sem_nsems = SvIV(*sv_ptr); - ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds))); + ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds))); XSRETURN(1); #else croak("System V semxxx is not implemented on this machine"); @@ -203,7 +203,7 @@ ftok(path, id) key_t k = ftok(path, id); ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k)); #else - DIE(no_func, "ftok"); + DIE(PL_no_func, "ftok"); #endif int diff --git a/contrib/perl5/ext/IPC/SysV/hints/cygwin.pl b/contrib/perl5/ext/IPC/SysV/hints/cygwin.pl new file mode 100644 index 0000000..e1a1dea --- /dev/null +++ b/contrib/perl5/ext/IPC/SysV/hints/cygwin.pl @@ -0,0 +1,2 @@ +# SysV IPC is an optional Cygwin package +$self->{LIBS} = ['-lcygipc'] diff --git a/contrib/perl5/ext/IPC/SysV/hints/next_3.pl b/contrib/perl5/ext/IPC/SysV/hints/next_3.pl new file mode 100644 index 0000000..2290ac7 --- /dev/null +++ b/contrib/perl5/ext/IPC/SysV/hints/next_3.pl @@ -0,0 +1 @@ +$self->{CCFLAGS} = $Config{ccflags} . ' -D_POSIX_SOURCE' ; diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.pm b/contrib/perl5/ext/NDBM_File/NDBM_File.pm index ed4fe2b..f98669f 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.pm +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.pm @@ -5,16 +5,14 @@ BEGIN { use strict; } } -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.03"; -$VERSION = "1.01"; - -bootstrap NDBM_File $VERSION; +XSLoader::load 'NDBM_File', $VERSION; 1; @@ -35,6 +33,6 @@ NDBM_File - Tied access to ndbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.xs b/contrib/perl5/ext/NDBM_File/NDBM_File.xs index d129a9c..49a1db5 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.xs +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.xs @@ -3,39 +3,80 @@ #include "XSUB.h" #include <ndbm.h> -typedef DBM* NDBM_File; -#define dbm_TIEHASH(dbtype,filename,flags,mode) dbm_open(filename,flags,mode) -#define dbm_FETCH(db,key) dbm_fetch(db,key) -#define dbm_STORE(db,key,value,flags) dbm_store(db,key,value,flags) -#define dbm_DELETE(db,key) dbm_delete(db,key) -#define dbm_FIRSTKEY(db) dbm_firstkey(db) -#define dbm_NEXTKEY(db,key) dbm_nextkey(db) +typedef struct { + DBM * dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } NDBM_File_type; -MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_ +typedef NDBM_File_type * NDBM_File ; +typedef datum datum_key ; +typedef datum datum_value ; + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + + +MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = ndbm_ NDBM_File -dbm_TIEHASH(dbtype, filename, flags, mode) +ndbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype char * filename int flags int mode + CODE: + { + DBM * dbp ; + + RETVAL = NULL ; + if (dbp = dbm_open(filename, flags, mode)) { + RETVAL = (NDBM_File)safemalloc(sizeof(NDBM_File_type)) ; + Zero(RETVAL, 1, NDBM_File_type) ; + RETVAL->dbp = dbp ; + } + + } + OUTPUT: + RETVAL void -dbm_DESTROY(db) +ndbm_DESTROY(db) NDBM_File db CODE: - dbm_close(db); + dbm_close(db->dbp); + safefree(db); -datum -dbm_FETCH(db, key) +#define ndbm_FETCH(db,key) dbm_fetch(db->dbp,key) +datum_value +ndbm_FETCH(db, key) NDBM_File db - datum key + datum_key key +#define ndbm_STORE(db,key,value,flags) dbm_store(db->dbp,key,value,flags) int -dbm_STORE(db, key, value, flags = DBM_REPLACE) +ndbm_STORE(db, key, value, flags = DBM_REPLACE) NDBM_File db - datum key - datum value + datum_key key + datum_value value int flags CLEANUP: if (RETVAL) { @@ -43,28 +84,85 @@ dbm_STORE(db, key, value, flags = DBM_REPLACE) croak("No write permission to ndbm file"); croak("ndbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.dptr); - dbm_clearerr(db); + dbm_clearerr(db->dbp); } +#define ndbm_DELETE(db,key) dbm_delete(db->dbp,key) int -dbm_DELETE(db, key) +ndbm_DELETE(db, key) NDBM_File db - datum key + datum_key key -datum -dbm_FIRSTKEY(db) +#define ndbm_FIRSTKEY(db) dbm_firstkey(db->dbp) +datum_key +ndbm_FIRSTKEY(db) NDBM_File db -datum -dbm_NEXTKEY(db, key) +#define ndbm_NEXTKEY(db,key) dbm_nextkey(db->dbp) +datum_key +ndbm_NEXTKEY(db, key) NDBM_File db - datum key + datum_key key +#define ndbm_error(db) dbm_error(db->dbp) int -dbm_error(db) +ndbm_error(db) NDBM_File db +#define ndbm_clearerr(db) dbm_clearerr(db->dbp) void -dbm_clearerr(db) +ndbm_clearerr(db) + NDBM_File db + + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = NULL ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + + +SV * +filter_fetch_key(db, code) + NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) NDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; diff --git a/contrib/perl5/ext/NDBM_File/hints/cygwin.pl b/contrib/perl5/ext/NDBM_File/hints/cygwin.pl new file mode 100644 index 0000000..0a4b762 --- /dev/null +++ b/contrib/perl5/ext/NDBM_File/hints/cygwin.pl @@ -0,0 +1,2 @@ +# uses GDBM ndbm compatibility feature +$self->{LIBS} = ['-lgdbm']; diff --git a/contrib/perl5/ext/NDBM_File/hints/sco.pl b/contrib/perl5/ext/NDBM_File/hints/sco.pl new file mode 100644 index 0000000..f551578 --- /dev/null +++ b/contrib/perl5/ext/NDBM_File/hints/sco.pl @@ -0,0 +1,4 @@ +# SCO ODT 3.2v4.2 has a -ldbm library that is missing dbmclose. +# This system should have a complete library installed as -ldbm.nfs which +# should be used instead (Probably need the networking product add-on) +$self->{LIBS} = ['-lndbm',-e "/usr/lib/libdbm.nfs.a"?'-ldbm.nfs':'-ldbm']; diff --git a/contrib/perl5/ext/NDBM_File/typemap b/contrib/perl5/ext/NDBM_File/typemap index 317a8f3..eeb5d59 100644 --- a/contrib/perl5/ext/NDBM_File/typemap +++ b/contrib/perl5/ext/NDBM_File/typemap @@ -2,7 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM +datum_key T_DATUM_K +datum_value T_DATUM_V gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ @@ -13,14 +14,23 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; T_GDATUM UNIMPLEMENTED OUTPUT -T_DATUM +T_DATUM_K + sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.pm b/contrib/perl5/ext/ODBM_File/ODBM_File.pm index 923640f..57fe4c3 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.pm +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.pm @@ -1,16 +1,14 @@ package ODBM_File; use strict; -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.02"; -$VERSION = "1.00"; - -bootstrap ODBM_File $VERSION; +XSLoader::load 'ODBM_File', $VERSION; 1; @@ -30,6 +28,6 @@ ODBM_File - Tied access to odbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.xs b/contrib/perl5/ext/ODBM_File/ODBM_File.xs index 892c038..150f2ef 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.xs +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.xs @@ -2,9 +2,6 @@ #include "perl.h" #include "XSUB.h" -#ifdef NULL -#undef NULL /* XXX Why? */ -#endif #ifdef I_DBM # include <dbm.h> #else @@ -30,7 +27,37 @@ #include <fcntl.h> -typedef void* ODBM_File; +typedef struct { + void * dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } ODBM_File_type; + +typedef ODBM_File_type * ODBM_File ; +typedef datum datum_key ; +typedef datum datum_value ; + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + #define odbm_FETCH(db,key) fetch(key) #define odbm_STORE(db,key,value,flags) store(key,value) @@ -46,10 +73,6 @@ static int dbmrefcnt; MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ -#ifndef NULL -# define NULL 0 -#endif - ODBM_File odbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype @@ -59,6 +82,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode) CODE: { char *tmpbuf; + void * dbp ; if (dbmrefcnt++) croak("Old dbm can only open one database"); New(0, tmpbuf, strlen(filename) + 5, char); @@ -75,7 +99,10 @@ odbm_TIEHASH(dbtype, filename, flags, mode) else croak("ODBM_FILE: Can't open %s", filename); } - RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); + dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); + RETVAL = (ODBM_File)safemalloc(sizeof(ODBM_File_type)) ; + Zero(RETVAL, 1, ODBM_File_type) ; + RETVAL->dbp = dbp ; ST(0) = sv_mortalcopy(&PL_sv_undef); sv_setptrobj(ST(0), RETVAL, dbtype); } @@ -86,17 +113,18 @@ DESTROY(db) CODE: dbmrefcnt--; dbmclose(); + safefree(db); -datum +datum_value odbm_FETCH(db, key) ODBM_File db - datum key + datum_key key int odbm_STORE(db, key, value, flags = DBM_REPLACE) ODBM_File db - datum key - datum value + datum_key key + datum_value value int flags CLEANUP: if (RETVAL) { @@ -109,14 +137,66 @@ odbm_STORE(db, key, value, flags = DBM_REPLACE) int odbm_DELETE(db, key) ODBM_File db - datum key + datum_key key -datum +datum_key odbm_FIRSTKEY(db) ODBM_File db -datum +datum_key odbm_NEXTKEY(db, key) ODBM_File db - datum key + datum_key key + + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = Nullsv ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + + +SV * +filter_fetch_key(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; diff --git a/contrib/perl5/ext/ODBM_File/hints/cygwin.pl b/contrib/perl5/ext/ODBM_File/hints/cygwin.pl new file mode 100644 index 0000000..a0d33c8 --- /dev/null +++ b/contrib/perl5/ext/ODBM_File/hints/cygwin.pl @@ -0,0 +1,2 @@ +# uses GDBM dbm compatibility feature +$self->{LIBS} = ['-lgdbm']; diff --git a/contrib/perl5/ext/ODBM_File/hints/sco.pl b/contrib/perl5/ext/ODBM_File/hints/sco.pl index 4664f2b..f551578 100644 --- a/contrib/perl5/ext/ODBM_File/hints/sco.pl +++ b/contrib/perl5/ext/ODBM_File/hints/sco.pl @@ -1,4 +1,4 @@ -# Some versions of SCO contain a broken -ldbm library that is missing -# dbmclose. Some of those might have a fixed library installed as -# -ldbm.nfs. -$self->{LIBS} = ['-ldbm.nfs', '-ldbm']; +# SCO ODT 3.2v4.2 has a -ldbm library that is missing dbmclose. +# This system should have a complete library installed as -ldbm.nfs which +# should be used instead (Probably need the networking product add-on) +$self->{LIBS} = ['-lndbm',-e "/usr/lib/libdbm.nfs.a"?'-ldbm.nfs':'-ldbm']; diff --git a/contrib/perl5/ext/ODBM_File/typemap b/contrib/perl5/ext/ODBM_File/typemap index 5e12e73..7c23815 100644 --- a/contrib/perl5/ext/ODBM_File/typemap +++ b/contrib/perl5/ext/ODBM_File/typemap @@ -2,7 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM +datum_key T_DATUM_K +datum_value T_DATUM_V gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ @@ -13,13 +14,22 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; T_GDATUM UNIMPLEMENTED OUTPUT -T_DATUM +T_DATUM_K + sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); diff --git a/contrib/perl5/ext/Opcode/Opcode.pm b/contrib/perl5/ext/Opcode/Opcode.pm index 0ee6be6..9338d39 100644 --- a/contrib/perl5/ext/Opcode/Opcode.pm +++ b/contrib/perl5/ext/Opcode/Opcode.pm @@ -1,8 +1,8 @@ package Opcode; -require 5.002; +require 5.005_64; -use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK); +our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); $VERSION = "1.04"; $XS_VERSION = "1.03"; @@ -10,8 +10,8 @@ $XS_VERSION = "1.03"; use strict; use Carp; use Exporter (); -use DynaLoader (); -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); BEGIN { @EXPORT_OK = qw( @@ -28,7 +28,7 @@ sub opset_to_hex ($); sub opdump (;$); use subs @EXPORT_OK; -bootstrap Opcode $XS_VERSION; +XSLoader::load 'Opcode', $XS_VERSION; _init_optags(); @@ -130,7 +130,7 @@ Your mileage will vary. If in any doubt B<do not use it>. =head1 Operator Names and Operator Lists The canonical list of operator names is the contents of the array -op_name defined and initialised in file F<opcode.h> of the Perl +PL_op_name defined and initialised in file F<opcode.h> of the Perl source distribution (and installed into the perl library). Each operator has both a terse name (its opname) and a more verbose or @@ -332,11 +332,11 @@ invert_opset function. cond_expr flip flop andassign orassign and or xor - warn die lineseq nextstate unstack scope enter leave + warn die lineseq nextstate scope enter leave setstate rv2cv anoncode prototype - entersub leavesub return method -- XXX loops via recursion? + entersub leavesub leavesublv return method method_named -- XXX loops via recursion? leaveeval -- needed for Safe to operate, is safe without entereval @@ -365,7 +365,7 @@ used to implement a resource attack (e.g., consume all available CPU time). grepstart grepwhile mapstart mapwhile enteriter iter - enterloop leaveloop + enterloop leaveloop unstack last next redo goto diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs index e93b900..581cbc9 100644 --- a/contrib/perl5/ext/Opcode/Opcode.xs +++ b/contrib/perl5/ext/Opcode/Opcode.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -11,11 +12,11 @@ static SV *opset_all; /* mask with all bits set */ static IV opset_len; /* length of opmasks in bytes */ static int opcode_debug = 0; -static SV *new_opset _((SV *old_opset)); -static int verify_opset _((SV *opset, int fatal)); -static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname)); -static void put_op_bitspec _((char *optag, STRLEN len, SV *opset)); -static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal)); +static SV *new_opset (pTHX_ SV *old_opset); +static int verify_opset (pTHX_ SV *opset, int fatal); +static void set_opset_bits (pTHX_ char *bitmap, SV *bitspec, int on, char *opname); +static void put_op_bitspec (pTHX_ char *optag, STRLEN len, SV *opset); +static SV *get_op_bitspec (pTHX_ char *opname, STRLEN len, int fatal); /* Initialise our private op_named_bits HV. @@ -27,7 +28,7 @@ static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal)); */ static void -op_names_init(void) +op_names_init(pTHX) { int i; STRLEN len; @@ -43,16 +44,16 @@ op_names_init(void) hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0); } - put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv))); + put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv))); - opset_all = new_opset(Nullsv); + opset_all = new_opset(aTHX_ Nullsv); bitmap = SvPV(opset_all, len); i = len-1; /* deal with last byte specially, see below */ while(i-- > 0) bitmap[i] = 0xFF; /* Take care to set the right number of bits in the last byte */ bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF; - put_op_bitspec(":all",0, opset_all); /* don't mortalise */ + put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */ } @@ -62,10 +63,10 @@ op_names_init(void) */ static void -put_op_bitspec(char *optag, STRLEN len, SV *mask) +put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask) { SV **svp; - verify_opset(mask,1); + verify_opset(aTHX_ mask,1); if (!len) len = strlen(optag); svp = hv_fetch(op_named_bits, optag, len, 1); @@ -83,7 +84,7 @@ put_op_bitspec(char *optag, STRLEN len, SV *mask) */ static SV * -get_op_bitspec(char *opname, STRLEN len, int fatal) +get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal) { SV **svp; if (!len) @@ -106,11 +107,11 @@ get_op_bitspec(char *opname, STRLEN len, int fatal) static SV * -new_opset(SV *old_opset) +new_opset(pTHX_ SV *old_opset) { SV *opset; if (old_opset) { - verify_opset(old_opset,1); + verify_opset(aTHX_ old_opset,1); opset = newSVsv(old_opset); } else { @@ -125,7 +126,7 @@ new_opset(SV *old_opset) static int -verify_opset(SV *opset, int fatal) +verify_opset(pTHX_ SV *opset, int fatal) { char *err = Nullch; if (!SvOK(opset)) err = "undefined"; @@ -139,7 +140,7 @@ verify_opset(SV *opset, int fatal) static void -set_opset_bits(char *bitmap, SV *bitspec, int on, char *opname) +set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname) { if (SvIOK(bitspec)) { int myopcode = SvIV(bitspec); @@ -173,14 +174,14 @@ set_opset_bits(char *bitmap, SV *bitspec, int on, char *opname) static void -opmask_add(SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ +opmask_add(pTHX_ SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ { int i,j; char *bitmask; STRLEN len; int myopcode = 0; - verify_opset(opset,1); /* croaks on bad opset */ + verify_opset(aTHX_ opset,1); /* croaks on bad opset */ if (!PL_op_mask) /* caller must ensure PL_op_mask exists */ croak("Can't add to uninitialised PL_op_mask"); @@ -200,23 +201,23 @@ opmask_add(SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ } static void -opmask_addlocal(SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ +opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ { char *orig_op_mask = PL_op_mask; - SAVEPPTR(PL_op_mask); + SAVEVPTR(PL_op_mask); #if !defined(PERL_OBJECT) /* XXX casting to an ordinary function ptr from a member function ptr * is disallowed by Borland */ if (opcode_debug >= 2) - SAVEDESTRUCTOR((void(CPERLscope(*))_((void*)))warn,"PL_op_mask restored"); + SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored"); #endif PL_op_mask = &op_mask_buf[0]; if (orig_op_mask) Copy(orig_op_mask, PL_op_mask, PL_maxo, char); else Zero(PL_op_mask, PL_maxo, char); - opmask_add(opset); + opmask_add(aTHX_ opset); } @@ -230,7 +231,7 @@ BOOT: opset_len = (PL_maxo + 7) / 8; if (opcode_debug >= 1) warn("opset_len %ld\n", (long)opset_len); - op_names_init(); + op_names_init(aTHX); void @@ -244,7 +245,7 @@ PPCODE: ENTER; - opmask_addlocal(mask, op_mask_buf); + opmask_addlocal(aTHX_ mask, op_mask_buf); save_aptr(&PL_endav); PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ @@ -252,6 +253,8 @@ PPCODE: save_hptr(&PL_defstash); /* save current default stack */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ + save_hptr(&PL_curstash); + PL_curstash = PL_defstash; /* defstash must itself contain a main:: so we'll add that now */ /* take care with the ref counts (was cause of long standing bug) */ @@ -270,7 +273,10 @@ int verify_opset(opset, fatal = 0) SV *opset int fatal - +CODE: + RETVAL = verify_opset(aTHX_ opset,fatal); +OUTPUT: + RETVAL void invert_opset(opset) @@ -279,7 +285,7 @@ CODE: { char *bitmap; STRLEN len = opset_len; - opset = sv_2mortal(new_opset(opset)); /* verify and clone opset */ + opset = sv_2mortal(new_opset(aTHX_ opset)); /* verify and clone opset */ bitmap = SvPVX(opset); while(len-- > 0) bitmap[len] = ~bitmap[len]; @@ -300,7 +306,7 @@ PPCODE: int i, j, myopcode; char *bitmap = SvPV(opset, len); char **names = (desc) ? get_op_descs() : get_op_names(); - verify_opset(opset,1); + verify_opset(aTHX_ opset,1); for (myopcode=0, i=0; i < opset_len; i++) { U16 bits = bitmap[i]; for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) { @@ -318,21 +324,21 @@ CODE: SV *bitspec, *opset; char *bitmap; STRLEN len, on; - opset = sv_2mortal(new_opset(Nullsv)); + opset = sv_2mortal(new_opset(aTHX_ Nullsv)); bitmap = SvPVX(opset); for (i = 0; i < items; i++) { char *opname; on = 1; - if (verify_opset(ST(i),0)) { + if (verify_opset(aTHX_ ST(i),0)) { opname = "(opset)"; bitspec = ST(i); } else { opname = SvPV(ST(i), len); if (*opname == '!') { on=0; ++opname;--len; } - bitspec = get_op_bitspec(opname, len, 1); + bitspec = get_op_bitspec(aTHX_ opname, len, 1); } - set_opset_bits(bitmap, bitspec, on, opname); + set_opset_bits(aTHX_ bitmap, bitspec, on, opname); } ST(0) = opset; @@ -357,13 +363,13 @@ CODE: croak("Not a Safe object"); mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); if (ONLY_THESE) /* *_only = new mask, else edit current */ - sv_setsv(mask, sv_2mortal(new_opset(PERMITING ? opset_all : Nullsv))); + sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv))); else - verify_opset(mask,1); /* croaks */ + verify_opset(aTHX_ mask,1); /* croaks */ bitmap = SvPVX(mask); for (i = 1; i < items; i++) { on = PERMITING ? 0 : 1; /* deny = mask bit on */ - if (verify_opset(ST(i),0)) { /* it's a valid mask */ + if (verify_opset(aTHX_ ST(i),0)) { /* it's a valid mask */ opname = "(opset)"; bitspec = ST(i); } @@ -371,9 +377,9 @@ CODE: opname = SvPV(ST(i), len); /* invert if op has ! prefix (only one allowed) */ if (*opname == '!') { on = !on; ++opname; --len; } - bitspec = get_op_bitspec(opname, len, 1); /* croaks */ + bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */ } - set_opset_bits(bitmap, bitspec, on, opname); + set_opset_bits(aTHX_ bitmap, bitspec, on, opname); } ST(0) = &PL_sv_yes; @@ -388,10 +394,10 @@ PPCODE: char **op_desc = get_op_descs(); /* copy args to a scratch area since we may push output values onto */ /* the stack faster than we read values off it if masks are used. */ - args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*)))); + args = (SV**)SvPVX(sv_2mortal(newSVpvn((char*)&ST(0), items*sizeof(SV*)))); for (i = 0; i < items; i++) { char *opname = SvPV(args[i], len); - SV *bitspec = get_op_bitspec(opname, len, 1); + SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1); if (SvIOK(bitspec)) { myopcode = SvIV(bitspec); if (myopcode < 0 || myopcode >= PL_maxo) @@ -423,19 +429,19 @@ define_optag(optagsv, mask) CODE: STRLEN len; char *optag = SvPV(optagsv, len); - put_op_bitspec(optag, len, mask); /* croaks */ + put_op_bitspec(aTHX_ optag, len, mask); /* croaks */ ST(0) = &PL_sv_yes; void empty_opset() CODE: - ST(0) = sv_2mortal(new_opset(Nullsv)); + ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); void full_opset() CODE: - ST(0) = sv_2mortal(new_opset(opset_all)); + ST(0) = sv_2mortal(new_opset(aTHX_ opset_all)); void opmask_add(opset) @@ -443,6 +449,8 @@ opmask_add(opset) PREINIT: if (!PL_op_mask) Newz(0, PL_op_mask, PL_maxo, char); +CODE: + opmask_add(aTHX_ opset); void opcodes() @@ -457,7 +465,7 @@ PPCODE: void opmask() CODE: - ST(0) = sv_2mortal(new_opset(Nullsv)); + ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); if (PL_op_mask) { char *bitmap = SvPVX(ST(0)); int myopcode; diff --git a/contrib/perl5/ext/Opcode/Safe.pm b/contrib/perl5/ext/Opcode/Safe.pm index 2d09c2e..7e1d6a3 100644 --- a/contrib/perl5/ext/Opcode/Safe.pm +++ b/contrib/perl5/ext/Opcode/Safe.pm @@ -2,9 +2,8 @@ package Safe; use 5.003_11; use strict; -use vars qw($VERSION); -$VERSION = "2.06"; +our $VERSION = "2.06"; use Carp; @@ -235,7 +234,7 @@ sub rdo { 1; -__DATA__ +__END__ =head1 NAME diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL index d379fdb..55c5c1f 100644 --- a/contrib/perl5/ext/POSIX/Makefile.PL +++ b/contrib/perl5/ext/POSIX/Makefile.PL @@ -1,7 +1,17 @@ use ExtUtils::MakeMaker; +use Config; +my @libs; +if ($^O ne 'MSWin32') { + if ($Config{archname} =~ /RM\d\d\d-svr4/) { + @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]); + } + else { + @libs = ('LIBS' => ["-lm -lposix -lcposix"]); + } +} WriteMakefile( NAME => 'POSIX', - ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), + @libs, MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', diff --git a/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm index 84298cb..9416f70 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pm +++ b/contrib/perl5/ext/POSIX/POSIX.pm @@ -1,203 +1,34 @@ package POSIX; -use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT_OK $AUTOLOAD); +our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = (); -use Carp; use AutoLoader; -require Config; -use Symbol; -require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); - -$VERSION = "1.02" ; - -%EXPORT_TAGS = ( - - assert_h => [qw(assert NDEBUG)], - - ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower - isprint ispunct isspace isupper isxdigit tolower toupper)], - - dirent_h => [qw()], - - errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT - EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED - ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT - EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS - EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK - EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH - ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM - ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR - ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM - EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE - ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT - ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY - EUSERS EWOULDBLOCK EXDEV errno)], - - fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK - F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK - O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK - O_RDONLY O_RDWR O_TRUNC O_WRONLY - creat - SEEK_CUR SEEK_END SEEK_SET - S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID - S_IWGRP S_IWOTH S_IWUSR)], - - float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG - DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP - DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP - FLT_DIG FLT_EPSILON FLT_MANT_DIG - FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP - FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP - FLT_RADIX FLT_ROUNDS - LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG - LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP - LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], - - grp_h => [qw()], - - limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX - INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON - MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX - PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN - SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX - ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX - _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT - _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX - _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX - _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], +use XSLoader (); - locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC - LC_TIME NULL localeconv setlocale)], - - math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod - frexp ldexp log10 modf pow sinh tan tanh)], - - pwd_h => [qw()], - - setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], - - signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK - SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM - SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL - SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN - SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR - SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal - sigpending sigprocmask sigsuspend)], - - stdarg_h => [qw()], - - stddef_h => [qw(NULL offsetof)], - - stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid - L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET - STREAM_MAX TMP_MAX stderr stdin stdout - clearerr fclose fdopen feof ferror fflush fgetc fgetpos - fgets fopen fprintf fputc fputs fread freopen - fscanf fseek fsetpos ftell fwrite getchar gets - perror putc putchar puts remove rewind - scanf setbuf setvbuf sscanf tmpfile tmpnam - ungetc vfprintf vprintf vsprintf)], - - stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX - abort atexit atof atoi atol bsearch calloc div - free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort realloc strtod strtol strtoul wcstombs wctomb)], - - string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat - strchr strcmp strcoll strcpy strcspn strerror strlen - strncat strncmp strncpy strpbrk strrchr strspn strstr - strtok strxfrm)], - - sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG - S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR - fstat mkfifo)], - - sys_times_h => [qw()], - - sys_types_h => [qw()], - - sys_utsname_h => [qw(uname)], - - sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED - WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], - - termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 - B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL - CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK - ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR - INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST - PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION - TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW - TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART - VSTOP VSUSP VTIME - cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain - tcflow tcflush tcgetattr tcsendbreak tcsetattr )], - - time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime - difftime mktime strftime tzset tzname)], - - unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK - _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON - _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX - _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS - _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX - _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL - _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS - _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION - _exit access ctermid cuserid - dup2 dup execl execle execlp execv execve execvp - fpathconf getcwd getegid geteuid getgid getgroups - getpid getuid isatty lseek pathconf pause setgid setpgid - setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], - - utime_h => [qw()], - -); - -Exporter::export_tags(); - -@EXPORT_OK = qw( - closedir opendir readdir rewinddir - fcntl open - getgrgid getgrnam - atan2 cos exp log sin sqrt - getpwnam getpwuid - kill - fileno getc printf rename sprintf - abs exit rand srand system - chmod mkdir stat umask - times - wait waitpid - gmtime localtime time - alarm chdir chown close fork getlogin getppid getpgrp link - pipe read rmdir sleep unlink write - utime - nice -); +our $VERSION = "1.03" ; # Grandfather old foo_h form to new :foo_h form +my $loaded; + sub import { + load_imports() unless $loaded++; my $this = shift; my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_; local $Exporter::ExportLevel = 1; Exporter::import($this,@list); } +sub croak { require Carp; goto &Carp::croak } -bootstrap POSIX $VERSION; +XSLoader::load 'POSIX', $VERSION; my $EINVAL = constant("EINVAL", 0); my $EAGAIN = constant("EAGAIN", 0); sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { + # require AutoLoader; $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD } @@ -273,7 +104,7 @@ sub closedir { sub opendir { usage "opendir(directory)" if @_ != 1; - my $dirhandle = gensym; + my $dirhandle; CORE::opendir($dirhandle, $_[0]) ? $dirhandle : undef; @@ -932,3 +763,178 @@ sub utime { CORE::utime($_[1], $_[2], $_[0]); } +sub load_imports { +%EXPORT_TAGS = ( + + assert_h => [qw(assert NDEBUG)], + + ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower + isprint ispunct isspace isupper isxdigit tolower toupper)], + + dirent_h => [qw()], + + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], + + fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK + F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK + O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK + O_RDONLY O_RDWR O_TRUNC O_WRONLY + creat + SEEK_CUR SEEK_END SEEK_SET + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID + S_IWGRP S_IWOTH S_IWUSR)], + + float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG + DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP + FLT_DIG FLT_EPSILON FLT_MANT_DIG + FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP + FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP + FLT_RADIX FLT_ROUNDS + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG + LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP + LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], + + grp_h => [qw()], + + limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX + INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON + MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX + PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN + SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX + ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX + _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], + + locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC + LC_TIME NULL localeconv setlocale)], + + math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tan tanh)], + + pwd_h => [qw()], + + setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], + + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN + SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal + sigpending sigprocmask sigsuspend)], + + stdarg_h => [qw()], + + stddef_h => [qw(NULL offsetof)], + + stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid + L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET + STREAM_MAX TMP_MAX stderr stdin stdout + clearerr fclose fdopen feof ferror fflush fgetc fgetpos + fgets fopen fprintf fputc fputs fread freopen + fscanf fseek fsetpos ftell fwrite getchar gets + perror putc putchar puts remove rewind + scanf setbuf setvbuf sscanf tmpfile tmpnam + ungetc vfprintf vprintf vsprintf)], + + stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX + abort atexit atof atoi atol bsearch calloc div + free getenv labs ldiv malloc mblen mbstowcs mbtowc + qsort realloc strtod strtol strtoul wcstombs wctomb)], + + string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat + strchr strcmp strcoll strcpy strcspn strerror strlen + strncat strncmp strncpy strpbrk strrchr strspn strstr + strtok strxfrm)], + + sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR + fstat mkfifo)], + + sys_times_h => [qw()], + + sys_types_h => [qw()], + + sys_utsname_h => [qw(uname)], + + sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED + WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], + + termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 + B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL + CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK + ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR + INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST + PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION + TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW + TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART + VSTOP VSUSP VTIME + cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain + tcflow tcflush tcgetattr tcsendbreak tcsetattr )], + + time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime + difftime mktime strftime tzset tzname)], + + unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET + STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON + _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX + _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS + _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX + _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL + _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS + _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION + _exit access ctermid cuserid + dup2 dup execl execle execlp execv execve execvp + fpathconf getcwd getegid geteuid getgid getgroups + getpid getuid isatty lseek pathconf pause setgid setpgid + setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], + + utime_h => [qw()], + +); + +# Exporter::export_tags(); +for (values %EXPORT_TAGS) { + push @EXPORT, @$_; +} + +@EXPORT_OK = qw( + closedir opendir readdir rewinddir + fcntl open + getgrgid getgrnam + atan2 cos exp log sin sqrt + getpwnam getpwuid + kill + fileno getc printf rename sprintf + abs exit rand srand system + chmod mkdir stat umask + times + wait waitpid + gmtime localtime time + alarm chdir chown close fork getlogin getppid getpgrp link + pipe read rmdir sleep unlink write + utime + nice +); + +require Exporter; +} diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod index 6a4a61a..08300e4 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pod +++ b/contrib/perl5/ext/POSIX/POSIX.pod @@ -847,31 +847,35 @@ setjmp() is C-specific: use eval {} instead. =item setlocale -Modifies and queries program's locale. +Modifies and queries program's locale. The following examples assume + + use POSIX qw(setlocale LC_ALL LC_CTYPE); + +has been issued. The following will set the traditional UNIX system locale behavior (the second argument C<"C">). - $loc = POSIX::setlocale( &POSIX::LC_ALL, "C" ); + $loc = setlocale( LC_ALL, "C" ); -The following will query (the missing second argument) the current -LC_CTYPE category. +The following will query the current LC_CTYPE category. (No second +argument means 'query'.) - $loc = POSIX::setlocale( &POSIX::LC_CTYPE); + $loc = setlocale( LC_CTYPE ); The following will set the LC_CTYPE behaviour according to the locale environment variables (the second argument C<"">). Please see your systems L<setlocale(3)> documentation for the locale environment variables' meaning or consult L<perllocale>. - $loc = POSIX::setlocale( &POSIX::LC_CTYPE, ""); + $loc = setlocale( LC_CTYPE, "" ); The following will set the LC_COLLATE behaviour to Argentinian Spanish. B<NOTE>: The naming and availability of locales depends on your operating system. Please consult L<perllocale> for how to find out which locales are available in your system. - $loc = POSIX::setlocale( &POSIX::LC_ALL, "es_AR.ISO8859-1" ); + $loc = setlocale( LC_ALL, "es_AR.ISO8859-1" ); =item setpgid @@ -1015,8 +1019,13 @@ The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the year 2001 is 101. Consult your system's C<strftime()> manpage for details -about these and the other arguments. The given arguments are made consistent -by calling C<mktime()> before calling your system's C<strftime()> function. +about these and the other arguments. +If you want your code to be portable, your format (C<fmt>) argument +should use only the conversion specifiers defined by the ANSI C +standard. These are C<aAbBcdHIjmMpSUwWxXyYZ%>. +The given arguments are made consistent +as though by calling C<mktime()> before calling your system's +C<strftime()> function, except that the C<isdst> value is not affected. The string for Tuesday, December 12, 1995. diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs index 15e026e..3a523d1 100644 --- a/contrib/perl5/ext/POSIX/POSIX.xs +++ b/contrib/perl5/ext/POSIX/POSIX.xs @@ -1,11 +1,14 @@ #ifdef WIN32 #define _POSIX_ #endif + +#define PERL_NO_GET_CONTEXT + #include "EXTERN.h" #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" -#ifdef PERL_OBJECT /* XXX _very_ temporary hacks */ +#if defined(PERL_OBJECT) || defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS) # undef signal # undef open # undef setmode @@ -78,6 +81,7 @@ /* The non-POSIX CRTL times() has void return type, so we just get the current time directly */ clock_t vms_times(struct tms *PL_bufptr) { + dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to * produce the return value that the POSIX standard expects */ @@ -102,6 +106,9 @@ } # define times(t) vms_times(t) #else +#if defined (__CYGWIN__) +# define tzname _tzname +#endif #if defined (WIN32) # undef mkfifo # define mkfifo(a,b) not_here("mkfifo") @@ -135,8 +142,12 @@ #else # ifndef HAS_MKFIFO -# ifndef mkfifo -# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) +# ifdef OS2 +# define mkfifo(a,b) not_here("mkfifo") +# else /* !( defined OS2 ) */ +# ifndef mkfifo +# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) +# endif # endif # endif /* !HAS_MKFIFO */ @@ -177,10 +188,10 @@ typedef struct termios* POSIX__Termios; #endif /* Possibly needed prototypes */ -char *cuserid _((char *)); -double strtod _((const char *, char **)); -long strtol _((const char *, char **, int)); -unsigned long strtoul _((const char *, char **, int)); +char *cuserid (char *); +double strtod (const char *, char **); +long strtol (const char *, char **, int); +unsigned long strtoul (const char *, char **, int); #ifndef HAS_CUSERID #define cuserid(a) (char *) not_here("cuserid") @@ -278,7 +289,7 @@ unsigned long strtoul _((const char *, char **, int)); #endif #ifdef HAS_TZNAME -# ifndef WIN32 +# if !defined(WIN32) && !defined(__CYGWIN__) extern char *tzname[]; # endif #else @@ -303,14 +314,13 @@ char *tzname[] = { "" , "" }; */ #ifdef HAS_GNULIBC # ifndef STRUCT_TM_HASZONE -# define STRUCT_TM_HAS_ZONE +# define STRUCT_TM_HASZONE # endif #endif #ifdef STRUCT_TM_HASZONE static void -init_tm(ptm) /* see mktime, strftime and asctime */ - struct tm *ptm; +init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ { Time_t now; (void)time(&now); @@ -321,6 +331,202 @@ init_tm(ptm) /* see mktime, strftime and asctime */ # define init_tm(ptm) #endif +/* + * mini_mktime - normalise struct tm values without the localtime() + * semantics (and overhead) of mktime(). + */ +static void +mini_mktime(struct tm *ptm) +{ + int yearday; + int secs; + int month, mday, year, jday; + int odd_cent, odd_year; + +#define DAYS_PER_YEAR 365 +#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) +#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) +#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) +#define SECS_PER_HOUR (60*60) +#define SECS_PER_DAY (24*SECS_PER_HOUR) +/* parentheses deliberately absent on these two, otherwise they don't work */ +#define MONTH_TO_DAYS 153/5 +#define DAYS_TO_MONTH 5/153 +/* offset to bias by March (month 4) 1st between month/mday & year finding */ +#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) +/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ +#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ + +/* + * Year/day algorithm notes: + * + * With a suitable offset for numeric value of the month, one can find + * an offset into the year by considering months to have 30.6 (153/5) days, + * using integer arithmetic (i.e., with truncation). To avoid too much + * messing about with leap days, we consider January and February to be + * the 13th and 14th month of the previous year. After that transformation, + * we need the month index we use to be high by 1 from 'normal human' usage, + * so the month index values we use run from 4 through 15. + * + * Given that, and the rules for the Gregorian calendar (leap years are those + * divisible by 4 unless also divisible by 100, when they must be divisible + * by 400 instead), we can simply calculate the number of days since some + * arbitrary 'beginning of time' by futzing with the (adjusted) year number, + * the days we derive from our month index, and adding in the day of the + * month. The value used here is not adjusted for the actual origin which + * it normally would use (1 January A.D. 1), since we're not exposing it. + * We're only building the value so we can turn around and get the + * normalised values for the year, month, day-of-month, and day-of-year. + * + * For going backward, we need to bias the value we're using so that we find + * the right year value. (Basically, we don't want the contribution of + * March 1st to the number to apply while deriving the year). Having done + * that, we 'count up' the contribution to the year number by accounting for + * full quadracenturies (400-year periods) with their extra leap days, plus + * the contribution from full centuries (to avoid counting in the lost leap + * days), plus the contribution from full quad-years (to count in the normal + * leap days), plus the leftover contribution from any non-leap years. + * At this point, if we were working with an actual leap day, we'll have 0 + * days left over. This is also true for March 1st, however. So, we have + * to special-case that result, and (earlier) keep track of the 'odd' + * century and year contributions. If we got 4 extra centuries in a qcent, + * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. + * Otherwise, we add back in the earlier bias we removed (the 123 from + * figuring in March 1st), find the month index (integer division by 30.6), + * and the remainder is the day-of-month. We then have to convert back to + * 'real' months (including fixing January and February from being 14/15 in + * the previous year to being in the proper year). After that, to get + * tm_yday, we work with the normalised year and get a new yearday value for + * January 1st, which we subtract from the yearday value we had earlier, + * representing the date we've re-built. This is done from January 1 + * because tm_yday is 0-origin. + * + * Since POSIX time routines are only guaranteed to work for times since the + * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm + * applies Gregorian calendar rules even to dates before the 16th century + * doesn't bother me. Besides, you'd need cultural context for a given + * date to know whether it was Julian or Gregorian calendar, and that's + * outside the scope for this routine. Since we convert back based on the + * same rules we used to build the yearday, you'll only get strange results + * for input which needed normalising, or for the 'odd' century years which + * were leap years in the Julian calander but not in the Gregorian one. + * I can live with that. + * + * This algorithm also fails to handle years before A.D. 1 gracefully, but + * that's still outside the scope for POSIX time manipulation, so I don't + * care. + */ + + year = 1900 + ptm->tm_year; + month = ptm->tm_mon; + mday = ptm->tm_mday; + /* allow given yday with no month & mday to dominate the result */ + if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { + month = 0; + mday = 0; + jday = 1 + ptm->tm_yday; + } + else { + jday = 0; + } + if (month >= 2) + month+=2; + else + month+=14, year--; + yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; + yearday += month*MONTH_TO_DAYS + mday + jday; + /* + * Note that we don't know when leap-seconds were or will be, + * so we have to trust the user if we get something which looks + * like a sensible leap-second. Wild values for seconds will + * be rationalised, however. + */ + if ((unsigned) ptm->tm_sec <= 60) { + secs = 0; + } + else { + secs = ptm->tm_sec; + ptm->tm_sec = 0; + } + secs += 60 * ptm->tm_min; + secs += SECS_PER_HOUR * ptm->tm_hour; + if (secs < 0) { + if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { + /* got negative remainder, but need positive time */ + /* back off an extra day to compensate */ + yearday += (secs/SECS_PER_DAY)-1; + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); + } + else { + yearday += (secs/SECS_PER_DAY); + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); + } + } + else if (secs >= SECS_PER_DAY) { + yearday += (secs/SECS_PER_DAY); + secs %= SECS_PER_DAY; + } + ptm->tm_hour = secs/SECS_PER_HOUR; + secs %= SECS_PER_HOUR; + ptm->tm_min = secs/60; + secs %= 60; + ptm->tm_sec += secs; + /* done with time of day effects */ + /* + * The algorithm for yearday has (so far) left it high by 428. + * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to + * bias it by 123 while trying to figure out what year it + * really represents. Even with this tweak, the reverse + * translation fails for years before A.D. 0001. + * It would still fail for Feb 29, but we catch that one below. + */ + jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ + yearday -= YEAR_ADJUST; + year = (yearday / DAYS_PER_QCENT) * 400; + yearday %= DAYS_PER_QCENT; + odd_cent = yearday / DAYS_PER_CENT; + year += odd_cent * 100; + yearday %= DAYS_PER_CENT; + year += (yearday / DAYS_PER_QYEAR) * 4; + yearday %= DAYS_PER_QYEAR; + odd_year = yearday / DAYS_PER_YEAR; + year += odd_year; + yearday %= DAYS_PER_YEAR; + if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ + month = 1; + yearday = 29; + } + else { + yearday += YEAR_ADJUST; /* recover March 1st crock */ + month = yearday*DAYS_TO_MONTH; + yearday -= month*MONTH_TO_DAYS; + /* recover other leap-year adjustment */ + if (month > 13) { + month-=14; + year++; + } + else { + month-=2; + } + } + ptm->tm_year = year - 1900; + if (yearday) { + ptm->tm_mday = yearday; + ptm->tm_mon = month; + } + else { + ptm->tm_mday = 31; + ptm->tm_mon = month - 1; + } + /* re-build yearday based on Jan 1 to get tm_yday */ + year--; + yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; + yearday += 14*MONTH_TO_DAYS + 1; + ptm->tm_yday = jday - yearday; + /* fix tm_wday if not overridden by caller */ + if ((unsigned)ptm->tm_wday > 6) + ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; +} #ifdef HAS_LONG_DOUBLE # if LONG_DOUBLESIZE > DOUBLESIZE @@ -348,7 +554,7 @@ not_here(char *s) } static -#ifdef HAS_LONG_DOUBLE +#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE) long double #else double @@ -1519,9 +1725,10 @@ constant(char *name, int arg) #else goto not_there; #endif - if (strEQ(name, "L_tmpname")) -#ifdef L_tmpname - return L_tmpname; + /* L_tmpnam[e] was a typo--retained for compatibility */ + if (strEQ(name, "L_tmpname") || strEQ(name, "L_tmpnam")) +#ifdef L_tmpnam + return L_tmpnam; #else goto not_there; #endif @@ -3045,7 +3252,7 @@ setlocale(category, locale = 0) else #endif newctype = RETVAL; - perl_new_ctype(newctype); + new_ctype(newctype); } #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE @@ -3062,7 +3269,7 @@ setlocale(category, locale = 0) else #endif newcoll = RETVAL; - perl_new_collate(newcoll); + new_collate(newcoll); } #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC @@ -3079,7 +3286,7 @@ setlocale(category, locale = 0) else #endif newnum = RETVAL; - perl_new_numeric(newnum); + new_numeric(newnum); } #endif /* USE_LOCALE_NUMERIC */ } @@ -3167,17 +3374,15 @@ sigaction(sig, action, oldaction = 0) # This code is really grody because we're trying to make the signal # interface look beautiful, which is hard. - if (!PL_siggv) - gv_fetchpv("SIG", TRUE, SVt_PVHV); - { + GV *siggv = gv_fetchpv("SIG", TRUE, SVt_PVHV); struct sigaction act; struct sigaction oact; POSIX__SigSet sigset; SV** svp; - SV** sigsvp = hv_fetch(GvHVn(PL_siggv), - sig_name[sig], - strlen(sig_name[sig]), + SV** sigsvp = hv_fetch(GvHVn(siggv), + PL_sig_name[sig], + strlen(PL_sig_name[sig]), TRUE); STRLEN n_a; @@ -3196,7 +3401,7 @@ sigaction(sig, action, oldaction = 0) croak("Can't supply an action without a HANDLER"); sv_setpv(*sigsvp, SvPV(*svp, n_a)); mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ - act.sa_handler = sighandler; + act.sa_handler = PL_sighandlerp; /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); @@ -3262,7 +3467,7 @@ INIT: } else if (sv_derived_from(ST(2), "POSIX::SigSet")) { IV tmp = SvIV((SV*)SvRV(ST(2))); - oldsigset = (POSIX__SigSet) tmp; + oldsigset = INT2PTR(POSIX__SigSet,tmp); } else { New(0, oldsigset, 1, sigset_t); @@ -3367,9 +3572,18 @@ write(fd, buffer, nbytes) char * buffer size_t nbytes -char * -tmpnam(s = 0) - char * s = 0; +SV * +tmpnam() + PREINIT: + STRLEN i; + int len; + CODE: + RETVAL = newSVpvn("", 0); + SvGROW(RETVAL, L_tmpnam); + len = strlen(tmpnam(SvPV(RETVAL, i))); + SvCUR_set(RETVAL, len); + OUTPUT: + RETVAL void abort() @@ -3434,10 +3648,12 @@ strtol(str, base = 0) char *unparsed; PPCODE: num = strtol(str, &unparsed, base); - if (num >= IV_MIN && num <= IV_MAX) - PUSHs(sv_2mortal(newSViv((IV)num))); - else +#if IVSIZE <= LONGSIZE + if (num < IV_MIN || num > IV_MAX) PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); if (GIMME == G_ARRAY) { EXTEND(SP, 1); if (unparsed) @@ -3629,7 +3845,7 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; - (void) mktime(&mytm); + mini_mktime(&mytm); len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); /* ** The following is needed to handle to the situation where @@ -3645,28 +3861,35 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) ** If there is a better way to make it portable, go ahead by ** all means. */ - if ( ( len > 0 && len < sizeof(tmpbuf) ) - || ( len == 0 && strlen(fmt) == 0 ) ) { + if ((len > 0 && len < sizeof(tmpbuf)) || (len == 0 && *fmt == '\0')) ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); - } else { + else { /* Possibly buf overflowed - try again with a bigger buf */ - int bufsize = strlen(fmt) + sizeof(tmpbuf); + int fmtlen = strlen(fmt); + int bufsize = fmtlen + sizeof(tmpbuf); char* buf; int buflen; New(0, buf, bufsize, char); - while( buf ) { + while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); - if ( buflen > 0 && buflen < bufsize ) break; + if (buflen > 0 && buflen < bufsize) + break; + /* heuristic to prevent out-of-memory errors */ + if (bufsize > 100*fmtlen) { + Safefree(buf); + buf = NULL; + break; + } bufsize *= 2; Renew(buf, bufsize, char); } - if ( buf ) { - ST(0) = sv_2mortal(newSVpv(buf, buflen)); + if (buf) { + ST(0) = sv_2mortal(newSVpvn(buf, buflen)); Safefree(buf); - } else { - ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); } + else + ST(0) = sv_2mortal(newSVpvn(tmpbuf, len)); } } @@ -3677,8 +3900,8 @@ void tzname() PPCODE: EXTEND(SP,2); - PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0])))); - PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1])))); + PUSHs(sv_2mortal(newSVpvn(tzname[0],strlen(tzname[0])))); + PUSHs(sv_2mortal(newSVpvn(tzname[1],strlen(tzname[1])))); SysRet access(filename, mode) diff --git a/contrib/perl5/ext/SDBM_File/Makefile.PL b/contrib/perl5/ext/SDBM_File/Makefile.PL index 7494785..a1debb9 100644 --- a/contrib/perl5/ext/SDBM_File/Makefile.PL +++ b/contrib/perl5/ext/SDBM_File/Makefile.PL @@ -16,16 +16,30 @@ WriteMakefile( XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'SDBM_File.pm', DEFINE => $define, + PERL_MALLOC_OK => 1, ); sub MY::postamble { - if ($^O ne 'VMS') { + if ($^O =~ /MSWin32/ && Win32::IsWin95()) { + # XXX: dmake-specific, like rest of Win95 port + return + ' +$(MYEXTLIB): sdbm/Makefile +@[ + cd sdbm + $(MAKE) all + cd .. +] +'; + } + elsif ($^O ne 'VMS') { ' $(MYEXTLIB): sdbm/Makefile cd sdbm && $(MAKE) all '; - } else { - ' + } + else { + ' $(MYEXTLIB) : [.sdbm]descrip.mms set def [.sdbm] $(MMS) all diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.pm b/contrib/perl5/ext/SDBM_File/SDBM_File.pm index a2d4df8..c5e26c8 100644 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.pm +++ b/contrib/perl5/ext/SDBM_File/SDBM_File.pm @@ -1,16 +1,14 @@ package SDBM_File; use strict; -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.02" ; -$VERSION = "1.00" ; - -bootstrap SDBM_File $VERSION; +XSLoader::load 'SDBM_File', $VERSION; 1; @@ -30,6 +28,6 @@ SDBM_File - Tied access to sdbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.xs b/contrib/perl5/ext/SDBM_File/SDBM_File.xs index 38eaebf..a4b9045 100644 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.xs +++ b/contrib/perl5/ext/SDBM_File/SDBM_File.xs @@ -1,15 +1,47 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "sdbm/sdbm.h" -typedef DBM* SDBM_File; +typedef struct { + DBM * dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } SDBM_File_type; + +typedef SDBM_File_type * SDBM_File ; +typedef datum datum_key ; +typedef datum datum_value ; + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + #define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode) -#define sdbm_FETCH(db,key) sdbm_fetch(db,key) -#define sdbm_STORE(db,key,value,flags) sdbm_store(db,key,value,flags) -#define sdbm_DELETE(db,key) sdbm_delete(db,key) -#define sdbm_FIRSTKEY(db) sdbm_firstkey(db) -#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db) +#define sdbm_FETCH(db,key) sdbm_fetch(db->dbp,key) +#define sdbm_STORE(db,key,value,flags) sdbm_store(db->dbp,key,value,flags) +#define sdbm_DELETE(db,key) sdbm_delete(db->dbp,key) +#define sdbm_EXISTS(db,key) sdbm_exists(db->dbp,key) +#define sdbm_FIRSTKEY(db) sdbm_firstkey(db->dbp) +#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db->dbp) MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_ @@ -20,23 +52,46 @@ sdbm_TIEHASH(dbtype, filename, flags, mode) char * filename int flags int mode + CODE: + { + DBM * dbp ; + + RETVAL = NULL ; + if (dbp = sdbm_open(filename,flags,mode) ) { + RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ; + Zero(RETVAL, 1, SDBM_File_type) ; + RETVAL->dbp = dbp ; + } + + } + OUTPUT: + RETVAL void sdbm_DESTROY(db) SDBM_File db CODE: - sdbm_close(db); + sdbm_close(db->dbp); + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; + safefree(db) ; -datum +datum_value sdbm_FETCH(db, key) SDBM_File db - datum key + datum_key key int sdbm_STORE(db, key, value, flags = DBM_REPLACE) SDBM_File db - datum key - datum value + datum_key key + datum_value value int flags CLEANUP: if (RETVAL) { @@ -44,28 +99,93 @@ sdbm_STORE(db, key, value, flags = DBM_REPLACE) croak("No write permission to sdbm file"); croak("sdbm store returned %d, errno %d, key \"%s\"", RETVAL,errno,key.dptr); - sdbm_clearerr(db); + sdbm_clearerr(db->dbp); } int sdbm_DELETE(db, key) SDBM_File db - datum key + datum_key key -datum +int +sdbm_EXISTS(db,key) + SDBM_File db + datum_key key + +datum_key sdbm_FIRSTKEY(db) SDBM_File db -datum +datum_key sdbm_NEXTKEY(db, key) SDBM_File db - datum key + datum_key key int sdbm_error(db) SDBM_File db + CODE: + RETVAL = sdbm_error(db->dbp) ; + OUTPUT: + RETVAL int sdbm_clearerr(db) SDBM_File db + CODE: + RETVAL = sdbm_clearerr(db->dbp) ; + OUTPUT: + RETVAL + + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = NULL ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + + +SV * +filter_fetch_key(db, code) + SDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + SDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + SDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + SDBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL b/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL index e6fdcf9..4453dea 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL +++ b/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL @@ -42,12 +42,14 @@ INST_STATIC = libsdbm$(LIB_EXT) } sub MY::top_targets { + my $noecho = shift->{NOECHO}; + my $r = ' all :: static - $(NOECHO) $(NOOP) + ' . $noecho . '$(NOOP) config :: - $(NOECHO) $(NOOP) + ' . $noecho . '$(NOOP) lint: lint -abchx $(LIBSRCS) @@ -58,7 +60,7 @@ lint: # variables into the environment so $(MYEXTLIB) is set in here to this # value which can not be built. sdbm/libsdbm.a: - $(NOECHO) $(NOOP) + ' . $noecho . '$(NOOP) ' unless $^O eq 'VMS'; return $r; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/README.too b/contrib/perl5/ext/SDBM_File/sdbm/README.too index c2d0959..1fec315 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/README.too +++ b/contrib/perl5/ext/SDBM_File/sdbm/README.too @@ -7,3 +7,8 @@ Fri Apr 15 10:15:30 EDT 1994. Additional portability/configuration changes for libsdbm by Andy Dougherty doughera@lafcol.lafayette.edu. + + +Mon Mar 22 03:24:47 PST 1999. + +sdbm_exists added to the library by Russ Allbery <rra@stanford.edu>. diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dba.c b/contrib/perl5/ext/SDBM_File/sdbm/dba.c index 05e70c8..7406776 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dba.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dba.c @@ -11,8 +11,7 @@ char *progname; extern void oops(); int -main(argc, argv) -char **argv; +main(int argc, char **argv) { int n; char *p; @@ -23,6 +22,9 @@ char **argv; if (p = argv[1]) { name = (char *) malloc((n = strlen(p)) + 5); + if (!name) + oops("cannot get memory"); + strcpy(name, p); strcpy(name + n, ".pag"); @@ -37,8 +39,8 @@ char **argv; return 0; } -sdump(pagf) -int pagf; +void +sdump(int pagf) { register b; register n = 0; @@ -67,8 +69,8 @@ int pagf; oops("read failed: block %d", n); } -pagestat(pag) -char *pag; +int +pagestat(char *pag) { register n; register free; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbd.c b/contrib/perl5/ext/SDBM_File/sdbm/dbd.c index 04ab842..0a58d9a 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbd.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbd.c @@ -14,8 +14,7 @@ extern void oops(); #define empty(page) (((short *) page)[0] == 0) int -main(argc, argv) -char **argv; +main(int argc, char **argv) { int n; char *p; @@ -26,6 +25,9 @@ char **argv; if (p = argv[1]) { name = (char *) malloc((n = strlen(p)) + 5); + if (!name) + oops("cannot get memory"); + strcpy(name, p); strcpy(name + n, ".pag"); @@ -39,8 +41,8 @@ char **argv; return 0; } -sdump(pagf) -int pagf; +void +sdump(int pagf) { register r; register n = 0; @@ -65,8 +67,8 @@ int pagf; #ifdef OLD -dispage(pag) -char *pag; +int +dispage(char *pag) { register i, n; register off; @@ -87,8 +89,8 @@ char *pag; } } #else -dispage(pag) -char *pag; +void +dispage(char *pag) { register i, n; register off; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbe.c b/contrib/perl5/ext/SDBM_File/sdbm/dbe.c index 2a306f2..166e64e 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbe.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbe.c @@ -52,10 +52,7 @@ char *optarg; /* Global argument pointer. */ #endif char -getopt(argc, argv, optstring) -int argc; -char **argv; -char *optstring; +getopt(int argc, char **argv, char *optstring) { register int c; register char *place; @@ -131,14 +128,13 @@ char *optstring; void -print_datum(db) -datum db; +print_datum(datum db) { int i; putchar('"'); for (i = 0; i < db.dsize; i++) { - if (isprint(db.dptr[i])) + if (isprint((unsigned char)db.dptr[i])) putchar(db.dptr[i]); else { putchar('\\'); @@ -152,8 +148,7 @@ datum db; datum -read_datum(s) -char *s; +read_datum(char *s) { datum db; char *p; @@ -161,6 +156,9 @@ char *s; db.dsize = 0; db.dptr = (char *) malloc(strlen(s) * sizeof(char)); + if (!db.dptr) + oops("cannot get memory"); + for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { if (*s == '\\') { if (*++s == 'n') @@ -171,7 +169,10 @@ char *s; *p = '\f'; else if (*s == 't') *p = '\t'; - else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) { + else if (isdigit((unsigned char)*s) + && isdigit((unsigned char)*(s + 1)) + && isdigit((unsigned char)*(s + 2))) + { i = (*s++ - '0') << 6; i |= (*s++ - '0') << 3; i |= *s - '0'; @@ -191,22 +192,21 @@ char *s; char * -key2s(db) -datum db; +key2s(datum db) { char *buf; char *p1, *p2; buf = (char *) malloc((db.dsize + 1) * sizeof(char)); + if (!buf) + oops("cannot get memory"); for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); *p1 = '\0'; return buf; } - -main(argc, argv) -int argc; -char **argv; +int +main(int argc, char **argv) { typedef enum { YOW, FETCH, STORE, DELETE, SCAN, REGEXP @@ -285,7 +285,7 @@ char **argv; } } - if (giveusage | what == YOW | argn < 1) { + if (giveusage || what == YOW || argn < 1) { fprintf(stderr, "Usage: %s databse [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); exit(-1); } diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c index 1388230..dc47d70 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c @@ -27,8 +27,8 @@ static DBM *cur_db = NODB; static char no_db[] = "dbm: no open database\n"; -dbminit(file) - char *file; +int +dbminit(char *file) { if (cur_db != NODB) dbm_close(cur_db); @@ -43,8 +43,7 @@ dbminit(file) } long -forder(key) -datum key; +forder(datum key) { if (cur_db == NODB) { printf(no_db); @@ -54,8 +53,7 @@ datum key; } datum -fetch(key) -datum key; +fetch(datum key) { datum item; @@ -67,8 +65,8 @@ datum key; return (dbm_fetch(cur_db, key)); } -delete(key) -datum key; +int +delete(datum key) { if (cur_db == NODB) { printf(no_db); @@ -79,8 +77,8 @@ datum key; return (dbm_delete(cur_db, key)); } -store(key, dat) -datum key, dat; +int +store(datum key, datum dat) { if (cur_db == NODB) { printf(no_db); @@ -93,7 +91,7 @@ datum key, dat; } datum -firstkey() +firstkey(void) { datum item; @@ -106,8 +104,7 @@ firstkey() } datum -nextkey(key) -datum key; +nextkey(datum key) { datum item; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbu.c b/contrib/perl5/ext/SDBM_File/sdbm/dbu.c index a3c0004..e68b78d 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbu.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbu.c @@ -65,9 +65,7 @@ static cmd *parse(); static void badk(), doit(), prdatum(); int -main(argc, argv) -int argc; -char *argv[]; +main(int argc, char **argv) { int c; register cmd *act; @@ -98,9 +96,7 @@ char *argv[]; } static void -doit(act, file) -register cmd *act; -char *file; +doit(register cmd *act, char *file) { datum key; datum val; @@ -197,8 +193,7 @@ char *file; } static void -badk(word) -char *word; +badk(char *word) { register int i; @@ -214,8 +209,7 @@ char *word; } static cmd * -parse(str) -register char *str; +parse(register char *str) { register int i = CTABSIZ; register cmd *p; @@ -227,9 +221,7 @@ register char *str; } static void -prdatum(stream, d) -FILE *stream; -datum d; +prdatum(FILE *stream, datum d) { register int c; register char *p = d.dptr; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/pair.c b/contrib/perl5/ext/SDBM_File/sdbm/pair.c index a9a805a..4f0fde2 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/pair.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/pair.c @@ -8,7 +8,11 @@ */ #include "config.h" -#include "EXTERN.h" +#ifdef __CYGWIN__ +# define EXTCONST extern const +#else +# include "EXTERN.h" +#endif #include "sdbm.h" #include "tune.h" #include "pair.h" @@ -102,6 +106,17 @@ getpair(char *pag, datum key) return val; } +int +exipair(char *pag, datum key) +{ + register short *ino = (short *) pag; + + if (ino[0] == 0) + return 0; + + return (seepair(pag, ino[0], key.dptr, key.dsize) != 0); +} + #ifdef SEEDUPS int duppair(char *pag, datum key) diff --git a/contrib/perl5/ext/SDBM_File/sdbm/pair.h b/contrib/perl5/ext/SDBM_File/sdbm/pair.h index 8a675b9..b6944ed 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/pair.h +++ b/contrib/perl5/ext/SDBM_File/sdbm/pair.h @@ -2,6 +2,7 @@ #define chkpage sdbm__chkpage #define delpair sdbm__delpair #define duppair sdbm__duppair +#define exipair sdbm__exipair #define fitpair sdbm__fitpair #define getnkey sdbm__getnkey #define getpair sdbm__getpair @@ -11,6 +12,7 @@ extern int fitpair proto((char *, int)); extern void putpair proto((char *, datum, datum)); extern datum getpair proto((char *, datum)); +extern int exipair proto((char *, datum)); extern int delpair proto((char *, datum)); extern int chkpage proto((char *)); extern datum getnkey proto((char *, int)); diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 index 7e5c176..fe6fe76 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 +++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 @@ -1,7 +1,7 @@ .\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ .TH SDBM 3 "1 March 1990" .SH NAME -sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines +sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_exists, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines .SH SYNOPSIS .nf .ft B @@ -26,6 +26,8 @@ int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) .sp int sdbm_delete(\s-1DBM\s0 *db, datum key) .sp +int sdbm_exists(\s-1DBM\s0 *db, datum key) +.sp datum sdbm_firstkey(\s-1DBM\s0 *db) .sp datum sdbm_nextkey(\s-1DBM\s0 *db) @@ -47,6 +49,7 @@ int sdbm_pagfno(\s-1DBM\s0 *db) .IX sdbm_fetch "" "\fLsdbm_fetch\fR \(em fetch \fLsdbm\fR database data" .IX sdbm_store "" "\fLsdbm_store\fR \(em add data to \fLsdbm\fR database" .IX sdbm_delete "" "\fLsdbm_delete\fR \(em remove data from \fLsdbm\fR database" +.IX sdbm_exists "" "\fLsdbm_exists\fR \(em test \fLsdbm\fR key existence" .IX sdbm_firstkey "" "\fLsdbm_firstkey\fR \(em access \fLsdbm\fR database" .IX sdbm_nextkey "" "\fLsdbm_nextkey\fR \(em access \fLsdbm\fR database" .IX sdbm_hash "" "\fLsdbm_hash\fR \(em string hash for \fLsdbm\fR database" @@ -149,6 +152,8 @@ Given a handle, one can retrieve data associated with a key by using the routine, and associate data with a key by using the .BR sdbm_store (\|) routine. +.BR sdbm_exists (\|) +will say whether a given key exists in the database. .LP The values of the .I flags diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c index c147e45..64c75cb 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c @@ -9,6 +9,9 @@ #include "INTERN.h" #include "config.h" +#ifdef WIN32 +#include "io.h" +#endif #include "sdbm.h" #include "tune.h" #include "pair.h" @@ -36,7 +39,7 @@ extern int errno; extern Malloc_t malloc proto((MEM_SIZE)); extern Free_t free proto((Malloc_t)); -extern Off_t lseek(int, Off_t, int); + #endif /* @@ -125,7 +128,7 @@ sdbm_prep(char *dirname, char *pagname, int flags, int mode) * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ -#if defined(OS2) || defined(MSDOS) || defined(WIN32) +#if defined(OS2) || defined(MSDOS) || defined(WIN32) || defined(__CYGWIN__) flags |= O_BINARY; # endif if ((db->pagf = open(pagname, flags, mode)) > -1) { @@ -182,6 +185,18 @@ sdbm_fetch(register DBM *db, datum key) } int +sdbm_exists(register DBM *db, datum key) +{ + if (db == NULL || bad(key)) + return errno = EINVAL, -1; + + if (getpage(db, exhash(key))) + return exipair(db->pagbuf, key); + + return ioerr(db), -1; +} + +int sdbm_delete(register DBM *db, datum key) { if (db == NULL || bad(key)) @@ -416,9 +431,12 @@ getdbit(register DBM *db, register long int dbit) dirb = c / DBLKSIZ; if (dirb != db->dirbno) { + int got; if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); db->dirbno = dirb; debug(("dir read: %d\n", dirb)); @@ -437,10 +455,12 @@ setdbit(register DBM *db, register long int dbit) dirb = c / DBLKSIZ; if (dirb != db->dirbno) { - (void) memset(db->dirbuf, 0, DBLKSIZ); + int got; if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); db->dirbno = dirb; debug(("dir read: %d\n", dirb)); @@ -448,8 +468,13 @@ setdbit(register DBM *db, register long int dbit) db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); +#if 0 if (dbit >= db->maxbno) db->maxbno += DBLKSIZ * BYTESIZ; +#else + if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) + db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; +#endif if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h index 84d5f75..86ba82d 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h +++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h @@ -79,6 +79,7 @@ extern int sdbm_delete proto((DBM *, datum)); extern int sdbm_store proto((DBM *, datum, datum, int)); extern datum sdbm_firstkey proto((DBM *)); extern datum sdbm_nextkey proto((DBM *)); +extern int sdbm_exists proto((DBM *, datum)); /* * other @@ -98,8 +99,12 @@ extern long sdbm_hash proto((char *, int)); #define dbm_clearerr sdbm_clearerr #endif -/* Most of the following is stolen from perl.h. */ +/* Most of the following is stolen from perl.h. We don't include + perl.h here because we just want the portability parts of perl.h, + not everything else. +*/ #ifndef H_PERL /* Include guard */ +#include "embed.h" /* Follow all the global renamings. */ /* * The following contortions are brought to you on behalf of all the @@ -168,27 +173,17 @@ extern long sdbm_hash proto((char *, int)); /* This comes after <stdlib.h> so we don't try to change the standard * library prototypes; we'll use our own instead. */ -#if defined(MYMALLOC) && (defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)) - -# ifdef HIDEMYMALLOC -# define malloc Mymalloc -# define calloc Mycalloc -# define realloc Myremalloc -# define free Myfree -# endif -# ifdef EMBEDMYMALLOC -# define malloc Perl_malloc -# define calloc Perl_calloc -# define realloc Perl_realloc -# define free Perl_free -# endif - - Malloc_t malloc proto((MEM_SIZE nbytes)); - Malloc_t calloc proto((MEM_SIZE elements, MEM_SIZE size)); - Malloc_t realloc proto((Malloc_t where, MEM_SIZE nbytes)); - Free_t free proto((Malloc_t where)); - -#endif /* MYMALLOC && (HIDEMYMALLOC || EMBEDMYMALLOC) */ +#if defined(MYMALLOC) && !defined(PERL_POLLUTE_MALLOC) +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_mfree + +Malloc_t Perl_malloc proto((MEM_SIZE nbytes)); +Malloc_t Perl_calloc proto((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t Perl_realloc proto((Malloc_t where, MEM_SIZE nbytes)); +Free_t Perl_mfree proto((Malloc_t where)); +#endif /* MYMALLOC */ #ifdef I_STRING #include <string.h> diff --git a/contrib/perl5/ext/SDBM_File/typemap b/contrib/perl5/ext/SDBM_File/typemap index 317a8f3..eeb5d59 100644 --- a/contrib/perl5/ext/SDBM_File/typemap +++ b/contrib/perl5/ext/SDBM_File/typemap @@ -2,7 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM +datum_key T_DATUM_K +datum_value T_DATUM_V gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ @@ -13,14 +14,23 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; T_GDATUM UNIMPLEMENTED OUTPUT -T_DATUM +T_DATUM_K + sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ diff --git a/contrib/perl5/ext/Socket/Makefile.PL b/contrib/perl5/ext/Socket/Makefile.PL index 3819143..339c45a 100644 --- a/contrib/perl5/ext/Socket/Makefile.PL +++ b/contrib/perl5/ext/Socket/Makefile.PL @@ -1,7 +1,9 @@ use ExtUtils::MakeMaker; +use Config; WriteMakefile( - NAME => 'Socket', + NAME => 'Socket', VERSION_FROM => 'Socket.pm', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? + ($Config{libs} =~ /(-lsocks\S*)/ ? (LIBS => [ "$1" ] ) : ()), + MAN3PODS => {}, # Pods will be built by installman. + XSPROTOARG => '-noprototypes', # XXX remove later? ); diff --git a/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm index 1ed19f7..02f098d 100644 --- a/contrib/perl5/ext/Socket/Socket.pm +++ b/contrib/perl5/ext/Socket/Socket.pm @@ -1,7 +1,7 @@ package Socket; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); -$VERSION = "1.7"; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); +$VERSION = "1.72"; =head1 NAME @@ -160,10 +160,11 @@ have AF_UNIX in the right place. =cut use Carp; +use warnings::register; require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); @EXPORT = qw( inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in pack_sockaddr_un unpack_sockaddr_un @@ -193,6 +194,8 @@ require DynaLoader; AF_UNIX AF_UNSPEC AF_X25 + IOV_MAX + MSG_BCAST MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC @@ -203,6 +206,7 @@ require DynaLoader; MSG_ERRQUEUE MSG_FIN MSG_MAXIOVLEN + MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK @@ -241,6 +245,9 @@ require DynaLoader; SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP + SHUT_RD + SHUT_RDWR + SHUT_WR SOCK_DGRAM SOCK_RAW SOCK_RDM @@ -266,9 +273,17 @@ require DynaLoader; SO_SNDTIMEO SO_TYPE SO_USELOOPBACK + UIO_MAXIOV ); -@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF); +@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF + + IPPROTO_TCP + TCP_KEEPALIVE + TCP_MAXRT + TCP_MAXSEG + TCP_NODELAY + TCP_STDURG); %EXPORT_TAGS = ( crlf => [qw(CR LF CRLF $CR $LF $CRLF)], @@ -288,7 +303,8 @@ BEGIN { sub sockaddr_in { if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die my($af, $port, @quad) = @_; - carp "6-ARG sockaddr_in call is deprecated" if $^W; + warnings::warn "6-ARG sockaddr_in call is deprecated" + if warnings::enabled(); pack_sockaddr_in($port, inet_aton(join('.', @quad))); } elsif (wantarray) { croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; @@ -309,6 +325,115 @@ sub sockaddr_un { } } +sub INADDR_ANY (); +sub INADDR_BROADCAST (); +sub INADDR_LOOPBACK (); +sub INADDR_LOOPBACK (); + +sub AF_802 (); +sub AF_APPLETALK (); +sub AF_CCITT (); +sub AF_CHAOS (); +sub AF_DATAKIT (); +sub AF_DECnet (); +sub AF_DLI (); +sub AF_ECMA (); +sub AF_GOSIP (); +sub AF_HYLINK (); +sub AF_IMPLINK (); +sub AF_INET (); +sub AF_LAT (); +sub AF_MAX (); +sub AF_NBS (); +sub AF_NIT (); +sub AF_NS (); +sub AF_OSI (); +sub AF_OSINET (); +sub AF_PUP (); +sub AF_SNA (); +sub AF_UNIX (); +sub AF_UNSPEC (); +sub AF_X25 (); +sub IOV_MAX (); +sub MSG_BCAST (); +sub MSG_CTLFLAGS (); +sub MSG_CTLIGNORE (); +sub MSG_CTRUNC (); +sub MSG_DONTROUTE (); +sub MSG_DONTWAIT (); +sub MSG_EOF (); +sub MSG_EOR (); +sub MSG_ERRQUEUE (); +sub MSG_FIN (); +sub MSG_MAXIOVLEN (); +sub MSG_MCAST (); +sub MSG_NOSIGNAL (); +sub MSG_OOB (); +sub MSG_PEEK (); +sub MSG_PROXY (); +sub MSG_RST (); +sub MSG_SYN (); +sub MSG_TRUNC (); +sub MSG_URG (); +sub MSG_WAITALL (); +sub PF_802 (); +sub PF_APPLETALK (); +sub PF_CCITT (); +sub PF_CHAOS (); +sub PF_DATAKIT (); +sub PF_DECnet (); +sub PF_DLI (); +sub PF_ECMA (); +sub PF_GOSIP (); +sub PF_HYLINK (); +sub PF_IMPLINK (); +sub PF_INET (); +sub PF_LAT (); +sub PF_MAX (); +sub PF_NBS (); +sub PF_NIT (); +sub PF_NS (); +sub PF_OSI (); +sub PF_OSINET (); +sub PF_PUP (); +sub PF_SNA (); +sub PF_UNIX (); +sub PF_UNSPEC (); +sub PF_X25 (); +sub SCM_CONNECT (); +sub SCM_CREDENTIALS (); +sub SCM_CREDS (); +sub SCM_RIGHTS (); +sub SCM_TIMESTAMP (); +sub SHUT_RD (); +sub SHUT_RDWR (); +sub SHUT_WR (); +sub SOCK_DGRAM (); +sub SOCK_RAW (); +sub SOCK_RDM (); +sub SOCK_SEQPACKET (); +sub SOCK_STREAM (); +sub SOL_SOCKET (); +sub SOMAXCONN (); +sub SO_ACCEPTCONN (); +sub SO_BROADCAST (); +sub SO_DEBUG (); +sub SO_DONTLINGER (); +sub SO_DONTROUTE (); +sub SO_ERROR (); +sub SO_KEEPALIVE (); +sub SO_LINGER (); +sub SO_OOBINLINE (); +sub SO_RCVBUF (); +sub SO_RCVLOWAT (); +sub SO_RCVTIMEO (); +sub SO_REUSEADDR (); +sub SO_SNDBUF (); +sub SO_SNDLOWAT (); +sub SO_SNDTIMEO (); +sub SO_TYPE (); +sub SO_USELOOPBACK (); +sub UIO_MAXIOV (); sub AUTOLOAD { my($constname); @@ -318,10 +443,10 @@ sub AUTOLOAD { my ($pack,$file,$line) = caller; croak "Your vendor has not defined Socket macro $constname, used"; } - eval "sub $AUTOLOAD { $val }"; + eval "sub $AUTOLOAD () { $val }"; goto &$AUTOLOAD; } -bootstrap Socket $VERSION; +XSLoader::load 'Socket', $VERSION; 1; diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs index 0bd6e59..0584e78 100644 --- a/contrib/perl5/ext/Socket/Socket.xs +++ b/contrib/perl5/ext/Socket/Socket.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -6,42 +7,58 @@ # ifdef I_SYS_TYPES # include <sys/types.h> # endif -#include <sys/socket.h> -#ifdef MPE -# define PF_INET AF_INET -# define PF_UNIX AF_UNIX -# define SOCK_RAW 3 -#endif -#ifdef I_SYS_UN -#include <sys/un.h> -#endif +# include <sys/socket.h> +# if defined(USE_SOCKS) && defined(I_SOCKS) +# include <socks.h> +# endif +# ifdef MPE +# define PF_INET AF_INET +# define PF_UNIX AF_UNIX +# define SOCK_RAW 3 +# endif +# ifdef I_SYS_UN +# include <sys/un.h> +# endif +/* XXX Configure test for <netinet/in_systm.h needed XXX */ +# if defined(NeXT) || defined(__NeXT__) +# include <netinet/in_systm.h> +# endif # ifdef I_NETINET_IN # include <netinet/in.h> # endif -#include <netdb.h> -#ifdef I_ARPA_INET -# include <arpa/inet.h> -#endif +# ifdef I_NETDB +# include <netdb.h> +# endif +# ifdef I_ARPA_INET +# include <arpa/inet.h> +# endif +# ifdef I_NETINET_TCP +# include <netinet/tcp.h> +# endif #else -#include "sockadapt.h" +# include "sockadapt.h" +#endif + +#ifdef I_SYSUIO +# include <sys/uio.h> #endif #ifndef AF_NBS -#undef PF_NBS +# undef PF_NBS #endif #ifndef AF_X25 -#undef PF_X25 +# undef PF_X25 #endif #ifndef INADDR_NONE -#define INADDR_NONE 0xffffffff +# define INADDR_NONE 0xffffffff #endif /* INADDR_NONE */ #ifndef INADDR_BROADCAST -#define INADDR_BROADCAST 0xffffffff +# define INADDR_BROADCAST 0xffffffff #endif /* INADDR_BROADCAST */ #ifndef INADDR_LOOPBACK -#define INADDR_LOOPBACK 0x7F000001 +# define INADDR_LOOPBACK 0x7F000001 #endif /* INADDR_LOOPBACK */ #ifndef HAS_INET_ATON @@ -56,6 +73,7 @@ static int my_inet_aton(register const char *cp, struct in_addr *addr) { + dTHX; register U32 val; register int base; register char c; @@ -322,6 +340,18 @@ constant(char *name, int arg) case 'H': break; case 'I': + if (strEQ(name, "IOV_MAX")) +#ifdef IOV_MAX + return IOV_MAX; +#else + goto not_there; +#endif + if (strEQ(name, "IPPROTO_TCP")) +#ifdef IPPROTO_TCP + return IPPROTO_TCP; +#else + goto not_there; +#endif break; case 'J': break; @@ -330,6 +360,12 @@ constant(char *name, int arg) case 'L': break; case 'M': + if (strEQ(name, "MSG_BCAST")) +#ifdef MSG_BCAST + return MSG_BCAST; +#else + goto not_there; +#endif if (strEQ(name, "MSG_CTLFLAGS")) #ifdef MSG_CTLFLAGS return MSG_CTLFLAGS; @@ -390,6 +426,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "MSG_MCAST")) +#ifdef MSG_MCAST + return MSG_MCAST; +#else + goto not_there; +#endif if (strEQ(name, "MSG_NOSIGNAL")) #ifdef MSG_NOSIGNAL return MSG_NOSIGNAL; @@ -624,6 +666,24 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "SHUT_RD")) +#ifdef SHUT_RD + return SHUT_RD; +#else + return 0; +#endif + if (strEQ(name, "SHUT_RDWR")) +#ifdef SHUT_RDWR + return SHUT_RDWR; +#else + return 2; +#endif + if (strEQ(name, "SHUT_WR")) +#ifdef SHUT_WR + return SHUT_WR; +#else + return 1; +#endif if (strEQ(name, "SOCK_DGRAM")) #ifdef SOCK_DGRAM return SOCK_DGRAM; @@ -782,8 +842,44 @@ constant(char *name, int arg) #endif break; case 'T': + if (strEQ(name, "TCP_KEEPALIVE")) +#ifdef TCP_KEEPALIVE + return TCP_KEEPALIVE; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_MAXRT")) +#ifdef TCP_MAXRT + return TCP_MAXRT; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_MAXSEG")) +#ifdef TCP_MAXSEG + return TCP_MAXSEG; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_NODELAY")) +#ifdef TCP_NODELAY + return TCP_NODELAY; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_STDURG")) +#ifdef TCP_STDURG + return TCP_STDURG; +#else + goto not_there; +#endif break; case 'U': + if (strEQ(name, "UIO_MAXIOV")) +#ifdef UIO_MAXIOV + return UIO_MAXIOV; +#else + goto not_there; +#endif break; case 'V': break; @@ -851,7 +947,7 @@ inet_ntoa(ip_address_sv) Copy( ip_address, &addr, sizeof addr, char ); addr_str = inet_ntoa(addr); - ST(0) = sv_2mortal(newSVpv(addr_str, strlen(addr_str))); + ST(0) = sv_2mortal(newSVpvn(addr_str, strlen(addr_str))); } void @@ -862,13 +958,38 @@ pack_sockaddr_un(pathname) #ifdef I_SYS_UN struct sockaddr_un sun_ad; /* fear using sun */ STRLEN len; + Zero( &sun_ad, sizeof sun_ad, char ); sun_ad.sun_family = AF_UNIX; len = strlen(pathname); if (len > sizeof(sun_ad.sun_path)) len = sizeof(sun_ad.sun_path); +# ifdef OS2 /* Name should start with \socket\ and contain backslashes! */ + { + int off; + char *s, *e; + + if (pathname[0] != '/' && pathname[0] != '\\') + croak("Relative UNIX domain socket name '%s' unsupported", pathname); + else if (len < 8 + || pathname[7] != '/' && pathname[7] != '\\' + || !strnicmp(pathname + 1, "socket", 6)) + off = 7; + else + off = 0; /* Preserve names starting with \socket\ */ + Copy( "\\socket", sun_ad.sun_path, off, char); + Copy( pathname, sun_ad.sun_path + off, len, char ); + + s = sun_ad.sun_path + off - 1; + e = s + len + 1; + while (++s < e) + if (*s = '/') + *s = '\\'; + } +# else /* !( defined OS2 ) */ Copy( pathname, sun_ad.sun_path, len, char ); - ST(0) = sv_2mortal(newSVpv((char *)&sun_ad, sizeof sun_ad)); +# endif + ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad)); #else ST(0) = (SV *) not_here("pack_sockaddr_un"); #endif @@ -903,7 +1024,7 @@ unpack_sockaddr_un(sun_sv) e = addr.sun_path; while (*e && e < addr.sun_path + sizeof addr.sun_path) ++e; - ST(0) = sv_2mortal(newSVpv(addr.sun_path, e - addr.sun_path)); + ST(0) = sv_2mortal(newSVpvn(addr.sun_path, e - addr.sun_path)); #else ST(0) = (SV *) not_here("unpack_sockaddr_un"); #endif @@ -922,7 +1043,7 @@ pack_sockaddr_in(port,ip_address) sin.sin_port = htons(port); Copy( ip_address, &sin.sin_addr, sizeof sin.sin_addr, char ); - ST(0) = sv_2mortal(newSVpv((char *)&sin, sizeof sin)); + ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof sin)); } void @@ -952,7 +1073,7 @@ unpack_sockaddr_in(sin_sv) EXTEND(SP, 2); PUSHs(sv_2mortal(newSViv((IV) port))); - PUSHs(sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address))); + PUSHs(sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address))); } void @@ -961,7 +1082,7 @@ INADDR_ANY() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_ANY); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address )); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address )); } void @@ -970,7 +1091,7 @@ INADDR_LOOPBACK() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_LOOPBACK); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); } void @@ -979,7 +1100,7 @@ INADDR_NONE() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_NONE); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); } void @@ -988,5 +1109,5 @@ INADDR_BROADCAST() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_BROADCAST); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); } diff --git a/contrib/perl5/ext/Sys/Hostname/Hostname.pm b/contrib/perl5/ext/Sys/Hostname/Hostname.pm new file mode 100644 index 0000000..1efc897 --- /dev/null +++ b/contrib/perl5/ext/Sys/Hostname/Hostname.pm @@ -0,0 +1,153 @@ +package Sys::Hostname; + +use strict; + +use Carp; + +require Exporter; +use XSLoader (); +require AutoLoader; + +our @ISA = qw/ Exporter AutoLoader /; +our @EXPORT = qw/ hostname /; + +our $VERSION = '1.1'; + +our $host; + +XSLoader::load 'Sys::Hostname', $VERSION; + +sub hostname { + + # method 1 - we already know it + return $host if defined $host; + + # method 1' - try to ask the system + $host = ghname(); + return $host if defined $host; + + if ($^O eq 'VMS') { + + # method 2 - no sockets ==> return DECnet node name + eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] }; + if ($@) { return $host = $ENV{'SYS$NODE'}; } + + # method 3 - has someone else done the job already? It's common for the + # TCP/IP stack to advertise the hostname via a logical name. (Are + # there any other logicals which TCP/IP stacks use for the host name?) + $host = $ENV{'ARPANET_HOST_NAME'} || $ENV{'INTERNET_HOST_NAME'} || + $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'} || + $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'}; + return $host if $host; + + # method 4 - does hostname happen to work? + my($rslt) = `hostname`; + if ($rslt !~ /IVVERB/) { ($host) = $rslt =~ /^(\S+)/; } + return $host if $host; + + # rats! + $host = ''; + Carp::croak "Cannot get host name of local machine"; + + } + elsif ($^O eq 'MSWin32') { + ($host) = gethostbyname('localhost'); + chomp($host = `hostname 2> NUL`) unless defined $host; + return $host; + } + elsif ($^O eq 'epoc') { + $host = 'localhost'; + return $host; + } + else { # Unix + # is anyone going to make it here? + + # method 2 - syscall is preferred since it avoids tainting problems + # XXX: is it such a good idea to return hostname untainted? + eval { + local $SIG{__DIE__}; + require "syscall.ph"; + $host = "\0" x 65; ## preload scalar + syscall(&SYS_gethostname, $host, 65) == 0; + } + + # method 2a - syscall using systeminfo instead of gethostname + # -- needed on systems like Solaris + || eval { + local $SIG{__DIE__}; + require "sys/syscall.ph"; + require "sys/systeminfo.ph"; + $host = "\0" x 65; ## preload scalar + syscall(&SYS_systeminfo, &SI_HOSTNAME, $host, 65) != -1; + } + + # method 3 - trusty old hostname command + || eval { + local $SIG{__DIE__}; + local $SIG{CHLD}; + $host = `(hostname) 2>/dev/null`; # bsdish + } + + # method 4 - use POSIX::uname(), which strictly can't be expected to be + # correct + || eval { + local $SIG{__DIE__}; + require POSIX; + $host = (POSIX::uname())[1]; + } + + # method 5 - sysV uname command (may truncate) + || eval { + local $SIG{__DIE__}; + $host = `uname -n 2>/dev/null`; ## sysVish + } + + # method 6 - Apollo pre-SR10 + || eval { + local $SIG{__DIE__}; + my($a,$b,$c,$d); + ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6); + } + + # bummer + || Carp::croak "Cannot get host name of local machine"; + + # remove garbage + $host =~ tr/\0\r\n//d; + $host; + } +} + +1; + +__END__ + +=head1 NAME + +Sys::Hostname - Try every conceivable way to get hostname + +=head1 SYNOPSIS + + use Sys::Hostname; + $host = hostname; + +=head1 DESCRIPTION + +Attempts several methods of getting the system hostname and +then caches the result. It tries the first available of the C +library's gethostname(), C<`$Config{aphostname}`>, uname(2), +C<syscall(SYS_gethostname)>, C<`hostname`>, C<`uname -n`>, +and the file F</com/host>. If all that fails it C<croak>s. + +All NULs, returns, and newlines are removed from the result. + +=head1 AUTHOR + +David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt> + +Texas Instruments + +XS code added by Greg Bacon E<lt>F<gbacon@cs.uah.edu>E<gt> + +=cut + diff --git a/contrib/perl5/ext/Sys/Hostname/Hostname.xs b/contrib/perl5/ext/Sys/Hostname/Hostname.xs new file mode 100644 index 0000000..f104383 --- /dev/null +++ b/contrib/perl5/ext/Sys/Hostname/Hostname.xs @@ -0,0 +1,76 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#if defined(I_UNISTD) && defined(HAS_GETHOSTNAME) +# include <unistd.h> +#endif + +/* a reasonable default */ +#ifndef MAXHOSTNAMELEN +# define MAXHOSTNAMELEN 256 +#endif + +/* swiped from POSIX.xs */ +#if defined(__VMS) && !defined(__POSIX_SOURCE) +# if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +# include <utsname.h> +# endif +#endif + +#ifdef I_SYSUTSNAME +# include <sys/utsname.h> +#endif + +MODULE = Sys::Hostname PACKAGE = Sys::Hostname + +void +ghname() + PREINIT: + IV retval = -1; + SV *sv; + PPCODE: + EXTEND(SP, 1); +#ifdef HAS_GETHOSTNAME + { + char tmps[MAXHOSTNAMELEN]; + retval = PerlSock_gethostname(tmps, sizeof(tmps)); + sv = newSVpvn(tmps, strlen(tmps)); + } +#else +# ifdef HAS_PHOSTNAME + { + PerlIO *io; + char tmps[MAXHOSTNAMELEN]; + char *p = tmps; + char c; + io = PerlProc_popen(PHOSTNAME, "r"); + if (!io) + goto check_out; + while (PerlIO_read(io, &c, sizeof(c)) == 1) { + if (isSPACE(c) || p - tmps >= sizeof(tmps)) + break; + *p++ = c; + } + PerlProc_pclose(io); + *p = '\0'; + retval = 0; + sv = newSVpvn(tmps, strlen(tmps)); + } +# else +# ifdef HAS_UNAME + { + struct utsname u; + if (PerlEnv_uname(&u) == -1) + goto check_out; + sv = newSVpvn(u.nodename, strlen(u.nodename)); + retval = 0; + } +# endif +# endif +#endif + check_out: + if (retval == -1) + XSRETURN_UNDEF; + else + PUSHs(sv_2mortal(sv)); diff --git a/contrib/perl5/ext/Sys/Hostname/Makefile.PL b/contrib/perl5/ext/Sys/Hostname/Makefile.PL new file mode 100644 index 0000000..a0892f6 --- /dev/null +++ b/contrib/perl5/ext/Sys/Hostname/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Sys::Hostname', + VERSION_FROM => 'Hostname.pm', + MAN3PODS => {}, # Pods will be built by installman. + XSPROTOARG => '-noprototypes', +); diff --git a/contrib/perl5/ext/Sys/Syslog/Makefile.PL b/contrib/perl5/ext/Sys/Syslog/Makefile.PL new file mode 100644 index 0000000..e5edf3e --- /dev/null +++ b/contrib/perl5/ext/Sys/Syslog/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Sys::Syslog', + VERSION_FROM => 'Syslog.pm', + MAN3PODS => {}, # Pods will be built by installman. + XSPROTOARG => '-noprototypes', +); diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.pm b/contrib/perl5/ext/Sys/Syslog/Syslog.pm new file mode 100644 index 0000000..2a91354 --- /dev/null +++ b/contrib/perl5/ext/Sys/Syslog/Syslog.pm @@ -0,0 +1,294 @@ +package Sys::Syslog; +require 5.000; +require Exporter; +require DynaLoader; +use Carp; + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw(openlog closelog setlogmask syslog); +@EXPORT_OK = qw(setlogsock); +$VERSION = '0.01'; + +use Socket; +use Sys::Hostname; + +# adapted from syslog.pl +# +# Tom Christiansen <tchrist@convex.com> +# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> +# NOTE: openlog now takes three arguments, just like openlog(3) +# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu> +# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list +# Modified to use an XS backend instead of syslog.ph by Tom Hughes <tom@compton.nu> + +# Todo: enable connect to try all three types before failing (auto setlogsock)? + +=head1 NAME + +Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls + +=head1 SYNOPSIS + + use Sys::Syslog; # all except setlogsock, or: + use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock + + setlogsock $sock_type; + openlog $ident, $logopt, $facility; + syslog $priority, $format, @args; + $oldmask = setlogmask $mask_priority; + closelog; + +=head1 DESCRIPTION + +Sys::Syslog is an interface to the UNIX C<syslog(3)> program. +Call C<syslog()> with a string priority and a list of C<printf()> args +just like C<syslog(3)>. + +Syslog provides the functions: + +=over + +=item openlog $ident, $logopt, $facility + +I<$ident> is prepended to every message. +I<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>. +I<$facility> specifies the part of the system + +=item syslog $priority, $format, @args + +If I<$priority> permits, logs I<($format, @args)> +printed as by C<printf(3V)>, with the addition that I<%m> +is replaced with C<"$!"> (the latest error message). + +=item setlogmask $mask_priority + +Sets log mask I<$mask_priority> and returns the old mask. + +=item setlogsock $sock_type (added in 5.004_02) + +Sets the socket type to be used for the next call to +C<openlog()> or C<syslog()> and returns TRUE on success, +undef on failure. + +A value of 'unix' will connect to the UNIX domain socket returned by +C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an +INET socket returned by getservbyname(). Any other value croaks. + +The default is for the INET socket to be used. + +=item closelog + +Closes the log file. + +=back + +Note that C<openlog> now takes three arguments, just like C<openlog(3)>. + +=head1 EXAMPLES + + openlog($program, 'cons,pid', 'user'); + syslog('info', 'this is another test'); + syslog('mail|warning', 'this is a better test: %d', time); + closelog(); + + syslog('debug', 'this is the last test'); + + setlogsock('unix'); + openlog("$program $$", 'ndelay', 'user'); + syslog('notice', 'fooprogram: this is really done'); + + setlogsock('inet'); + $! = 55; + syslog('info', 'problem was %m'); # %m == $! in syslog(3) + +=head1 SEE ALSO + +L<syslog(3)> + +=head1 AUTHOR + +Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>. +UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt> +with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list. +Dependency on F<syslog.ph> replaced with XS code bu Tom Hughes E<lt>F<tom@compton.nu>E<gt>. + +=cut + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + croak "& not defined" if $constname eq 'constant'; + my $val = constant($constname); + if ($! != 0) { + croak "Your vendor has not defined Sys::Syslog macro $constname"; + } + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + +bootstrap Sys::Syslog $VERSION; + +$maskpri = &LOG_UPTO(&LOG_DEBUG); + +sub openlog { + ($ident, $logopt, $facility) = @_; # package vars + $lo_pid = $logopt =~ /\bpid\b/; + $lo_ndelay = $logopt =~ /\bndelay\b/; + $lo_cons = $logopt =~ /\bcons\b/; + $lo_nowait = $logopt =~ /\bnowait\b/; + return 1 unless $lo_ndelay; + &connect; +} + +sub closelog { + $facility = $ident = ''; + &disconnect; +} + +sub setlogmask { + local($oldmask) = $maskpri; + $maskpri = shift; + $oldmask; +} + +sub setlogsock { + local($setsock) = shift; + &disconnect if $connected; + if (lc($setsock) eq 'unix') { + if (defined &_PATH_LOG) { + $sock_type = 1; + } else { + return undef; + } + } elsif (lc($setsock) eq 'inet') { + if (getservbyname('syslog','udp')) { + undef($sock_type); + } else { + return undef; + } + } else { + croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'"; + } + return 1; +} + +sub syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + local(@words, $num, $numpri, $numfac, $sum); + local($facility) = $facility; # may need to change temporarily. + + croak "syslog: expected both priority and mask" unless $mask && $priority; + + @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". + undef $numpri; + undef $numfac; + foreach (@words) { + $num = &xlate($_); # Translate word to number. + if (/^kern$/ || $num < 0) { + croak "syslog: invalid level/facility: $_"; + } + elsif ($num <= &LOG_PRIMASK) { + croak "syslog: too many levels given: $_" if defined($numpri); + $numpri = $num; + return 0 unless &LOG_MASK($numpri) & $maskpri; + } + else { + croak "syslog: too many facilities given: $_" if defined($numfac); + $facility = $_; + $numfac = $num; + } + } + + croak "syslog: level must be given" unless defined($numpri); + + if (!defined($numfac)) { # Facility not specified in this call. + $facility = 'user' unless $facility; + $numfac = &xlate($facility); + } + + &connect unless $connected; + + $whoami = $ident; + + if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) { + $whoami = $1; + $mask = $2; + } + + unless ($whoami) { + ($whoami = getlogin) || + ($whoami = getpwuid($<)) || + ($whoami = 'syslog'); + } + + $whoami .= "[$$]" if $lo_pid; + + $mask =~ s/%m/$!/g; + $mask .= "\n" unless $mask =~ /\n$/; + $message = sprintf ($mask, @_); + + $sum = $numpri + $numfac; + unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) { + if ($lo_cons) { + if ($pid = fork) { + unless ($lo_nowait) { + $died = waitpid($pid, 0); + } + } + else { + if (open(CONS,">/dev/console")) { + print CONS "<$facility.$priority>$whoami: $message\r"; + exit if defined $pid; # if fork failed, we're parent + close CONS; + } + } + } + } +} + +sub xlate { + local($name) = @_; + $name = uc $name; + $name = "LOG_$name" unless $name =~ /^LOG_/; + $name = "Sys::Syslog::$name"; + eval { &$name } || -1; +} + +sub connect { + unless ($host) { + require Sys::Hostname; + my($host_uniq) = Sys::Hostname::hostname(); + ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) + } + unless ( $sock_type ) { + my $udp = getprotobyname('udp'); + my $syslog = getservbyname('syslog','udp'); + my $this = sockaddr_in($syslog, INADDR_ANY); + my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host"); + socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!"; + connect(SYSLOG,$that) || croak "connect: $!"; + } else { + my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph"; + my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; + socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; + if (!connect(SYSLOG,$that)) { + socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) || croak "socket: $!"; + connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)"; + } + } + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; +} + +sub disconnect { + close SYSLOG; + $connected = 0; +} + +1; diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.xs b/contrib/perl5/ext/Sys/Syslog/Syslog.xs new file mode 100644 index 0000000..f0573b8 --- /dev/null +++ b/contrib/perl5/ext/Sys/Syslog/Syslog.xs @@ -0,0 +1,642 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifdef I_SYSLOG +#include <syslog.h> +#endif + +static double +constant_LOG_NO(char *name, int len) +{ + switch (name[6 + 0]) { + case 'T': + if (strEQ(name + 6, "TICE")) { /* LOG_NO removed */ +#ifdef LOG_NOTICE + return LOG_NOTICE; +#else + goto not_there; +#endif + } + case 'W': + if (strEQ(name + 6, "WAIT")) { /* LOG_NO removed */ +#ifdef LOG_NOWAIT + return LOG_NOWAIT; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_N(char *name, int len) +{ + switch (name[5 + 0]) { + case 'D': + if (strEQ(name + 5, "DELAY")) { /* LOG_N removed */ +#ifdef LOG_NDELAY + return LOG_NDELAY; +#else + goto not_there; +#endif + } + case 'E': + if (strEQ(name + 5, "EWS")) { /* LOG_N removed */ +#ifdef LOG_NEWS + return LOG_NEWS; +#else + goto not_there; +#endif + } + case 'F': + if (strEQ(name + 5, "FACILITIES")) { /* LOG_N removed */ +#ifdef LOG_NFACILITIES + return LOG_NFACILITIES; +#else + goto not_there; +#endif + } + case 'O': + return constant_LOG_NO(name, len); + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_P(char *name, int len) +{ + switch (name[5 + 0]) { + case 'I': + if (strEQ(name + 5, "ID")) { /* LOG_P removed */ +#ifdef LOG_PID + return LOG_PID; +#else + goto not_there; +#endif + } + case 'R': + if (strEQ(name + 5, "RIMASK")) { /* LOG_P removed */ +#ifdef LOG_PRIMASK + return LOG_PRIMASK; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_AU(char *name, int len) +{ + if (6 + 2 >= len ) { + errno = EINVAL; + return 0; + } + switch (name[6 + 2]) { + case '\0': + if (strEQ(name + 6, "TH")) { /* LOG_AU removed */ +#ifdef LOG_AUTH + return LOG_AUTH; +#else + goto not_there; +#endif + } + case 'P': + if (strEQ(name + 6, "THPRIV")) { /* LOG_AU removed */ +#ifdef LOG_AUTHPRIV + return LOG_AUTHPRIV; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_A(char *name, int len) +{ + switch (name[5 + 0]) { + case 'L': + if (strEQ(name + 5, "LERT")) { /* LOG_A removed */ +#ifdef LOG_ALERT + return LOG_ALERT; +#else + goto not_there; +#endif + } + case 'U': + return constant_LOG_AU(name, len); + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_CR(char *name, int len) +{ + switch (name[6 + 0]) { + case 'I': + if (strEQ(name + 6, "IT")) { /* LOG_CR removed */ +#ifdef LOG_CRIT + return LOG_CRIT; +#else + goto not_there; +#endif + } + case 'O': + if (strEQ(name + 6, "ON")) { /* LOG_CR removed */ +#ifdef LOG_CRON + return LOG_CRON; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_C(char *name, int len) +{ + switch (name[5 + 0]) { + case 'O': + if (strEQ(name + 5, "ONS")) { /* LOG_C removed */ +#ifdef LOG_CONS + return LOG_CONS; +#else + goto not_there; +#endif + } + case 'R': + return constant_LOG_CR(name, len); + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_D(char *name, int len) +{ + switch (name[5 + 0]) { + case 'A': + if (strEQ(name + 5, "AEMON")) { /* LOG_D removed */ +#ifdef LOG_DAEMON + return LOG_DAEMON; +#else + goto not_there; +#endif + } + case 'E': + if (strEQ(name + 5, "EBUG")) { /* LOG_D removed */ +#ifdef LOG_DEBUG + return LOG_DEBUG; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_U(char *name, int len) +{ + switch (name[5 + 0]) { + case 'S': + if (strEQ(name + 5, "SER")) { /* LOG_U removed */ +#ifdef LOG_USER + return LOG_USER; +#else + goto not_there; +#endif + } + case 'U': + if (strEQ(name + 5, "UCP")) { /* LOG_U removed */ +#ifdef LOG_UUCP + return LOG_UUCP; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_E(char *name, int len) +{ + switch (name[5 + 0]) { + case 'M': + if (strEQ(name + 5, "MERG")) { /* LOG_E removed */ +#ifdef LOG_EMERG + return LOG_EMERG; +#else + goto not_there; +#endif + } + case 'R': + if (strEQ(name + 5, "RR")) { /* LOG_E removed */ +#ifdef LOG_ERR + return LOG_ERR; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_F(char *name, int len) +{ + switch (name[5 + 0]) { + case 'A': + if (strEQ(name + 5, "ACMASK")) { /* LOG_F removed */ +#ifdef LOG_FACMASK + return LOG_FACMASK; +#else + goto not_there; +#endif + } + case 'T': + if (strEQ(name + 5, "TP")) { /* LOG_F removed */ +#ifdef LOG_FTP + return LOG_FTP; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_LO(char *name, int len) +{ + if (6 + 3 >= len ) { + errno = EINVAL; + return 0; + } + switch (name[6 + 3]) { + case '0': + if (strEQ(name + 6, "CAL0")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL0 + return LOG_LOCAL0; +#else + goto not_there; +#endif + } + case '1': + if (strEQ(name + 6, "CAL1")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL1 + return LOG_LOCAL1; +#else + goto not_there; +#endif + } + case '2': + if (strEQ(name + 6, "CAL2")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL2 + return LOG_LOCAL2; +#else + goto not_there; +#endif + } + case '3': + if (strEQ(name + 6, "CAL3")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL3 + return LOG_LOCAL3; +#else + goto not_there; +#endif + } + case '4': + if (strEQ(name + 6, "CAL4")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL4 + return LOG_LOCAL4; +#else + goto not_there; +#endif + } + case '5': + if (strEQ(name + 6, "CAL5")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL5 + return LOG_LOCAL5; +#else + goto not_there; +#endif + } + case '6': + if (strEQ(name + 6, "CAL6")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL6 + return LOG_LOCAL6; +#else + goto not_there; +#endif + } + case '7': + if (strEQ(name + 6, "CAL7")) { /* LOG_LO removed */ +#ifdef LOG_LOCAL7 + return LOG_LOCAL7; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant_LOG_L(char *name, int len) +{ + switch (name[5 + 0]) { + case 'F': + if (strEQ(name + 5, "FMT")) { /* LOG_L removed */ +#ifdef LOG_LFMT + return LOG_LFMT; +#else + goto not_there; +#endif + } + case 'O': + return constant_LOG_LO(name, len); + case 'P': + if (strEQ(name + 5, "PR")) { /* LOG_L removed */ +#ifdef LOG_LPR + return LOG_LPR; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + +static double +constant(char *name, int len) +{ + errno = 0; + if (0 + 4 >= len ) { + errno = EINVAL; + return 0; + } + switch (name[0 + 4]) { + case 'A': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_A(name, len); + case 'C': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_C(name, len); + case 'D': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_D(name, len); + case 'E': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_E(name, len); + case 'F': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_F(name, len); + case 'I': + if (strEQ(name + 0, "LOG_INFO")) { /* removed */ +#ifdef LOG_INFO + return LOG_INFO; +#else + goto not_there; +#endif + } + case 'K': + if (strEQ(name + 0, "LOG_KERN")) { /* removed */ +#ifdef LOG_KERN + return LOG_KERN; +#else + goto not_there; +#endif + } + case 'L': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_L(name, len); + case 'M': + if (strEQ(name + 0, "LOG_MAIL")) { /* removed */ +#ifdef LOG_MAIL + return LOG_MAIL; +#else + goto not_there; +#endif + } + case 'N': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_N(name, len); + case 'O': + if (strEQ(name + 0, "LOG_ODELAY")) { /* removed */ +#ifdef LOG_ODELAY + return LOG_ODELAY; +#else + goto not_there; +#endif + } + case 'P': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_P(name, len); + case 'S': + if (strEQ(name + 0, "LOG_SYSLOG")) { /* removed */ +#ifdef LOG_SYSLOG + return LOG_SYSLOG; +#else + goto not_there; +#endif + } + case 'U': + if (!strnEQ(name + 0,"LOG_", 4)) + break; + return constant_LOG_U(name, len); + case 'W': + if (strEQ(name + 0, "LOG_WARNING")) { /* removed */ +#ifdef LOG_WARNING + return LOG_WARNING; +#else + goto not_there; +#endif + } + } + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = Sys::Syslog PACKAGE = Sys::Syslog + +char * +_PATH_LOG() + CODE: +#ifdef _PATH_LOG + RETVAL = _PATH_LOG; +#else + croak("Your vendor has not defined the Sys::Syslog macro _PATH_LOG"); + RETVAL = NULL; +#endif + OUTPUT: + RETVAL + +int +LOG_FAC(p) + INPUT: + int p + CODE: +#ifdef LOG_FAC + RETVAL = LOG_FAC(p); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_FAC"); + RETVAL = -1; +#endif + OUTPUT: + RETVAL + +int +LOG_PRI(p) + INPUT: + int p + CODE: +#ifdef LOG_PRI + RETVAL = LOG_PRI(p); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_PRI"); + RETVAL = -1; +#endif + OUTPUT: + RETVAL + +int +LOG_MAKEPRI(fac,pri) + INPUT: + int fac + int pri + CODE: +#ifdef LOG_MAKEPRI + RETVAL = LOG_MAKEPRI(fac,pri); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_MAKEPRI"); + RETVAL = -1; +#endif + OUTPUT: + RETVAL + +int +LOG_MASK(pri) + INPUT: + int pri + CODE: +#ifdef LOG_MASK + RETVAL = LOG_MASK(pri); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_MASK"); + RETVAL = -1; +#endif + OUTPUT: + RETVAL + +int +LOG_UPTO(pri) + INPUT: + int pri + CODE: +#ifdef LOG_UPTO + RETVAL = LOG_UPTO(pri); +#else + croak("Your vendor has not defined the Sys::Syslog macro LOG_UPTO"); + RETVAL = -1; +#endif + OUTPUT: + RETVAL + + +double +constant(sv) + PREINIT: + STRLEN len; + INPUT: + SV * sv + char * s = SvPV(sv, len); + CODE: + RETVAL = constant(s,len); + OUTPUT: + RETVAL + diff --git a/contrib/perl5/ext/Thread/Thread.pm b/contrib/perl5/ext/Thread/Thread.pm index c8bca0d..00cba8a 100644 --- a/contrib/perl5/ext/Thread/Thread.pm +++ b/contrib/perl5/ext/Thread/Thread.pm @@ -1,16 +1,16 @@ package Thread; require Exporter; -require DynaLoader; -use vars qw($VERSION @ISA @EXPORT); +use XSLoader (); +our($VERSION, @ISA, @EXPORT); $VERSION = "1.0"; -@ISA = qw(Exporter DynaLoader); +@ISA = qw(Exporter); @EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async); =head1 NAME -Thread - multithreading +Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) =head1 SYNOPSIS @@ -18,20 +18,32 @@ Thread - multithreading my $t = new Thread \&start_sub, @start_args; - $t->join; + $result = $t->join; + $result = $t->eval; + $t->detach; - my $tid = Thread->self->tid; + if($t->equal($another_thread)) { + # ... + } + my $tid = Thread->self->tid; my $tlist = Thread->list; lock($scalar); + yield(); use Thread 'async'; - use Thread 'eval'; - =head1 DESCRIPTION + WARNING: Threading is an experimental feature. Both the interface + and implementation are subject to change drastically. In fact, this + documentation describes the flavor of threads that was in version + 5.005. Perl 5.6.0 and later have the beginnings of support for + interpreter threads, which (when finished) is expected to be + significantly different from what is described here. The information + contained here may therefore soon be obsolete. Use at your own risk! + The C<Thread> module provides multithreading support for perl. =head1 FUNCTIONS @@ -70,8 +82,8 @@ of that container are not locked. For example, if a thread does a C<lock You may also C<lock> a sub, using C<lock &sub>. Any calls to that sub from another thread will block until the lock is released. This behaviour is not -equvalent to C<use attrs qw(locked)> in the sub. C<use attrs qw(locked)> -serializes access to a subroutine, but allows different threads +equivalent to declaring the sub with the C<locked> attribute. The C<locked> +attribute serializes access to a subroutine, but allows different threads non-simultaneous access. C<lock &sub>, on the other hand, will not allow I<any> other thread access for the duration of the lock. @@ -122,6 +134,11 @@ The C<cond_broadcast> function works similarly to C<cond_wait>. C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in a C<cond_wait> on the locked variable, rather than only one. +=item yield + +The C<yield> function allows another thread to take control of the +CPU. The exact results are implementation-dependent. + =back =head1 METHODS @@ -145,6 +162,18 @@ The C<eval> method wraps an C<eval> around a C<join>, and so waits for a thread to exit, passing along any values the thread might have returned. Errors, of course, get placed into C<$@>. +=item detach + +C<detach> tells a thread that it is never going to be joined i.e. +that all traces of its existence can be removed once it stops running. +Errors in detached threads will not be visible anywhere - if you want +to catch them, you should use $SIG{__DIE__} or something like that. + +=item equal + +C<equal> tests whether two thread objects represent the same thread and +returns true if they do. + =item tid The C<tid> method returns the tid of a thread. The tid is a monotonically @@ -152,6 +181,8 @@ increasing integer assigned when a thread is created. The main thread of a program will have a tid of zero, while subsequent threads will have tids assigned starting with one. +=back + =head1 LIMITATIONS The sequence number used to assign tids is a simple integer, and no @@ -161,7 +192,7 @@ duplicate tids. This limitation may be lifted in a future version of Perl. =head1 SEE ALSO -L<attrs>, L<Thread::Queue>, L<Thread::Semaphore>, L<Thread::Specific>. +L<attributes>, L<Thread::Queue>, L<Thread::Semaphore>, L<Thread::Specific>. =cut @@ -180,6 +211,6 @@ sub eval { return eval { shift->join; }; } -bootstrap Thread; +XSLoader::load 'Thread'; 1; diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs index 2337e8c..4b5e6db 100644 --- a/contrib/perl5/ext/Thread/Thread.xs +++ b/contrib/perl5/ext/Thread/Thread.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -20,16 +21,17 @@ static int sig_pipe[2]; #endif static void -remove_thread(struct perl_thread *t) +remove_thread(pTHX_ struct perl_thread *t) { #ifdef USE_THREADS - DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: remove_thread %p\n", thr, t))); MUTEX_LOCK(&PL_threads_mutex); MUTEX_DESTROY(&t->mutex); PL_nthreads--; t->prev->next = t->next; t->next->prev = t->prev; + SvREFCNT_dec(t->oursv); COND_BROADCAST(&PL_nthreads_cond); MUTEX_UNLOCK(&PL_threads_mutex); #endif @@ -48,7 +50,7 @@ threadstart(void *arg) AV *av; int i; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); thr = (Thread) arg; savemark = TOPMARK; @@ -68,7 +70,7 @@ threadstart(void *arg) myop.op_flags |= OPf_WANT_LIST; PL_op = pp_entersub(ARGS); DEBUG_S(if (!PL_op) - PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n")); + PerlIO_printf(Perl_debug_log, "thread starts at Nullop\n")); /* * When this thread is next scheduled, we start in the right * place. When the thread runs off the end of the sub, perl.c @@ -85,13 +87,18 @@ threadstart(void *arg) I32 oldscope = PL_scopestack_ix; I32 retval; SV *sv; - AV *av = newAV(); + AV *av; int i, ret; dJMPENV; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n", + +#if defined(MULTIPLICITY) + PERL_SET_INTERP(thr->interp); +#endif + + DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n", thr)); - /* Don't call *anything* requiring dTHR until after SET_THR() */ + /* Don't call *anything* requiring dTHR until after PERL_SET_THX() */ /* * Wait until our creator releases us. If we didn't do this, then * it would be potentially possible for out thread to carry on and @@ -107,12 +114,13 @@ threadstart(void *arg) * from our pthread_t structure to our struct perl_thread, since * we're the only thread who can get at it anyway. */ - SET_THR(thr); + PERL_SET_THX(thr); /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */ - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); + av = newAV(); sv = POPs; PUTBACK; ENTER; @@ -122,18 +130,18 @@ threadstart(void *arg) retval = SP - (PL_stack_base + oldmark); SP = PL_stack_base + oldmark + 1; if (SvCUR(thr->errsv)) { - STRLEN n_a; MUTEX_LOCK(&thr->mutex); thr->flags |= THRf_DID_DIE; MUTEX_UNLOCK(&thr->mutex); av_store(av, 0, &PL_sv_no); av_store(av, 1, newSVsv(thr->errsv)); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n", - thr, SvPV(thr->errsv, n_a))); - } else { + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p died: %s\n", + thr, SvPV(thr->errsv, PL_na))); + } + else { DEBUG_S(STMT_START { for (i = 1; i <= retval; i++) { - PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n", + PerlIO_printf(Perl_debug_log, "%p return[%d] = %s\n", thr, i, SvPEEK(SP[i - 1])); } } STMT_END); @@ -153,7 +161,6 @@ threadstart(void *arg) SvREFCNT_dec(thr->threadsv); SvREFCNT_dec(thr->specific); SvREFCNT_dec(thr->errsv); - SvREFCNT_dec(thr->errhv); /*Safefree(cxstack);*/ while (PL_curstackinfo->si_next) @@ -175,37 +182,39 @@ threadstart(void *arg) SvREFCNT_dec(PL_rs); SvREFCNT_dec(PL_nrs); SvREFCNT_dec(PL_statname); + SvREFCNT_dec(PL_errors); Safefree(PL_screamfirst); Safefree(PL_screamnext); Safefree(PL_reg_start_tmp); SvREFCNT_dec(PL_lastscream); SvREFCNT_dec(PL_defoutgv); + Safefree(PL_reg_poscache); MUTEX_LOCK(&thr->mutex); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: threadstart finishing: state is %u\n", thr, ThrSTATE(thr))); switch (ThrSTATE(thr)) { case THRf_R_JOINABLE: ThrSETSTATE(thr, THRf_ZOMBIE); MUTEX_UNLOCK(&thr->mutex); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: R_JOINABLE thread finished\n", thr)); break; case THRf_R_JOINED: ThrSETSTATE(thr, THRf_DEAD); MUTEX_UNLOCK(&thr->mutex); - remove_thread(thr); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + remove_thread(aTHX_ thr); + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: R_JOINED thread finished\n", thr)); break; case THRf_R_DETACHED: ThrSETSTATE(thr, THRf_DEAD); MUTEX_UNLOCK(&thr->mutex); SvREFCNT_dec(av); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: DETACHED thread finished\n", thr)); - remove_thread(thr); /* This might trigger main thread to finish */ + remove_thread(aTHX_ thr); /* This might trigger main thread to finish */ break; default: MUTEX_UNLOCK(&thr->mutex); @@ -222,7 +231,7 @@ threadstart(void *arg) } static SV * -newthread (SV *startsv, AV *initargs, char *classname) +newthread (pTHX_ SV *startsv, AV *initargs, char *classname) { #ifdef USE_THREADS dSP; @@ -234,17 +243,18 @@ newthread (SV *startsv, AV *initargs, char *classname) static pthread_attr_t attr; static int attr_inited = 0; sigset_t fullmask, oldmask; + static int attr_joinable = PTHREAD_CREATE_JOINABLE; #endif - + savethread = thr; thr = new_struct_thread(thr); /* temporarily pretend to be the child thread in case the * XPUSHs() below want to grow the child's stack. This is * safe, since the other thread is not yet created, and we * are the only ones who know about it */ - SET_THR(thr); + PERL_SET_THX(thr); SPAGAIN; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: newthread (%p), tid is %u, preparing stack\n", savethread, thr, thr->tid)); /* The following pushes the arg list and startsv onto the *new* stack */ @@ -256,7 +266,7 @@ newthread (SV *startsv, AV *initargs, char *classname) PUTBACK; /* On your marks... */ - SET_THR(savethread); + PERL_SET_THX(savethread); MUTEX_LOCK(&thr->mutex); #ifdef THREAD_CREATE @@ -269,39 +279,27 @@ newthread (SV *startsv, AV *initargs, char *classname) err = 0; if (!attr_inited) { attr_inited = 1; -#ifdef OLD_PTHREADS_API - err = pthread_attr_create(&attr); -#else err = pthread_attr_init(&attr); -#endif -#ifdef OLD_PTHREADS_API -#ifdef VMS -/* This is available with the old pthreads API, but only with */ -/* DecThreads (VMS and Digital Unix) */ - if (err == 0) - err = pthread_attr_setdetach_np(&attr, ATTR_JOINABLE); -#endif -#else +# ifdef PTHREAD_ATTR_SETDETACHSTATE if (err == 0) - err = pthread_attr_setdetachstate(&attr, ATTR_JOINABLE); -#endif + err = PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable); + +# else + croak("panic: can't pthread_attr_setdetachstate"); +# endif } if (err == 0) -#ifdef OLD_PTHREADS_API - err = pthread_create(&thr->self, attr, threadstart, (void*) thr); -#else - err = pthread_create(&thr->self, &attr, threadstart, (void*) thr); -#endif + err = PTHREAD_CREATE(&thr->self, attr, threadstart, (void*) thr); #endif + if (err) { MUTEX_UNLOCK(&thr->mutex); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: create of %p failed %d\n", savethread, thr, err)); /* Thread creation failed--clean up */ SvREFCNT_dec(thr->cvcache); - remove_thread(thr); - MUTEX_DESTROY(&thr->mutex); + remove_thread(aTHX_ thr); for (i = 0; i <= AvFILL(initargs); i++) SvREFCNT_dec(*av_fetch(initargs, i, FALSE)); SvREFCNT_dec(startsv); @@ -330,18 +328,19 @@ newthread (SV *startsv, AV *initargs, char *classname) #endif } -static Signal_t handle_thread_signal _((int sig)); +static Signal_t handle_thread_signal (int sig); static Signal_t handle_thread_signal(int sig) { + dTHXo; unsigned char c = (unsigned char) sig; /* * We're not really allowed to call fprintf in a signal handler * so don't be surprised if this isn't robust while debugging * with -DL. */ - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "handle_thread_signal: got signal %d\n", sig);); write(sig_pipe[1], &c, 1); } @@ -355,7 +354,7 @@ new(classname, startsv, ...) SV * startsv AV * av = av_make(items - 2, &ST(2)); PPCODE: - XPUSHs(sv_2mortal(newthread(startsv, av, classname))); + XPUSHs(sv_2mortal(newthread(aTHX_ startsv, av, classname))); void join(t) @@ -364,7 +363,9 @@ join(t) int i = NO_INIT PPCODE: #ifdef USE_THREADS - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n", + if (t == thr) + croak("Attempt to join self"); + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n", thr, t, ThrSTATE(t));); MUTEX_LOCK(&t->mutex); switch (ThrSTATE(t)) { @@ -376,7 +377,7 @@ join(t) case THRf_ZOMBIE: ThrSETSTATE(t, THRf_DEAD); MUTEX_UNLOCK(&t->mutex); - remove_thread(t); + remove_thread(aTHX_ t); break; default: MUTEX_UNLOCK(&t->mutex); @@ -385,14 +386,17 @@ join(t) } JOIN(t, &av); + sv_2mortal((SV*)av); + if (SvTRUE(*av_fetch(av, 0, FALSE))) { /* Could easily speed up the following if necessary */ for (i = 1; i <= AvFILL(av); i++) - XPUSHs(sv_2mortal(*av_fetch(av, i, FALSE))); - } else { + XPUSHs(*av_fetch(av, i, FALSE)); + } + else { STRLEN n_a; char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: join propagating die message: %s\n", thr, mess)); croak(mess); @@ -404,7 +408,7 @@ detach(t) Thread t CODE: #ifdef USE_THREADS - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n", thr, t, ThrSTATE(t));); MUTEX_LOCK(&t->mutex); switch (ThrSTATE(t)) { @@ -419,7 +423,7 @@ detach(t) ThrSETSTATE(t, THRf_DEAD); DETACH(t); MUTEX_UNLOCK(&t->mutex); - remove_thread(t); + remove_thread(aTHX_ t); break; default: MUTEX_UNLOCK(&t->mutex); @@ -496,7 +500,7 @@ CODE: sv = SvRV(sv); mg = condpair_magic(sv); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv)); + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_wait %p\n", thr, sv)); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) { MUTEX_UNLOCK(MgMUTEXP(mg)); @@ -521,7 +525,7 @@ CODE: sv = SvRV(sv); mg = condpair_magic(sv); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv)); + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_signal %p\n",thr,sv)); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) { MUTEX_UNLOCK(MgMUTEXP(mg)); @@ -541,7 +545,7 @@ CODE: sv = SvRV(sv); mg = condpair_magic(sv); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n", + DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_broadcast %p\n", thr, sv)); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) { @@ -643,8 +647,8 @@ await_signal() croak("panic: await_signal"); ST(0) = sv_newmortal(); if (ret) - sv_setsv(ST(0), c ? psig_ptr[c] : &PL_sv_no); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no); + DEBUG_S(PerlIO_printf(Perl_debug_log, "await_signal returning %s\n", SvPEEK(ST(0)));); MODULE = Thread PACKAGE = Thread::Specific diff --git a/contrib/perl5/ext/Thread/Thread/Queue.pm b/contrib/perl5/ext/Thread/Thread/Queue.pm index 6d5f82b..831573c 100644 --- a/contrib/perl5/ext/Thread/Thread/Queue.pm +++ b/contrib/perl5/ext/Thread/Thread/Queue.pm @@ -67,15 +67,13 @@ sub new { return bless [@_], $class; } -sub dequeue { - use attrs qw(locked method); +sub dequeue : locked : method { my $q = shift; cond_wait $q until @$q; return shift @$q; } -sub dequeue_nb { - use attrs qw(locked method); +sub dequeue_nb : locked : method { my $q = shift; if (@$q) { return shift @$q; @@ -84,14 +82,12 @@ sub dequeue_nb { } } -sub enqueue { - use attrs qw(locked method); +sub enqueue : locked : method { my $q = shift; push(@$q, @_) and cond_broadcast $q; } -sub pending { - use attrs qw(locked method); +sub pending : locked : method { my $q = shift; return scalar(@$q); } diff --git a/contrib/perl5/ext/Thread/Thread/Semaphore.pm b/contrib/perl5/ext/Thread/Thread/Semaphore.pm index 915808c..3cd6338 100644 --- a/contrib/perl5/ext/Thread/Thread/Semaphore.pm +++ b/contrib/perl5/ext/Thread/Thread/Semaphore.pm @@ -69,16 +69,14 @@ sub new { bless \$val, $class; } -sub down { - use attrs qw(locked method); +sub down : locked : method { my $s = shift; my $inc = @_ ? shift : 1; cond_wait $s until $$s >= $inc; $$s -= $inc; } -sub up { - use attrs qw(locked method); +sub up : locked : method { my $s = shift; my $inc = @_ ? shift : 1; ($$s += $inc) > 0 and cond_broadcast $s; diff --git a/contrib/perl5/ext/Thread/Thread/Specific.pm b/contrib/perl5/ext/Thread/Thread/Specific.pm index 9c8a66a..a6271a4 100644 --- a/contrib/perl5/ext/Thread/Thread/Specific.pm +++ b/contrib/perl5/ext/Thread/Thread/Specific.pm @@ -15,14 +15,13 @@ C<key_create> returns a unique thread-specific key. =cut -sub import { - use attrs qw(locked method); +sub import : locked : method { require fields; - fields->import(@_); + fields::->import(@_); } -sub key_create { - use attrs qw(locked method); +sub key_create : locked : method { + our %FIELDS; # suppress "used only once" return ++$FIELDS{__MAX__}; } diff --git a/contrib/perl5/ext/Thread/sync.t b/contrib/perl5/ext/Thread/sync.t index 9c2e589..6445b55 100644 --- a/contrib/perl5/ext/Thread/sync.t +++ b/contrib/perl5/ext/Thread/sync.t @@ -2,8 +2,7 @@ use Thread; $level = 0; -sub single_file { - use attrs 'locked'; +sub single_file : locked { my $arg = shift; $level++; print "Level $level for $arg\n"; diff --git a/contrib/perl5/ext/Thread/sync2.t b/contrib/perl5/ext/Thread/sync2.t index 0901da4..ffc74b4 100644 --- a/contrib/perl5/ext/Thread/sync2.t +++ b/contrib/perl5/ext/Thread/sync2.t @@ -2,8 +2,7 @@ use Thread; $global = undef; -sub single_file { - use attrs 'locked'; +sub single_file : locked { my $who = shift; my $i; diff --git a/contrib/perl5/ext/Thread/typemap b/contrib/perl5/ext/Thread/typemap index 21eb6c3..7ce7d5c 100644 --- a/contrib/perl5/ext/Thread/typemap +++ b/contrib/perl5/ext/Thread/typemap @@ -13,7 +13,7 @@ T_XSCPTR || mg->mg_private != ${ntype}_MAGIC_SIGNATURE) croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\"); $var = ($type) SvPVX(mg->mg_obj); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(Perl_debug_log, \"XSUB ${func_name}: %p\\n\", $var);) } STMT_END T_IVREF diff --git a/contrib/perl5/ext/attrs/attrs.pm b/contrib/perl5/ext/attrs/attrs.pm index fe2bf35..2070632 100644 --- a/contrib/perl5/ext/attrs/attrs.pm +++ b/contrib/perl5/ext/attrs/attrs.pm @@ -1,14 +1,11 @@ package attrs; -require DynaLoader; -use vars '@ISA'; -@ISA = 'DynaLoader'; +use XSLoader (); -use vars qw($VERSION); $VERSION = "1.0"; =head1 NAME -attrs - set/get attributes of a subroutine +attrs - set/get attributes of a subroutine (deprecated) =head1 SYNOPSIS @@ -21,11 +18,17 @@ attrs - set/get attributes of a subroutine =head1 DESCRIPTION -This module lets you set and get attributes for subroutines. +NOTE: Use of this pragma is deprecated. Use the syntax + + sub foo : locked method { } + +to declare attributes instead. See also L<attributes>. + +This pragma lets you set and get attributes for subroutines. Setting attributes takes place at compile time; trying to set invalid attribute names causes a compile-time error. Calling -C<attr::get> on a subroutine reference or name returns its list -of attribute names. Notice that C<attr::get> is not exported. +C<attrs::get> on a subroutine reference or name returns its list +of attribute names. Notice that C<attrs::get> is not exported. Valid attributes are as follows. =over @@ -50,6 +53,6 @@ subroutine is entered. =cut -bootstrap attrs $VERSION; +XSLoader::load 'attrs', $VERSION; 1; diff --git a/contrib/perl5/ext/attrs/attrs.xs b/contrib/perl5/ext/attrs/attrs.xs index 7f7970d..4c00cd7 100644 --- a/contrib/perl5/ext/attrs/attrs.xs +++ b/contrib/perl5/ext/attrs/attrs.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -26,6 +27,10 @@ char * Class PPCODE: if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv))) croak("can't set attributes outside a subroutine scope"); + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, + "pragma \"attrs\" is deprecated, " + "use \"sub NAME : ATTRS\" instead"); for (i = 1; i < items; i++) { STRLEN n_a; char *attr = SvPV(ST(i), n_a); @@ -55,7 +60,7 @@ SV * sub if (!sub) croak("invalid subroutine reference or name"); if (CvFLAGS(sub) & CVf_METHOD) - XPUSHs(sv_2mortal(newSVpv("method", 0))); + XPUSHs(sv_2mortal(newSVpvn("method", 6))); if (CvFLAGS(sub) & CVf_LOCKED) - XPUSHs(sv_2mortal(newSVpv("locked", 0))); + XPUSHs(sv_2mortal(newSVpvn("locked", 6))); diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL index 040b085..bd0f1f7 100644 --- a/contrib/perl5/ext/re/Makefile.PL +++ b/contrib/perl5/ext/re/Makefile.PL @@ -5,7 +5,7 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)', - DEFINE => '-DPERL_EXT_RE_BUILD', + DEFINE => '-DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG', clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, ); diff --git a/contrib/perl5/ext/re/re.pm b/contrib/perl5/ext/re/re.pm index 83e7dba..3f142d9 100644 --- a/contrib/perl5/ext/re/re.pm +++ b/contrib/perl5/ext/re/re.pm @@ -41,11 +41,11 @@ on tainted data aren't meant to extract safe substrings, but to perform other transformations. When C<use re 'eval'> is in effect, a regex is allowed to contain -C<(?{ ... })> zero-width assertions even if the regex contains -variable interpolation. This is normally disallowed, since it is a +C<(?{ ... })> zero-width assertions even if regular expression contains +variable interpolation. That is normally disallowed, since it is a potential security risk. Note that this pragma is ignored when the regular expression is obtained from tainted data, i.e. evaluation is always -disallowed with tainted regular expressions. See L<perlre/(?{ code })>. +disallowed with tainted regular expresssions. See L<perlre/(?{ code })>. For the purpose of this pragma, interpolation of precompiled regular expressions (i.e., the result of C<qr//>) is I<not> considered variable @@ -74,6 +74,8 @@ See L<perlmodlib/Pragmatic Modules>. =cut +# N.B. File::Basename contains a literal for 'taint' as a fallback. If +# taint is changed here, File::Basename must be updated as well. my %bitmask = ( taint => 0x00100000, eval => 0x00200000, @@ -84,16 +86,13 @@ sub setcolor { require Term::Cap; my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. - my $props = $ENV{PERL_RE_TC} || 'md,me,so,se'; # can use us/ue later + my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; my @props = split /,/, $props; + my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; - - $ENV{TERMCAP_COLORS} = join "\t", map {$terminal->Tputs($_,1)} @props; + $colors =~ s/\0//g; + $ENV{PERL_RE_COLORS} = $colors; }; - - not defined $ENV{TERMCAP_COLORS} or ($ENV{TERMCAP_COLORS} =~ tr/\t/\t/) >= 4 - or not defined $ENV{PERL_RE_TC} - or die "Not enough fields in \$ENV{PERL_RE_TC}=`$ENV{PERL_RE_TC}'"; } sub bits { @@ -106,9 +105,8 @@ sub bits { foreach my $s (@_){ if ($s eq 'debug' or $s eq 'debugcolor') { setcolor() if $s eq 'debugcolor'; - require DynaLoader; - @ISA = ('DynaLoader'); - bootstrap re; + require XSLoader; + XSLoader::load('re'); install() if $on; uninstall() unless $on; next; diff --git a/contrib/perl5/ext/re/re.xs b/contrib/perl5/ext/re/re.xs index 7230d62..04a5fdc 100644 --- a/contrib/perl5/ext/re/re.xs +++ b/contrib/perl5/ext/re/re.xs @@ -3,36 +3,49 @@ # define DEBUGGING #endif +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -extern regexp* my_regcomp _((char* exp, char* xend, PMOP* pm)); -extern I32 my_regexec _((regexp* prog, char* stringarg, char* strend, - char* strbeg, I32 minend, SV* screamer, - void* data, U32 flags)); +extern regexp* my_regcomp (pTHX_ char* exp, char* xend, PMOP* pm); +extern I32 my_regexec (pTHX_ regexp* prog, char* stringarg, char* strend, + char* strbeg, I32 minend, SV* screamer, + void* data, U32 flags); +extern void my_regfree (pTHX_ struct regexp* r); +extern char* my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos, + char *strend, U32 flags, + struct re_scream_pos_data_s *data); +extern SV* my_re_intuit_string (pTHX_ regexp *prog); static int oldfl; #define R_DB 512 static void -deinstall(void) +deinstall(pTHX) { dTHR; - PL_regexecp = ®exec_flags; - PL_regcompp = &pregcomp; + PL_regexecp = Perl_regexec_flags; + PL_regcompp = Perl_pregcomp; + PL_regint_start = Perl_re_intuit_start; + PL_regint_string = Perl_re_intuit_string; + PL_regfree = Perl_pregfree; + if (!oldfl) PL_debug &= ~R_DB; } static void -install(void) +install(pTHX) { dTHR; PL_colorset = 0; /* Allow reinspection of ENV. */ PL_regexecp = &my_regexec; PL_regcompp = &my_regcomp; + PL_regint_start = &my_re_intuit_start; + PL_regint_string = &my_re_intuit_string; + PL_regfree = &my_regfree; oldfl = PL_debug & R_DB; PL_debug |= R_DB; } @@ -41,6 +54,10 @@ MODULE = re PACKAGE = re void install() + CODE: + install(aTHX); void deinstall() + CODE: + deinstall(aTHX); |
