require Exporter;
@ISA = qw(Exporter DynaLoader);
@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
- class peekop cast_I32 ad cstring cchar hash
+ class peekop cast_I32 cstring cchar hash
main_root main_start main_cv svref_2object
- walkoptree walkoptree_exec walksymtable
- comppadlist sv_undef compile_stats timing_info);
+ walkoptree walkoptree_slow walkoptree_exec walksymtable
+ parents comppadlist sv_undef compile_stats timing_info);
use strict;
@B::SV::ISA = 'B::OBJECT';
my $debug;
my $op_count = 0;
+my @parents = ();
sub debug {
my ($class, $value) = @_;
# add to .xs for perl5.002
sub OPf_KIDS () { 4 }
-sub ad {
- my $obj = shift;
- return $$obj;
-}
-
sub class {
my $obj = shift;
my $name = ref $obj;
return $name;
}
+sub parents { \@parents }
+
# For debugging
sub peekop {
my $op = shift;
return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
}
-sub walkoptree {
+sub walkoptree_slow {
my($op, $method, $level) = @_;
$op_count++; # just for statistics
$level ||= 0;
warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
$op->$method($level);
- if (ad($op) && ($op->flags & OPf_KIDS)) {
+ if ($$op && ($op->flags & OPf_KIDS)) {
my $kid;
+ unshift(@parents, $op);
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
- walkoptree($kid, $method, $level + 1);
+ walkoptree_slow($kid, $method, $level + 1);
}
+ shift @parents;
}
}
my %symtable;
sub savesym {
my ($obj, $value) = @_;
-# warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
- $symtable{sprintf("sym_%x", ad($obj))} = $value;
+# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
}
sub objsym {
my $obj = shift;
- return $symtable{sprintf("sym_%x", ad($obj))};
+ return $symtable{sprintf("sym_%x", $$obj)};
}
sub walkoptree_exec {
print $prefix, "goto $sym\n";
return;
}
- savesym($op, sprintf("%s (0x%lx)", class($op), ad($op)));
+ savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
$op->$method($level);
$ppname = $op->ppaddr;
if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
print $prefix, "}\n";
} elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
my $pmreplstart = $op->pmreplstart;
- if (ad($pmreplstart)) {
+ if ($$pmreplstart) {
print $prefix, "PMREPLSTART => {\n";
walkoptree_exec($pmreplstart, $method, $level + 1);
print $prefix, "}\n";
print $prefix, "}\n";
} elsif ($ppname eq "pp_subst") {
my $replstart = $op->pmreplstart;
- if (ad($replstart)) {
+ if ($$replstart) {
print $prefix, "SUBST => {\n";
walkoptree_exec($replstart, $method, $level + 1);
print $prefix, "}\n";
}
sub walksymtable {
- my ($symref, $method, $recurse) = @_;
+ my ($symref, $method, $recurse, $prefix) = @_;
my $sym;
no strict 'vars';
local(*glob);
while (($sym, *glob) = each %$symref) {
if ($sym =~ /::$/) {
+ $sym = $prefix . $sym;
if ($sym ne "main::" && &$recurse($sym)) {
- walksymtable(\%glob, $method, $recurse);
+ walksymtable(\%glob, $method, $recurse, $sym);
}
} else {
svref_2object(\*glob)->EGV->$method();
}
#endif /* INDIRECT_BGET_MACROS */
+void
+walkoptree(opsv, method)
+SV *opsv;
+char *method;
+{
+ dSP;
+ OP *o;
+
+ if (!SvROK(opsv))
+ croak("opsv is not a reference");
+ opsv = sv_mortalcopy(opsv);
+ o = (OP*)SvIV((SV*)SvRV(opsv));
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method(method, G_DISCARD);
+ if (o && (o->op_flags & OPf_KIDS)) {
+ OP *kid;
+ for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
+ /* Use the same opsv. Rely on methods not to mess it up. */
+ sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid);
+ walkoptree(opsv, method);
+ }
+ }
+}
typedef OP *B__OP;
typedef UNOP *B__UNOP;
void
+walkoptree(opsv, method)
+ SV * opsv
+ char * method
+
+int
byteload_fh(fp)
FILE * fp
+ CODE:
+ byteload_fh(fp);
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
void
byteload_string(str)
#define OP_next(o) o->op_next
#define OP_sibling(o) o->op_sibling
#define OP_ppaddr(o) ppnames[o->op_type]
+#define OP_desc(o) op_desc[o->op_type]
#define OP_targ(o) o->op_targ
#define OP_type(o) o->op_type
#define OP_seq(o) o->op_seq
OP_ppaddr(o)
B::OP o
+char *
+OP_desc(o)
+ B::OP o
+
U16
OP_targ(o)
B::OP o
@ISA = "Exporter";
@EXPORT_OK = qw(find_leaders);
-use B qw(ad peekop walkoptree walkoptree_exec
+use B qw(peekop walkoptree walkoptree_exec
main_root main_start svref_2object);
use B::Terse;
use strict;
sub mark_leader {
my $op = shift;
- if (ad($op)) {
- $bblock->{ad($op)} = $op;
+ if ($$op) {
+ $bblock->{$$op} = $op;
}
}
while ($leader = shift @leaders) {
$lastop = $leader;
$op = $leader->next;
- while (ad($op) && !exists($bblock->{ad($op)})) {
- $bblock->{ad($op)} = $leader;
+ while ($$op && !exists($bblock->{$$op})) {
+ $bblock->{$$op} = $leader;
$lastop = $op;
$op = $op->next;
}
foreach $bb (@bblock_ends) {
($leader, $lastop) = @$bb;
printf "%s .. %s\n", peekop($leader), peekop($lastop);
- for ($op = $leader; ad($op) != ad($lastop); $op = $op->next) {
+ for ($op = $leader; $$op != $$lastop; $op = $op->next) {
printf " %s\n", peekop($op);
}
printf " %s\n", peekop($lastop);
my $op = shift;
if ($op->ppaddr ne "pp_pushre") {
my $replroot = $op->pmreplroot;
- if (ad($replroot)) {
+ if ($$replroot) {
mark_leader($replroot);
mark_leader($op->next);
mark_leader($op->pmreplstart);
use strict;
use Carp;
-use B qw(ad minus_c main_cv main_root main_start comppadlist
+use B qw(minus_c main_cv main_root main_start comppadlist
class peekop walkoptree svref_2object cstring walksymtable);
use B::Asmdata qw(@optype @specialsv_name);
use B::Assembler qw(assemble_fh);
}
}
-sub saved { $saved{ad($_[0])} }
-sub mark_saved { $saved{ad($_[0])} = 1 }
-sub unmark_saved { $saved{ad($_[0])} = 0 }
+sub saved { $saved{${$_[0]}} }
+sub mark_saved { $saved{${$_[0]}} = 1 }
+sub unmark_saved { $saved{${$_[0]}} = 0 }
my $debug = 0;
sub debug { $debug = shift }
sub B::OBJECT::nyi {
my $obj = shift;
warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
- class($obj), ad($obj));
+ class($obj), $$obj);
}
#
my $type = $op->type;
if ($bypass_nullops) {
- $next = $next->next while ad($next) && $next->type == 0;
+ $next = $next->next while $$next && $next->type == 0;
}
$nextix = $next->objix;
#my $pmnextix = $op->pmnext->objix;
$short->bytecode;
- if (ad($replroot)) {
+ if ($$replroot) {
# OP_PUSHRE (a mutated version of OP_MATCH for the regexp
# argument to a split) stores a GV in op_pmreplroot instead
# of a substitution syntax tree. We don't want to walk that...
sub B::RV::bytecode {
my $sv = shift;
return if saved($sv);
- my $rvix = $sv->RV->objix;
+ my $rv = $sv->RV;
+ my $rvix = $rv->objix;
+ $rv->bytecode;
$sv->B::SV::bytecode;
print "xrv $rvix\n";
}
if (!$name) {
# It's an ordinary HV. Stashes have NAME set and need no further
# saving beyond the gv_stashpv that $hv->objix already ensures.
- #
- # XXX We don't yet save the contents of non-empty HVs
+ my @contents = $hv->ARRAY;
+ my ($i, @ixes);
+ for ($i = 1; $i < @contents; $i += 2) {
+ push(@ixes, $contents[$i]->objix);
+ }
+ for ($i = 1; $i < @contents; $i += 2) {
+ $contents[$i]->bytecode;
+ }
ldsv($ix);
+ for ($i = 0; $i < @contents; $i += 2) {
+ printf("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;
}
}
my @ixes = map($_->objix, @subfields);
# Save OP tree from CvROOT (first element of @subfields)
my $root = shift @subfields;
- if (ad($root)) {
+ if ($$root) {
walkoptree($root, "bytecode");
}
# Reset sv register for $cv (since above ->objix calls stomped on it)
sub B::GV::bytecodecv {
my $gv = shift;
my $cv = $gv->CV;
- if (ad($cv) && !saved($cv)) {
+ if ($$cv && !saved($cv)) {
if ($debug_cv) {
warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
- $gv->STASH->NAME, $gv->NAME, ad($cv), ad($gv));
+ $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
}
$gv->bytecode;
}
B->debug(1);
} elsif ($arg eq "a") {
B::Assembler::debug(1);
- } elsif ($arg eq "D") {
+ } elsif ($arg eq "C") {
$debug_cv = 1;
}
}
output_main set_callback save_unused_subs objsym);
use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start
- ad peekop class cstring cchar svref_2object compile_stats
+ peekop class cstring cchar svref_2object compile_stats
comppadlist hash);
use B::Asmdata qw(@specialsv_name);
sub savesym {
my ($obj, $value) = @_;
-# warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
- $symtable{sprintf("sym_%x", ad($obj))} = $value;
+# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
}
sub objsym {
my $obj = shift;
- return $symtable{sprintf("sym_%x", ad($obj))};
+ return $symtable{sprintf("sym_%x", $$obj)};
}
sub getsym {
$nullop_count++ unless $type;
push(@op_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
$type, $op_seq, $op->flags, $op->private));
savesym($op, "&op_list[$#op_list]");
}
my ($op, $level) = @_;
push(@unop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
- $op->type, $op_seq, $op->flags,$op->private,ad($op->first)));
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags,$op->private,${$op->first}));
savesym($op, "(OP*)&unop_list[$#unop_list]");
}
my ($op, $level) = @_;
push(@binop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
$op->type, $op_seq, $op->flags, $op->private,
- ad($op->first), ad($op->last)));
+ ${$op->first}, ${$op->last}));
savesym($op, "(OP*)&binop_list[$#binop_list]");
}
my ($op, $level) = @_;
push(@listop_list, sprintf(
"sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x, %u",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
- $op->type, $op_seq, $op->flags, $op->private, ad($op->first),
- ad($op->last), $op->children));
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private, ${$op->first},
+ ${$op->last}, $op->children));
savesym($op, "(OP*)&listop_list[$#listop_list]");
}
my ($op, $level) = @_;
push(@logop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
$op->type, $op_seq, $op->flags, $op->private,
- ad($op->first), ad($op->other)));
+ ${$op->first}, ${$op->other}));
savesym($op, "(OP*)&logop_list[$#logop_list]");
}
my ($op, $level) = @_;
push(@condop_list, sprintf(
"sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x, sym_%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
- $op->type, $op_seq, $op->flags, $op->private, ad($op->first),
- ad($op->true), ad($op->false)));
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private, ${$op->first},
+ ${$op->true}, ${$op->false}));
savesym($op, "(OP*)&condop_list[$#condop_list]");
}
push(@loop_list, sprintf(
"sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, "
."sym_%x, sym_%x, %u, sym_%x, sym_%x, sym_%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ, $op->type,
- $op_seq, $op->flags, $op->private, ad($op->first), ad($op->last),
- $op->children, ad($op->redoop), ad($op->nextop), ad($op->lastop)));
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type,
+ $op_seq, $op->flags, $op->private, ${$op->first}, ${$op->last},
+ $op->children, ${$op->redoop}, ${$op->nextop}, ${$op->lastop}));
savesym($op, "(OP*)&loop_list[$#loop_list]");
}
my ($op, $level) = @_;
push(@pvop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
$op->type, $op_seq, $op->flags, $op->private,
cstring($op->pv)));
savesym($op, "(OP*)&pvop_list[$#pvop_list]");
sub B::SVOP::save {
my ($op, $level) = @_;
+ my $svsym = $op->sv->save;
push(@svop_list,
- sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, (SV*)sym_%x",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
- $op->type, $op_seq, $op->flags, $op->private, ad($op->sv)));
+ sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private, "(SV*)$svsym"));
savesym($op, "(OP*)&svop_list[$#svop_list]");
-# warn sprintf("svop saving sv %s 0x%x\n", ref($op->sv), ad($op->sv));#debug
- $op->sv->save;
+# warn sprintf("svop saving sv %s 0x%x\n", ref($op->sv), ${$op->sv});#debug
}
sub B::GVOP::save {
my $gvsym = $op->gv->save;
push(@gvop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
$op->type, $op_seq, $op->flags, $op->private));
push_init(sprintf("gvop_list[$#gvop_list].op_gv = %s;", $gvsym));
savesym($op, "(OP*)&gvop_list[$#gvop_list]");
push(@cop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, "
."Nullhv, Nullgv, %u, %d, %u",
- ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
$op->type, $op_seq, $op->flags, $op->private,
cstring($op->label), $op->cop_seq, $op->arybase, $op->line));
push_init(sprintf("cop_list[$#cop_list].cop_filegv = %s;", $gvsym),
my $shortsym = $op->pmshort->save;
my $replroot = $op->pmreplroot;
my $replstart = $op->pmreplstart;
- my $replrootfield = sprintf("sym_%x", ad($replroot));
- my $replstartfield = sprintf("sym_%x", ad($replstart));
+ my $replrootfield = sprintf("sym_%x", $$replroot);
+ my $replstartfield = sprintf("sym_%x", $$replstart);
my $gvsym;
my $ppaddr = $op->ppaddr;
- if (ad($replroot)) {
+ if ($$replroot) {
# OP_PUSHRE (a mutated version of OP_MATCH for the regexp
# argument to a split) stores a GV in op_pmreplroot instead
# of a substitution syntax tree. We don't want to walk that...
push(@pmop_list,
sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x,"
." %u, %s, %s, 0, 0, %s, 0x%x, 0x%x, %u",
- ad($op->next), ad($op->sibling), $ppaddr, $op->targ,
+ ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
$op->type, $op_seq, $op->flags, $op->private,
- ad($op->first), ad($op->last), $op->children,
+ ${$op->first}, ${$op->last}, $op->children,
$replrootfield, $replstartfield,
$shortsym, $op->pmflags, $op->pmpermflags, $op->pmslen));
my $pm = "pmop_list[$#pmop_list]";
sub B::PVMG::save_magic {
my ($sv) = @_;
- #warn sprintf("saving magic for %s (0x%x)\n", class($sv), ad($sv)); # debug
+ #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
my $stash = $sv->SvSTASH;
- if (ad($stash)) {
- warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, ad($stash))
+ if ($$stash) {
+ warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
if $debug_mg;
# XXX Hope stash is already going to be saved.
- push_init(sprintf("SvSTASH(sym_%x) = sym_%x;", ad($sv), ad($stash)));
+ push_init(sprintf("SvSTASH(sym_%x) = sym_%x;", $$sv, $$stash));
}
my @mgchain = $sv->MAGIC;
my ($mg, $type, $obj, $ptr);
my $len = defined($ptr) ? length($ptr) : 0;
if ($debug_mg) {
warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
- class($sv), ad($sv), class($obj), ad($obj),
+ class($sv), $$sv, class($obj), $$obj,
cchar($type), cstring($ptr));
}
push_init(sprintf("sv_magic((SV*)sym_%x, (SV*)sym_%x, %s, %s, %d);",
- ad($sv), ad($obj), cchar($type),cstring($ptr),$len));
+ $$sv, $$obj, cchar($type),cstring($ptr),$len));
}
}
return savesym($sv, "&sv_list[$#sv_list]");
}
+sub try_autoload {
+ my ($cvstashname, $cvname) = @_;
+ warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
+ # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
+ # use should be handled by the class itself.
+ no strict 'refs';
+ my $isa = \@{"$cvstashname\::ISA"};
+ if (grep($_ eq "AutoLoader", @$isa)) {
+ warn "Forcing immediate load of sub derived from AutoLoader\n";
+ # Tweaked version of AutoLoader::AUTOLOAD
+ my $dir = $cvstashname;
+ $dir =~ s(::)(/)g;
+ eval { require "auto/$dir/$cvname.al" };
+ if ($@) {
+ warn qq(failed require "auto/$dir/$cvname.al": $@\n);
+ return 0;
+ } else {
+ return 1;
+ }
+ }
+}
+
sub B::CV::save {
my ($cv) = @_;
my $sym = objsym($cv);
if (defined($sym)) {
-# warn sprintf("CV 0x%x already saved as $sym\n", ad($cv)); # debug
+# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
return $sym;
}
# Reserve a place on sv_list and xpvcv_list and record indices
my $xpvcv_ix = $#xpvcv_list;
# Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
$sym = savesym($cv, "&sv_list[$sv_ix]");
- warn sprintf("saving CV 0x%x as $sym\n", ad($cv)) if $debug_cv;
+ warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
my $gv = $cv->GV;
+ my $cvstashname = $gv->STASH->NAME;
+ my $cvname = $gv->NAME;
my $root = $cv->ROOT;
+ my $cvxsub = $cv->XSUB;
+ if (!$$root && !$cvxsub) {
+ if (try_autoload($cvstashname, $cvname)) {
+ # Recalculate root and xsub
+ $root = $cv->ROOT;
+ $cvxsub = $cv->XSUB;
+ if ($$root || $cvxsub) {
+ warn "Successful forced autoload\n";
+ }
+ }
+ }
my $startfield = 0;
my $padlist = $cv->PADLIST;
- if (ad($root)) {
+ my $pv = $cv->PV;
+ my $xsub = 0;
+ my $xsubany = "Nullany";
+ if ($$root) {
warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
- ad($cv), ad($root)) if $debug_cv;
+ $$cv, $$root) if $debug_cv;
my $ppname;
- if (ad($gv)) {
+ if ($$gv) {
my $stashname = $gv->STASH->NAME;
my $gvname = $gv->NAME;
- $ppname = "pp_sub_";
- $ppname .= $stashname eq "main" ? $gvname : "$stashname\::$gvname";
- $ppname =~ s/::/__/g;
- } else {
+ my $ppname = "";
+ if ($gvname ne "__ANON__") {
+ $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
+ $ppname .= ($stashname eq "main") ?
+ $gvname : "$stashname\::$gvname";
+ $ppname =~ s/::/__/g;
+ }
+ }
+ if (!$ppname) {
$ppname = "pp_anonsub_$anonsub_index";
$anonsub_index++;
}
$startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
- ad($cv), $ppname, ad($root)) if $debug_cv;
- }
- if (ad($padlist)) {
- warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
- ad($padlist), ad($cv)) if $debug_cv;
- $padlist->save;
- warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
- ad($padlist), ad($cv)) if $debug_cv;
+ $$cv, $ppname, $$root) if $debug_cv;
+ if ($$padlist) {
+ warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
+ $$padlist, $$cv) if $debug_cv;
+ $padlist->save;
+ warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
+ $$padlist, $$cv) if $debug_cv;
+ }
}
- my $pv = $cv->PV;
- my $xsub = 0;
- my $xsubany = "Nullany";
- if ($cv->XSUB) {
+ elsif ($cvxsub) {
$xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
- # Find out canonical name of XSUB function from EGV (I hope)
+ # Try to find out canonical name of XSUB function from EGV.
+ # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
+ # calls newXS() manually with weird arguments).
my $egv = $gv->EGV;
my $stashname = $egv->STASH->NAME;
$stashname =~ s/::/__/g;
$xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
push(@decl_list, "void $xsub _((CV*));");
}
+ else {
+ warn "No definition for sub %s::%s (unable to autoload)\n",
+ $cvstashname, $cvname; # debug
+ }
$xpvcv_list[$xpvcv_ix] = sprintf(
"%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, sym_%lx, $xsub, $xsubany,".
" Nullgv, Nullgv, %d, sym_%lx, (CV*)sym_%lx, 0",
cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield,
- ad($cv->ROOT), $cv->DEPTH, ad($padlist), ad($cv->OUTSIDE));
- if (ad($gv)) {
+ ${$cv->ROOT}, $cv->DEPTH, $$padlist, ${$cv->OUTSIDE});
+ if ($$gv) {
$gv->save;
- push_init(sprintf("CvGV(sym_%lx) = sym_%lx;",ad($cv),ad($gv)));
+ push_init(sprintf("CvGV(sym_%lx) = sym_%lx;",$$cv,$$gv));
warn sprintf("done saving GV 0x%x for CV 0x%x\n",
- ad($gv), ad($cv)) if $debug_cv;
+ $$gv, $$cv) if $debug_cv;
}
my $filegv = $cv->FILEGV;
- if (ad($filegv)) {
+ if ($$filegv) {
$filegv->save;
- push_init(sprintf("CvFILEGV(sym_%lx) = sym_%lx;",ad($cv),ad($filegv)));
+ push_init(sprintf("CvFILEGV(sym_%lx) = sym_%lx;",$$cv,$$filegv));
warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
- ad($filegv), ad($cv)) if $debug_cv;
+ $$filegv, $$cv) if $debug_cv;
}
my $stash = $cv->STASH;
- if (ad($stash)) {
+ if ($$stash) {
$stash->save;
- push_init(sprintf("CvSTASH(sym_%lx) = sym_%lx;", ad($cv), ad($stash)));
+ push_init(sprintf("CvSTASH(sym_%lx) = sym_%lx;", $$cv, $$stash));
warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
- ad($stash), ad($cv)) if $debug_cv;
+ $$stash, $$cv) if $debug_cv;
}
$sv_list[$sv_ix] = sprintf("(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
$xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS);
my ($gv) = @_;
my $sym = objsym($gv);
if (defined($sym)) {
- #warn sprintf("GV 0x%x already saved as $sym\n", ad($gv)); # debug
+ #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
return $sym;
} else {
my $ix = $gv_index++;
$sym = savesym($gv, "gv_list[$ix]");
- #warn sprintf("Saving GV 0x%x as $sym\n", ad($gv)); # debug
+ #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
}
my $gvname = $gv->NAME;
my $name = cstring($gv->STASH->NAME . "::" . $gvname);
#warn "GV name is $name\n"; # debug
my $egv = $gv->EGV;
my $egvsym;
- if (ad($gv) != ad($egv)) {
+ if ($$gv != $$egv) {
#warn(sprintf("EGV name is %s, saving it now\n",
# $egv->STASH->NAME . "::" . $egv->NAME)); # debug
$egvsym = $egv->save;
# Don't save subfields of special GVs (*_, *1, *# and so on)
# warn "GV::save saving subfields\n"; # debug
my $gvsv = $gv->SV;
- if (ad($gvsv)) {
- push_init(sprintf("GvSV($sym) = sym_%x;", ad($gvsv)));
+ if ($$gvsv) {
+ push_init(sprintf("GvSV($sym) = sym_%x;", $$gvsv));
# warn "GV::save \$$name\n"; # debug
$gvsv->save;
}
my $gvav = $gv->AV;
- if (ad($gvav)) {
- push_init(sprintf("GvAV($sym) = sym_%x;", ad($gvav)));
+ if ($$gvav) {
+ push_init(sprintf("GvAV($sym) = sym_%x;", $$gvav));
# warn "GV::save \@$name\n"; # debug
$gvav->save;
}
my $gvhv = $gv->HV;
- if (ad($gvhv)) {
- push_init(sprintf("GvHV($sym) = sym_%x;", ad($gvhv)));
+ if ($$gvhv) {
+ push_init(sprintf("GvHV($sym) = sym_%x;", $$gvhv));
# warn "GV::save \%$name\n"; # debug
$gvhv->save;
}
my $gvcv = $gv->CV;
- if (ad($gvcv)) {
- push_init(sprintf("GvCV($sym) = (CV*)sym_%x;", ad($gvcv)));
+ if ($$gvcv) {
+ push_init(sprintf("GvCV($sym) = (CV*)sym_%x;", $$gvcv));
# warn "GV::save &$name\n"; # debug
$gvcv->save;
}
my $gvfilegv = $gv->FILEGV;
- if (ad($gvfilegv)) {
- push_init(sprintf("GvFILEGV($sym) = sym_%x;",ad($gvfilegv)));
+ if ($$gvfilegv) {
+ push_init(sprintf("GvFILEGV($sym) = sym_%x;",$$gvfilegv));
# warn "GV::save GvFILEGV(*$name)\n"; # debug
$gvfilegv->save;
}
my $gvform = $gv->FORM;
- if (ad($gvform)) {
- push_init(sprintf("GvFORM($sym) = (CV*)sym_%x;", ad($gvform)));
+ if ($$gvform) {
+ push_init(sprintf("GvFORM($sym) = (CV*)sym_%x;", $$gvform));
# warn "GV::save GvFORM(*$name)\n"; # debug
$gvform->save;
}
my $gvio = $gv->IO;
- if (ad($gvio)) {
- push_init(sprintf("GvIOp($sym) = sym_%x;", ad($gvio)));
+ if ($$gvio) {
+ push_init(sprintf("GvIOp($sym) = sym_%x;", $$gvio));
# warn "GV::save GvIO(*$name)\n"; # debug
$gvio->save;
}
my $sv_list_index = $#sv_list;
my $fill = $av->FILL;
$av->save_magic;
- warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", ad($av), $avflags)
+ warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
if $debug_av;
# XXX AVf_REAL is wrong test: need to save comppadlist but not stack
#if ($fill > -1 && ($avflags & AVf_REAL)) {
my $i = 0;
foreach $el (@array) {
warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
- ad($av), $i++, class($el), ad($el));
+ $$av, $i++, class($el), $$el);
}
}
my @names = map($_->save, @array);
# A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
# the only symptom is that sv_reset tries to reset the PMf_USED flag of
# a trashed op but we look at the trashed op_type and segfault.
- #my $adpmroot = ad($hv->PMROOT);
+ #my $adpmroot = ${$hv->PMROOT};
my $adpmroot = 0;
push(@decl_list, "static HV *hv$hv_index;");
# XXX Beware of weird package names containing double-quotes, \n, ...?
my ($field, $fsym);
foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
$fsym = $io->$field();
- if (ad($fsym)) {
- push_init(sprintf("Io$field($sym) = (GV*)sym_%x;", ad($fsym)));
+ if ($$fsym) {
+ push_init(sprintf("Io$field($sym) = (GV*)sym_%x;", $$fsym));
$fsym->save;
}
}
my $sv = shift;
# This is where we catch an honest-to-goodness Nullsv (which gets
# blessed into B::SV explicitly) and any stray erroneous SVs.
- return 0 unless ad($sv);
+ return 0 unless $$sv;
confess sprintf("cannot save that type of SV: %s (0x%x)\n",
- class($sv), ad($sv));
+ class($sv), $$sv);
}
sub output_all {
#include "EXTERN.h"
#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
#ifdef __cplusplus
}
my $gv = shift;
my $cv = $gv->CV;
my $name = $gv->NAME;
- if (ad($cv) && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
+ if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
if ($debug_cv) {
warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
- $gv->STASH->NAME, $name, ad($cv), ad($gv));
+ $gv->STASH->NAME, $name, $$cv, $$gv);
}
$gv->save;
}
sub save_unused_subs {
my %search_pack;
- map { $search_pack{"$_\::"} = 1 } @_;
+ map { $search_pack{$_} = 1 } @_;
no strict qw(vars refs);
- walksymtable(\%{"main::"}, "savecv", sub { exists($search_pack{$_[0]}) });
+ walksymtable(\%{"main::"}, "savecv", sub {
+ my $package = shift;
+ $package =~ s/::$//;
+ #warn "Considering $package\n";#debug
+ return 1 if exists $search_pack{$package};
+ #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;
+ }
+ my $m;
+ foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
+ if (defined(&{$package."::$m"})) {
+ warn "$package has method $m: -u$package assumed\n";#debug
+ return 1;
+ }
+ }
+ return 0;
+ });
}
sub save_main {
my $curpad_sym = (comppadlist->ARRAY)[1]->save;
walkoptree(main_root, "save");
- if (@unused_sub_packages) {
- warn "done main optree, walking symtable for extras\n" if $debug_cv;
- save_unused_subs(@unused_sub_packages);
- }
- push_init(sprintf("main_root = sym_%x;", ad(main_root)),
- sprintf("main_start = sym_%x;", ad(main_start)),
+ warn "done main optree, walking symtable for extras\n" if $debug_cv;
+ save_unused_subs(@unused_sub_packages);
+
+ push_init(sprintf("main_root = sym_%x;", ${main_root()}),
+ sprintf("main_start = sym_%x;", ${main_start()}),
"curpad = AvARRAY($curpad_sym);");
output_boilerplate();
print "\n";
#
package B::CC;
use strict;
-use B qw(main_start main_root class comppadlist peekop svref_2object ad
+use B qw(main_start main_root class comppadlist peekop svref_2object
timing_info);
use B::C qw(push_decl init_init push_init save_unused_subs objsym
output_all output_boilerplate output_main);
sub CXt_SUBST () { 4 }
sub CXt_BLOCK () { 5 }
+my $module; # module name (when compiled with -m)
my %done; # hash keyed by $$op of leaders of basic blocks
# which have already been done.
my $leaders; # ref to hash of basic block leaders. Keys are $$op
my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
my %constobj; # OP_CONST constants as Stackobj-derived objects
- # keyed by ad($sv).
+ # keyed by $$sv.
my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
# block or even to the end of each loop of blocks,
# depending on optimisation options.
sub pp_const {
my $op = shift;
my $sv = $op->sv;
- my $obj = $constobj{ad($sv)};
+ my $obj = $constobj{$$sv};
if (!defined($obj)) {
- $obj = $constobj{ad($sv)} = new B::Stackobj::Const ($sv);
+ $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
}
push(@stack, $obj);
return $op->next;
return $op->next;
}
+sub pp_enterwrite {
+ my $op = shift;
+ pp_entersub($op);
+}
+
+sub pp_leavewrite {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ # XXX Is this the right way to distinguish between it returning
+ # CvSTART(cv) (via doform) and pop_return()?
+ runtime("if (op) op = (*op->op_ppaddr)();");
+ runtime("SPAGAIN;");
+ $know_op = 0;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
sub doeval {
my $op = shift;
$curcop->write_back;
write_back_stack();
my $sym = doop($op);
my $replroot = $op->pmreplroot;
- if (ad($replroot)) {
+ if ($$replroot) {
runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
$sym, label($replroot));
$op->pmreplstart->save;
write_back_stack();
doop($op);
my $pmop = $op->other;
- 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
runtime sprintf("if (op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
$pmopsym, label($pmop->pmreplstart));
invalidate_lexicals();
my @comppadlist = comppadlist->ARRAY;
my $curpad_sym = $comppadlist[1]->save;
my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
- if (@unused_sub_packages) {
- save_unused_subs(@unused_sub_packages);
- # That only queues them. Now we need to generate code for them.
- cc_recurse();
- }
+ save_unused_subs(@unused_sub_packages);
+ cc_recurse();
+
return if $errors;
- push_init(sprintf("main_root = sym_%x;", ad(main_root)),
- "main_start = $start;",
- "curpad = AvARRAY($curpad_sym);");
+ if (!defined($module)) {
+ push_init(sprintf("main_root = sym_%x;", ${main_root()}),
+ "main_start = $start;",
+ "curpad = AvARRAY($curpad_sym);");
+ }
output_boilerplate();
print "\n";
output_all("perl_init");
output_runtime();
print "\n";
output_main();
+ if (defined($module)) {
+ my $cmodule = $module;
+ $cmodule =~ s/::/__/g;
+ print <<"EOT";
+
+#include "XSUB.h"
+XS(boot_$cmodule)
+{
+ dXSARGS;
+ perl_init();
+ ENTER;
+ SAVETMPS;
+ SAVESPTR(curpad);
+ SAVESPTR(op);
+ curpad = AvARRAY($curpad_sym);
+ op = $start;
+ pp_main(ARGS);
+ FREETMPS;
+ LEAVE;
+ ST(0) = &sv_yes;
+ XSRETURN(1);
+}
+EOT
+ }
if ($debug_timings) {
warn sprintf("Done at %s\n", timing_info);
}
if ($arg >= 1) {
$freetmps_each_bblock = 1 unless $freetmps_each_loop;
}
+ } elsif ($opt eq "m") {
+ $module = $arg;
} elsif ($opt eq "D") {
$arg ||= shift @options;
foreach $arg (split(//, $arg)) {
package B::Debug;
use strict;
-use B qw(peekop class ad walkoptree walkoptree_exec
+use B qw(peekop class walkoptree walkoptree_exec
main_start main_root cstring sv_undef);
use B::Asmdata qw(@specialsv_name);
+my %done_gv;
+
sub B::OP::debug {
my ($op) = @_;
- printf <<'EOT', class($op), ad($op), ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
+ printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
%s (0x%lx)
op_next 0x%x
op_sibling 0x%x
sub B::UNOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_first\t0x%x\n", ad($op->first);
+ printf "\top_first\t0x%x\n", ${$op->first};
}
sub B::BINOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
- printf "\top_last\t\t0x%x\n", ad($op->last);
+ printf "\top_last\t\t0x%x\n", ${$op->last};
}
sub B::LOGOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
- printf "\top_other\t0x%x\n", ad($op->other);
+ printf "\top_other\t0x%x\n", ${$op->other};
}
sub B::CONDOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
- printf "\top_true\t0x%x\n", ad($op->true);
- printf "\top_false\t0x%x\n", ad($op->false);
+ printf "\top_true\t0x%x\n", ${$op->true};
+ printf "\top_false\t0x%x\n", ${$op->false};
}
sub B::LISTOP::debug {
sub B::PMOP::debug {
my ($op) = @_;
$op->B::LISTOP::debug();
- printf "\top_pmreplroot\t0x%x\n", ad($op->pmreplroot);
- printf "\top_pmreplstart\t0x%x\n", ad($op->pmreplstart);
- printf "\top_pmnext\t0x%x\n", ad($op->pmnext);
+ printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
+ printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
+ printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
- printf "\top_pmshort\t0x%x\n", ad($op->pmshort);
+ printf "\top_pmshort\t0x%x\n", ${$op->pmshort};
printf "\top_pmflags\t0x%x\n", $op->pmflags;
printf "\top_pmslen\t%d\n", $op->pmslen;
$op->pmshort->debug;
my ($op) = @_;
$op->B::OP::debug();
my ($filegv) = $op->filegv;
- printf <<'EOT', $op->label, ad($op->stash), ad($filegv), $op->seq, $op->arybase, $op->line;
+ printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line;
cop_label %s
cop_stash 0x%x
cop_filegv 0x%x
sub B::SVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_sv\t\t0x%x\n", ad($op->sv);
+ printf "\top_sv\t\t0x%x\n", ${$op->sv};
$op->sv->debug;
}
sub B::GVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_gv\t\t0x%x\n", ad($op->gv);
+ printf "\top_gv\t\t0x%x\n", ${$op->gv};
+ $op->gv->debug;
}
sub B::CVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_cv\t\t0x%x\n", ad($op->cv);
+ printf "\top_cv\t\t0x%x\n", ${$op->cv};
}
sub B::NULL::debug {
my ($sv) = @_;
- if (ad($sv) == ad(sv_undef())) {
+ if ($$sv == ${sv_undef()}) {
print "&sv_undef\n";
} else {
- printf "NULL (0x%x)\n", ad($sv);
+ printf "NULL (0x%x)\n", $$sv;
}
}
print class($sv), " = NULL\n";
return;
}
- printf <<'EOT', class($sv), ad($sv), $sv->REFCNT, $sv->FLAGS;
+ printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
%s (0x%x)
REFCNT %d
FLAGS 0x%x
my ($padlist) = $sv->PADLIST;
my ($gv) = $sv->GV;
my ($filegv) = $sv->FILEGV;
- printf <<'EOT', ad($stash), ad($start), ad($root), ad($gv), ad($filegv), $sv->DEPTH, $padlist, ad($sv->OUTSIDE);
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
STASH 0x%x
START 0x%x
ROOT 0x%x
my ($av) = @_;
$av->B::SV::debug;
my(@array) = $av->ARRAY;
- print "\tARRAY\t\t(", join(", ", map("0x" . ad($_), @array)), ")\n";
+ print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
FILL %d
MAX %d
sub B::GV::debug {
my ($gv) = @_;
+ if ($done_gv{$$gv}++) {
+ printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME;
+ return;
+ }
my ($sv) = $gv->SV;
my ($av) = $gv->AV;
my ($cv) = $gv->CV;
$gv->B::SV::debug;
- printf <<'EOT', $gv->NAME, $gv->STASH, ad($sv), $gv->GvREFCNT, $gv->FORM, ad($av), ad($gv->HV), ad($gv->EGV), ad($cv), $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
+ printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
NAME %s
- STASH 0x%x
+ STASH %s (0x%x)
SV 0x%x
GvREFCNT %d
FORM 0x%x
--- /dev/null
+package B::Deparse;
+use strict;
+use B qw(peekop class main_root);
+
+my $debug;
+
+sub compile {
+ my $opt = shift;
+ if ($opt eq "-d") {
+ $debug = 1;
+ }
+ return sub { print deparse(main_root), "\n" }
+}
+
+sub ppname {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ warn sprintf("ppname %s\n", peekop($op)) if $debug;
+ no strict "refs";
+ return defined(&$ppname) ? &$ppname($op) : 0;
+}
+
+sub deparse {
+ my $op = shift;
+ my $expr;
+ warn sprintf("deparse %s\n", peekop($op)) if $debug;
+ while (ref($expr = ppname($op))) {
+ $op = $expr;
+ warn sprintf("Redirecting to %s\n", peekop($op)) if $debug;
+ }
+ return $expr;
+}
+
+sub pp_leave {
+ my $op = shift;
+ my ($child, $expr);
+ for ($child = $op->first; !$expr; $child = $child->sibling) {
+ $expr = ppname($child);
+ }
+ return $expr;
+}
+
+sub SWAP_CHILDREN () { 1 }
+
+sub binop {
+ my ($op, $opname, $flags) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ if ($flags & SWAP_CHILDREN) {
+ ($left, $right) = ($right, $left);
+ }
+ warn sprintf("binop deparsing first %s\n", peekop($op->first)) if $debug;
+ $left = deparse($left);
+ warn sprintf("binop deparsing last %s\n", peekop($op->last)) if $debug;
+ $right = deparse($right);
+ return "($left $opname $right)";
+}
+
+sub pp_add { binop($_[0], "+") }
+sub pp_multiply { binop($_[0], "*") }
+sub pp_subtract { binop($_[0], "-") }
+sub pp_divide { binop($_[0], "/") }
+sub pp_modulo { binop($_[0], "%") }
+sub pp_eq { binop($_[0], "==") }
+sub pp_ne { binop($_[0], "!=") }
+sub pp_lt { binop($_[0], "<") }
+sub pp_gt { binop($_[0], ">") }
+sub pp_ge { binop($_[0], ">=") }
+
+sub pp_sassign { binop($_[0], "=", SWAP_CHILDREN) }
+
+sub pp_null {
+ my $op = shift;
+ warn sprintf("Skipping null op %s\n", peekop($op)) if $debug;
+ return $op->first;
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ if (class($sv) eq "IV") {
+ return $sv->IV;
+ } elsif (class($sv) eq "NV") {
+ return $sv->NV;
+ } else {
+ return $sv->PV;
+ }
+}
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gv = $op->gv;
+ my $stash = $gv->STASH->NAME;
+ if ($stash eq "main") {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ return sprintf('$%s%s', $stash, $gv->NAME);
+}
+
+1;
--- /dev/null
+package B::Lint;
+
+=head1 NAME
+
+B::Lint - Perl lint
+
+=head1 SYNOPSIS
+
+perl -MO=Lint[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Lint module is equivalent to an extended version of the B<-w>
+option of B<perl>. It is named after the program B<lint> which carries
+out a similar process for C programs.
+
+=head1 OPTIONS AND LINT CHECKS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options. Following any options
+(indicated by a leading B<->) come lint check arguments. Each is a
+word representing one possible lint check (turning on that check) or
+is B<no-foo> meaning to turn off check B<foo>. By default, a standard
+list of checks is turned on. Available checks are:
+
+=over 8
+
+=item B<context>
+
+Produces a warning whenever an array is used in an implicit scalar
+context. For example, both of the lines
+
+ $foo = length(@bar);
+ $foo = @bar;
+will elicit a warning. Using an explicit B<scalar()> silences the
+warning. For example,
+
+ $foo = scalar(@bar);
+
+=item B<implicit-read> and B<implicit-write>
+
+These options produce a warning whenever an operation implicitly
+reads or (respectively) writes to one of Perl's special variables.
+For example, B<implicit-read> will warn about these:
+
+ /foo/;
+
+and B<implicit-write> will warn about these:
+
+ s/foo/bar/;
+
+=back
+
+=head1 BUGS
+
+This is only a very preliminary version.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(walkoptree_slow main_root parents);
+
+# Constants (should probably be elsewhere)
+sub G_ARRAY () { 1 }
+sub OPf_LIST () { 1 }
+sub OPf_KNOW () { 2 }
+sub OPf_STACKED () { 64 }
+
+my $file = "unknown"; # shadows current filename
+my $line = 0; # shadows current line number
+
+# Lint checks
+my %check;
+my %implies_ok_context;
+BEGIN {
+ map($implies_ok_context{$_}++,
+ qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
+ pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
+}
+
+# Lint checks turned on by default
+my @default_checks = qw(context);
+
+# Debugging options
+my ($debug_op);
+
+sub warning {
+ my $format = (@_ < 2) ? "%s" : shift;
+ warn sprintf("$format at %s line %d\n", @_, $file, $line);
+}
+
+# This gimme can't cope with context that's only determined
+# at runtime via dowantarray().
+sub gimme {
+ my $op = shift;
+ my $flags = $op->flags;
+ if ($flags & OPf_KNOW) {
+ return(($flags & OPf_LIST) ? 1 : 0);
+ }
+ return undef;
+}
+
+sub B::OP::lint {}
+
+sub B::COP::lint {
+ my $op = shift;
+ if ($op->ppaddr eq "pp_nextstate") {
+ $file = $op->filegv->SV->PV;
+ $line = $op->line;
+ }
+}
+
+sub B::UNOP::lint {
+ my $op = shift;
+ my $ppaddr = $op->ppaddr;
+ if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
+ my $parent = parents->[0];
+ my $pname = $parent->ppaddr;
+ return if gimme($op) || $implies_ok_context{$pname};
+ # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
+ # null out the parent so we have to check for a parent of pp_null and
+ # a grandparent of pp_enteriter or pp_delete
+ if ($pname eq "pp_null") {
+ my $gpname = parents->[1]->ppaddr;
+ return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
+ }
+ warning("Implicit scalar context for %s in %s",
+ $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
+ }
+}
+
+sub B::PMOP::lint {
+ my $op = shift;
+ if ($check{implicit_read}) {
+ my $ppaddr = $op->ppaddr;
+ if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
+ warning('Implicit match on $_');
+ }
+ }
+ elsif ($check{implicit_write}) {
+ my $ppaddr = $op->ppaddr;
+ if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
+ warning('Implicit substitution on $_');
+ }
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ # Turn on default lint checks
+ for $opt (@default_checks) {
+ $check{$opt} = 1;
+ }
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ }
+ }
+ }
+ }
+ foreach $opt (@default_checks, @options) {
+ $opt =~ tr/-/_/;
+ if ($opt =~ s/^no-//) {
+ $check{$opt} = 0;
+ } else {
+ $check{$opt} = 1;
+ }
+ }
+ # Remaining arguments are things to check
+
+ return sub { walkoptree_slow(main_root, "lint") };
+}
+
+1;
package B::Terse;
use strict;
-use B qw(peekop class ad walkoptree walkoptree_exec
+use B qw(peekop class walkoptree_slow walkoptree_exec
main_start main_root cstring svref_2object);
use B::Asmdata qw(@specialsv_name);
if ($order eq "exec") {
walkoptree_exec($cv->START, "terse");
} else {
- walkoptree($cv->ROOT, "terse");
+ walkoptree_slow($cv->ROOT, "terse");
}
}
if ($order eq "exec") {
return sub { walkoptree_exec(main_start, "terse") }
} else {
- return sub { walkoptree(main_root, "terse") }
+ return sub { walkoptree_slow(main_root, "terse") }
}
}
}
sub B::PV::terse {
my ($sv, $level) = @_;
print indent($level);
- printf "%s (0x%lx) %s\n", class($sv), ad($sv), cstring($sv->PV);
+ printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
}
sub B::AV::terse {
my ($sv, $level) = @_;
print indent($level);
- printf "%s (0x%lx) FILL %d\n", class($sv), ad($sv), $sv->FILL;
+ printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
}
sub B::GV::terse {
$stash = $stash . "::";
}
print indent($level);
- printf "%s (0x%lx) *%s%s\n", class($gv), ad($gv), $stash, $gv->NAME;
+ printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME;
}
sub B::IV::terse {
my ($sv, $level) = @_;
print indent($level);
- printf "%s (0x%lx) %d\n", class($sv), ad($sv), $sv->IV;
+ printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV;
}
sub B::NV::terse {
my ($sv, $level) = @_;
print indent($level);
- printf "%s (0x%lx) %s\n", class($sv), ad($sv), $sv->NV;
+ printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
}
sub B::NULL::terse {
my ($sv, $level) = @_;
print indent($level);
- printf "%s (0x%lx)\n", class($sv), ad($sv);
+ printf "%s (0x%lx)\n", class($sv), $$sv;
}
sub B::SPECIAL::terse {
=cut
use strict;
-use B qw(peekop class ad comppadlist main_start svref_2object walksymtable);
+use B qw(peekop class comppadlist main_start svref_2object walksymtable);
# Constants (should probably be elsewhere)
sub OPpLVAL_INTRO () { 128 }
sub B::GV::xref {
my $gv = shift;
my $cv = $gv->CV;
- if (ad($cv)) {
+ if ($$cv) {
#return if $done{$$cv}++;
$file = $gv->FILEGV->SV->PV;
$line = $gv->LINE;
push(@todo, $cv);
}
my $form = $gv->FORM;
- if (ad($form)) {
+ if ($$form) {
return if $done{$$form}++;
$file = $gv->FILEGV->SV->PV;
$line = $gv->LINE;
WriteMakefile(
NAME => "B",
- VERSION => "a2",
- MAP_TARGET => "bperl",
+ VERSION => "a4",
OBJECT => "B.o ccop.o byterun.o",
depend => {
"B.o" => "B.c ccop.h bytecode.h byterun.h",
"ccop.o" => "ccop.c ccop.h"
},
clean => {
- FILES => "bperl byteperl btest btest.c *.o B.c *~"
+ FILES => "perl byteperl btest btest.c *.o B.c *~"
}
);
- Perl Compiler Kit, Version alpha3
+ Perl Compiler Kit, Version alpha4
- Copyright (c) 1996, Malcolm Beattie
+ Copyright (c) 1996, 1997, Malcolm Beattie
This program is free software; you can redistribute it and/or modify
it under the terms of either:
CHANGES
+New since alpha3
+ Anonymous subs work properly with C and CC.
+ Heuristics for forcing compilation of apparently unused subs/methods.
+ Subs which use the AutoLoader module are forcibly loaded at compile-time.
+ Slightly faster compilation.
+ Handles slightly more complex code within a BEGIN { }.
+ Minor bug fixes.
+
New since alpha2
CC backend now supports ".." and s//e.
Xref backend generates cross-reference reports
INSTALLATION
-(1) You need perl5.002 or perl5.003.
+(1) You need perl5.002 or later.
(2) If you want to compile and run programs with the C or CC backends
which undefine (or redefine) subroutines, then you need to apply a
(4) If your platform supports dynamic loading then just type
make
and you can then use
- perl -Iblib/arch -MO=foo bar baz
+ perl -Iblib/arch -MO=foo bar
to use the compiler modules (see later for details).
If you need/want instead to make a statically linked perl which
contains the appropriate modules, then type
- make bperl
+ make perl
make byteperl
and you can then use
- ./bperl -MO=foo bar baz
+ ./perl -MO=foo bar
to use the compiler modules.
In both cases, the byteperl executable is required for running standalone
bytecode programs. It is *not* a standard perl+XSUB perl executable.
if you have built the extensions for a dynamic loading platform but
haven't installed the extensions completely. You'll need to replace
"perl" by
- ./bperl
+ ./perl
if you have built the extensions into a statically linked perl binary.
(1) To compile perl program foo.pl with the C backend, do
ld -shared -o libperl.so -all libperl.a -none -lc
and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
also suggest -fomit-frame-pointer for Linux on Intel architetcures),
-do "Make libperl.a" and then do
+do "make libperl.a" and then do
gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
and then
# cp libperl.so.5.3 /usr/lib
Test results from compiling t/*/*.t
C Bytecode CC
-base/cond.t OK OK OK
-base/if.t OK OK OK
-base/lex.t OK OK OK
-base/pat.t OK OK OK
-base/term.t OK OK OK
-cmd/elsif.t OK OK OK
-cmd/for.t OK OK OK
-cmd/mod.t OK OK OK
-cmd/subval.t OK OK 1..34, not ok 27,28 (simply
+base/cond.t OK ok OK
+base/if.t OK ok OK
+base/lex.t OK ok OK
+base/pat.t OK ok OK
+base/term.t OK ok OK
+cmd/elsif.t OK ok OK
+cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter
+cmd/mod.t OK ok ok
+cmd/subval.t OK ok 1..34, not ok 27,28 (simply
because filename changes).
-cmd/switch.t OK OK OK
-cmd/while.t OK OK OK
-io/argv.t OK OK OK
-io/dup.t OK OK OK
-io/fs.t OK OK OK
-io/inplace.t OK OK OK
-io/pipe.t OK with -umain OK OK with -umain
-io/print.t OK OK OK
-io/tell.t OK OK OK
-op/append.t OK OK OK
-op/array.t OK OK 1..36, not ok 7,10 (no $[)
-op/auto.t OK OK OK
-op/chop.t OK OK OK
-op/cond.t OK OK OK
-op/delete.t OK OK OK
-op/do.t OK OK OK
-op/each.t OK OK OK
-op/eval.t OK OK OK
-op/exec.t OK OK OK
-op/exp.t OK OK OK
-op/flip.t OK OK OK
-op/fork.t OK OK OK
-op/glob.t OK OK OK
-op/goto.t OK OK 1..9, Can't find label label1.
+cmd/switch.t OK ok ok
+cmd/while.t OK ok ok
+io/argv.t OK ok ok
+io/dup.t OK ok ok
+io/fs.t OK ok ok
+io/inplace.t OK ok ok
+io/pipe.t OK ok ok with -umain
+io/print.t OK ok ok
+io/tell.t OK ok ok
+op/append.t OK ok OK
+op/array.t OK ok 1..36, not ok 7,10 (no $[)
+op/auto.t OK ok OK
+op/chop.t OK ok OK
+op/cond.t OK ok OK
+op/delete.t OK ok OK
+op/do.t OK ok OK
+op/each.t OK ok OK
+op/eval.t OK ok ok 1-6 of 16 then exits
+op/exec.t OK ok OK
+op/exp.t OK ok OK
+op/flip.t OK ok OK
+op/fork.t OK ok OK
+op/glob.t OK ok OK
+op/goto.t OK ok 1..9, Can't find label label1.
op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
-op/index.t OK OK OK
-op/int.t OK OK OK
-op/join.t OK OK OK
-op/list.t OK OK OK
-op/local.t OK OK OK
-op/magic.t OK OK OK with -umain
+op/index.t OK ok OK
+op/int.t OK ok OK
+op/join.t OK ok OK
+op/list.t OK ok OK
+op/local.t OK ok OK
+op/magic.t OK ok OK
op/misc.t no DATA filehandle so succeeds trivially with 1..0
-op/mkdir.t OK OK OK
-op/my.t OK OK OK
-op/oct.t OK OK OK (C large const warnings)
-op/ord.t OK OK OK
+op/mkdir.t OK ok OK
+op/my.t OK ok OK
+op/oct.t OK ok OK (C large const warnings)
+op/ord.t OK ok OK
op/overload.t Mostly not ok Mostly not ok C errors.
-op/pack.t OK OK OK
-op/pat.t OK OK OK
-op/push.t OK OK OK
-op/quotemeta.t OK OK OK
-op/rand.t OK OK OK
-op/range.t OK OK OK
-op/read.t OK OK OK
-op/readdir.t OK OK OK
-op/ref.t omits "ok 40" (lex destruction) OK (Bytecode)
+op/pack.t OK ok OK
+op/pat.t omit 26 (reset) ok [lots of memory for compile]
+op/push.t OK ok OK
+op/quotemeta.t OK ok OK
+op/rand.t OK ok
+op/range.t OK ok OK
+op/read.t OK ok OK
+op/readdir.t OK ok OK (substcont works too)
+op/ref.t omits "ok 40" (lex destruction) ok (Bytecode)
CC: need -u for OBJ,BASEOBJ,
- MYHASH,UNIVERSAL,WHATEVER,main
- FINALE. 1..41, ok1-33,36-38,
+ UNIVERSAL,WHATEVER,main.
+ 1..41, ok1-33,36-38,
then ok 41, ok 39.DESTROY probs
-op/regexp.t OK OK OK (trivially all eval'd)
-op/repeat.t OK OK OK
-op/sleep.t OK OK OK
-op/sort.t OK OK 1..10, ok 1, Out of memory!
-op/split.t OK OK OK
-op/sprintf.t OK OK OK
-op/stat.t OK OK OK
-op/study.t OK OK OK
-op/subst.t OK OK OK
-op/substr.t OK OK ok1-22 except 7-9,11 (all $[)
-op/time.t OK OK OK
-op/undef.t OK OK OK
-op/unshift.t OK OK OK
-op/vec.t OK OK OK
+op/regexp.t OK ok ok (trivially all eval'd)
+op/repeat.t OK ok ok
+op/sleep.t OK ok ok
+op/sort.t OK ok 1..10, ok 1, Out of memory!
+op/split.t OK ok ok
+op/sprintf.t OK ok ok
+op/stat.t OK ok ok
+op/study.t OK ok ok
+op/subst.t OK ok ok
+op/substr.t OK ok ok1-22 except 7-9,11 (all $[)
+op/time.t OK ok ok
+op/undef.t omit 21 ok ok
+op/unshift.t OK ok ok
+op/vec.t OK ok ok
op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
-#!./bperl
use B::Assembler qw(assemble_fh);
use FileHandle;
xio_page_len IoPAGE_LEN(sv) long
xio_lines_left IoLINES_LEFT(sv) long
xio_top_name IoTOP_NAME(sv) pvcontents
-xio_top_gv IoTOP_GV(sv) svindex
+xio_top_gv *(SV**)&IoTOP_GV(sv) svindex
xio_fmt_name IoFMT_NAME(sv) pvcontents
-xio_fmt_gv IoFMT_GV(sv) svindex
+xio_fmt_gv *(SV**)&IoFMT_GV(sv) svindex
xio_bottom_name IoBOTTOM_NAME(sv) pvcontents
-xio_bottom_gv IoBOTTOM_GV(sv) svindex
+xio_bottom_gv *(SV**)&IoBOTTOM_GV(sv) svindex
xio_subprocess IoSUBPROCESS(sv) short
xio_type IoTYPE(sv) char
xio_flags IoFLAGS(sv) char
xcv_stash *(SV**)&CvSTASH(sv) svindex
xcv_start CvSTART(sv) opindex
xcv_root CvROOT(sv) opindex
-xcv_gv CvGV(sv) svindex
-xcv_filegv CvFILEGV(sv) svindex
+xcv_gv *(SV**)&CvGV(sv) svindex
+xcv_filegv *(SV**)&CvFILEGV(sv) svindex
xcv_depth CvDEPTH(sv) long
xcv_padlist *(SV**)&CvPADLIST(sv) svindex
xcv_outside *(SV**)&CvOUTSIDE(sv) svindex
op_pmpermflags cPMOP->op_pmpermflags U16
op_pmslen cPMOP->op_pmslen char
op_sv cSVOP->op_sv svindex
-op_gv cGVOP->op_gv svindex
+op_gv *(SV**)&cGVOP->op_gv svindex
op_pv cPVOP->op_pv pvcontents
op_pv_tr cPVOP->op_pv op_tr_array
op_redoop cLOOP->op_redoop opindex
op_lastop cLOOP->op_lastop opindex
cop_label cCOP->cop_label pvcontents
cop_stash *(SV**)&cCOP->cop_stash svindex
-cop_filegv cCOP->cop_filegv svindex
+cop_filegv *(SV**)&cCOP->cop_filegv svindex
cop_seq cCOP->cop_seq U32
cop_arybase cCOP->cop_arybase I32
cop_line cCOP->cop_line line_t
#include "EXTERN.h"
#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
#include "byterun.h"
#ifdef __cplusplus
{
svindex arg;
BGET_objindex(arg);
- IoTOP_GV(sv) = arg;
+ *(SV**)&IoTOP_GV(sv) = arg;
break;
}
case INSN_XIO_FMT_NAME: /* 37 */
{
svindex arg;
BGET_objindex(arg);
- IoFMT_GV(sv) = arg;
+ *(SV**)&IoFMT_GV(sv) = arg;
break;
}
case INSN_XIO_BOTTOM_NAME: /* 39 */
{
svindex arg;
BGET_objindex(arg);
- IoBOTTOM_GV(sv) = arg;
+ *(SV**)&IoBOTTOM_GV(sv) = arg;
break;
}
case INSN_XIO_SUBPROCESS: /* 41 */
{
svindex arg;
BGET_objindex(arg);
- CvGV(sv) = arg;
+ *(SV**)&CvGV(sv) = arg;
break;
}
case INSN_XCV_FILEGV: /* 48 */
{
svindex arg;
BGET_objindex(arg);
- CvFILEGV(sv) = arg;
+ *(SV**)&CvFILEGV(sv) = arg;
break;
}
case INSN_XCV_DEPTH: /* 49 */
{
svindex arg;
BGET_objindex(arg);
- cGVOP->op_gv = arg;
+ *(SV**)&cGVOP->op_gv = arg;
break;
}
case INSN_OP_PV: /* 107 */
{
svindex arg;
BGET_objindex(arg);
- cCOP->cop_filegv = arg;
+ *(SV**)&cCOP->cop_filegv = arg;
break;
}
case INSN_COP_SEQ: /* 115 */
SPAGAIN; \
} while(0)
-#include "patchlevel.h"
#if PATCHLEVEL < 3
#define RUN() run()
#else
-#!./bperl
use B::Disassembler qw(disassemble_fh);
use FileHandle;
--- /dev/null
+use File::Find;
+use Config;
+
+if (@ARGV != 2) {
+ warn <<"EOT";
+Usage: makeliblinks libautodir targetdir
+where libautodir is the architecture-dependent auto directory
+(e.g. $Config::Config{archlib}/auto).
+EOT
+ exit 2;
+}
+
+my ($libautodir, $targetdir) = @ARGV;
+
+# Calculate relative path prefix from $targetdir to $libautodir
+sub relprefix {
+ my ($to, $from) = @_;
+ my $up;
+ for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
+ $from =~ s(
+ [^/]+ (?# a group of non-slashes)
+ /* (?# maybe with some trailing slashes)
+ $ (?# at the end of the path)
+ )()x;
+ }
+ return (("../" x $up) . substr($to, length($from)));
+}
+
+my $relprefix = relprefix($libautodir, $targetdir);
+
+my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
+
+sub link_if_library {
+ if (/\.($dlext|$lib_ext)$/o) {
+ my $ext = $1;
+ my $name = $File::Find::name;
+ if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
+ die "directory of $name doesn't match $libautodir\n";
+ }
+ substr($name, 0, length($libautodir) + 1) = '';
+ my @parts = split(m(/), $name);
+ if ($parts[-1] ne "$parts[-2].$ext") {
+ die "module name $_ doesn't match its directory $libautodir\n";
+ }
+ pop @parts;
+ my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
+ print "$libpath -> $relprefix/$name\n";
+ symlink("$relprefix/$name", $libpath)
+ or warn "above link failed with error: $!\n";
+ }
+}
+
+find(\&link_if_library, $libautodir);
+exit 0;
#!/bin/sh
+cwd=`pwd`
if [ -f bperl ]; then
perl=./bperl
else
$perl -MO=C,-obtest.tc $pl \
&& mv btest.tc btest.c \
&& $perl cc_harness -o btest btest.c \
- && ./btest
+ && (cd t; $cwd/btest)
done
#!/bin/sh
+cwd=`pwd`
if [ -f bperl ]; then
perl=./bperl
else
$perl -MO=CC,-obtest.tc $pl \
&& mv btest.tc btest.c \
&& $perl cc_harness -O2 -o btest btest.c\
- && ./btest
+ && (cd t; $cwd/btest)
done
projects / p5sagit/p5-mst-13.2.git / commitdiff