perl
view release on metacpan or search on metacpan
}
/* To save memory, we store both the environ array and its values in a
* single memory block. */
char **new_environ = (char**)PerlMemShared_malloc(
(sizeof(char*) * (n_entries + 1)) + vars_size
);
char *vars = (char*)(new_environ + n_entries + 1);
for (size_t i = 0, copied = 0; n_entries > i; ++i) {
size_t len = strlen(environ[i]) + 1;
new_environ[i] = (char *) CopyD(environ[i], vars + copied, len, char);
copied += len;
}
ENV_READ_UNLOCK;
new_environ[n_entries] = NULL;
ENV_LOCK;
environ = new_environ;
ENV_UNLOCK;
/* Store a pointer in a global variable to ensure it's always reachable so
* LeakSanitizer/Valgrind won't complain about it. We can't ever free it.
* Even if libc allocates a new environ, it's possible that some of its
* values will still be pointing to the old environ.
*/
PL_my_environ = new_environ;
}
#endif
/*
=for apidoc perl_parse
Tells a Perl interpreter to parse a Perl script. This performs most
of the initialisation of a Perl interpreter. See L<perlembed> for
a tutorial.
C<my_perl> points to the Perl interpreter that is to parse the script.
It must have been previously created through the use of L</perl_alloc>
and L</perl_construct>. C<xsinit> points to a callback function that
will be called to set up the ability for this Perl interpreter to load
XS extensions, or may be null to perform no such setup.
C<argc> and C<argv> supply a set of command-line arguments to the Perl
interpreter, as would normally be passed to the C<main> function of
a C program. C<argv[argc]> must be null. These arguments are where
the script to parse is specified, either by naming a script file or by
providing a script in a C<-e> option.
If L<C<$0>|perlvar/$0> will be written to in the Perl interpreter, then
the argument strings must be in writable memory, and so mustn't just be
string constants.
C<env> specifies a set of environment variables that will be used by
this Perl interpreter. If non-null, it must point to a null-terminated
array of environment strings. If null, the Perl interpreter will use
the environment supplied by the C<environ> global variable.
This function initialises the interpreter, and parses and compiles the
script specified by the command-line arguments. This includes executing
code in C<BEGIN>, C<UNITCHECK>, and C<CHECK> blocks. It does not execute
C<INIT> blocks or the main program.
Returns an integer of slightly tricky interpretation. The correct
use of the return value is as a truth value indicating whether there
was a failure in initialisation. If zero is returned, this indicates
that initialisation was successful, and it is safe to proceed to call
L</perl_run> and make other use of it. If a non-zero value is returned,
this indicates some problem that means the interpreter wants to terminate.
The interpreter should not be just abandoned upon such failure; the caller
should proceed to shut the interpreter down cleanly with L</perl_destruct>
and free it with L</perl_free>.
For historical reasons, the non-zero return value also attempts to
be a suitable value to pass to the C library function C<exit> (or to
return from C<main>), to serve as an exit code indicating the nature
of the way initialisation terminated. However, this isn't portable,
due to differing exit code conventions. An attempt is made to return
an exit code of the type required by the host operating system, but
because it is constrained to be non-zero, it is not necessarily possible
to indicate every type of exit. It is only reliable on Unix, where a
zero exit code can be augmented with a set bit that will be ignored.
In any case, this function is not the correct place to acquire an exit
code: one should get that from L</perl_destruct>.
=cut
*/
#define SET_CURSTASH(newstash) \
if (PL_curstash != newstash) { \
SvREFCNT_dec(PL_curstash); \
PL_curstash = (HV *)SvREFCNT_inc(newstash); \
}
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
I32 oldscope;
int ret;
dJMPENV;
PERL_ARGS_ASSERT_PERL_PARSE;
#ifndef MULTIPLICITY
PERL_UNUSED_ARG(my_perl);
#endif
debug_hash_seed(false);
#ifdef __amigaos4__
{
struct NameTranslationInfo nti;
__translate_amiga_to_unix_path_name(&argv[0],&nti);
}
#endif
{
int i;
assert(argc >= 0);
for(i = 0; i != argc; i++)
assert(argv[i]);
assert(!argv[argc]);
}
PL_origargc = argc;
/* Uncomment the next line for PATH semantics */
/* But you'll need to write tests */
/* av_push(GvAVn(PL_incgv), newSVpvs(".")); */
} else {
incpush(p, (STRLEN)(s - p), flags);
}
p = s + 1;
}
if (p != end)
incpush(p, (STRLEN)(end - p), flags);
}
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
SV *atsv;
volatile const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0;
CV *cv;
STRLEN len;
int ret;
dJMPENV;
PERL_ARGS_ASSERT_CALL_LIST;
while (av_count(paramList) > 0) {
cv = MUTABLE_CV(av_shift(paramList));
if (PL_savebegin) {
if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv));
}
else if (paramList == PL_checkav) {
/* save PL_checkav for compiler */
Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv));
}
else if (paramList == PL_unitcheckav) {
/* save PL_unitcheckav for compiler */
Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv));
}
} else {
SAVEFREESV(cv);
}
JMPENV_PUSH(ret);
switch (ret) {
case 0:
CALL_LIST_BODY(cv);
atsv = ERRSV;
(void)SvPV_const(atsv, len);
if (len) {
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
if (paramList == PL_beginav)
sv_catpvs(atsv, "BEGIN failed--compilation aborted");
else
sv_catpvf(atsv,
"%s failed--call queue aborted",
paramList == PL_checkav ? "CHECK"
: paramList == PL_initav ? "INIT"
: paramList == PL_unitcheckav ? "UNITCHECK"
: "END");
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
croak("%" SVf, SVfARG(atsv));
}
break;
case 1:
STATUS_ALL_FAILURE;
/* FALLTHROUGH */
case 2:
/* my_exit() was called */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
SET_CURSTASH(PL_defstash);
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_POP;
my_exit_jump();
NOT_REACHED; /* NOTREACHED */
case 3:
if (PL_restartop) {
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
JMPENV_JUMP(3);
}
PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
FREETMPS;
break;
}
JMPENV_POP;
}
}
/*
=for apidoc my_exit
A wrapper for the C library L<exit(3)>, honoring what L<perlapi/PL_exit_flags>
say to do.
=cut
*/
void
Perl_my_exit(pTHX_ U32 status)
{
if (PL_exit_flags & PERL_EXIT_ABORT) {
abort();
}
if (PL_exit_flags & PERL_EXIT_WARN) {
PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
warn("Unexpected exit %lu", (unsigned long)status);
PL_exit_flags &= ~PERL_EXIT_ABORT;
}
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
break;
case 1:
( run in 1.333 second using v1.01-cache-2.11-cpan-5a3173703d6 )