/* 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
#ifdef PERL_OBJECT
my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
ipLIO, ipD, ipS, ipP);
- PERL_SET_INTERP(my_perl);
+ if (!PL_curinterp) {
+ PERL_SET_INTERP(my_perl);
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ INIT_THREADS;
+ ALLOC_THREAD_KEY;
+#endif
+ }
+ PERL_SET_THX(my_perl);
#else
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- PERL_SET_INTERP(my_perl);
+ if (!PL_curinterp) {
+ PERL_SET_INTERP(my_perl);
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ INIT_THREADS;
+ ALLOC_THREAD_KEY;
+#endif
+ }
+ PERL_SET_THX(my_perl);
Zero(my_perl, 1, PerlInterpreter);
PL_Mem = ipM;
PL_MemShared = ipMS;
return my_perl;
}
#else
+
+/*
+=for apidoc perl_alloc
+
+Allocates a new Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
PerlInterpreter *
perl_alloc(void)
{
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
- PERL_SET_INTERP(my_perl);
+
+ if (!PL_curinterp) {
+ PERL_SET_INTERP(my_perl);
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+ INIT_THREADS;
+ ALLOC_THREAD_KEY;
+#endif
+ }
+ PERL_SET_THX(my_perl);
Zero(my_perl, 1, PerlInterpreter);
return my_perl;
}
#endif /* PERL_IMPLICIT_SYS */
+/*
+=for apidoc perl_construct
+
+Initializes a new Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
void
perl_construct(pTHXx)
{
struct perl_thread *thr = NULL;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
-
+
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
#ifdef USE_THREADS
-
- INIT_THREADS;
-#ifdef ALLOC_THREAD_KEY
- ALLOC_THREAD_KEY;
-#else
- if (pthread_key_create(&PL_thr_key, 0))
- Perl_croak(aTHX_ "panic: pthread_key_create");
-#endif
MUTEX_INIT(&PL_sv_mutex);
/*
* Safe to use basic SV functions from now on (though
COND_INIT(&PL_eval_cond);
MUTEX_INIT(&PL_threads_mutex);
COND_INIT(&PL_nthreads_cond);
-#ifdef EMULATE_ATOMIC_REFCOUNTS
+# ifdef EMULATE_ATOMIC_REFCOUNTS
MUTEX_INIT(&PL_svref_mutex);
-#endif /* EMULATE_ATOMIC_REFCOUNTS */
+# endif /* EMULATE_ATOMIC_REFCOUNTS */
MUTEX_INIT(&PL_cred_mutex);
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':
if (!*++s && (s=argv[1]) != Nullch) {
argc--,argv++;
}
- while (s && isSPACE(*s))
- ++s;
if (s && *s) {
- char *e, *p;
- for (e = s; *e && !isSPACE(*e); e++) ;
- p = savepvn(s, e-s);
+ char *p;
+ STRLEN len = strlen(s);
+ p = savepvn(s, len);
incpush(p, TRUE);
- sv_catpv(sv,"-I");
- sv_catpv(sv,p);
- sv_catpv(sv," ");
+ sv_catpvn(sv, "-I", 2);
+ sv_catpvn(sv, p, len);
+ sv_catpvn(sv, " ", 1);
Safefree(p);
- } /* XXX else croak? */
+ }
+ else
+ Perl_croak(aTHX_ "No directory specified for -I");
break;
case 'P':
forbid_setid("-P");
# ifdef USE_THREADS
sv_catpv(PL_Sv," USE_THREADS");
# endif
+# ifdef USE_ITHREADS
+ sv_catpv(PL_Sv," USE_ITHREADS");
+# endif
+# 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");
+# endif
+# ifdef USE_LARGE_FILES
+ sv_catpv(PL_Sv," USE_LARGE_FILES");
+# endif
+# ifdef USE_SOCKS
+ sv_catpv(PL_Sv," USE_SOCKS");
+# endif
# ifdef PERL_OBJECT
sv_catpv(PL_Sv," PERL_OBJECT");
# endif
#ifndef SECURE_INTERNAL_GETENV
!PL_tainting &&
#endif
- (s = PerlEnv_getenv("PERL5OPT"))) {
+ (s = PerlEnv_getenv("PERL5OPT")))
+ {
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T')
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;
if (*s) {
char *e, *p;
- for (e = s; *e && !isSPACE(*e); e++) ;
- p = savepvn(s, e-s);
- incpush(p, TRUE);
- Safefree(p);
- s = e;
+ p = s;
+ /* ignore trailing spaces (possibly followed by other switches) */
+ do {
+ for (e = p; *e && !isSPACE(*e); e++) ;
+ p = e;
+ while (isSPACE(*p))
+ p++;
+ } while (*p && *p != '-');
+ e = savepvn(s, e-s);
+ incpush(e, TRUE);
+ Safefree(e);
+ s = p;
+ if (*s == '-')
+ s++;
}
else
- Perl_croak(aTHX_ "No space allowed after -I");
+ Perl_croak(aTHX_ "No directory specified for -I");
return s;
case 'l':
PL_minus_l = TRUE;
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
Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
sv_catpv(cpp, cpp_cfg);
- sv_catpv(sv,"-I");
+ sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
#ifdef MSDOS
-e \"/^#[ ]*undef[ ]/b\" \
-e \"/^#[ ]*endif/b\" \
-e \"s/^#.*//\" \
- %s | %_ -C %_ %s",
+ %s | %"SVf" -C %"SVf" %s",
(PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
# ifdef __OPEN_VM
-e '/^#[ ]*undef[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
- %s | %_ %_ %s",
+ %s | %"SVf" %"SVf" %s",
# else
Perl_sv_setpvf(aTHX_ cmd, "\
%s %s -e '/^[^#]/b' \
-e '/^#[ ]*undef[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
- %s | %_ -C %_ %s",
+ %s | %"SVf" -C %"SVf" %s",
# endif
#ifdef LOC_SED
LOC_SED,
{
/* try again */
PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
- (UV)PERL_REVISION, (UV)PERL_VERSION,
- (UV)PERL_SUBVERSION), PL_origargv);
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION), PL_origargv);
Perl_croak(aTHX_ "Can't do setuid\n");
}
#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. */
#ifndef IAMSUID
/* try again */
PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
- (UV)PERL_REVISION, (UV)PERL_VERSION,
- (UV)PERL_SUBVERSION), PL_origargv);
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION), PL_origargv);
#endif
Perl_croak(aTHX_ "Can't do setuid\n");
}
fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
- (UV)PERL_REVISION, (UV)PERL_VERSION,
- (UV)PERL_SUBVERSION), PL_origargv);/* try again */
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION), PL_origargv);/* try again */
Perl_croak(aTHX_ "Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
for (; argc > 0 && **argv == '-'; argc--,argv++) {
if (!argv[0][1])
break;
- if (argv[0][1] == '-') {
+ if (argv[0][1] == '-' && !argv[0][2]) {
argc--,argv++;
break;
}
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, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir,
- ARCHNAME, (UV)PERL_REVISION,
- (UV)PERL_VERSION, (UV)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),
- newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ av_push(GvAVn(PL_incgv), newSVsv(subdir));
- /* .../archname if -d .../archname/auto */
- Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME);
+ /* .../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 */
+ 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), 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