PERL_SET_INTERP(my_perl); \
INIT_THREADS; \
ALLOC_THREAD_KEY; \
+ PERL_SET_THX(my_perl); \
+ OP_REFCNT_INIT; \
+ } \
+ else { \
+ PERL_SET_THX(my_perl); \
} \
- PERL_SET_THX(my_perl); \
} STMT_END
# else
# define INIT_TLS_AND_INTERP \
# 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 */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
+ PL_errors = newSVpvn("",0);
ENTER;
}
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
+#ifdef USE_ITHREADS
+ Safefree(CopFILE(&PL_compiling));
+ CopFILE(&PL_compiling) = Nullch;
+ Safefree(CopSTASHPV(&PL_compiling));
+#else
+ SvREFCNT_dec(CopFILEGV(&PL_compiling));
+ CopFILEGV(&PL_compiling) = Nullgv;
+ /* cop_stash is not refcounted */
+#endif
/* Prepare to destruct main symbol table. */
SvREFCNT(&PL_sv_yes) = 0;
sv_clear(&PL_sv_yes);
SvANY(&PL_sv_yes) = NULL;
+ SvFLAGS(&PL_sv_yes) = 0;
SvREFCNT(&PL_sv_no) = 0;
sv_clear(&PL_sv_no);
SvANY(&PL_sv_no) = NULL;
+ SvFLAGS(&PL_sv_no) = 0;
+
+ SvREFCNT(&PL_sv_undef) = 0;
+ SvREADONLY_off(&PL_sv_undef);
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
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);
#if defined(PERL_OBJECT)
PerlMem_free(this);
#else
+# if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
+ void *host = w32_internal_host;
PerlMem_free(aTHXx);
+ win32_delete_internal_host(host);
+# else
+ PerlMem_free(aTHXx);
+# endif
#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) {
char *p;
STRLEN len = strlen(s);
p = savepvn(s, len);
- incpush(p, TRUE);
+ incpush(p, TRUE, TRUE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
sv_catpvn(sv, " ", 1);
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 */
+#ifndef PERL_MICRO
#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
init_os_extras();
#endif
+#endif
#ifdef USE_SOCKS
SOCKSinit(argv[0]);
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);
- PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
+ 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);
"-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)",
+"-c check syntax only (runs BEGIN and CHECK blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-e 'command' one line of program (several -e's allowed, omit programfile)",
};
char **p = usage_msg;
- printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
+ PerlIO_printf(PerlIO_stdout(),
+ "\nUsage: %s [switches] [--] [programfile] [arguments]",
+ name);
while (*p)
- printf("\n %s", *p++);
+ PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
}
/* This routine handles any switches that can be given during run */
case '0':
{
dTHR;
+ numlen = 0; /* disallow underscores */
rschar = (U32)scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
if (rschar & ~((U8)~0))
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE);
+ incpush(e, TRUE, TRUE);
Safefree(e);
s = p;
if (*s == '-')
if (isDIGIT(*s)) {
PL_ors = savepv("\n");
PL_orslen = 1;
+ numlen = 0; /* disallow underscores */
*PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
s += numlen;
}
sv_catpv( sv, " ()");
}
} else {
+ if (s == start)
+ Perl_croak(aTHX_ "Module name required with -%c option",
+ s[-1]);
sv_catpvn(sv, start, s-start);
sv_catpv(sv, " split(/,/,q{");
sv_catpv(sv, ++s);
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':
- printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
- PL_patchlevel, ARCHNAME));
+ PerlIO_printf(PerlIO_stdout(),
+ 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" : "");
+ PerlIO_printf(PerlIO_stdout(),
+ "\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-2000, Larry Wall\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "\n\nCopyright 1987-2000, Larry Wall\n");
#ifdef MSDOS
- printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
- printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
- printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
+ "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#ifdef OS2
- printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
- "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
+ "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
- printf("atariST series port, ++jrb bammi@cadence.com\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "atariST series port, ++jrb bammi@cadence.com\n");
#endif
#ifdef __BEOS__
- printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "BeOS port Copyright Tom Spindler, 1997-1999\n");
#endif
#ifdef MPE
- printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
#endif
#ifdef OEMVS
- printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
#endif
#ifdef __VOS__
- printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
#endif
#ifdef __OPEN_VM
- printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "VM/ESA port by Neale Ferguson, 1998-1999\n");
#endif
#ifdef POSIX_BC
- printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
#ifdef __MINT__
- printf("MiNT port by Guido Flohr, 1997-1999\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "MiNT port by Guido Flohr, 1997-1999\n");
#endif
#ifdef EPOC
- printf("EPOC port by Olaf Flebbe, 1999-2000\n");
+ PerlIO_printf(PerlIO_stdout(),
+ "EPOC port by Olaf Flebbe, 1999-2000\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
- printf("\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\
Complete documentation for Perl, including FAQ lists, should be found on\n\
return s;
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
- PL_compiling.cop_warnings = WARN_ALL ;
+ PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
- PL_compiling.cop_warnings = WARN_NONE ;
+ PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
case '*':
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));
+ PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
}
}
+#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\" \
* an irrelevant filesystem while trying to reach the right one.
*/
-# ifdef HAS_FSTATVFS
+#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
+
+# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
+ defined(HAS_FSTATVFS)
+# define FD_ON_NOSUID_CHECK_OKAY
struct statvfs stfs;
+
check_okay = fstatvfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
-# else
-# ifdef PERL_MOUNT_NOSUID
-# if defined(HAS_FSTATFS) && \
- defined(HAS_STRUCT_STATFS) && \
- defined(HAS_STRUCT_STATFS_F_FLAGS)
+# endif /* fstatvfs */
+
+# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
+ defined(PERL_MOUNT_NOSUID) && \
+ defined(HAS_FSTATFS) && \
+ defined(HAS_STRUCT_STATFS) && \
+ defined(HAS_STRUCT_STATFS_F_FLAGS)
+# define FD_ON_NOSUID_CHECK_OKAY
struct statfs stfs;
+
check_okay = fstatfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
-# else
-# if defined(HAS_FSTAT) && \
- defined(HAS_USTAT) && \
- defined(HAS_GETMNT) && \
- defined(HAS_STRUCT_FS_DATA) && \
- defined(NOSTAT_ONE)
+# endif /* fstatfs */
+
+# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
+ defined(PERL_MOUNT_NOSUID) && \
+ defined(HAS_FSTAT) && \
+ defined(HAS_USTAT) && \
+ defined(HAS_GETMNT) && \
+ defined(HAS_STRUCT_FS_DATA) && \
+ defined(NOSTAT_ONE)
+# define FD_ON_NOSUID_CHECK_OKAY
struct stat fdst;
+
if (fstat(fd, &fdst) == 0) {
- struct ustat us;
- if (ustat(fdst.st_dev, &us) == 0) {
- struct fs_data fsd;
- /* NOSTAT_ONE here because we're not examining fields which
- * vary between that case and STAT_ONE. */
+ struct ustat us;
+ if (ustat(fdst.st_dev, &us) == 0) {
+ struct fs_data fsd;
+ /* NOSTAT_ONE here because we're not examining fields which
+ * vary between that case and STAT_ONE. */
if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
- size_t cmplen = sizeof(us.f_fname);
- if (sizeof(fsd.fd_req.path) < cmplen)
- cmplen = sizeof(fsd.fd_req.path);
- if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
- fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- }
- }
- }
- }
- }
-# endif /* fstat+ustat+getmnt */
-# endif /* fstatfs */
-# else
-# if defined(HAS_GETMNTENT) && \
- defined(HAS_HASMNTOPT) && \
- defined(MNTOPT_NOSUID)
- FILE *mtab = fopen("/etc/mtab", "r");
- struct mntent *entry;
- struct stat stb, fsb;
+ size_t cmplen = sizeof(us.f_fname);
+ if (sizeof(fsd.fd_req.path) < cmplen)
+ cmplen = sizeof(fsd.fd_req.path);
+ if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
+ fdst.st_dev == fsd.fd_req.dev) {
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ }
+ }
+ }
+ }
+ }
+# endif /* fstat+ustat+getmnt */
+
+# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
+ defined(HAS_GETMNTENT) && \
+ defined(HAS_HASMNTOPT) && \
+ defined(MNTOPT_NOSUID)
+# define FD_ON_NOSUID_CHECK_OKAY
+ FILE *mtab = fopen("/etc/mtab", "r");
+ struct mntent *entry;
+ struct stat stb, fsb;
if (mtab && (fstat(fd, &stb) == 0)) {
- while (entry = getmntent(mtab)) {
- if (stat(entry->mnt_dir, &fsb) == 0
- && fsb.st_dev == stb.st_dev)
- {
- /* found the filesystem */
- check_okay = 1;
- if (hasmntopt(entry, MNTOPT_NOSUID))
- on_nosuid = 1;
- break;
- } /* A single fs may well fail its stat(). */
- }
+ while (entry = getmntent(mtab)) {
+ if (stat(entry->mnt_dir, &fsb) == 0
+ && fsb.st_dev == stb.st_dev)
+ {
+ /* found the filesystem */
+ check_okay = 1;
+ if (hasmntopt(entry, MNTOPT_NOSUID))
+ on_nosuid = 1;
+ break;
+ } /* A single fs may well fail its stat(). */
+ }
}
if (mtab)
- fclose(mtab);
-# endif /* getmntent+hasmntopt */
-# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
-# endif /* statvfs */
+ fclose(mtab);
+# endif /* getmntent+hasmntopt */
if (!check_okay)
Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
/* 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
SV *sv = newSVpv(argv[0],0);
av_push(GvAVn(PL_argvgv),sv);
if (PL_widesyscalls)
- sv_utf8_upgrade(sv);
+ (void)sv_utf8_decode(sv);
}
}
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
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
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE);
+ incpush(s, TRUE, TRUE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
#endif /* VMS */
}
/* Use the ~-expanded versions of APPLLIB (undocumented),
- ARCHLIB PRIVLIB SITEARCH and SITELIB
+ ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE);
+ 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"
+# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
- incpush(PRIVLIB_EXP, TRUE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE);
#else
- incpush(PRIVLIB_EXP, FALSE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE);
+#endif
+
+#ifdef SITEARCH_EXP
+ /* sitearch is always relative to sitelib on Windows for
+ * DLL-based path intuition to work correctly */
+# if !defined(WIN32)
+ incpush(SITEARCH_EXP, FALSE, FALSE);
+# endif
#endif
-#if defined(WIN32)
- incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
-#else
#ifdef SITELIB_EXP
- {
- char *path = SITELIB_EXP;
-
- if (path) {
- char buf[1024];
- char *ver = strrchr(path,'/'); /* XXX Hack, Configure var needed */
- if (ver && ver[1] == (STRINGIFY(PERL_REVISION))[0]
- && strlen(path) < sizeof(buf))
- {
- strcpy(buf,path);
- buf[ver-path] = '\0';
- path = buf;
- }
- incpush(path, TRUE);
- }
- }
+# if defined(WIN32)
+ incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
+# else
+ incpush(SITELIB_EXP, FALSE, FALSE);
+# endif
#endif
+
+#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+ incpush(SITELIB_STEM, FALSE, TRUE);
#endif
-#if defined(PERL_VENDORLIB_EXP)
-#if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE);
-#else
- incpush(PERL_VENDORLIB_EXP, FALSE);
+
+#ifdef PERL_VENDORARCH_EXP
+ /* vendorarch is always relative to vendorlib on Windows for
+ * DLL-based path intuition to work correctly */
+# if !defined(WIN32)
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
+# endif
#endif
+
+#ifdef PERL_VENDORLIB_EXP
+# if defined(WIN32)
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
+# else
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+# endif
#endif
+
+#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
+#endif
+
+#ifdef PERL_OTHERLIBDIRS
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
+#endif
+
if (!PL_tainting)
- incpush(".", FALSE);
+ incpush(".", FALSE, FALSE);
+#endif /* MACOS_TRADITIONAL */
}
#if defined(DOSISH)
# 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
#endif
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
{
SV *subdir = Nullsv;
- if (!p)
+ if (!p || !*p)
return;
- if (addsubdirs) {
+ if (addsubdirs || addoldvers) {
subdir = sv_newmortal();
}
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) {
+ if (addsubdirs || addoldvers) {
#ifdef PERL_INC_VERSION_LIST
/* Configure terminates PERL_INC_VERSION_LIST with a NULL */
const char *incverlist[] = { PERL_INC_VERSION_LIST };
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
- /* .../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), 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));
+ 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_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
+ 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));
-#ifdef PERL_INC_VERSION_LIST
- for (incver = incverlist; *incver; incver++) {
- /* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+ /* .../version if -d .../version */
+ 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 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
+
+ /* .../archname if -d .../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));
+ }
+
+#ifdef PERL_INC_VERSION_LIST
+ if (addoldvers) {
+ for (incver = incverlist; *incver; incver++) {
+ /* .../xxx if -d .../xxx */
+ 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));
+ }
}
#endif
}
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
https://perl5.git.perl.org / perl5.git / blobdiff