/* perl.c
*
- * Copyright (c) 1987-1999 Larry Wall
+ * Copyright (c) 1987-2000 Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
return my_perl;
}
#else
+
+/*
+=for apidoc perl_alloc
+
+Allocates a new Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
PerlInterpreter *
perl_alloc(void)
{
}
#endif /* PERL_IMPLICIT_SYS */
+/*
+=for apidoc perl_construct
+
+Initializes a new Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
void
perl_construct(pTHXx)
{
thr = init_main_thread();
#endif /* USE_THREADS */
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
+#endif
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
PL_patchlevel = NEWSV(0,4);
SvUPGRADE(PL_patchlevel, SVt_PVNV);
if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
- SvGROW(PL_patchlevel,24);
+ SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
s = (U8*)SvPVX(PL_patchlevel);
s = uv_to_utf8(s, (UV)PERL_REVISION);
s = uv_to_utf8(s, (UV)PERL_VERSION);
ENTER;
}
+/*
+=for apidoc perl_destruct
+
+Shuts down a Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
void
perl_destruct(pTHXx)
{
/* magical thingies */
- Safefree(PL_ofs); /* $, */
+ Safefree(PL_ofs); /* $, */
PL_ofs = Nullch;
- Safefree(PL_ors); /* $\ */
+ Safefree(PL_ors); /* $\ */
PL_ors = Nullch;
SvREFCNT_dec(PL_rs); /* $/ */
SvREFCNT_dec(PL_nrs); /* $/ helper */
PL_nrs = Nullsv;
- PL_multiline = 0; /* $* */
+ PL_multiline = 0; /* $* */
+ Safefree(PL_osname); /* $^O */
+ PL_osname = Nullch;
SvREFCNT_dec(PL_statname);
PL_statname = Nullsv;
/* startup and shutdown function lists */
SvREFCNT_dec(PL_beginav);
SvREFCNT_dec(PL_endav);
- SvREFCNT_dec(PL_stopav);
+ SvREFCNT_dec(PL_checkav);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_endav = Nullav;
- PL_stopav = Nullav;
+ PL_checkav = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
SvREFCNT_dec(PL_argvout_stack);
PL_argvout_stack = Nullav;
- SvREFCNT_dec(PL_fdpid);
- PL_fdpid = Nullav;
SvREFCNT_dec(PL_modglobal);
PL_modglobal = Nullhv;
SvREFCNT_dec(PL_preambleav);
PL_bodytarget = Nullsv;
PL_formtarget = Nullsv;
+ /* free locale stuff */
+#ifdef USE_LOCALE_COLLATE
+ Safefree(PL_collation_name);
+ PL_collation_name = Nullch;
+#endif
+
+#ifdef USE_LOCALE_NUMERIC
+ Safefree(PL_numeric_name);
+ PL_numeric_name = Nullch;
+#endif
+
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_alnum);
SvREFCNT_dec(PL_utf8_alnumc);
/* Now absolutely destruct everything, somehow or other, loops or no. */
last_sv_count = 0;
+ SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
last_sv_count = PL_sv_count;
sv_clean_all();
}
+ SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
+ SvFLAGS(PL_fdpid) |= SVt_PVAV;
SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
SvFLAGS(PL_strtab) |= SVt_PVHV;
-
+
+ AvREAL_off(PL_fdpid); /* no surviving entries */
+ SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
+ PL_fdpid = Nullav;
+
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
}
SvREFCNT_dec(PL_strtab);
+ /* free special SVs */
+
+ SvREFCNT(&PL_sv_yes) = 0;
+ sv_clear(&PL_sv_yes);
+ SvANY(&PL_sv_yes) = NULL;
+
+ SvREFCNT(&PL_sv_no) = 0;
+ sv_clear(&PL_sv_no);
+ SvANY(&PL_sv_no) = NULL;
+
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
Safefree(PL_thrsv);
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
-
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
}
}
+/*
+=for apidoc perl_free
+
+Releases a Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
void
perl_free(pTHXx)
{
++PL_exitlistlen;
}
+/*
+=for apidoc perl_parse
+
+Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
+
+=cut
+*/
+
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
- env, xsinit);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
- if (PL_stopav)
- call_list(oldscope, PL_stopav);
- return 0;
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ parse_body(env,xsinit);
+#endif
+ if (PL_checkav)
+ call_list(oldscope, PL_checkav);
+ ret = 0;
+ break;
case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_stopav)
- call_list(oldscope, PL_stopav);
- return STATUS_NATIVE_EXPORT;
+ if (PL_checkav)
+ call_list(oldscope, PL_checkav);
+ ret = STATUS_NATIVE_EXPORT;
+ break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
- return 1;
+ ret = 1;
+ break;
}
- return 0;
+ JMPENV_POP;
+ return ret;
+}
+
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+STATIC void *
+S_vparse_body(pTHX_ va_list args)
+{
+ char **env = va_arg(args, char**);
+ XSINIT_t xsinit = va_arg(args, XSINIT_t);
+
+ return parse_body(env, xsinit);
}
+#endif
STATIC void *
-S_parse_body(pTHX_ va_list args)
+S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
- char **env = va_arg(args, char**);
char *scriptname = NULL;
int fdscript = -1;
VOL bool dosearch = FALSE;
register char *s;
char *cddir = Nullch;
- XSINIT_t xsinit = va_arg(args, XSINIT_t);
-
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
SAVEFREESV(sv);
#endif
case ' ':
case '0':
+ case 'C':
case 'F':
case 'a':
case 'c':
# ifdef USE_ITHREADS
sv_catpv(PL_Sv," USE_ITHREADS");
# endif
-# ifdef USE_64_BITS
- sv_catpv(PL_Sv," USE_64_BITS");
+# ifdef USE_64_BIT_INT
+ sv_catpv(PL_Sv," USE_64_BIT_INT");
+# endif
+# ifdef USE_64_BIT_ALL
+ sv_catpv(PL_Sv," USE_64_BIT_ALL");
# endif
# ifdef USE_LONG_DOUBLE
sv_catpv(PL_Sv," USE_LONG_DOUBLE");
CvPADLIST(PL_compcv) = comppadlist;
boot_core_UNIVERSAL();
+#ifndef PERL_MICRO
boot_core_xsutils();
+#endif
if (xsinit)
(*xsinit)(aTHXo); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
init_os_extras();
#endif
return NULL;
}
+/*
+=for apidoc perl_run
+
+Tells a Perl interpreter to run. See L<perlembed>.
+
+=cut
+*/
+
int
perl_run(pTHXx)
{
dTHR;
I32 oldscope;
- int ret;
+ int ret = 0;
dJMPENV;
#ifdef USE_THREADS
dTHX;
oldscope = PL_scopestack_ix;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
goto redo_body;
- case 0: /* normal completion */
- case 2: /* my_exit() */
+ case 0: /* normal completion */
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ run_body(oldscope);
+#endif
+ /* FALL THROUGH */
+ case 2: /* my_exit() */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return STATUS_NATIVE_EXPORT;
+ ret = STATUS_NATIVE_EXPORT;
+ break;
case 3:
if (PL_restartop) {
POPSTACK_TO(PL_mainstack);
}
PerlIO_printf(Perl_error_log, "panic: restartop\n");
FREETMPS;
- return 1;
+ ret = 1;
+ break;
}
- /* NOTREACHED */
- return 0;
+ JMPENV_POP;
+ return ret;
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_run_body(pTHX_ va_list args)
+S_vrun_body(pTHX_ va_list args)
{
- dTHR;
I32 oldscope = va_arg(args, I32);
+ return run_body(oldscope);
+}
+#endif
+
+
+STATIC void *
+S_run_body(pTHX_ I32 oldscope)
+{
+ dTHR;
+
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
return NULL;
}
+/*
+=for apidoc p||get_sv
+
+Returns the SV of the specified Perl scalar. If C<create> is set and the
+Perl variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+=cut
+*/
+
SV*
Perl_get_sv(pTHX_ const char *name, I32 create)
{
return Nullsv;
}
+/*
+=for apidoc p||get_av
+
+Returns the AV of the specified Perl array. If C<create> is set and the
+Perl variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+=cut
+*/
+
AV*
Perl_get_av(pTHX_ const char *name, I32 create)
{
return Nullav;
}
+/*
+=for apidoc p||get_hv
+
+Returns the HV of the specified Perl hash. If C<create> is set and the
+Perl variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+=cut
+*/
+
HV*
Perl_get_hv(pTHX_ const char *name, I32 create)
{
return Nullhv;
}
+/*
+=for apidoc p||get_cv
+
+Returns the CV of the specified Perl subroutine. If C<create> is set and
+the Perl subroutine does not exist then it will be declared (which has the
+same effect as saying C<sub name;>). If C<create> is not set and the
+subroutine does not exist then NULL is returned.
+
+=cut
+*/
+
CV*
Perl_get_cv(pTHX_ const char *name, I32 create)
{
/* Be sure to refetch the stack pointer after calling these routines. */
+/*
+=for apidoc p||call_argv
+
+Performs a callback to the specified Perl sub. See L<perlcall>.
+
+=cut
+*/
+
I32
Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
return call_pv(sub_name, flags);
}
+/*
+=for apidoc p||call_pv
+
+Performs a callback to the specified Perl sub. See L<perlcall>.
+
+=cut
+*/
+
I32
Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
/* name of the subroutine */
return call_sv((SV*)get_cv(sub_name, TRUE), flags);
}
+/*
+=for apidoc p||call_method
+
+Performs a callback to the specified Perl method. The blessed object must
+be on the stack. See L<perlcall>.
+
+=cut
+*/
+
I32
Perl_call_method(pTHX_ const char *methname, I32 flags)
/* name of the subroutine */
{
dSP;
OP myop;
- if (!PL_op)
+ if (!PL_op) {
+ Zero(&myop, 1, OP);
PL_op = &myop;
+ }
XPUSHs(sv_2mortal(newSVpv(methname,0)));
PUTBACK;
pp_method();
- if(PL_op == &myop)
- PL_op = Nullop;
+ if (PL_op == &myop)
+ PL_op = Nullop;
return call_sv(*PL_stack_sp--, flags);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
+/*
+=for apidoc p||call_sv
+
+Performs a callback to the Perl sub whose name is in the SV. See
+L<perlcall>.
+
+=cut
+*/
+
I32
Perl_call_sv(pTHX_ SV *sv, I32 flags)
if (!(flags & G_EVAL)) {
CATCH_SET(TRUE);
- call_xbody((OP*)&myop, FALSE);
+ call_body((OP*)&myop, FALSE);
retval = PL_stack_sp - (PL_stack_base + oldmark);
CATCH_SET(oldcatch);
}
}
PL_markstack_ptr++;
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, FALSE);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ call_body((OP*)&myop, FALSE);
+#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
PL_curpm = newpm;
LEAVE;
}
+ JMPENV_POP;
}
if (flags & G_DISCARD) {
return retval;
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_call_body(pTHX_ va_list args)
+S_vcall_body(pTHX_ va_list args)
{
OP *myop = va_arg(args, OP*);
int is_eval = va_arg(args, int);
- call_xbody(myop, is_eval);
+ call_body(myop, is_eval);
return NULL;
}
+#endif
STATIC void
-S_call_xbody(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ OP *myop, int is_eval)
{
dTHR;
/* Eval a string. The G_EVAL flag is always assumed. */
+/*
+=for apidoc p||eval_sv
+
+Tells Perl to C<eval> the string in the SV.
+
+=cut
+*/
+
I32
Perl_eval_sv(pTHX_ SV *sv, I32 flags)
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, TRUE);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ redo_body:
+ call_body((OP*)&myop,TRUE);
+#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
break;
}
+ JMPENV_POP;
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
retval = 0;
return retval;
}
+/*
+=for apidoc p||eval_pv
+
+Tells Perl to C<eval> the given string and return an SV* result.
+
+=cut
+*/
+
SV*
Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
/* Require a module. */
+/*
+=for apidoc p||require_pv
+
+Tells Perl to C<require> a module.
+
+=cut
+*/
+
void
Perl_require_pv(pTHX_ const char *pv)
{
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
+"-C enable native wide character system interfaces",
"-c check syntax only (runs BEGIN and END blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-v print version, subversion (includes VERY IMPORTANT perl info)",
"-V[:variable] print configuration summary (or a single Config.pm variable)",
"-w enable many useful warnings (RECOMMENDED)",
+"-W enable all warnings",
+"-X disable all warnings",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
"\n",
NULL
}
return s + numlen;
}
+ case 'C':
+ PL_widesyscalls = TRUE;
+ s++;
+ return s;
case 'F':
PL_minus_F = TRUE;
PL_splitstr = savepv(s + 1);
s++;
return s;
case 'v':
- printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
- (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
+ printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
+ PL_patchlevel, ARCHNAME));
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
printf("\n(with %d registered patch%s, see perl -V for more detail)",
(int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- printf("\n\nCopyright 1987-1999, Larry Wall\n");
+ printf("\n\nCopyright 1987-2000, Larry Wall\n");
#ifdef MSDOS
printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef __MINT__
printf("MiNT port by Guido Flohr, 1997-1999\n");
#endif
+#ifdef EPOC
+ printf("EPOC port by Olaf Flebbe, 1999-2000\n");
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
/* Mention
* I_SYSSTATVFS HAS_FSTATVFS
* I_SYSMOUNT
- * I_STATFS HAS_FSTATFS
+ * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
* I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
* here so that metaconfig picks them up. */
incpush(PRIVLIB_EXP, FALSE);
#endif
-#ifdef SITEARCH_EXP
- incpush(SITEARCH_EXP, FALSE);
-#endif
-#ifdef SITELIB_EXP
-#if defined(WIN32)
- incpush(SITELIB_EXP, TRUE);
+#if defined(WIN32)
+ incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
#else
- incpush(SITELIB_EXP, FALSE);
+#ifdef SITELIB_EXP
+ {
+ char *path = SITELIB_EXP;
+
+ if (path) {
+ char buf[1024];
+ strcpy(buf,path);
+ if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
+ *strrchr(buf,'/') = '\0';
+ incpush(buf, TRUE);
+ }
+ }
#endif
#endif
#if defined(PERL_VENDORLIB_EXP)
* archname-specific sub-directories.
*/
if (addsubdirs) {
+#ifdef PERL_INC_VERSION_LIST
+ /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
+ const char *incverlist[] = { PERL_INC_VERSION_LIST };
+ const char **incver;
+#endif
struct stat tmpstatbuf;
#ifdef VMS
char *unix;
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
- /* .../archname/version if -d .../archname/version/auto */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/"PERL_FS_VER_FMT"/auto", libdir,
- ARCHNAME, (int)PERL_REVISION,
- (int)PERL_VERSION, (int)PERL_SUBVERSION);
+ /* .../version/archname if -d .../version/archname */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION, ARCHNAME);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+
+ /* .../version if -d .../version */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv),
- newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
- /* .../archname if -d .../archname/auto */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/auto", libdir, ARCHNAME);
+ /* .../archname if -d .../archname */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv),
- newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+
+#ifdef PERL_INC_VERSION_LIST
+ for (incver = incverlist; *incver; incver++) {
+ /* .../xxx if -d .../xxx */
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ }
+#endif
}
/* finally push this lib directory on the end of @INC */
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
+ CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
+#else
+ JMPENV_PUSH(ret);
+#endif
switch (ret) {
case 0:
+#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ call_list_body(cv);
+#endif
atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
else
Perl_sv_catpvf(aTHX_ atsv,
"%s failed--call queue aborted",
- paramList == PL_stopav ? "STOP"
+ paramList == PL_checkav ? "CHECK"
: paramList == PL_initav ? "INIT"
: "END");
while (PL_scopestack_ix > oldscope)
LEAVE;
+ JMPENV_POP;
Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
}
break;
PL_curstash = PL_defstash;
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
+ JMPENV_POP;
if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
else
Perl_croak(aTHX_ "%s failed--call queue aborted",
- paramList == PL_stopav ? "STOP"
+ paramList == PL_checkav ? "CHECK"
: paramList == PL_initav ? "INIT"
: "END");
}
FREETMPS;
break;
}
+ JMPENV_POP;
}
}
+#ifdef PERL_FLEXIBLE_EXCEPTIONS
STATIC void *
-S_call_list_body(pTHX_ va_list args)
+S_vcall_list_body(pTHX_ va_list args)
{
- dTHR;
CV *cv = va_arg(args, CV*);
+ return call_list_body(cv);
+}
+#endif
+STATIC void *
+S_call_list_body(pTHX_ CV *cv)
+{
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
return NULL;
projects / p5sagit/p5-mst-13.2.git / blobdiff