/* 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.
#endif
#ifdef PERL_OBJECT
-CPerlObj*
-perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
- struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
- struct IPerlDir* ipD, struct IPerlSock* ipS,
- struct IPerlProc* ipP)
-{
- CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
- if (pPerl != NULL)
- pPerl->Init();
-
- return pPerl;
-}
-#else
+#define perl_construct Perl_construct
+#define perl_parse Perl_parse
+#define perl_run Perl_run
+#define perl_destruct Perl_destruct
+#define perl_free Perl_free
+#endif
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
-perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
+perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
+ struct IPerlMem* ipMP, struct IPerlEnv* ipE,
struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
struct IPerlDir* ipD, struct IPerlSock* ipS,
struct IPerlProc* ipP)
{
PerlInterpreter *my_perl;
-
+#ifdef PERL_OBJECT
+ my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
+ ipLIO, ipD, ipS, ipP);
+ PERL_SET_INTERP(my_perl);
+#else
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_INTERP(my_perl);
Zero(my_perl, 1, PerlInterpreter);
PL_Mem = ipM;
+ PL_MemShared = ipMS;
+ PL_MemParse = ipMP;
PL_Env = ipE;
PL_StdIO = ipStd;
PL_LIO = ipLIO;
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+#endif
+
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);
+ Zero(my_perl, 1, PerlInterpreter);
return my_perl;
}
#endif /* PERL_IMPLICIT_SYS */
-#endif /* PERL_OBJECT */
+
+/*
+=for apidoc perl_construct
+
+Initializes a new Perl interpreter. See L<perlembed>.
+
+=cut
+*/
void
perl_construct(pTHXx)
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
-#ifdef USE_THREADS
-
INIT_THREADS;
+#ifdef USE_THREADS
#ifdef ALLOC_THREAD_KEY
ALLOC_THREAD_KEY;
#else
init_i18nl10n(1);
SET_NUMERIC_STANDARD();
+ {
+ U8 *s;
+ PL_patchlevel = NEWSV(0,4);
+ SvUPGRADE(PL_patchlevel, SVt_PVNV);
+ if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
+ SvGROW(PL_patchlevel,24);
+ s = (U8*)SvPVX(PL_patchlevel);
+ s = uv_to_utf8(s, (UV)PERL_REVISION);
+ s = uv_to_utf8(s, (UV)PERL_VERSION);
+ s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
+ *s = '\0';
+ SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
+ SvPOK_on(PL_patchlevel);
+ SvNVX(PL_patchlevel) = (NV)PERL_REVISION
+ + ((NV)PERL_VERSION / (NV)1000)
#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
- sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
- + ((double) PERL_VERSION / (double) 1000)
- + ((double) PERL_SUBVERSION / (double) 100000));
-#else
- sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
- ((double) PERL_VERSION / (double) 1000));
+ + ((NV)PERL_SUBVERSION / (NV)1000000)
#endif
+ ;
+ SvNOK_on(PL_patchlevel); /* dual valued */
+ SvUTF8_on(PL_patchlevel);
+ SvREADONLY_on(PL_patchlevel);
+ }
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
ENTER;
}
+/*
+=for apidoc perl_destruct
+
+Shuts down a Perl interpreter. See L<perlembed>.
+
+=cut
+*/
+
void
perl_destruct(pTHXx)
{
dTHX;
#endif /* USE_THREADS */
+ /* wait for all pseudo-forked children to finish */
+ PERL_WAIT_FOR_CHILDREN;
+
#ifdef USE_THREADS
#ifndef FAKE_THREADS
/* Pass 1 on any remaining threads: detach joinables, join zombies */
Safefree(PL_inplace);
PL_inplace = Nullch;
+ SvREFCNT_dec(PL_patchlevel);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
/* 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 */
PL_stderrgv = Nullgv;
PL_last_in_gv = Nullgv;
PL_replgv = Nullgv;
+ PL_debstash = Nullhv;
/* reset so print() ends up where we expect */
setdefout(Nullgv);
+ SvREFCNT_dec(PL_argvout_stack);
+ PL_argvout_stack = Nullav;
+
+ SvREFCNT_dec(PL_modglobal);
+ PL_modglobal = Nullhv;
+ SvREFCNT_dec(PL_preambleav);
+ PL_preambleav = Nullav;
+ SvREFCNT_dec(PL_subname);
+ PL_subname = Nullsv;
+ SvREFCNT_dec(PL_linestr);
+ PL_linestr = Nullsv;
+ SvREFCNT_dec(PL_pidstatus);
+ PL_pidstatus = Nullhv;
+ SvREFCNT_dec(PL_toptarget);
+ PL_toptarget = Nullsv;
+ SvREFCNT_dec(PL_bodytarget);
+ PL_bodytarget = Nullsv;
+ PL_formtarget = Nullsv;
+
+ /* free locale stuff */
+ Safefree(PL_collation_name);
+ PL_collation_name = Nullch;
+
+ Safefree(PL_numeric_name);
+ PL_numeric_name = Nullch;
+
+ /* clear utf8 character classes */
+ SvREFCNT_dec(PL_utf8_alnum);
+ SvREFCNT_dec(PL_utf8_alnumc);
+ SvREFCNT_dec(PL_utf8_ascii);
+ SvREFCNT_dec(PL_utf8_alpha);
+ SvREFCNT_dec(PL_utf8_space);
+ SvREFCNT_dec(PL_utf8_cntrl);
+ SvREFCNT_dec(PL_utf8_graph);
+ SvREFCNT_dec(PL_utf8_digit);
+ SvREFCNT_dec(PL_utf8_upper);
+ SvREFCNT_dec(PL_utf8_lower);
+ SvREFCNT_dec(PL_utf8_print);
+ SvREFCNT_dec(PL_utf8_punct);
+ SvREFCNT_dec(PL_utf8_xdigit);
+ SvREFCNT_dec(PL_utf8_mark);
+ SvREFCNT_dec(PL_utf8_toupper);
+ SvREFCNT_dec(PL_utf8_tolower);
+ PL_utf8_alnum = Nullsv;
+ PL_utf8_alnumc = Nullsv;
+ PL_utf8_ascii = Nullsv;
+ PL_utf8_alpha = Nullsv;
+ PL_utf8_space = Nullsv;
+ PL_utf8_cntrl = Nullsv;
+ PL_utf8_graph = Nullsv;
+ PL_utf8_digit = Nullsv;
+ PL_utf8_upper = Nullsv;
+ PL_utf8_lower = Nullsv;
+ PL_utf8_print = Nullsv;
+ PL_utf8_punct = Nullsv;
+ PL_utf8_xdigit = Nullsv;
+ PL_utf8_mark = Nullsv;
+ PL_utf8_toupper = Nullsv;
+ PL_utf8_totitle = Nullsv;
+ PL_utf8_tolower = Nullsv;
+
+ if (!specialWARN(PL_compiling.cop_warnings))
+ SvREFCNT_dec(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = Nullsv;
+
/* Prepare to destruct main symbol table. */
hv = PL_defstash;
PL_defstash = 0;
SvREFCNT_dec(hv);
+ SvREFCNT_dec(PL_curstname);
+ PL_curstname = Nullsv;
/* clear queued errors */
SvREFCNT_dec(PL_errors);
/* 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);
sv_free_arenas();
/* No SVs have survived, need to clean out */
- PL_linestr = NULL;
- PL_pidstatus = Nullhv;
Safefree(PL_origfilename);
- Safefree(PL_archpat_auto);
Safefree(PL_reg_start_tmp);
if (PL_reg_curpm)
Safefree(PL_reg_curpm);
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)
{
env, xsinit);
switch (ret) {
case 0:
- if (PL_stopav)
- call_list(oldscope, PL_stopav);
+ if (PL_checkav)
+ call_list(oldscope, PL_checkav);
return 0;
case 1:
STATUS_ALL_FAILURE;
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_stopav)
- call_list(oldscope, PL_stopav);
+ if (PL_checkav)
+ call_list(oldscope, PL_checkav);
return STATUS_NATIVE_EXPORT;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
#endif
case ' ':
case '0':
+ case 'C':
case 'F':
case 'a':
case 'c':
goto reswitch;
case 'e':
-#ifdef MACOS_TRADITIONAL
- /* ignore -e for Dev:Pseudo argument */
- if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
- break;
-#endif
if (PL_euid != PL_uid || PL_egid != PL_gid)
Perl_croak(aTHX_ "No -e allowed in setuid scripts");
if (!PL_e_script) {
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_BITS
+ sv_catpv(PL_Sv," USE_64_BITS");
+# 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')
}
#endif
-#ifdef MACOS_TRADITIONAL
- if (PL_doextract || gAlwaysExtract)
-#else
if (PL_doextract) {
-#endif
find_beginning();
if (cddir && PerlDir_chdir(cddir) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+
}
PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
SETERRNO(0,SS$_NORMAL);
PL_error_count = 0;
-#ifdef MACOS_TRADITIONAL
- if (gSyntaxError = (yyparse() || PL_error_count)) {
- if (PL_minus_c)
- Perl_croak(aTHX_ "%s had compilation errors.\n", MPWFileName(PL_origfilename));
- else {
- Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
- MPWFileName(PL_origfilename));
- }
- }
-#else
if (yyparse() || PL_error_count) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
PL_origfilename);
}
}
-#endif
- PL_curcop->cop_line = 0;
+ CopLINE_set(PL_curcop, 0);
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
if (PL_e_script) {
if (PL_do_undump)
my_unexec();
- if (isWARN_ONCE)
+ if (isWARN_ONCE) {
+ SAVECOPFILE(PL_curcop);
+ SAVECOPLINE(PL_curcop);
gv_check(PL_defstash);
+ }
LEAVE;
FREETMPS;
return NULL;
}
+/*
+=for apidoc perl_run
+
+Tells a Perl interpreter to run. See L<perlembed>.
+
+=cut
+*/
+
int
perl_run(pTHXx)
{
PTR2UV(thr)));
if (PL_minus_c) {
-#ifdef MACOS_TRADITIONAL
- PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", MPWFileName(PL_origfilename));
-#else
PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
-#endif
-my_exit(0);
+ my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
sv_setiv(PL_DBsingle, 1);
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)
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
- if (PL_statusvalue)
+ if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
/* NOTREACHED */
/* 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)
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
- if (PL_statusvalue)
+ if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
/* NOTREACHED */
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)",
}
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;
sv_catpv(sv, "})");
}
s += strlen(s);
- if (PL_preambleav == NULL)
+ if (!PL_preambleav)
PL_preambleav = newAV();
av_push(PL_preambleav, sv);
}
s++;
return s;
case 'u':
-#ifdef MACOS_TRADITIONAL
- Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
-#endif
PL_do_undump = TRUE;
s++;
return s;
s++;
return s;
case 'v':
-#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
- printf("\nThis is perl, version %d.%03d_%02d built for %s",
- PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
-#else
- printf("\nThis is perl, version %s built for %s",
- PL_patchlevel, ARCHNAME);
-#endif
+ printf(Perl_form(aTHX_ "\nThis is perl, v%v 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");
-#ifdef MACOS_TRADITIONAL
- fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout);
-#endif
+ printf("\n\nCopyright 1987-2000, Larry Wall\n");
#ifdef MSDOS
printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
# endif
#endif
-#ifdef MACOS_TRADITIONAL
- /* In MacOS time() already returns values in excess of 2**31-1,
- * therefore we patch the integerness away. */
- PL_opargs[OP_TIME] &= ~OA_RETINTEGER;
-#endif
-
}
STATIC void
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
sv_setpvn(ERRSV, "", 0);
PL_curstash = PL_defstash;
- PL_compiling.cop_stash = PL_defstash;
+ CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
}
}
- CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename));
+ CopFILE_set(PL_curcop, PL_origfilename);
if (strEQ(PL_origfilename,"-"))
scriptname = "";
if (*fdscript >= 0) {
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,
PL_statbuf.st_mode & (S_ISUID|S_ISGID))
{
/* try again */
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+ PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION), PL_origargv);
Perl_croak(aTHX_ "Can't do setuid\n");
}
#endif
# if defined(HAS_FSTAT) && \
defined(HAS_USTAT) && \
defined(HAS_GETMNT) && \
- defined(HAS_STRUCT_FS_DATA) &&
+ defined(HAS_STRUCT_FS_DATA) && \
defined(NOSTAT_ONE)
struct stat fdst;
if (fstat(fd, &fdst) == 0) {
if (PL_statbuf.st_mode & S_IWOTH)
Perl_croak(aTHX_ "Setuid/gid script is writable by world");
PL_doswitches = FALSE; /* -s is insecure in suid */
- PL_curcop->cop_line++;
+ CopLINE_inc(PL_curcop);
if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
Perl_croak(aTHX_ "No #! line");
(void)PerlIO_close(PL_rsfp);
#ifndef IAMSUID
/* try again */
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+ PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
+ (int)PERL_REVISION, (int)PERL_VERSION,
+ (int)PERL_SUBVERSION), PL_origargv);
#endif
Perl_croak(aTHX_ "Can't do setuid\n");
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
- PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
+ PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
+ (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 */
/* skip forward in input to the real script? */
forbid_setid("-x");
-#ifdef MACOS_TRADITIONAL
- /* Since the Mac OS does not honor !# arguments for us,
- * we do it ourselves. */
- while (PL_doextract || gAlwaysExtract) {
- if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
- if (!gAlwaysExtract)
- Perl_croak(aTHX_ "No Perl script found in input\n");
-
- if (PL_doextract) /* require explicit override ? */
- if (!OverrideExtract(PL_origfilename))
- Perl_croak(aTHX_ "User aborted script\n");
- else
- PL_doextract = FALSE;
-
- /* Pater peccavi, file does not have #! */
- PerlIO_rewind(PL_rsfp);
-
- break;
- }
-#else
while (PL_doextract) {
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
Perl_croak(aTHX_ "No Perl script found in input\n");
-#endif
if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
- PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
+ PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
s2 = s;
PL_markstack_ptr = PL_markstack;
PL_markstack_max = PL_markstack + REASONABLE(32);
- SET_MARKBASE;
+ SET_MARK_OFFSET;
New(54,PL_scopestack,REASONABLE(32),I32);
PL_scopestack_ix = 0;
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (PL_osname)
- Safefree(PL_osname);
- PL_osname = savepv(OSNAME);
+ if (!PL_osname)
+ PL_osname = savepv(OSNAME);
}
STATIC void
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;
}
TAINT;
if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
-#ifdef MACOS_TRADITIONAL
- sv_setpv(GvSV(tmpgv),MPWFileName(PL_origfilename));
- /* $0 is not majick on a Mac */
-#else
sv_setpv(GvSV(tmpgv),PL_origfilename);
magicname("0", "0", 1);
-#endif
}
if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
#ifdef OS2
for (; argc > 0; argc--,argv++) {
av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
}
- PL_argvout_stack = newAV();
}
if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
HV *hv;
}
TAINT_NOT;
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (IV)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
}
STATIC void
#ifdef ARCHLIB_EXP
incpush(ARCHLIB_EXP, FALSE);
#endif
-#ifdef MACOS_TRADITIONAL
- {
- struct stat tmpstatbuf;
- SV * privdir = NEWSV(55, 0);
- char * macperl = getenv("MACPERL") || "";
-
- Perl_sv_setpvf(privdir, "%slib:", macperl);
- if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE);
- Perl_sv_setpvf(privdir, "%ssite_perl:", macperl);
- if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE);
-
- SvREFCNT_dec(privdir);
- }
- if (!PL_tainting)
- incpush(":", FALSE);
-#else
#ifndef PRIVLIB_EXP
#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
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)
#endif
if (!PL_tainting)
incpush(".", FALSE);
-#endif /* MACOS_TRADITIONAL */
}
-#if defined(MACOS_TRADITIONAL)
-# define PERLLIB_SEP ','
+#if defined(DOSISH)
+# define PERLLIB_SEP ';'
#else
-# if defined(DOSISH)
-# define PERLLIB_SEP ';'
+# if defined(VMS)
+# define PERLLIB_SEP '|'
# else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
-# else
-# define PERLLIB_SEP ':'
-# endif
+# define PERLLIB_SEP ':'
# endif
-#endif
+#endif
#ifndef PERLLIB_MANGLE
-# define PERLLIB_MANGLE(s,n) (s)
+# define PERLLIB_MANGLE(s,n) (s)
#endif
STATIC void
if (addsubdirs) {
subdir = sv_newmortal();
- if (!PL_archpat_auto) {
- STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
- + sizeof("//auto"));
- New(55, PL_archpat_auto, len, char);
-#ifdef MACOS_TRADITIONAL
- sprintf(PL_archpat_auto, "%s:%s:auto:", ARCHNAME, PL_patchlevel);
-#else
- sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
-#endif
-#ifdef VMS
- for (len = sizeof(ARCHNAME) + 2;
- PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
- if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
-#endif
- }
}
/* Break at all separators */
sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
p = Nullch; /* break out */
}
-#ifdef MACOS_TRADITIONAL
- if (!strchr(SvPVX(libdir), ':'))
- sv_insert(libdir, 0, 0, ":", 1);
- if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
- sv_catpv(libdir, ":");
-#endif
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* 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 */
- sv_setsv(subdir, libdir);
- sv_catpv(subdir, PL_archpat_auto);
+ /* .../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 */
- sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
- strlen(PL_patchlevel) + 1, "", 0);
+ /* .../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 */
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
dTHR;
- SV *atsv = ERRSV;
- line_t oldline = PL_curcop->cop_line;
+ SV *atsv;
+ line_t oldline = CopLINE(PL_curcop);
CV *cv;
STRLEN len;
int ret;
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
switch (ret) {
case 0:
+ atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
+ STRLEN n_a;
PL_curcop = &PL_compiling;
- PL_curcop->cop_line = oldline;
+ CopLINE_set(PL_curcop, oldline);
if (paramList == PL_beginav)
sv_catpv(atsv, "BEGIN failed--compilation aborted");
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;
- Perl_croak(aTHX_ "%s", SvPVX(atsv));
+ Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
}
break;
case 1:
FREETMPS;
PL_curstash = PL_defstash;
PL_curcop = &PL_compiling;
- PL_curcop->cop_line = oldline;
- if (PL_statusvalue) {
+ CopLINE_set(PL_curcop, oldline);
+ 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");
}
case 3:
if (PL_restartop) {
PL_curcop = &PL_compiling;
- PL_curcop->cop_line = oldline;
+ CopLINE_set(PL_curcop, oldline);
JMPENV_JUMP(3);
}
PerlIO_printf(Perl_error_log, "panic: restartop\n");
sv_chop(PL_e_script, nl);
return 1;
}
-
projects / p5sagit/p5-mst-13.2.git / blobdiff