/* startup and shutdown function lists */
SvREFCNT_dec(PL_beginav);
SvREFCNT_dec(PL_endav);
+ SvREFCNT_dec(PL_stopav);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_endav = Nullav;
+ PL_stopav = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
env, xsinit);
switch (ret) {
case 0:
+ if (PL_stopav)
+ call_list(oldscope, PL_stopav);
return 0;
case 1:
STATUS_ALL_FAILURE;
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav && !PL_minus_c)
- call_list(oldscope, PL_endav);
+ if (PL_stopav)
+ call_list(oldscope, PL_stopav);
return STATUS_NATIVE_EXPORT;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
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) {
}
#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;
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
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);
- my_exit(0);
+#endif
+my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
sv_setiv(PL_DBsingle, 1);
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;
#endif
printf("\n\nCopyright 1987-1999, Larry Wall\n");
+#ifdef MACOS_TRADITIONAL
+ fputs("Macintosh port Copyright 1991-1999, Matthias Neeracher\n", stdout);
+#endif
#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
/* 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_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
+ 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
#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
#endif
if (!PL_tainting)
incpush(".", FALSE);
+#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH)
-# define PERLLIB_SEP ';'
+#if defined(MACOS_TRADITIONAL)
+# define PERLLIB_SEP ','
#else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
+# if defined(DOSISH)
+# define PERLLIB_SEP ';'
# else
-# define PERLLIB_SEP ':'
+# if defined(VMS)
+# define PERLLIB_SEP '|'
+# else
+# define PERLLIB_SEP ':'
+# endif
# endif
-#endif
+#endif
#ifndef PERLLIB_MANGLE
-# define PERLLIB_MANGLE(s,n) (s)
+# define PERLLIB_MANGLE(s,n) (s)
#endif
STATIC void
STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
+ sizeof("//auto"));
New(55, PL_archpat_auto, len, char);
- sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
+#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++)
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
if (paramList == PL_beginav)
sv_catpv(atsv, "BEGIN failed--compilation aborted");
else
- sv_catpv(atsv, "END failed--cleanup aborted");
+ Perl_sv_catpvf(aTHX_ atsv,
+ "%s failed--call queue aborted",
+ paramList == PL_stopav ? "STOP"
+ : paramList == PL_initav ? "INIT"
+ : "END");
while (PL_scopestack_ix > oldscope)
LEAVE;
Perl_croak(aTHX_ "%s", SvPVX(atsv));
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav && !PL_minus_c)
- call_list(oldscope, PL_endav);
PL_curcop = &PL_compiling;
PL_curcop->cop_line = oldline;
if (PL_statusvalue) {
if (paramList == PL_beginav)
Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
else
- Perl_croak(aTHX_ "END failed--cleanup aborted");
+ Perl_croak(aTHX_ "%s failed--call queue aborted",
+ paramList == PL_stopav ? "STOP"
+ : paramList == PL_initav ? "INIT"
+ : "END");
}
my_exit_jump();
/* NOTREACHED */
what a local C compiler calls 'long'. If you want
native-length longs, use the '!' suffix.)
- n A short in "network" (big-endian) order.
- N A long in "network" (big-endian) order.
- v A short in "VAX" (little-endian) order.
- V A long in "VAX" (little-endian) order.
+ n An unsigned short in "network" (big-endian) order.
+ N An unsigned long in "network" (big-endian) order.
+ v An unsigned short in "VAX" (little-endian) order.
+ V An unsigned long in "VAX" (little-endian) order.
(These 'shorts' and 'longs' are _exactly_ 16 bits and
_exactly_ 32 bits, respectively.)
0x12 0x34 0x56 0x78 # little-endian
0x78 0x56 0x34 0x12 # big-endian
-Basically, the Intel, Alpha, and VAX CPUs and little-endian, while
+Basically, the Intel, Alpha, and VAX CPUs are little-endian, while
everybody else, for example Motorola m68k/88k, PPC, Sparc, HP PA,
Power, and Cray are big-endian. MIPS can be either: Digital used it
in little-endian mode; SGI uses it in big-endian mode.
array, returns the undefined value. If ARRAY is omitted, shifts the
C<@_> array within the lexical scope of subroutines and formats, and the
C<@ARGV> array at file scopes or within the lexical scopes established by
- the C<eval ''>, C<BEGIN {}>, C<END {}>, and C<INIT {}> constructs.
+ the C<eval ''>, C<BEGIN {}>, C<INIT {}>, C<STOP {}>, and C<END {}>
+ constructs.
+
See also C<unshift>, C<push>, and C<pop>. C<Shift()> and C<unshift> do the
same thing to the left end of an array that C<pop> and C<push> do to the
right end.
* 1999-02-27 mjd-perl-patch@plover.com */
#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
+/* On MacOS, respect nonbreaking spaces */
+#ifdef MACOS_TRADITIONAL
+#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
+#else
+#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
+#endif
+
/* LEX_* are values for PL_lex_state, the state of the lexer.
* They are arranged oddly so that the guard on the switch statement
* can get by with a single comparison (if the compiler is smart enough).
char ch;
int sawline = 0;
+ PERL_ASYNC_CHECK();
PL_curcop->cop_line++;
if (*s++ != '#')
return;
- while (*s == ' ' || *s == '\t') s++;
+ while (SPACE_OR_TAB(*s)) s++;
if (strnEQ(s, "line ", 5)) {
s += 5;
sawline = 1;
n = s;
while (isDIGIT(*s))
s++;
- while (*s == ' ' || *s == '\t')
+ while (SPACE_OR_TAB(*s))
s++;
if (*s == '"' && (t = strchr(s+1, '"')))
s++;
{
dTHR;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
return s;
}
*s = '#'; /* Don't try to parse shebang line */
}
#endif /* ALTERNATE_SHEBANG */
+#ifndef MACOS_TRADITIONAL
if (!d &&
*s == '#' &&
ipathend > ipath &&
PerlProc_execv(ipath, newargv);
Perl_croak(aTHX_ "Can't exec %s", ipath);
}
+#endif
if (d) {
U32 oldpdb = PL_perldb;
bool oldn = PL_minus_n;
bool oldp = PL_minus_p;
while (*d && !isSPACE(*d)) d++;
- while (*d == ' ' || *d == '\t') d++;
+ while (SPACE_OR_TAB(*d)) d++;
if (*d++ == '-') {
do {
"(Maybe you didn't strip carriage returns after a network transfer?)\n");
#endif
case ' ': case '\t': case '\f': case 013:
+#ifdef MACOS_TRADITIONAL
+ case '\312': /* Them nonbreaking spaces again */
+#endif
s++;
goto retry;
case '#':
PL_bufptr = s;
tmp = *s++;
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
if (strnEQ(s,"=>",2)) {
PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
OPERATOR(HASHBRACK);
case XOPERATOR:
- while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ while (s < PL_bufend && SPACE_OR_TAB(*s))
s++;
d = s;
PL_tokenbuf[0] = '\0';
if (d < PL_bufend && *d == '-') {
PL_tokenbuf[0] = '-';
d++;
- while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
d++;
}
if (d < PL_bufend && isIDFIRST_lazy(d)) {
d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
FALSE, &len);
- while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ while (d < PL_bufend && SPACE_OR_TAB(*d))
d++;
if (*d == '}') {
char minus = (PL_tokenbuf[0] == '-');
if (PL_lex_brackets < PL_lex_formbrack) {
char *t;
#ifdef PERL_STRICT_CR
- for (t = s; *t == ' ' || *t == '\t'; t++) ;
+ for (t = s; SPACE_OR_TAB(*t); t++) ;
#else
- for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+ for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
#endif
if (*t == '\n' || *t == '#') {
s--;
if (*s == '(') {
CLINE;
if (gv && GvCVu(gv)) {
- for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
+ for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
s = d + 1;
goto its_constant;
case KEY_DESTROY:
case KEY_BEGIN:
case KEY_END:
+ case KEY_STOP:
case KEY_INIT:
if (PL_expect == XSTATE) {
s = PL_bufptr;
break;
}
break;
+ case 'S':
+ if (strEQ(d,"STOP")) return KEY_STOP;
+ break;
case 's':
switch (d[1]) {
case 0: return KEY_s;
if (isSPACE(s[-1])) {
while (s < send) {
char ch = *s++;
- if (ch != ' ' && ch != '\t') {
+ if (!SPACE_OR_TAB(ch)) {
*d = ch;
break;
}
Perl_croak(aTHX_ ident_too_long);
}
*d = '\0';
- while (s < send && (*s == ' ' || *s == '\t')) s++;
+ while (s < send && SPACE_OR_TAB(*s)) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
dTHR; /* only for ckWARN */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
if (!outer)
*d++ = '\n';
- for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
+ for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
if (*peek && strchr("`'\"",*peek)) {
s = peek;
term = *s++;
if (*s == '.' || *s == '}') {
/*SUPPRESS 530*/
#ifdef PERL_STRICT_CR
- for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
+ for (t = s+1;SPACE_OR_TAB(*t); t++) ;
#else
- for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
+ for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
#endif
if (*t == '\n' || t == PL_bufend)
break;
Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
else
Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
- if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
+ if (PL_multi_start < PL_multi_end &&
+ (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
Perl_sv_catpvf(aTHX_ msg,
- " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
+ " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
(int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
PL_multi_end = 0;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff