c.pm

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

                $init->add("}");    
	    } else {     
               $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
#              warn "GV::save &$name\n"; # debug
	    } 
        }     
	$init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
#	warn "GV::save GvFILE(*$name)\n"; # debug
	my $gvform = $gv->FORM;
	if ($$gvform) {
	    $gvform->save;
	    $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
#	    warn "GV::save GvFORM(*$name)\n"; # debug
	}
	my $gvio = $gv->IO;
	if ($$gvio) {
	    $gvio->save;
	    $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
#	    warn "GV::save GvIO(*$name)\n"; # debug
	}
    }
    return $sym;
}
sub B::AV::save {
    my ($av) = @_;
    my $sym = objsym($av);
    return $sym if defined $sym;
    my $avflags = $av->AvFLAGS;
    $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
			    $avflags));
    $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
			 $xpvavsect->index, $av->REFCNT  , $av->FLAGS));
    my $sv_list_index = $svsect->index;
    my $fill = $av->FILL;
    $av->save_magic;
    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)) {
    if ($fill > -1) {
	my @array = $av->ARRAY;
	if ($debug_av) {
	    my $el;
	    my $i = 0;
	    foreach $el (@array) {
		warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
			     $$av, $i++, class($el), $$el);
	    }
	}
	my @names = map($_->save, @array);
	# XXX Better ways to write loop?
	# Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
	# Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
	$init->add("{",
		   "\tSV **svp;",
		   "\tAV *av = (AV*)&sv_list[$sv_list_index];",
		   "\tav_extend(av, $fill);",
		   "\tsvp = AvARRAY(av);",
	       map("\t*svp++ = (SV*)$_;", @names),
		   "\tAvFILLp(av) = $fill;",
		   "}");
    } else {
	my $max = $av->MAX;
	$init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
	    if $max > -1;
    }
    return savesym($av, "(AV*)&sv_list[$sv_list_index]");
}

sub B::HV::save {
    my ($hv) = @_;
    my $sym = objsym($hv);
    return $sym if defined $sym;
    my $name = $hv->NAME;
    if ($name) {
	# It's a stash

	# 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 = ${$hv->PMROOT};
	my $adpmroot = 0;
	$decl->add("static HV *hv$hv_index;");
	# XXX Beware of weird package names containing double-quotes, \n, ...?
	$init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
	if ($adpmroot) {
	    $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
			       $adpmroot));
	}
	$sym = savesym($hv, "hv$hv_index");
	$hv_index++;
	return $sym;
    }
    # It's just an ordinary HV
    $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
			    $hv->MAX, $hv->RITER));
    $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
			 $xpvhvsect->index, $hv->REFCNT  , $hv->FLAGS));
    my $sv_list_index = $svsect->index;
    my @contents = $hv->ARRAY;
    if (@contents) {
	my $i;
	for ($i = 1; $i < @contents; $i += 2) {
	    $contents[$i] = $contents[$i]->save;
	}
	$init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
	while (@contents) {
	    my ($key, $value) = splice(@contents, 0, 2);
	    $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
			       cstring($key),length($key),$value, hash($key)));
#	    $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
#			       cstring($key),length($key),$value, 0));
	}
	$init->add("}");
    }
    $hv->save_magic();
    return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
}

sub B::IO::save {
    my ($io) = @_;
    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,
			    $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
			    cstring($io->TOP_NAME), cstring($io->FMT_NAME), 
			    cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
			    cchar($io->IoTYPE), $io->IoFLAGS));
    $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
			 $xpviosect->index, $io->REFCNT , $io->FLAGS));
    $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
    my ($field, $fsym);
    foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
      	$fsym = $io->$field();
	if ($$fsym) {
	    $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
	    $fsym->save;
	}
    }
    $io->save_magic;
    return $sym;
}

sub B::SV::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 $$sv;
    confess sprintf("cannot save that type of SV: %s (0x%x)\n",
		    class($sv), $$sv);
}

sub output_all {
    my $init_name = shift;
    my $section;
    my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
		    $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
		    $loopsect, $copsect, $svsect, $xpvsect,
		    $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
		    $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
    $symsect->output(\*STDOUT, "#define %s\n");
    print "\n";
    output_declarations();
    foreach $section (@sections) {
	my $lines = $section->index + 1;
	if ($lines) {
	    my $name = $section->name;
	    my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
	    print "Static $typename ${name}_list[$lines];\n";
	}
    }
    $decl->output(\*STDOUT, "%s\n");
    print "\n";
    foreach $section (@sections) {
	my $lines = $section->index + 1;
	if ($lines) {
	    my $name = $section->name;
	    my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
	    printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
	    $section->output(\*STDOUT, "\t{ %s },\n");
	    print "};\n\n";
	}
    }

    print <<"EOT";
static int $init_name()
{
	dTARG;
	dSP;
EOT
    $init->output(\*STDOUT, "\t%s\n");
    print "\treturn 0;\n}\n";
    if ($verbose) {
	warn compile_stats();
	warn "NULLOP count: $nullop_count\n";
    }
}

sub output_declarations {
    print <<'EOT';
#ifdef BROKEN_STATIC_REDECL
#define Static extern
#else
#define Static static
#endif /* BROKEN_STATIC_REDECL */

#ifdef BROKEN_UNION_INIT
/*
 * Cribbed from cv.h with ANY (a union) replaced by void*.
 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
 */
typedef struct {
    char *	xpv_pv;		/* pointer to malloced string */
    STRLEN	xpv_cur;	/* length of xp_pv as a C string */
    STRLEN	xpv_len;	/* allocated size */
    IV		xof_off;	/* integer value */
    NV		xnv_nv;		/* numeric value, if any */
    MAGIC*	xmg_magic;	/* magic for scalar array */
    HV*		xmg_stash;	/* class package */

    HV *	xcv_stash;
    OP *	xcv_start;
    OP *	xcv_root;
    void      (*xcv_xsub) (pTHXo_ CV*);
    ANY		xcv_xsubany;
    GV *	xcv_gv;
    char *	xcv_file;
    long	xcv_depth;	/* >= 2 indicates recursive call */
    AV *	xcv_padlist;
    CV *	xcv_outside;
#ifdef USE_THREADS
    perl_mutex *xcv_mutexp;
    struct perl_thread *xcv_owner;	/* current owner thread */
#endif /* USE_THREADS */
    cv_flags_t	xcv_flags;
} XPVCV_or_similar;
#define ANYINIT(i) i
#else
#define XPVCV_or_similar XPVCV
#define ANYINIT(i) {i}
#endif /* BROKEN_UNION_INIT */
#define Nullany ANYINIT(0)

#define UNUSED 0
#define sym_0 0

EOT
    print "static GV *gv_list[$gv_index];\n" if $gv_index;
    print "\n";
}


sub output_boilerplate {
    print <<'EOT';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* Workaround for mapstart: the only op which needs a different ppaddr */
#undef Perl_pp_mapstart
#define Perl_pp_mapstart Perl_pp_grepstart
#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);

static void xs_init (pTHX);
static void dl_init (pTHX);
static PerlInterpreter *my_perl;
EOT
}

sub output_main {
    print <<'EOT';
int
main(int argc, char **argv, char **env)
{
    int exitstatus;
    int i;
    char **fakeargv;

    PERL_SYS_INIT3(&argc,&argv,&env);
 
    if (!PL_do_undump) {
	my_perl = perl_alloc();
	if (!my_perl)
	    exit(1);
	perl_construct( my_perl );
	PL_perl_destruct_level = 0;
    }

#ifdef CSH
    if (!PL_cshlen) 
      PL_cshlen = strlen(PL_cshname);
#endif

#ifdef ALLOW_PERL_OPTIONS
#define EXTRA_OPTIONS 2
#else
#define EXTRA_OPTIONS 3
#endif /* ALLOW_PERL_OPTIONS */
    New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
    fakeargv[0] = argv[0];
    fakeargv[1] = "-e";
    fakeargv[2] = "";
#ifndef ALLOW_PERL_OPTIONS
    fakeargv[3] = "--";
#endif /* ALLOW_PERL_OPTIONS */
    for (i = 1; i < argc; i++)
	fakeargv[i + EXTRA_OPTIONS] = argv[i];
    fakeargv[argc + EXTRA_OPTIONS] = 0;
    
    exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
			    fakeargv, NULL);
    if (exitstatus)
	exit( exitstatus );

    sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
    PL_main_cv = PL_compcv;
    PL_compcv = 0;

    exitstatus = perl_init();
    if (exitstatus)
	exit( exitstatus );
    dl_init(aTHX);

    exitstatus = perl_run( my_perl );

    perl_destruct( my_perl );
    perl_free( my_perl );

    PERL_SYS_TERM();

    exit( exitstatus );
}

/* yanked from perl.c */
static void
xs_init(pTHX)
{
    char *file = __FILE__;
    dTARG;
    dSP;
EOT
    print "\n#ifdef USE_DYNAMIC_LOADING";
    print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
    print "\n#endif\n" ;
    # delete $xsub{'DynaLoader'}; 
    delete $xsub{'UNIVERSAL'}; 
    print("/* bootstrapping code*/\n\tSAVETMPS;\n");
    print("\ttarg=sv_newmortal();\n");
    print "#ifdef DYNALOADER_BOOTSTRAP\n";
    print "\tPUSHMARK(sp);\n";
    print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
    print qq/\tPUTBACK;\n/;
    print "\tboot_DynaLoader(aTHX_ NULL);\n";
    print qq/\tSPAGAIN;\n/;
    print "#endif\n";
    foreach my $stashname (keys %xsub){
	if ($xsub{$stashname} ne 'Dynamic') {
	   my $stashxsub=$stashname;
	   $stashxsub  =~ s/::/__/g; 
	   print "\tPUSHMARK(sp);\n";
	   print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
	   print qq/\tPUTBACK;\n/;
	   print "\tboot_$stashxsub(aTHX_ NULL);\n";
	   print qq/\tSPAGAIN;\n/;
	}   
    }
    print("\tFREETMPS;\n/* end bootstrapping code */\n");
    print "}\n";
    
print <<'EOT';
static void
dl_init(pTHX)
{
    char *file = __FILE__;
    dTARG;
    dSP;
EOT
    print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
    print("\ttarg=sv_newmortal();\n");
    foreach my $stashname (@DynaLoader::dl_modules) {
	warn "Loaded $stashname\n";
	if (exists($xsub{$stashname}) && $xsub{$stashname} eq 'Dynamic') {
  	   my $stashxsub=$stashname;
	   $stashxsub  =~ s/::/__/g; 
   	   print "\tPUSHMARK(sp);\n";
   	   print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
	   print qq/\tPUTBACK;\n/;
           print "#ifdef DYNALOADER_BOOTSTRAP\n";
	   warn "bootstrapping $stashname added to xs_init\n";
	   print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
           print "\n#else\n";
	   print "\tboot_$stashxsub(aTHX_ NULL);\n";
           print "#endif\n";
	   print qq/\tSPAGAIN;\n/;
	}   
    }
    print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
    print "}\n";
}
sub dump_symtable {
    # For debugging
    my ($sym, $val);
    warn "----Symbol table:\n";
    while (($sym, $val) = each %symtable) {
	warn "$sym => $val\n";
    }
    warn "---End of symbol table\n";
}

sub save_object {