# endif /* EMULATE_ATOMIC_REFCOUNTS */
MUTEX_INIT(&PL_cred_mutex);
+ MUTEX_INIT(&PL_sv_lock_mutex);
+ MUTEX_INIT(&PL_fdpid_mutex);
thr = init_main_thread();
#endif /* USE_THREADS */
PL_localpatches = local_patches; /* For possible -v */
#endif
+#ifdef HAVE_INTERP_INTERN
+ sys_intern_init();
+#endif
+
PerlIO_init(); /* Hook to IO system */
PL_fdpid = newAV(); /* for remembering popen pids by fd */
DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
MUTEX_DESTROY(&PL_threads_mutex);
COND_DESTROY(&PL_nthreads_cond);
+ PL_nthreads--;
#endif /* !defined(FAKE_THREADS) */
#endif /* USE_THREADS */
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
-#ifndef USE_ITHREADS
+#ifdef USE_ITHREADS
+ Safefree(CopFILE(&PL_compiling));
+ CopFILE(&PL_compiling) = Nullch;
+ Safefree(CopSTASHPV(&PL_compiling));
+#else
SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV_set(&PL_compiling, Nullgv);
+ CopFILEGV(&PL_compiling) = Nullgv;
+ /* cop_stash is not refcounted */
#endif
/* Prepare to destruct main symbol table. */
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
PL_fdpid = Nullav;
+#ifdef HAVE_INTERP_INTERN
+ sys_intern_clear();
+#endif
+
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
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 */
Safefree(PL_origfilename);
Safefree(PL_reg_start_tmp);
if (PL_reg_curpm)
Safefree(PL_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
+ Safefree(PL_psig_ptr);
+ Safefree(PL_psig_name);
nuke_stacks();
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
MUTEX_DESTROY(&PL_sv_mutex);
MUTEX_DESTROY(&PL_eval_mutex);
MUTEX_DESTROY(&PL_cred_mutex);
+ MUTEX_DESTROY(&PL_fdpid_mutex);
COND_DESTROY(&PL_eval_cond);
#ifdef EMULATE_ATOMIC_REFCOUNTS
MUTEX_DESTROY(&PL_svref_mutex);
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
+ sv_free_arenas();
+
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
PL_origargv = argv;
PL_origargc = argc;
-#ifndef VMS /* VMS doesn't have environ array */
+#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
PL_origenviron = environ;
#endif
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) {
validate_suid(validarg, scriptname,fdscript);
+#ifndef PERL_MICRO
#if defined(SIGCHLD) || defined(SIGCLD)
{
#ifndef SIGCHLD
}
}
#endif
+#endif
+#ifdef MACOS_TRADITIONAL
+ if (PL_doextract || gMacPerl_AlwaysExtract) {
+#else
if (PL_doextract) {
+#endif
find_beginning();
if (cddir && PerlDir_chdir(cddir) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
if (xsinit)
(*xsinit)(aTHXo); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
+#ifndef PERL_MICRO
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
init_os_extras();
#endif
+#endif
#ifdef USE_SOCKS
+# ifdef HAS_SOCKS5_INIT
+ socks5_init(argv[0]);
+# else
SOCKSinit(argv[0]);
+# endif
#endif
init_predump_symbols();
SETERRNO(0,SS$_NORMAL);
PL_error_count = 0;
+#ifdef MACOS_TRADITIONAL
+ if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
+ if (PL_minus_c)
+ Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
+ else {
+ Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
+ MacPerl_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
CopLINE_set(PL_curcop, 0);
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
PTR2UV(thr)));
if (PL_minus_c) {
+#ifdef MACOS_TRADITIONAL
+ PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
+#else
PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
+#endif
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- dSP;
- OP myop;
- 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;
- return call_sv(*PL_stack_sp--, flags);
+ return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
I32
Perl_call_sv(pTHX_ SV *sv, I32 flags)
-
/* See G_* flags in cop.h */
{
dSP;
LOGOP myop; /* fake syntax tree node */
+ UNOP method_op;
I32 oldmark;
I32 retval;
I32 oldscope;
&& !(flags & G_NODEBUG))
PL_op->op_private |= OPpENTERSUB_DB;
+ if (flags & G_METHOD) {
+ Zero(&method_op, 1, UNOP);
+ method_op.op_next = PL_op;
+ method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
+ myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ PL_op = (OP*)&method_op;
+ }
+
if (!(flags & G_EVAL)) {
CATCH_SET(TRUE);
call_body((OP*)&myop, FALSE);
CATCH_SET(oldcatch);
}
else {
- cLOGOP->op_other = PL_op;
+ myop.op_other = (OP*)&myop;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
ENTER;
SAVETMPS;
- push_return(PL_op->op_next);
+ push_return(Nullop);
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
PL_eval_root = PL_op; /* Only needed so that goto works right. */
if (PL_op == myop) {
if (is_eval)
- PL_op = Perl_pp_entereval(aTHX);
+ PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
else
- PL_op = Perl_pp_entersub(aTHX);
+ PL_op = Perl_pp_entersub(aTHX); /* this does */
}
if (PL_op)
CALLRUNOPS(aTHX);
dSP;
SV* sv = newSVpv(p, 0);
- PUSHMARK(SP);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
char *
Perl_moreswitches(pTHX_ char *s)
{
- I32 numlen;
+ STRLEN numlen;
U32 rschar;
switch (*s) {
case 'd':
forbid_setid("-d");
s++;
- if (*s == ':' || *s == '=') {
- my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
+ /* The following permits -d:Mod to accepts arguments following an =
+ in the fashion that -MSome::Mod does. */
+ if (*s == ':' || *s == '=') {
+ char *start;
+ SV *sv;
+ sv = newSVpv("use Devel::", 0);
+ start = ++s;
+ /* We now allow -d:Module=Foo,Bar */
+ while(isALNUM(*s) || *s==':') ++s;
+ if (*s != '=')
+ sv_catpv(sv, start);
+ else {
+ sv_catpvn(sv, start, s-start);
+ sv_catpv(sv, " split(/,/,q{");
+ sv_catpv(sv, ++s);
+ sv_catpv(sv, "})");
+ }
s += strlen(s);
+ my_setenv("PERL5DB", SvPV(sv, PL_na));
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
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;
return s;
case 'v':
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
+ Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
PL_patchlevel, ARCHNAME));
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PerlIO_stdout(),
"\n\nCopyright 1987-2000, Larry Wall\n");
+#ifdef MACOS_TRADITIONAL
+ PerlIO_printf(PerlIO_stdout(),
+ "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n");
+#endif
#ifdef MSDOS
PerlIO_printf(PerlIO_stdout(),
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
PerlIO_printf(PerlIO_stdout(),
"\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
-GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
+GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
Complete documentation for Perl, including FAQ lists, should be found on\n\
this system using `man perl' or `perldoc perl'. If you have access to the\n\
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
}
}
+#ifdef USE_ITHREADS
+ Safefree(CopFILE(PL_curcop));
+#else
+ SvREFCNT_dec(CopFILEGV(PL_curcop));
+#endif
CopFILE_set(PL_curcop, PL_origfilename);
if (strEQ(PL_origfilename,"-"))
scriptname = "";
sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
-#ifdef MSDOS
+#if defined(MSDOS) || defined(WIN32)
Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
tmpstatbuf.st_ino != PL_statbuf.st_ino) {
(void)PerlIO_close(PL_rsfp);
- if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
- PerlIO_printf(PL_rsfp,
-"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
-(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
- PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
- (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
- CopFILE(PL_curcop),
- PL_statbuf.st_uid, PL_statbuf.st_gid);
- (void)PerlProc_pclose(PL_rsfp);
- }
Perl_croak(aTHX_ "Permission denied\n");
}
if (
/* 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 || gMacPerl_AlwaysExtract) {
+ if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ if (!gMacPerl_AlwaysExtract)
+ 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 */
PL_doextract = FALSE;
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (!PL_osname)
- PL_osname = savepv(OSNAME);
+ if (PL_osname)
+ Safefree(PL_osname);
+ PL_osname = savepv(OSNAME);
}
STATIC void
TAINT;
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
+#ifdef MACOS_TRADITIONAL
+ /* $0 is not majick on a Mac */
+ sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
+#else
sv_setpv(GvSV(tmpgv),PL_origfilename);
magicname("0", "0", 1);
+#endif
}
if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname());
+ sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, PL_envgv, 'E');
-#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
+#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */
/* Note that if the supplied env parameter is actually a copy
of the global environ then it may now point to free'd memory
if the environment has been modified since. To avoid this
#ifdef ARCHLIB_EXP
incpush(ARCHLIB_EXP, FALSE, FALSE);
#endif
+#ifdef MACOS_TRADITIONAL
+ {
+ struct stat tmpstatbuf;
+ SV * privdir = NEWSV(55, 0);
+ char * macperl = PerlEnv_getenv("MACPERL");
+
+ if (!macperl)
+ macperl = "";
+
+ Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
+ if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
+ incpush(SvPVX(privdir), TRUE, FALSE);
+ Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
+ if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
+ incpush(SvPVX(privdir), TRUE, FALSE);
+
+ SvREFCNT_dec(privdir);
+ }
+ if (!PL_tainting)
+ incpush(":", FALSE, FALSE);
+#else
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
if (!PL_tainting)
incpush(".", FALSE, FALSE);
+#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH)
+#if defined(DOSISH) || defined(EPOC)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
# define PERLLIB_SEP '|'
# else
-# define PERLLIB_SEP ':'
+# if defined(MACOS_TRADITIONAL)
+# define PERLLIB_SEP ','
+# else
+# define PERLLIB_SEP ':'
+# endif
# endif
#endif
#ifndef PERLLIB_MANGLE
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
SvPV(libdir,len));
#endif
if (addsubdirs) {
+#ifdef MACOS_TRADITIONAL
+#define PERL_AV_SUFFIX_FMT ""
+#define PERL_ARCH_FMT ":%s"
+#else
+#define PERL_AV_SUFFIX_FMT "/"
+#define PERL_ARCH_FMT "/%s"
+#endif
/* .../version/archname if -d .../version/archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s",
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
av_push(GvAVn(PL_incgv), newSVsv(subdir));
/* .../version if -d .../version */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
av_push(GvAVn(PL_incgv), newSVsv(subdir));
/* .../archname if -d .../archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
if (addoldvers) {
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- SAVEFREESV(cv);
+ if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) {
+ /* save PL_beginav for compiler */
+ if (! PL_beginav_save)
+ PL_beginav_save = newAV();
+ av_push(PL_beginav_save, (SV*)cv);
+ } else {
+ SAVEFREESV(cv);
+ }
#ifdef PERL_FLEXIBLE_EXCEPTIONS
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
#else