c.pm

Altera recommends the following system configuration: * Pentium II 400 with 512-MB system memory (fa

    $val .= '.00' if $val =~ /^-?\d+$/;
    $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
			 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub savepvn {
    my ($dest,$pv) = @_;
    my @res;
    if (defined $max_string_len && length($pv) > $max_string_len) {
	push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
	my $offset = 0;
	while (length $pv) {
	    my $str = substr $pv, 0, $max_string_len, '';
	    push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
			       cstring($str), length($str));
	    $offset += length $str;
	}
	push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
    }
    else {
	push @res, sprintf("%s = savepvn(%s, %u);", $dest,
			   cstring($pv), length($pv));
    }
    return @res;
}

sub B::PVLV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    my ($lvtarg, $lvtarg_sym);
    $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, 
			    $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
    $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
			 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
				   $xpvlvsect->index), $pv));
    }
    $sv->save_magic;
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PVIV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
    $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
			 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
				   $xpvivsect->index), $pv));
    }
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PVNV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;     
    $pv = '' unless defined $pv;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    my $val= $sv->NVX;
    $val .= '.00' if $val =~ /^-?\d+$/;
    $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
			    $pvsym, $len, $pvmax, $sv->IVX, $val));
    $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
			 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
				   $xpvnvsect->index), $pv));
    }
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::BM::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV . "\0" . $sv->TABLE;
    my $len = length($pv);
    $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
			    $len, $len + 258, $sv->IVX, $sv->NVX,
			    $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
    $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
			 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
    $sv->save_magic;
    $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
			       $xpvbmsect->index), $pv),
	       sprintf("xpvbm_list[%d].xpv_cur = %u;",
		       $xpvbmsect->index, $len - 257));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
    $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
			 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
				   $xpvsect->index), $pv));
    }
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

sub B::PVMG::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    my $pv = $sv->PV;
    my $len = length($pv);
    my ($pvsym, $pvmax) = savepv($pv);
    $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
			    $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
    $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
			 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
    if (!$pv_copy_on_grow) {
	$init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
				   $xpvmgsect->index), $pv));
    }
    $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
    $sv->save_magic;
    return $sym;
}

sub B::PVMG::save_magic {
    my ($sv) = @_;
    #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
    my $stash = $sv->SvSTASH;
    $stash->save;
    if ($$stash) {
	warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
	    if $debug_mg;
	# XXX Hope stash is already going to be saved.
	$init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
    }
    my @mgchain = $sv->MAGIC;
    my ($mg, $type, $obj, $ptr,$len,$ptrsv);
    foreach $mg (@mgchain) {
	$type = $mg->TYPE;
	$obj = $mg->OBJ;
	$ptr = $mg->PTR;
	$len=$mg->LENGTH;
	if ($debug_mg) {
	    warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
			 class($sv), $$sv, class($obj), $$obj,
			 cchar($type), cstring($ptr));
	}
	$obj->save;
	if ($len == HEf_SVKEY){
		#The pointer is an SV*
		$ptrsv=svref_2object($ptr)->save;
		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
			   $$sv, $$obj, cchar($type),$ptrsv,$len));
	}else{
		$init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
			   $$sv, $$obj, cchar($type),cstring($ptr),$len));
	}
    }
}

sub B::RV::save {
    my ($sv) = @_;
    my $sym = objsym($sv);
    return $sym if defined $sym;
    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 , $sv->FLAGS));
    return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
}

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 Dummy_initxs{};
sub B::CV::save {
    my ($cv) = @_;
    my $sym = objsym($cv);
    if (defined($sym)) {
#	warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
	return $sym;
    }
    # Reserve a place in svsect and xpvcvsect and record indices
    my $gv = $cv->GV;
    my ($cvname, $cvstashname);
    if ($$gv){
    	$cvname = $gv->NAME;
    	$cvstashname = $gv->STASH->NAME;
    }
    my $root = $cv->ROOT;
    my $cvxsub = $cv->XSUB;
    #INIT is removed from the symbol table, so this call must come
    # from PL_initav->save. Re-bootstrapping  will push INIT back in
    # so nullop should be sent.
    if ($cvxsub && ($cvname ne "INIT")) {
	my $egv = $gv->EGV;
	my $stashname = $egv->STASH->NAME;
         if ($cvname eq "bootstrap")
          {                                   
           my $file = $gv->FILE;    
           $decl->add("/* bootstrap $file */"); 
           warn "Bootstrap $stashname $file\n";
           $xsub{$stashname}='Dynamic'; 
	   # $xsub{$stashname}='Static' unless  $xsub{$stashname};
           return qq/NULL/;
          }                                   
        warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
	return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
    }
    if ($cvxsub && $cvname eq "INIT") {
	 no strict 'refs';
   	 return svref_2object(\&Dummy_initxs)->save;
    }
    my $sv_ix = $svsect->index + 1;
    $svsect->add("svix$sv_ix");
    my $xpvcv_ix = $xpvcvsect->index + 1;
    $xpvcvsect->add("xpvcvix$xpvcv_ix");
    # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
    $sym = savesym($cv, "&sv_list[$sv_ix]");
    warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
    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;
    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",
		     $$cv, $$root) if $debug_cv;
	my $ppname = "";
	if ($$gv) {
	    my $stashname = $gv->STASH->NAME;
	    my $gvname = $gv->NAME;
	    if ($gvname ne "__ANON__") {
		$ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
		$ppname .= ($stashname eq "main") ?
			    $gvname : "$stashname\::$gvname";
		$ppname =~ s/::/__/g;
	        if ($gvname eq "INIT"){
		       $ppname .= "_$initsub_index";
		       $initsub_index++;
		    }
	    }
	}
	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",
		     $$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;
	}
    }
    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, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x",
			  $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
			  $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
                        $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));

    if (${$cv->OUTSIDE} == ${main_cv()}){
	$init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
	$init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
    }

    if ($$gv) {
	$gv->save;
	$init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
	warn sprintf("done saving GV 0x%x for CV 0x%x\n",
		     $$gv, $$cv) if $debug_cv;
    }
    $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
    my $stash = $cv->STASH;
    if ($$stash) {
	$stash->save;
	$init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
	warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
		     $$stash, $$cv) if $debug_cv;
    }
    $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
			  $sv_ix, $xpvcv_ix, $cv->REFCNT +1 , $cv->FLAGS));
    return $sym;
}

sub B::GV::save {
    my ($gv) = @_;
    my $sym = objsym($gv);
    if (defined($sym)) {
	#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", $$gv); # debug
    }
    my $is_empty = $gv->is_empty;
    my $gvname = $gv->NAME;
    my $name = cstring($gv->STASH->NAME . "::" . $gvname);
    #warn "GV name is $name\n"; # debug
    my $egvsym;
    unless ($is_empty) {
	my $egv = $gv->EGV;
	if ($$gv != $$egv) {
	    #warn(sprintf("EGV name is %s, saving it now\n",
	    #	     $egv->STASH->NAME . "::" . $egv->NAME)); # debug
	    $egvsym = $egv->save;
	}
    }
    $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
	       sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
	       sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
    $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;

    # Shouldn't need to do save_magic since gv_fetchpv handles that
    #$gv->save_magic;
    my $refcnt = $gv->REFCNT + 1;
    $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;

    return $sym if $is_empty;

    my $gvrefcnt = $gv->GvREFCNT;
    if ($gvrefcnt > 1) {
	$init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
    }
    if (defined($egvsym)) {
	# Shared glob *foo = *bar
	$init->add("gp_free($sym);",
		   "GvGP($sym) = GvGP($egvsym);");
    } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
	# Don't save subfields of special GVs (*_, *1, *# and so on)
#	warn "GV::save saving subfields\n"; # debug
	my $gvsv = $gv->SV;
	if ($$gvsv) {
	    $gvsv->save;
	    $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
#	    warn "GV::save \$$name\n"; # debug
	}
	my $gvav = $gv->AV;
	if ($$gvav) {
	    $gvav->save;
	    $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
#	    warn "GV::save \@$name\n"; # debug
	}
	my $gvhv = $gv->HV;
	if ($$gvhv) {
	    $gvhv->save;
	    $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
#	    warn "GV::save \%$name\n"; # debug
	}
	my $gvcv = $gv->CV;
	if ($$gvcv) { 
	    my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
		 "::" . $gvcv->GV->EGV->NAME);  
	    if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
	        # must save as a 'stub' so newXS() has a CV to populate
                $init->add("{ CV *cv;");
                $init->add("\tcv=perl_get_cv($origname,TRUE);");
                $init->add("\tGvCV($sym)=cv;");
                $init->add("\tSvREFCNT_inc((SV *)cv);");