diff options
Diffstat (limited to 'contrib/perl5/ext')
90 files changed, 3426 insertions, 1552 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm index 4512d916e61e..c58e769a84d5 100644 --- a/contrib/perl5/ext/B/B.pm +++ b/contrib/perl5/ext/B/B.pm @@ -9,11 +9,17 @@ package B; use XSLoader (); require Exporter; @ISA = qw(Exporter); -@EXPORT_OK = qw(minus_c ppname + +# walkoptree_slow comes from B.pm (you are there), +# walkoptree comes from B.xs +@EXPORT_OK = qw(minus_c ppname save_BEGINs class peekop cast_I32 cstring cchar hash threadsv_names - 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); + main_root main_start main_cv svref_2object opnumber + amagic_generation + walkoptree_slow walkoptree walkoptree_exec walksymtable + parents comppadlist sv_undef compile_stats timing_info + begin_av init_av end_av); + sub OPf_KIDS (); use strict; @B::SV::ISA = 'B::OBJECT'; @@ -54,6 +60,21 @@ use strict; package B::OBJECT; } +sub B::GV::SAFENAME { + my $name = (shift())->NAME; + + # The regex below corresponds to the isCONTROLVAR macro + # from toke.c + + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; + return $name; +} + +sub B::IV::int_value { + my ($self) = @_; + return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); +} + my $debug; my $op_count = 0; my @parents = (); @@ -125,6 +146,7 @@ sub objsym { sub walkoptree_exec { my ($op, $method, $level) = @_; + $level ||= 0; my ($sym, $ppname); my $prefix = " " x $level; for (; $$op; $op = $op->next) { @@ -184,7 +206,7 @@ sub walksymtable { *glob = "*main::".$prefix.$sym; if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) { + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walksymtable(\%glob, $method, $recurse, $sym); } } else { @@ -326,8 +348,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item IV +Returns the value of the IV, I<interpreted as +a signed integer>. This will be misleading +if C<FLAGS & SVf_IVisUV>. Perhaps you want the +C<int_value> method instead? + =item IVX +=item UVX + +=item int_value + +This method returns the value of the IV as an integer. +It differs from C<IV> in that it returns the correct +value regardless of whether it's stored signed or +unsigned. + =item needs64bits =item packiv @@ -358,6 +394,22 @@ C<REFCNT> (corresponding to the C function C<SvREFCNT>). =item PV +This method is the one you usually want. It constructs a +string using the length and offset information in the struct: +for ordinary scalars it will return the string that you'd see +from Perl, even if it contains null characters. + +=item PVX + +This method is less often useful. It assumes that the string +stored in the struct is null-terminated, and disregards the +length information. + +It is the appropriate method to use if you need to get the name +of a lexical variable from a padname array. Lexical variable names +are always stored with a null terminator, and the length field +(SvCUR) is overloaded for other purposes and can't be relied on here. + =back =head2 B::PVMG METHODS @@ -426,6 +478,21 @@ This method returns TRUE if the GP field of the GV is NULL. =item NAME +=item SAFENAME + +This method returns the name of the glob, but if the first +character of the name is a control character, then it converts +it to ^X first, so that *^G would return "^G" rather than "\cG". + +It's useful if you want to print out the name of a variable. +If you restrict yourself to globs which exist at compile-time +then the result ought to be unambiguous, because code like +C<${"^G"} = 1> is compiled as two ops - a constant string and +a dereference (rv2gv) - so that the glob is created at runtime. + +If you're working with globs at runtime, and need to disambiguate +*^G from *{"^G"}, then you should use the raw NAME method. + =item STASH =item SV diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs index 9e2985582a15..100574752115 100644 --- a/contrib/perl5/ext/B/B.xs +++ b/contrib/perl5/ext/B/B.xs @@ -81,7 +81,7 @@ static char *opclassnames[] = { static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */ -static SV *specialsv_list[4]; +static SV *specialsv_list[6]; static opclass cc_opclass(pTHX_ OP *o) @@ -386,11 +386,15 @@ BOOT: specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; #include "defsubs.h" } #define B_main_cv() PL_main_cv #define B_init_av() PL_initav +#define B_begin_av() PL_beginav_save +#define B_end_av() PL_endav #define B_main_root() PL_main_root #define B_main_start() PL_main_start #define B_amagic_generation() PL_amagic_generation @@ -402,6 +406,12 @@ BOOT: B::AV B_init_av() +B::AV +B_begin_av() + +B::AV +B_end_av() + B::CV B_main_cv() @@ -515,6 +525,11 @@ minus_c() CODE: PL_minus_c = TRUE; +void +save_BEGINs() + CODE: + PL_minus_c |= 0x10; + SV * cstring(sv) SV * sv @@ -567,11 +582,12 @@ char * OP_name(o) B::OP o CODE: - ST(0) = sv_newmortal(); - sv_setpv(ST(0), PL_op_name[o->op_type]); + RETVAL = PL_op_name[o->op_type]; + OUTPUT: + RETVAL -char * +void OP_ppaddr(o) B::OP o PREINIT: @@ -633,13 +649,20 @@ B::OP LOGOP_other(o) B::LOGOP o -#define LISTOP_children(o) o->op_children - MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_ U32 LISTOP_children(o) B::LISTOP o + OP * kid = NO_INIT + int i = NO_INIT + CODE: + i = 0; + for (kid = o->op_first; kid; kid = kid->op_sibling) + i++; + RETVAL = i; + OUTPUT: + RETVAL #define PMOP_pmreplroot(o) o->op_pmreplroot #define PMOP_pmreplstart(o) o->op_pmreplstart @@ -693,8 +716,8 @@ PMOP_precomp(o) if (rx) sv_setpvn(ST(0), rx->precomp, rx->prelen); -#define SVOP_sv(o) cSVOPo->op_sv -#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) +#define SVOP_sv(o) cSVOPo->op_sv +#define SVOP_gv(o) ((GV*)cSVOPo->op_sv) MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_ @@ -862,11 +885,11 @@ packiv(sv) MODULE = B PACKAGE = B::NV PREFIX = Sv -double +NV SvNV(sv) B::NV sv -double +NV SvNVX(sv) B::NV sv @@ -878,6 +901,10 @@ SvRV(sv) MODULE = B PACKAGE = B::PV PREFIX = Sv +char* +SvPVX(sv) + B::PV sv + void SvPV(sv) B::PV sv @@ -1210,7 +1237,7 @@ CvXSUBANY(cv) MODULE = B PACKAGE = B::CV -U8 +U16 CvFLAGS(cv) B::CV cv @@ -1251,7 +1278,7 @@ HvARRAY(hv) I32 len; (void)hv_iterinit(hv); EXTEND(sp, HvKEYS(hv) * 2); - while (sv = hv_iternextsv(hv, &key, &len)) { + while ((sv = hv_iternextsv(hv, &key, &len))) { 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 bc0eda935b7a..dc176be9626e 100644 --- a/contrib/perl5/ext/B/B/Asmdata.pm +++ b/contrib/perl5/ext/B/B/Asmdata.pm @@ -15,7 +15,7 @@ use Exporter; our(%insn_data, @insn_name, @optype, @specialsv_name); @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); +@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); # XXX insn_data is initialised this way because with a large # %insn_data = (foo => [...], bar => [...], ...) initialiser @@ -27,93 +27,93 @@ $insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; $insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; $insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; $insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; -$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"]; -$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"]; -$insn_data{newop} = [7, \&PUT_U8, "GET_U8"]; -$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"]; -$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"]; -$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"]; -$insn_data{pv_free} = [12, \&PUT_none, "GET_none"]; -$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"]; -$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"]; -$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"]; -$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"]; -$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_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"]; -$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"]; -$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"]; -$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"]; -$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"]; -$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"]; -$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"]; -$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"]; -$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_top_gv} = [36, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_fmt_gv} = [38, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xio_bottom_gv} = [40, \&PUT_svindex, "GET_svindex"]; -$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"]; -$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"]; -$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"]; -$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_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_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"]; -$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"]; -$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"]; -$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"]; -$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{hv_store} = [60, \&PUT_svindex, "GET_svindex"]; -$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"]; -$insn_data{mg_obj} = [62, \&PUT_svindex, "GET_svindex"]; -$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"]; -$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"]; -$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{xmg_stash} = [66, \&PUT_svindex, "GET_svindex"]; -$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"]; -$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"]; -$insn_data{gp_sv} = [69, \&PUT_svindex, "GET_svindex"]; -$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"]; -$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_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"]; -$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"]; -$insn_data{gp_share} = [80, \&PUT_svindex, "GET_svindex"]; -$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"]; -$insn_data{op_next} = [82, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_sibling} = [83, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"]; -$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"]; -$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"]; -$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"]; -$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"]; -$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_children} = [93, \&PUT_U32, "GET_U32"]; +$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; +$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; +$insn_data{newsv} = [7, \&PUT_U8, "GET_U8"]; +$insn_data{newop} = [8, \&PUT_U8, "GET_U8"]; +$insn_data{newopn} = [9, \&PUT_U8, "GET_U8"]; +$insn_data{newpv} = [11, \&PUT_PV, "GET_PV"]; +$insn_data{pv_cur} = [12, \&PUT_U32, "GET_U32"]; +$insn_data{pv_free} = [13, \&PUT_none, "GET_none"]; +$insn_data{sv_upgrade} = [14, \&PUT_U8, "GET_U8"]; +$insn_data{sv_refcnt} = [15, \&PUT_U32, "GET_U32"]; +$insn_data{sv_refcnt_add} = [16, \&PUT_I32, "GET_I32"]; +$insn_data{sv_flags} = [17, \&PUT_U32, "GET_U32"]; +$insn_data{xrv} = [18, \&PUT_svindex, "GET_svindex"]; +$insn_data{xpv} = [19, \&PUT_none, "GET_none"]; +$insn_data{xiv32} = [20, \&PUT_I32, "GET_I32"]; +$insn_data{xiv64} = [21, \&PUT_IV64, "GET_IV64"]; +$insn_data{xnv} = [22, \&PUT_NV, "GET_NV"]; +$insn_data{xlv_targoff} = [23, \&PUT_U32, "GET_U32"]; +$insn_data{xlv_targlen} = [24, \&PUT_U32, "GET_U32"]; +$insn_data{xlv_targ} = [25, \&PUT_svindex, "GET_svindex"]; +$insn_data{xlv_type} = [26, \&PUT_U8, "GET_U8"]; +$insn_data{xbm_useful} = [27, \&PUT_I32, "GET_I32"]; +$insn_data{xbm_previous} = [28, \&PUT_U16, "GET_U16"]; +$insn_data{xbm_rare} = [29, \&PUT_U8, "GET_U8"]; +$insn_data{xfm_lines} = [30, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines} = [31, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page} = [32, \&PUT_I32, "GET_I32"]; +$insn_data{xio_page_len} = [33, \&PUT_I32, "GET_I32"]; +$insn_data{xio_lines_left} = [34, \&PUT_I32, "GET_I32"]; +$insn_data{xio_top_name} = [36, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_top_gv} = [37, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_fmt_name} = [38, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_fmt_gv} = [39, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_bottom_name} = [40, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xio_bottom_gv} = [41, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_subprocess} = [42, \&PUT_U16, "GET_U16"]; +$insn_data{xio_type} = [43, \&PUT_U8, "GET_U8"]; +$insn_data{xio_flags} = [44, \&PUT_U8, "GET_U8"]; +$insn_data{xcv_stash} = [45, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_start} = [46, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_root} = [47, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_gv} = [48, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_file} = [49, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xcv_depth} = [50, \&PUT_I32, "GET_I32"]; +$insn_data{xcv_padlist} = [51, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_outside} = [52, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_flags} = [53, \&PUT_U16, "GET_U16"]; +$insn_data{av_extend} = [54, \&PUT_I32, "GET_I32"]; +$insn_data{av_push} = [55, \&PUT_svindex, "GET_svindex"]; +$insn_data{xav_fill} = [56, \&PUT_I32, "GET_I32"]; +$insn_data{xav_max} = [57, \&PUT_I32, "GET_I32"]; +$insn_data{xav_flags} = [58, \&PUT_U8, "GET_U8"]; +$insn_data{xhv_riter} = [59, \&PUT_I32, "GET_I32"]; +$insn_data{xhv_name} = [60, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{hv_store} = [61, \&PUT_svindex, "GET_svindex"]; +$insn_data{sv_magic} = [62, \&PUT_U8, "GET_U8"]; +$insn_data{mg_obj} = [63, \&PUT_svindex, "GET_svindex"]; +$insn_data{mg_private} = [64, \&PUT_U16, "GET_U16"]; +$insn_data{mg_flags} = [65, \&PUT_U8, "GET_U8"]; +$insn_data{mg_pv} = [66, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{xmg_stash} = [67, \&PUT_svindex, "GET_svindex"]; +$insn_data{gv_fetchpv} = [68, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_stashpv} = [69, \&PUT_strconst, "GET_strconst"]; +$insn_data{gp_sv} = [70, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_refcnt} = [71, \&PUT_U32, "GET_U32"]; +$insn_data{gp_refcnt_add} = [72, \&PUT_I32, "GET_I32"]; +$insn_data{gp_av} = [73, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_hv} = [74, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cv} = [75, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_file} = [76, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{gp_io} = [77, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_form} = [78, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cvgen} = [79, \&PUT_U32, "GET_U32"]; +$insn_data{gp_line} = [80, \&PUT_U16, "GET_U16"]; +$insn_data{gp_share} = [81, \&PUT_svindex, "GET_svindex"]; +$insn_data{xgv_flags} = [82, \&PUT_U8, "GET_U8"]; +$insn_data{op_next} = [83, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_sibling} = [84, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_ppaddr} = [85, \&PUT_strconst, "GET_strconst"]; +$insn_data{op_targ} = [86, \&PUT_U32, "GET_U32"]; +$insn_data{op_type} = [87, \&PUT_U16, "GET_U16"]; +$insn_data{op_seq} = [88, \&PUT_U16, "GET_U16"]; +$insn_data{op_flags} = [89, \&PUT_U8, "GET_U8"]; +$insn_data{op_private} = [90, \&PUT_U8, "GET_U8"]; +$insn_data{op_first} = [91, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_last} = [92, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_other} = [93, \&PUT_opindex, "GET_opindex"]; $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"]; @@ -128,9 +128,9 @@ $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_label} = [108, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_stashpv} = [109, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_file} = [110, \&PUT_pvindex, "GET_pvindex"]; $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"]; @@ -138,6 +138,9 @@ $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"]; +$insn_data{push_begin} = [118, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_init} = [119, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_end} = [120, \&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 6c51a9ad3e3b..5e798ce485d4 100644 --- a/contrib/perl5/ext/B/B/Assembler.pm +++ b/contrib/perl5/ext/B/B/Assembler.pm @@ -4,14 +4,17 @@ # # 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::Assembler; use Exporter; use B qw(ppname); use B::Asmdata qw(%insn_data @insn_name); +use Config qw(%Config); +require ByteLoader; # we just need its $VERSIOM @ISA = qw(Exporter); -@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments - parse_statement uncstring); +@EXPORT_OK = qw(assemble_fh newasm endasm assemble); +$VERSION = 0.02; use strict; my %opnumber; @@ -20,7 +23,7 @@ for ($i = 0; defined($opname = ppname($i)); $i++) { $opnumber{$opname} = $i; } -my ($linenum, $errors); +my($linenum, $errors, $out); # global state, set up by newasm sub error { my $str = shift; @@ -49,13 +52,15 @@ sub B::Asmdata::PUT_U8 { return $c; } -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_U16 { pack("S", $_[0]) } +sub B::Asmdata::PUT_U32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_I32 { pack("L", $_[0]) } +sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) + # may not even be portable between compilers +sub B::Asmdata::PUT_objindex { pack("L", $_[0]) } # could allow names here sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } sub B::Asmdata::PUT_strconst { my $arg = shift; @@ -79,7 +84,7 @@ sub B::Asmdata::PUT_PV { my $arg = shift; $arg = uncstring($arg); error "bad string argument: $arg" unless defined($arg); - return pack("N", length($arg)) . $arg; + return pack("L", length($arg)) . $arg; } sub B::Asmdata::PUT_comment_t { my $arg = shift; @@ -90,7 +95,7 @@ sub B::Asmdata::PUT_comment_t { } return $arg . "\n"; } -sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above sub B::Asmdata::PUT_none { my $arg = shift; error "extraneous argument: $arg" if defined $arg; @@ -103,12 +108,12 @@ sub B::Asmdata::PUT_op_tr_array { error "wrong number of arguments to op_tr_array"; @ary = (0) x 256; } - return pack("n256", @ary); + return pack("S256", @ary); } # XXX Check this works sub B::Asmdata::PUT_IV64 { my $arg = shift; - return pack("NN", $arg >> 32, $arg & 0xffffffff); + return pack("LL", $arg >> 32, $arg & 0xffffffff); } my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", @@ -138,6 +143,24 @@ sub strip_comments { return $stmt; } +# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, +# ptrsize, byteorder +# nvtype is irrelevant (floats are stored as strings) +# byteorder is strconst not U32 because of varying size issues + +sub gen_header { + my $header = ""; + + $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' + $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); + $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); + $header .= B::Asmdata::PUT_U32($Config{ivsize}); + $header .= B::Asmdata::PUT_U32($Config{ptrsize}); + $header .= B::Asmdata::PUT_strconst(sprintf(qq["0x%s"], $Config{byteorder})); + + $header; +} + sub parse_statement { my $stmt = shift; my ($insn, $arg) = $stmt =~ m{ @@ -183,27 +206,52 @@ sub assemble_insn { sub assemble_fh { my ($fh, $out) = @_; - my ($line, $insn, $arg); - $linenum = 0; - $errors = 0; + my $line; + my $asm = newasm($out); while ($line = <$fh>) { - $linenum++; - chomp $line; - if ($debug) { - my $quotedline = $line; - $quotedline =~ s/\\/\\\\/g; - $quotedline =~ s/"/\\"/g; - &$out(assemble_insn("comment", qq("$quotedline"))); - } - $line = strip_comments($line) or next; - ($insn, $arg) = parse_statement($line); - &$out(assemble_insn($insn, $arg)); - if ($debug) { - &$out(assemble_insn("nop", undef)); - } + assemble($line); } + endasm(); +} + +sub newasm { + my($outsub) = @_; + + die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; + die <<EOD if ref $out; +Can't have multiple byteassembly sessions at once! + (perhaps you forgot an endasm()?) +EOD + + $linenum = $errors = 0; + $out = $outsub; + + $out->(gen_header()); +} + +sub endasm { if ($errors) { - die "Assembly failed with $errors error(s)\n"; + die "There were $errors assembly errors\n"; + } + $linenum = $errors = $out = 0; +} + +sub assemble { + my($line) = @_; + my ($insn, $arg); + $linenum++; + chomp $line; + if ($debug) { + my $quotedline = $line; + $quotedline =~ s/\\/\\\\/g; + $quotedline =~ s/"/\\"/g; + $out->(assemble_insn("comment", qq("$quotedline"))); + } + $line = strip_comments($line) or next; + ($insn, $arg) = parse_statement($line); + $out->(assemble_insn($insn, $arg)); + if ($debug) { + $out->(assemble_insn("nop", undef)); } } @@ -217,14 +265,21 @@ B::Assembler - Assemble Perl bytecode =head1 SYNOPSIS - use Assembler; + use B::Assembler qw(newasm endasm assemble); + newasm(\&printsub); # sets up for assembly + assemble($buf); # assembles one line + endasm(); # closes down + + use B::Assembler qw(assemble_fh); + assemble_fh($fh, \&printsub); # assemble everything in $fh =head1 DESCRIPTION See F<ext/B/B/Assembler.pm>. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm index 27003b6bd0b2..54d7c533c868 100644 --- a/contrib/perl5/ext/B/B/Bytecode.pm +++ b/contrib/perl5/ext/B/B/Bytecode.pm @@ -6,16 +6,18 @@ # License or the Artistic License, as specified in the README file. # package B::Bytecode; + use strict; use Carp; -use IO::File; - -use B qw(minus_c main_cv main_root main_start comppadlist +use B qw(main_cv main_root main_start comppadlist class peekop walkoptree svref_2object cstring walksymtable - SVf_POK SVp_POK SVf_IOK SVp_IOK + init_av begin_av end_av + SVf_POK SVp_POK SVf_IOK SVp_IOK SVf_NOK SVp_NOK + SVf_READONLY GVf_IMPORTED_AV GVf_IMPORTED_CV GVf_IMPORTED_HV + GVf_IMPORTED_SV SVTYPEMASK ); use B::Asmdata qw(@optype @specialsv_name); -use B::Assembler qw(assemble_fh); +use B::Assembler qw(newasm endasm assemble); my %optype_enum; my $i; @@ -31,41 +33,76 @@ sub POK () { SVf_POK|SVp_POK } # XXX Shouldn't be hardwired sub IOK () { SVf_IOK|SVp_IOK } -my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv); -my $assembler_pid; +# Following is SVf_NOK|SVp_NOK +# XXX Shouldn't be hardwired +sub NOK () { SVf_NOK|SVp_NOK } + +# nonexistant flags (see B::GV::bytecode for usage) +sub GVf_IMPORTED_IO () { 0; } +sub GVf_IMPORTED_FORM () { 0; } + +my ($verbose, $no_assemble, $debug_bc, $debug_cv); +my @packages; # list of packages to compile + +sub asm (@) { # print replacement that knows about assembling + if ($no_assemble) { + print @_; + } else { + my $buf = join '', @_; + assemble($_) for (split /\n/, $buf); + } +} + +sub asmf (@) { # printf replacement that knows about assembling + if ($no_assemble) { + printf shift(), @_; + } else { + my $format = shift; + my $buf = sprintf $format, @_; + assemble($_) for (split /\n/, $buf); + } +} # Optimisation options. On the command line, use hyphens instead of # underscores for compatibility with gcc-style options. We use # underscores here because they are OK in (strict) barewords. -my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops); -my %optimise = (strip_syntax_tree => \$strip_syntree, - compress_nullops => \$compress_nullops, +my ($compress_nullops, $omit_seq, $bypass_nullops); +my %optimise = (compress_nullops => \$compress_nullops, omit_sequence_numbers => \$omit_seq, bypass_nullops => \$bypass_nullops); +my $strip_syntree; # this is left here in case stripping the + # syntree ever becomes safe again + # -- BKS, June 2000 + my $nextix = 0; my %symtable; # maps object addresses to object indices. # Filled in at allocation (newsv/newop) time. + my %saved; # maps object addresses (for SVish classes) to "saved yet?" # flag. Set at FOO::bytecode time usually by SV::bytecode. # Manipulated via saved(), mark_saved(), unmark_saved(). +my %strtable; # maps shared strings to object indices + # Filled in at allocation (pvix) time + my $svix = -1; # we keep track of when the sv register contains an element # of the object table to avoid unnecessary repeated # consecutive ldsv instructions. + my $opix = -1; # Ditto for the op register. sub ldsv { my $ix = shift; if ($ix != $svix) { - print "ldsv $ix\n"; + asm "ldsv $ix\n"; $svix = $ix; } } sub stsv { my $ix = shift; - print "stsv $ix\n"; + asm "stsv $ix\n"; $svix = $ix; } @@ -76,14 +113,14 @@ sub set_svix { sub ldop { my $ix = shift; if ($ix != $opix) { - print "ldop $ix\n"; + asm "ldop $ix\n"; $opix = $ix; } } sub stop { my $ix = shift; - print "stop $ix\n"; + asm "stop $ix\n"; $opix = $ix; } @@ -100,12 +137,29 @@ sub pvstring { } } +sub nv { + # print full precision + my $str = sprintf "%.40f", $_[0]; + $str =~ s/0+$//; # remove trailing zeros + $str =~ s/\.$/.0/; + return $str; +} + sub saved { $saved{${$_[0]}} } sub mark_saved { $saved{${$_[0]}} = 1 } sub unmark_saved { $saved{${$_[0]}} = 0 } sub debug { $debug_bc = shift } +sub pvix { # save a shared PV (mainly for COPs) + return $strtable{$_[0]} if defined($strtable{$_[0]}); + asmf "newpv %s\n", pvstring($_[0]); + my $ix = $nextix++; + $strtable{$_[0]} = $ix; + asmf "stpv %d\n", $ix; + return $ix; +} + sub B::OBJECT::nyi { my $obj = shift; warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n", @@ -129,7 +183,7 @@ sub B::OBJECT::objix { sub B::SV::newix { my ($sv, $ix) = @_; - printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv); + asmf "newsv %d\t# %s\n", $sv->FLAGS & SVTYPEMASK, class($sv); stsv($ix); } @@ -137,7 +191,7 @@ sub B::GV::newix { my ($gv, $ix) = @_; my $gvname = $gv->NAME; my $name = cstring($gv->STASH->NAME . "::" . $gvname); - print "gv_fetchpv $name\n"; + asm "gv_fetchpv $name\n"; stsv($ix); } @@ -146,7 +200,7 @@ sub B::HV::newix { my $name = $hv->NAME; if ($name) { # It's a stash - printf "gv_stashpv %s\n", cstring($name); + asmf "gv_stashpv %s\n", cstring($name); stsv($ix); } else { # It's an ordinary HV. Fall back to ordinary newix method @@ -158,7 +212,7 @@ sub B::SPECIAL::newix { my ($sv, $ix) = @_; # Special case. $$sv is not the address of the SV but an # index into svspecialsv_list. - printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; + asmf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv]; stsv($ix); } @@ -166,8 +220,8 @@ sub B::OP::newix { my ($op, $ix) = @_; my $class = class($op); my $typenum = $optype_enum{$class}; - croak "OP::newix: can't understand class $class" unless defined($typenum); - print "newop $typenum\t# $class\n"; + croak("OP::newix: can't understand class $class") unless defined($typenum); + asm "newop $typenum\t# $class\n"; stop($ix); } @@ -180,7 +234,7 @@ sub B::OP::bytecode { my $op = shift; my $next = $op->next; my $nextix; - my $sibix = $op->sibling->objix; + my $sibix = $op->sibling->objix unless $strip_syntree; my $ix = $op->objix; my $type = $op->type; @@ -189,24 +243,24 @@ sub B::OP::bytecode { } $nextix = $next->objix; - printf "# %s\n", peekop($op) if $debug_bc; + asmf "# %s\n", peekop($op) if $debug_bc; ldop($ix); - print "op_next $nextix\n"; - print "op_sibling $sibix\n" unless $strip_syntree; - printf "op_type %s\t# %d\n", "pp_" . $op->name, $type; - printf("op_seq %d\n", $op->seq) unless $omit_seq; + asm "op_next $nextix\n"; + asm "op_sibling $sibix\n" unless $strip_syntree; + asmf "op_type %s\t# %d\n", "pp_" . $op->name, $type; + asmf("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", + asmf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n", $op->targ, $op->flags, $op->private; } } sub B::UNOP::bytecode { my $op = shift; - my $firstix = $op->first->objix; + my $firstix = $op->first->objix unless $strip_syntree; $op->B::OP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_first $firstix\n"; + asm "op_first $firstix\n"; } } @@ -214,7 +268,7 @@ sub B::LOGOP::bytecode { my $op = shift; my $otherix = $op->other->objix; $op->B::UNOP::bytecode; - print "op_other $otherix\n"; + asm "op_other $otherix\n"; } sub B::SVOP::bytecode { @@ -222,7 +276,7 @@ sub B::SVOP::bytecode { my $sv = $op->sv; my $svix = $sv->objix; $op->B::OP::bytecode; - print "op_sv $svix\n"; + asm "op_sv $svix\n"; $sv->bytecode; } @@ -230,7 +284,7 @@ sub B::PADOP::bytecode { my $op = shift; my $padix = $op->padix; $op->B::OP::bytecode; - print "op_padix $padix\n"; + asm "op_padix $padix\n"; } sub B::PVOP::bytecode { @@ -243,27 +297,18 @@ sub B::PVOP::bytecode { # if ($op->name eq "trans") { my @shorts = unpack("s256", $pv); # assembler handles endianness - print "op_pv_tr ", join(",", @shorts), "\n"; + asm "op_pv_tr ", join(",", @shorts), "\n"; } else { - printf "newpv %s\nop_pv\n", pvstring($pv); + asmf "newpv %s\nop_pv\n", pvstring($pv); } } sub B::BINOP::bytecode { my $op = shift; - my $lastix = $op->last->objix; + my $lastix = $op->last->objix unless $strip_syntree; $op->B::UNOP::bytecode; if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_last $lastix\n"; - } -} - -sub B::LISTOP::bytecode { - my $op = shift; - my $children = $op->children; - $op->B::BINOP::bytecode; - if (($op->type || !$compress_nullops) && !$strip_syntree) { - print "op_children $children\n"; + asm "op_last $lastix\n"; } } @@ -273,28 +318,29 @@ sub B::LOOP::bytecode { my $nextopix = $op->nextop->objix; my $lastopix = $op->lastop->objix; $op->B::LISTOP::bytecode; - print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; + asm "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n"; } sub B::COP::bytecode { my $op = shift; - my $stashpv = $op->stashpv; my $file = $op->file; my $line = $op->line; + if ($debug_bc) { # do this early to aid debugging + asmf "# line %s:%d\n", $file, $line; + } + my $stashpv = $op->stashpv; my $warnings = $op->warnings; my $warningsix = $warnings->objix; - if ($debug_bc) { - printf "# line %s:%d\n", $file, $line; - } + my $labelix = pvix($op->label); + my $stashix = pvix($stashpv); + my $fileix = pvix($file); + $warnings->bytecode; $op->B::OP::bytecode; - printf <<"EOT", pvstring($op->label), pvstring($stashpv), $op->cop_seq, pvstring($file), $op->arybase; -newpv %s -cop_label -newpv %s -cop_stashpv + asmf <<"EOT", $labelix, $stashix, $op->cop_seq, $fileix, $op->arybase; +cop_label %d +cop_stashpv %d cop_seq %d -newpv %s -cop_file +cop_file %d cop_arybase %d cop_line $line cop_warnings $warningsix @@ -322,13 +368,13 @@ sub B::PMOP::bytecode { } $op->B::LISTOP::bytecode; if ($opname eq "pushre") { - printf "op_pmreplrootgv $replrootix\n"; + asmf "op_pmreplrootgv $replrootix\n"; } else { - print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; + asm "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n"; } my $re = pvstring($op->precomp); # op_pmnext omitted since a perl bug means it's sometime corrupt - printf <<"EOT", $op->pmflags, $op->pmpermflags; + asmf <<"EOT", $op->pmflags, $op->pmpermflags; op_pmflags 0x%x op_pmpermflags 0x%x newpv $re @@ -343,7 +389,7 @@ sub B::SV::bytecode { my $refcnt = $sv->REFCNT; my $flags = sprintf("0x%x", $sv->FLAGS); ldsv($ix); - print "sv_refcnt $refcnt\nsv_flags $flags\n"; + asm "sv_refcnt $refcnt\nsv_flags $flags\n"; mark_saved($sv); } @@ -351,7 +397,7 @@ sub B::PV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; + asmf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK; } sub B::IV::bytecode { @@ -359,14 +405,14 @@ sub B::IV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::SV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32" if $sv->FLAGS & IOK; # could be PVNV } sub B::NV::bytecode { my $sv = shift; return if saved($sv); $sv->B::SV::bytecode; - printf "xnv %s\n", $sv->NVX; + asmf "xnv %s\n", nv($sv->NVX); } sub B::RV::bytecode { @@ -376,7 +422,7 @@ sub B::RV::bytecode { my $rvix = $rv->objix; $rv->bytecode; $sv->B::SV::bytecode; - print "xrv $rvix\n"; + asm "xrv $rvix\n"; } sub B::PVIV::bytecode { @@ -384,7 +430,7 @@ sub B::PVIV::bytecode { return if saved($sv); my $iv = $sv->IVX; $sv->B::PV::bytecode; - printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; + asmf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32"; } sub B::PVNV::bytecode { @@ -404,12 +450,12 @@ sub B::PVNV::bytecode { } else { my $pv = $sv->PV; $sv->B::IV::bytecode; - printf "xnv %s\n", $sv->NVX; + asmf "xnv %s\n", nv($sv->NVX); if ($flag == 1) { $pv .= "\0" . $sv->TABLE; - printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; + asmf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257; } else { - printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; + asmf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK; } } } @@ -431,9 +477,9 @@ sub B::PVMG::bytecode { # @mgobjix = map($_->OBJ->objix, @mgchain); $sv->B::PVNV::bytecode($flag); - print "xmg_stash $stashix\n"; + asm "xmg_stash $stashix\n"; foreach $mg (@mgchain) { - printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", + asmf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n", cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR); } } @@ -442,7 +488,7 @@ sub B::PVLV::bytecode { my $sv = shift; return if saved($sv); $sv->B::PVMG::bytecode; - printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); + asmf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE); xlv_targoff %d xlv_targlen %d xlv_type %s @@ -454,46 +500,63 @@ sub B::BM::bytecode { return if saved($sv); # See PVNV::bytecode for an explanation of what the argument does $sv->B::PVMG::bytecode(1); - printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", + asmf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n", $sv->USEFUL, $sv->PREVIOUS, $sv->RARE; } +sub empty_gv { # is a GV empty except for imported stuff? + my $gv = shift; + + return 0 if ($gv->SV->FLAGS & SVTYPEMASK); # sv not SVt_NULL + my @subfield_names = qw(AV HV CV FORM IO); + @subfield_names = grep {; + no strict 'refs'; + !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()) && ${$gv->$_()}; + } @subfield_names; + return scalar @subfield_names; +} + sub B::GV::bytecode { my $gv = shift; return if saved($gv); + return unless grep { $_ eq $gv->STASH->NAME; } @packages; + return if $gv->NAME =~ m/^\(/; # ignore overloads - they'll be rebuilt my $ix = $gv->objix; mark_saved($gv); ldsv($ix); - printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; + asmf <<"EOT", $gv->FLAGS, $gv->GvFLAGS; sv_flags 0x%x xgv_flags 0x%x EOT my $refcnt = $gv->REFCNT; - printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; + asmf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1; return if $gv->is_empty; - printf <<"EOT", $gv->LINE, pvstring($gv->FILE); + asmf <<"EOT", $gv->LINE, pvix($gv->FILE); gp_line %d -newpv %s -gp_file +gp_file %d 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; + asmf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1; if ($gvrefcnt > 1 && $ix != $egvix) { - print "gp_share $egvix\n"; + asm "gp_share $egvix\n"; } else { if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) { my $i; my @subfield_names = qw(SV AV HV CV FORM IO); + @subfield_names = grep {; + no strict 'refs'; + !($gv->GvFLAGS & ${\"GVf_IMPORTED_$_"}->()); + } @subfield_names; my @subfields = map($gv->$_(), @subfield_names); my @ixes = map($_->objix, @subfields); # Reset sv register for $gv ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + asmf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } # Now save all the subfields my $sv; @@ -523,10 +586,10 @@ sub B::HV::bytecode { } ldsv($ix); for ($i = 0; $i < @contents; $i += 2) { - printf("newpv %s\nhv_store %d\n", + asmf("newpv %s\nhv_store %d\n", pvstring($contents[$i]), $ixes[$i / 2]); } - printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; + asmf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS; } } @@ -551,22 +614,26 @@ sub B::AV::bytecode { # create an AV with NEWSV and SvUPGRADE rather than doing newAV # which is what sets AvMAX and AvFILL. ldsv($ix); - printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; + asmf "sv_flags 0x%x\n", $av->FLAGS & ~SVf_READONLY; # SvREADONLY_off($av) in case PADCONST + asmf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS; if ($fill > -1) { my $elix; foreach $elix (@ixes) { - print "av_push $elix\n"; + asm "av_push $elix\n"; } } else { if ($max > -1) { - print "av_extend $max\n"; + asm "av_extend $max\n"; } } + asmf "sv_flags 0x%x\n", $av->FLAGS; # restore flags from above } sub B::CV::bytecode { my $cv = shift; return if saved($cv); + return if ${$cv->GV} && ($cv->GV->GvFLAGS & GVf_IMPORTED_CV); + my $fileix = pvix($cv->FILE); my $ix = $cv->objix; $cv->B::PVMG::bytecode; my $i; @@ -581,10 +648,10 @@ sub B::CV::bytecode { # Reset sv register for $cv (since above ->objix calls stomped on it) ldsv($ix); for ($i = 0; $i < @ixes; $i++) { - printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; + asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i]; } - printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; - printf "newpv %s\nxcv_file\n", pvstring($cv->FILE); + asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS; + asmf "xcv_file %d\n", $fileix; # 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 @@ -607,17 +674,17 @@ sub B::IO::bytecode { $io->B::PVMG::bytecode; ldsv($ix); - print "xio_top_gv $top_gvix\n"; - print "xio_fmt_gv $fmt_gvix\n"; - print "xio_bottom_gv $bottom_gvix\n"; + asm "xio_top_gv $top_gvix\n"; + asm "xio_fmt_gv $fmt_gvix\n"; + asm "xio_bottom_gv $bottom_gvix\n"; my $field; foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) { - printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); + asmf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field); } foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) { - printf "xio_%s %d\n", lc($field), $io->$field(); + asmf "xio_%s %d\n", lc($field), $io->$field(); } - printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; + asmf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS; $top_gv->bytecode; $fmt_gv->bytecode; $bottom_gv->bytecode; @@ -628,8 +695,7 @@ sub B::SPECIAL::bytecode { } sub bytecompile_object { - my $sv; - foreach $sv (@_) { + for my $sv (@_) { svref_2object($sv)->bytecode; } } @@ -637,7 +703,7 @@ sub bytecompile_object { sub B::GV::bytecodecv { my $gv = shift; my $cv = $gv->CV; - if ($$cv && !saved($cv)) { + if ($$cv && !saved($cv) && !($gv->FLAGS & GVf_IMPORTED_CV)) { if ($debug_cv) { warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", $gv->STASH->NAME, $gv->NAME, $$cv, $$gv); @@ -646,43 +712,66 @@ sub B::GV::bytecodecv { } } -sub bytecompile_main { - my $curpad = (comppadlist->ARRAY)[1]; - my $curpadix = $curpad->objix; - $curpad->bytecode; - 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 XSLoader Config DB VMS strict vars - FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol - SelectSaver blib Cwd)) - { - $exclude{$pack."::"} = 1; +sub save_call_queues { + if (begin_av()->isa("B::AV")) { # this is just to save 'use Foo;' calls + for my $cv (begin_av()->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME; } @packages; + my $op = $cv->START; +OPLOOP: + while ($$op) { + if ($op->name eq 'require') { # save any BEGIN that does a require + $cv->bytecode; + asmf "push_begin %d\n", $cv->objix; + last OPLOOP; + } + $op = $op->next; + } + } + } + if (init_av()->isa("B::AV")) { + for my $cv (init_av()->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME; } @packages; + $cv->bytecode; + asmf "push_init %d\n", $cv->objix; + } } - no strict qw(vars refs); - walksymtable(\%{"main::"}, "bytecodecv", sub { - warn "considering $_[0]\n" if $debug_bc; - return !defined($exclude{$_[0]}); - }); - if (!$module_only) { - printf "main_root %d\n", main_root->objix; - printf "main_start %d\n", main_start->objix; - printf "curpad $curpadix\n"; - # XXX Do min_intro_pending and max_intro_pending matter? + if (end_av()->isa("B::AV")) { + for my $cv (end_av()->ARRAY) { + next unless grep { $_ eq $cv->STASH->NAME; } @packages; + $cv->bytecode; + asmf "push_end %d\n", $cv->objix; + } } } -sub prepare_assemble { - my $newfh = IO::File->new_tmpfile; - select($newfh); - binmode $newfh; - return $newfh; +sub symwalk { + no strict 'refs'; + my $ok = 1 if grep { (my $name = $_[0]) =~ s/::$//; $_ eq $name;} @packages; + if (grep { /^$_[0]/; } @packages) { + walksymtable(\%{"$_[0]"}, "bytecodecv", \&symwalk, $_[0]); + } + warn "considering $_[0] ... " . ($ok ? "accepted\n" : "rejected\n") + if $debug_bc; + $ok; } -sub do_assemble { - my $fh = shift; - seek($fh, 0, 0); # rewind the temporary file - assemble_fh($fh, sub { print OUT @_ }); +sub bytecompile_main { + my $curpad = (comppadlist->ARRAY)[1]; + my $curpadix = $curpad->objix; + $curpad->bytecode; + save_call_queues(); + walkoptree(main_root, "bytecode") unless ref(main_root) eq "B::NULL"; + warn "done main program, now walking symbol table\n" if $debug_bc; + if (@packages) { + no strict qw(refs); + walksymtable(\%{"main::"}, "bytecodecv", \&symwalk); + } else { + die "No packages requested for compilation!\n"; + } + asmf "main_root %d\n", main_root->objix; + asmf "main_start %d\n", main_start->objix; + asmf "curpad $curpadix\n"; + # XXX Do min_intro_pending and max_intro_pending matter? } sub compile { @@ -690,7 +779,7 @@ sub compile { my ($option, $opt, $arg); open(OUT, ">&STDOUT"); binmode OUT; - select(OUT); + select OUT; OPTION: while ($option = shift @options) { if ($option =~ /^-(.)(.*)/) { @@ -727,8 +816,6 @@ sub compile { } } elsif ($opt eq "v") { $verbose = 1; - } elsif ($opt eq "m") { - $module_only = 1; } elsif ($opt eq "S") { $no_assemble = 1; } elsif ($opt eq "f") { @@ -747,9 +834,6 @@ sub compile { foreach $ref (values %optimise) { $$ref = 0; } - if ($arg >= 6) { - $strip_syntree = 1; - } if ($arg >= 2) { $bypass_nullops = 1; } @@ -757,28 +841,30 @@ sub compile { $compress_nullops = 1; $omit_seq = 1; } + } elsif ($opt eq "u") { + $arg ||= shift @options; + push @packages, $arg; + } else { + warn qq(ignoring unknown option "$opt$arg"\n); } } + if (! @packages) { + warn "No package specified for compilation, assuming main::\n"; + @packages = qw(main); + } if (@options) { - return sub { - my $objname; - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; - foreach $objname (@options) { - eval "bytecompile_object(\\$objname)"; - } - do_assemble($newfh) unless $no_assemble; - } + die "Extraneous options left on B::Bytecode commandline: @options\n"; } else { - return sub { - my $newfh; - $newfh = prepare_assemble() unless $no_assemble; + return sub { + newasm(\&apr) unless $no_assemble; bytecompile_main(); - do_assemble($newfh) unless $no_assemble; - } + endasm() unless $no_assemble; + }; } } +sub apr { print @_; } + 1; __END__ @@ -848,18 +934,11 @@ which is only used by perl's internal compiler. If op->op_next ever points to a NULLOP, replaces the op_next field with the first non-NULLOP in the path of execution. -=item B<-fstrip-syntax-tree> - -Leaves out code to fill in the pointers which link the internal syntax -tree together. They're not needed at run-time but leaving them out -will make it impossible to recompile or disassemble the resulting -program. It will also stop C<goto label> statements from working. - =item B<-On> Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>. -B<-O6> adds B<-fstrip-syntax-tree>. +B<-O2> adds B<-fbypass-nullops>. =item B<-D> @@ -887,33 +966,33 @@ Prints each CV taken from the final symbol tree walk. Output (bytecode) assembler source rather than piping it through the assembler and outputting bytecode. -=item B<-m> - -Compile as a module rather than a standalone program. Currently this -just means that the bytecodes for initialising C<main_start>, -C<main_root> and C<curpad> are omitted. - +=item B<-upackage> + +Stores package in the output. + =back =head1 EXAMPLES - perl -MO=Bytecode,-O6,-o,foo.plc foo.pl + perl -MO=Bytecode,-O6,-ofoo.plc,-umain foo.pl - perl -MO=Bytecode,-S foo.pl > foo.S + perl -MO=Bytecode,-S,-umain foo.pl > foo.S assemble foo.S > 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,-uFoo,-oFoo.pmc Foo.pm =head1 BUGS -Plenty. Current status: experimental. +Output is still huge and there are still occasional crashes during +either compilation or ByteLoading. Current status: experimental. -=head1 AUTHOR +=head1 AUTHORS Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Benjamin Stuhl, C<sho_pi@hotmail.com> =cut diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm index d0c8159d9f31..4befe7988ba2 100644 --- a/contrib/perl5/ext/B/B/C.pm +++ b/contrib/perl5/ext/B/B/C.pm @@ -225,11 +225,10 @@ sub B::LISTOP::save { my ($op, $level) = @_; 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", + $listopsect->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}, - $op->children)); + $op->private, ${$op->first}, ${$op->last})); my $ix = $listopsect->index; $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); savesym($op, "(OP*)&listop_list[$ix]"); @@ -255,11 +254,11 @@ sub B::LOOP::save { #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, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x", + $loopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, 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->redoop}, ${$op->nextop}, ${$op->lastop})); my $ix = $loopsect->index; $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)); @@ -351,10 +350,10 @@ 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, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x", + $pmopsect->add(sprintf("s\\_%x, s\\_%x, NULL, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %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, + ${$op->first}, ${$op->last}, $replrootfield, $replstartfield, $op->pmflags, $op->pmpermflags,)); my $pm = sprintf("pmop_list[%d]", $pmopsect->index); @@ -1020,9 +1019,8 @@ sub output_all { print <<"EOT"; static int $init_name() { - dTHR; dTARG; - djSP; + dSP; EOT $init->output(\*STDOUT, "\t%s\n"); print "\treturn 0;\n}\n"; @@ -1050,15 +1048,15 @@ typedef struct { STRLEN xpv_cur; /* length of xp_pv as a C string */ STRLEN xpv_len; /* allocated size */ IV xof_off; /* integer value */ - double xnv_nv; /* numeric value, if any */ + NV xnv_nv; /* numeric value, if any */ MAGIC* xmg_magic; /* magic for scalar array */ HV* xmg_stash; /* class package */ HV * xcv_stash; OP * xcv_start; OP * xcv_root; - void (*xcv_xsub) (CV*); - void * xcv_xsubany; + void (*xcv_xsub) (pTHXo_ CV*); + ANY xcv_xsubany; GV * xcv_gv; char * xcv_file; long xcv_depth; /* >= 2 indicates recursive call */ @@ -1174,7 +1172,7 @@ xs_init(pTHX) { char *file = __FILE__; dTARG; - djSP; + dSP; EOT print "\n#ifdef USE_DYNAMIC_LOADING"; print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; @@ -1210,7 +1208,7 @@ dl_init(pTHX) { char *file = __FILE__; dTARG; - djSP; + dSP; EOT print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); print("\ttarg=sv_newmortal();\n"); @@ -1338,7 +1336,7 @@ sub should_save # 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)) + if (UNIVERSAL::can($package, $m)) { warn "$package has method $m: saving package\n";#debug return mark_package($package); @@ -1368,7 +1366,7 @@ sub walkpackages if ($sym =~ /::$/) { $sym = $prefix . $sym; - if ($sym ne "main::" && &$recurse($sym)) + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { walkpackages(\%glob, $recurse, $sym); } diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm index c5ca2a3df5bb..51922eeb2b21 100644 --- a/contrib/perl5/ext/B/B/CC.pm +++ b/contrib/perl5/ext/B/B/CC.pm @@ -151,7 +151,7 @@ sub init_pp { $ppname = shift; $runtime_list_ref = []; $declare_ref = {}; - runtime("djSP;"); + runtime("dSP;"); declare("I32", "oldsave"); declare("SV", "**svp"); map { declare("SV", "*$_") } qw(sv src dst left right); diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm index ae7a9733bcdd..049195b42369 100644 --- a/contrib/perl5/ext/B/B/Debug.pm +++ b/contrib/perl5/ext/B/B/Debug.pm @@ -33,6 +33,16 @@ sub B::BINOP::debug { printf "\top_last\t\t0x%x\n", ${$op->last}; } +sub B::LOOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; + op_redoop 0x%x + op_nextop 0x%x + op_lastop 0x%x +EOT +} + sub B::LOGOP::debug { my ($op) = @_; $op->B::UNOP::debug(); @@ -53,7 +63,6 @@ sub B::PMOP::debug { printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); printf "\top_pmflags\t0x%x\n", $op->pmflags; - $op->pmshort->debug; $op->pmreplroot->debug; } @@ -209,14 +218,14 @@ EOT sub B::GV::debug { my ($gv) = @_; if ($done_gv{$$gv}++) { - printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME; + printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; return; } my ($sv) = $gv->SV; 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->FILE, $gv->GvFLAGS; + printf <<'EOT', $gv->SAFENAME, $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 @@ -244,7 +253,7 @@ sub B::SPECIAL::debug { sub compile { my $order = shift; B::clearsym(); - if ($order eq "exec") { + if ($order && $order eq "exec") { return sub { walkoptree_exec(main_start, "debug") } } else { return sub { walkoptree(main_root, "debug") } diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm index cd53c112d8c2..ead02e14a84f 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, 1999 Stephen McCamant. All rights reserved. +# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved. # This module is free software; you can redistribute and/or modify # it under the same terms as Perl itself. @@ -8,16 +8,16 @@ package B::Deparse; 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 + CVf_METHOD CVf_LOCKED CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = 0.59; +$VERSION = 0.60; use strict; # Changes between 0.50 and 0.51: @@ -83,6 +83,12 @@ use strict; # - added support for Chip's OP_METHOD_NAMED # - added support for Ilya's OPpTARGET_MY optimization # - elided arrows before `()' subscripts when possible +# Changes between 0.59 and 0.60 +# - support for method attribues was added +# - some warnings fixed +# - separate recognition of constant subs +# - rewrote continue block handling, now recoginizing for loops +# - added more control of expanding control structures # Todo: # - finish tr/// changes @@ -93,8 +99,8 @@ use strict; # - 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?) +# - interpret 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?) @@ -108,7 +114,6 @@ use strict; # - version using op_next instead of op_first/sibling? # - avoid string copies (pass arrays, one big join?) # - auto-apply `-u'? -# - while{} with one-statement continue => for(; XXX; XXX) {}? # - -uPackage:: descend recursively? # - here-docs? # - <DATA>? @@ -252,17 +257,17 @@ sub walk_sub { walk_tree($op, sub { my $op = shift; if ($op->name eq "gv") { - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); if ($op->next->name eq "entersub") { - next if $self->{'subs_done'}{$$gv}++; - next if class($gv->CV) eq "SPECIAL"; + return if $self->{'subs_done'}{$$gv}++; + return 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"; + return if $self->{'forms_done'}{$$gv}++; + return if class($gv->FORM) eq "SPECIAL"; $self->todo($gv, $gv->FORM, 1); $self->walk_sub($gv->FORM); } @@ -345,6 +350,10 @@ sub new { $self->{'cuddle'} = "\n"; $self->{'indent_size'} = 4; $self->{'use_tabs'} = 0; + $self->{'expand'} = 0; + $self->{'unquote'} = 0; + $self->{'linenums'} = 0; + $self->{'parens'} = 0; $self->{'ex_const'} = "'???'"; while (my $arg = shift @_) { if (substr($arg, 0, 2) eq "-u") { @@ -357,6 +366,8 @@ sub new { $self->{'unquote'} = 1; } elsif (substr($arg, 0, 2) eq "-s") { $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; } } return $self; @@ -378,7 +389,7 @@ sub compile { while (scalar(@{$self->{'subs_todo'}})) { push @text, $self->next_todo; } - print indent(join("", @text)), "\n" if @text; + print $self->indent(join("", @text)), "\n" if @text; } } @@ -393,6 +404,7 @@ sub deparse { my $self = shift; my($op, $cx) = @_; # cluck if class($op) eq "NULL"; +# cluck unless $op; # return $self->$ {\("pp_" . $op->name)}($op, $cx); my $meth = "pp_" . $op->name; return $self->$meth($op, $cx); @@ -433,6 +445,13 @@ sub deparse_sub { if ($cv->FLAGS & SVf_POK) { $proto = "(". $cv->PV . ") "; } + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) { + $proto .= ": "; + $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; + $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; + $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; + } + local($self->{'curcv'}) = $cv; local($self->{'curstash'}) = $self->{'curstash'}; if (not null $cv->ROOT) { @@ -553,7 +572,11 @@ sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - return $self->maybe_parens_func("local", $text, $cx, 16); + if (want_scalar($op)) { + return "local $text"; + } else { + return $self->maybe_parens_func("local", $text, $cx, 16); + } } else { return $text; } @@ -581,7 +604,11 @@ sub maybe_my { my $self = shift; my($op, $cx, $text) = @_; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { - return $self->maybe_parens_func("my", $text, $cx, 16); + if (want_scalar($op)) { + return "my $text"; + } else { + return $self->maybe_parens_func("my", $text, $cx, 16); + } } else { return $text; } @@ -672,70 +699,69 @@ sub pp_entertry { # see also leavetry return "XXX"; } -# leave and scope/lineseq should probably share code -sub pp_leave { +sub lineseq { my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - local($self->{'curstash'}) = $self->{'curstash'}; - $kid = $op->first->sibling; # skip enter - if (is_miniwhile($kid)) { - my $top = $kid->first; - my $name = $top->name; - if ($name eq "and") { - $name = "while"; - } elsif ($name eq "or") { - $name = "until"; - } else { # no conditional -> while 1 or until 0 - return $self->deparse($top->first, 1) . " while 1"; - } - my $cond = $top->first; - my $body = $cond->sibling->first; # skip lineseq - $cond = $self->deparse($cond, 1); - $body = $self->deparse($body, 1); - return "$body $name $cond"; - } - for (; !null($kid); $kid = $kid->sibling) { + my(@ops) = @_; + my($expr, @exprs); + for (my $i = 0; $i < @ops; $i++) { $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; + if (is_state $ops[$i]) { + $expr = $self->deparse($ops[$i], 0); + $i++; + last if $i > $#ops; } - $expr .= $self->deparse($kid, 0); + if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and + $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3) + { + push @exprs, $expr . $self->for_loop($ops[$i], 0); + $i++; + next; + } + $expr .= $self->deparse($ops[$i], 0); push @exprs, $expr if length $expr; } - if ($cx > 0) { # inside an expression - return "do { " . join(";\n", @exprs) . " }"; - } else { - return join(";\n", @exprs) . ";"; - } + return join(";\n", @exprs); } -sub pp_scope { - my $self = shift; - my($op, $cx) = @_; - my ($kid, $expr); - my @exprs; - for ($kid = $op->first; !null($kid); $kid = $kid->sibling) { - $expr = ""; - if (is_state $kid) { - $expr = $self->deparse($kid, 0); - $kid = $kid->sibling; - last if null $kid; +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + local($self->{'curstash'}) = $self->{'curstash'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = "while"; + } elsif ($name eq "or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; } - $expr .= $self->deparse($kid, 0); - push @exprs, $expr if length $expr; + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; } if ($cx > 0) { # inside an expression, (a do {} while for lineseq) - return "do { " . join(";\n", @exprs) . " }"; + return "do { " . $self->lineseq(@kids) . " }"; } else { - return join(";\n", @exprs) . ";"; + return $self->lineseq(@kids) . ";"; } } -sub pp_lineseq { pp_scope(@_) } +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } # The BEGIN {} is used here because otherwise this code isn't executed # when you run B::Deparse on itself. @@ -747,7 +773,7 @@ sub gv_name { my $self = shift; my $gv = shift; my $stash = $gv->STASH->NAME; - my $name = $gv->NAME; + my $name = $gv->SAFENAME; if ($stash eq $self->{'curstash'} or $globalnames{$name} or $name =~ /^[^A-Za-z_]/) { @@ -755,8 +781,8 @@ sub gv_name { } else { $stash = $stash . "::"; } - if ($name =~ /^([\cA-\cZ])$/) { - $name = "^" . chr(64 + ord($1)); + if ($name =~ /^\^../) { + $name = "{$name}"; # ${^WARNING_BITS} etc } return $stash . $name; } @@ -840,7 +866,7 @@ sub pp_i_preinc { pfixop(@_, "++", 23) } sub pp_i_predec { pfixop(@_, "--", 23) } 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_complement { maybe_targmy(@_, \&pfixop, "~", 21) } sub pp_negate { maybe_targmy(@_, \&real_negate) } sub real_negate { @@ -917,7 +943,6 @@ sub pp_prototype { unop(@_, "prototype") } sub pp_close { unop(@_, "close") } sub pp_fileno { unop(@_, "fileno") } sub pp_umask { unop(@_, "umask") } -sub pp_binmode { unop(@_, "binmode") } sub pp_untie { unop(@_, "untie") } sub pp_tied { unop(@_, "tied") } sub pp_dbmclose { unop(@_, "dbmclose") } @@ -1373,11 +1398,14 @@ sub logop { my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; my $right = $op->first->sibling; - if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b} + if ($cx == 0 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} $left = $self->deparse($left, 1); $right = $self->deparse($right, 0); return "$blockname ($left) {\n\t$right\n\b}\cK"; - } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a + } elsif ($cx == 0 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a $right = $self->deparse($right, 1); $left = $self->deparse($left, 1); return "$right $blockname $left"; @@ -1457,6 +1485,7 @@ sub pp_return { listop(@_, "return") } sub pp_open { listop(@_, "open") } sub pp_pipe_op { listop(@_, "pipe") } sub pp_tie { listop(@_, "tie") } +sub pp_binmode { listop(@_, "binmode") } sub pp_dbmopen { listop(@_, "dbmopen") } sub pp_sselect { listop(@_, "select") } sub pp_select { listop(@_, "select") } @@ -1653,6 +1682,13 @@ sub pp_list { } } +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + sub pp_cond_expr { my $self = shift; my($op, $cx) = @_; @@ -1660,52 +1696,55 @@ sub pp_cond_expr { my $true = $cond->sibling; my $false = $true->sibling; my $cuddle = $self->{'cuddle'}; - unless ($cx == 0 and is_scope($true) and is_scope($false)) { + unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { $cond = $self->deparse($cond, 8); $true = $self->deparse($true, 8); $false = $self->deparse($false, 8); return $self->maybe_parens("$cond ? $true : $false", $cx, 8); - } + } + $cond = $self->deparse($cond, 1); $true = $self->deparse($true, 0); - 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->name eq "lineseq") { - my $newop = $false->first->sibling->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - $false = $newtrue->sibling; # last in chain is OP_AND => no else - $newcond = $self->deparse($newcond, 1); - $newtrue = $self->deparse($newtrue, 0); - push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; - } - if (!null($false)) { - $false = $cuddle . "else {\n\t" . - $self->deparse($false, 0) . "\n\b}\cK"; - } else { - $false = "\cK"; - } - return $head . join($cuddle, "", @elsifs) . $false; + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; } - $false = $self->deparse($false, 0); - return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK"; + return $head . join($cuddle, "", @elsifs) . $false; } -sub pp_leaveloop { +sub loop_common { my $self = shift; - my($op, $cx) = @_; + my($op, $cx, $init) = @_; my $enter = $op->first; my $kid = $enter->sibling; local($self->{'curstash'}) = $self->{'curstash'}; my $head = ""; my $bare = 0; + my $body; + my $cond = undef; if ($kid->name eq "lineseq") { # bare or infinite loop if (is_state $kid->last) { # infinite $head = "for (;;) "; # shorter than while (1) + $cond = ""; } else { $bare = 1; } + $body = $kid; } elsif ($enter->name eq "enteriter") { # foreach my $ary = $enter->first->sibling; # first was pushmark my $var = $ary->sibling; @@ -1737,62 +1776,60 @@ sub pp_leaveloop { $var = "\$" . $self->deparse($var, 1); } $head = "foreach $var ($ary) "; - $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER } elsif ($kid->name eq "null") { # while/until $kid = $kid->first; - my $name = {"and" => "while", "or" => "until"} - ->{$kid->name}; - $head = "$name (" . $self->deparse($kid->first, 1) . ") "; - $kid = $kid->first->sibling; + my $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $self->deparse($kid->first, 1); + $head = "$name ($cond) "; + $body = $kid->first->sibling; } 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 - # by `next BLOCK' points to its first OP, which happens to be the - # the op_next of the head of the _previous_ statement. - # Unless it's a bare loop, in which case it's last, since there's - # no unstack or extra nextstate. - # Except if the previous head isn't null but the first kid is - # (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 $precont; - my $cont = $kid->first; - if ($bare) { - while (!null($cont->sibling)) { - $precont = $cont; - $cont = $cont->sibling; - } - } else { - while (!null($cont->sibling->sibling->sibling)) { - $precont = $cont; - $cont = $cont->sibling; + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's penultimate child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the third-to-last child in the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(@states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; } - } - if ($precont and $ {$precont->next} == $ {$enter->nextop} - || $ {$precont->next} == $ {$enter->nextop->next} ) - { - my $state = $kid->first; - my $cuddle = $self->{'cuddle'}; - my($expr, @exprs); - for (; $$state != $$cont; $state = $state->sibling) { - $expr = ""; - if (is_state $state) { - $expr = $self->deparse($state, 0); - $state = $state->sibling; - last if null $kid; - } - $expr .= $self->deparse($state, 0); - push @exprs, $expr if $expr; - } - $kid = join(";\n", @exprs); - $cont = $cuddle . "continue {\n\t" . - $self->deparse($cont, 0) . "\n\b}\cK"; } else { $cont = "\cK"; - $kid = $self->deparse($kid, 0); + $body = $self->deparse($body, 0); } - return $head . "{\n\t" . $kid . "\n\b}" . $cont; + return $head . "{\n\t" . $body . "\n\b}" . $cont; +} + +sub pp_leaveloop { loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + return $self->loop_common($op->sibling, $cx, $init); } sub pp_leavetry { @@ -1814,7 +1851,7 @@ sub pp_null { } elsif ($op->first->name eq "enter") { return $self->pp_leave($op, $cx); } elsif ($op->targ == OP_STRINGIFY) { - return $self->dquote($op); + return $self->dquote($op, $cx); } elsif (!null($op->first->sibling) and $op->first->sibling->name eq "readline" and $op->first->sibling->flags & OPf_STACKED) { @@ -1832,21 +1869,10 @@ 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; - my $str = $self->padname_sv($targ)->PV; - return padname_fix($str); + return $self->padname_sv($targ)->PVX; } sub padany { @@ -1879,37 +1905,34 @@ sub pp_threadsv { return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); } -sub maybe_padgv { +sub gv_or_padgv { my $self = shift; my $op = shift; - my $gv; - if ($Config{useithreads}) { - $gv = $self->padval($op->padix); - } - else { - $gv = $op->gv; + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; } - return $gv; } sub pp_gvsv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv)); } sub pp_gv { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return $self->gv_name($gv); } sub pp_aelemfast { my $self = shift; my($op, $cx) = @_; - my $gv = $self->maybe_padgv($op); + my $gv = $self->gv_or_padgv($op); return "\$" . $self->gv_name($gv) . "[" . $op->private . "]"; } @@ -2220,7 +2243,7 @@ sub pp_entersub { $amper = "&"; $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { - my $gv = $self->maybe_padgv($kid->first); + my $gv = $self->gv_or_padgv($kid->first); if (class($gv->CV) ne "SPECIAL") { $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; } @@ -2252,9 +2275,9 @@ sub pp_entersub { } else { if (defined $proto and $proto eq "") { return $kid; - } elsif ($proto eq "\$") { + } elsif (defined $proto and $proto eq "\$") { return $self->maybe_parens_func($kid, $args, $cx, 16); - } elsif ($proto or $simple) { + } elsif (defined($proto) && $proto or $simple) { return $self->maybe_parens_func($kid, $args, $cx, 5); } else { return "$kid(" . $args . ")"; @@ -2350,7 +2373,7 @@ sub const { if (class($sv) eq "SPECIAL") { return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no } elsif ($sv->FLAGS & SVf_IOK) { - return $sv->IV; + return $sv->int_value; } elsif ($sv->FLAGS & SVf_NOK) { return $sv->NV; } elsif ($sv->FLAGS & SVf_ROK) { @@ -2381,7 +2404,9 @@ sub pp_const { # return $self->const_sv($op)->PV; # } my $sv = $self->const_sv($op); - return const($sv); +# return const($sv); + my $c = const $sv; + return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c; } sub dq { @@ -2391,7 +2416,13 @@ sub dq { 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); + my $first = $self->dq($op->first); + my $last = $self->dq($op->last); + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + if ($last =~ /^[{\[\w]/) { + $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; + } + return $first . $last; } elsif ($type eq "uc") { return '\U' . $self->dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -2418,7 +2449,7 @@ sub pp_backtick { sub dquote { my $self = shift; - my($op, $cx) = shift; + my($op, $cx) = @_; my $kid = $op->first->sibling; # skip ex-stringify, pushmark return $self->deparse($kid, $cx) if $self->{'unquote'}; $self->maybe_targmy($kid, $cx, @@ -2486,7 +2517,7 @@ sub pchr { # ASCII sub collapse { my(@chars) = @_; - my($c, $str, $tr); + my($str, $c, $tr) = (""); for ($c = 0; $c < @chars; $c++) { $tr = $chars[$c]; $str .= pchr($tr); @@ -2539,7 +2570,7 @@ sub tr_decode_byte { } @from = @newfrom; } - unless ($flags & OPpTRANS_DELETE) { + unless ($flags & OPpTRANS_DELETE || !@to) { pop @to while $#to and $to[$#to] == $to[$#to -1]; } my($from, $to); @@ -2678,9 +2709,15 @@ sub re_dq { my $op = shift; my $type = $op->name; if ($type eq "const") { - return uninterp($self->const_sv($op)->PV); + return re_uninterp($self->const_sv($op)->PV); } elsif ($type eq "concat") { - return $self->re_dq($op->first) . $self->re_dq($op->last); + my $first = $self->re_dq($op->first); + my $last = $self->re_dq($op->last); + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + if ($last =~ /^[{\[\w]/) { + $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/; + } + return $first . $last; } elsif ($type eq "uc") { return '\U' . $self->re_dq($op->first->sibling) . '\E'; } elsif ($type eq "lc") { @@ -2842,8 +2879,8 @@ B::Deparse - Perl compiler backend to produce perl code =head1 SYNOPSIS -B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][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>][B<,-x>I<LEVEL>] I<prog.pl> =head1 DESCRIPTION @@ -2988,6 +3025,55 @@ file is compiled as a main program. =back +=item B<-x>I<LEVEL> + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I<LEVEL> should be a digit, with higher values +meaning more expansion. As with B<-q>, this actually involves turning off +special cases in B::Deparse's normal operations. + +If I<LEVEL> is at least 3, for loops will be translated into equivalent +while loops with continue blocks; for instance + + for ($i = 0; $i < 10; ++$i) { + print $i; + } + +turns into + + $i = 0; + while ($i < 10) { + print $i; + } continue { + ++$i + } + +Note that in a few cases this translation can't be perfectly carried back +into the source code -- if the loop's initializer declares a my variable, +for instance, it won't have the correct scope outside of the loop. + +If I<LEVEL> is at least 7, if statements will be translated into equivalent +expressions using C<&&>, C<?:> and C<do {}>; for instance + + print 'hi' if $nice; + if ($nice) { + print 'hi'; + } + if ($nice) { + print 'hi'; + } else { + print 'bye'; + } + +turns into + + $nice and print 'hi'; + $nice and do { print 'hi' }; + $nice ? do { print 'hi' } : do { print 'bye' }; + +Long sequences of elsifs will turn into nested ternary operators, which +B::Deparse doesn't know how to indent nicely. + =back =head1 USING B::Deparse AS A MODULE @@ -3034,7 +3120,7 @@ See the 'to do' list at the beginning of the module file. =head1 AUTHOR -Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier +Stephen McCamant <smcc@CSUA.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. diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm index d054a2d16473..212532b9ce91 100644 --- a/contrib/perl5/ext/B/B/Disassembler.pm +++ b/contrib/perl5/ext/B/B/Disassembler.pm @@ -31,6 +31,13 @@ sub GET_U16 { return unpack("n", $str); } +sub GET_NV { + my $fh = shift; + my $str = $fh->readn(8); + croak "reached EOF while reading NV" unless length($str) == 8; + return unpack("N", $str); +} + sub GET_U32 { my $fh = shift; my $str = $fh->readn(4); diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm index ed0d07dfcbd6..094b3cf8fd00 100644 --- a/contrib/perl5/ext/B/B/Lint.pm +++ b/contrib/perl5/ext/B/B/Lint.pm @@ -116,7 +116,7 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; -use B qw(walkoptree_slow main_root walksymtable svref_2object parents +use B qw(walkoptree main_root walksymtable svref_2object parents OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY ); @@ -277,12 +277,12 @@ sub B::GV::lintcv { return if !$$cv || $done_cv{$$cv}++; my $root = $cv->ROOT; #warn " root = $root (0x$$root)\n";#debug - walkoptree_slow($root, "lint") if $$root; + walkoptree($root, "lint") if $$root; } sub do_lint { my %search_pack; - walkoptree_slow(main_root, "lint") if ${main_root()}; + walkoptree(main_root, "lint") if ${main_root()}; # Now do subs in main no strict qw(vars refs); diff --git a/contrib/perl5/ext/B/B/Showlex.pm b/contrib/perl5/ext/B/B/Showlex.pm index 648f95dcc0a3..842ca3ee2b86 100644 --- a/contrib/perl5/ext/B/B/Showlex.pm +++ b/contrib/perl5/ext/B/B/Showlex.pm @@ -12,7 +12,24 @@ use B::Terse (); # to see the names of file scope lexicals used by bar.pl # -sub showarray { +sub shownamearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + print "$i: "; + my $sv = $els[$i]; + if (class($sv) ne "SPECIAL") { + printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + } else { + $sv->terse; + } + } +} + +sub showvaluearray { my ($name, $av) = @_; my @els = $av->ARRAY; my $count = @els; @@ -26,8 +43,8 @@ sub showarray { sub showlex { my ($objname, $namesav, $valsav) = @_; - showarray("Pad of lexical names for $objname", $namesav); - showarray("Pad of lexical values for $objname", $valsav); + shownamearray("Pad of lexical names for $objname", $namesav); + showvaluearray("Pad of lexical values for $objname", $valsav); } sub showlex_obj { diff --git a/contrib/perl5/ext/B/B/Stash.pm b/contrib/perl5/ext/B/B/Stash.pm index 0a3543eed41e..f3a82478777d 100644 --- a/contrib/perl5/ext/B/B/Stash.pm +++ b/contrib/perl5/ext/B/B/Stash.pm @@ -2,11 +2,19 @@ # vishalb@hotmail.com package B::Stash; +=pod + +=head1 NAME + +B::Stash - show what stashes are loaded + +=cut + BEGIN { %Seen = %INC } CHECK { my @arr=scan($main::{"main::"}); - @arr=map{s/\:\:$//;$_;} @arr; + @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; print "-umain,-u", join (",-u",@arr) ,"\n"; } sub scan{ diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm index 66b5cfc2f2f0..52f0549911e4 100644 --- a/contrib/perl5/ext/B/B/Terse.pm +++ b/contrib/perl5/ext/B/B/Terse.pm @@ -1,7 +1,7 @@ package B::Terse; use strict; -use B qw(peekop class walkoptree_slow walkoptree_exec - main_start main_root cstring svref_2object); +use B qw(peekop class walkoptree walkoptree_exec walkoptree_slow + main_start main_root cstring svref_2object SVf_IVisUV); use B::Asmdata qw(@specialsv_name); sub terse { @@ -15,7 +15,7 @@ sub terse { } sub compile { - my $order = shift; + my $order = @_ ? shift : ""; my @options = @_; B::clearsym(); if (@options) { @@ -37,7 +37,7 @@ sub compile { } sub indent { - my $level = shift; + my $level = @_ ? shift : 0; return " " x $level; } @@ -102,13 +102,14 @@ sub B::GV::terse { $stash = $stash . "::"; } print indent($level); - printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME; + printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->SAFENAME; } sub B::IV::terse { my ($sv, $level) = @_; print indent($level); - printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV; + my $v = $sv->FLAGS & SVf_IVisUV ? "%u" : "%d"; + printf "%s (0x%lx) $v\n", class($sv), $$sv, $sv->int_value; } sub B::NV::terse { diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL index cb9696bf4164..dcf6a1db15b2 100644 --- a/contrib/perl5/ext/B/Makefile.PL +++ b/contrib/perl5/ext/B/Makefile.PL @@ -1,5 +1,6 @@ use ExtUtils::MakeMaker; use Config; +use File::Spec; my $e = $Config{'exe_ext'}; my $o = $Config{'obj_ext'}; @@ -29,8 +30,19 @@ sub post_constants { "\nLIBS = $Config::Config{libs}\n" } -sub postamble { -' -B$(OBJ_EXT) : defsubs.h -' +sub upupfile { + File::Spec->catfile(File::Spec->updir, + File::Spec->updir, $_[0]); +} + +sub MY::postamble { + my $op_h = upupfile('op.h'); + my $cop_h = upupfile('cop.h'); + my $noecho = shift->{NOECHO}; +" +B\$(OBJ_EXT) : defsubs.h + +defsubs.h :: $op_h $cop_h + $noecho \$(NOOP) +" } diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm index 352f8d42069e..2ef91edbd92d 100644 --- a/contrib/perl5/ext/B/O.pm +++ b/contrib/perl5/ext/B/O.pm @@ -1,5 +1,5 @@ package O; -use B qw(minus_c); +use B qw(minus_c save_BEGINs); use Carp; sub import { @@ -11,6 +11,7 @@ sub import { my $compilesub = &{"B::${backend}::compile"}(@options); if (ref($compilesub) eq "CODE") { minus_c; + save_BEGINs; eval 'CHECK { &$compilesub() }'; } else { die $compilesub; diff --git a/contrib/perl5/ext/B/defsubs_h.PL b/contrib/perl5/ext/B/defsubs_h.PL index 80ef936fcecf..da6566b0d717 100644 --- a/contrib/perl5/ext/B/defsubs_h.PL +++ b/contrib/perl5/ext/B/defsubs_h.PL @@ -6,16 +6,23 @@ 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 +foreach my $const (qw( + AVf_REAL HEf_SVKEY + SVf_READONLY SVTYPEMASK + GVf_IMPORTED_AV GVf_IMPORTED_HV + GVf_IMPORTED_SV GVf_IMPORTED_CV + CVf_METHOD CVf_LOCKED CVf_LVALUE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK - SVf_ROK SVp_IOK SVp_POK )) + SVf_ROK SVp_IOK SVp_POK SVp_NOK + )) { doconst($const); } foreach my $file (qw(op.h cop.h)) { - open(OPH,"../../$file") || die "Cannot open ../../$file:$!"; + my $path = $^O eq 'MacOS' ? ":::$file" : "../../$file"; + open(OPH,"$path") || die "Cannot open $path:$!"; while (<OPH>) { doconst($1) if (/#define\s+(\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/); diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop index e0cb8ff62052..e08333d172db 100644 --- a/contrib/perl5/ext/B/ramblings/flip-flop +++ b/contrib/perl5/ext/B/ramblings/flip-flop @@ -9,13 +9,13 @@ PP(pp_range) } pp_range is a LOGOP. -In array context, it just returns op_next. +In list context, it just returns op_next. In scalar context it checks the truth of targ and returns op_other if true, op_next if false. flip is an UNOP. It "looks after" its child which is always a pp_range LOGOP. -In array context, it just returns the child's op_other. +In list 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_other. diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.pm b/contrib/perl5/ext/ByteLoader/ByteLoader.pm index 286d74697eec..9c8c84d677c2 100644 --- a/contrib/perl5/ext/ByteLoader/ByteLoader.pm +++ b/contrib/perl5/ext/ByteLoader/ByteLoader.pm @@ -2,7 +2,7 @@ package ByteLoader; use XSLoader (); -$VERSION = 0.03; +$VERSION = 0.04; XSLoader::load 'ByteLoader', $VERSION; @@ -17,10 +17,10 @@ ByteLoader - load byte compiled perl code =head1 SYNOPSIS - use ByteLoader 0.03; + use ByteLoader 0.04; <byte code> - use ByteLoader 0.03; + use ByteLoader 0.04; <byte code> =head1 DESCRIPTION diff --git a/contrib/perl5/ext/ByteLoader/ByteLoader.xs b/contrib/perl5/ext/ByteLoader/ByteLoader.xs index 7c3746bba70d..05b795ca25d7 100644 --- a/contrib/perl5/ext/ByteLoader/ByteLoader.xs +++ b/contrib/perl5/ext/ByteLoader/ByteLoader.xs @@ -4,47 +4,95 @@ #include "XSUB.h" #include "byterun.h" -static int -xgetc(PerlIO *io) -{ - dTHX; - return PerlIO_getc(io); -} +/* Something arbitary for a buffer size */ +#define BYTELOADER_BUFFER 8096 -static int -xfread(char *buf, size_t size, size_t n, PerlIO *io) +int +bl_getc(struct byteloader_fdata *data) { dTHX; - int i = PerlIO_read(io, buf, n * size); - if (i > 0) - i /= size; - return i; + if (SvCUR(data->datasv) <= data->next_out) { + int result; + /* Run out of buffered data, so attempt to read some more */ + *(SvPV_nolen (data->datasv)) = '\0'; + SvCUR_set (data->datasv, 0); + data->next_out = 0; + result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); + + /* Filter returned error, or we got EOF and no data, then return EOF. + Not sure if filter is allowed to return EOF and add data simultaneously + Think not, but will bullet proof against it. */ + if (result < 0 || SvCUR(data->datasv) == 0) + return EOF; + /* Else there must be at least one byte present, which is good enough */ + } + + return *((char *) SvPV_nolen (data->datasv) + data->next_out++); } -static void -freadpv(U32 len, void *data, XPV *pv) +int +bl_read(struct byteloader_fdata *data, char *buf, size_t size, size_t n) { 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; + char *start; + STRLEN len; + size_t wanted = size * n; + + start = SvPV (data->datasv, len); + if (len < (data->next_out + wanted)) { + int result; + + /* Shuffle data to start of buffer */ + len -= data->next_out; + if (len) { + memmove (start, start + data->next_out, len + 1); + SvCUR_set (data->datasv, len); + } else { + *start = '\0'; /* Avoid call to memmove. */ + SvCUR_set (data->datasv, 0); + } + data->next_out = 0; + + /* Attempt to read more data. */ + do { + result = FILTER_READ (data->idx + 1, data->datasv, BYTELOADER_BUFFER); + + start = SvPV (data->datasv, len); + } while (result > 0 && len < wanted); + /* Loop while not (EOF || error) and short reads */ + + /* If not enough data read, truncate copy */ + if (wanted > len) + wanted = len; + } + + if (wanted > 0) { + memcpy (buf, start + data->next_out, wanted); + data->next_out += wanted; + wanted /= size; + } + return (int) wanted; } 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; + struct byteloader_state bstate; + struct byteloader_fdata data; + + data.next_out = 0; + data.datasv = FILTER_DATA(idx); + data.idx = idx; - bs.data = PL_rsfp; - bs.pfgetc = (int(*) (void*))xgetc; - bs.pfread = (int(*) (char*,size_t,size_t,void*))xfread; - bs.pfreadpv = freadpv; + bstate.bs_fdata = &data; + bstate.bs_obj_list = Null(void**); + bstate.bs_obj_list_fill = -1; + bstate.bs_sv = Nullsv; + bstate.bs_iv_overflows = 0; - byterun(aTHXo_ bs); + byterun(aTHXo_ &bstate); if (PL_in_eval) { OP *o; @@ -70,8 +118,12 @@ PROTOTYPES: ENABLE void import(...) + PREINIT: + SV *sv = newSVpvn ("", 0); PPCODE: - filter_add(byteloader_filter, NULL); + if (!sv) + croak ("Could not allocate ByteLoader buffers"); + filter_add(byteloader_filter, sv); void unimport(...) diff --git a/contrib/perl5/ext/ByteLoader/bytecode.h b/contrib/perl5/ext/ByteLoader/bytecode.h index 1621fed4eba4..c6acd28436dc 100644 --- a/contrib/perl5/ext/ByteLoader/bytecode.h +++ b/contrib/perl5/ext/ByteLoader/bytecode.h @@ -5,29 +5,33 @@ typedef char *op_tr_array; typedef int comment_t; typedef SV *svindex; typedef OP *opindex; +typedef char *pvindex; typedef IV IV64; #define BGET_FREAD(argp, len, nelem) \ - bs.pfread((char*)(argp),(len),(nelem),bs.data) -#define BGET_FGETC() bs.pfgetc(bs.data) + bl_read(bstate->bs_fdata,(char*)(argp),(len),(nelem)) +#define BGET_FGETC() bl_getc(bstate->bs_fdata) #define BGET_U32(arg) \ - BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg) + BGET_FREAD(&arg, sizeof(U32), 1) #define BGET_I32(arg) \ - BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg) + BGET_FREAD(&arg, sizeof(I32), 1) #define BGET_U16(arg) \ - BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg) + BGET_FREAD(&arg, sizeof(U16), 1) #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; \ - } \ +#define BGET_PV(arg) STMT_START { \ + BGET_U32(arg); \ + if (arg) { \ + New(666, bstate->bs_pv.xpv_pv, arg, char); \ + bl_read(bstate->bs_fdata, (void*)bstate->bs_pv.xpv_pv, arg, 1); \ + bstate->bs_pv.xpv_len = arg; \ + bstate->bs_pv.xpv_cur = arg - 1; \ + } else { \ + bstate->bs_pv.xpv_pv = 0; \ + bstate->bs_pv.xpv_len = 0; \ + bstate->bs_pv.xpv_cur = 0; \ + } \ } STMT_END #ifdef BYTELOADER_LOG_COMMENTS @@ -63,22 +67,20 @@ typedef IV IV64; arg = (I32)lo; \ } \ else { \ - bytecode_iv_overflows++; \ + bstate->bs_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; \ +#define BGET_op_tr_array(arg) do { \ + unsigned short *ary; \ + int i; \ + New(666, ary, 256, unsigned short); \ + BGET_FREAD(ary, sizeof(unsigned short), 256); \ + arg = (char *) ary; \ } while (0) -#define BGET_pvcontents(arg) arg = bytecode_pv.xpv_pv +#define BGET_pvcontents(arg) arg = bstate->bs_pv.xpv_pv #define BGET_strconst(arg) STMT_START { \ for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \ arg = PL_tokenbuf; \ @@ -91,14 +93,21 @@ typedef IV IV64; } STMT_END #define BGET_objindex(arg, type) STMT_START { \ - U32 ix; \ BGET_U32(ix); \ - arg = (type)bytecode_obj_list[ix]; \ + arg = (type)bstate->bs_obj_list[ix]; \ } STMT_END #define BGET_svindex(arg) BGET_objindex(arg, svindex) #define BGET_opindex(arg) BGET_objindex(arg, opindex) +#define BGET_pvindex(arg) STMT_START { \ + BGET_objindex(arg, pvindex); \ + arg = arg ? savepv(arg) : arg; \ + } STMT_END #define BSET_ldspecsv(sv, arg) sv = specialsv_list[arg] +#define BSET_stpv(pv, arg) STMT_START { \ + BSET_OBJ_STORE(pv, arg); \ + SAVEFREEPV(pv); \ + } STMT_END #define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg #define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg @@ -110,23 +119,29 @@ typedef IV IV64; #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_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = bstate->bs_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); \ + SvPV_set(sv, bstate->bs_pv.xpv_pv); \ + SvCUR_set(sv, bstate->bs_pv.xpv_cur); \ + SvLEN_set(sv, bstate->bs_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) + hv_store((HV*)sv, bstate->bs_pv.xpv_pv, bstate->bs_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) + CALLREGCOMP(aTHX_ arg, arg + bstate->bs_pv.xpv_cur, ((PMOP*)o)) : 0 +#define BSET_newsv(sv, arg) \ + STMT_START { \ + sv = (arg == SVt_PVAV ? (SV*)newAV() : \ + arg == SVt_PVHV ? (SV*)newHV() : \ + NEWSV(666,0)); \ + SvUPGRADE(sv, arg); \ + } STMT_END #define BSET_newop(o, arg) ((o = (OP*)safemalloc(optype_size[arg])), \ memzero((char*)o,optype_size[arg])) #define BSET_newopn(o, arg) STMT_START { \ @@ -135,7 +150,10 @@ typedef IV IV64; oldop->op_next = o; \ } STMT_END -#define BSET_ret(foo) return +#define BSET_ret(foo) STMT_START { \ + Safefree(bstate->bs_obj_list); \ + return; \ + } STMT_END /* * Kludge special-case workaround for OP_MAPSTART @@ -152,10 +170,88 @@ typedef IV IV64; PL_comppad = (AV *)arg; \ pad = AvARRAY(arg); \ } STMT_END +/* this works now that Sarathy's changed the CopFILE_set macro to do the SvREFCNT_inc() + -- BKS 6-2-2000 */ #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) +/* this is simply stolen from the code in newATTRSUB() */ +#define BSET_push_begin(ary,cv) \ + STMT_START { \ + I32 oldscope = PL_scopestack_ix; \ + ENTER; \ + SAVECOPFILE(&PL_compiling); \ + SAVECOPLINE(&PL_compiling); \ + save_svref(&PL_rs); \ + sv_setsv(PL_rs, PL_nrs); \ + if (!PL_beginav) \ + PL_beginav = newAV(); \ + av_push(PL_beginav, cv); \ + call_list(oldscope, PL_beginav); \ + PL_curcop = &PL_compiling; \ + PL_compiling.op_private = PL_hints; \ + LEAVE; \ + } STMT_END +#define BSET_push_init(ary,cv) \ + STMT_START { \ + av_unshift((PL_initav ? PL_initav : (PL_initav = newAV(), PL_initav)), 1); \ + av_store(PL_initav, 0, cv); \ + } STMT_END +#define BSET_push_end(ary,cv) \ + STMT_START { \ + av_unshift((PL_endav ? PL_endav : (PL_endav = newAV(), PL_endav)), 1); \ + av_store(PL_endav, 0, cv); \ + } STMT_END +#define BSET_OBJ_STORE(obj, ix) \ + (I32)ix > bstate->bs_obj_list_fill ? \ + bset_obj_store(aTHXo_ bstate, obj, (I32)ix) : (bstate->bs_obj_list[ix] = obj) + +/* NOTE: the bytecode header only sanity-checks the bytecode. If a script cares about + * what version of Perl it's being called under, it should do a 'require 5.6.0' or + * equivalent. However, since the header includes checks requiring an exact match in + * ByteLoader versions (we can't guarantee forward compatibility), you don't + * need to specify one: + * use ByteLoader; + * is all you need. + * -- BKS, June 2000 +*/ + +#define HEADER_FAIL(f) \ + Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f) +#define HEADER_FAIL1(f, arg1) \ + Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1) +#define HEADER_FAIL2(f, arg1, arg2) \ + Perl_croak(aTHX_ "Invalid bytecode for this architecture: " f, arg1, arg2) + +#define BYTECODE_HEADER_CHECK \ + STMT_START { \ + U32 sz = 0; \ + strconst str; \ + \ + BGET_U32(sz); /* Magic: 'PLBC' */ \ + if (sz != 0x43424c50) { \ + HEADER_FAIL1("bad magic (want 0x43424c50, got %#x)", (int)sz); \ + } \ + BGET_strconst(str); /* archname */ \ + if (strNE(str, ARCHNAME)) { \ + HEADER_FAIL2("wrong architecture (want %s, you have %s)",str,ARCHNAME); \ + } \ + BGET_strconst(str); /* ByteLoader version */ \ + if (strNE(str, VERSION)) { \ + HEADER_FAIL2("mismatched ByteLoader versions (want %s, you have %s)", \ + str, VERSION); \ + } \ + BGET_U32(sz); /* ivsize */ \ + if (sz != IVSIZE) { \ + HEADER_FAIL("different IVSIZE"); \ + } \ + BGET_U32(sz); /* ptrsize */ \ + if (sz != PTRSIZE) { \ + HEADER_FAIL("different PTRSIZE"); \ + } \ + BGET_strconst(str); /* byteorder */ \ + if (strNE(str, STRINGIFY(BYTEORDER))) { \ + HEADER_FAIL("different byteorder"); \ + } \ + } STMT_END diff --git a/contrib/perl5/ext/ByteLoader/byterun.c b/contrib/perl5/ext/ByteLoader/byterun.c index a1044ab2c0f2..71cd8aa08496 100644 --- a/contrib/perl5/ext/ByteLoader/byterun.c +++ b/contrib/perl5/ext/ByteLoader/byterun.c @@ -26,7 +26,7 @@ #include "bytecode.h" -static int optype_size[] = { +static const int optype_size[] = { sizeof(OP), sizeof(UNOP), sizeof(BINOP), @@ -40,38 +40,34 @@ static int optype_size[] = { 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) +bset_obj_store(pTHXo_ struct byteloader_state *bstate, 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; + if (ix > bstate->bs_obj_list_fill) { + Renew(bstate->bs_obj_list, ix + 32, void*); + bstate->bs_obj_list_fill = ix + 31; } - bytecode_obj_list[ix] = obj; + bstate->bs_obj_list[ix] = obj; return obj; } void -byterun(pTHXo_ struct bytestream bs) +byterun(pTHXo_ register struct byteloader_state *bstate) { - dTHR; - int insn; + register int insn; + U32 ix; + SV *specialsv_list[6]; + + BYTECODE_HEADER_CHECK; /* croak if incorrect platform */ + New(666, bstate->bs_obj_list, 32, void*); /* set op objlist */ + bstate->bs_obj_list_fill = 31; specialsv_list[0] = Nullsv; specialsv_list[1] = &PL_sv_undef; specialsv_list[2] = &PL_sv_yes; specialsv_list[3] = &PL_sv_no; + specialsv_list[4] = pWARN_ALL; + specialsv_list[5] = pWARN_NONE; while ((insn = BGET_FGETC()) != EOF) { switch (insn) { @@ -95,7 +91,7 @@ byterun(pTHXo_ struct bytestream bs) { svindex arg; BGET_svindex(arg); - bytecode_sv = arg; + bstate->bs_sv = arg; break; } case INSN_LDOP: /* 2 */ @@ -109,7 +105,7 @@ byterun(pTHXo_ struct bytestream bs) { U32 arg; BGET_U32(arg); - BSET_OBJ_STORE(bytecode_sv, arg); + BSET_OBJ_STORE(bstate->bs_sv, arg); break; } case INSN_STOP: /* 4 */ @@ -119,610 +115,610 @@ byterun(pTHXo_ struct bytestream bs) BSET_OBJ_STORE(PL_op, arg); break; } - case INSN_LDSPECSV: /* 5 */ + case INSN_STPV: /* 5 */ + { + U32 arg; + BGET_U32(arg); + BSET_stpv(bstate->bs_pv.xpv_pv, arg); + break; + } + case INSN_LDSPECSV: /* 6 */ { U8 arg; BGET_U8(arg); - BSET_ldspecsv(bytecode_sv, arg); + BSET_ldspecsv(bstate->bs_sv, arg); break; } - case INSN_NEWSV: /* 6 */ + case INSN_NEWSV: /* 7 */ { U8 arg; BGET_U8(arg); - BSET_newsv(bytecode_sv, arg); + BSET_newsv(bstate->bs_sv, arg); break; } - case INSN_NEWOP: /* 7 */ + case INSN_NEWOP: /* 8 */ { U8 arg; BGET_U8(arg); BSET_newop(PL_op, arg); break; } - case INSN_NEWOPN: /* 8 */ + case INSN_NEWOPN: /* 9 */ { U8 arg; BGET_U8(arg); BSET_newopn(PL_op, arg); break; } - case INSN_NEWPV: /* 9 */ + case INSN_NEWPV: /* 11 */ { PV arg; BGET_PV(arg); break; } - case INSN_PV_CUR: /* 11 */ + case INSN_PV_CUR: /* 12 */ { STRLEN arg; BGET_U32(arg); - bytecode_pv.xpv_cur = arg; + bstate->bs_pv.xpv_cur = arg; break; } - case INSN_PV_FREE: /* 12 */ + case INSN_PV_FREE: /* 13 */ { - BSET_pv_free(bytecode_pv); + BSET_pv_free(bstate->bs_pv); break; } - case INSN_SV_UPGRADE: /* 13 */ + case INSN_SV_UPGRADE: /* 14 */ { char arg; BGET_U8(arg); - BSET_sv_upgrade(bytecode_sv, arg); + BSET_sv_upgrade(bstate->bs_sv, arg); break; } - case INSN_SV_REFCNT: /* 14 */ + case INSN_SV_REFCNT: /* 15 */ { U32 arg; BGET_U32(arg); - SvREFCNT(bytecode_sv) = arg; + SvREFCNT(bstate->bs_sv) = arg; break; } - case INSN_SV_REFCNT_ADD: /* 15 */ + case INSN_SV_REFCNT_ADD: /* 16 */ { I32 arg; BGET_I32(arg); - BSET_sv_refcnt_add(SvREFCNT(bytecode_sv), arg); + BSET_sv_refcnt_add(SvREFCNT(bstate->bs_sv), arg); break; } - case INSN_SV_FLAGS: /* 16 */ + case INSN_SV_FLAGS: /* 17 */ { U32 arg; BGET_U32(arg); - SvFLAGS(bytecode_sv) = arg; + SvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_XRV: /* 17 */ + case INSN_XRV: /* 18 */ { svindex arg; BGET_svindex(arg); - SvRV(bytecode_sv) = arg; + SvRV(bstate->bs_sv) = arg; break; } - case INSN_XPV: /* 18 */ + case INSN_XPV: /* 19 */ { - BSET_xpv(bytecode_sv); + BSET_xpv(bstate->bs_sv); break; } - case INSN_XIV32: /* 19 */ + case INSN_XIV32: /* 20 */ { I32 arg; BGET_I32(arg); - SvIVX(bytecode_sv) = arg; + SvIVX(bstate->bs_sv) = arg; break; } - case INSN_XIV64: /* 20 */ + case INSN_XIV64: /* 21 */ { IV64 arg; BGET_IV64(arg); - SvIVX(bytecode_sv) = arg; + SvIVX(bstate->bs_sv) = arg; break; } - case INSN_XNV: /* 21 */ + case INSN_XNV: /* 22 */ { NV arg; BGET_NV(arg); - SvNVX(bytecode_sv) = arg; + SvNVX(bstate->bs_sv) = arg; break; } - case INSN_XLV_TARGOFF: /* 22 */ + case INSN_XLV_TARGOFF: /* 23 */ { STRLEN arg; BGET_U32(arg); - LvTARGOFF(bytecode_sv) = arg; + LvTARGOFF(bstate->bs_sv) = arg; break; } - case INSN_XLV_TARGLEN: /* 23 */ + case INSN_XLV_TARGLEN: /* 24 */ { STRLEN arg; BGET_U32(arg); - LvTARGLEN(bytecode_sv) = arg; + LvTARGLEN(bstate->bs_sv) = arg; break; } - case INSN_XLV_TARG: /* 24 */ + case INSN_XLV_TARG: /* 25 */ { svindex arg; BGET_svindex(arg); - LvTARG(bytecode_sv) = arg; + LvTARG(bstate->bs_sv) = arg; break; } - case INSN_XLV_TYPE: /* 25 */ + case INSN_XLV_TYPE: /* 26 */ { char arg; BGET_U8(arg); - LvTYPE(bytecode_sv) = arg; + LvTYPE(bstate->bs_sv) = arg; break; } - case INSN_XBM_USEFUL: /* 26 */ + case INSN_XBM_USEFUL: /* 27 */ { I32 arg; BGET_I32(arg); - BmUSEFUL(bytecode_sv) = arg; + BmUSEFUL(bstate->bs_sv) = arg; break; } - case INSN_XBM_PREVIOUS: /* 27 */ + case INSN_XBM_PREVIOUS: /* 28 */ { U16 arg; BGET_U16(arg); - BmPREVIOUS(bytecode_sv) = arg; + BmPREVIOUS(bstate->bs_sv) = arg; break; } - case INSN_XBM_RARE: /* 28 */ + case INSN_XBM_RARE: /* 29 */ { U8 arg; BGET_U8(arg); - BmRARE(bytecode_sv) = arg; + BmRARE(bstate->bs_sv) = arg; break; } - case INSN_XFM_LINES: /* 29 */ + case INSN_XFM_LINES: /* 30 */ { I32 arg; BGET_I32(arg); - FmLINES(bytecode_sv) = arg; + FmLINES(bstate->bs_sv) = arg; break; } - case INSN_XIO_LINES: /* 30 */ + case INSN_XIO_LINES: /* 31 */ { long arg; BGET_I32(arg); - IoLINES(bytecode_sv) = arg; + IoLINES(bstate->bs_sv) = arg; break; } - case INSN_XIO_PAGE: /* 31 */ + case INSN_XIO_PAGE: /* 32 */ { long arg; BGET_I32(arg); - IoPAGE(bytecode_sv) = arg; + IoPAGE(bstate->bs_sv) = arg; break; } - case INSN_XIO_PAGE_LEN: /* 32 */ + case INSN_XIO_PAGE_LEN: /* 33 */ { long arg; BGET_I32(arg); - IoPAGE_LEN(bytecode_sv) = arg; + IoPAGE_LEN(bstate->bs_sv) = arg; break; } - case INSN_XIO_LINES_LEFT: /* 33 */ + case INSN_XIO_LINES_LEFT: /* 34 */ { long arg; BGET_I32(arg); - IoLINES_LEFT(bytecode_sv) = arg; + IoLINES_LEFT(bstate->bs_sv) = arg; break; } - case INSN_XIO_TOP_NAME: /* 34 */ + case INSN_XIO_TOP_NAME: /* 36 */ { pvcontents arg; BGET_pvcontents(arg); - IoTOP_NAME(bytecode_sv) = arg; + IoTOP_NAME(bstate->bs_sv) = arg; break; } - case INSN_XIO_TOP_GV: /* 36 */ + case INSN_XIO_TOP_GV: /* 37 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoTOP_GV(bytecode_sv) = arg; + *(SV**)&IoTOP_GV(bstate->bs_sv) = arg; break; } - case INSN_XIO_FMT_NAME: /* 37 */ + case INSN_XIO_FMT_NAME: /* 38 */ { pvcontents arg; BGET_pvcontents(arg); - IoFMT_NAME(bytecode_sv) = arg; + IoFMT_NAME(bstate->bs_sv) = arg; break; } - case INSN_XIO_FMT_GV: /* 38 */ + case INSN_XIO_FMT_GV: /* 39 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoFMT_GV(bytecode_sv) = arg; + *(SV**)&IoFMT_GV(bstate->bs_sv) = arg; break; } - case INSN_XIO_BOTTOM_NAME: /* 39 */ + case INSN_XIO_BOTTOM_NAME: /* 40 */ { pvcontents arg; BGET_pvcontents(arg); - IoBOTTOM_NAME(bytecode_sv) = arg; + IoBOTTOM_NAME(bstate->bs_sv) = arg; break; } - case INSN_XIO_BOTTOM_GV: /* 40 */ + case INSN_XIO_BOTTOM_GV: /* 41 */ { svindex arg; BGET_svindex(arg); - *(SV**)&IoBOTTOM_GV(bytecode_sv) = arg; + *(SV**)&IoBOTTOM_GV(bstate->bs_sv) = arg; break; } - case INSN_XIO_SUBPROCESS: /* 41 */ + case INSN_XIO_SUBPROCESS: /* 42 */ { short arg; BGET_U16(arg); - IoSUBPROCESS(bytecode_sv) = arg; + IoSUBPROCESS(bstate->bs_sv) = arg; break; } - case INSN_XIO_TYPE: /* 42 */ + case INSN_XIO_TYPE: /* 43 */ { char arg; BGET_U8(arg); - IoTYPE(bytecode_sv) = arg; + IoTYPE(bstate->bs_sv) = arg; break; } - case INSN_XIO_FLAGS: /* 43 */ + case INSN_XIO_FLAGS: /* 44 */ { char arg; BGET_U8(arg); - IoFLAGS(bytecode_sv) = arg; + IoFLAGS(bstate->bs_sv) = arg; break; } - case INSN_XCV_STASH: /* 44 */ + case INSN_XCV_STASH: /* 45 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvSTASH(bytecode_sv) = arg; + *(SV**)&CvSTASH(bstate->bs_sv) = arg; break; } - case INSN_XCV_START: /* 45 */ + case INSN_XCV_START: /* 46 */ { opindex arg; BGET_opindex(arg); - CvSTART(bytecode_sv) = arg; + CvSTART(bstate->bs_sv) = arg; break; } - case INSN_XCV_ROOT: /* 46 */ + case INSN_XCV_ROOT: /* 47 */ { opindex arg; BGET_opindex(arg); - CvROOT(bytecode_sv) = arg; + CvROOT(bstate->bs_sv) = arg; break; } - case INSN_XCV_GV: /* 47 */ + case INSN_XCV_GV: /* 48 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvGV(bytecode_sv) = arg; + *(SV**)&CvGV(bstate->bs_sv) = arg; break; } - case INSN_XCV_FILE: /* 48 */ + case INSN_XCV_FILE: /* 49 */ { - pvcontents arg; - BGET_pvcontents(arg); - CvFILE(bytecode_sv) = arg; + pvindex arg; + BGET_pvindex(arg); + CvFILE(bstate->bs_sv) = arg; break; } - case INSN_XCV_DEPTH: /* 49 */ + case INSN_XCV_DEPTH: /* 50 */ { long arg; BGET_I32(arg); - CvDEPTH(bytecode_sv) = arg; + CvDEPTH(bstate->bs_sv) = arg; break; } - case INSN_XCV_PADLIST: /* 50 */ + case INSN_XCV_PADLIST: /* 51 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvPADLIST(bytecode_sv) = arg; + *(SV**)&CvPADLIST(bstate->bs_sv) = arg; break; } - case INSN_XCV_OUTSIDE: /* 51 */ + case INSN_XCV_OUTSIDE: /* 52 */ { svindex arg; BGET_svindex(arg); - *(SV**)&CvOUTSIDE(bytecode_sv) = arg; + *(SV**)&CvOUTSIDE(bstate->bs_sv) = arg; break; } - case INSN_XCV_FLAGS: /* 52 */ + case INSN_XCV_FLAGS: /* 53 */ { U16 arg; BGET_U16(arg); - CvFLAGS(bytecode_sv) = arg; + CvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_AV_EXTEND: /* 53 */ + case INSN_AV_EXTEND: /* 54 */ { SSize_t arg; BGET_I32(arg); - BSET_av_extend(bytecode_sv, arg); + BSET_av_extend(bstate->bs_sv, arg); break; } - case INSN_AV_PUSH: /* 54 */ + case INSN_AV_PUSH: /* 55 */ { svindex arg; BGET_svindex(arg); - BSET_av_push(bytecode_sv, arg); + BSET_av_push(bstate->bs_sv, arg); break; } - case INSN_XAV_FILL: /* 55 */ + case INSN_XAV_FILL: /* 56 */ { SSize_t arg; BGET_I32(arg); - AvFILLp(bytecode_sv) = arg; + AvFILLp(bstate->bs_sv) = arg; break; } - case INSN_XAV_MAX: /* 56 */ + case INSN_XAV_MAX: /* 57 */ { SSize_t arg; BGET_I32(arg); - AvMAX(bytecode_sv) = arg; + AvMAX(bstate->bs_sv) = arg; break; } - case INSN_XAV_FLAGS: /* 57 */ + case INSN_XAV_FLAGS: /* 58 */ { U8 arg; BGET_U8(arg); - AvFLAGS(bytecode_sv) = arg; + AvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_XHV_RITER: /* 58 */ + case INSN_XHV_RITER: /* 59 */ { I32 arg; BGET_I32(arg); - HvRITER(bytecode_sv) = arg; + HvRITER(bstate->bs_sv) = arg; break; } - case INSN_XHV_NAME: /* 59 */ + case INSN_XHV_NAME: /* 60 */ { pvcontents arg; BGET_pvcontents(arg); - HvNAME(bytecode_sv) = arg; + HvNAME(bstate->bs_sv) = arg; break; } - case INSN_HV_STORE: /* 60 */ + case INSN_HV_STORE: /* 61 */ { svindex arg; BGET_svindex(arg); - BSET_hv_store(bytecode_sv, arg); + BSET_hv_store(bstate->bs_sv, arg); break; } - case INSN_SV_MAGIC: /* 61 */ + case INSN_SV_MAGIC: /* 62 */ { char arg; BGET_U8(arg); - BSET_sv_magic(bytecode_sv, arg); + BSET_sv_magic(bstate->bs_sv, arg); break; } - case INSN_MG_OBJ: /* 62 */ + case INSN_MG_OBJ: /* 63 */ { svindex arg; BGET_svindex(arg); - SvMAGIC(bytecode_sv)->mg_obj = arg; + SvMAGIC(bstate->bs_sv)->mg_obj = arg; break; } - case INSN_MG_PRIVATE: /* 63 */ + case INSN_MG_PRIVATE: /* 64 */ { U16 arg; BGET_U16(arg); - SvMAGIC(bytecode_sv)->mg_private = arg; + SvMAGIC(bstate->bs_sv)->mg_private = arg; break; } - case INSN_MG_FLAGS: /* 64 */ + case INSN_MG_FLAGS: /* 65 */ { U8 arg; BGET_U8(arg); - SvMAGIC(bytecode_sv)->mg_flags = arg; + SvMAGIC(bstate->bs_sv)->mg_flags = arg; break; } - case INSN_MG_PV: /* 65 */ + case INSN_MG_PV: /* 66 */ { pvcontents arg; BGET_pvcontents(arg); - BSET_mg_pv(SvMAGIC(bytecode_sv), arg); + BSET_mg_pv(SvMAGIC(bstate->bs_sv), arg); break; } - case INSN_XMG_STASH: /* 66 */ + case INSN_XMG_STASH: /* 67 */ { svindex arg; BGET_svindex(arg); - *(SV**)&SvSTASH(bytecode_sv) = arg; + *(SV**)&SvSTASH(bstate->bs_sv) = arg; break; } - case INSN_GV_FETCHPV: /* 67 */ + case INSN_GV_FETCHPV: /* 68 */ { strconst arg; BGET_strconst(arg); - BSET_gv_fetchpv(bytecode_sv, arg); + BSET_gv_fetchpv(bstate->bs_sv, arg); break; } - case INSN_GV_STASHPV: /* 68 */ + case INSN_GV_STASHPV: /* 69 */ { strconst arg; BGET_strconst(arg); - BSET_gv_stashpv(bytecode_sv, arg); + BSET_gv_stashpv(bstate->bs_sv, arg); break; } - case INSN_GP_SV: /* 69 */ + case INSN_GP_SV: /* 70 */ { svindex arg; BGET_svindex(arg); - GvSV(bytecode_sv) = arg; + GvSV(bstate->bs_sv) = arg; break; } - case INSN_GP_REFCNT: /* 70 */ + case INSN_GP_REFCNT: /* 71 */ { U32 arg; BGET_U32(arg); - GvREFCNT(bytecode_sv) = arg; + GvREFCNT(bstate->bs_sv) = arg; break; } - case INSN_GP_REFCNT_ADD: /* 71 */ + case INSN_GP_REFCNT_ADD: /* 72 */ { I32 arg; BGET_I32(arg); - BSET_gp_refcnt_add(GvREFCNT(bytecode_sv), arg); + BSET_gp_refcnt_add(GvREFCNT(bstate->bs_sv), arg); break; } - case INSN_GP_AV: /* 72 */ + case INSN_GP_AV: /* 73 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvAV(bytecode_sv) = arg; + *(SV**)&GvAV(bstate->bs_sv) = arg; break; } - case INSN_GP_HV: /* 73 */ + case INSN_GP_HV: /* 74 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvHV(bytecode_sv) = arg; + *(SV**)&GvHV(bstate->bs_sv) = arg; break; } - case INSN_GP_CV: /* 74 */ + case INSN_GP_CV: /* 75 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvCV(bytecode_sv) = arg; + *(SV**)&GvCV(bstate->bs_sv) = arg; break; } - case INSN_GP_FILE: /* 75 */ + case INSN_GP_FILE: /* 76 */ { - pvcontents arg; - BGET_pvcontents(arg); - GvFILE(bytecode_sv) = arg; + pvindex arg; + BGET_pvindex(arg); + GvFILE(bstate->bs_sv) = arg; break; } - case INSN_GP_IO: /* 76 */ + case INSN_GP_IO: /* 77 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvIOp(bytecode_sv) = arg; + *(SV**)&GvIOp(bstate->bs_sv) = arg; break; } - case INSN_GP_FORM: /* 77 */ + case INSN_GP_FORM: /* 78 */ { svindex arg; BGET_svindex(arg); - *(SV**)&GvFORM(bytecode_sv) = arg; + *(SV**)&GvFORM(bstate->bs_sv) = arg; break; } - case INSN_GP_CVGEN: /* 78 */ + case INSN_GP_CVGEN: /* 79 */ { U32 arg; BGET_U32(arg); - GvCVGEN(bytecode_sv) = arg; + GvCVGEN(bstate->bs_sv) = arg; break; } - case INSN_GP_LINE: /* 79 */ + case INSN_GP_LINE: /* 80 */ { line_t arg; BGET_U16(arg); - GvLINE(bytecode_sv) = arg; + GvLINE(bstate->bs_sv) = arg; break; } - case INSN_GP_SHARE: /* 80 */ + case INSN_GP_SHARE: /* 81 */ { svindex arg; BGET_svindex(arg); - BSET_gp_share(bytecode_sv, arg); + BSET_gp_share(bstate->bs_sv, arg); break; } - case INSN_XGV_FLAGS: /* 81 */ + case INSN_XGV_FLAGS: /* 82 */ { U8 arg; BGET_U8(arg); - GvFLAGS(bytecode_sv) = arg; + GvFLAGS(bstate->bs_sv) = arg; break; } - case INSN_OP_NEXT: /* 82 */ + case INSN_OP_NEXT: /* 83 */ { opindex arg; BGET_opindex(arg); PL_op->op_next = arg; break; } - case INSN_OP_SIBLING: /* 83 */ + case INSN_OP_SIBLING: /* 84 */ { opindex arg; BGET_opindex(arg); PL_op->op_sibling = arg; break; } - case INSN_OP_PPADDR: /* 84 */ + case INSN_OP_PPADDR: /* 85 */ { strconst arg; BGET_strconst(arg); BSET_op_ppaddr(PL_op->op_ppaddr, arg); break; } - case INSN_OP_TARG: /* 85 */ + case INSN_OP_TARG: /* 86 */ { PADOFFSET arg; BGET_U32(arg); PL_op->op_targ = arg; break; } - case INSN_OP_TYPE: /* 86 */ + case INSN_OP_TYPE: /* 87 */ { OPCODE arg; BGET_U16(arg); BSET_op_type(PL_op, arg); break; } - case INSN_OP_SEQ: /* 87 */ + case INSN_OP_SEQ: /* 88 */ { U16 arg; BGET_U16(arg); PL_op->op_seq = arg; break; } - case INSN_OP_FLAGS: /* 88 */ + case INSN_OP_FLAGS: /* 89 */ { U8 arg; BGET_U8(arg); PL_op->op_flags = arg; break; } - case INSN_OP_PRIVATE: /* 89 */ + case INSN_OP_PRIVATE: /* 90 */ { U8 arg; BGET_U8(arg); PL_op->op_private = arg; break; } - case INSN_OP_FIRST: /* 90 */ + case INSN_OP_FIRST: /* 91 */ { opindex arg; BGET_opindex(arg); cUNOP->op_first = arg; break; } - case INSN_OP_LAST: /* 91 */ + case INSN_OP_LAST: /* 92 */ { opindex arg; BGET_opindex(arg); cBINOP->op_last = arg; break; } - case INSN_OP_OTHER: /* 92 */ + case INSN_OP_OTHER: /* 93 */ { 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; @@ -823,22 +819,22 @@ byterun(pTHXo_ struct bytestream bs) } case INSN_COP_LABEL: /* 108 */ { - pvcontents arg; - BGET_pvcontents(arg); + pvindex arg; + BGET_pvindex(arg); cCOP->cop_label = arg; break; } case INSN_COP_STASHPV: /* 109 */ { - pvcontents arg; - BGET_pvcontents(arg); + pvindex arg; + BGET_pvindex(arg); BSET_cop_stashpv(cCOP, arg); break; } case INSN_COP_FILE: /* 110 */ { - pvcontents arg; - BGET_pvcontents(arg); + pvindex arg; + BGET_pvindex(arg); BSET_cop_file(cCOP, arg); break; } @@ -891,6 +887,27 @@ byterun(pTHXo_ struct bytestream bs) BSET_curpad(PL_curpad, arg); break; } + case INSN_PUSH_BEGIN: /* 118 */ + { + svindex arg; + BGET_svindex(arg); + BSET_push_begin(PL_beginav, arg); + break; + } + case INSN_PUSH_INIT: /* 119 */ + { + svindex arg; + BGET_svindex(arg); + BSET_push_init(PL_initav, arg); + break; + } + case INSN_PUSH_END: /* 120 */ + { + svindex arg; + BGET_svindex(arg); + BSET_push_end(PL_endav, 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 index f0de6b482044..f074f2d6cf6f 100644 --- a/contrib/perl5/ext/ByteLoader/byterun.h +++ b/contrib/perl5/ext/ByteLoader/byterun.h @@ -8,108 +8,120 @@ /* * 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 *); +struct byteloader_fdata { + SV *datasv; + int next_out; + int idx; }; +struct byteloader_state { + struct byteloader_fdata *bs_fdata; + SV *bs_sv; + void **bs_obj_list; + int bs_obj_list_fill; + XPV bs_pv; + int bs_iv_overflows; +}; + +int bl_getc(struct byteloader_fdata *); +int bl_read(struct byteloader_fdata *, char *, size_t, size_t); +extern void byterun(pTHXo_ struct byteloader_state *); + 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_STPV, /* 5 */ + INSN_LDSPECSV, /* 6 */ + INSN_NEWSV, /* 7 */ + INSN_NEWOP, /* 8 */ + INSN_NEWOPN, /* 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_NEWPV, /* 11 */ + INSN_PV_CUR, /* 12 */ + INSN_PV_FREE, /* 13 */ + INSN_SV_UPGRADE, /* 14 */ + INSN_SV_REFCNT, /* 15 */ + INSN_SV_REFCNT_ADD, /* 16 */ + INSN_SV_FLAGS, /* 17 */ + INSN_XRV, /* 18 */ + INSN_XPV, /* 19 */ + INSN_XIV32, /* 20 */ + INSN_XIV64, /* 21 */ + INSN_XNV, /* 22 */ + INSN_XLV_TARGOFF, /* 23 */ + INSN_XLV_TARGLEN, /* 24 */ + INSN_XLV_TARG, /* 25 */ + INSN_XLV_TYPE, /* 26 */ + INSN_XBM_USEFUL, /* 27 */ + INSN_XBM_PREVIOUS, /* 28 */ + INSN_XBM_RARE, /* 29 */ + INSN_XFM_LINES, /* 30 */ + INSN_XIO_LINES, /* 31 */ + INSN_XIO_PAGE, /* 32 */ + INSN_XIO_PAGE_LEN, /* 33 */ + INSN_XIO_LINES_LEFT, /* 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_XIO_TOP_NAME, /* 36 */ + INSN_XIO_TOP_GV, /* 37 */ + INSN_XIO_FMT_NAME, /* 38 */ + INSN_XIO_FMT_GV, /* 39 */ + INSN_XIO_BOTTOM_NAME, /* 40 */ + INSN_XIO_BOTTOM_GV, /* 41 */ + INSN_XIO_SUBPROCESS, /* 42 */ + INSN_XIO_TYPE, /* 43 */ + INSN_XIO_FLAGS, /* 44 */ + INSN_XCV_STASH, /* 45 */ + INSN_XCV_START, /* 46 */ + INSN_XCV_ROOT, /* 47 */ + INSN_XCV_GV, /* 48 */ + INSN_XCV_FILE, /* 49 */ + INSN_XCV_DEPTH, /* 50 */ + INSN_XCV_PADLIST, /* 51 */ + INSN_XCV_OUTSIDE, /* 52 */ + INSN_XCV_FLAGS, /* 53 */ + INSN_AV_EXTEND, /* 54 */ + INSN_AV_PUSH, /* 55 */ + INSN_XAV_FILL, /* 56 */ + INSN_XAV_MAX, /* 57 */ + INSN_XAV_FLAGS, /* 58 */ + INSN_XHV_RITER, /* 59 */ + INSN_XHV_NAME, /* 60 */ + INSN_HV_STORE, /* 61 */ + INSN_SV_MAGIC, /* 62 */ + INSN_MG_OBJ, /* 63 */ + INSN_MG_PRIVATE, /* 64 */ + INSN_MG_FLAGS, /* 65 */ + INSN_MG_PV, /* 66 */ + INSN_XMG_STASH, /* 67 */ + INSN_GV_FETCHPV, /* 68 */ + INSN_GV_STASHPV, /* 69 */ + INSN_GP_SV, /* 70 */ + INSN_GP_REFCNT, /* 71 */ + INSN_GP_REFCNT_ADD, /* 72 */ + INSN_GP_AV, /* 73 */ + INSN_GP_HV, /* 74 */ + INSN_GP_CV, /* 75 */ + INSN_GP_FILE, /* 76 */ + INSN_GP_IO, /* 77 */ + INSN_GP_FORM, /* 78 */ + INSN_GP_CVGEN, /* 79 */ + INSN_GP_LINE, /* 80 */ + INSN_GP_SHARE, /* 81 */ + INSN_XGV_FLAGS, /* 82 */ + INSN_OP_NEXT, /* 83 */ + INSN_OP_SIBLING, /* 84 */ + INSN_OP_PPADDR, /* 85 */ + INSN_OP_TARG, /* 86 */ + INSN_OP_TYPE, /* 87 */ + INSN_OP_SEQ, /* 88 */ + INSN_OP_FLAGS, /* 89 */ + INSN_OP_PRIVATE, /* 90 */ + INSN_OP_FIRST, /* 91 */ + INSN_OP_LAST, /* 92 */ + INSN_OP_OTHER, /* 93 */ INSN_OP_PMREPLROOT, /* 94 */ INSN_OP_PMREPLROOTGV, /* 95 */ INSN_OP_PMREPLSTART, /* 96 */ @@ -134,7 +146,10 @@ enum { INSN_MAIN_START, /* 115 */ INSN_MAIN_ROOT, /* 116 */ INSN_CURPAD, /* 117 */ - MAX_INSN = 117 + INSN_PUSH_BEGIN, /* 118 */ + INSN_PUSH_INIT, /* 119 */ + INSN_PUSH_END, /* 120 */ + MAX_INSN = 120 }; enum { @@ -151,11 +166,3 @@ enum { 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/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes index 95eb487e5659..eda270d82b52 100644 --- a/contrib/perl5/ext/DB_File/Changes +++ b/contrib/perl5/ext/DB_File/Changes @@ -291,3 +291,46 @@ to David Harris for spotting the underlying problem, contributing the updates to the documentation and writing DB_File::Lock (available on CPAN). + +1.73 31st May 2000 + + * Added support in version.c for building with threaded Perl. + + * Berkeley DB 3.1 has reenabled support for null keys. The test + harness has been updated to reflect this. + +1.74 10th December 2000 + + * A "close" call in DB_File.xs needed parenthesised to stop win32 from + thinking it was one of its macros. + + * Updated dbinfo to support Berkeley DB 3.1 file format changes. + + * DB_File.pm & the test hasness now use the warnings pragma (when + available). + + * Included Perl core patch 7703 -- size argument for hash_cb is different + for Berkeley DB 3.x + + * Included Perl core patch 7801 -- Give __getBerkeleyDBInfo the ANSI C + treatment. + + * @a = () produced the warning 'Argument "" isn't numeric in entersub' + This has been fixed. Thanks to Edward Avis for spotting this bug. + + * Added note about building under Linux. Included patches. + + * Included Perl core patch 8068 -- fix for bug 20001013.009 + When run with warnings enabled "$hash{XX} = undef " produced an + "Uninitialized value" warning. This has been fixed. + +1.75 17th December 2000 + + * Fixed perl core patch 7703 + + * Added suppport to allow DB_File to be built with Berkeley DB 3.2 -- + btree_compare, btree_prefix and hash_cb needed to be changed. + + * Updated dbinfo to support Berkeley DB 3.2 file format changes. + + diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm index 00b24b90e611..c8302168f8e4 100644 --- a/contrib/perl5/ext/DB_File/DB_File.pm +++ b/contrib/perl5/ext/DB_File/DB_File.pm @@ -1,8 +1,8 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 16th January 2000 -# version 1.72 +# last modified 17th December 2000 +# version 1.75 # # Copyright (c) 1995-2000 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or @@ -13,6 +13,7 @@ package DB_File::HASHINFO ; require 5.003 ; +use warnings; use strict; use Carp; require Tie::Hash; @@ -104,6 +105,7 @@ sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } package DB_File::RECNOINFO ; +use warnings; use strict ; @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; @@ -121,6 +123,7 @@ sub TIEHASH package DB_File::BTREEINFO ; +use warnings; use strict ; @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; @@ -140,6 +143,7 @@ sub TIEHASH package DB_File ; +use warnings; use strict; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version $use_XSLoader @@ -147,7 +151,7 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO use Carp; -$VERSION = "1.72" ; +$VERSION = "1.75" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -271,7 +275,7 @@ sub TIEARRAY sub CLEAR { my $self = shift; - my $key = "" ; + my $key = 0 ; my $value = "" ; my $status = $self->seq($key, $value, R_FIRST()); my @keys; @@ -665,6 +669,7 @@ This example shows how to create a database, add key/value pairs to the database, delete keys/value pairs and finally how to enumerate the contents of the database. + use warnings ; use strict ; use DB_File ; use vars qw( %h $k $v ) ; @@ -715,6 +720,7 @@ This script shows how to override the default sorting algorithm that BTREE uses. Instead of using the normal lexical ordering, a case insensitive compare function will be used. + use warnings ; use strict ; use DB_File ; @@ -783,6 +789,7 @@ There are some difficulties in using the tied hash interface if you want to manipulate a BTREE database with duplicate keys. Consider this code: + use warnings ; use strict ; use DB_File ; @@ -837,6 +844,7 @@ and the API in general. Here is the script above rewritten using the C<seq> API method. + use warnings ; use strict ; use DB_File ; @@ -908,6 +916,7 @@ particular value occurred in the BTREE. So assuming the database created above, we can use C<get_dup> like this: + use warnings ; use strict ; use DB_File ; @@ -957,6 +966,7 @@ returns 0. Otherwise the method returns a non-zero value. Assuming the database from the previous example: + use warnings ; use strict ; use DB_File ; @@ -995,6 +1005,7 @@ Otherwise the method returns a non-zero value. Again assuming the existence of the C<tree> database + use warnings ; use strict ; use DB_File ; @@ -1039,6 +1050,7 @@ the use of the R_CURSOR flag with seq: In the example script below, the C<match> sub uses this feature to find and print the first matching key/value pair given a partial key. + use warnings ; use strict ; use DB_File ; use Fcntl ; @@ -1143,6 +1155,7 @@ Here is a simple example that uses RECNO (if you are using a version of Perl earlier than 5.004_57 this example won't work -- see L<Extra RECNO Methods> for a workaround). + use warnings ; use strict ; use DB_File ; @@ -1232,6 +1245,7 @@ Here is a more complete example that makes use of some of the methods described above. It also makes use of the API interface directly (see L<THE API INTERFACE>). + use warnings ; use strict ; use vars qw(@h $H $file $i) ; use DB_File ; @@ -1583,6 +1597,7 @@ 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 warnings ; use strict ; use DB_File ; @@ -1625,6 +1640,7 @@ when reading. Here is a DBM Filter that does it: + use warnings ; use strict ; use DB_File ; my %hash ; @@ -1791,6 +1807,7 @@ Here is a snippet of code that is loosely based on Tom Christiansen's I<ggh> script (available from your nearest CPAN archive in F<authors/id/TOMC/scripts/nshist.gz>). + use warnings ; use strict ; use DB_File ; use Fcntl ; @@ -1947,6 +1964,7 @@ You will encounter this particular error message when you have the C<strict 'subs'> pragma (or the full strict pragma) in your script. Consider this script: + use warnings ; use strict ; use DB_File ; use vars qw(%x) ; diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs index 2b76bab72263..fa3bb336c2d2 100644 --- a/contrib/perl5/ext/DB_File/DB_File.xs +++ b/contrib/perl5/ext/DB_File/DB_File.xs @@ -3,8 +3,8 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 16th January 2000 - version 1.72 + last modified 17 December 2000 + version 1.75 All comments/suggestions/problems are welcome @@ -82,6 +82,14 @@ Support for Berkeley DB 2/3's backward compatability mode. Rewrote push 1.72 - No change to DB_File.xs + 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + Added suppport to allow DB_File to be built with + Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb + needed to be changed. */ @@ -127,6 +135,10 @@ # include <db.h> #endif +#ifdef CAN_PROTOTYPE +extern void __getBerkeleyDBInfo(void); +#endif + #ifndef pTHX # define pTHX # define pTHX_ @@ -158,6 +170,10 @@ # define BERKELEY_DB_1_OR_2 #endif +#if DB_VERSION_MAJOR > 3 || (DB_VERSION_MAJOR == 3 && DB_VERSION_MINOR >= 2) +# define AT_LEAST_DB_3_2 +#endif + /* map version 2 features & constants onto their version 1 equivalent */ #ifdef DB_Prefix_t @@ -243,6 +259,7 @@ typedef db_recno_t recno_t; #else /* db version 1.x */ +#define BERKELEY_DB_1 #define BERKELEY_DB_1_OR_2 typedef union INFO { @@ -472,6 +489,19 @@ u_int flags ; static int +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_compare(DB * db, const DBT *key1, const DBT *key2) +#else +btree_compare(db, key1, key2) +DB * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif /* CAN_PROTOTYPE */ + +#else /* Berkeley DB < 3.2 */ + #ifdef CAN_PROTOTYPE btree_compare(const DBT *key1, const DBT *key2) #else @@ -479,6 +509,9 @@ btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif + { #ifdef dTHX dTHX; @@ -528,6 +561,19 @@ const DBT * key2 ; } static DB_Prefix_t +#ifdef AT_LEAST_DB_3_2 + +#ifdef CAN_PROTOTYPE +btree_prefix(DB * db, const DBT *key1, const DBT *key2) +#else +btree_prefix(db, key1, key2) +Db * db ; +const DBT * key1 ; +const DBT * key2 ; +#endif + +#else /* Berkeley DB < 3.2 */ + #ifdef CAN_PROTOTYPE btree_prefix(const DBT *key1, const DBT *key2) #else @@ -535,6 +581,8 @@ btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; #endif + +#endif { #ifdef dTHX dTHX; @@ -583,13 +631,35 @@ const DBT * key2 ; return (retval) ; } + +#ifdef BERKELEY_DB_1 +# define HASH_CB_SIZE_TYPE size_t +#else +# define HASH_CB_SIZE_TYPE u_int32_t +#endif + static DB_Hash_t +#ifdef AT_LEAST_DB_3_2 + #ifdef CAN_PROTOTYPE -hash_cb(const void *data, size_t size) +hash_cb(DB * db, const void *data, u_int32_t size) +#else +hash_cb(db, data, size) +DB * db ; +const void * data ; +HASH_CB_SIZE_TYPE size ; +#endif + +#else /* Berkeley DB < 3.2 */ + +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, HASH_CB_SIZE_TYPE size) #else hash_cb(data, size) const void * data ; -size_t size ; +HASH_CB_SIZE_TYPE size ; +#endif + #endif { #ifdef dTHX @@ -1265,7 +1335,7 @@ SV * sv ; Flags |= DB_TRUNCATE ; #endif - status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, Flags, mode) ; /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL index cac6578bb308..041416029ac4 100644 --- a/contrib/perl5/ext/DB_File/Makefile.PL +++ b/contrib/perl5/ext/DB_File/Makefile.PL @@ -17,6 +17,7 @@ WriteMakefile( OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', XSPROTOARG => '-noprototypes', DEFINE => $OS2 || "", + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); sub MY::postamble { diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo index 701ac612b62b..5a4df15907ee 100644 --- a/contrib/perl5/ext/DB_File/dbinfo +++ b/contrib/perl5/ext/DB_File/dbinfo @@ -4,10 +4,10 @@ # a database file # # Author: Paul Marquess <Paul.Marquess@btinternet.com> -# Version: 1.02 -# Date 20th August 1999 +# Version: 1.03 +# Date 17th September 2000 # -# Copyright (c) 1998 Paul Marquess. All rights reserved. +# Copyright (c) 1998-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. @@ -28,7 +28,8 @@ my %Data = 4 => "Unknown", 5 => "2.0.0 -> 2.3.0", 6 => "2.3.1 -> 2.7.7", - 7 => "3.0.0 or greater", + 7 => "3.0.x", + 8 => "3.1.x or greater", } }, 0x061561 => { @@ -40,14 +41,17 @@ my %Data = 3 => "1.86", 4 => "2.0.0 -> 2.1.0", 5 => "2.2.6 -> 2.7.7", - 6 => "3.0.0 or greater", + 6 => "3.0.x", + 7 => "3.1.x or greater", } }, 0x042253 => { Type => "Queue", Versions => { - 1 => "3.0.0 or greater", + 1 => "3.0.x", + 2 => "3.1.x", + 3 => "3.2.x or greater", } }, ) ; @@ -86,7 +90,7 @@ else { die "not a Berkeley DB database file.\n" } my $type = $Data{$magic} ; -my $magic = sprintf "%06X", $magic ; +$magic = sprintf "%06X", $magic ; my $ver_string = "Unknown" ; $ver_string = $type->{Versions}{$version} diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap index 41a24f4a8638..55439ee76d91 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 7th September 1999 -# version 1.71 +# last modified 10th December 2000 +# version 1.74 # #################################### DB SECTION # @@ -29,9 +29,10 @@ T_dbtkeydatum T_dbtdatum ckFilter($arg, filter_store_value, \"filter_store_value\"); DBT_clear($var) ; - $var.data = SvPV($arg, PL_na); - $var.size = (int)PL_na; - + if (SvOK($arg)) { + $var.data = SvPV($arg, PL_na); + $var.size = (int)PL_na; + } OUTPUT diff --git a/contrib/perl5/ext/DB_File/version.c b/contrib/perl5/ext/DB_File/version.c index f8c6cac9af78..6e55b2e3d18b 100644 --- a/contrib/perl5/ext/DB_File/version.c +++ b/contrib/perl5/ext/DB_File/version.c @@ -4,7 +4,7 @@ written by Paul Marquess <Paul.Marquess@btinternet.com> last modified 16th January 2000 - version 1.72 + version 1.73 All comments/suggestions/problems are welcome @@ -16,6 +16,9 @@ 1.71 - Support for Berkeley DB version 3. Support for Berkeley DB 2/3's backward compatability mode. 1.72 - No change. + 1.73 - Added support for threading + 1.74 - Added Perl core patch 7801. + */ @@ -26,8 +29,15 @@ #include <db.h> void +#ifdef CAN_PROTOTYPE +__getBerkeleyDBInfo(void) +#else __getBerkeleyDBInfo() +#endif { +#ifdef dTHX + dTHX; +#endif 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) ; diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm index 93b87f9aba96..a8e59ab379d7 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.pm +++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm @@ -9,7 +9,7 @@ package Data::Dumper; -$VERSION = '2.101'; +$VERSION = '2.102'; #$| = 1; @@ -291,8 +291,7 @@ sub _dump { $s->{level}++; $ipad = $s->{xpad} x $s->{level}; - - if ($realtype eq 'SCALAR') { + if ($realtype eq 'SCALAR' || $realtype eq 'REF') { if ($realpack) { $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; } @@ -685,7 +684,7 @@ the last. Returns the stringified form of the values stored in the object (preserving the order in which they were supplied to C<new>), subject to the -configuration options below. In an array context, it returns a list +configuration options below. In a list context, it returns a list of strings corresponding to the supplied values. The second form, for convenience, simply calls the C<new> method on its @@ -701,7 +700,7 @@ dumping subroutine references. Expects a anonymous hash of name => value pairs. Same rules apply for names as in C<new>. If no argument is supplied, will return the "seen" list of -name => value pairs, in an array context. Otherwise, returns the object +name => value pairs, in a list context. Otherwise, returns the object itself. =item I<$OBJ>->Values(I<[ARRAYREF]>) @@ -732,7 +731,7 @@ itself. Returns the stringified form of the values in the list, subject to the 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. +in a list context. =back diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs index 990ea7469931..25e72b144c9d 100644 --- a/contrib/perl5/ext/Data/Dumper/Dumper.xs +++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs @@ -584,8 +584,10 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (SvIOK(val)) { STRLEN len; - i = SvIV(val); - (void) sprintf(tmpbuf, "%"IVdf, (IV)i); + if (SvIsUV(val)) + (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); + else + (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); } @@ -803,7 +805,7 @@ Data_Dumper_Dumpxs(href, ...) if ((svp = av_fetch(namesav, i, TRUE))) sv_setsv(name, *svp); else - SvOK_off(name); + (void)SvOK_off(name); if (SvOK(name)) { if ((SvPVX(name))[0] == '*') { diff --git a/contrib/perl5/ext/Devel/DProf/DProf.xs b/contrib/perl5/ext/Devel/DProf/DProf.xs index 31e984f929b7..aba6de99d3ed 100644 --- a/contrib/perl5/ext/Devel/DProf/DProf.xs +++ b/contrib/perl5/ext/Devel/DProf/DProf.xs @@ -3,11 +3,6 @@ #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 */ @@ -28,6 +23,7 @@ # define HZ ((I32)CLK_TCK) # define DPROF_HZ HZ # include <starlet.h> /* prototype for sys$gettim() */ +# include <lib$routines.h> # define Times(ptr) (dprof_times(aTHX_ ptr)) #else # ifndef HZ @@ -280,10 +276,6 @@ 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 */ @@ -388,7 +380,6 @@ prof_mark(pTHX_ opcode ptype) 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; @@ -477,8 +468,6 @@ prof_record(pTHX) /* 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); } @@ -502,7 +491,7 @@ prof_record(pTHX) static void check_depth(pTHX_ void *foo) { - U32 need_depth = (U32)foo; + U32 need_depth = PTR2UV(foo); if (need_depth != g_depth) { if (need_depth > g_depth) { warn("garbled call depth when profiling"); @@ -547,6 +536,7 @@ XS(XS_DB_sub) prof_mark(aTHX_ OP_ENTERSUB); PUSHMARK(ORIGMARK); perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG); + PL_curstash = oldstash; prof_mark(aTHX_ OP_LEAVESUB); g_depth--; } diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL index 3c6dbf545d1c..f6d0cc9caa5d 100644 --- a/contrib/perl5/ext/Devel/Peek/Makefile.PL +++ b/contrib/perl5/ext/Devel/Peek/Makefile.PL @@ -2,6 +2,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => "Devel::Peek", VERSION_FROM => 'Peek.pm', + XSPROTOARG => '-noprototypes', 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm index 080251bb5e87..08501728c06d 100644 --- a/contrib/perl5/ext/Devel/Peek/Peek.pm +++ b/contrib/perl5/ext/Devel/Peek/Peek.pm @@ -10,7 +10,8 @@ require Exporter; use XSLoader (); @ISA = qw(Exporter); -@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg + fill_mstats mstats_fillhash mstats2hash); @EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); @@ -58,16 +59,76 @@ 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. Function C<DumpArray()> allows dumping of multiple values (useful when you -need to analize returns of functions). +need to analyze 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. +=head2 Memory footprint debugging + +When perl is compiled with support for memory footprint debugging +(default with Perl's malloc()), Devel::Peek provides an access to this API. + +Use mstat() function to emit a memory state statistic to the terminal. +For more information on the format of output of mstat() see +L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. + +Three additional functions allow access to this statistic from Perl. +First, use C<mstats_fillhash(%hash)> to get the information contained +in the output of mstat() into %hash. The field of this hash are + + minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack + topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree + +Two additional fields C<free>, C<used> contain array references which +provide per-bucket count of free and used chunks. Two other fields +C<mem_size>, C<available_size> contain array references which provide +the information about the allocated size and usable size of chunks in +each bucket. Again, see L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>> +for details. + +Keep in mind that only the first several "odd-numbered" buckets are +used, so the information on size of the "odd-numbered" buckets which are +not used is probably meaningless. + +The information in + + mem_size available_size minbucket nbuckets + +is the property of a particular build of perl, and does not depend on +the current process. If you do not provide the optional argument to +the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then +the information in fields C<mem_size>, C<available_size> is not +updated. + +C<fill_mstats($buf)> is a much cheaper call (both speedwise and +memory-wise) which collects the statistic into $buf in +machine-readable form. At a later moment you may need to call +C<mstats2hash($buf, %hash)> to use this information to fill %hash. + +All three APIs C<fill_mstats($buf)>, C<mstats_fillhash(%hash)>, and +C<mstats2hash($buf, %hash)> are designed to allocate no memory if used +I<the second time> on the same $buf and/or %hash. + +So, if you want to collect memory info in a cycle, you may call + + $#buf = 999; + fill_mstats($_) for @buf; + mstats_fillhash(%report, 1); # Static info too + + foreach (@buf) { + # Do something... + fill_mstats $_; # Collect statistic + } + foreach (@buf) { + mstats2hash($_, %report); # Preserve static info + # Do something with %report + } + =head1 EXAMPLES The following examples don't attempt to show everything as that would be a @@ -403,8 +464,9 @@ it has no prototype (C<PROTOTYPE> field is missing). =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>. +C<DumpProg>, C<fill_mstats>, C<mstats_fillhash>, C<mstats2hash> by +default. Additionally available C<SvREFCNT>, C<SvREFCNT_inc> and +C<SvREFCNT_dec>. =head1 BUGS diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs index 9837e9ceb216..1e481492b5d9 100644 --- a/contrib/perl5/ext/Devel/Peek/Peek.xs +++ b/contrib/perl5/ext/Devel/Peek/Peek.xs @@ -82,8 +82,6 @@ DeadCode(pTHX) } } 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); */ @@ -125,6 +123,183 @@ DeadCode(pTHX) PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); #endif +#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ + || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) + +/* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ +# define _NBUCKETS (2*8*IVSIZE+1) + +struct mstats_buffer +{ + perl_mstats_t buffer; + UV buf[_NBUCKETS*4]; +}; + +void +_fill_mstats(struct mstats_buffer *b, int level) +{ + dTHX; + b->buffer.nfree = b->buf; + b->buffer.ntotal = b->buf + _NBUCKETS; + b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; + b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; + Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); + get_mstats(&(b->buffer), _NBUCKETS, level); +} + +void +fill_mstats(SV *sv, int level) +{ + dTHX; + int nbuckets; + struct mstats_buffer buf; + + if (SvREADONLY(sv)) + croak("Cannot modify a readonly value"); + SvGROW(sv, sizeof(struct mstats_buffer)+1); + _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); + SvCUR_set(sv, sizeof(struct mstats_buffer)); + *SvEND(sv) = '\0'; + SvPOK_only(sv); +} + +void +_mstats_to_hv(HV *hv, struct mstats_buffer *b, int level) +{ + dTHX; + SV **svp; + int type; + + svp = hv_fetch(hv, "topbucket", 9, 1); + sv_setiv(*svp, b->buffer.topbucket); + + svp = hv_fetch(hv, "topbucket_ev", 12, 1); + sv_setiv(*svp, b->buffer.topbucket_ev); + + svp = hv_fetch(hv, "topbucket_odd", 13, 1); + sv_setiv(*svp, b->buffer.topbucket_odd); + + svp = hv_fetch(hv, "totfree", 7, 1); + sv_setiv(*svp, b->buffer.totfree); + + svp = hv_fetch(hv, "total", 5, 1); + sv_setiv(*svp, b->buffer.total); + + svp = hv_fetch(hv, "total_chain", 11, 1); + sv_setiv(*svp, b->buffer.total_chain); + + svp = hv_fetch(hv, "total_sbrk", 10, 1); + sv_setiv(*svp, b->buffer.total_sbrk); + + svp = hv_fetch(hv, "sbrks", 5, 1); + sv_setiv(*svp, b->buffer.sbrks); + + svp = hv_fetch(hv, "sbrk_good", 9, 1); + sv_setiv(*svp, b->buffer.sbrk_good); + + svp = hv_fetch(hv, "sbrk_slack", 10, 1); + sv_setiv(*svp, b->buffer.sbrk_slack); + + svp = hv_fetch(hv, "start_slack", 11, 1); + sv_setiv(*svp, b->buffer.start_slack); + + svp = hv_fetch(hv, "sbrked_remains", 14, 1); + sv_setiv(*svp, b->buffer.sbrked_remains); + + svp = hv_fetch(hv, "minbucket", 9, 1); + sv_setiv(*svp, b->buffer.minbucket); + + svp = hv_fetch(hv, "nbuckets", 8, 1); + sv_setiv(*svp, b->buffer.nbuckets); + + if (_NBUCKETS < b->buffer.nbuckets) + warn("FIXME: internal mstats buffer too short"); + + for (type = 0; type < (level ? 4 : 2); type++) { + UV *p, *p1; + AV *av; + int i; + static const char *types[4] = { + "free", "used", "mem_size", "available_size" + }; + + svp = hv_fetch(hv, types[type], strlen(types[type]), 1); + + if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) + croak("Unexpected value for the key '%s' in the mstats hash", types[type]); + if (!SvOK(*svp)) { + av = newAV(); + SvUPGRADE(*svp, SVt_RV); + SvRV(*svp) = (SV*)av; + SvROK_on(*svp); + } else + av = (AV*)SvRV(*svp); + + av_extend(av, b->buffer.nbuckets - 1); + /* XXXX What is the official way to reduce the size of the array? */ + switch (type) { + case 0: + p = b->buffer.nfree; + break; + case 1: + p = b->buffer.ntotal; + p1 = b->buffer.nfree; + break; + case 2: + p = b->buffer.bucket_mem_size; + break; + case 3: + p = b->buffer.bucket_available_size; + break; + } + for (i = 0; i < b->buffer.nbuckets; i++) { + svp = av_fetch(av, i, 1); + if (type == 1) + sv_setiv(*svp, p[i]-p1[i]); + else + sv_setuv(*svp, p[i]); + } + } +} +void +mstats_fillhash(SV *sv, int level) +{ + struct mstats_buffer buf; + + if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) + croak("Not a hash reference"); + _fill_mstats(&buf, level); + _mstats_to_hv((HV *)SvRV(sv), &buf, level); +} +void +mstats2hash(SV *sv, SV *rv, int level) +{ + if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) + croak("Not a hash reference"); + if (!SvPOK(sv)) + croak("Undefined value when expecting mstats buffer"); + if (SvCUR(sv) != sizeof(struct mstats_buffer)) + croak("Wrong size for a value with a mstats buffer"); + _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); +} +#else /* !( defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ ) */ +void +fill_mstats(SV *sv, int level) +{ + croak("Cannot report mstats without Perl malloc"); +} +void +mstats_fillhash(SV *sv, int level) +{ + croak("Cannot report mstats without Perl malloc"); +} +void +mstats2hash(SV *sv, SV *rv, int level) +{ + croak("Cannot report mstats without Perl malloc"); +} +#endif /* defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS)... */ + #define _CvGV(cv) \ (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) @@ -136,6 +311,17 @@ mstat(str="Devel::Peek::mstat: ") char *str void +fill_mstats(SV *sv, int level = 0) + +void +mstats_fillhash(SV *sv, int level = 0) + PROTOTYPE: \%;$ + +void +mstats2hash(SV *sv, SV *rv, int level = 0) + PROTOTYPE: $\%;$ + +void Dump(sv,lim=4) SV * sv I32 lim @@ -173,7 +359,7 @@ void DumpProg() PPCODE: { - warn("dumpindent is %d", PL_dumpindent); + warn("dumpindent is %d", (int)PL_dumpindent); if (PL_main_root) op_dump(PL_main_root); } @@ -195,7 +381,7 @@ PPCODE: # PPCODE needed since by default it is void -SV * +void SvREFCNT_dec(sv) SV * sv PPCODE: diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL index e0eb604c73ae..266c9d030f77 100644 --- a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL +++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL @@ -1,4 +1,3 @@ - use Config; sub to_string { @@ -12,7 +11,7 @@ unlink "DynaLoader.pm" if -f "DynaLoader.pm"; open OUT, ">DynaLoader.pm" or die $!; print OUT <<'EOT'; -# Generated from DynaLoader.pm.PL (resolved %Config::Config values) +# Generated from DynaLoader.pm.PL package DynaLoader; @@ -21,18 +20,22 @@ package DynaLoader; # feast like to keep their secret; for wonder makes the words of # praise louder.' -# (Quote from Tolkien sugested by Anno Siegel.) +# (Quote from Tolkien suggested 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 = "1.04"; # avoid typo warning +use vars qw($VERSION *AUTOLOAD); + +$VERSION = 1.04; # avoid typo warning require AutoLoader; *AUTOLOAD = \&AutoLoader::AUTOLOAD; +use Config; + # The following require can't be removed during maintenance # releases, sadly, because of the risk of buggy code that does # require Carp; Carp::croak "..."; without brackets dying @@ -40,7 +43,6 @@ require AutoLoader; # We'll let those bugs get found on the development track. require Carp if $] < 5.00450; - # enable debug/trace messages from DynaLoader perl code $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; @@ -71,52 +73,116 @@ print OUT <<'EOT'; # (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) # 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_VMS = $^O eq 'VMS'; +$do_expand = $Is_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"; -# Initialise @dl_library_path with the 'standard' library path -# for this platform as determined by Configure +EOT -# push(@dl_library_path, split(' ', $Config::Config{'libpth'}); +my $cfg_dl_library_path = <<'EOT'; +push(@dl_library_path, split(' ', $Config::Config{libpth})); EOT -print OUT "push(\@dl_library_path, split(' ', ", - to_string($Config::Config{'libpth'}), "));\n"; +sub dquoted_comma_list { + join(", ", map {qq("$_")} @_); +} -print OUT <<'EOT'; +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + eval $cfg_dl_library_path; + if (!$ENV{PERL_BUILD_EXPAND_ENV_VARS}) { + my $dl_library_path = dquoted_comma_list(@dl_library_path); + print OUT <<EOT; +# The below \@dl_library_path has been expanded (%Config) in Perl build time. + +\@dl_library_path = ($dl_library_path); + +EOT + } +} +else { + print OUT <<EOT; +# Initialise \@dl_library_path with the 'standard' library path +# for this platform as determined by Configure. + +$cfg_dl_library_path + +EOT +} + +my $ldlibpthname; +my $ldlibpthname_defined; +my $pthsep; + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) { + $ldlibpthname = $Config::Config{ldlibpthname}; + $ldlibpthname_defined = defined $Config::Config{ldlibpthname} ? 1 : 0; + $pthsep = $Config::Config{path_sep}; +} +else { + $ldlibpthname = q($Config::Config{ldlibpthname}); + $ldlibpthname_defined = q(defined $Config::Config{ldlibpthname}); + $pthsep = q($Config::Config{path_sep}); + print OUT <<EOT; +my \$ldlibpthname = $ldlibpthname; +my \$ldlibpthname_defined = $ldlibpthname_defined; +my \$pthsep = $pthsep; + +EOT +} + +my $env_dl_library_path = <<'EOT'; +if ($ldlibpthname_defined && + exists $ENV{$ldlibpthname}) { + push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname})); +} -# 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 exists $ENV{LD_LIBRARY_PATH}; + +if ($ldlibpthname_defined && + $ldlibpthname ne 'LD_LIBRARY_PATH' && + exists $ENV{LD_LIBRARY_PATH}) { + push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH})); +} +EOT + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) { + eval $env_dl_library_path; +} +else { + print OUT <<EOT; +# Add to \@dl_library_path any extra directories we can gather from environment +# during runtime. + +$env_dl_library_path + +EOT +} + +if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS} && $ENV{PERL_BUILD_EXPAND_ENV_VARS}) { + my $dl_library_path = dquoted_comma_list(@dl_library_path); + print OUT <<EOT; +# The below \@dl_library_path has been expanded (%Config, %ENV) +# in Perl build time. + +\@dl_library_path = ($dl_library_path); + +EOT } +print OUT <<'EOT'; # No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_load_file); - + !defined(&dl_error); if ($dl_debug) { print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; @@ -170,8 +236,8 @@ sub bootstrap { print STDERR "DynaLoader::bootstrap for $module ", ($Is_MacOS - ? "(auto/$modpname/$modfname.$dl_dlext)\n" : - "(:auto:$modpname:$modfname.$dl_dlext)\n") + ? "(:auto:$modpname:$modfname.$dl_dlext)\n" : + "(auto/$modpname/$modfname.$dl_dlext)\n") if $dl_debug; foreach (@INC) { @@ -198,7 +264,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}; + $file = uc($file) if $Is_VMS && $Config::Config{d_vms_case_sensitive_symbols}; my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @dl_require_symbols = ($bootname); @@ -326,7 +392,7 @@ print OUT <<'EOT'; # (this is a more complicated issue than it first appears) if (m:/: && -d $_) { push(@dirs, $_); next; } - # VMS: we may be using native VMS directry syntax instead of + # VMS: we may be using native VMS directory syntax instead of # Unix emulation, so check this as well if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } diff --git a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL index 8cdfd634255e..7657410d46c3 100644 --- a/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL +++ b/contrib/perl5/ext/DynaLoader/XSLoader_pm.PL @@ -37,10 +37,12 @@ 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; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && - !defined(&dl_load_file); + !defined(&dl_error); package XSLoader; 1; # End of main code diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs index 35242ed652da..e29c0f85f76f 100644 --- a/contrib/perl5/ext/DynaLoader/dl_aix.xs +++ b/contrib/perl5/ext/DynaLoader/dl_aix.xs @@ -11,6 +11,8 @@ * on statup... It can probably be trimmed more. */ +#define PERLIO_NOT_STDIO 0 + /* * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17 * This is an unpublished work copyright (c) 1992 Helios Software GmbH @@ -36,6 +38,8 @@ #include <sys/types.h> #include <sys/ldr.h> #include <a.out.h> +#undef FREAD +#undef FWRITE #include <ldfcn.h> #ifdef USE_64_BIT_ALL @@ -58,13 +62,18 @@ /* 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" +# if defined(USE_vacpp_load_h) +# include "/usr/vacpp/include/load.h" # elif defined(USE_ibmcxx_load_h) # include "/usr/ibmcxx/include/load.h" +# elif defined(USE_xlC_load_h) +# include "/usr/lpp/xlC/include/load.h" +# elif defined(USE_load_h) +# include "/usr/include/load.h" # endif #else # define LOAD load @@ -85,12 +94,6 @@ # define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr)) #endif -/* If using PerlIO, redefine these macros from <ldfcn.h> */ -#ifdef USE_PERLIO -#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) -#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) -#endif - /* * We simulate dlopen() et al. through a call to load. Because AIX has * no call to find an exported symbol we read the loader section of the @@ -116,8 +119,8 @@ typedef struct Module { } Module, *ModulePtr; /* - * We keep a list of all loaded modules to be able to call the fini - * handlers at atexit() time. + * We keep a list of all loaded modules to be able to reference count + * duplicate dlopen's. */ static ModulePtr modList; /* XXX threaded */ @@ -130,7 +133,7 @@ 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)"; @@ -197,15 +200,15 @@ void *dlopen(char *path, int mode) { dTHX; register ModulePtr mp; - static int inited; /* XXX threaded */ + static void *mainModule; /* XXX threaded */ /* * Upon the first call register a terminate handler that will * close all libraries. */ - if (!inited) { - inited++; - atexit(terminate); + if (mainModule == NULL) { + if ((mainModule = findMain()) == NULL) + return NULL; } /* * Scan the list of modules if have the module already loaded. @@ -273,9 +276,13 @@ void *dlopen(char *path, int mode) /* * 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. + * of the perl core are in the same shared object. Also bind + * against the main part, in the case a perl is not the main + * part, e.g mod_perl as DSO in Apache so perl modules can + * also reference Apache symbols. */ - if (loadbind(0, (void *)dlopen, mp->entry) == -1) { + if (loadbind(0, (void *)dlopen, mp->entry) == -1 || + loadbind(0, mainModule, mp->entry)) { int saverrno = errno; dlclose(mp); @@ -303,7 +310,7 @@ static void caterr(char *s) p++; switch(atoi(s)) { case L_ERROR_TOOMANY: - strcat(errbuf, "to many errors"); + strcat(errbuf, "too many errors"); break; case L_ERROR_NOLIB: strcat(errbuf, "can't load library"); @@ -393,12 +400,6 @@ int dlclose(void *handle) return result; } -static void terminate(void) -{ - while (modList) - dlclose(modList); -} - /* Added by Wayne Scott * This is needed because the ldopen system call calls * calloc to allocated a block of date. The ldclose call calls free. @@ -530,11 +531,7 @@ static int readExports(ModulePtr mp) } /* This first case is a hack, since it assumes that the 3rd parameter to FREAD is 1. See the redefinition of FREAD above to see how this works. */ -#ifdef USE_PERLIO - if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) { -#else if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { -#endif errvalid++; strcpy(errbuf, "readExports: cannot read loader section"); safefree(ldbuf); @@ -590,6 +587,52 @@ 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. @@ -642,6 +685,17 @@ dl_load_file(filename, flags=0) else 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 * dl_find_symbol(libhandle, symbolname) diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs index 8e4936d128d9..e1b2a8241082 100644 --- a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs +++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs @@ -112,7 +112,7 @@ SaveError("%s",dlerror()) ; Note that SaveError() takes a printf format string. Use a "%s" as - the first parameter if the error may contain and % characters. + the first parameter if the error may contain any % characters. */ @@ -198,7 +198,7 @@ int dl_unload_file(libref) void * libref CODE: - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", PTR2ul(libref))); RETVAL = (dlclose(libref) == 0 ? 1 : 0); if (!RETVAL) SaveError(aTHX_ "%s", dlerror()) ; diff --git a/contrib/perl5/ext/DynaLoader/hints/aix.pl b/contrib/perl5/ext/DynaLoader/hints/aix.pl index 7dde941b43d6..d4231ccb3ef8 100644 --- a/contrib/perl5/ext/DynaLoader/hints/aix.pl +++ b/contrib/perl5/ext/DynaLoader/hints/aix.pl @@ -2,9 +2,13 @@ use Config; if ($Config{libs} =~ /-lC/ && -f '/lib/libC.a') { $self->{CCFLAGS} = $Config{ccflags} . ' -DUSE_libC'; - if (-f '/usr/ibmcxx/include/load.h') { + if (-f '/usr/vacpp/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_vacpp_load_h'; + } elsif (-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'; + } elsif (-f '/usr/include/load.h') { + $self->{CCFLAGS} .= ' -DUSE_load_h'; } } diff --git a/contrib/perl5/ext/Errno/ChangeLog b/contrib/perl5/ext/Errno/ChangeLog index 2bfa003d96a4..dd94b37bafb0 100644 --- a/contrib/perl5/ext/Errno/ChangeLog +++ b/contrib/perl5/ext/Errno/ChangeLog @@ -1,3 +1,8 @@ +Change 171 on 2000-09-12 by <calle@lysator.liu.se> (Calle Dybedahl) + + - Fixed filename-extracting regexp to allow whitespace between + "#" and "line", which the cpp on Unicos 9 produces. + Change 170 on 1998/07/05 by <gbarr@pobox.com> (Graham Barr) Fixed three problems reported by Hans Mulder for NeXT diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL index df68dc3bda60..3f2f3e04266a 100644 --- a/contrib/perl5/ext/Errno/Errno_pm.PL +++ b/contrib/perl5/ext/Errno/Errno_pm.PL @@ -29,6 +29,14 @@ sub process_file { warn "Cannot open '$file'"; return; } + } elsif ($Config{gccversion} ne '') { + # With the -dM option, gcc outputs every #define it finds + my $ccopts = "-E -dM "; + $ccopts .= "-traditional-cpp " if $^O eq 'darwin'; + unless(open(FH,"$Config{cc} $ccopts $file |")) { + warn "Cannot open '$file'"; + return; + } } else { unless(open(FH,"< $file")) { # This file could be a temporary file created by cppstdin @@ -37,11 +45,19 @@ sub process_file { return; } } - while(<FH>) { - $err{$1} = 1 - if /^\s*#\s*define\s+(E\w+)\s+/; - } - close(FH); + + if ($^O eq 'MacOS') { + while(<FH>) { + $err{$1} = $2 + if /^\s*#\s*define\s+(E\w+)\s+(\d+)/; + } + } else { + while(<FH>) { + $err{$1} = 1 + if /^\s*#\s*define\s+(E\w+)\s+/; + } + } + close(FH); } my $cppstdin; @@ -79,6 +95,18 @@ sub get_files { } elsif ($^O eq 'vmesa') { # OS/390 C compiler doesn't generate #file or #line directives $file{'../../vmesa/errno.h'} = 1; + } elsif ($Config{archname} eq 'epoc') { + # Watch out for cross compiling for EPOC (usually done on linux) + $file{'/usr/local/epoc/include/libc/sys/errno.h'} = 1; + } elsif ($^O eq 'linux') { + # Some Linuxes have weird errno.hs which generate + # no #file or #line directives + $file{'/usr/include/errno.h'} = 1; + } elsif ($^O eq 'MacOS') { + # note that we are only getting the GUSI errno's here ... + # we might miss out on compiler-specific ones + $file{"$ENV{GUSI}include:sys:errno.h"} = 1; + } else { open(CPPI,"> errno.c") or die "Cannot open errno.c"; @@ -102,7 +130,7 @@ sub get_files { $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/'; } else { - $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"'; + $pat = '^#\s*(?:line)?\s*\d+\s+"([^"]+)"'; } while(<CPPO>) { if ($^O eq 'os2' or $^O eq 'MSWin32') { @@ -141,31 +169,33 @@ sub write_errno_pm { close(CPPI); + unless ($^O eq 'MacOS') { # trust what we have # invoke CPP and read the output - if ($^O eq 'VMS') { - my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; - $cpp =~ s/sys\$input//i; - open(CPPO,"$cpp errno.c |") or - die "Cannot exec $Config{cppstdin}"; - } elsif ($^O eq 'MSWin32') { - open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or - die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; - } else { - my $cpp = default_cpp(); - open(CPPO,"$cpp < errno.c |") - or die "Cannot exec $cpp"; - } + if ($^O eq 'VMS') { + my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}"; + $cpp =~ s/sys\$input//i; + open(CPPO,"$cpp errno.c |") or + die "Cannot exec $Config{cppstdin}"; + } elsif ($^O eq 'MSWin32') { + open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or + die "Cannot run '$Config{cpprun} $Config{cppflags} errno.c'"; + } else { + my $cpp = default_cpp(); + open(CPPO,"$cpp < errno.c |") + or die "Cannot exec $cpp"; + } - %err = (); + %err = (); - while(<CPPO>) { - my($name,$expr); - next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; - next if $name eq $expr; - $err{$name} = eval $expr; + while(<CPPO>) { + my($name,$expr); + next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/; + next if $name eq $expr; + $err{$name} = eval $expr; + } + close(CPPO); } - close(CPPO); # Write Errno.pm diff --git a/contrib/perl5/ext/Fcntl/Fcntl.xs b/contrib/perl5/ext/Fcntl/Fcntl.xs index b597e03c1a1b..51851bb6746b 100644 --- a/contrib/perl5/ext/Fcntl/Fcntl.xs +++ b/contrib/perl5/ext/Fcntl/Fcntl.xs @@ -33,13 +33,6 @@ --AD October 16, 1995 */ -static int -not_here(char *s) -{ - croak("%s not implemented on this architecture", s); - return -1; -} - static double constant(char *name, int arg) { diff --git a/contrib/perl5/ext/File/Glob/Changes b/contrib/perl5/ext/File/Glob/Changes index e246c6d6840f..f46ec704e9ad 100644 --- a/contrib/perl5/ext/File/Glob/Changes +++ b/contrib/perl5/ext/File/Glob/Changes @@ -45,3 +45,5 @@ Revision history for Perl extension File::Glob - 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). +0.992 Tue Mar 20 09:25:48 2001 + - Add alphabetic sorting for csh compatibility (GLOB_ALPHASORT) diff --git a/contrib/perl5/ext/File/Glob/Glob.pm b/contrib/perl5/ext/File/Glob/Glob.pm index 4b7e54b9e3ea..20b26f9661f2 100644 --- a/contrib/perl5/ext/File/Glob/Glob.pm +++ b/contrib/perl5/ext/File/Glob/Glob.pm @@ -11,10 +11,15 @@ require AutoLoader; @ISA = qw(Exporter AutoLoader); +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + @EXPORT_OK = qw( csh_glob + bsd_glob glob GLOB_ABEND + GLOB_ALPHASORT GLOB_ALTDIRFUNC GLOB_BRACE GLOB_CSH @@ -33,6 +38,7 @@ require AutoLoader; %EXPORT_TAGS = ( 'glob' => [ qw( GLOB_ABEND + GLOB_ALPHASORT GLOB_ALTDIRFUNC GLOB_BRACE GLOB_CSH @@ -47,6 +53,7 @@ require AutoLoader; GLOB_QUOTE GLOB_TILDE glob + bsd_glob ) ], ); @@ -99,7 +106,13 @@ sub GLOB_ERROR { return constant('GLOB_ERROR', 0); } -sub GLOB_CSH () { GLOB_BRACE() | GLOB_NOMAGIC() | GLOB_QUOTE() | GLOB_TILDE() } +sub GLOB_CSH () { + GLOB_BRACE() + | GLOB_NOMAGIC() + | GLOB_QUOTE() + | GLOB_TILDE() + | GLOB_ALPHASORT() +} $DEFAULT_FLAGS = GLOB_CSH(); if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { @@ -108,12 +121,18 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { # Autoload methods go after =cut, and are processed by the autosplit program. -sub glob { +sub bsd_glob { my ($pat,$flags) = @_; $flags = $DEFAULT_FLAGS if @_ < 2; return doglob($pat,$flags); } +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + goto &bsd_glob; +} + ## borrowed heavily from gsar's File::DosGlob my %iter; my %entries; @@ -127,6 +146,9 @@ sub csh_glob { $pat = $_ unless defined $pat; # extract patterns + $pat =~ s/^\s+//; # Protect against empty elements in + $pat =~ s/\s+$//; # things like < *.c> and <*.c >. + # These alone shouldn't trigger ParseWords. if ($pat =~ /\s/) { # XXX this is needed for compatibility with the csh # implementation in Perl. Need to support a flag @@ -177,13 +199,13 @@ File::Glob - Perl extension for BSD glob routine =head1 SYNOPSIS use File::Glob ':glob'; - @list = glob('*.[ch]'); - $homedir = glob('~gnat', GLOB_TILDE | GLOB_ERR); + @list = bsd_glob('*.[ch]'); + $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); if (GLOB_ERROR) { # an error occurred reading $homedir } - ## override the core glob (core glob() does this automatically + ## 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}> @@ -198,19 +220,27 @@ File::Glob - Perl extension for BSD glob routine =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 +File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is +a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). +bsd_glob() 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: +variable. + +Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). +Note that they don't share the same prototype--CORE::glob() only accepts +a single argument. Due to historical reasons, CORE::glob() will also +split its argument on whitespace, treating it as multiple patterns, +whereas bsd_glob() considers them as one pattern. + +The POSIX defined flags for bsd_glob() 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. +Force bsd_glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily bsd_glob() continues to find matches. =item C<GLOB_MARK> @@ -220,18 +250,18 @@ 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. +makes bsd_glob() treat case differences as not significant. =item C<GLOB_NOCHECK> -If the pattern does not match any pathname, then glob() returns a list +If the pattern does not match any pathname, then bsd_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()). +flag prevents that sorting (speeding up bsd_glob()). =back @@ -266,7 +296,7 @@ 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>. +C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>. =back @@ -275,9 +305,21 @@ 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. +The following flag has been added in the Perl implementation for +compatibility with common flavors of csh: + +=over 4 + +=item C<GLOB_ALPHASORT> + +If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical +order (case does not matter) rather than in ASCII order. + +=back + =head1 DIAGNOSTICS -glob() returns a list of matching paths, possibly zero length. If an +bsd_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: @@ -294,12 +336,12 @@ 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> +In the case where bsd_glob() has found some matching paths, but is +interrupted by an error, it 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 +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will continue processing despite those errors, unless the C<GLOB_ERR> flag is set. @@ -311,10 +353,10 @@ Be aware that all filenames returned from File::Glob are tainted. =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. +If you want to use multiple patterns, e.g. C<bsd_glob "a* b*">, you should +probably throw them in a set as in C<bsd_glob "{a*,b*}">. This is because +the argument to bsd_glob() isn't subjected to parsing by the C shell. +Remember that you can use a backslash to escape things. =item * @@ -334,14 +376,32 @@ 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. +=item * + +Mac OS (Classic) users should note a few differences. Since +Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. +~user/foo) and the C<GLOB_TILDE> flag is used, it simply returns that +pattern without doing any expansion. + +Glob on Mac OS is case-insensitive by default (if you don't use any +flags). If you specify any flags at all and still want glob +to be case-insensitive, you must include C<GLOB_NOCASE> in the flags. + +The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users +should be careful about specifying relative pathnames. While a full path +always begins with a volume name, a relative pathname should always +begin with a ':'. If specifying a volume name only, a trailing ':' is +required. + =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 +made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>, and Thomas Wegner +E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the following copyright: Copyright (c) 1989, 1993 The Regents of the University of California. diff --git a/contrib/perl5/ext/File/Glob/Glob.xs b/contrib/perl5/ext/File/Glob/Glob.xs index e01ae7e85a94..ee8c0c9751fc 100644 --- a/contrib/perl5/ext/File/Glob/Glob.xs +++ b/contrib/perl5/ext/File/Glob/Glob.xs @@ -4,16 +4,9 @@ #include "bsd_glob.h" +/* XXX: need some thread awareness */ 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) { @@ -28,6 +21,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "GLOB_ALPHASORT")) +#ifdef GLOB_ALPHASORT + return GLOB_ALPHASORT; +#else + goto not_there; +#endif if (strEQ(name, "GLOB_ALTDIRFUNC")) #ifdef GLOB_ALTDIRFUNC return GLOB_ALTDIRFUNC; diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.c b/contrib/perl5/ext/File/Glob/bsd_glob.c index 62bfe4f80c8a..15ee659c8584 100644 --- a/contrib/perl5/ext/File/Glob/bsd_glob.c +++ b/contrib/perl5/ext/File/Glob/bsd_glob.c @@ -57,6 +57,9 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; * expand {1,2}{a,b} to 1a 1b 2a 2b * gl_matchc: * Number of matches in the current invocation of glob. + * GLOB_ALPHASORT: + * sort alphabetically like csh (case doesn't matter) instead of in ASCII + * order */ #include <EXTERN.h> @@ -76,8 +79,11 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; #ifndef MAXPATHLEN # ifdef PATH_MAX # define MAXPATHLEN PATH_MAX -# else -# define MAXPATHLEN 1024 +# ifdef MACOS_TRADITIONAL +# define MAXPATHLEN 255 +# else +# define MAXPATHLEN 1024 +# endif # endif #endif @@ -90,7 +96,11 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; #define BG_QUOTE '\\' #define BG_RANGE '-' #define BG_RBRACKET ']' -#define BG_SEP '/' +#ifdef MACOS_TRADITIONAL +# define BG_SEP ':' +#else +# define BG_SEP '/' +#endif #ifdef DOSISH #define BG_SEP2 '\\' #endif @@ -448,6 +458,12 @@ glob0(const Char *pattern, glob_t *pglob) int c, err, oldflags, oldpathc; Char *bufnext, patbuf[MAXPATHLEN+1]; +#ifdef MACOS_TRADITIONAL + if ( (*pattern == BG_TILDE) && (pglob->gl_flags & GLOB_TILDE) ) { + return(globextend(pattern, pglob)); + } +#endif + qpat = globtilde(pattern, patbuf, pglob); qpatnext = qpat; oldflags = pglob->gl_flags; @@ -531,7 +547,8 @@ glob0(const Char *pattern, glob_t *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 & (GLOB_ALPHASORT|GLOB_NOCASE)) + ? ci_compare : compare); pglob->gl_flags = oldflags; return(0); } @@ -541,13 +558,17 @@ ci_compare(const void *p, const void *q) { const char *pp = *(const char **)p; const char *qq = *(const char **)q; + int ci; while (*pp && *qq) { if (tolower(*pp) != tolower(*qq)) break; ++pp; ++qq; } - return (tolower(*pp) - tolower(*qq)); + ci = tolower(*pp) - tolower(*qq); + if (ci == 0) + return compare(p, q); + return ci; } static int @@ -653,7 +674,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, * and dirent.h as taking pointers to differently typed opaque * structures. */ - Direntry_t *(*readdirfunc)(); + Direntry_t *(*readdirfunc)(DIR*); *pathend = BG_EOS; errno = 0; @@ -689,7 +710,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, /* Search directory for matching names. */ if (pglob->gl_flags & GLOB_ALTDIRFUNC) - readdirfunc = pglob->gl_readdir; + readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; else readdirfunc = my_readdir; while ((dp = (*readdirfunc)(dirp))) { @@ -853,10 +874,15 @@ g_opendir(register Char *str, glob_t *pglob) { char buf[MAXPATHLEN]; - if (!*str) + if (!*str) { +#ifdef MACOS_TRADITIONAL + strcpy(buf, ":"); +#else strcpy(buf, "."); - else +#endif + } else { g_Ctoc(str, buf); + } if (pglob->gl_flags & GLOB_ALTDIRFUNC) return((*pglob->gl_opendir)(buf)); diff --git a/contrib/perl5/ext/File/Glob/bsd_glob.h b/contrib/perl5/ext/File/Glob/bsd_glob.h index 10d1de534c64..5d04fff1c341 100644 --- a/contrib/perl5/ext/File/Glob/bsd_glob.h +++ b/contrib/perl5/ext/File/Glob/bsd_glob.h @@ -72,6 +72,7 @@ typedef struct { #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_ALPHASORT 0x2000 /* Alphabetic, not ASCII sort, like csh. */ #define GLOB_NOSPACE (-1) /* Malloc call failed. */ #define GLOB_ABEND (-2) /* Unignored error. */ diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm index ab866eecabed..310243c736e8 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.pm +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.pm @@ -40,6 +40,7 @@ L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. package GDBM_File; use strict; +use warnings; our($VERSION, @ISA, @EXPORT, $AUTOLOAD); require Carp; @@ -53,13 +54,14 @@ use XSLoader (); GDBM_FAST GDBM_INSERT GDBM_NEWDB + GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER ); -$VERSION = "1.03"; +$VERSION = "1.05"; sub AUTOLOAD { my($constname); diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs index 870f056c9bf0..5e426f90f32d 100644 --- a/contrib/perl5/ext/GDBM_File/GDBM_File.xs +++ b/contrib/perl5/ext/GDBM_File/GDBM_File.xs @@ -42,12 +42,14 @@ typedef datum datum_value ; typedef void (*FATALFUNC)(); +#ifndef GDBM_FAST static int not_here(char *s) { croak("GDBM_File::%s not implemented on this architecture", s); return -1; } +#endif /* GDBM allocates the datum with system malloc() and expects the user * to free() it. So we either have to free() it immediately, or have @@ -56,7 +58,7 @@ not_here(char *s) static void output_datum(pTHX_ SV *arg, char *str, int size) { -#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC)) +#if !defined(MYMALLOC) || (defined(MYMALLOC) && defined(PERL_POLLUTE_MALLOC) && !defined(LEAKTEST)) sv_usepvn(arg, str, size); #else sv_setpvn(arg, str, size); @@ -122,6 +124,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "GDBM_NOLOCK")) +#ifdef GDBM_NOLOCK + return GDBM_NOLOCK; +#else + goto not_there; +#endif if (strEQ(name, "GDBM_READER")) #ifdef GDBM_READER return GDBM_READER; @@ -214,7 +222,7 @@ gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak) GDBM_FILE dbp ; RETVAL = NULL ; - if (dbp = gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)) { + 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 ; diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap index 4f79ae3e32a5..1dd063003ab6 100644 --- a/contrib/perl5/ext/GDBM_File/typemap +++ b/contrib/perl5/ext/GDBM_File/typemap @@ -19,8 +19,14 @@ T_DATUM_K $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; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } OUTPUT T_DATUM_K output_datum(aTHX_ $arg, $var.dptr, $var.dsize); diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs index 1b79cfd4c093..38acf4114843 100644 --- a/contrib/perl5/ext/IO/IO.xs +++ b/contrib/perl5/ext/IO/IO.xs @@ -136,18 +136,23 @@ io_blocking(InputStream f, int block) MODULE = IO PACKAGE = IO::Seekable PREFIX = f -SV * +void fgetpos(handle) InputStream handle CODE: if (handle) { Fpos_t pos; + if ( #ifdef PerlIO - PerlIO_getpos(handle, &pos); + PerlIO_getpos(handle, &pos) #else - fgetpos(handle, &pos); + fgetpos(handle, &pos) #endif - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + ) { + ST(0) = &PL_sv_undef; + } else { + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } } else { ST(0) = &PL_sv_undef; @@ -176,7 +181,7 @@ fsetpos(handle, pos) MODULE = IO PACKAGE = IO::File PREFIX = f -SV * +void new_tmpfile(packname = "IO::File") char * packname PREINIT: diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm index 930df55fec8b..fb754a60bfae 100644 --- a/contrib/perl5/ext/IO/lib/IO/Handle.pm +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -71,7 +71,7 @@ corresponding built-in functions: $io->printf ( FMT, [ARGS] ) $io->stat $io->sysread ( BUF, LEN, [OFFSET] ) - $io->syswrite ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, [LEN, [OFFSET]] ) $io->truncate ( LEN ) See L<perlvar> for complete descriptions of each of the following @@ -110,18 +110,19 @@ or a file descriptor number. =item $io->opened -Returns true if the object is currently a valid file descriptor. +Returns true if the object is currently a valid file descriptor, false +otherwise. =item $io->getline 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. +except that it's more readable and can be safely called in a +list context but still returns just one line. =item $io->getlines -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. +This works like <$io> when called in a list 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 $io->ungetc ( ORD ) @@ -139,31 +140,37 @@ called C<format_write>. =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>. +since it was opened or since the last call to C<clearerr>, or if the +handle is invalid. It only returns false for a valid handle with no +outstanding errors. =item $io->clearerr -Clear the given handle's error indicator. +Clear the given handle's error indicator. Returns -1 if the handle is +invalid, 0 otherwise. =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)>. +operates on the file descriptor (similar to sysread, sysseek and +systell). 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. Returns "0 but true" on success, C<undef> on error, C<undef> +for an invalid handle. 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. +will be written to the underlying file descriptor. Returns "0 but true" +on success, C<undef> on error. =item $io->printflush ( ARGS ) Turns on autoflush, print ARGS and then restores the autoflush status of the -C<IO::Handle> object. +C<IO::Handle> object. Returns the return value from print. =item $io->blocking ( [ BOOL ] ) @@ -183,11 +190,18 @@ C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering policy for an IO::Handle. The calling sequences for the Perl functions are the same as their C counterparts--including the constants C<_IOFBF>, 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 -the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. +specifies a scalar variable to use as a buffer. You should only +change the buffer before any I/O, or immediately after calling flush. + +WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<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! Remember that +the order of global destruction is undefined, so even if your buffer +variable remains in scope until program termination, it may be undefined +before the file IO::Handle is closed. Note that you need to import the +constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf +returns nothing. setvbuf returns "0 but true", on success, C<undef> on +failure. Lastly, there is a special method for working under B<-T> and setuid/gid scripts: @@ -199,7 +213,8 @@ scripts: 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 take, and appropriate consideration for the data source and potential -vulnerability should be kept in mind. +vulnerability should be kept in mind. Returns 0 on success, -1 if setting +the taint-clean flag failed. (eg invalid handle) =back @@ -425,8 +440,11 @@ sub write { sub syswrite { @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; - $_[2] = length($_[1]) unless defined $_[2]; - syswrite($_[0], $_[1], $_[2], $_[3] || 0); + if (defined($_[2])) { + syswrite($_[0], $_[1], $_[2], $_[3] || 0); + } else { + syswrite($_[0], $_[1]); + } } sub stat { diff --git a/contrib/perl5/ext/IO/lib/IO/Poll.pm b/contrib/perl5/ext/IO/lib/IO/Poll.pm index 687664b9abfa..70a3469edbb2 100644 --- a/contrib/perl5/ext/IO/lib/IO/Poll.pm +++ b/contrib/perl5/ext/IO/lib/IO/Poll.pm @@ -1,3 +1,4 @@ + # IO::Poll.pm # # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. @@ -12,28 +13,31 @@ use Exporter (); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.01"; +$VERSION = "0.05"; -@EXPORT = qw(poll); +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); @EXPORT_OK = qw( - POLLIN POLLPRI - POLLOUT POLLRDNORM POLLWRNORM POLLRDBAND POLLWRBAND POLLNORM - POLLERR - POLLHUP - POLLNVAL -); + ); +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles sub new { my $class = shift; - my $self = bless [{},{}], $class; + my $self = bless [{},{},{}], $class; $self; } @@ -42,20 +46,21 @@ sub mask { my $self = shift; my $io = shift; my $fd = fileno($io); - if(@_) { + if (@_) { my $mask = shift; - $self->[0]{$fd} ||= {}; if($mask) { - $self->[0]{$fd}{$io} = $mask; - } - else { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { delete $self->[0]{$fd}{$io}; + delete $self->[1]{$fd} unless %{$self->[0]{$fd}}; + delete $self->[2]{$io}; } } - elsif(exists $self->[0]{$fd}{$io}) { + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; return $self->[0]{$fd}{$io}; - } - return; } @@ -64,13 +69,13 @@ sub poll { $self->[1] = {}; - my($fd,$ref); + my($fd,$mask,$iom); my @poll = (); - while(($fd,$ref) = each %{$self->[0]}) { - my $events = 0; - map { $events |= $_ } values %{$ref}; - push(@poll,$fd, $events); + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); } my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; @@ -80,8 +85,7 @@ sub poll { while(@poll) { my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got - if $got; + $self->[1]{$fd} = $got if $got; } return $ret; @@ -91,9 +95,8 @@ 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} + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) : 0; } @@ -105,20 +108,16 @@ sub remove { sub handles { my $self = shift; - - return map { keys %$_ } values %{$self->[0]} - unless(@_); + return values %{$self->[2]} 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; - } + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; } } return @handles; @@ -138,8 +137,8 @@ IO::Poll - Object interface to system poll call $poll = new IO::Poll; - $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); - $poll->mask($output_handle => POLLWRNORM); + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); $poll->poll($timeout); diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm index e09d48b9bff8..243a971acccc 100644 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -18,19 +18,69 @@ C<IO::Seekable> does not have a constructor of its own as it is intended to 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-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. +=over 4 +=item $io->getpos + +Returns an opaque value that represents the current position of the +IO::File, or C<undef> if this is not possible (eg an unseekable stream such +as a terminal, pipe or socket). If the fgetpos() function is available in +your C library it is used to implements getpos, else perl emulates getpos +using C's ftell() function. + +=item $io->setpos + +Uses the value of a previous getpos call to return to a previously visited +position. Returns "0 but true" on success, C<undef> on failure. + +=back + 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: - $io->seek( POS, WHENCE ) - $io->sysseek( POS, WHENCE ) - $io->tell +=over 4 + +=item $io->setpos ( POS, WHENCE ) + +Seek the IO::File to position POS, relative to WHENCE: + +=over 8 + +=item WHENCE=0 (SEEK_SET) + +POS is absolute position. (Seek relative to the start of the file) + +=item WHENCE=1 (SEEK_CUR) + +POS is an offset from the current position. (Seek relative to current) + +=item WHENCE=1 (SEEK_END) + +POS is an offset from the end of the file. (Seek relative to end) + +=back + +The SEEK_* constants can be imported from the C<Fcntl> module if you +don't wish to use the numbers C<0> C<1> or C<2> in your code. + +Returns C<1> upon success, C<0> otherwise. + +=item $io->sysseek( POS, WHENCE ) + +Similar to $io->seek, but sets the IO::File's position using the system +call lseek(2) directly, so will confuse most perl IO operators except +sysread and syswrite (see L<perlfunc> for full details) + +Returns the new position, or C<undef> on failure. A position +of zero is returned as the string C<"0 but true"> + +=item $io->tell + +Returns the IO::File's current position, or -1 on error. +=back + =head1 SEE ALSO L<perlfunc>, diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm index df92b04b74f3..1a3a26fe6ae3 100644 --- a/contrib/perl5/ext/IO/lib/IO/Select.pm +++ b/contrib/perl5/ext/IO/lib/IO/Select.pm @@ -56,6 +56,7 @@ sub exists sub _fileno { my($self, $f) = @_; + return unless defined $f; $f = $f->[0] if ref($f) eq 'ARRAY'; ($f =~ /^\d+$/) ? $f : fileno($f); } @@ -300,9 +301,9 @@ 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. +the maximum amount of time to wait before returning an empty list, in +seconds, possibly fractional. If C<TIMEOUT> is not given and any +handles are registered then the call will block. =item can_write ( [ TIMEOUT ] ) diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm index 6884f02cf868..b8da0926692d 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -361,7 +361,7 @@ 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 +or undef upon failure. In a list context a two-element array is returned containing the new socket and the peer address; the list will be empty upon failure. diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm index 27a3d4d847ee..d2cc488dd2d8 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm @@ -34,6 +34,7 @@ sub new { sub _sock_info { my($addr,$port,$proto) = @_; + my $origport = $port; my @proto = (); my @serv = (); @@ -59,14 +60,14 @@ sub _sock_info { my $defport = $1 || undef; my $pnum = ($port =~ m,^(\d+)$,)[0]; - if ($port =~ m,\D,) { - unless (@serv = getservbyname($port, $proto[0] || "")) { - $@ = "Bad service '$port'"; - return; - } - } + @serv = getservbyname($port, $proto[0] || "") + if ($port =~ m,\D,); $port = $pnum || $serv[2] || $defport || undef; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } $proto = (getprotobyname($serv[3]))[2] || undef if @serv && !$proto; @@ -150,11 +151,16 @@ sub configure { $sock->socket(AF_INET, $type, $proto) or return _error($sock, $!, "$!"); - if ($arg->{Reuse}) { + if ($arg->{Reuse} || $arg->{ReuseAddr}) { $sock->sockopt(SO_REUSEADDR,1) or return _error($sock, $!, "$!"); } + if ($arg->{ReusePort}) { + $sock->sockopt(SO_REUSEPORT,1) or + return _error($sock, $!, "$!"); + } + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { $sock->bind($lport || 0, $laddr) or return _error($sock, $!, "$!"); @@ -301,7 +307,9 @@ C<IO::Socket::INET> provides. 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 + ReuseAddr Set SO_REUSEADDR before binding + Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr) + ReusePort Set SO_REUSEPORT before binding Timeout Timeout value for various operations MultiHomed Try all adresses for multi-homed hosts diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm index d083f48b78f7..2a11752d027a 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm @@ -37,7 +37,7 @@ sub configure { $sock->bind($addr) or return undef; } - if(exists $arg->{Listen}) { + if(exists $arg->{Listen} && $type != SOCK_DGRAM) { $sock->listen($arg->{Listen} || 5) or return undef; } diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL index 60dd74d9a9c4..f994950d195a 100644 --- a/contrib/perl5/ext/IPC/SysV/Makefile.PL +++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL @@ -31,7 +31,7 @@ WriteMakefile( 'clean' => {FILES => join(" ", map { "$_ */$_ */*/$_" } - qw(*% *.html *.b[ac]k *.old *.orig)) + qw(*% *.html *.b[ac]k *.old)) }, 'macro' => { INSTALLDIRS => 'perl' }, ); diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs index 38062e028b5e..c7985f99fe3e 100644 --- a/contrib/perl5/ext/IPC/SysV/SysV.xs +++ b/contrib/perl5/ext/IPC/SysV/SysV.xs @@ -194,7 +194,7 @@ PPCODE: MODULE=IPC::SysV PACKAGE=IPC::SysV -int +void ftok(path, id) char * path int id @@ -203,10 +203,10 @@ ftok(path, id) key_t k = ftok(path, id); ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k)); #else - DIE(PL_no_func, "ftok"); + DIE(aTHX_ PL_no_func, "ftok"); #endif -int +void SHMLBA() CODE: #ifdef SHMLBA @@ -436,7 +436,7 @@ BOOT: char *name; int i; - for(i = 0 ; name = IPC__SysV__const[i].n ; i++) { + for(i = 0 ; (name = IPC__SysV__const[i].n) ; i++) { newCONSTSUB(stash,name, newSViv(IPC__SysV__const[i].v)); } } diff --git a/contrib/perl5/ext/NDBM_File/Makefile.PL b/contrib/perl5/ext/NDBM_File/Makefile.PL index 6ceab55a4aed..7b586017d7d4 100644 --- a/contrib/perl5/ext/NDBM_File/Makefile.PL +++ b/contrib/perl5/ext/NDBM_File/Makefile.PL @@ -5,4 +5,5 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.pm b/contrib/perl5/ext/NDBM_File/NDBM_File.pm index f98669f4860d..b2804597a14e 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.pm +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.pm @@ -1,16 +1,13 @@ package NDBM_File; -BEGIN { - if ($] >= 5.002) { - use strict; - } -} +use strict; +use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.03"; +our $VERSION = "1.04"; XSLoader::load 'NDBM_File', $VERSION; @@ -24,15 +21,93 @@ NDBM_File - Tied access to ndbm files =head1 SYNOPSIS - use NDBM_File; - use Fcntl; # for O_ constants + use Fcntl; # For O_RDWR, O_CREAT, etc. + use NDBM_File; - tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... + + untie %h; + +=head1 DESCRIPTION + +C<NDBM_File> establishes a connection between a Perl hash variable and +a file in NDBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. - untie %h; +Use C<NDBM_File> with the Perl built-in C<tie> function to establish +the connection between the variable and the file. The arguments to +C<tie> should be: -=head1 DESCRIPTION +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"NDBM_File">. (Ths tells Perl to use the C<NDBM_File> +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C<O_RDONLY> + +Read-only access to the data in the file. + +=item C<O_WRONLY> + +Write-only access to the data in the file. + +=item C<O_RDWR> + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C<O_CREAT> to +any of these, as in the example. If you omit C<O_CREAT> and the file +does not already exist, the C<tie> call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L<perlfunc/umask>.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C<tie> call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C<ndbm store returned -1, errno 22, key "..." at ...> + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the NDBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. -See L<perlfunc/tie>, L<perldbmfilter> +See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> =cut diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.xs b/contrib/perl5/ext/NDBM_File/NDBM_File.xs index 49a1db5e5657..c417eb693e92 100644 --- a/contrib/perl5/ext/NDBM_File/NDBM_File.xs +++ b/contrib/perl5/ext/NDBM_File/NDBM_File.xs @@ -1,6 +1,11 @@ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" +/* If using the DB3 emulation, ENTER is defined both + * by DB3 and Perl. We drop the Perl definition now. + * See also INSTALL section on DB3. + * -- Stanislav Brabec <utx@penguin.cz> */ +#undef ENTER #include <ndbm.h> typedef struct { diff --git a/contrib/perl5/ext/NDBM_File/typemap b/contrib/perl5/ext/NDBM_File/typemap index eeb5d59027f5..40b95f22c022 100644 --- a/contrib/perl5/ext/NDBM_File/typemap +++ b/contrib/perl5/ext/NDBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $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; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.pm b/contrib/perl5/ext/ODBM_File/ODBM_File.pm index 57fe4c352ddd..9e8e008e0243 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.pm +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.pm @@ -1,12 +1,13 @@ package ODBM_File; use strict; +use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02"; +our $VERSION = "1.03"; XSLoader::load 'ODBM_File', $VERSION; @@ -20,14 +21,93 @@ ODBM_File - Tied access to odbm files =head1 SYNOPSIS + use Fcntl; # For O_RDWR, O_CREAT, etc. use ODBM_File; - tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... + + untie %h; + +=head1 DESCRIPTION + +C<ODBM_File> establishes a connection between a Perl hash variable and +a file in ODBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. - untie %h; +Use C<ODBM_File> with the Perl built-in C<tie> function to establish +the connection between the variable and the file. The arguments to +C<tie> should be: -=head1 DESCRIPTION +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"ODBM_File">. (Ths tells Perl to use the C<ODBM_File> +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C<O_RDONLY> + +Read-only access to the data in the file. + +=item C<O_WRONLY> + +Write-only access to the data in the file. + +=item C<O_RDWR> + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C<O_CREAT> to +any of these, as in the example. If you omit C<O_CREAT> and the file +does not already exist, the C<tie> call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L<perlfunc/umask>.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C<tie> call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C<odbm store returned -1, errno 22, key "..." at ...> + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the ODBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. -See L<perlfunc/tie>, L<perldbmfilter> +See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> =cut diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.xs b/contrib/perl5/ext/ODBM_File/ODBM_File.xs index 150f2ef89475..27174ef062b7 100644 --- a/contrib/perl5/ext/ODBM_File/ODBM_File.xs +++ b/contrib/perl5/ext/ODBM_File/ODBM_File.xs @@ -3,6 +3,11 @@ #include "XSUB.h" #ifdef I_DBM +/* If using the DB3 emulation, ENTER is defined both + * by DB3 and Perl. We drop the Perl definition now. + * See also INSTALL section on DB3. + * -- Stanislav Brabec <utx@penguin.cz> */ +# undef ENTER # include <dbm.h> #else # ifdef I_RPCSVC_DBM diff --git a/contrib/perl5/ext/ODBM_File/typemap b/contrib/perl5/ext/ODBM_File/typemap index 7c23815ec75a..096427ea7f3a 100644 --- a/contrib/perl5/ext/ODBM_File/typemap +++ b/contrib/perl5/ext/ODBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $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; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/contrib/perl5/ext/Opcode/Opcode.pm b/contrib/perl5/ext/Opcode/Opcode.pm index 9338d392fae2..841120c4c63d 100644 --- a/contrib/perl5/ext/Opcode/Opcode.pm +++ b/contrib/perl5/ext/Opcode/Opcode.pm @@ -163,7 +163,7 @@ accumulated set of ops at that point. =item an operator set (opset) -An I<opset> as a binary string of approximately 43 bytes which holds a +An I<opset> as a binary string of approximately 44 bytes which holds a set or zero or more operators. The opset and opset_to_ops functions can be used to convert from @@ -185,7 +185,7 @@ tags and sets. All are available for export by the package. =item opcodes In a scalar context opcodes returns the number of opcodes in this -version of perl (around 340 for perl5.002). +version of perl (around 350 for perl-5.7.0). In a list context it returns a list of all the operator names. (Not yet implemented, use @names = opset_to_ops(full_opset).) diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs index 581cbc94d939..cc4e1f45e17a 100644 --- a/contrib/perl5/ext/Opcode/Opcode.xs +++ b/contrib/perl5/ext/Opcode/Opcode.xs @@ -250,7 +250,7 @@ PPCODE: save_aptr(&PL_endav); PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ - save_hptr(&PL_defstash); /* save current default stack */ + save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ save_hptr(&PL_curstash); @@ -263,6 +263,11 @@ PPCODE: sv_free((SV*)GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); + /* %INC must be clean for use/require in compartment */ + save_hash(PL_incgv); + sv_free((SV*)GvHV(PL_incgv)); /* get rid of what save_hash gave us*/ + GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); + PUSHMARK(SP); perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ SPAGAIN; /* for the PUTBACK added by xsubpp */ @@ -320,7 +325,7 @@ PPCODE: void opset(...) CODE: - int i, j; + int i; SV *bitspec, *opset; char *bitmap; STRLEN len, on; diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL index 55c5c1fbf3f6..73bb02dddb54 100644 --- a/contrib/perl5/ext/POSIX/Makefile.PL +++ b/contrib/perl5/ext/POSIX/Makefile.PL @@ -2,12 +2,7 @@ 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"]); - } + @libs = ('LIBS' => ["-lm -lposix -lcposix"]); } WriteMakefile( NAME => 'POSIX', diff --git a/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm index 9416f70809ab..252e5bbad1cf 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pm +++ b/contrib/perl5/ext/POSIX/POSIX.pm @@ -565,9 +565,9 @@ sub chmod { sub fstat { usage "fstat(fd)" if @_ != 1; local *TMP; - open(TMP, "<&$_[0]"); # Gross. + CORE::open(TMP, "<&$_[0]"); # Gross. my @l = CORE::stat(TMP); - close(TMP); + CORE::close(TMP); @l; } @@ -893,7 +893,7 @@ sub load_imports { 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 + STDERR_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 diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod index 08300e4337b6..49761358ca20 100644 --- a/contrib/perl5/ext/POSIX/POSIX.pod +++ b/contrib/perl5/ext/POSIX/POSIX.pod @@ -65,15 +65,19 @@ all. This could be construed to be a bug. =item _exit -This is identical to the C function C<_exit()>. +This is identical to the C function C<_exit()>. It exits the program +immediately which means among other things buffered I/O is B<not> flushed. =item abort -This is identical to the C function C<abort()>. +This is identical to the C function C<abort()>. It terminates the +process with a C<SIGABRT> signal unless caught by a signal handler or +if the handler does not return normally (it e.g. does a C<longjmp>). =item abs -This is identical to Perl's builtin C<abs()> function. +This is identical to Perl's builtin C<abs()> function, returning +the absolute value of its numerical argument. =item access @@ -83,83 +87,117 @@ Determines the accessibility of a file. print "have read permission\n"; } -Returns C<undef> on failure. +Returns C<undef> on failure. Note: do not use C<access()> for +security purposes. Between the C<access()> call and the operation +you are preparing for the permissions might change: a classic +I<race condition>. =item acos -This is identical to the C function C<acos()>. +This is identical to the C function C<acos()>, returning +the arcus cosine of its numerical argument. See also L<Math::Trig>. =item alarm -This is identical to Perl's builtin C<alarm()> function. +This is identical to Perl's builtin C<alarm()> function, +either for arming or disarming the C<SIGARLM> timer. =item asctime -This is identical to the C function C<asctime()>. +This is identical to the C function C<asctime()>. It returns +a string of the form + + "Fri Jun 2 18:22:13 2000\n\0" + +and it is called thusly + + $asctime = asctime($sec, $min, $hour, $mday, $mon, $year, + $wday, $yday, $isdst); + +The C<$mon> is zero-based: January equals C<0>. The C<$year> is +1900-based: 2001 equals C<101>. The C<$wday>, C<$yday>, and C<$isdst> +default to zero (and the first two are usually ignored anyway). =item asin -This is identical to the C function C<asin()>. +This is identical to the C function C<asin()>, returning +the arcus sine of its numerical argument. See also L<Math::Trig>. =item assert -Unimplemented. +Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module +to achieve similar things. =item atan -This is identical to the C function C<atan()>. +This is identical to the C function C<atan()>, returning the +arcus tangent of its numerical argument. See also L<Math::Trig>. =item atan2 -This is identical to Perl's builtin C<atan2()> function. +This is identical to Perl's builtin C<atan2()> function, returning +the arcus tangent defined by its two numerical arguments, the I<y> +coordinate and the I<x> coordinate. See also L<Math::Trig>. =item atexit -atexit() is C-specific: use END {} instead. +atexit() is C-specific: use C<END {}> instead, see L<perlsub>. =item atof -atof() is C-specific. +atof() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. =item atoi -atoi() is C-specific. +atoi() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. +If you need to have just the integer part, see L<perlfunc/int>. =item atol -atol() is C-specific. +atol() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. +If you need to have just the integer part, see L<perlfunc/int>. =item bsearch -bsearch() not supplied. +bsearch() not supplied. For doing binary search on wordlists, +see L<Search::Dict>. =item calloc -calloc() is C-specific. +calloc() is C-specific. Perl does memory management transparently. =item ceil -This is identical to the C function C<ceil()>. +This is identical to the C function C<ceil()>, returning the smallest +integer value greater than or equal to the given numerical argument. =item chdir -This is identical to Perl's builtin C<chdir()> function. +This is identical to Perl's builtin C<chdir()> function, allowing +one to change the working (default) directory, see L<perlfunc/chdir>. =item chmod -This is identical to Perl's builtin C<chmod()> function. +This is identical to Perl's builtin C<chmod()> function, allowing +one to change file and directory permissions, see L<perlfunc/chmod>. =item chown -This is identical to Perl's builtin C<chown()> function. +This is identical to Perl's builtin C<chown()> function, allowing one +to change file and directory owners and groups, see L<perlfunc/chown>. =item clearerr -Use method C<IO::Handle::clearerr()> instead. +Use the method L<IO::Handle::clearerr()> instead, to reset the error +state (if any) and EOF state (if any) of the given stream. =item clock -This is identical to the C function C<clock()>. +This is identical to the C function C<clock()>, returning the +amount of spent processor time in microseconds. =item close @@ -171,17 +209,23 @@ C<POSIX::open>. Returns C<undef> on failure. +See also L<perlfunc/close>. + =item closedir -This is identical to Perl's builtin C<closedir()> function. +This is identical to Perl's builtin C<closedir()> function for closing +a directory handle, see L<perlfunc/closedir>. =item cos -This is identical to Perl's builtin C<cos()> function. +This is identical to Perl's builtin C<cos()> function, for returning +the cosine of its numerical argument, see L<perlfunc/cos>. +See also L<Math::Trig>. =item cosh -This is identical to the C function C<cosh()>. +This is identical to the C function C<cosh()>, for returning +the hyperbolic cosine of its numeric argument. See also L<Math::Trig>. =item creat @@ -191,6 +235,8 @@ C<POSIX::open>. Use C<POSIX::close> to close the file. $fd = POSIX::creat( "foo", 0611 ); POSIX::close( $fd ); +See also L<perlfunc/sysopen> and its C<O_CREAT> flag. + =item ctermid Generates the path name for the controlling terminal. @@ -199,25 +245,30 @@ Generates the path name for the controlling terminal. =item ctime -This is identical to the C function C<ctime()>. +This is identical to the C function C<ctime()> and equivalent +to C<asctime(localtime(...))>, see L</asctime> and L</localtime>. =item cuserid -Get the character login name of the user. +Get the login name of the owner of the current process. $name = POSIX::cuserid(); =item difftime -This is identical to the C function C<difftime()>. +This is identical to the C function C<difftime()>, for returning +the time difference (in seconds) between two times (as returned +by C<time()>), see L</time>. =item div -div() is C-specific. +div() is C-specific, use L<perlfunc/int> on the usual C</> division and +the modulus C<%>. =item dup -This is similar to the C function C<dup()>. +This is similar to the C function C<dup()>, for duplicating a file +descriptor. This uses file descriptors such as those obtained by calling C<POSIX::open>. @@ -226,7 +277,8 @@ Returns C<undef> on failure. =item dup2 -This is similar to the C function C<dup2()>. +This is similar to the C function C<dup2()>, for duplicating a file +descriptor to an another known file descriptor. This uses file descriptors such as those obtained by calling C<POSIX::open>. @@ -239,57 +291,64 @@ Returns the value of errno. $errno = POSIX::errno(); +This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>. + =item execl -execl() is C-specific. +execl() is C-specific, see L<perlfunc/exec>. =item execle -execle() is C-specific. +execle() is C-specific, see L<perlfunc/exec>. =item execlp -execlp() is C-specific. +execlp() is C-specific, see L<perlfunc/exec>. =item execv -execv() is C-specific. +execv() is C-specific, see L<perlfunc/exec>. =item execve -execve() is C-specific. +execve() is C-specific, see L<perlfunc/exec>. =item execvp -execvp() is C-specific. +execvp() is C-specific, see L<perlfunc/exec>. =item exit -This is identical to Perl's builtin C<exit()> function. +This is identical to Perl's builtin C<exit()> function for exiting the +program, see L<perlfunc/exit>. =item exp -This is identical to Perl's builtin C<exp()> function. +This is identical to Perl's builtin C<exp()> function for +returning the exponent (I<e>-based) of the numerical argument, +see L<perlfunc/exp>. =item fabs -This is identical to Perl's builtin C<abs()> function. +This is identical to Perl's builtin C<abs()> function for returning +the absolute value of the numerical argument, see L<perlfunc/abs>. =item fclose -Use method C<IO::Handle::close()> instead. +Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>. =item fcntl -This is identical to Perl's builtin C<fcntl()> function. +This is identical to Perl's builtin C<fcntl()> function, +see L<perlfunc/fcntl>. =item fdopen -Use method C<IO::Handle::new_from_fd()> instead. +Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>. =item feof -Use method C<IO::Handle::eof()> instead. +Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>. =item ferror @@ -298,38 +357,49 @@ Use method C<IO::Handle::error()> instead. =item fflush Use method C<IO::Handle::flush()> instead. +See also L<perlvar/$OUTPUT_AUTOFLUSH>. =item fgetc -Use method C<IO::Handle::getc()> instead. +Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>. =item fgetpos -Use method C<IO::Seekable::getpos()> instead. +Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>. =item fgets -Use method C<IO::Handle::gets()> instead. +Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known +as L<perlfunc/readline>. =item fileno -Use method C<IO::Handle::fileno()> instead. +Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>. =item floor -This is identical to the C function C<floor()>. +This is identical to the C function C<floor()>, returning the largest +integer value less than or equal to the numerical argument. =item fmod This is identical to the C function C<fmod()>. + $r = modf($x, $y); + +It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>. +The C<$r> has the same sign as C<$x> and magnitude (absolute value) +less than the magnitude of C<$y>. + =item fopen -Use method C<IO::File::open()> instead. +Use method C<IO::File::open()> instead, or see L<perlfunc/open>. =item fork -This is identical to Perl's builtin C<fork()> function. +This is identical to Perl's builtin C<fork()> function +for duplicating the current process, see L<perlfunc/fork> +and L<perlfork> if you are in Windows. =item fpathconf @@ -346,45 +416,45 @@ Returns C<undef> on failure. =item fprintf -fprintf() is C-specific--use printf instead. +fprintf() is C-specific, see L<perlfunc/printf> instead. =item fputc -fputc() is C-specific--use print instead. +fputc() is C-specific, see L<perlfunc/print> instead. =item fputs -fputs() is C-specific--use print instead. +fputs() is C-specific, see L<perlfunc/print> instead. =item fread -fread() is C-specific--use read instead. +fread() is C-specific, see L<perlfunc/read> instead. =item free -free() is C-specific. +free() is C-specific. Perl does memory management transparently. =item freopen -freopen() is C-specific--use open instead. +freopen() is C-specific, see L<perlfunc/open> instead. =item frexp Return the mantissa and exponent of a floating-point number. - ($mantissa, $exponent) = POSIX::frexp( 3.14 ); + ($mantissa, $exponent) = POSIX::frexp( 1.234e56 ); =item fscanf -fscanf() is C-specific--use <> and regular expressions instead. +fscanf() is C-specific, use E<lt>E<gt> and regular expressions instead. =item fseek -Use method C<IO::Seekable::seek()> instead. +Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>. =item fsetpos -Use method C<IO::Seekable::setpos()> instead. +Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>. =item fstat @@ -397,174 +467,221 @@ Perl's builtin C<stat> function. =item ftell -Use method C<IO::Seekable::tell()> instead. +Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>. =item fwrite -fwrite() is C-specific--use print instead. +fwrite() is C-specific, see L<perlfunc/print> instead. =item getc -This is identical to Perl's builtin C<getc()> function. +This is identical to Perl's builtin C<getc()> function, +see L<perlfunc/getc>. =item getchar -Returns one character from STDIN. +Returns one character from STDIN. Identical to Perl's C<getc()>, +see L<perlfunc/getc>. =item getcwd Returns the name of the current working directory. +See also L<Cwd>. =item getegid -Returns the effective group id. +Returns the effective group identifier. Similar to Perl' s builtin +variable C<$(>, see L<perlvar/$EGID>. =item getenv Returns the value of the specified enironment variable. +The same information is available through the C<%ENV> array. =item geteuid -Returns the effective user id. +Returns the effective user identifier. Identical to Perl's builtin C<$E<gt>> +variable, see L<perlvar/$EUID>. =item getgid -Returns the user's real group id. +Returns the user's real group identifier. Similar to Perl's builtin +variable C<$)>, see L<perlvar/$GID>. =item getgrgid -This is identical to Perl's builtin C<getgrgid()> function. +This is identical to Perl's builtin C<getgrgid()> function for +returning group entries by group identifiers, see +L<perlfunc/getgrgid>. =item getgrnam -This is identical to Perl's builtin C<getgrnam()> function. +This is identical to Perl's builtin C<getgrnam()> function for +returning group entries by group names, see L<perlfunc/getgrnam>. =item getgroups -Returns the ids of the user's supplementary groups. +Returns the ids of the user's supplementary groups. Similar to Perl's +builtin variable C<$)>, see L<perlvar/$GID>. =item getlogin -This is identical to Perl's builtin C<getlogin()> function. +This is identical to Perl's builtin C<getlogin()> function for +returning the user name associated with the current session, see +L<perlfunc/getlogin>. =item getpgrp -This is identical to Perl's builtin C<getpgrp()> function. +This is identical to Perl's builtin C<getpgrp()> function for +returning the prcess group identifier of the current process, see +L<perlfunc/getpgrp>. =item getpid -Returns the process's id. +Returns the process identifier. Identical to Perl's builtin +variable C<$$>, see L<perlvar/$PID>. =item getppid -This is identical to Perl's builtin C<getppid()> function. +This is identical to Perl's builtin C<getppid()> function for +returning the process identifier of the parent process of the current +process , see L<perlfunc/getppid>. =item getpwnam -This is identical to Perl's builtin C<getpwnam()> function. +This is identical to Perl's builtin C<getpwnam()> function for +returning user entries by user names, see L<perlfunc/getpwnam>. =item getpwuid -This is identical to Perl's builtin C<getpwuid()> function. +This is identical to Perl's builtin C<getpwuid()> function for +returning user entries by user identifiers, see L<perlfunc/getpwuid>. =item gets -Returns one line from STDIN. +Returns one line from C<STDIN>, similar to E<lt>E<gt>, also known +as the C<readline()> function, see L<perlfunc/readline>. + +B<NOTE>: if you have C programs that still use C<gets()>, be very +afraid. The C<gets()> function is a source of endless grief because +it has no buffer overrun checks. It should B<never> be used. The +C<fgets()> function should be preferred instead. =item getuid -Returns the user's id. +Returns the user's identifier. Identical to Perl's builtin C<$E<lt>> variable, +see L<perlvar/$UID>. =item gmtime -This is identical to Perl's builtin C<gmtime()> function. +This is identical to Perl's builtin C<gmtime()> function for +converting seconds since the epoch to a date in Greenwich Mean Time, +see L<perlfunc/gmtime>. =item isalnum This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isalnum:]]/> construct instead, or possibly the C</\w/> construct. =item isalpha This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isalpha:]]/> construct instead. =item isatty Returns a boolean indicating whether the specified filehandle is connected -to a tty. +to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>. =item iscntrl This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:iscntrl:]]/> construct instead. =item isdigit This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isdigit:]]/> construct instead, or the C</\d/> construct. =item isgraph This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isgraph:]]/> construct instead. =item islower This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:islower:]]/> construct instead. Do B<not> use C</a-z/>. =item isprint This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isprint:]]/> construct instead. =item ispunct This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:ispunct:]]/> construct instead. =item isspace This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isspace:]]/> construct instead, or the C</\s/> construct. =item isupper This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isupper:]]/> construct instead. Do B<not> use C</A-Z/>. =item isxdigit This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C</[[:isxdigit:]]/> construct instead, or simply C</[0-9a-f]/i>. =item kill -This is identical to Perl's builtin C<kill()> function. +This is identical to Perl's builtin C<kill()> function for sending +signals to processes (often to terminate them), see L<perlfunc/kill>. =item labs -labs() is C-specific, use abs instead. +(For returning absolute values of long integers.) +labs() is C-specific, see L<perlfunc/abs> instead. =item ldexp -This is identical to the C function C<ldexp()>. +This is identical to the C function C<ldexp()> +for multiplying floating point numbers with powers of two. + + $x_quadrupled = POSIX::ldexp($x, 2); =item ldiv -ldiv() is C-specific, use / and int instead. +(For computing dividends of long integers.) +ldiv() is C-specific, use C</> and C<int()> instead. =item link -This is identical to Perl's builtin C<link()> function. +This is identical to Perl's builtin C<link()> function +for creating hard links into files, see L<perlfunc/link>. =item localeconv Get numeric formatting information. Returns a reference to a hash containing the current locale formatting values. -The database for the B<de> (Deutsch or German) locale. +Here is how to query the database for the B<de> (Deutsch or German) locale. $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" ); print "Locale = $loc\n"; @@ -590,19 +707,34 @@ The database for the B<de> (Deutsch or German) locale. =item localtime -This is identical to Perl's builtin C<localtime()> function. +This is identical to Perl's builtin C<localtime()> function for +converting seconds since the epoch to a date see L<perlfunc/localtime>. =item log -This is identical to Perl's builtin C<log()> function. +This is identical to Perl's builtin C<log()> function, +returning the natural (I<e>-based) logarithm of the numerical argument, +see L<perlfunc/log>. =item log10 -This is identical to the C function C<log10()>. +This is identical to the C function C<log10()>, +returning the 10-base logarithm of the numerical argument. +You can also use + + sub log10 { log($_[0]) / log(10) } + +or + + sub log10 { log($_[0]) / 2.30258509299405 } + +or + + sub log10 { log($_[0]) * 0.434294481903252 } =item longjmp -longjmp() is C-specific: use die instead. +longjmp() is C-specific: use L<perlfunc/die> instead. =item lseek @@ -616,49 +748,63 @@ Returns C<undef> on failure. =item malloc -malloc() is C-specific. +malloc() is C-specific. Perl does memory management transparently. =item mblen This is identical to the C function C<mblen()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item mbstowcs This is identical to the C function C<mbstowcs()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item mbtowc This is identical to the C function C<mbtowc()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item memchr -memchr() is C-specific, use index() instead. +memchr() is C-specific, see L<perlfunc/index> instead. =item memcmp -memcmp() is C-specific, use eq instead. +memcmp() is C-specific, use C<eq> instead, see L<perlop>. =item memcpy -memcpy() is C-specific, use = instead. +memcpy() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. =item memmove -memmove() is C-specific, use = instead. +memmove() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>. =item memset -memset() is C-specific, use x instead. +memset() is C-specific, use C<x> instead, see L<perlop>. =item mkdir -This is identical to Perl's builtin C<mkdir()> function. +This is identical to Perl's builtin C<mkdir()> function +for creating directories, see L<perlfunc/mkdir>. =item mkfifo -This is similar to the C function C<mkfifo()>. +This is similar to the C function C<mkfifo()> for creating +FIFO special files. -Returns C<undef> on failure. + if (mkfifo($path, $mode)) { .... + +Returns C<undef> on failure. The C<$mode> is similar to the +mode of C<mkdir()>, see L<perlfunc/mkdir>. =item mktime @@ -689,13 +835,16 @@ Return the integral and fractional parts of a floating-point number. =item nice -This is similar to the C function C<nice()>. +This is similar to the C function C<nice()>, for changing +the scheduling preference of the current process. Positive +arguments mean more polite process, negative values more +needy process. Normal user processes can only be more polite. Returns C<undef> on failure. =item offsetof -offsetof() is C-specific. +offsetof() is C-specific, you probably want to see L<perlfunc/pack> instead. =item open @@ -720,6 +869,8 @@ Create a new file with mode 0640. Set up the file for writing. Returns C<undef> on failure. +See also L<perlfunc/sysopen>. + =item opendir Open a directory for reading. @@ -743,13 +894,17 @@ Returns C<undef> on failure. =item pause -This is similar to the C function C<pause()>. +This is similar to the C function C<pause()>, which suspends +the execution of the current process until a signal is received. Returns C<undef> on failure. =item perror -This is identical to the C function C<perror()>. +This is identical to the C function C<perror()>, which outputs to the +standard error stream the specified message followed by ": " and the +current error string. Use the C<warn()> function and the C<$!> +variable instead, see L<perlfunc/warn> and L<perlvar/$ERRNO>. =item pipe @@ -760,39 +915,45 @@ returned by C<POSIX::open>. POSIX::write( $fd0, "hello", 5 ); POSIX::read( $fd1, $buf, 5 ); +See also L<perlfunc/pipe>. + =item pow -Computes $x raised to the power $exponent. +Computes C<$x> raised to the power C<$exponent>. $ret = POSIX::pow( $x, $exponent ); +You can also use the C<**> operator, see L<perlop>. + =item printf -Prints the specified arguments to STDOUT. +Formats and prints the specified arguments to STDOUT. +See also L<perlfunc/printf>. =item putc -putc() is C-specific--use print instead. +putc() is C-specific, see L<perlfunc/print> instead. =item putchar -putchar() is C-specific--use print instead. +putchar() is C-specific, see L<perlfunc/print> instead. =item puts -puts() is C-specific--use print instead. +puts() is C-specific, see L<perlfunc/print> instead. =item qsort -qsort() is C-specific, use sort instead. +qsort() is C-specific, see L<perlfunc/sort> instead. =item raise Sends the specified signal to the current process. +See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>. =item rand -rand() is non-portable, use Perl's rand instead. +C<rand()> is non-portable, see L<perlfunc/rand> instead. =item read @@ -805,21 +966,26 @@ read then Perl will extend it to make room for the request. Returns C<undef> on failure. +See also L<perlfunc/sysread>. + =item readdir -This is identical to Perl's builtin C<readdir()> function. +This is identical to Perl's builtin C<readdir()> function +for reading directory entries, see L<perlfunc/readdir>. =item realloc -realloc() is C-specific. +realloc() is C-specific. Perl does memory management transparently. =item remove -This is identical to Perl's builtin C<unlink()> function. +This is identical to Perl's builtin C<unlink()> function +for removing files, see L<perlfunc/unlink>. =item rename -This is identical to Perl's builtin C<rename()> function. +This is identical to Perl's builtin C<rename()> function +for renaming files, see L<perlfunc/rename>. =item rewind @@ -827,23 +993,29 @@ Seeks to the beginning of the file. =item rewinddir -This is identical to Perl's builtin C<rewinddir()> function. +This is identical to Perl's builtin C<rewinddir()> function for +rewinding directory entry streams, see L<perlfunc/rewinddir>. =item rmdir -This is identical to Perl's builtin C<rmdir()> function. +This is identical to Perl's builtin C<rmdir()> function +for removing (empty) directories, see L<perlfunc/rmdir>. =item scanf -scanf() is C-specific--use <> and regular expressions instead. +scanf() is C-specific, use E<lt>E<gt> and regular expressions instead, +see L<perlre>. =item setgid -Sets the real group id for this process. +Sets the real group identifier for this process. +Identical to assigning a value to the Perl's builtin C<$)> variable, +see L<perlvar/$UID>. =item setjmp -setjmp() is C-specific: use eval {} instead. +C<setjmp()> is C-specific: use C<eval {}> instead, +see L<perlfunc/eval>. =item setlocale @@ -879,17 +1051,21 @@ out which locales are available in your system. =item setpgid -This is similar to the C function C<setpgid()>. +This is similar to the C function C<setpgid()> for +setting the process group identifier of the current process. Returns C<undef> on failure. =item setsid -This is identical to the C function C<setsid()>. +This is identical to the C function C<setsid()> for +setting the session identifier of the current process. =item setuid -Sets the real user id for this process. +Sets the real user identifier for this process. +Identical to assigning a value to the Perl's builtin C<$E<lt>> variable, +see L<perlvar/$UID>. =item sigaction @@ -905,7 +1081,7 @@ Returns C<undef> on failure. =item siglongjmp -siglongjmp() is C-specific: use die instead. +siglongjmp() is C-specific: use L<perlfunc/die> instead. =item sigpending @@ -933,7 +1109,8 @@ Returns C<undef> on failure. =item sigsetjmp -sigsetjmp() is C-specific: use eval {} instead. +C<sigsetjmp()> is C-specific: use C<eval {}> instead, +see L<perlfunc/eval>. =item sigsuspend @@ -949,63 +1126,80 @@ Returns C<undef> on failure. =item sin -This is identical to Perl's builtin C<sin()> function. +This is identical to Perl's builtin C<sin()> function +for returning the sine of the numerical argument, +see L<perlfunc/sin>. See also L<Math::Trig>. =item sinh -This is identical to the C function C<sinh()>. +This is identical to the C function C<sinh()> +for returning the hyperbolic sine of the numerical argument. +See also L<Math::Trig>. =item sleep -This is identical to Perl's builtin C<sleep()> function. +This is identical to Perl's builtin C<sleep()> function +for suspending the execution of the current for process +for certain number of seconds, see L<perlfunc/sleep>. =item sprintf -This is identical to Perl's builtin C<sprintf()> function. +This is similar to Perl's builtin C<sprintf()> function +for returning a string that has the arguments formatted as requested, +see L<perlfunc/sprintf>. =item sqrt This is identical to Perl's builtin C<sqrt()> function. +for returning the square root of the numerical argument, +see L<perlfunc/sqrt>. =item srand -srand(). +Give a seed the pseudorandom number generator, see L<perlfunc/srand>. =item sscanf -sscanf() is C-specific--use regular expressions instead. +sscanf() is C-specific, use regular expressions instead, +see L<perlre>. =item stat -This is identical to Perl's builtin C<stat()> function. +This is identical to Perl's builtin C<stat()> function +for retutning information about files and directories. =item strcat -strcat() is C-specific, use .= instead. +strcat() is C-specific, use C<.=> instead, see L<perlop>. =item strchr -strchr() is C-specific, use index() instead. +strchr() is C-specific, see L<perlfunc/index> instead. =item strcmp -strcmp() is C-specific, use eq instead. +strcmp() is C-specific, use C<eq> or C<cmp> instead, see L<perlop>. =item strcoll -This is identical to the C function C<strcoll()>. +This is identical to the C function C<strcoll()> +for collating (comparing) strings transformed using +the C<strxfrm()> function. Not really needed since +Perl can do this transparently, see L<perllocale>. =item strcpy -strcpy() is C-specific, use = instead. +strcpy() is C-specific, use C<=> instead, see L<perlop>. =item strcspn -strcspn() is C-specific, use regular expressions instead. +strcspn() is C-specific, use regular expressions instead, +see L<perlre>. =item strerror Returns the error string for the specified errno. +Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>. =item strftime @@ -1034,39 +1228,38 @@ The string for Tuesday, December 12, 1995. =item strlen -strlen() is C-specific, use length instead. +strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>. =item strncat -strncat() is C-specific, use .= instead. +strncat() is C-specific, use C<.=> instead, see L<perlop>. =item strncmp -strncmp() is C-specific, use eq instead. +strncmp() is C-specific, use C<eq> instead, see L<perlop>. =item strncpy -strncpy() is C-specific, use = instead. - -=item stroul - -stroul() is C-specific. +strncpy() is C-specific, use C<=> instead, see L<perlop>. =item strpbrk -strpbrk() is C-specific. +strpbrk() is C-specific, use regular expressions instead, +see L<perlre>. =item strrchr -strrchr() is C-specific, use rindex() instead. +strrchr() is C-specific, see L<perlfunc/rindex> instead. =item strspn -strspn() is C-specific. +strspn() is C-specific, use regular expressions instead, +see L<perlre>. =item strstr -This is identical to Perl's builtin C<index()> function. +This is identical to Perl's builtin C<index()> function, +see L<perlfunc/index>. =item strtod @@ -1093,7 +1286,8 @@ When called in a scalar context strtod returns the parsed number. =item strtok -strtok() is C-specific. +strtok() is C-specific, use regular expressions instead, see +L<perlre>, or L<perlfunc/split>. =item strtol @@ -1127,12 +1321,12 @@ When called in a scalar context strtol returns the parsed number. =item strtoul -String to unsigned (long) integer translation. strtoul is identical -to strtol except that strtoul only parses unsigned integers. See -I<strtol> for details. +String to unsigned (long) integer translation. strtoul() is identical +to strtol() except that strtoul() only parses unsigned integers. See +L</strtol> for details. -Note: Some vendors supply strtod and strtol but not strtoul. -Other vendors that do suply strtoul parse "-1" as a valid value. +Note: Some vendors supply strtod() and strtol() but not strtoul(). +Other vendors that do supply strtoul() parse "-1" as a valid value. =item strxfrm @@ -1140,6 +1334,11 @@ String transformation. Returns the transformed string. $dst = POSIX::strxfrm( $src ); +Used in conjunction with the C<strcoll()> function, see L</strcoll>. + +Not really needed since Perl can do this transparently, see +L<perllocale>. + =item sysconf Retrieves values of system configurable variables. @@ -1152,53 +1351,66 @@ Returns C<undef> on failure. =item system -This is identical to Perl's builtin C<system()> function. +This is identical to Perl's builtin C<system()> function, see +L<perlfunc/system>. =item tan -This is identical to the C function C<tan()>. +This is identical to the C function C<tan()>, returning the +tangent of the numerical argument. See also L<Math::Trig>. =item tanh -This is identical to the C function C<tanh()>. +This is identical to the C function C<tanh()>, returning the +hyperbolic tangent of the numerical argument. See also L<Math::Trig>. =item tcdrain -This is similar to the C function C<tcdrain()>. +This is similar to the C function C<tcdrain()> for draining +the output queue of its argument stream. Returns C<undef> on failure. =item tcflow -This is similar to the C function C<tcflow()>. +This is similar to the C function C<tcflow()> for controlling +the flow of its argument stream. Returns C<undef> on failure. =item tcflush -This is similar to the C function C<tcflush()>. +This is similar to the C function C<tcflush()> for flushing +the I/O buffers of its argumeny stream. Returns C<undef> on failure. =item tcgetpgrp -This is identical to the C function C<tcgetpgrp()>. +This is identical to the C function C<tcgetpgrp()> for returning the +process group identifier of the foreground process group of the controlling +terminal. =item tcsendbreak -This is similar to the C function C<tcsendbreak()>. +This is similar to the C function C<tcsendbreak()> for sending +a break on its argument stream. Returns C<undef> on failure. =item tcsetpgrp -This is similar to the C function C<tcsetpgrp()>. +This is similar to the C function C<tcsetpgrp()> for setting the +process group identifier of the foreground process group of the controlling +terminal. Returns C<undef> on failure. =item time -This is identical to Perl's builtin C<time()> function. +This is identical to Perl's builtin C<time()> function +for returning the number of seconds since the epoch +(whatever it is for the system), see L<perlfunc/time>. =item times @@ -1214,7 +1426,7 @@ seconds. =item tmpfile -Use method C<IO::File::new_tmpfile()> instead. +Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>. =item tmpnam @@ -1222,17 +1434,28 @@ Returns a name for a temporary file. $tmpfile = POSIX::tmpnam(); +For security reasons, which are probably detailed in your system's +documentation for the C library tmpnam() function, this interface +should not be used; instead see L<File::Temp>. + =item tolower -This is identical to Perl's builtin C<lc()> function. +This is identical to the C function, except that it can apply to a single +character or to a whole string. Consider using the C<lc()> function, +see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish +strings. =item toupper -This is identical to Perl's builtin C<uc()> function. +This is identical to the C function, except that it can apply to a single +character or to a whole string. Consider using the C<uc()> function, +see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish +strings. =item ttyname -This is identical to the C function C<ttyname()>. +This is identical to the C function C<ttyname()> for returning the +name of the current terminal. =item tzname @@ -1243,17 +1466,31 @@ Retrieves the time conversion information from the C<tzname> variable. =item tzset -This is identical to the C function C<tzset()>. +This is identical to the C function C<tzset()> for setting +the current timezone based on the environment variable C<TZ>, +to be used by C<ctime()>, C<localtime()>, C<mktime()>, and C<strftime()> +functions. =item umask -This is identical to Perl's builtin C<umask()> function. +This is identical to Perl's builtin C<umask()> function +for setting (and querying) the file creation permission mask, +see L<perlfunc/umask>. =item uname Get name of current operating system. - ($sysname, $nodename, $release, $version, $machine ) = POSIX::uname(); + ($sysname, $nodename, $release, $version, $machine) = POSIX::uname(); + +Note that the actual meanings of the various fields are not +that well standardized, do not expect any great portability. +The C<$sysname> might be the name of the operating system, +the C<$nodename> might be the name of the host, the C<$release> +might be the (major) release number of the operating system, +the C<$version> might be the (minor) release number of the +operating system, and the C<$machine> might be a hardware identifier. +Maybe. =item ungetc @@ -1261,32 +1498,36 @@ Use method C<IO::Handle::ungetc()> instead. =item unlink -This is identical to Perl's builtin C<unlink()> function. +This is identical to Perl's builtin C<unlink()> function +for removing files, see L<perlfunc/unlink>. =item utime -This is identical to Perl's builtin C<utime()> function. +This is identical to Perl's builtin C<utime()> function +for changing the time stamps of files and directories, +see L<perlfunc/utime>. =item vfprintf -vfprintf() is C-specific. +vfprintf() is C-specific, see L<perlfunc/printf> instead. =item vprintf -vprintf() is C-specific. +vprintf() is C-specific, see L<perlfunc/printf> instead. =item vsprintf -vsprintf() is C-specific. +vsprintf() is C-specific, see L<perlfunc/sprintf> instead. =item wait -This is identical to Perl's builtin C<wait()> function. +This is identical to Perl's builtin C<wait()> function, +see L<perlfunc/wait>. =item waitpid Wait for a child process to change state. This is identical to Perl's -builtin C<waitpid()> function. +builtin C<waitpid()> function, see L<perlfunc/waitpid>. $pid = POSIX::waitpid( -1, &POSIX::WNOHANG ); print "status = ", ($? / 256), "\n"; @@ -1294,10 +1535,16 @@ builtin C<waitpid()> function. =item wcstombs This is identical to the C function C<wcstombs()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item wctomb This is identical to the C function C<wctomb()>. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item write @@ -1310,6 +1557,8 @@ calling C<POSIX::open>. Returns C<undef> on failure. +See also L<perlfunc/syswrite>. + =back =head1 CLASSES @@ -1715,7 +1964,7 @@ CLK_TCK CLOCKS_PER_SEC =item Constants -R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STRERR_FILENO W_OK X_OK +R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK =back @@ -1733,7 +1982,3 @@ WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG =back -=head1 CREATION - -This document generated by ./mkposixman.PL version 19960129. - diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs index 3a523d1d07a3..7ffd49411a5b 100644 --- a/contrib/perl5/ext/POSIX/POSIX.xs +++ b/contrib/perl5/ext/POSIX/POSIX.xs @@ -55,6 +55,9 @@ #ifdef I_UNISTD #include <unistd.h> #endif +#ifdef MACOS_TRADITIONAL +#undef fdopen +#endif #include <fcntl.h> #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -80,7 +83,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) { + clock_t vms_times(struct tms *bufptr) { dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to @@ -101,7 +104,7 @@ _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); # endif /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)PL_bufptr); + times((tbuffer_t *)bufptr); return (clock_t) retval; } # define times(t) vms_times(t) @@ -139,10 +142,12 @@ # define sigdelset(a,b) not_here("sigdelset") # define sigfillset(a) not_here("sigfillset") # define sigismember(a,b) not_here("sigismember") +# define setuid(a) not_here("setuid") +# define setgid(a) not_here("setgid") #else # ifndef HAS_MKFIFO -# ifdef OS2 +# if defined(OS2) || defined(MACOS_TRADITIONAL) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -151,12 +156,17 @@ # endif # endif /* !HAS_MKFIFO */ -# include <grp.h> -# include <sys/times.h> -# ifdef HAS_UNAME -# include <sys/utsname.h> +# ifdef MACOS_TRADITIONAL +# define ttyname(a) (char*)not_here("ttyname") +# define tzset() not_here("tzset") +# else +# include <grp.h> +# include <sys/times.h> +# ifdef HAS_UNAME +# include <sys/utsname.h> +# endif +# include <sys/wait.h> # endif -# include <sys/wait.h> # ifdef I_UTIME # include <utime.h> # endif @@ -529,12 +539,12 @@ mini_mktime(struct tm *ptm) } #ifdef HAS_LONG_DOUBLE -# if LONG_DOUBLESIZE > DOUBLESIZE +# if LONG_DOUBLESIZE > NVSIZE # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */ # endif #endif -#ifndef HAS_LONG_DOUBLE +#ifndef HAS_LONG_DOUBLE #ifdef LDBL_MAX #undef LDBL_MAX #endif @@ -554,11 +564,7 @@ not_here(char *s) } static -#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE) -long double -#else -double -#endif +NV constant(char *name, int arg) { errno = 0; @@ -1517,6 +1523,11 @@ constant(char *name, int arg) break; case 'H': if (strEQ(name, "HUGE_VAL")) +#if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + /* HUGE_VALL is admittedly non-POSIX but if we are using long doubles + * we might as well use long doubles. --jhi */ + return HUGE_VALL; +#endif #ifdef HUGE_VAL return HUGE_VAL; #else @@ -2291,9 +2302,9 @@ constant(char *name, int arg) #else goto not_there; #endif - if (strEQ(name, "STRERR_FILENO")) -#ifdef STRERR_FILENO - return STRERR_FILENO; + if (strEQ(name, "STDERR_FILENO")) +#ifdef STDERR_FILENO + return STDERR_FILENO; #else goto not_there; #endif @@ -3005,7 +3016,7 @@ setcc(termios_ref, ccix, cc) MODULE = POSIX PACKAGE = POSIX -double +NV constant(name,arg) char * name int arg @@ -3161,7 +3172,7 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); - if (lcbuf = localeconv()) { + if ((lcbuf = localeconv())) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) hv_store(RETVAL, "decimal_point", 13, @@ -3294,73 +3305,73 @@ setlocale(category, locale = 0) RETVAL -double +NV acos(x) - double x + NV x -double +NV asin(x) - double x + NV x -double +NV atan(x) - double x + NV x -double +NV ceil(x) - double x + NV x -double +NV cosh(x) - double x + NV x -double +NV floor(x) - double x + NV x -double +NV fmod(x,y) - double x - double y + NV x + NV y void frexp(x) - double x + NV x PPCODE: int expvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); PUSHs(sv_2mortal(newSViv(expvar))); -double +NV ldexp(x,exp) - double x + NV x int exp -double +NV log10(x) - double x + NV x void modf(x) - double x + NV x PPCODE: - double intvar; + NV intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); -double +NV sinh(x) - double x + NV x -double +NV tan(x) - double x + NV x -double +NV tanh(x) - double x + NV x SysRet sigaction(sig, action, oldaction = 0) @@ -3406,9 +3417,8 @@ sigaction(sig, action, oldaction = 0) /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); - sigset = (sigset_t*) tmp; + IV tmp = SvIV((SV*)SvRV(*svp)); + sigset = INT2PTR(sigset_t*, tmp); act.sa_mask = *sigset; } else @@ -3433,9 +3443,8 @@ sigaction(sig, action, oldaction = 0) /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { - unsigned long tmp; - tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); - sigset = (sigset_t*) tmp; + IV tmp = SvIV((SV*)SvRV(*svp)); + sigset = INT2PTR(sigset_t*, tmp); } else { New(0, sigset, 1, sigset_t); @@ -3506,7 +3515,7 @@ SysRet nice(incr) int incr -int +void pipe() PPCODE: int fds[2]; @@ -3549,7 +3558,7 @@ tcsetpgrp(fd, pgrp_id) int fd pid_t pgrp_id -int +void uname() PPCODE: #ifdef HAS_UNAME @@ -3683,7 +3692,7 @@ strtoul(str, base = 0) PUSHs(&PL_sv_undef); } -SV * +void strxfrm(src) SV * src CODE: @@ -3818,7 +3827,10 @@ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) OUTPUT: RETVAL -char * +#XXX: if $xsubpp::WantOptimize is always the default +# sv_setpv(TARG, ...) could be used rather than +# ST(0) = sv_2mortal(newSVpv(...)) +void strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) char * fmt int sec diff --git a/contrib/perl5/ext/POSIX/typemap b/contrib/perl5/ext/POSIX/typemap index 63e41c77bf1f..baf9bfc05194 100644 --- a/contrib/perl5/ext/POSIX/typemap +++ b/contrib/perl5/ext/POSIX/typemap @@ -5,6 +5,7 @@ Time_t T_NV Gid_t T_NV Off_t T_NV Dev_t T_NV +NV T_NV fd T_IV speed_t T_IV tcflag_t T_IV diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.pm b/contrib/perl5/ext/SDBM_File/SDBM_File.pm index c5e26c8e04d8..ee82a54145d9 100644 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.pm +++ b/contrib/perl5/ext/SDBM_File/SDBM_File.pm @@ -1,12 +1,13 @@ package SDBM_File; use strict; +use warnings; require Tie::Hash; use XSLoader (); our @ISA = qw(Tie::Hash); -our $VERSION = "1.02" ; +our $VERSION = "1.03" ; XSLoader::load 'SDBM_File', $VERSION; @@ -20,14 +21,96 @@ SDBM_File - Tied access to sdbm files =head1 SYNOPSIS + use Fcntl; # For O_RDWR, O_CREAT, etc. use SDBM_File; - tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + tie(%h, 'SDBM_File', 'filename', O_RDWR|O_CREAT, 0666) + or die "Couldn't tie SDBM file 'filename': $!; aborting"; + + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... untie %h; =head1 DESCRIPTION -See L<perlfunc/tie>, L<perldbmfilter> +C<SDBM_File> establishes a connection between a Perl hash variable and +a file in SDBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. + +Use C<SDBM_File> with the Perl built-in C<tie> function to establish +the connection between the variable and the file. The arguments to +C<tie> should be: + +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"SDBM_File">. (Ths tells Perl to use the C<SDBM_File> +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C<O_RDONLY> + +Read-only access to the data in the file. + +=item C<O_WRONLY> + +Write-only access to the data in the file. + +=item C<O_RDWR> + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C<O_CREAT> to +any of these, as in the example. If you omit C<O_CREAT> and the file +does not already exist, the C<tie> call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L<perlfunc/umask>.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C<tie> call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C<sdbm store returned -1, errno 22, key "..." at ...> + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the SDBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. + +See L<perlfunc/tie>, L<perldbmfilter>, L<Fcntl> =cut diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.xs b/contrib/perl5/ext/SDBM_File/SDBM_File.xs index a4b90451a9bc..859730bf3ac1 100644 --- a/contrib/perl5/ext/SDBM_File/SDBM_File.xs +++ b/contrib/perl5/ext/SDBM_File/SDBM_File.xs @@ -57,7 +57,7 @@ sdbm_TIEHASH(dbtype, filename, flags, mode) DBM * dbp ; RETVAL = NULL ; - if (dbp = sdbm_open(filename,flags,mode) ) { + if ((dbp = sdbm_open(filename,flags,mode))) { RETVAL = (SDBM_File)safemalloc(sizeof(SDBM_File_type)) ; Zero(RETVAL, 1, SDBM_File_type) ; RETVAL->dbp = dbp ; diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c index dc47d7001dee..321ac3ef6061 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c @@ -3,16 +3,33 @@ * All rights reserved. * * Redistribution and use in source and binary forms are permitted - * provided that the above copyright notice and this paragraph are - * duplicated in all such forms and that any documentation, - * advertising materials, and other materials related to such - * distribution and use acknowledge that the software was developed - * by the University of California, Berkeley. The name of the - * University may not be used to endorse or promote products derived - * from this software without specific prior written permission. - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * provided that the above copyright notice and this notice are + * duplicated in all such forms. + * + * [additional clause stricken -- see below] + * + * The name of the University may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE. + * + * This notice previously contained the additional clause: + * + * and that any documentation, advertising materials, and other + * materials related to such distribution and use acknowledge that + * the software was developed by the University of California, + * Berkeley. + * + * Pursuant to the licensing change made by the Office of Technology + * Licensing of the University of California, Berkeley on July 22, + * 1999 and documented in: + * + * ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change + * + * this clause has been stricken and no longer is applicable to this + * software. */ #ifndef lint diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h index 1196953d9653..e2c935523899 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h +++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h @@ -3,16 +3,33 @@ * All rights reserved. * * Redistribution and use in source and binary forms are permitted - * provided that the above copyright notice and this paragraph are - * duplicated in all such forms and that any documentation, - * advertising materials, and other materials related to such - * distribution and use acknowledge that the software was developed - * by the University of California, Berkeley. The name of the - * University may not be used to endorse or promote products derived - * from this software without specific prior written permission. - * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED - * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * provided that the above copyright notice and this notice are + * duplicated in all such forms. + * + * [additional clause stricken -- see below] + * + * The name of the University may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY + * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE. + * + * This notice previously contained the additional clause: + * + * and that any documentation, advertising materials, and other + * materials related to such distribution and use acknowledge that + * the software was developed by the University of California, + * Berkeley. + * + * Pursuant to the licensing change made by the Office of Technology + * Licensing of the University of California, Berkeley on July 22, + * 1999 and documented in: + * + * ftp://ftp.cs.berkeley.edu/pub/4bsd/README.Impt.License.Change + * + * this clause has been stricken and no longer is applicable to this + * software. * * @(#)dbm.h 5.2 (Berkeley) 5/24/89 */ diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c index 64c75cbb2083..d41c770dfbcc 100644 --- a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c +++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c @@ -283,6 +283,10 @@ makroom(register DBM *db, long int hash, int need) { long newp; char twin[PBLKSIZ]; +#if defined(DOSISH) || defined(WIN32) + char zer[PBLKSIZ]; + long oldtail; +#endif char *pag = db->pagbuf; char *New = twin; register int smax = SPLTMAX; @@ -305,6 +309,23 @@ makroom(register DBM *db, long int hash, int need) * still looking at the page of interest. current page is not updated * here, as sdbm_store will do so, after it inserts the incoming pair. */ + +#if defined(DOSISH) || defined(WIN32) + /* + * Fill hole with 0 if made it. + * (hole is NOT read as 0) + */ + oldtail = lseek(db->pagf, 0L, SEEK_END); + memset(zer, 0, PBLKSIZ); + while (OFF_PAG(newp) > oldtail) { + if (lseek(db->pagf, 0L, SEEK_END) < 0 || + write(db->pagf, zer, PBLKSIZ) < 0) { + + return 0; + } + oldtail += PBLKSIZ; + } +#endif if (hash & (db->hmask + 1)) { if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) diff --git a/contrib/perl5/ext/SDBM_File/typemap b/contrib/perl5/ext/SDBM_File/typemap index eeb5d59027f5..40b95f22c022 100644 --- a/contrib/perl5/ext/SDBM_File/typemap +++ b/contrib/perl5/ext/SDBM_File/typemap @@ -20,8 +20,14 @@ T_DATUM_K $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; + if (SvOK($arg)) { + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; + } + else { + $var.dptr = \"\"; + $var.dsize = 0; + } T_GDATUM UNIMPLEMENTED OUTPUT diff --git a/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm index 02f098df77c9..d89b2f66b378 100644 --- a/contrib/perl5/ext/Socket/Socket.pm +++ b/contrib/perl5/ext/Socket/Socket.pm @@ -111,7 +111,7 @@ to inet_aton('255.255.255.255'). =item sockaddr_in SOCKADDR_IN -In an array context, unpacks its SOCKADDR_IN argument and returns an array +In a list context, unpacks its SOCKADDR_IN argument and returns an array consisting of (PORT, ADDRESS). In a scalar context, packs its (PORT, ADDRESS) arguments as a SOCKADDR_IN and returns it. If this is confusing, use pack_sockaddr_in() and unpack_sockaddr_in() explicitly. @@ -135,7 +135,7 @@ Will croak if the structure does not have AF_INET in the right place. =item sockaddr_un SOCKADDR_UN -In an array context, unpacks its SOCKADDR_UN argument and returns an array +In a list context, unpacks its SOCKADDR_UN argument and returns an array consisting of (PATHNAME). In a scalar context, packs its PATHNAME arguments as a SOCKADDR_UN and returns it. If this is confusing, use pack_sockaddr_un() and unpack_sockaddr_un() explicitly. @@ -268,6 +268,7 @@ use XSLoader (); SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR + SO_REUSEPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs index 0584e785b529..e08982909b56 100644 --- a/contrib/perl5/ext/Socket/Socket.xs +++ b/contrib/perl5/ext/Socket/Socket.xs @@ -1006,12 +1006,15 @@ unpack_sockaddr_un(sun_sv) STRLEN sockaddrlen; char * sun_ad = SvPV(sun_sv,sockaddrlen); char * e; - +# ifndef __linux__ + /* On Linux sockaddrlen on sockets returned by accept, recvfrom, + getpeername and getsockname is not equal to sizeof(addr). */ if (sockaddrlen != sizeof(addr)) { croak("Bad arg length for %s, length is %d, should be %d", "Socket::unpack_sockaddr_un", sockaddrlen, sizeof(addr)); } +# endif Copy( sun_ad, &addr, sizeof addr, char ); diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.pm b/contrib/perl5/ext/Sys/Syslog/Syslog.pm index 2a91354e8792..92b82a1acdce 100644 --- a/contrib/perl5/ext/Sys/Syslog/Syslog.pm +++ b/contrib/perl5/ext/Sys/Syslog/Syslog.pm @@ -70,9 +70,11 @@ 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. +A value of 'unix' will connect to the UNIX domain socket returned by the +C<_PATH_LOG> macro (if you system defines it) in F<syslog.h>. A value of +'inet' will connect to an INET socket returned by getservbyname(). If +C<_PATH_LOG> is unavailable or if getservbyname() fails, returns undef. Any +other value croaks. The default is for the INET socket to be used. @@ -107,10 +109,15 @@ 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>. +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 +E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and the perl5-porters mailing list. + +Dependency on F<syslog.ph> replaced with XS code by Tom Hughes +E<lt>F<tom@compton.nu>E<gt>. =cut @@ -159,7 +166,7 @@ sub setlogsock { local($setsock) = shift; &disconnect if $connected; if (lc($setsock) eq 'unix') { - if (defined &_PATH_LOG) { + if (length _PATH_LOG()) { $sock_type = 1; } else { return undef; @@ -244,9 +251,9 @@ sub syslog { 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; } + exit if defined $pid; # if fork failed, we're parent } } } @@ -267,14 +274,15 @@ sub connect { ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _) } unless ( $sock_type ) { - my $udp = getprotobyname('udp'); - my $syslog = getservbyname('syslog','udp'); + my $udp = getprotobyname('udp') || croak "getprotobyname failed for udp"; + my $syslog = getservbyname('syslog','udp') || croak "getservbyname failed"; 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 $syslog = _PATH_LOG(); + length($syslog) || croak "_PATH_LOG unavailable in syslog.h"; my $that = sockaddr_un($syslog) || croak "Can't locate $syslog"; socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!"; if (!connect(SYSLOG,$that)) { diff --git a/contrib/perl5/ext/Sys/Syslog/Syslog.xs b/contrib/perl5/ext/Sys/Syslog/Syslog.xs index f0573b8109aa..31c0e845a2de 100644 --- a/contrib/perl5/ext/Sys/Syslog/Syslog.xs +++ b/contrib/perl5/ext/Sys/Syslog/Syslog.xs @@ -550,8 +550,7 @@ _PATH_LOG() #ifdef _PATH_LOG RETVAL = _PATH_LOG; #else - croak("Your vendor has not defined the Sys::Syslog macro _PATH_LOG"); - RETVAL = NULL; + RETVAL = ""; #endif OUTPUT: RETVAL diff --git a/contrib/perl5/ext/Thread/Thread.pm b/contrib/perl5/ext/Thread/Thread.pm index 00cba8af6736..23f9fe513845 100644 --- a/contrib/perl5/ext/Thread/Thread.pm +++ b/contrib/perl5/ext/Thread/Thread.pm @@ -12,6 +12,15 @@ $VERSION = "1.0"; Thread - manipulate threads in Perl (EXPERIMENTAL, subject to change) +=head1 CAVEAT + +The Thread extension requires Perl to be built in a particular way to +enable the older 5.005 threading model. Just to confuse matters, there +is an alternate threading model known as "ithreads" that does NOT +support this extension. If you are using a binary distribution such +as ActivePerl that is built with ithreads support, this extension CANNOT +be used. + =head1 SYNOPSIS use Thread; @@ -130,7 +139,7 @@ signal is discarded. =item cond_broadcast VARIABLE -The C<cond_broadcast> function works similarly to C<cond_wait>. +The C<cond_broadcast> function works similarly to C<cond_signal>. 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. diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs index 4b5e6db9f869..15e2aa27c3ad 100644 --- a/contrib/perl5/ext/Thread/Thread.xs +++ b/contrib/perl5/ext/Thread/Thread.xs @@ -21,7 +21,7 @@ static int sig_pipe[2]; #endif static void -remove_thread(pTHX_ struct perl_thread *t) +remove_thread(pTHX_ Thread t) { #ifdef USE_THREADS DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, @@ -82,7 +82,7 @@ threadstart(void *arg) #else Thread thr = (Thread) arg; LOGOP myop; - djSP; + dSP; I32 oldmark = TOPMARK; I32 oldscope = PL_scopestack_ix; I32 retval; @@ -98,7 +98,6 @@ threadstart(void *arg) DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n", 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 @@ -116,7 +115,6 @@ threadstart(void *arg) */ PERL_SET_THX(thr); - /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */ DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n", thr, SvPEEK(TOPs))); @@ -323,7 +321,13 @@ newthread (pTHX_ SV *startsv, AV *initargs, char *classname) return sv; #else - croak("No threads in this perl"); +# ifdef USE_ITHREADS + croak("This perl was built for \"ithreads\", which currently does not support Thread.pm.\n" + "Run \"perldoc Thread\" for more information"); +# else + croak("This perl was not built with support for 5.005-style threads.\n" + "Run \"perldoc Thread\" for more information"); +# endif return &PL_sv_undef; #endif } diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL index bd0f1f741c19..bc31b2c2cc6d 100644 --- a/contrib/perl5/ext/re/Makefile.PL +++ b/contrib/perl5/ext/re/Makefile.PL @@ -1,4 +1,6 @@ use ExtUtils::MakeMaker; +use File::Spec; + WriteMakefile( NAME => 're', VERSION_FROM => 're.pm', @@ -9,33 +11,28 @@ WriteMakefile( clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' }, ); -sub MY::postamble { - if ($^O eq 'VMS') { - return <<'VMS_EOF'; -re_comp.c : [--]regcomp.c - - $(RM_F) $(MMS$TARGET_NAME) - $(CP) [--]regcomp.c $(MMS$TARGET_NAME) +package MY; -re_comp$(OBJ_EXT) : re_comp.c +sub upupfile { + File::Spec->catfile(File::Spec->updir, File::Spec->updir, $_[0]); +} -re_exec.c : [--]regexec.c - - $(RM_F) $(MMS$TARGET_NAME) - $(CP) [--]regexec.c $(MMS$TARGET_NAME) +sub postamble { + my $regcomp_c = upupfile('regcomp.c'); + my $regexec_c = upupfile('regexec.c'); -re_exec$(OBJ_EXT) : re_exec.c + <<EOF; +re_comp.c : $regcomp_c + - \$(RM_F) re_comp.c + \$(CP) $regcomp_c re_comp.c +re_comp\$(OBJ_EXT) : re_comp.c -VMS_EOF - } else { - return <<'EOF'; -re_comp.c: ../../regcomp.c - -$(RM_F) $@ - $(CP) ../../regcomp.c $@ +re_exec.c : $regexec_c + - \$(RM_F) re_exec.c + \$(CP) $regexec_c re_exec.c -re_exec.c: ../../regexec.c - -$(RM_F) $@ - $(CP) ../../regexec.c $@ +re_exec\$(OBJ_EXT) : re_exec.c EOF - } } diff --git a/contrib/perl5/ext/re/re.xs b/contrib/perl5/ext/re/re.xs index 04a5fdc7420e..25c2a90d60f1 100644 --- a/contrib/perl5/ext/re/re.xs +++ b/contrib/perl5/ext/re/re.xs @@ -25,7 +25,6 @@ static int oldfl; static void deinstall(pTHX) { - dTHR; PL_regexecp = Perl_regexec_flags; PL_regcompp = Perl_pregcomp; PL_regint_start = Perl_re_intuit_start; @@ -39,7 +38,6 @@ deinstall(pTHX) static void install(pTHX) { - dTHR; PL_colorset = 0; /* Allow reinspection of ENV. */ PL_regexecp = &my_regexec; PL_regcompp = &my_regcomp; |