view release on metacpan or  search on metacpan

src/perperl_perl.c  view on Meta::CPAN

	temp_script_name = "-e&{$" PERPERL_PKG("_sub") "}(@ARGV);";
    }

    /* Parse perl file. */
    perl_argv = perperl_opt_perl_argv(temp_script_name);
    if (perl_parse(my_perl, xs_init,
	perperl_util_argc((const char * const *)perl_argv), perl_argv, NULL))
    {
	DIE_QUIET("perl_parse error");
    }
    cleanup_after_perl();

    /* If we had to use /dev/fd/N, perl will close the file for us, so
     * make sure our code knows it's closed.  If we need it from here on out
     * it'll have to be re-opened.
     */
    if (use_devfd)
	perperl_script_close();

    /* Create a PersistentScript entry for the standard script */
    scr = find_scr(perperl_util_stat_devino(perperl_script_getstat()), &is_new);

    /* If using groups, try pre-loading the script to save time later */
    if (!single_script && !perperl_script_open_failure()) {
	load_script(
	    perperl_util_stat_devino(perperl_script_getstat()),
	    scr, perperl_opt_script_fname()
	);
	cleanup_after_perl();
    }

    /* Time to close stderr */
    close(2);
}

void perperl_perl_run(slotnum_t gslotnum, slotnum_t bslotnum) {
    int numrun, exit_val;
    int single_script = DOING_SINGLE_SCRIPT;

    /* Start listening on our socket */
    perperl_ipc_listen(bslotnum);

    /* Main loop */
    for (numrun = 0; !OPTVAL_MAXRUNS || numrun < OPTVAL_MAXRUNS; ++numrun) {

	/* Lock/mmap our temp file.  If our group is invalid, exit quietly */
	if (getppid() == 1 || !perperl_group_lock(gslotnum))
	    all_done();

	/* Update our maturity level */
	FILE_SLOT(be_slot, bslotnum).maturity = numrun ? 2 : 1;

	/* Put ourself onto the be_wait list */
	perperl_backend_be_wait_put(gslotnum, bslotnum);

	/* If we were listed as starting, turn that off */
	if (FILE_SLOT(gr_slot, gslotnum).be_starting == perperl_util_getpid())
	    FILE_SLOT(gr_slot, gslotnum).be_starting = 0;

	/* Send out alarm signal to frontends */
	perperl_group_sendsigs(gslotnum);

	/* Fix our listener fd */
	perperl_ipc_listen_fixfd(bslotnum);

	/* Unlock file */
	perperl_file_set_state(FS_HAVESLOTS);

	/* Do an accept on our socket */
	backend_accept();

	/* Lock file.  If our group is invalid, exit quietly */
	if (!perperl_group_lock(gslotnum))
	    all_done();

	/* If we were listed as starting, turn that off */
	if (FILE_SLOT(gr_slot, gslotnum).be_starting == perperl_util_getpid())
	    FILE_SLOT(gr_slot, gslotnum).be_starting = 0;

	/* Wake up any waiting frontends */
	perperl_group_sendsigs(gslotnum);

	/* Unlock the file */
	perperl_file_set_state(FS_HAVESLOTS);

	/* Run the perl code once */
	exit_val = onerun(single_script);

	/* Send the exit status to the frontend */
	perperl_file_set_state(FS_CORRUPT);
	perperl_backend_exited(bslotnum, 0, exit_val);
    }
    
    /* Start up a replacement backend */
    if (perperl_group_lock(gslotnum))
	perperl_group_start_be(gslotnum);

    /* Exit out */
    all_done();
}

int perperl_perl_fork(void) {
    dSP;
    int retval;
    static int made_sub;

    if (!made_sub) {
	made_sub = 1;
	eval_pv("sub " PERPERL_PKG("_fork") " {return fork;}", TRUE);
    }

    ENTER;
    SAVETMPS;

    PUSHMARK(SP);
    if (call_sv(get_perlvar(&PERLVAR_FORK), G_NOARGS|G_SCALAR) != 1)
	DIE_QUIET("perl fork didn't return one value");

    SPAGAIN;
    retval = POPi;
    PUTBACK;

    FREETMPS;
    LEAVE;

    return retval;
}

/*
 * Glue
 */

void perperl_abort(const char *s) {
    PerlIO_puts(PerlIO_stderr(), s);
    perperl_util_exit(1, 0);
}