diff options
| -rw-r--r-- | Changes | 4 | ||||
| -rw-r--r-- | ext/B/B.pm | 7 | ||||
| -rw-r--r-- | ext/B/B.xs | 28 | ||||
| -rw-r--r-- | ext/B/B/C.pm | 337 | ||||
| -rw-r--r-- | ext/B/B/CC.pm | 38 | ||||
| -rw-r--r-- | ext/B/B/Deparse.pm | 2 | ||||
| -rw-r--r-- | perl.h | 9 | ||||
| -rw-r--r-- | pod/perl.pod | 11 | ||||
| -rw-r--r-- | pod/perl5005delta.pod | 8 | ||||
| -rw-r--r-- | pod/perldiag.pod | 8 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 4 | ||||
| -rw-r--r-- | pp_sys.c | 8 | ||||
| -rw-r--r-- | t/lib/io_unix.t | 1 | ||||
| -rw-r--r-- | toke.c | 3 | ||||
| -rw-r--r-- | util.c | 2 |
15 files changed, 315 insertions, 155 deletions
@@ -20,7 +20,6 @@ current addresses (as of July 1998): Abigail <abigail@fnx.com> Kenneth Albanowski <kjahds@kjahds.com> Russ Allbery <rra@stanford.edu> - Graham Barr <gbarr@ti.com> Spider Boardman <spider@orb.nashua.nh.us> Tom Christiansen <tchrist@perl.com> Jan Dubois <jan.dubois@ibm.net> @@ -51,10 +50,11 @@ current addresses (as of July 1998): And the Keepers of the Patch Pumpkin: Charles Bailey <bailey@newman.upenn.edu> + Graham Barr <gbarr@ti.com> Malcolm Beattie <mbeattie@sable.ox.ac.uk> Tim Bunce <Tim.Bunce@ig.co.uk> Andy Dougherty <doughera@lafcol.lafayette.edu> - Gurusamy Sarathy <gsar@engin.umich.edu> + Gurusamy Sarathy <gsar@umich.edu> Chip Salzenberg <chip@perl.com> And, of course, the Author of Perl: diff --git a/ext/B/B.pm b/ext/B/B.pm index 75dcfb3b74..1599fe21c5 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -11,7 +11,7 @@ require Exporter; @ISA = qw(Exporter DynaLoader); @EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname class peekop cast_I32 cstring cchar hash threadsv_names - main_root main_start main_cv svref_2object + main_root main_start main_cv svref_2object opnumber walkoptree walkoptree_slow walkoptree_exec walksymtable parents comppadlist sv_undef compile_stats timing_info init_av); @@ -187,9 +187,12 @@ sub walkoptree_exec { sub walksymtable { my ($symref, $method, $recurse, $prefix) = @_; my $sym; + my $ref; no strict 'vars'; local(*glob); - while (($sym, *glob) = each %$symref) { + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) { + *glob = $ref; if ($sym =~ /::$/) { $sym = $prefix . $sym; if ($sym ne "main::" && &$recurse($sym)) { diff --git a/ext/B/B.xs b/ext/B/B.xs index 678bbbdbaf..3e300240ea 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -514,7 +514,28 @@ svref_2object(sv) croak("argument is not a reference"); RETVAL = (SV*)SvRV(sv); OUTPUT: - RETVAL + RETVAL + +void +opnumber(name) +char * name +CODE: +{ + int i; + IV result = -1; + ST(0) = sv_newmortal(); + if (strncmp(name,"pp_",3) == 0) + name += 3; + for (i = 0; i < PL_maxo; i++) + { + if (strcmp(name, PL_op_name[i]) == 0) + { + result = i; + break; + } + } + sv_setiv(ST(0),result); +} void ppname(opnum) @@ -533,10 +554,9 @@ hash(sv) char *s; STRLEN len; U32 hash = 0; - char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */ + char hexhash[19]; /* must fit "0xffffffff" plus trailing \0 */ s = SvPV(sv, len); - while (len--) - hash = hash * 33 + *s++; + PERL_HASH(hash, s, len); sprintf(hexhash, "0x%x", hash); ST(0) = sv_2mortal(newSVpv(hexhash, 0)); diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm index e695cc2876..40583bd71d 100644 --- a/ext/B/B/C.pm +++ b/ext/B/B/C.pm @@ -5,15 +5,51 @@ # You may distribute under the terms of either the GNU General Public # License or the Artistic License, as specified in the README file. # +package B::C::Section; +use B (); +use base B::Section; + +sub new +{ + my $class = shift; + my $o = $class->SUPER::new(@_); + push(@$o,[]); + return $o; +} + +sub add +{ + my $section = shift; + push(@{$section->[-1]},@_); +} + +sub index +{ + my $section = shift; + return scalar(@{$section->[-1]})-1; +} + +sub output +{ + my ($section, $fh, $format) = @_; + my $sym = $section->symtable || {}; + my $default = $section->default; + foreach (@{$section->[-1]}) + { + s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; + printf $fh $format, $_; + } +} + package B::C; use Exporter (); @ISA = qw(Exporter); -@EXPORT_OK = qw(output_all output_boilerplate output_main - init_sections set_callback save_unused_subs objsym); +@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused + init_sections set_callback save_unused_subs objsym save_context); use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop class cstring cchar svref_2object compile_stats comppadlist hash - threadsv_names main_cv init_av); + threadsv_names main_cv init_av opnumber); use B::Asmdata qw(@specialsv_name); use FileHandle; @@ -25,13 +61,14 @@ my $gv_index = 0; my $re_index = 0; my $pv_index = 0; my $anonsub_index = 0; +my $initsub_index = 0; my %symtable; my $warn_undefined_syms; my $verbose; -my @unused_sub_packages; +my %unused_sub_packages; my $nullop_count; -my $pv_copy_on_grow; +my $pv_copy_on_grow = 0; my ($debug_cops, $debug_av, $debug_cv, $debug_mg); my @threadsv_names; @@ -40,7 +77,7 @@ BEGIN { } # Code sections -my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect, +my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, @@ -68,9 +105,9 @@ my $op_seq = 65535; sub AVf_REAL () { 1 } -# XXX This shouldn't really be hardcoded here but it saves -# looking up the name of every BASEOP in B::OP -sub OP_THREADSV () { 345 } +# Look this up here so we can do just a number compare +# rather than looking up the name of every BASEOP in B::OP +my $OP_THREADSV = opnumber('threadsv'); sub savesym { my ($obj, $value) = @_; @@ -98,10 +135,11 @@ sub getsym { } sub savepv { - my $pv = shift; + my $pv = shift; + $pv = '' unless defined $pv; # Is this sane ? my $pvsym = 0; my $pvmax = 0; - if ($pv_copy_on_grow) { + if ($pv_copy_on_grow) { my $cstring = cstring($pv); if ($cstring ne "0") { # sic $pvsym = sprintf("pv%d", $pv_index++); @@ -117,7 +155,7 @@ sub B::OP::save { my ($op, $level) = @_; my $type = $op->type; $nullop_count++ unless $type; - if ($type == OP_THREADSV) { + if ($type == $OP_THREADSV) { # saves looking up ppaddr but it's a bit naughty to hard code this $init->add(sprintf("(void)find_threadsv(%s);", cstring($threadsv_names[$op->targ]))); @@ -388,7 +426,8 @@ sub B::PVNV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - my $pv = $sv->PV; + my $pv = $sv->PV; + $pv = '' unless defined $pv; my $len = length($pv); my ($pvsym, $pvmax) = savepv($pv); $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", @@ -489,7 +528,9 @@ sub B::RV::save { my ($sv) = @_; my $sym = objsym($sv); return $sym if defined $sym; - $xrvsect->add($sv->RV->save); + my $rv = $sv->RV->save; + $rv =~ s/^\([AGHS]V\s*\*\)\s*(\&sv_list.*)$/$1/; + $xrvsect->add($rv); $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS)); return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); @@ -564,6 +605,10 @@ sub B::CV::save { $ppname .= ($stashname eq "main") ? $gvname : "$stashname\::$gvname"; $ppname =~ s/::/__/g; + if ($gvname eq "INIT"){ + $ppname .= "_$initsub_index"; + $initsub_index++; + } } } if (!$ppname) { @@ -595,7 +640,8 @@ sub B::CV::save { else { warn sprintf("No definition for sub %s::%s (unable to autoload)\n", $cvstashname, $cvname); # debug - } + } + $pv = '' unless defined $pv; # Avoid use of undef warnings $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x", $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, @@ -802,6 +848,8 @@ sub B::HV::save { my ($key, $value) = splice(@contents, 0, 2); $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", cstring($key),length($key),$value, hash($key))); +# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", +# cstring($key),length($key),$value, 0)); } $init->add("}"); } @@ -813,6 +861,7 @@ sub B::IO::save { my $sym = objsym($io); return $sym if defined $sym; my $pv = $io->PV; + $pv = '' unless defined $pv; my $len = length($pv); $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", $len, $len+1, $io->IVX, $io->NVX, $io->LINES, @@ -849,7 +898,7 @@ sub output_all { my $section; my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect, - $cvopsect, $loopsect, $copsect, $svsect, $xpvsect, + $loopsect, $copsect, $svsect, $xpvsect, $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n"); @@ -1056,107 +1105,179 @@ sub save_object { sub Dummy_BootStrap { } -sub B::GV::savecv { - my $gv = shift; - my $cv = $gv->CV; - my $name = $gv->NAME; - if ($$cv) { - if ($name eq "bootstrap" && $cv->XSUB) { - my $file = $cv->FILEGV->SV->PV; - $bootstrap->add($file); - my $name = $gv->STASH->NAME.'::'.$name; - no strict 'refs'; - *{$name} = \&Dummy_BootStrap; - $cv = $gv->CV; - } - if ($debug_cv) { - warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", - $gv->STASH->NAME, $name, $$cv, $$gv); - } - my $package=$gv->STASH->NAME; - # This seems to undo all the ->isa and prefix stuff we do below - # so disable again for now - if (0 && ! grep(/^$package$/,@unused_sub_packages)){ - warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) - if $debug_cv; - return ; +sub B::GV::savecv +{ + my $gv = shift; + my $package=$gv->STASH->NAME; + my $name = $gv->NAME; + my $cv = $gv->CV; + return unless ($$cv || $name eq 'ISA'); + # We may be looking at this package just because it is a branch in the + # symbol table which is on the path to a package which we need to save + # e.g. this is 'Getopt' and wee need to save 'Getopt::Long' + # + if ($$cv && $name eq "bootstrap" && $cv->XSUB) + { + my $file = $cv->FILEGV->SV->PV; + $bootstrap->add($file); + } + unless ($unused_sub_packages{$package}) + { + warn sprintf("omitting cv $name in %s\n", $package) if $$cv; # if $debug_cv; + return ; + } + if ($$cv) + { + if ($name eq "bootstrap" && $cv->XSUB) + { + my $name = $gv->STASH->NAME.'::'.$name; + no strict 'refs'; + *{$name} = \&Dummy_BootStrap; + $cv = $gv->CV; + } + warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n", + $package, $name, $$cv, $$gv) if ($debug_cv); + $gv->save; + } + elsif ($name eq 'ISA') + { + $gv->save; + } +} + +sub mark_package +{ + my $package = shift; + unless ($unused_sub_packages{$package}) + { + no strict 'refs'; + $unused_sub_packages{$package} = 1; + if (defined(@{$package.'::ISA'})) + { + foreach my $isa (@{$package.'::ISA'}) + { + if ($isa eq 'DynaLoader') + { + unless (defined(&{$package.'::bootstrap'})) + { + warn "Forcing bootstrap of $package\n"; + eval { $package->bootstrap }; + } + } + else + { + unless ($unused_sub_packages{$isa}) + { + warn "$isa saved (it is in $package\'s \@ISA)\n"; + mark_package($isa); + } + } } - $gv->save; } - elsif ($name eq 'ISA') - { - $gv->save; - } + } + return 1; +} + +sub should_save +{ + no strict qw(vars refs); + my $package = shift; + $package =~ s/::$//; + return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. + # warn "Considering $package\n";#debug + foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) + { + # If this package is a prefix to something we are saving, traverse it + # but do not mark it for saving if it is not already + # e.g. to get to Getopt::Long we need to traverse Getopt but need + # not save Getopt + return 1 if ($u =~ /^$package\:\:/); + } + if (exists $unused_sub_packages{$package}) + { + # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; + return $unused_sub_packages{$package} + } + # Omit the packages which we use (and which cause grief + # because of fancy "goto &$AUTOLOAD" stuff). + # XXX Surely there must be a nicer way to do this. + if ($package eq "FileHandle" || $package eq "Config" || + $package eq "SelectSaver" || $package =~/^(B|IO)::/) + { + return $unused_sub_packages{$package} = 0; + } + # Now see if current package looks like an OO class this is probably too strong. + foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) + { + if ($package->can($m)) + { + warn "$package has method $m: saving package\n";#debug + return mark_package($package); + } + } + return $unused_sub_packages{$package} = 0; +} +sub walkpackages +{ + my ($symref, $recurse, $prefix) = @_; + my $sym; + my $ref; + no strict 'vars'; + local(*glob); + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) + { + *glob = $ref; + if ($sym =~ /::$/) + { + $sym = $prefix . $sym; + if ($sym ne "main::" && &$recurse($sym)) + { + walkpackages(\%glob, $recurse, $sym); + } + } + } } +sub save_unused_subs +{ + no strict qw(refs); + warn "Prescan\n"; + walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); + warn "Saving methods\n"; + walksymtable(\%{"main::"}, "savecv", \&should_save); +} -sub save_unused_subs { - my %search_pack; - map { $search_pack{$_} = 1 } @_; - @unused_sub_packages=@_; - no strict qw(vars refs); - walksymtable(\%{"main::"}, "savecv", sub { - my $package = shift; - $package =~ s/::$//; - return 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. - #warn "Considering $package\n";#debug - return 1 if exists $search_pack{$package}; - #sub try for a partial match - if (grep(/^$package\:\:/,@unused_sub_packages)){ - return 1; - } - #warn " (nothing explicit)\n";#debug - # Omit the packages which we use (and which cause grief - # because of fancy "goto &$AUTOLOAD" stuff). - # XXX Surely there must be a nicer way to do this. - if ($package eq "FileHandle" - || $package eq "Config" - || $package eq "SelectSaver") { - return 0; - } - foreach my $u (keys %search_pack) { - if ($package =~ /^${u}::/) { - warn "$package starts with $u\n"; - return 1 - } - if ($package->isa($u)) { - warn "$package isa $u\n"; - return 1 - } - return 1 if $package->isa($u); - } - foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) { - if (defined(&{$package."::$m"})) { - warn "$package has method $m: -u$package assumed\n";#debug - push @unused_sub_package, $package; - return 1; - } - } - return 0; - }); +sub save_context +{ + my $curpad_nam = (comppadlist->ARRAY)[0]->save; + my $curpad_sym = (comppadlist->ARRAY)[1]->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + $init->add( "PL_curpad = AvARRAY($curpad_sym);", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); } sub save_main { + warn "Starting compile\n"; + foreach my $pack (keys %unused_sub_packages) + { + mark_package($pack); + } warn "Walking tree\n"; - my $curpad_nam = (comppadlist->ARRAY)[0]->save; - my $curpad_sym = (comppadlist->ARRAY)[1]->save; - my $init_av = init_av->save; - my $inc_hv = svref_2object(\%INC)->save; - my $inc_av = svref_2object(\@INC)->save; walkoptree(main_root, "save"); warn "done main optree, walking symtable for extras\n" if $debug_cv; - save_unused_subs(@unused_sub_packages); - + save_unused_subs(); + my $init_av = init_av->save; $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), sprintf("PL_main_start = s\\_%x;", ${main_start()}), - "PL_curpad = AvARRAY($curpad_sym);", - "PL_initav = $init_av;", - "GvHV(PL_incgv) = $inc_hv;", - "GvAV(PL_incgv) = $inc_av;", - "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "PL_initav = $init_av;"); + save_context(); warn "Writing output\n"; output_boilerplate(); print "\n"; @@ -1168,7 +1289,7 @@ sub save_main { sub init_sections { my @sections = (init => \$init, decl => \$decl, sym => \$symsect, binop => \$binopsect, condop => \$condopsect, - cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect, + cop => \$copsect, gvop => \$gvopsect, listop => \$listopsect, logop => \$logopsect, loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, @@ -1180,8 +1301,14 @@ sub init_sections { xpvio => \$xpviosect, bootstrap => \$bootstrap); my ($name, $sectref); while (($name, $sectref) = splice(@sections, 0, 2)) { - $$sectref = new B::Section $name, \%symtable, 0; + $$sectref = new B::C::Section $name, \%symtable, 0; } +} + +sub mark_unused +{ + my ($arg,$val) = @_; + $unused_sub_packages{$arg} = $val; } sub compile { @@ -1226,7 +1353,7 @@ sub compile { $verbose = 1; } elsif ($opt eq "u") { $arg ||= shift @options; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "f") { $arg ||= shift @options; if ($arg eq "cog") { diff --git a/ext/B/B/CC.pm b/ext/B/B/CC.pm index d200d70f1a..e6c21bca75 100644 --- a/ext/B/B/CC.pm +++ b/ext/B/B/CC.pm @@ -8,8 +8,8 @@ package B::CC; use strict; use B qw(main_start main_root class comppadlist peekop svref_2object - timing_info); -use B::C qw(save_unused_subs objsym init_sections + timing_info init_av); +use B::C qw(save_unused_subs objsym init_sections mark_unused output_all output_boilerplate output_main); use B::Bblock qw(find_leaders); use B::Stackobj qw(:types :flags); @@ -499,7 +499,7 @@ sub pp_and { if (@stack >= 1) { my $bool = pop_bool(); write_back_stack(); - runtime(sprintf("if (!$bool) goto %s;", label($next))); + runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); } else { runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), "*sp--;"); @@ -513,10 +513,10 @@ sub pp_or { reload_lexicals(); unshift(@bblock_todo, $next); if (@stack >= 1) { - my $obj = pop @stack; + my $bool = pop_bool @stack; write_back_stack(); - runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }", - $obj->as_numeric, $obj->as_sv, label($next))); + runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", + $bool, label($next))); } else { runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), "*sp--;"); @@ -1264,11 +1264,11 @@ sub pp_substcont { write_back_stack(); doop($op); my $pmop = $op->other; - warn sprintf("substcont: op = %s, pmop = %s\n", - peekop($op), peekop($pmop));#debug -# my $pmopsym = objsym($pmop); + # warn sprintf("substcont: op = %s, pmop = %s\n", + # peekop($op), peekop($pmop));#debug +# my $pmopsym = objsym($pmop); my $pmopsym = $pmop->save; # XXX can this recurse? - warn "pmopsym = $pmopsym\n";#debug +# warn "pmopsym = $pmopsym\n";#debug runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", $pmopsym, label($pmop->pmreplstart)); invalidate_lexicals(); @@ -1387,10 +1387,13 @@ sub cc_obj { sub cc_main { my @comppadlist = comppadlist->ARRAY; - my $curpad_nam = $comppadlist[0]->save; - my $curpad_sym = $comppadlist[1]->save; + my $curpad_nam = $comppadlist[0]->save; + my $curpad_sym = $comppadlist[1]->save; + my $init_av = init_av->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); - save_unused_subs(@unused_sub_packages); + save_unused_subs(); cc_recurse(); return if $errors; @@ -1398,8 +1401,13 @@ sub cc_main { $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), "PL_main_start = $start;", "PL_curpad = AvARRAY($curpad_sym);", + "PL_initav = $init_av;", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", - "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));"); + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + ); + } output_boilerplate(); print "\n"; @@ -1459,7 +1467,7 @@ sub compile { $module_name = $arg; } elsif ($opt eq "u") { $arg ||= shift @options; - push(@unused_sub_packages, $arg); + mark_unused($arg,undef); } elsif ($opt eq "f") { $arg ||= shift @options; my $value = $arg !~ s/^no-//; diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 5e0bd1d3de..60f6f0dbd8 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -1442,7 +1442,7 @@ sub pp_truncate { my(@exprs); my $parens = ($cx >= 5) || $self->{'parens'}; my $kid = $op->first->sibling; - my($fh, $len); + my $fh; if ($op->flags & OPf_SPECIAL) { # $kid is an OP_CONST $fh = $kid->sv->PV; @@ -1349,6 +1349,15 @@ typedef I32 (*filter_t) _((int, SV *, int)); # endif #endif +/* XXX MAXPATHLEN should be determined by Configure */ +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN 1024 +# endif +#endif + #ifndef FUNC_NAME_TO_PTR #define FUNC_NAME_TO_PTR(name) name #endif diff --git a/pod/perl.pod b/pod/perl.pod index 0d2251e04b..1b886d01e0 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -119,9 +119,9 @@ BASIC-PLUS.) Expression syntax corresponds quite closely to C expression syntax. Unlike most Unix utilities, Perl does not arbitrarily limit the size of your data--if you've got the memory, Perl can slurp in your whole file as a single string. Recursion is of -unlimited depth. And the tables used by hashes (previously called +unlimited depth. And the tables used by hashes (sometimes called "associative arrays") grow as necessary to prevent degraded -performance. Perl uses sophisticated pattern matching techniques to +performance. Perl can use sophisticated pattern matching techniques to scan large amounts of data very quickly. Although optimized for scanning text, Perl can also deal with binary data, and can make dbm files look like hashes. Setuid Perl scripts are safer than C programs @@ -298,9 +298,10 @@ and syswrite().) While none of the built-in data types have any arbitrary size limits (apart from memory size), there are still a few arbitrary limits: a -given variable name may not be longer than 255 characters, and no -component of your PATH may be longer than 255 if you use B<-S>. A regular -expression may not compile to more than 32767 bytes internally. +given variable name may not be longer than 251 characters. Line numbers +displayed by diagnostics are internally stored as short integers, +so they are limited to a maximum of 65535 (higher numbers usually being +affected by wraparound). You may mail your bug reports (be sure to include full configuration information as output by the myconfig program in the perl source tree, diff --git a/pod/perl5005delta.pod b/pod/perl5005delta.pod index 62787f5028..89088b2b03 100644 --- a/pod/perl5005delta.pod +++ b/pod/perl5005delta.pod @@ -884,6 +884,14 @@ a B<-e> switch. Maybe your /tmp partition is full, or clobbered. (F) The create routine failed for some reason while trying to process a B<-e> switch. Maybe your /tmp partition is full, or clobbered. +=item regexp too big + +(F) The current implementation of regular expressions uses shorts as +address offsets within a string. Unfortunately this means that if +the regular expression compiles to longer than 32767, it'll blow up. +Usually when you want a regular expression this big, there is a better +way to do it with multiple statements. See L<perlre>. + =back =head1 BUGS diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 50552cf8d0..0b157c1f7c 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -2241,14 +2241,6 @@ expression compiler gave it. (P) A "can't happen" error, because safemalloc() should have caught it earlier. -=item regexp too big - -(F) The current implementation of regular expressions uses shorts as -address offsets within a string. Unfortunately this means that if -the regular expression compiles to longer than 32767, it'll blow up. -Usually when you want a regular expression this big, there is a better -way to do it with multiple statements. See L<perlre>. - =item Reversed %s= operator (W) You wrote your assignment operator backwards. The = must always diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 3b52b8413c..fa8454739f 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -15,7 +15,7 @@ operator. A unary operator generally provides a scalar context to its argument, while a list operator may provide either scalar and list contexts for its arguments. If it does both, the scalar arguments will be first, and the list argument will follow. (Note that there can ever -be only one list argument.) For instance, splice() has three scalar +be only one such list argument.) For instance, splice() has three scalar arguments followed by a list. In the syntax descriptions that follow, list operators that expect a @@ -1473,7 +1473,7 @@ L</last>, L</next>, and L</redo> for additional control flow. Enter BLOCK as LOOPVAR set in turn to each element of LIST. For example: - foreach $rolling (@stones) { print "rolling $stone\n" } + foreach $rolling (@stones) { print "$rolling stone\n" } foreach my $file (@files) { print "file $file\n" } @@ -173,14 +173,6 @@ static int dooneliner _((char *cmd, char *filename)); #endif /* no flock() */ -#ifndef MAXPATHLEN -# ifdef PATH_MAX -# define MAXPATHLEN PATH_MAX -# else -# define MAXPATHLEN 1024 -# endif -#endif - #define ZBTLEN 10 static char zero_but_true[ZBTLEN + 1] = "0 but true"; diff --git a/t/lib/io_unix.t b/t/lib/io_unix.t index 3d9ed50f56..1d7842b6dc 100644 --- a/t/lib/io_unix.t +++ b/t/lib/io_unix.t @@ -1,4 +1,3 @@ - #!./perl BEGIN { @@ -4964,7 +4964,6 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) bool oldcatch = CATCH_GET; SV **cvp; SV *cv, *typesv; - char buf[128]; if (!table) { yyerror("%^H is not defined"); @@ -4972,6 +4971,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) } cvp = hv_fetch(table, key, strlen(key), FALSE); if (!cvp || !SvOK(*cvp)) { + char buf[128]; sprintf(buf,"$^H{%s} is not defined", key); yyerror(buf); return sv; @@ -5017,6 +5017,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type) POPSTACK; if (!SvOK(res)) { + char buf[128]; sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key); yyerror(buf); } @@ -2458,7 +2458,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) dTHR; char *xfound = Nullch; char *xfailed = Nullch; - char tmpbuf[512]; + char tmpbuf[MAXPATHLEN]; register char *s; I32 len; int retval; |