aboutsummaryrefslogtreecommitdiff
path: root/contrib/perl5
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5')
-rw-r--r--contrib/perl5/ext/IPC/SysV/Makefile.PL2
-rw-r--r--contrib/perl5/ext/POSIX/Makefile.PL12
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.xs330
-rw-r--r--contrib/perl5/hints/freebsd.sh79
-rw-r--r--contrib/perl5/lib/Cwd.pm41
-rw-r--r--contrib/perl5/lib/ExtUtils/Install.pm28
-rw-r--r--contrib/perl5/lib/ExtUtils/Liblist.pm52
-rw-r--r--contrib/perl5/lib/ExtUtils/MM_Unix.pm493
-rw-r--r--contrib/perl5/lib/ExtUtils/MakeMaker.pm250
-rw-r--r--contrib/perl5/lib/Sys/Hostname.pm6
-rw-r--r--contrib/perl5/perl.c1875
-rw-r--r--contrib/perl5/perl.h1954
-rw-r--r--contrib/perl5/pp.c2062
-rw-r--r--contrib/perl5/utils/h2ph.PL12
-rw-r--r--contrib/perl5/utils/perlbug.PL168
-rw-r--r--contrib/perl5/utils/splain.PL7
16 files changed, 2393 insertions, 4978 deletions
diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL
index 60dd74d9a9c4..a4de7a923167 100644
--- a/contrib/perl5/ext/IPC/SysV/Makefile.PL
+++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL
@@ -1,5 +1,5 @@
# This -*- perl -*- script makes the Makefile
-# $Id: Makefile.PL,v 1.3 1997/03/04 09:21:12 gbarr Exp $
+# $Id: Makefile.PL,v 1.1.1.2 1999/05/02 14:20:37 markm Exp $
require 5.002;
use ExtUtils::MakeMaker;
diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL
index 55c5c1fbf3f6..d379fdb908e0 100644
--- a/contrib/perl5/ext/POSIX/Makefile.PL
+++ b/contrib/perl5/ext/POSIX/Makefile.PL
@@ -1,17 +1,7 @@
use ExtUtils::MakeMaker;
-use Config;
-my @libs;
-if ($^O ne 'MSWin32') {
- if ($Config{archname} =~ /RM\d\d\d-svr4/) {
- @libs = ('LIBS' => ["-lm -lc -lposix -lcposix"]);
- }
- else {
- @libs = ('LIBS' => ["-lm -lposix -lcposix"]);
- }
-}
WriteMakefile(
NAME => 'POSIX',
- @libs,
+ ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])),
MAN3PODS => {}, # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'POSIX.pm',
diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs
index 3a523d1d07a3..2066b4697236 100644
--- a/contrib/perl5/ext/POSIX/POSIX.xs
+++ b/contrib/perl5/ext/POSIX/POSIX.xs
@@ -1,14 +1,12 @@
+/* $FreeBSD$ */
#ifdef WIN32
#define _POSIX_
#endif
-
-#define PERL_NO_GET_CONTEXT
-
#include "EXTERN.h"
#define PERLIO_NOT_STDIO 1
#include "perl.h"
#include "XSUB.h"
-#if defined(PERL_OBJECT) || defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS)
+#ifdef PERL_OBJECT /* XXX _very_ temporary hacks */
# undef signal
# undef open
# undef setmode
@@ -81,7 +79,6 @@
/* The non-POSIX CRTL times() has void return type, so we just get the
current time directly */
clock_t vms_times(struct tms *PL_bufptr) {
- dTHX;
clock_t retval;
/* Get wall time and convert to 10 ms intervals to
* produce the return value that the POSIX standard expects */
@@ -106,9 +103,6 @@
}
# define times(t) vms_times(t)
#else
-#if defined (__CYGWIN__)
-# define tzname _tzname
-#endif
#if defined (WIN32)
# undef mkfifo
# define mkfifo(a,b) not_here("mkfifo")
@@ -142,12 +136,8 @@
#else
# ifndef HAS_MKFIFO
-# ifdef OS2
-# define mkfifo(a,b) not_here("mkfifo")
-# else /* !( defined OS2 ) */
-# ifndef mkfifo
-# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
-# endif
+# ifndef mkfifo
+# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
# endif
# endif /* !HAS_MKFIFO */
@@ -188,10 +178,10 @@ typedef struct termios* POSIX__Termios;
#endif
/* Possibly needed prototypes */
-char *cuserid (char *);
-double strtod (const char *, char **);
-long strtol (const char *, char **, int);
-unsigned long strtoul (const char *, char **, int);
+char *cuserid _((char *));
+double strtod _((const char *, char **));
+long strtol _((const char *, char **, int));
+unsigned long strtoul _((const char *, char **, int));
#ifndef HAS_CUSERID
#define cuserid(a) (char *) not_here("cuserid")
@@ -289,7 +279,7 @@ unsigned long strtoul (const char *, char **, int);
#endif
#ifdef HAS_TZNAME
-# if !defined(WIN32) && !defined(__CYGWIN__)
+# ifndef WIN32
extern char *tzname[];
# endif
#else
@@ -314,13 +304,14 @@ char *tzname[] = { "" , "" };
*/
#ifdef HAS_GNULIBC
# ifndef STRUCT_TM_HASZONE
-# define STRUCT_TM_HASZONE
+# define STRUCT_TM_HAS_ZONE
# endif
#endif
#ifdef STRUCT_TM_HASZONE
static void
-init_tm(struct tm *ptm) /* see mktime, strftime and asctime */
+init_tm(ptm) /* see mktime, strftime and asctime */
+ struct tm *ptm;
{
Time_t now;
(void)time(&now);
@@ -331,202 +322,6 @@ init_tm(struct tm *ptm) /* see mktime, strftime and asctime */
# define init_tm(ptm)
#endif
-/*
- * mini_mktime - normalise struct tm values without the localtime()
- * semantics (and overhead) of mktime().
- */
-static void
-mini_mktime(struct tm *ptm)
-{
- int yearday;
- int secs;
- int month, mday, year, jday;
- int odd_cent, odd_year;
-
-#define DAYS_PER_YEAR 365
-#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
-#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
-#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
-#define SECS_PER_HOUR (60*60)
-#define SECS_PER_DAY (24*SECS_PER_HOUR)
-/* parentheses deliberately absent on these two, otherwise they don't work */
-#define MONTH_TO_DAYS 153/5
-#define DAYS_TO_MONTH 5/153
-/* offset to bias by March (month 4) 1st between month/mday & year finding */
-#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
-/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
-#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
-
-/*
- * Year/day algorithm notes:
- *
- * With a suitable offset for numeric value of the month, one can find
- * an offset into the year by considering months to have 30.6 (153/5) days,
- * using integer arithmetic (i.e., with truncation). To avoid too much
- * messing about with leap days, we consider January and February to be
- * the 13th and 14th month of the previous year. After that transformation,
- * we need the month index we use to be high by 1 from 'normal human' usage,
- * so the month index values we use run from 4 through 15.
- *
- * Given that, and the rules for the Gregorian calendar (leap years are those
- * divisible by 4 unless also divisible by 100, when they must be divisible
- * by 400 instead), we can simply calculate the number of days since some
- * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
- * the days we derive from our month index, and adding in the day of the
- * month. The value used here is not adjusted for the actual origin which
- * it normally would use (1 January A.D. 1), since we're not exposing it.
- * We're only building the value so we can turn around and get the
- * normalised values for the year, month, day-of-month, and day-of-year.
- *
- * For going backward, we need to bias the value we're using so that we find
- * the right year value. (Basically, we don't want the contribution of
- * March 1st to the number to apply while deriving the year). Having done
- * that, we 'count up' the contribution to the year number by accounting for
- * full quadracenturies (400-year periods) with their extra leap days, plus
- * the contribution from full centuries (to avoid counting in the lost leap
- * days), plus the contribution from full quad-years (to count in the normal
- * leap days), plus the leftover contribution from any non-leap years.
- * At this point, if we were working with an actual leap day, we'll have 0
- * days left over. This is also true for March 1st, however. So, we have
- * to special-case that result, and (earlier) keep track of the 'odd'
- * century and year contributions. If we got 4 extra centuries in a qcent,
- * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
- * Otherwise, we add back in the earlier bias we removed (the 123 from
- * figuring in March 1st), find the month index (integer division by 30.6),
- * and the remainder is the day-of-month. We then have to convert back to
- * 'real' months (including fixing January and February from being 14/15 in
- * the previous year to being in the proper year). After that, to get
- * tm_yday, we work with the normalised year and get a new yearday value for
- * January 1st, which we subtract from the yearday value we had earlier,
- * representing the date we've re-built. This is done from January 1
- * because tm_yday is 0-origin.
- *
- * Since POSIX time routines are only guaranteed to work for times since the
- * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
- * applies Gregorian calendar rules even to dates before the 16th century
- * doesn't bother me. Besides, you'd need cultural context for a given
- * date to know whether it was Julian or Gregorian calendar, and that's
- * outside the scope for this routine. Since we convert back based on the
- * same rules we used to build the yearday, you'll only get strange results
- * for input which needed normalising, or for the 'odd' century years which
- * were leap years in the Julian calander but not in the Gregorian one.
- * I can live with that.
- *
- * This algorithm also fails to handle years before A.D. 1 gracefully, but
- * that's still outside the scope for POSIX time manipulation, so I don't
- * care.
- */
-
- year = 1900 + ptm->tm_year;
- month = ptm->tm_mon;
- mday = ptm->tm_mday;
- /* allow given yday with no month & mday to dominate the result */
- if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
- month = 0;
- mday = 0;
- jday = 1 + ptm->tm_yday;
- }
- else {
- jday = 0;
- }
- if (month >= 2)
- month+=2;
- else
- month+=14, year--;
- yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
- yearday += month*MONTH_TO_DAYS + mday + jday;
- /*
- * Note that we don't know when leap-seconds were or will be,
- * so we have to trust the user if we get something which looks
- * like a sensible leap-second. Wild values for seconds will
- * be rationalised, however.
- */
- if ((unsigned) ptm->tm_sec <= 60) {
- secs = 0;
- }
- else {
- secs = ptm->tm_sec;
- ptm->tm_sec = 0;
- }
- secs += 60 * ptm->tm_min;
- secs += SECS_PER_HOUR * ptm->tm_hour;
- if (secs < 0) {
- if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
- /* got negative remainder, but need positive time */
- /* back off an extra day to compensate */
- yearday += (secs/SECS_PER_DAY)-1;
- secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
- }
- else {
- yearday += (secs/SECS_PER_DAY);
- secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
- }
- }
- else if (secs >= SECS_PER_DAY) {
- yearday += (secs/SECS_PER_DAY);
- secs %= SECS_PER_DAY;
- }
- ptm->tm_hour = secs/SECS_PER_HOUR;
- secs %= SECS_PER_HOUR;
- ptm->tm_min = secs/60;
- secs %= 60;
- ptm->tm_sec += secs;
- /* done with time of day effects */
- /*
- * The algorithm for yearday has (so far) left it high by 428.
- * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
- * bias it by 123 while trying to figure out what year it
- * really represents. Even with this tweak, the reverse
- * translation fails for years before A.D. 0001.
- * It would still fail for Feb 29, but we catch that one below.
- */
- jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
- yearday -= YEAR_ADJUST;
- year = (yearday / DAYS_PER_QCENT) * 400;
- yearday %= DAYS_PER_QCENT;
- odd_cent = yearday / DAYS_PER_CENT;
- year += odd_cent * 100;
- yearday %= DAYS_PER_CENT;
- year += (yearday / DAYS_PER_QYEAR) * 4;
- yearday %= DAYS_PER_QYEAR;
- odd_year = yearday / DAYS_PER_YEAR;
- year += odd_year;
- yearday %= DAYS_PER_YEAR;
- if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
- month = 1;
- yearday = 29;
- }
- else {
- yearday += YEAR_ADJUST; /* recover March 1st crock */
- month = yearday*DAYS_TO_MONTH;
- yearday -= month*MONTH_TO_DAYS;
- /* recover other leap-year adjustment */
- if (month > 13) {
- month-=14;
- year++;
- }
- else {
- month-=2;
- }
- }
- ptm->tm_year = year - 1900;
- if (yearday) {
- ptm->tm_mday = yearday;
- ptm->tm_mon = month;
- }
- else {
- ptm->tm_mday = 31;
- ptm->tm_mon = month - 1;
- }
- /* re-build yearday based on Jan 1 to get tm_yday */
- year--;
- yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
- yearday += 14*MONTH_TO_DAYS + 1;
- ptm->tm_yday = jday - yearday;
- /* fix tm_wday if not overridden by caller */
- if ((unsigned)ptm->tm_wday > 6)
- ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
-}
#ifdef HAS_LONG_DOUBLE
# if LONG_DOUBLESIZE > DOUBLESIZE
@@ -554,7 +349,7 @@ not_here(char *s)
}
static
-#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE)
+#ifdef HAS_LONG_DOUBLE
long double
#else
double
@@ -1725,10 +1520,9 @@ constant(char *name, int arg)
#else
goto not_there;
#endif
- /* L_tmpnam[e] was a typo--retained for compatibility */
- if (strEQ(name, "L_tmpname") || strEQ(name, "L_tmpnam"))
-#ifdef L_tmpnam
- return L_tmpnam;
+ if (strEQ(name, "L_tmpname"))
+#ifdef L_tmpname
+ return L_tmpname;
#else
goto not_there;
#endif
@@ -3252,7 +3046,7 @@ setlocale(category, locale = 0)
else
#endif
newctype = RETVAL;
- new_ctype(newctype);
+ perl_new_ctype(newctype);
}
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
@@ -3269,7 +3063,7 @@ setlocale(category, locale = 0)
else
#endif
newcoll = RETVAL;
- new_collate(newcoll);
+ perl_new_collate(newcoll);
}
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
@@ -3286,7 +3080,7 @@ setlocale(category, locale = 0)
else
#endif
newnum = RETVAL;
- new_numeric(newnum);
+ perl_new_numeric(newnum);
}
#endif /* USE_LOCALE_NUMERIC */
}
@@ -3374,15 +3168,17 @@ sigaction(sig, action, oldaction = 0)
# This code is really grody because we're trying to make the signal
# interface look beautiful, which is hard.
+ if (!PL_siggv)
+ gv_fetchpv("SIG", TRUE, SVt_PVHV);
+
{
- GV *siggv = gv_fetchpv("SIG", TRUE, SVt_PVHV);
struct sigaction act;
struct sigaction oact;
POSIX__SigSet sigset;
SV** svp;
- SV** sigsvp = hv_fetch(GvHVn(siggv),
- PL_sig_name[sig],
- strlen(PL_sig_name[sig]),
+ SV** sigsvp = hv_fetch(GvHVn(PL_siggv),
+ sig_name[sig],
+ strlen(sig_name[sig]),
TRUE);
STRLEN n_a;
@@ -3401,7 +3197,7 @@ sigaction(sig, action, oldaction = 0)
croak("Can't supply an action without a HANDLER");
sv_setpv(*sigsvp, SvPV(*svp, n_a));
mg_set(*sigsvp); /* handles DEFAULT and IGNORE */
- act.sa_handler = PL_sighandlerp;
+ act.sa_handler = sighandler;
/* Set up any desired mask. */
svp = hv_fetch(action, "MASK", 4, FALSE);
@@ -3467,7 +3263,7 @@ INIT:
}
else if (sv_derived_from(ST(2), "POSIX::SigSet")) {
IV tmp = SvIV((SV*)SvRV(ST(2)));
- oldsigset = INT2PTR(POSIX__SigSet,tmp);
+ oldsigset = (POSIX__SigSet) tmp;
}
else {
New(0, oldsigset, 1, sigset_t);
@@ -3572,18 +3368,9 @@ write(fd, buffer, nbytes)
char * buffer
size_t nbytes
-SV *
-tmpnam()
- PREINIT:
- STRLEN i;
- int len;
- CODE:
- RETVAL = newSVpvn("", 0);
- SvGROW(RETVAL, L_tmpnam);
- len = strlen(tmpnam(SvPV(RETVAL, i)));
- SvCUR_set(RETVAL, len);
- OUTPUT:
- RETVAL
+char *
+tmpnam(s = 0)
+ char * s = 0;
void
abort()
@@ -3648,12 +3435,10 @@ strtol(str, base = 0)
char *unparsed;
PPCODE:
num = strtol(str, &unparsed, base);
-#if IVSIZE <= LONGSIZE
- if (num < IV_MIN || num > IV_MAX)
- PUSHs(sv_2mortal(newSVnv((double)num)));
- else
-#endif
+ if (num >= IV_MIN && num <= IV_MAX)
PUSHs(sv_2mortal(newSViv((IV)num)));
+ else
+ PUSHs(sv_2mortal(newSVnv((double)num)));
if (GIMME == G_ARRAY) {
EXTEND(SP, 1);
if (unparsed)
@@ -3835,6 +3620,11 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
char tmpbuf[128];
struct tm mytm;
int len;
+#ifdef __FreeBSD__
+ long sgmtoff;
+ int sisdst;
+ char *szone;
+#endif
init_tm(&mytm); /* XXX workaround - see init_tm() above */
mytm.tm_sec = sec;
mytm.tm_min = min;
@@ -3845,7 +3635,18 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
mytm.tm_wday = wday;
mytm.tm_yday = yday;
mytm.tm_isdst = isdst;
- mini_mktime(&mytm);
+#ifdef __FreeBSD__
+ sgmtoff = mytm.tm_gmtoff;
+ sisdst = mytm.tm_isdst;
+ szone = mytm.tm_zone;
+ /* to prevent mess with shifted hours/days/etc. */
+ (void) timegm(&mytm);
+ mytm.tm_gmtoff = sgmtoff;
+ mytm.tm_isdst = sisdst;
+ mytm.tm_zone = szone;
+#else
+ (void) mktime(&mytm);
+#endif
len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm);
/*
** The following is needed to handle to the situation where
@@ -3861,35 +3662,28 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
** If there is a better way to make it portable, go ahead by
** all means.
*/
- if ((len > 0 && len < sizeof(tmpbuf)) || (len == 0 && *fmt == '\0'))
+ if ( ( len > 0 && len < sizeof(tmpbuf) )
+ || ( len == 0 && strlen(fmt) == 0 ) ) {
ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
- else {
+ } else {
/* Possibly buf overflowed - try again with a bigger buf */
- int fmtlen = strlen(fmt);
- int bufsize = fmtlen + sizeof(tmpbuf);
+ int bufsize = strlen(fmt) + sizeof(tmpbuf);
char* buf;
int buflen;
New(0, buf, bufsize, char);
- while (buf) {
+ while( buf ) {
buflen = strftime(buf, bufsize, fmt, &mytm);
- if (buflen > 0 && buflen < bufsize)
- break;
- /* heuristic to prevent out-of-memory errors */
- if (bufsize > 100*fmtlen) {
- Safefree(buf);
- buf = NULL;
- break;
- }
+ if ( buflen > 0 && buflen < bufsize ) break;
bufsize *= 2;
Renew(buf, bufsize, char);
}
- if (buf) {
- ST(0) = sv_2mortal(newSVpvn(buf, buflen));
+ if ( buf ) {
+ ST(0) = sv_2mortal(newSVpv(buf, buflen));
Safefree(buf);
+ } else {
+ ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
}
- else
- ST(0) = sv_2mortal(newSVpvn(tmpbuf, len));
}
}
@@ -3900,8 +3694,8 @@ void
tzname()
PPCODE:
EXTEND(SP,2);
- PUSHs(sv_2mortal(newSVpvn(tzname[0],strlen(tzname[0]))));
- PUSHs(sv_2mortal(newSVpvn(tzname[1],strlen(tzname[1]))));
+ PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0]))));
+ PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1]))));
SysRet
access(filename, mode)
diff --git a/contrib/perl5/hints/freebsd.sh b/contrib/perl5/hints/freebsd.sh
index fd60ba3cb919..e622fc49c047 100644
--- a/contrib/perl5/hints/freebsd.sh
+++ b/contrib/perl5/hints/freebsd.sh
@@ -99,11 +99,23 @@ esac
case "$osvers" in
0.*|1.0*) ;;
-1*|2*) cccdlflags='-DPIC -fpic'
- lddlflags="-Bshareable $lddlflags"
+# allow a 2.2.* a.out --> 3.0 ELF to work.
+2.2*) objformat=`objformat`
+ if [ x$objformat = xelf ]; then
+ libpth="/usr/lib /usr/local/lib"
+ glibpth="/usr/lib /usr/local/lib"
+ ldflags="-Wl,-E "
+ lddlflags="-shared "
+ else
+ if [ -e /usr/lib/aout ]; then
+ libpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ glibpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ fi
+ lddlflags='-Bshareable'
+ fi
+ cccdlflags='-DPIC -fpic'
;;
-
-*)
+3.*|4.0*)
objformat=`/usr/bin/objformat`
if [ x$objformat = xelf ]; then
libpth="/usr/lib /usr/local/lib"
@@ -112,23 +124,17 @@ case "$osvers" in
lddlflags="-shared "
else
if [ -e /usr/lib/aout ]; then
- libpth="/usr/lib/aout /usr/local/lib /usr/lib"
- glibpth="/usr/lib/aout /usr/local/lib /usr/lib"
- fi
- lddlflags='-Bshareable'
+ libpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ glibpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ fi
+ lddlflags='-Bshareable'
fi
cccdlflags='-DPIC -fpic'
;;
-esac
-
-case "$osvers" in
-0*|1*|2*|3*) ;;
-*)
- if /usr/bin/file -L /usr/lib/libc.so | /usr/bin/grep -vq "not stripped" ; then
- usenm=false
- fi
- ;;
+*) cccdlflags='-DPIC -fpic'
+ lddlflags="-Bshareable $lddlflags"
+ ;;
esac
cat <<'EOM' >&4
@@ -157,8 +163,8 @@ case "$osvers" in
# the equivalent in the main Configure so we copy a little
# from Configure XXX Configure should be fixed.
if $test -r $src/patchlevel.h;then
- patchlevel=`awk '/define[ ]+PERL_VERSION/ {print $3}' $src/patchlevel.h`
- subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $src/patchlevel.h`
+ patchlevel=`awk '/define[ ]+PATCHLEVEL/ {print $3}' $src/patchlevel.h`
+ subversion=`awk '/define[ ]+SUBVERSION/ {print $3}' $src/patchlevel.h`
else
patchlevel=0
subversion=0
@@ -174,17 +180,22 @@ esac
cat > UU/usethreads.cbu <<'EOCBU'
case "$usethreads" in
$define|true|[yY]*)
- lc_r=`/sbin/ldconfig -r|grep ':-lc_r'|awk '{print $NF}'|tail -1`
+ lc_r=`/sbin/ldconfig -r|grep ':-lc_r'|awk '{print $NF}'`
case "$osvers" in
- 0*|1*|2.0*|2.1*) cat <<EOM >&4
-I did not know that FreeBSD $osvers supports POSIX threads.
+ 2.2.8*|3.*|4.*)
+ if [ ! -r "$lc_r" ]; then
+ cat <<EOM >&4
+POSIX threads should be supported by FreeBSD $osvers --
+but your system is missing the shared libc_r.
+(/sbin/ldconfig -r doesn't find any).
-Feel free to tell perlbug@perl.com otherwise.
+Consider using the latest STABLE release.
EOM
- exit 1
+ exit 1
+ fi
+ ldflags="-pthread $ldflags"
;;
-
- 2.2.[0-7]*)
+ 2.2*)
cat <<EOM >&4
POSIX threads are not supported well by FreeBSD $osvers.
@@ -197,21 +208,13 @@ or preferably to 3.something.
EOM
exit 1
;;
+ *) cat <<EOM >&4
+I did not know that FreeBSD $osvers supports POSIX threads.
- *)
- if [ ! -r "$lc_r" ]; then
- cat <<EOM >&4
-POSIX threads should be supported by FreeBSD $osvers --
-but your system is missing the shared libc_r.
-(/sbin/ldconfig -r doesn't find any).
-
-Consider using the latest STABLE release.
+Feel free to tell perlbug@perl.com otherwise.
EOM
- exit 1
- fi
- ldflags="-pthread $ldflags"
+ exit 1
;;
-
esac
set `echo X "$libswanted "| sed -e 's/ c / c_r /'`
diff --git a/contrib/perl5/lib/Cwd.pm b/contrib/perl5/lib/Cwd.pm
index 9a92829da5e4..fa6e73611e7c 100644
--- a/contrib/perl5/lib/Cwd.pm
+++ b/contrib/perl5/lib/Cwd.pm
@@ -20,7 +20,7 @@ getcwd - get pathname of current working directory
chdir "/tmp";
print $ENV{'PWD'};
- use Cwd 'abs_path'; # aka realpath()
+ use Cwd 'abs_path';
print abs_path($ENV{'PWD'});
use Cwd 'fast_abs_path';
@@ -32,11 +32,8 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
in Perl.
The abs_path() function takes a single argument and returns the
-absolute pathname for that argument. It uses the same algorithm
-as getcwd(). (Actually, getcwd() is abs_path(".")) Symbolic links
-and relative-path components ("." and "..") are resolved to return
-the canonical pathname, just like realpath(3). Also callable as
-realpath().
+absolute pathname for that argument. It uses the same algorithm as
+getcwd(). (actually getcwd() is abs_path("."))
The fastcwd() function looks the same as getcwd(), but runs faster.
It's also more dangerous because it might conceivably chdir() you out
@@ -70,19 +67,19 @@ kept up to date if all packages which use chdir import it from Cwd.
use Carp;
-$VERSION = '2.02';
+$VERSION = '2.01';
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
+@EXPORT_OK = qw(chdir abs_path fast_abs_path);
# The 'natural and safe form' for UNIX (pwd may be setuid root)
sub _backtick_pwd {
my $cwd;
- chop($cwd = `pwd`);
+ chop($cwd = `/bin/pwd`);
$cwd;
}
@@ -108,6 +105,9 @@ sub getcwd
# This is a faster version of getcwd. It's also more dangerous because
# you might chdir out of a directory that you can't chdir back into.
+# List of metachars taken from do_exec() in doio.c
+my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n");
+
sub fastcwd {
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
@@ -136,10 +136,9 @@ sub fastcwd {
unshift(@path, $direntry);
}
$path = '/' . join('/', @path);
- if ($^O eq 'apollo') { $path = "/".$path; }
# At this point $path may be tainted (if tainting) and chdir would fail.
# To be more useful we untaint it then check that we landed where we started.
- $path = $1 if $path =~ /^(.*)\z/s; # untaint
+ $path = $1 if $path =~ /^(.*)$/; # untaint
CORE::chdir($path) || return undef;
($cdev, $cino) = stat('.');
die "Unstable directory path, current directory changed unexpectedly"
@@ -167,7 +166,7 @@ sub chdir_init {
$ENV{'PWD'} = cwd();
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
- if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
+ if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
my($pd,$pi) = stat($2);
my($dd,$di) = stat($1);
if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
@@ -184,7 +183,7 @@ sub chdir {
return 0 unless CORE::chdir $newdir;
if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
- if ($newdir =~ m#^/#s) {
+ if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
@@ -257,10 +256,6 @@ sub abs_path
$cwd;
}
-# added function alias for those of us more
-# used to the libc function. --tchrist 27-Jan-00
-*realpath = \&abs_path;
-
sub fast_abs_path {
my $cwd = getcwd();
my $path = shift || '.';
@@ -270,10 +265,6 @@ sub fast_abs_path {
$realpath;
}
-# added function alias to follow principle of least surprise
-# based on previous aliasing. --tchrist 27-Jan-00
-*fast_realpath = \&fast_abs_path;
-
# --- PORTING SECTION ---
@@ -339,7 +330,7 @@ sub _qnx_abs_path {
}
{
- no warnings; # assignments trigger 'subroutine redefined' warning
+ local $^W = 0; # assignments trigger 'subroutine redefined' warning
if ($^O eq 'VMS') {
*cwd = \&_vms_cwd;
@@ -380,12 +371,6 @@ sub _qnx_abs_path {
*abs_path = \&_qnx_abs_path;
*fast_abs_path = \&_qnx_abs_path;
}
- elsif ($^O eq 'cygwin') {
- *getcwd = \&cwd;
- *fastgetcwd = \&cwd;
- *fastcwd = \&cwd;
- *abs_path = \&fast_abs_path;
- }
}
# package main; eval join('',<DATA>) || die $@; # quick test
diff --git a/contrib/perl5/lib/ExtUtils/Install.pm b/contrib/perl5/lib/ExtUtils/Install.pm
index 36c72219a94f..bd49b9f6a21d 100644
--- a/contrib/perl5/lib/ExtUtils/Install.pm
+++ b/contrib/perl5/lib/ExtUtils/Install.pm
@@ -1,13 +1,13 @@
package ExtUtils::Install;
-use 5.005_64;
-our(@ISA, @EXPORT, $VERSION);
$VERSION = substr q$Revision: 1.28 $, 10;
# $Date: 1998/01/25 07:08:24 $
+# $FreeBSD$
use Exporter;
use Carp ();
use Config qw(%Config);
+use vars qw(@ISA @EXPORT $VERSION);
@ISA = ('Exporter');
@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
$Is_VMS = $^O eq 'VMS';
@@ -16,7 +16,7 @@ my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
my $Inc_uninstall_warn_handler;
-#our(@EXPORT, @ISA, $Is_VMS);
+#use vars qw( @EXPORT @ISA $Is_VMS );
#use strict;
sub forceunlink {
@@ -68,6 +68,7 @@ sub install {
}
$packlist->read($pack{"read"}) if (-f $pack{"read"});
my $cwd = cwd();
+ my $umask = umask 0 unless $Is_VMS;
my($source);
MOD_INSTALL: foreach $source (sort keys %hash) {
@@ -77,6 +78,9 @@ sub install {
#install locations. AFS users may call this a bug. We'll have
#to reconsider how to add the means to satisfy AFS users also.
+ # FreeBSD also doesn't like this (much). At install time, the
+ # ctime should change, even if the file does not.
+
#October 1997: we want to install .pm files into archlib if
#there are any files in arch. So we depend on having ./blib/arch
#hardcoded here.
@@ -85,7 +89,9 @@ sub install {
exists $hash{"blib/arch"} and
directory_not_empty("blib/arch")) {
$targetroot = $hash{"blib/arch"};
- print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n";
+ print "Files found in blib/arch --> Installing files in "
+ . "blib/lib into architecture dependend library tree!\n"
+ ; #if $verbose>1;
}
chdir($source) or next;
find(sub {
@@ -104,6 +110,8 @@ sub install {
print "$_ differs\n" if $verbose>1;
$diff++;
}
+ my $diff = 1; # Nasty, lowdown, rotten, scumsucking
+ # hack to make FreeBSD _really_ install.
if ($diff){
if (-f $targetfile){
@@ -134,6 +142,7 @@ sub install {
}, ".");
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
}
+ umask $umask unless $Is_VMS;
if ($pack{'write'}) {
$dir = dirname($pack{'write'});
mkpath($dir,0,0755);
@@ -192,6 +201,7 @@ sub uninstall {
forceunlink($_) unless $nonono;
}
print "unlink $fil\n" if $verbose;
+ close P;
forceunlink($fil) unless $nonono;
}
@@ -224,7 +234,7 @@ sub inc_uninstall {
if ($nonono) {
if ($verbose) {
$Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
- $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
+ $libdir =~ s|^\./|| ; # That's just cosmetics, no need to port. It looks prettier.
$Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
}
# if not verbose, we just say nothing
@@ -257,6 +267,7 @@ sub pm_to_blib {
close(FROMTO);
}
+ my $umask = umask 0022 unless $Is_VMS;
mkpath($autodir,0,0755);
foreach (keys %$fromto) {
next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
@@ -274,9 +285,10 @@ sub pm_to_blib {
utime($atime,$mtime+$Is_VMS,$fromto->{$_});
chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
print "cp $_ $fromto->{$_}\n";
- next unless /\.pm\z/;
+ next unless /\.pm$/;
autosplit($fromto->{$_},$autodir);
}
+ umask $umask unless $Is_VMS;
}
package ExtUtils::Install::Warn;
@@ -339,7 +351,7 @@ There are two keys with a special meaning in the hash: "read" and
target files to the file named by C<$hashref-E<gt>{write}>. If there is
another file named by C<$hashref-E<gt>{read}>, the contents of this file will
be merged into the written file. The read and the written file may be
-identical, but on AFS it is quite likely that people are installing to a
+identical, but on AFS it is quite likely, people are installing to a
different directory than the one where the files later appear.
install_default() takes one or less arguments. If no arguments are
@@ -352,7 +364,7 @@ The argument-less form is convenient for install scripts like
perl -MExtUtils::Install -e install_default Tk/Canvas
-Assuming this command is executed in a directory with a populated F<blib>
+Assuming this command is executed in a directory with populated F<blib>
directory, it will proceed as if the F<blib> was build by MakeMaker on
this machine. This is useful for binary distributions.
diff --git a/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm
index 6029557f11eb..89a242159202 100644
--- a/contrib/perl5/lib/ExtUtils/Liblist.pm
+++ b/contrib/perl5/lib/ExtUtils/Liblist.pm
@@ -1,9 +1,8 @@
package ExtUtils::Liblist;
-
-use 5.005_64;
+use vars qw($VERSION);
# Broken out of MakeMaker from version 4.11
-our $VERSION = substr q$Revision: 1.25 $, 10;
+$VERSION = substr q$Revision: 1.1.1.2 $, 10;
use Config;
use Cwd 'cwd';
@@ -109,14 +108,13 @@ sub _unix_os2_ext {
} elsif (-f ($fullname="$thispth/lib$thislib.$so")
&& (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){
} elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext")
- && (! $Config{'archname'} =~ /RM\d\d\d-svr4/)
&& ($thislib .= "_s") ){ # we must explicitly use _s version
} elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){
} elsif (-f ($fullname="$thispth/$thislib$Config_libext")){
} elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){
} elsif ($^O eq 'dgux'
&& -l ($fullname="$thispth/lib$thislib$Config_libext")
- && readlink($fullname) =~ /^elink:/s) {
+ && readlink($fullname) =~ /^elink:/) {
# Some of DG's libraries look like misconnected symbolic
# links, but development tools can follow them. (They
# look like this:
@@ -138,7 +136,7 @@ sub _unix_os2_ext {
# Now update library lists
# what do we know about this library...
- my $is_dyna = ($fullname !~ /\Q$Config_libext\E\z/);
+ my $is_dyna = ($fullname !~ /\Q$Config_libext\E$/);
my $in_perl = ($libs =~ /\B-l\Q$ {thislib}\E\b/s);
# Do not add it into the list if it is already linked in
@@ -364,7 +362,7 @@ sub _vms_ext {
return ('', '', $crtlstr, '');
}
- my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib);
+ my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj,$ldlib);
my $cwd = cwd();
my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'};
# List of common Unix library names and there VMS equivalents
@@ -432,28 +430,28 @@ sub _vms_ext {
warn "\tChecking $name\n" if $verbose > 2;
if (-f ($test = VMS::Filespec::rmsexpand($name))) {
# It's got its own suffix, so we'll have to figure out the type
- if ($test =~ /(?:$so|exe)$/i) { $type = 'SHR'; }
- elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; }
+ if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; }
+ elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; }
elsif ($test =~ /(?:$obj_ext|obj)$/i) {
warn "Note (probably harmless): "
."Plain object file $test found in library list\n";
- $type = 'OBJ';
+ $type = 'obj';
}
else {
warn "Note (probably harmless): "
."Unknown library type for $test; assuming shared\n";
- $type = 'SHR';
+ $type = 'sh';
}
}
elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or
-f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) {
- $type = 'SHR';
+ $type = 'sh';
$name = $test unless $test =~ /exe;?\d*$/i;
}
elsif (not length($ctype) and # If we've got a lib already, don't bother
( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or
-f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) {
- $type = 'OLB';
+ $type = 'olb';
$name = $test unless $test =~ /olb;?\d*$/i;
}
elsif (not length($ctype) and # If we've got a lib already, don't bother
@@ -461,18 +459,17 @@ sub _vms_ext {
-f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) {
warn "Note (probably harmless): "
."Plain object file $test found in library list\n";
- $type = 'OBJ';
+ $type = 'obj';
$name = $test unless $test =~ /obj;?\d*$/i;
}
if (defined $type) {
$ctype = $type; $cand = $name;
- last if $ctype eq 'SHR';
+ last if $ctype eq 'sh';
}
}
if ($ctype) {
- # This has to precede any other CRTLs, so just make it first
- if ($cand eq 'VAXCCURSE') { unshift @{$found{$ctype}}, $cand; }
- else { push @{$found{$ctype}}, $cand; }
+ eval '$' . $ctype . "{'$cand'}++";
+ die "Error recording library: $@" if $@;
warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1;
next LIB;
}
@@ -481,10 +478,15 @@ sub _vms_ext {
."No library found for $lib\n";
}
- push @fndlibs, @{$found{OBJ}} if exists $found{OBJ};
- push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB};
- push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR};
- $lib = join(' ',@fndlibs);
+ @libs = sort keys %obj;
+ # This has to precede any other CRTLs, so just make it first
+ if ($olb{VAXCCURSE}) {
+ push(@libs,"$olb{VAXCCURSE}/Library");
+ delete $olb{VAXCCURSE};
+ }
+ push(@libs, map { "$_/Library" } sort keys %olb);
+ push(@libs, map { "$_/Share" } sort keys %sh);
+ $lib = join(' ',@libs);
$ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
@@ -542,7 +544,7 @@ below.
=head2 EXTRALIBS
List of libraries that need to be linked with when linking a perl
-binary which includes this extension. Only those libraries that
+binary which includes this extension Only those libraries that
actually exist are included. These are written to a file and used
when linking perl.
@@ -564,7 +566,7 @@ object file. This list is used to create a .bs (bootstrap) file.
=head1 PORTABILITY
This module deals with a lot of system dependencies and has quite a
-few architecture specific C<if>s in the code.
+few architecture specific B<if>s in the code.
=head2 VMS implementation
@@ -684,7 +686,7 @@ enable searching for default libraries specified by C<$Config{libs}>.
The libraries specified may be a mixture of static libraries and
import libraries (to link with DLLs). Since both kinds are used
-pretty transparently on the Win32 platform, we do not attempt to
+pretty transparently on the win32 platform, we do not attempt to
distinguish between them.
=item *
diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm
index 4c8da339b87a..bb662ec7aefc 100644
--- a/contrib/perl5/lib/ExtUtils/MM_Unix.pm
+++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm
@@ -8,10 +8,11 @@ use strict;
use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT
$Verbose %pm %static $Xsubpp_Version);
-$VERSION = substr q$Revision: 1.12603 $, 10;
-# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $
+$VERSION = substr q$Revision: 1.1.1.2 $, 10;
+# $Id: MM_Unix.pm,v 1.1.1.2 1999/05/02 14:25:31 markm Exp $
-Exporter::import('ExtUtils::MakeMaker', qw($Verbose &neatvalue));
+Exporter::import('ExtUtils::MakeMaker',
+ qw( $Verbose &neatvalue));
$Is_OS2 = $^O eq 'os2';
$Is_Mac = $^O eq 'MacOS';
@@ -80,13 +81,13 @@ path. On UNIX eliminated successive slashes and successive "/.".
sub canonpath {
my($self,$path) = @_;
my $node = '';
- if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/|s ) {
+ if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/| ) {
$node = $1;
}
$path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
- $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx
- $path =~ s|(?<=[^/])/\z|| ; # xx/ -> xx
+ $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx
+ $path =~ s|(?<=[^/])/$|| ; # xx/ -> xx
"$node$path";
}
@@ -187,7 +188,6 @@ sub ExtUtils::MM_Unix::fixin ;
sub ExtUtils::MM_Unix::force ;
sub ExtUtils::MM_Unix::guess_name ;
sub ExtUtils::MM_Unix::has_link_code ;
-sub ExtUtils::MM_Unix::htmlifypods ;
sub ExtUtils::MM_Unix::init_dirscan ;
sub ExtUtils::MM_Unix::init_main ;
sub ExtUtils::MM_Unix::init_others ;
@@ -375,45 +375,21 @@ sub cflags {
$self->{uc $_} ||= $cflags{$_}
}
- if ($Is_PERL_OBJECT) {
- $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\b|$)/-DPERL_CAPI/g;
- if ($Is_Win32) {
- if ($Config{'cc'} =~ /^cl/i) {
- # Turn off C++ mode of the MSC compiler
- $self->{CCFLAGS} =~ s/-TP(\s|$)//g;
- $self->{OPTIMIZE} =~ s/-TP(\s|$)//g;
- }
- elsif ($Config{'cc'} =~ /^bcc32/i) {
- # Turn off C++ mode of the Borland compiler
- $self->{CCFLAGS} =~ s/-P(\s|$)//g;
- $self->{OPTIMIZE} =~ s/-P(\s|$)//g;
- }
- elsif ($Config{'cc'} =~ /^gcc/i) {
- # Turn off C++ mode of the GCC compiler
- $self->{CCFLAGS} =~ s/-xc\+\+(\s|$)//g;
- $self->{OPTIMIZE} =~ s/-xc\+\+(\s|$)//g;
- }
+ if ($self->{CAPI} && $Is_PERL_OBJECT) {
+ $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\s|$)//;
+ $self->{CCFLAGS} .= ' -DPERL_CAPI ';
+ if ($Is_Win32 && $Config{'cc'} =~ /^cl.exe/i) {
+ # Turn off C++ mode of the MSC compiler
+ $self->{CCFLAGS} =~ s/-TP(\s|$)//;
+ $self->{OPTIMIZE} =~ s/-TP(\s|$)//;
}
}
-
- if ($self->{POLLUTE}) {
- $self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
- }
-
- my $pollute = '';
- if ($Config{usemymalloc} and not $Config{bincompat5005}
- and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
- and $self->{PERL_MALLOC_OK}) {
- $pollute = '$(PERL_MALLOC_DEF)';
- }
-
return $self->{CFLAGS} = qq{
CCFLAGS = $self->{CCFLAGS}
OPTIMIZE = $self->{OPTIMIZE}
PERLTYPE = $self->{PERLTYPE}
LARGE = $self->{LARGE}
SPLIT = $self->{SPLIT}
-MPOLLUTE = $pollute
};
}
@@ -437,26 +413,13 @@ clean ::
');
# clean subdirectories first
for $dir (@{$self->{DIR}}) {
- if ($Is_Win32 && Win32::IsWin95()) {
- push @m, <<EOT;
- cd $dir
- \$(TEST_F) $self->{MAKEFILE}
- \$(MAKE) clean
- cd ..
-EOT
- }
- else {
- push @m, <<EOT;
- -cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean
-EOT
- }
+ push @m, "\t-cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean\n";
}
my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all
- perlmain.c mon.out core core.*perl.*.?
- *perl.core so_locations pm_to_blib
+ perlmain.c mon.out core so_locations pm_to_blib
*~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe
$(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def
$(BASEEXT).exp
@@ -483,7 +446,7 @@ sub const_cccmd {
return '' unless $self->needs_linking();
return $self->{CONST_CCCMD} =
q{CCCMD = $(CC) -c $(INC) $(CCFLAGS) $(OPTIMIZE) \\
- $(PERLTYPE) $(LARGE) $(SPLIT) $(MPOLLUTE) $(DEFINE_VERSION) \\
+ $(PERLTYPE) $(LARGE) $(SPLIT) $(DEFINE_VERSION) \\
$(XS_DEFINE_VERSION)};
}
@@ -556,7 +519,7 @@ sub constants {
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
- PERL_INC PERL FULLPERL FULL_AR
+ PERL_INC PERL FULLPERL
/ ) {
next unless defined $self->{$tmp};
@@ -568,7 +531,6 @@ VERSION_MACRO = VERSION
DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\"
XS_VERSION_MACRO = XS_VERSION
XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\"
-PERL_MALLOC_DEF = -DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc -Dfree=Perl_mfree -Drealloc=Perl_realloc -Dcalloc=Perl_calloc
};
push @m, qq{
@@ -598,19 +560,12 @@ XS_FILES= ".join(" \\\n\t", sort keys %{$self->{XS}})."
C_FILES = ".join(" \\\n\t", @{$self->{C}})."
O_FILES = ".join(" \\\n\t", @{$self->{O_FILES}})."
H_FILES = ".join(" \\\n\t", @{$self->{H}})."
-HTMLLIBPODS = ".join(" \\\n\t", sort keys %{$self->{HTMLLIBPODS}})."
-HTMLSCRIPTPODS = ".join(" \\\n\t", sort keys %{$self->{HTMLSCRIPTPODS}})."
MAN1PODS = ".join(" \\\n\t", sort keys %{$self->{MAN1PODS}})."
MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})."
";
for $tmp (qw/
- INST_HTMLPRIVLIBDIR INSTALLHTMLPRIVLIBDIR
- INST_HTMLSITELIBDIR INSTALLHTMLSITELIBDIR
- INST_HTMLSCRIPTDIR INSTALLHTMLSCRIPTDIR
- INST_HTMLLIBDIR HTMLEXT
- INST_MAN1DIR INSTALLMAN1DIR MAN1EXT
- INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
+ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
/) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
@@ -738,7 +693,7 @@ sub dir_target {
my($targ) = $self->catfile($dir,'.exists');
# catfile may have adapted syntax of $dir to target OS, so...
if ($Is_VMS) { # Just remove file name; dirspec is often in macro
- ($targdir = $targ) =~ s:/?\.exists\z::;
+ ($targdir = $targ) =~ s:/?\.exists$::;
}
else { # while elsewhere we expect to see the dir separator in $targ
$targdir = dirname($targ);
@@ -1081,7 +1036,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists
$ldrun = qq{-rpath "$self->{LD_RUN_PATH}"}
if ($^O eq 'irix' && $self->{LD_RUN_PATH});
- push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
+ push(@m,' $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
push @m, '
$(CHMOD) $(PERM_RWX) $@
@@ -1124,10 +1079,10 @@ Takes as argument a path and returns true, if it is an absolute path.
sub file_name_is_absolute {
my($self,$file) = @_;
if ($Is_Dos){
- $file =~ m{^([a-z]:)?[\\/]}is ;
+ $file =~ m{^([a-z]:)?[\\/]}i ;
}
else {
- $file =~ m:^/:s ;
+ $file =~ m:^/: ;
}
}
@@ -1310,7 +1265,7 @@ sub guess_name {
my($self) = @_;
use Cwd 'cwd';
my $name = basename(cwd());
- $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we
+ $name =~ s|[\-_][\d\.\-]+$||; # this is new with MM 5.00, we
# strip minus or underline
# followed by a float or some such
print "Warning: Guessing NAME [$name] from current directory name.\n";
@@ -1335,60 +1290,9 @@ sub has_link_code {
return $self->{HAS_LINK_CODE} = 0;
}
-=item htmlifypods (o)
-
-Defines targets and routines to translate the pods into HTML manpages
-and put them into the INST_HTMLLIBDIR and INST_HTMLSCRIPTDIR
-directories.
-
-=cut
-
-sub htmlifypods {
- my($self, %attribs) = @_;
- return "\nhtmlifypods : pure_all\n\t$self->{NOECHO}\$(NOOP)\n" unless
- %{$self->{HTMLLIBPODS}} || %{$self->{HTMLSCRIPTPODS}};
- my($dist);
- my($pod2html_exe);
- if (defined $self->{PERL_SRC}) {
- $pod2html_exe = $self->catfile($self->{PERL_SRC},'pod','pod2html');
- } else {
- $pod2html_exe = $self->catfile($Config{scriptdirexp},'pod2html');
- }
- unless ($pod2html_exe = $self->perl_script($pod2html_exe)) {
- # No pod2html but some HTMLxxxPODS to be installed
- print <<END;
-
-Warning: I could not locate your pod2html program. Please make sure,
- your pod2html program is in your PATH before you execute 'make'
-
-END
- $pod2html_exe = "-S pod2html";
- }
- my(@m);
- push @m,
-qq[POD2HTML_EXE = $pod2html_exe\n],
-qq[POD2HTML = \$(PERL) -we 'use File::Basename; use File::Path qw(mkpath); %m=\@ARGV;for (keys %m){' \\\n],
-q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "],
- $self->{MAKEFILE}, q[";' \\
--e 'print "Htmlifying $$m{$$_}\n";' \\
--e '$$dir = dirname($$m{$$_}); mkpath($$dir) unless -d $$dir;' \\
--e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2HTML_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\
--e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'
-];
- push @m, "\nhtmlifypods : pure_all ";
- push @m, join " \\\n\t", keys %{$self->{HTMLLIBPODS}}, keys %{$self->{HTMLSCRIPTPODS}};
-
- push(@m,"\n");
- if (%{$self->{HTMLLIBPODS}} || %{$self->{HTMLSCRIPTPODS}}) {
- push @m, "\t$self->{NOECHO}\$(POD2HTML) \\\n\t";
- push @m, join " \\\n\t", %{$self->{HTMLLIBPODS}}, %{$self->{HTMLSCRIPTPODS}};
- }
- join('', @m);
-}
-
=item init_dirscan
-Initializes DIR, XS, PM, C, O_FILES, H, PL_FILES, HTML*PODS, MAN*PODS, EXE_FILES.
+Initializes DIR, XS, PM, C, O_FILES, H, PL_FILES, MAN*PODS, EXE_FILES.
=cut
@@ -1405,26 +1309,24 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
if (-d $name){
next if -l $name; # We do not support symlinks at all
$dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
- } elsif ($name =~ /\.xs\z/){
- my($c); ($c = $name) =~ s/\.xs\z/.c/;
+ } elsif ($name =~ /\.xs$/){
+ my($c); ($c = $name) =~ s/\.xs$/.c/;
$xs{$name} = $c;
$c{$c} = 1;
- } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc
+ } elsif ($name =~ /\.c(pp|xx|c)?$/i){ # .c .C .cpp .cxx .cc
$c{$name} = 1
unless $name =~ m/perlmain\.c/; # See MAP_TARGET
- } elsif ($name =~ /\.h\z/i){
+ } elsif ($name =~ /\.h$/i){
$h{$name} = 1;
- } elsif ($name =~ /\.PL\z/) {
- ($pl_files{$name} = $name) =~ s/\.PL\z// ;
- } elsif (($Is_VMS || $Is_Dos) && $name =~ /[._]pl$/i) {
- # case-insensitive filesystem, one dot per name, so foo.h.PL
- # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
+ } elsif ($name =~ /\.PL$/) {
+ ($pl_files{$name} = $name) =~ s/\.PL$// ;
+ } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem
local($/); open(PL,$name); my $txt = <PL>; close PL;
if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
- ($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
+ ($pl_files{$name} = $name) =~ s/\.pl$// ;
}
else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); }
- } elsif ($name =~ /\.(p[ml]|pod)\z/){
+ } elsif ($name =~ /\.(p[ml]|pod)$/){
$pm{$name} = $self->catfile('$(INST_LIBDIR)',$name);
}
}
@@ -1499,64 +1401,70 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
$self->{PM} = \%pm unless $self->{PM};
$self->{C} = [sort keys %c] unless $self->{C};
my(@o_files) = @{$self->{C}};
- $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files] ;
+ $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
$self->{H} = [sort keys %h] unless $self->{H};
$self->{PL_FILES} = \%pl_files unless $self->{PL_FILES};
# Set up names of manual pages to generate from pods
- my %pods;
- foreach my $man (qw(MAN1 MAN3 HTMLLIB HTMLSCRIPT)) {
- unless ($self->{"${man}PODS"}) {
- $self->{"${man}PODS"} = {};
- $pods{$man} = 1 unless $self->{"INST_${man}DIR"} =~ /^(none|\s*)$/;
- }
- }
-
- if ($pods{MAN1} || $pods{HTMLSCRIPT}) {
+ if ($self->{MAN1PODS}) {
+ } elsif ( $self->{INST_MAN1DIR} =~ /^(none|\s*)$/ ) {
+ $self->{MAN1PODS} = {};
+ } else {
+ my %manifypods = ();
if ( exists $self->{EXE_FILES} ) {
foreach $name (@{$self->{EXE_FILES}}) {
+# use FileHandle ();
+# my $fh = new FileHandle;
local *FH;
my($ispod)=0;
+# if ($fh->open("<$name")) {
if (open(FH,"<$name")) {
+# while (<$fh>) {
while (<FH>) {
if (/^=head1\s+\w+/) {
$ispod=1;
last;
}
}
+# $fh->close;
close FH;
} else {
# If it doesn't exist yet, we assume, it has pods in it
$ispod = 1;
}
- next unless $ispod;
- if ($pods{HTMLSCRIPT}) {
- $self->{HTMLSCRIPTPODS}->{$name} =
- $self->catfile("\$(INST_HTMLSCRIPTDIR)", basename($name).".\$(HTMLEXT)");
- }
- if ($pods{MAN1}) {
- $self->{MAN1PODS}->{$name} =
- $self->catfile("\$(INST_MAN1DIR)", basename($name).".\$(MAN1EXT)");
+ if( $ispod ) {
+ $manifypods{$name} =
+ $self->catfile('$(INST_MAN1DIR)',
+ basename($name).'.$(MAN1EXT)');
}
}
}
+ $self->{MAN1PODS} = \%manifypods;
}
- if ($pods{MAN3} || $pods{HTMLLIB}) {
+ if ($self->{MAN3PODS}) {
+ } elsif ( $self->{INST_MAN3DIR} =~ /^(none|\s*)$/ ) {
+ $self->{MAN3PODS} = {};
+ } else {
my %manifypods = (); # we collect the keys first, i.e. the files
# we have to convert to pod
foreach $name (keys %{$self->{PM}}) {
- if ($name =~ /\.pod\z/ ) {
+ if ($name =~ /\.pod$/ ) {
$manifypods{$name} = $self->{PM}{$name};
- } elsif ($name =~ /\.p[ml]\z/ ) {
+ } elsif ($name =~ /\.p[ml]$/ ) {
+# use FileHandle ();
+# my $fh = new FileHandle;
local *FH;
my($ispod)=0;
+# $fh->open("<$name");
if (open(FH,"<$name")) {
+ # while (<$fh>) {
while (<FH>) {
if (/^=head1\s+\w+/) {
$ispod=1;
last;
}
}
+ # $fh->close;
close FH;
} else {
$ispod = 1;
@@ -1570,25 +1478,19 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
# Remove "Configure.pm" and similar, if it's not the only pod listed
# To force inclusion, just name it "Configure.pod", or override MAN3PODS
foreach $name (keys %manifypods) {
- if ($name =~ /(config|setup).*\.pm/is) {
+ if ($name =~ /(config|setup).*\.pm/i) {
delete $manifypods{$name};
next;
}
my($manpagename) = $name;
- $manpagename =~ s/\.p(od|m|l)\z//;
- if ($pods{HTMLLIB}) {
- $self->{HTMLLIBPODS}->{$name} =
- $self->catfile("\$(INST_HTMLLIBDIR)", "$manpagename.\$(HTMLEXT)");
- }
- unless ($manpagename =~ s!^\W*lib\W+!!s) { # everything below lib is ok
+ unless ($manpagename =~ s!^\W*lib\W+!!) { # everything below lib is ok
$manpagename = $self->catfile(split(/::/,$self->{PARENT_NAME}),$manpagename);
}
- if ($pods{MAN3}) {
- $manpagename = $self->replace_manpage_separator($manpagename);
- $self->{MAN3PODS}->{$name} =
- $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
- }
+ $manpagename =~ s/\.p(od|m|l)$//;
+ $manpagename = $self->replace_manpage_separator($manpagename);
+ $manifypods{$name} = $self->catfile("\$(INST_MAN3DIR)","$manpagename.\$(MAN3EXT)");
}
+ $self->{MAN3PODS} = \%manifypods;
}
}
@@ -1629,7 +1531,7 @@ sub init_main {
$modfname = &DynaLoader::mod2fname(\@modparts);
}
- ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ;
+ ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)$! ;
if (defined &DynaLoader::mod2fname) {
# As of 5.001m, dl_os2 appends '_'
@@ -1699,34 +1601,10 @@ from the perl source tree.
}
} else {
# we should also consider $ENV{PERL5LIB} here
- my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
$self->{PERL_LIB} ||= $Config::Config{privlibexp};
$self->{PERL_ARCHLIB} ||= $Config::Config{archlibexp};
$self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
my $perl_h;
-
- if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
- and not $old){
- # Maybe somebody tries to build an extension with an
- # uninstalled Perl outside of Perl build tree
- my $found;
- for my $dir (@INC) {
- $found = $dir, last if -e $self->catdir($dir, "Config.pm");
- }
- if ($found) {
- my $inc = dirname $found;
- if (-e $self->catdir($inc, "perl.h")) {
- $self->{PERL_LIB} = $found;
- $self->{PERL_ARCHLIB} = $found;
- $self->{PERL_INC} = $inc;
- $self->{UNINSTALLED_PERL} = 1;
- print STDOUT <<EOP;
-... Detected uninstalled Perl. Trying to continue.
-EOP
- }
- }
- }
-
unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))){
die qq{
Error: Unable to locate installed Perl libraries or Perl source code.
@@ -1817,7 +1695,8 @@ usually solves this kind of problem.
my($install_variable,$search_prefix,$replace_prefix);
- # If the prefix contains perl, Configure shapes the tree as follows:
+ # The rule, taken from Configure, is that if prefix contains perl,
+ # we shape the tree
# perlprefix/lib/ INSTALLPRIVLIB
# perlprefix/lib/pod/
# perlprefix/lib/site_perl/ INSTALLSITELIB
@@ -1829,58 +1708,45 @@ usually solves this kind of problem.
# prefix/lib/perl5/site_perl/ INSTALLSITELIB
# prefix/bin/ INSTALLBIN
# prefix/lib/perl5/man/ INSTALLMAN1DIR
- #
- # The above results in various kinds of breakage on various
- # platforms, so we cope with it as follows: if prefix/lib/perl5
- # or prefix/lib/perl5/man exist, we'll replace those instead
- # of /prefix/{lib,man}
$replace_prefix = qq[\$\(PREFIX\)];
+ $search_prefix = $self->catdir($configure_prefix,"local");
for $install_variable (qw/
INSTALLBIN
INSTALLSCRIPT
/) {
- $self->prefixify($install_variable,$configure_prefix,$replace_prefix);
+ $self->prefixify($install_variable,$search_prefix,$replace_prefix);
}
- my $funkylibdir = $self->catdir($configure_prefix,"lib","perl5");
- $funkylibdir = '' unless -d $funkylibdir;
- $search_prefix = $funkylibdir || $self->catdir($configure_prefix,"lib");
+ $search_prefix = $configure_prefix =~ /perl/ ?
+ $self->catdir($configure_prefix,"lib") :
+ $self->catdir($configure_prefix,"lib","perl5");
if ($self->{LIB}) {
$self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB};
$self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} =
$self->catdir($self->{LIB},$Config{'archname'});
- }
- else {
- if (-d $self->catdir($self->{PREFIX},"lib","perl5")) {
- $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5");
- }
- else {
- $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib");
- }
+ } else {
+ $replace_prefix = $self->{PREFIX} =~ /perl/ ?
+ $self->catdir(qq[\$\(PREFIX\)],"lib") :
+ $self->catdir(qq[\$\(PREFIX\)],"lib","perl5");
for $install_variable (qw/
INSTALLPRIVLIB
INSTALLARCHLIB
INSTALLSITELIB
INSTALLSITEARCH
- /)
- {
+ /) {
$self->prefixify($install_variable,$search_prefix,$replace_prefix);
}
}
- my $funkymandir = $self->catdir($configure_prefix,"lib","perl5","man");
- $funkymandir = '' unless -d $funkymandir;
- $search_prefix = $funkymandir || $self->catdir($configure_prefix,"man");
- if (-d $self->catdir($self->{PREFIX},"lib","perl5", "man")) {
- $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"lib", "perl5", "man");
- }
- else {
- $replace_prefix = $self->catdir(qq[\$\(PREFIX\)],"man");
- }
+ $search_prefix = $configure_prefix =~ /perl/ ?
+ $self->catdir($configure_prefix,"man") :
+ $self->catdir($configure_prefix,"lib","perl5","man");
+ $replace_prefix = $self->{PREFIX} =~ /perl/ ?
+ $self->catdir(qq[\$\(PREFIX\)],"man") :
+ $self->catdir(qq[\$\(PREFIX\)],"lib","perl5","man");
for $install_variable (qw/
INSTALLMAN1DIR
INSTALLMAN3DIR
- /)
- {
+ /) {
$self->prefixify($install_variable,$search_prefix,$replace_prefix);
}
@@ -1908,30 +1774,6 @@ usually solves this kind of problem.
}
$self->{MAN3EXT} ||= $Config::Config{man3ext};
- $self->{INSTALLHTMLPRIVLIBDIR} = $Config::Config{installhtmlprivlibdir}
- unless defined $self->{INSTALLHTMLPRIVLIBDIR};
- $self->{INSTALLHTMLSITELIBDIR} = $Config::Config{installhtmlsitelibdir}
- unless defined $self->{INSTALLHTMLSITELIBDIR};
-
- unless (defined $self->{INST_HTMLLIBDIR}){
- if ($self->{INSTALLHTMLSITELIBDIR} =~ /^(none|\s*)$/){
- $self->{INST_HTMLLIBDIR} = $self->{INSTALLHTMLSITELIBDIR};
- } else {
- $self->{INST_HTMLLIBDIR} = $self->catdir($self->curdir,'blib','html','lib');
- }
- }
-
- $self->{INSTALLHTMLSCRIPTDIR} = $Config::Config{installhtmlscriptdir}
- unless defined $self->{INSTALLHTMLSCRIPTDIR};
- unless (defined $self->{INST_HTMLSCRIPTDIR}){
- if ($self->{INSTALLHTMLSCRIPTDIR} =~ /^(none|\s*)$/){
- $self->{INST_HTMLSCRIPTDIR} = $self->{INSTALLHTMLSCRIPTDIR};
- } else {
- $self->{INST_HTMLSCRIPTDIR} = $self->catdir($self->curdir,'blib','html','bin');
- }
- }
- $self->{HTMLEXT} ||= $Config::Config{htmlext} || 'html';
-
# Get some stuff out of %Config if we haven't yet done so
print STDOUT "CONFIG must be an array ref\n"
@@ -2005,8 +1847,7 @@ usually solves this kind of problem.
push @defpath, $component if defined $component;
}
$self->{PERL} ||=
- $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl',
- 'perl','perl5',"perl$Config{version}" ],
+ $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ],
\@defpath, $Verbose );
# don't check if perl is executable, maybe they have decided to
# supply switches with perl
@@ -2125,8 +1966,6 @@ pure_perl_install ::
$(INST_ARCHLIB) $(INSTALLARCHLIB) \
$(INST_BIN) $(INSTALLBIN) \
$(INST_SCRIPT) $(INSTALLSCRIPT) \
- $(INST_HTMLLIBDIR) $(INSTALLHTMLPRIVLIBDIR) \
- $(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \
$(INST_MAN1DIR) $(INSTALLMAN1DIR) \
$(INST_MAN3DIR) $(INSTALLMAN3DIR)
}.$self->{NOECHO}.q{$(WARN_IF_OLD_PACKLIST) \
@@ -2141,15 +1980,12 @@ pure_site_install ::
$(INST_ARCHLIB) $(INSTALLSITEARCH) \
$(INST_BIN) $(INSTALLBIN) \
$(INST_SCRIPT) $(INSTALLSCRIPT) \
- $(INST_HTMLLIBDIR) $(INSTALLHTMLSITELIBDIR) \
- $(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \
$(INST_MAN1DIR) $(INSTALLMAN1DIR) \
$(INST_MAN3DIR) $(INSTALLMAN3DIR)
}.$self->{NOECHO}.q{$(WARN_IF_OLD_PACKLIST) \
}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{
doc_perl_install ::
- -}.$self->{NOECHO}.q{$(MKPATH) $(INSTALLARCHLIB)
-}.$self->{NOECHO}.q{$(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLPRIVLIB)" \
@@ -2159,7 +1995,6 @@ doc_perl_install ::
>> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{
doc_site_install ::
- -}.$self->{NOECHO}.q{$(MKPATH) $(INSTALLARCHLIB)
-}.$self->{NOECHO}.q{$(DOC_INSTALL) \
"Module" "$(NAME)" \
"installed into" "$(INSTALLSITELIB)" \
@@ -2385,7 +2220,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
my $incl;
my $xx;
- ($xx = $File::Find::name) =~ s,.*?/auto/,,s;
+ ($xx = $File::Find::name) =~ s,.*?/auto/,,;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
@@ -2403,7 +2238,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
my $excl;
my $xx;
- ($xx = $File::Find::name) =~ s,.*?/auto/,,s;
+ ($xx = $File::Find::name) =~ s,.*?/auto/,,;
$xx =~ s,/?$_,,;
$xx =~ s,/,::,g;
@@ -2420,7 +2255,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
# Once the patch to minimod.PL is in the distribution, I can
# drop it
- return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:;
+ return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}$:;
use Cwd 'cwd';
$static{cwd() . "/" . $_}++;
}, grep( -d $_, @{$searchdirs || []}) );
@@ -2431,7 +2266,7 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
$extra = [] unless $extra && ref $extra eq 'ARRAY';
for (sort keys %static) {
- next unless /\Q$self->{LIB_EXT}\E\z/;
+ next unless /\Q$self->{LIB_EXT}\E$/;
$_ = dirname($_) . "/extralibs.ld";
push @$extra, $_;
}
@@ -2516,7 +2351,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
$tmp/perlmain.c: $makefilename}, q{
}.$self->{NOECHO}.q{echo Writing $@
}.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\
- -e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
+ -e "writemain(grep s#.*/auto/##, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
};
push @m, "\t",$self->{NOECHO}.q{$(PERL) $(INSTALLSCRIPT)/fixpmain
@@ -2526,7 +2361,6 @@ $tmp/perlmain.c: $makefilename}, q{
push @m, q{
doc_inst_perl:
}.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod
- -}.$self->{NOECHO}.q{$(MKPATH) $(INSTALLARCHLIB)
-}.$self->{NOECHO}.q{$(DOC_INSTALL) \
"Perl binary" "$(MAP_TARGET)" \
MAP_STATIC "$(MAP_STATIC)" \
@@ -2608,11 +2442,7 @@ sub manifypods {
} else {
$pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man');
}
- unless ($pod2man_exe = $self->perl_script($pod2man_exe)) {
- # Maybe a build by uninstalled Perl?
- $pod2man_exe = $self->catfile($self->{PERL_INC}, "pod", "pod2man");
- }
- unless ($pod2man_exe = $self->perl_script($pod2man_exe)) {
+ unless ($self->perl_script($pod2man_exe)) {
# No pod2man but some MAN3PODS to be installed
print <<END;
@@ -2739,9 +2569,7 @@ sub nicetext {
=item parse_version
-parse a file and return what you think is $VERSION in this file set to.
-It will return the string "undef" if it can't figure out what $VERSION
-is.
+parse a file and return what you think is $VERSION in this file set to
=cut
@@ -2767,9 +2595,9 @@ sub parse_version {
$_
}; \$$2
};
- no warnings;
+ local($^W) = 0;
$result = eval($eval);
- warn "Could not eval '$eval' in $parsefile: $@" if $@;
+ die "Could not eval '$eval' in $parsefile: $@" if $@;
$result = "undef" unless defined $result;
last;
}
@@ -2791,7 +2619,7 @@ sub parse_abstract {
open(FH,$parsefile) or die "Could not open '$parsefile': $!";
my $inpod = 0;
my $package = $self->{DISTNAME};
- $package =~ s/-/::/g;
+ $package =~ s/-/::/;
while (<FH>) {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if !$inpod;
@@ -2883,53 +2711,16 @@ $(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
push @m, q{
PERL_HDRS = \
- $(PERL_INC)/EXTERN.h \
- $(PERL_INC)/INTERN.h \
- $(PERL_INC)/XSUB.h \
- $(PERL_INC)/av.h \
- $(PERL_INC)/cc_runtime.h \
- $(PERL_INC)/config.h \
- $(PERL_INC)/cop.h \
- $(PERL_INC)/cv.h \
- $(PERL_INC)/dosish.h \
- $(PERL_INC)/embed.h \
- $(PERL_INC)/embedvar.h \
- $(PERL_INC)/fakethr.h \
- $(PERL_INC)/form.h \
- $(PERL_INC)/gv.h \
- $(PERL_INC)/handy.h \
- $(PERL_INC)/hv.h \
- $(PERL_INC)/intrpvar.h \
- $(PERL_INC)/iperlsys.h \
- $(PERL_INC)/keywords.h \
- $(PERL_INC)/mg.h \
- $(PERL_INC)/nostdio.h \
- $(PERL_INC)/objXSUB.h \
- $(PERL_INC)/op.h \
- $(PERL_INC)/opcode.h \
- $(PERL_INC)/opnames.h \
- $(PERL_INC)/patchlevel.h \
- $(PERL_INC)/perl.h \
- $(PERL_INC)/perlapi.h \
- $(PERL_INC)/perlio.h \
- $(PERL_INC)/perlsdio.h \
- $(PERL_INC)/perlsfio.h \
- $(PERL_INC)/perlvars.h \
- $(PERL_INC)/perly.h \
- $(PERL_INC)/pp.h \
- $(PERL_INC)/pp_proto.h \
- $(PERL_INC)/proto.h \
- $(PERL_INC)/regcomp.h \
- $(PERL_INC)/regexp.h \
- $(PERL_INC)/regnodes.h \
- $(PERL_INC)/scope.h \
- $(PERL_INC)/sv.h \
- $(PERL_INC)/thrdvar.h \
- $(PERL_INC)/thread.h \
- $(PERL_INC)/unixish.h \
- $(PERL_INC)/utf8.h \
- $(PERL_INC)/util.h \
- $(PERL_INC)/warnings.h
+$(PERL_INC)/EXTERN.h $(PERL_INC)/gv.h $(PERL_INC)/pp.h \
+$(PERL_INC)/INTERN.h $(PERL_INC)/handy.h $(PERL_INC)/proto.h \
+$(PERL_INC)/XSUB.h $(PERL_INC)/hv.h $(PERL_INC)/regcomp.h \
+$(PERL_INC)/av.h $(PERL_INC)/keywords.h $(PERL_INC)/regexp.h \
+$(PERL_INC)/config.h $(PERL_INC)/mg.h $(PERL_INC)/scope.h \
+$(PERL_INC)/cop.h $(PERL_INC)/op.h $(PERL_INC)/sv.h \
+$(PERL_INC)/cv.h $(PERL_INC)/opcode.h $(PERL_INC)/unixish.h \
+$(PERL_INC)/dosish.h $(PERL_INC)/patchlevel.h $(PERL_INC)/util.h \
+$(PERL_INC)/embed.h $(PERL_INC)/perl.h $(PERL_INC)/iperlsys.h \
+$(PERL_INC)/form.h $(PERL_INC)/perly.h
$(OBJECT) : $(PERL_HDRS)
} if $self->{OBJECT};
@@ -3093,7 +2884,7 @@ sub prefixify {
my($self,$var,$sprefix,$rprefix) = @_;
$self->{uc $var} ||= $Config{lc $var};
$self->{uc $var} = VMS::Filespec::unixpath($self->{uc $var}) if $Is_VMS;
- $self->{uc $var} =~ s/\Q$sprefix\E/$rprefix/s;
+ $self->{uc $var} =~ s/\Q$sprefix\E/$rprefix/;
}
=item processPL (o)
@@ -3137,9 +2928,7 @@ sub realclean {
realclean purge :: clean
');
# realclean subdirectories first (already cleaned)
- my $sub = ($Is_Win32 && Win32::IsWin95()) ?
- "\tcd %s\n\t\$(TEST_F) %s\n\t\$(MAKE) %s realclean\n\tcd ..\n" :
- "\t-cd %s && \$(TEST_F) %s && \$(MAKE) %s realclean\n";
+ my $sub = "\t-cd %s && \$(TEST_F) %s && \$(MAKE) %s realclean\n";
foreach(@{$self->{DIR}}){
push(@m, sprintf($sub,$_,"$self->{MAKEFILE}.old","-f $self->{MAKEFILE}.old"));
push(@m, sprintf($sub,$_,"$self->{MAKEFILE}",''));
@@ -3217,18 +3006,9 @@ END
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
- my $ar;
- if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
- # Prefer the absolute pathed ar if available so that PATH
- # doesn't confuse us. Perl itself is built with the full_ar.
- $ar = 'FULL_AR';
- } else {
- $ar = 'AR';
- }
- push @m,
- "\t\$($ar) ".'$(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@'."\n";
push @m,
-q{ $(CHMOD) $(PERM_RWX) $@
+q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
+ $(CHMOD) $(PERM_RWX) $@
}.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
};
# Old mechanism - still available:
@@ -3292,25 +3072,12 @@ Helper subroutine for subdirs
sub subdir_x {
my($self, $subdir) = @_;
my(@m);
- if ($Is_Win32 && Win32::IsWin95()) {
- # XXX: dmake-specific, like rest of Win95 port
- return <<EOT;
-subdirs ::
-@[
- cd $subdir
- \$(MAKE) all \$(PASTHRU)
- cd ..
-]
-EOT
- }
- else {
- return <<EOT;
+ qq{
subdirs ::
$self->{NOECHO}cd $subdir && \$(MAKE) all \$(PASTHRU)
-EOT
- }
+};
}
=item subdirs (o)
@@ -3555,13 +3322,13 @@ sub tool_xsubpp {
}
}
- my $xsubpp = "xsubpp";
+ my $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp";
return qq{
XSUBPPDIR = $xsdir
XSUBPP = \$(XSUBPPDIR)/$xsubpp
XSPROTOARG = $self->{XSPROTOARG}
-XSUBPPDEPS = @tmdeps \$(XSUBPP)
+XSUBPPDEPS = @tmdeps
XSUBPPARGS = @tmargs
};
};
@@ -3637,7 +3404,7 @@ sub top_targets {
';
push @m, '
-all :: pure_all htmlifypods manifypods
+all :: pure_all manifypods
'.$self->{NOECHO}.'$(NOOP)
'
unless $self->{SKIPHASH}{'all'};
@@ -3659,25 +3426,13 @@ config :: $(INST_AUTODIR)/.exists
'.$self->{NOECHO}.'$(NOOP)
';
- push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
-
- if (%{$self->{HTMLLIBPODS}}) {
- push @m, qq[
-config :: \$(INST_HTMLLIBDIR)/.exists
+ push @m, qq{
+config :: Version_check
$self->{NOECHO}\$(NOOP)
-];
- push @m, $self->dir_target(qw[$(INST_HTMLLIBDIR)]);
- }
+} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
- if (%{$self->{HTMLSCRIPTPODS}}) {
- push @m, qq[
-config :: \$(INST_HTMLSCRIPTDIR)/.exists
- $self->{NOECHO}\$(NOOP)
-
-];
- push @m, $self->dir_target(qw[$(INST_HTMLSCRIPTDIR)]);
- }
+ push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
if (%{$self->{MAN1PODS}}) {
push @m, qq[
@@ -3741,7 +3496,7 @@ sub xs_c {
return '' unless $self->needs_linking();
'
.xs.c:
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c
';
}
@@ -3756,7 +3511,7 @@ sub xs_cpp {
return '' unless $self->needs_linking();
'
.xs.cpp:
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.cpp
';
}
@@ -3772,7 +3527,7 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o
return '' unless $self->needs_linking();
'
.xs$(OBJ_EXT):
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
}
diff --git a/contrib/perl5/lib/ExtUtils/MakeMaker.pm b/contrib/perl5/lib/ExtUtils/MakeMaker.pm
index 38cb2169a338..a614830538ce 100644
--- a/contrib/perl5/lib/ExtUtils/MakeMaker.pm
+++ b/contrib/perl5/lib/ExtUtils/MakeMaker.pm
@@ -1,8 +1,10 @@
+# $FreeBSD$
+
BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatible with perl5.001m
package ExtUtils::MakeMaker;
-$VERSION = "5.45";
+$VERSION = "5.4302";
$Version_OK = "5.17"; # Makefiles older than $Version_OK will die
# (Will be checked from MakeMaker version 4.13 onwards)
($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//;
@@ -17,7 +19,7 @@ use Carp ();
use vars qw(
@ISA @EXPORT @EXPORT_OK $AUTOLOAD
- $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision
+ $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $Setup_done
$VERSION $Verbose $Version_OK %Config %Keep_after_flush
%MM_Sections %Prepend_dot_dot %Recognized_Att_Keys
@Get_from_Config @MM_Sections @Overridable @Parent
@@ -70,7 +72,6 @@ $Is_VMS = $^O eq 'VMS';
$Is_OS2 = $^O eq 'os2';
$Is_Mac = $^O eq 'MacOS';
$Is_Win32 = $^O eq 'MSWin32';
-$Is_Cygwin= $^O eq 'cygwin';
require ExtUtils::MM_Unix;
@@ -87,15 +88,36 @@ if ($Is_Mac) {
if ($Is_Win32) {
require ExtUtils::MM_Win32;
}
-if ($Is_Cygwin) {
- require ExtUtils::MM_Cygwin;
-}
-full_setup();
+# The SelfLoader would bring a lot of overhead for MakeMaker, because
+# we know for sure we will use most of the autoloaded functions once
+# we have to use one of them. So we write our own loader
+
+sub AUTOLOAD {
+ my $code;
+ if (defined fileno(DATA)) {
+ my $fh = select DATA;
+ my $o = $/; # For future reads from the file.
+ $/ = "\n__END__\n";
+ $code = <DATA>;
+ $/ = $o;
+ select $fh;
+ close DATA;
+ eval $code;
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ Carp::croak $@;
+ }
+ } else {
+ warn "AUTOLOAD called unexpectedly for $AUTOLOAD";
+ }
+ defined(&$AUTOLOAD) or die "Myloader inconsistency error";
+ goto &$AUTOLOAD;
+}
-# The use of the Version_check target has been dropped between perl
-# 5.5.63 and 5.5.64. We must keep the subroutine for a while so that
-# old Makefiles can satisfy the Version_check target.
+# The only subroutine we do not SelfLoad is Version_Check because it's
+# called so often. Loading this minimum still requires 1.2 secs on my
+# Indy :-(
sub Version_check {
my($checkversion) = @_;
@@ -116,10 +138,38 @@ sub warnhandler {
warn @_;
}
+sub ExtUtils::MakeMaker::eval_in_subdirs ;
+sub ExtUtils::MakeMaker::eval_in_x ;
+sub ExtUtils::MakeMaker::full_setup ;
+sub ExtUtils::MakeMaker::writeMakefile ;
+sub ExtUtils::MakeMaker::new ;
+sub ExtUtils::MakeMaker::check_manifest ;
+sub ExtUtils::MakeMaker::parse_args ;
+sub ExtUtils::MakeMaker::check_hints ;
+sub ExtUtils::MakeMaker::mv_all_methods ;
+sub ExtUtils::MakeMaker::skipcheck ;
+sub ExtUtils::MakeMaker::flush ;
+sub ExtUtils::MakeMaker::mkbootstrap ;
+sub ExtUtils::MakeMaker::mksymlists ;
+sub ExtUtils::MakeMaker::neatvalue ;
+sub ExtUtils::MakeMaker::selfdocument ;
+sub ExtUtils::MakeMaker::WriteMakefile ;
+sub ExtUtils::MakeMaker::prompt ($;$) ;
+
+1;
+
+__DATA__
+
+package ExtUtils::MakeMaker;
+
sub WriteMakefile {
Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
local $SIG{__WARN__} = \&warnhandler;
+ unless ($Setup_done++){
+ full_setup();
+ undef &ExtUtils::MakeMaker::full_setup; #safe memory
+ }
my %att = @_;
MM->new(\%att)->flush;
}
@@ -180,6 +230,7 @@ sub eval_in_x {
sub full_setup {
$Verbose ||= 0;
+ $^W=1;
# package name for the classes into which the first object will be blessed
$PACKNAME = "PACK000";
@@ -188,19 +239,15 @@ sub full_setup {
AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION
C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS
- EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H
- HTMLLIBPODS HTMLSCRIPTPOD IMPORTS
- INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR
- INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR INSTALLMAN1DIR
+ EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H IMPORTS
+ INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR
INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH
INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB
- INST_HTMLLIBDIR INST_HTMLSCRIPTDIR
INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIB LIBPERL_A LIBS
LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB
- PERL_MALLOC_OK
NAME NEEDS_LINKING NOECHO NORECURS NO_VC OBJECT OPTIMIZE PERL PERLMAINCC
PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX
- PL_FILES PM PMLIBDIRS POLLUTE PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX
+ PL_FILES PM PMLIBDIRS PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX
PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
@@ -227,8 +274,7 @@ sub full_setup {
pasthru
c_o xs_c xs_o top_targets linkext dlsyms dynamic dynamic_bs
- dynamic_lib static static_lib htmlifypods manifypods processPL
- installbin subdirs
+ dynamic_lib static static_lib manifypods processPL installbin subdirs
clean realclean dist_basics dist_core dist_dir dist_test dist_ci
install force perldepend makefile staticmake test ppd
@@ -259,8 +305,7 @@ sub full_setup {
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
- lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so
- exe_ext full_ar
+ lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so exe_ext
);
my $item;
@@ -281,9 +326,8 @@ sub full_setup {
%Prepend_dot_dot =
qw(
- INST_BIN 1 INST_EXE 1 INST_LIB 1 INST_ARCHLIB 1 INST_SCRIPT 1
- MAP_TARGET 1 INST_HTMLLIBDIR 1 INST_HTMLSCRIPTDIR 1
- INST_MAN1DIR 1 INST_MAN3DIR 1 PERL_SRC 1 PERL 1 FULLPERL 1
+ INST_BIN 1 INST_EXE 1 INST_LIB 1 INST_ARCHLIB 1 INST_SCRIPT
+ 1 MAP_TARGET 1 INST_MAN1DIR 1 INST_MAN3DIR 1 PERL_SRC 1
);
@@ -330,13 +374,9 @@ sub ExtUtils::MakeMaker::new {
my($prereq);
foreach $prereq (sort keys %{$self->{PREREQ_PM}}) {
- my $eval = "require $prereq";
+ my $eval = "use $prereq $self->{PREREQ_PM}->{$prereq}";
eval $eval;
-
- if ($@) {
- warn "Warning: prerequisite $prereq failed to load: $@";
- }
- elsif ($prereq->VERSION < $self->{PREREQ_PM}->{$prereq} ){
+ if ($@){
warn "Warning: prerequisite $prereq $self->{PREREQ_PM}->{$prereq} not found";
# Why is/was this 'delete' here? We need PREREQ_PM later to make PPDs.
# } else {
@@ -402,13 +442,11 @@ sub ExtUtils::MakeMaker::new {
}
if ($self->{PARENT}) {
$self->{PARENT}->{CHILDREN}->{$newclass} = $self;
- foreach my $opt (qw(CAPI POLLUTE)) {
- if (exists $self->{PARENT}->{$opt}
- and not exists $self->{$opt})
- {
- # inherit, but only if already unspecified
- $self->{$opt} = $self->{PARENT}->{$opt};
- }
+ if (exists $self->{PARENT}->{CAPI}
+ and not exists $self->{CAPI})
+ {
+ # inherit, but only if already unspecified
+ $self->{CAPI} = $self->{PARENT}->{CAPI};
}
}
} else {
@@ -434,7 +472,7 @@ sub ExtUtils::MakeMaker::new {
else {
$pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!;
}
- print STDOUT <<END unless $self->{UNINSTALLED_PERL};
+ print STDOUT <<END;
Your perl and your Config.pm seem to have different ideas about the architecture
they are running on.
Perl thinks: [$pthinks]
@@ -936,29 +974,26 @@ want to specify some other option, set C<TESTDB_SW> variable:
=head2 make install
make alone puts all relevant files into directories that are named by
-the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_HTMLLIBDIR,
-INST_HTMLSCRIPTDIR, INST_MAN1DIR, and INST_MAN3DIR. All these default
-to something below ./blib if you are I<not> building below the perl
-source directory. If you I<are> building below the perl source,
-INST_LIB and INST_ARCHLIB default to ../../lib, and INST_SCRIPT is not
-defined.
+the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR, and
+INST_MAN3DIR. All these default to something below ./blib if you are
+I<not> building below the perl source directory. If you I<are>
+building below the perl source, INST_LIB and INST_ARCHLIB default to
+ ../../lib, and INST_SCRIPT is not defined.
The I<install> target of the generated Makefile copies the files found
below each of the INST_* directories to their INSTALL*
counterparts. Which counterparts are chosen depends on the setting of
INSTALLDIRS according to the following table:
- INSTALLDIRS set to
- perl site
+ INSTALLDIRS set to
+ perl site
- INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH
- INST_LIB INSTALLPRIVLIB INSTALLSITELIB
- INST_HTMLLIBDIR INSTALLHTMLPRIVLIBDIR INSTALLHTMLSITELIBDIR
- INST_HTMLSCRIPTDIR INSTALLHTMLSCRIPTDIR
- INST_BIN INSTALLBIN
- INST_SCRIPT INSTALLSCRIPT
- INST_MAN1DIR INSTALLMAN1DIR
- INST_MAN3DIR INSTALLMAN3DIR
+ INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH
+ INST_LIB INSTALLPRIVLIB INSTALLSITELIB
+ INST_BIN INSTALLBIN
+ INST_SCRIPT INSTALLSCRIPT
+ INST_MAN1DIR INSTALLMAN1DIR
+ INST_MAN3DIR INSTALLMAN3DIR
The INSTALL... macros in turn default to their %Config
($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.
@@ -1135,7 +1170,7 @@ MakeMaker gives you much more freedom than needed to configure
internal variables and get different results. It is worth to mention,
that make(1) also lets you configure most of the variables that are
used in the Makefile. But in the majority of situations this will not
-be necessary, and should only be done if the author of a package
+be necessary, and should only be done, if the author of a package
recommends it (or you know what you're doing).
=head2 Using Attributes and Parameters
@@ -1179,9 +1214,6 @@ currently used by MakeMaker but may be handy in Makefile.PLs.
=item CAPI
-[This attribute is obsolete in Perl 5.6. PERL_OBJECT builds are C-compatible
-by default.]
-
Switch to force usage of the Perl C API even when compiling for PERL_OBJECT.
Note that this attribute is passed through to any recursive build,
@@ -1295,20 +1327,6 @@ names are passed through unaltered to the linker options file.
Ref to array of *.h file names. Similar to C.
-=item HTMLLIBPODS
-
-Hashref of .pm and .pod files. MakeMaker will default this to all
- .pod and any .pm files that include POD directives. The files listed
-here will be converted to HTML format and installed as was requested
-at Configure time.
-
-=item HTMLSCRIPTPODS
-
-Hashref of pod-containing files. MakeMaker will default this to all
-EXE_FILES files that include POD directives. The files listed
-here will be converted to HTML format and installed as was requested
-at Configure time.
-
=item IMPORTS
This attribute is used to specify names to be imported into the
@@ -1349,22 +1367,6 @@ choose: installprivlib and installarchlib versus installsitelib and
installsitearch. The first pair is chosen with INSTALLDIRS=perl, the
second with INSTALLDIRS=site. Default is site.
-=item INSTALLHTMLPRIVLIBDIR
-
-This directory gets the HTML pages at 'make install' time. Defaults to
-$Config{installhtmlprivlibdir}.
-
-=item INSTALLHTMLSCRIPTDIR
-
-This directory gets the HTML pages at 'make install' time. Defaults to
-$Config{installhtmlscriptdir}.
-
-=item INSTALLHTMLSITELIBDIR
-
-This directory gets the HTML pages at 'make install' time. Defaults to
-$Config{installhtmlsitelibdir}.
-
-
=item INSTALLMAN1DIR
This directory gets the man pages at 'make install' time. Defaults to
@@ -1414,14 +1416,6 @@ need to use it.
Directory where we put library files of this extension while building
it.
-=item INST_HTMLLIBDIR
-
-Directory to hold the man pages in HTML format at 'make' time
-
-=item INST_HTMLSCRIPTDIR
-
-Directory to hold the man pages in HTML format at 'make' time
-
=item INST_MAN1DIR
Directory to hold the man pages at 'make' time
@@ -1433,38 +1427,10 @@ Directory to hold the man pages at 'make' time
=item INST_SCRIPT
Directory, where executable files should be installed during
-'make'. Defaults to "./blib/script", just to have a dummy location during
+'make'. Defaults to "./blib/bin", just to have a dummy location during
testing. make install will copy the files in INST_SCRIPT to
INSTALLSCRIPT.
-=item PERL_MALLOC_OK
-
-defaults to 0. Should be set to TRUE if the extension can work with
-the memory allocation routines substituted by the Perl malloc() subsystem.
-This should be applicable to most extensions with exceptions of those
-
-=over
-
-=item *
-
-with bugs in memory allocations which are caught by Perl's malloc();
-
-=item *
-
-which interact with the memory allocator in other ways than via
-malloc(), realloc(), free(), calloc(), sbrk() and brk();
-
-=item *
-
-which rely on special alignment which is not provided by Perl's malloc().
-
-=back
-
-B<NOTE.> Negligence to set this flag in I<any one> of loaded extension
-nullifies many advantages of Perl's malloc(), such as better usage of
-system resources, error detection, memory usage reporting, catchable failure
-of memory allocations, etc.
-
=item LDFROM
defaults to "$(OBJECT)" and is used in the ld command to specify
@@ -1550,9 +1516,9 @@ Makefile.PL.
=item NEEDS_LINKING
-MakeMaker will figure out if an extension contains linkable code
+MakeMaker will figure out, if an extension contains linkable code
anywhere down the directory tree, and will set this variable
-accordingly, but you can speed it up a very little bit if you define
+accordingly, but you can speed it up a very little bit, if you define
this boolean variable yourself.
=item NOECHO
@@ -1567,7 +1533,7 @@ Boolean. Attribute to inhibit descending into subdirectories.
=item NO_VC
-In general, any generated Makefile checks for the current version of
+In general any generated Makefile checks for the current version of
MakeMaker and the version the Makefile was built under. If NO_VC is
set, the version check is neglected. Do not write this into your
Makefile.PL, use it interactively instead.
@@ -1594,7 +1560,7 @@ to $(CC).
=item PERL_ARCHLIB
-Same as above for architecture dependent files.
+Same as above for architecture dependent files
=item PERL_LIB
@@ -1648,18 +1614,6 @@ they contain will be installed in the corresponding location in the
library. A libscan() method can be used to alter the behaviour.
Defining PM in the Makefile.PL will override PMLIBDIRS.
-=item POLLUTE
-
-Release 5.005 grandfathered old global symbol names by providing preprocessor
-macros for extension source compatibility. As of release 5.6, these
-preprocessor definitions are not available by default. The POLLUTE flag
-specifies that the old names should still be defined:
-
- perl Makefile.PL POLLUTE=1
-
-Please inform the module author if this is necessary to successfully install
-a module under 5.6 or later.
-
=item PPM_INSTALL_EXEC
Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl)
@@ -1688,8 +1642,8 @@ only check if any version is installed already.
=item SKIP
Arryref. E.g. [qw(name1 name2)] skip (do not write) sections of the
-Makefile. Caution! Do not use the SKIP attribute for the negligible
-speedup. It may seriously damage the resulting Makefile. Only use it
+Makefile. Caution! Do not use the SKIP attribute for the neglectible
+speedup. It may seriously damage the resulting Makefile. Only use it,
if you really need it.
=item TYPEMAPS
@@ -1812,7 +1766,7 @@ NB: Extensions that have nothing but *.pm files had to say
{LINKTYPE => ''}
with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line
-can be deleted safely. MakeMaker recognizes when there's nothing to
+can be deleted safely. MakeMaker recognizes, when there's nothing to
be linked.
=item macro
@@ -1823,13 +1777,9 @@ be linked.
{FILES => '$(INST_ARCHAUTODIR)/*.xyz'}
-=item test
-
- {TESTS => 't/*.t'}
-
=item tool_autosplit
- {MAXLEN => 8}
+ {MAXLEN =E<gt> 8}
=back
@@ -1915,7 +1865,7 @@ details)
=item make distclean
does a realclean first and then the distcheck. Note that this is not
-needed to build a new distribution as long as you are sure that the
+needed to build a new distribution as long as you are sure, that the
MANIFEST file is ok.
=item make manifest
diff --git a/contrib/perl5/lib/Sys/Hostname.pm b/contrib/perl5/lib/Sys/Hostname.pm
index 95f9a99a7abf..f8e90959f473 100644
--- a/contrib/perl5/lib/Sys/Hostname.pm
+++ b/contrib/perl5/lib/Sys/Hostname.pm
@@ -93,14 +93,20 @@ sub hostname {
# method 3 - trusty old hostname command
|| eval {
+ $pathstack = $ENV{'PATH'};
+ $ENV{'PATH'} = "/bin:/usr/bin";
local $SIG{__DIE__};
$host = `(hostname) 2>/dev/null`; # bsdish
+ $ENV{'PATH'} = $pathstack;
}
# method 4 - sysV uname command (may truncate)
|| eval {
+ $pathstack = $ENV{'PATH'};
+ $ENV{'PATH'} = "/bin:/usr/bin";
local $SIG{__DIE__};
$host = `uname -n 2>/dev/null`; ## sysVish
+ $ENV{'PATH'} = $pathstack;
}
# method 5 - Apollo pre-SR10
diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c
index 578fafc3f1b5..cc1f7edd132c 100644
--- a/contrib/perl5/perl.c
+++ b/contrib/perl5/perl.c
@@ -1,6 +1,6 @@
/* perl.c
*
- * Copyright (c) 1987-2000 Larry Wall
+ * Copyright (c) 1987-1999 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.
@@ -12,9 +12,8 @@
*/
#include "EXTERN.h"
-#define PERL_IN_PERL_C
#include "perl.h"
-#include "patchlevel.h" /* for local_patches */
+#include "patchlevel.h"
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
@@ -22,10 +21,15 @@
#endif
#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
-char *getenv (char *); /* Usually in <stdlib.h> */
+char *getenv _((char *)); /* Usually in <stdlib.h> */
#endif
-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
@@ -40,133 +44,92 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
#endif
#ifdef PERL_OBJECT
-#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
-
-#if defined(USE_THREADS)
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- INIT_THREADS; \
- ALLOC_THREAD_KEY; \
- } \
- } STMT_END
+static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
#else
-# if defined(USE_ITHREADS)
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- INIT_THREADS; \
- ALLOC_THREAD_KEY; \
- PERL_SET_THX(my_perl); \
- OP_REFCNT_INIT; \
- } \
- else { \
- PERL_SET_THX(my_perl); \
- } \
- } STMT_END
-# else
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- } \
- PERL_SET_THX(my_perl); \
- } STMT_END
-# endif
+static void find_beginning _((void));
+static void forbid_setid _((char *));
+static void incpush _((char *, int));
+static void init_interp _((void));
+static void init_ids _((void));
+static void init_debugger _((void));
+static void init_lexer _((void));
+static void init_main_stash _((void));
+#ifdef USE_THREADS
+static struct perl_thread * init_main_thread _((void));
+#endif /* USE_THREADS */
+static void init_perllib _((void));
+static void init_postdump_symbols _((int, char **, char **));
+static void init_predump_symbols _((void));
+static void my_exit_jump _((void)) __attribute__((noreturn));
+static void nuke_stacks _((void));
+static void open_script _((char *, bool, SV *, int *fd));
+static void usage _((char *));
+#ifdef IAMSUID
+static int fd_on_nosuid_fs _((int));
+#endif
+static void validate_suid _((char *, char*, int));
+static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
#endif
-#ifdef PERL_IMPLICIT_SYS
-PerlInterpreter *
-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);
- INIT_TLS_AND_INTERP;
-#else
- /* New() needs interpreter, so call malloc() instead */
- my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- INIT_TLS_AND_INTERP;
- 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;
+CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+{
+ CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
+ if(pPerl != NULL)
+ pPerl->Init();
+
+ return pPerl;
}
#else
-
-/*
-=for apidoc perl_alloc
-
-Allocates a new Perl interpreter. See L<perlembed>.
-
-=cut
-*/
-
PerlInterpreter *
perl_alloc(void)
{
- PerlInterpreter *my_perl;
-
- /* New() needs interpreter, so call malloc() instead */
- my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ PerlInterpreter *sv_interp;
- INIT_TLS_AND_INTERP;
- Zero(my_perl, 1, PerlInterpreter);
- return my_perl;
+ PL_curinterp = 0;
+ New(53, sv_interp, 1, PerlInterpreter);
+ return sv_interp;
}
-#endif /* PERL_IMPLICIT_SYS */
-
-/*
-=for apidoc perl_construct
-
-Initializes a new Perl interpreter. See L<perlembed>.
-
-=cut
-*/
+#endif /* PERL_OBJECT */
void
-perl_construct(pTHXx)
+#ifdef PERL_OBJECT
+CPerlObj::perl_construct(void)
+#else
+perl_construct(register PerlInterpreter *sv_interp)
+#endif
{
#ifdef USE_THREADS
int i;
#ifndef FAKE_THREADS
- struct perl_thread *thr = NULL;
+ struct perl_thread *thr;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
+
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return;
+#endif
#ifdef MULTIPLICITY
- init_interp();
- PL_perl_destruct_level = 1;
-#else
- if (PL_perl_destruct_level > 0)
- init_interp();
+ ++PL_ninterps;
+ Zero(sv_interp, 1, PerlInterpreter);
#endif
/* 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))
+ croak("panic: pthread_key_create");
+#endif
MUTEX_INIT(&PL_sv_mutex);
+ MUTEX_INIT(&PL_cred_mutex);
/*
* Safe to use basic SV functions from now on (though
* not things like mortals or tainting yet).
@@ -175,21 +138,13 @@ perl_construct(pTHXx)
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_linestr = NEWSV(65,79);
sv_upgrade(PL_linestr,SVt_PVIV);
@@ -215,7 +170,7 @@ perl_construct(pTHXx)
/* TODO: */
/* PL_sighandlerp = sighandler; */
#else
- PL_sighandlerp = Perl_sighandler;
+ PL_sighandlerp = sighandler;
#endif
PL_pidstatus = newHV();
@@ -230,43 +185,36 @@ perl_construct(pTHXx)
#endif
}
- PL_nrs = newSVpvn("\n", 1);
+ PL_nrs = newSVpv("\n", 1);
PL_rs = SvREFCNT_inc(PL_nrs);
- init_stacks();
+ init_stacks(ARGS);
+#ifdef MULTIPLICITY
+ init_interp();
+ PL_perl_destruct_level = 1;
+#else
+ if (PL_perl_destruct_level > 0)
+ init_interp();
+#endif
init_ids();
PL_lex_state = LEX_NOTPARSING;
- JMPENV_BOOTSTRAP;
+ PL_start_env.je_prev = NULL;
+ PL_start_env.je_ret = -1;
+ PL_start_env.je_mustcatch = TRUE;
+ PL_top_env = &PL_start_env;
STATUS_ALL_SUCCESS;
- init_i18nl10n(1);
SET_NUMERIC_STANDARD();
-
- {
- U8 *s;
- PL_patchlevel = NEWSV(0,4);
- (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
- if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
- 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);
- 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
- + ((NV)PERL_SUBVERSION / (NV)1000000)
-#endif
- ;
- SvNOK_on(PL_patchlevel); /* dual valued */
- SvUTF8_on(PL_patchlevel);
- SvREADONLY_on(PL_patchlevel);
- }
+#if defined(SUBVERSION) && SUBVERSION > 0
+ sprintf(PL_patchlevel, "%7.5f", (double) 5
+ + ((double) PATCHLEVEL / (double) 1000)
+ + ((double) SUBVERSION / (double) 100000));
+#else
+ sprintf(PL_patchlevel, "%5.3f", (double) 5 +
+ ((double) PATCHLEVEL / (double) 1000));
+#endif
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
@@ -277,19 +225,20 @@ perl_construct(pTHXx)
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
+ DEBUG( {
+ New(51,PL_debname,128,char);
+ New(52,PL_debdelim,128,char);
+ } )
+
ENTER;
}
-/*
-=for apidoc perl_destruct
-
-Shuts down a Perl interpreter. See L<perlembed>.
-
-=cut
-*/
-
void
-perl_destruct(pTHXx)
+#ifdef PERL_OBJECT
+CPerlObj::perl_destruct(void)
+#else
+perl_destruct(register PerlInterpreter *sv_interp)
+#endif
{
dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
@@ -297,18 +246,19 @@ perl_destruct(pTHXx)
HV *hv;
#ifdef USE_THREADS
Thread t;
- dTHX;
#endif /* USE_THREADS */
- /* wait for all pseudo-forked children to finish */
- PERL_WAIT_FOR_CHILDREN;
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return;
+#endif
#ifdef USE_THREADS
#ifndef FAKE_THREADS
/* Pass 1 on any remaining threads: detach joinables, join zombies */
retry_cleanup:
MUTEX_LOCK(&PL_threads_mutex);
- DEBUG_S(PerlIO_printf(Perl_debug_log,
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: waiting for %d threads...\n",
PL_nthreads - 1));
for (t = thr->next; t != thr; t = t->next) {
@@ -316,7 +266,7 @@ perl_destruct(pTHXx)
switch (ThrSTATE(t)) {
AV *av;
case THRf_ZOMBIE:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joining zombie %p\n", t));
ThrSETSTATE(t, THRf_DEAD);
MUTEX_UNLOCK(&t->mutex);
@@ -330,11 +280,11 @@ perl_destruct(pTHXx)
MUTEX_UNLOCK(&PL_threads_mutex);
JOIN(t, &av);
SvREFCNT_dec((SV*)av);
- DEBUG_S(PerlIO_printf(Perl_debug_log,
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joined zombie %p OK\n", t));
goto retry_cleanup;
case THRf_R_JOINABLE:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: detaching thread %p\n", t));
ThrSETSTATE(t, THRf_R_DETACHED);
/*
@@ -348,7 +298,7 @@ perl_destruct(pTHXx)
MUTEX_UNLOCK(&t->mutex);
goto retry_cleanup;
default:
- DEBUG_S(PerlIO_printf(Perl_debug_log,
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: ignoring %p (state %u)\n",
t, ThrSTATE(t)));
MUTEX_UNLOCK(&t->mutex);
@@ -360,14 +310,14 @@ perl_destruct(pTHXx)
/* Pass 2 on remaining threads: wait for the thread count to drop to one */
while (PL_nthreads > 1)
{
- DEBUG_S(PerlIO_printf(Perl_debug_log,
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: final wait for %d threads\n",
PL_nthreads - 1));
COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
}
/* At this point, we're the last thread */
MUTEX_UNLOCK(&PL_threads_mutex);
- DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
MUTEX_DESTROY(&PL_threads_mutex);
COND_DESTROY(&PL_nthreads_cond);
#endif /* !defined(FAKE_THREADS) */
@@ -377,7 +327,7 @@ perl_destruct(pTHXx)
#ifdef DEBUGGING
{
char *s;
- if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
+ if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
@@ -388,6 +338,10 @@ perl_destruct(pTHXx)
LEAVE;
FREETMPS;
+#ifdef MULTIPLICITY
+ --PL_ninterps;
+#endif
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
@@ -400,7 +354,6 @@ perl_destruct(pTHXx)
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = Nullcv;
- PL_dirty = TRUE;
if (PL_sv_objcount) {
/*
@@ -408,6 +361,8 @@ perl_destruct(pTHXx)
* destructors and destructees still exist. Some sv's might remain.
* Non-referenced objects are on their own.
*/
+
+ PL_dirty = TRUE;
sv_clean_objs();
}
@@ -416,10 +371,12 @@ perl_destruct(pTHXx)
PL_warnhook = Nullsv;
SvREFCNT_dec(PL_diehook);
PL_diehook = Nullsv;
+ SvREFCNT_dec(PL_parsehook);
+ PL_parsehook = Nullsv;
/* call exit list functions */
while (PL_exitlistlen-- > 0)
- PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
+ PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
Safefree(PL_exitlist);
@@ -450,14 +407,15 @@ perl_destruct(pTHXx)
PL_minus_a = FALSE;
PL_minus_F = FALSE;
PL_doswitches = FALSE;
- PL_dowarn = G_WARN_OFF;
+ PL_dowarn = FALSE;
PL_doextract = FALSE;
PL_sawampersand = FALSE; /* must save all match strings */
+ PL_sawstudy = FALSE; /* do fbm_instr on all strings */
+ PL_sawvec = FALSE;
PL_unsafe = FALSE;
Safefree(PL_inplace);
PL_inplace = Nullch;
- SvREFCNT_dec(PL_patchlevel);
if (PL_e_script) {
SvREFCNT_dec(PL_e_script);
@@ -466,10 +424,10 @@ 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); /* $/ */
@@ -478,9 +436,7 @@ perl_destruct(pTHXx)
SvREFCNT_dec(PL_nrs); /* $/ helper */
PL_nrs = Nullsv;
- PL_multiline = 0; /* $* */
- Safefree(PL_osname); /* $^O */
- PL_osname = Nullch;
+ PL_multiline = 0; /* $* */
SvREFCNT_dec(PL_statname);
PL_statname = Nullsv;
@@ -496,157 +452,61 @@ perl_destruct(pTHXx)
Safefree(PL_screamnext);
PL_screamnext = 0;
- /* float buffer */
- Safefree(PL_efloatbuf);
- PL_efloatbuf = Nullch;
- PL_efloatsize = 0;
-
/* startup and shutdown function lists */
SvREFCNT_dec(PL_beginav);
SvREFCNT_dec(PL_endav);
- SvREFCNT_dec(PL_checkav);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_endav = Nullav;
- PL_checkav = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
PL_envgv = Nullgv;
+ PL_siggv = Nullgv;
PL_incgv = Nullgv;
PL_hintgv = Nullgv;
PL_errgv = Nullgv;
PL_argvgv = Nullgv;
PL_argvoutgv = Nullgv;
PL_stdingv = Nullgv;
- 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 */
-#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);
- 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;
-#ifndef USE_ITHREADS
- SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV_set(&PL_compiling, Nullgv);
-#endif
-
/* 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);
- PL_errors = Nullsv;
FREETMPS;
- if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
+ if (destruct_level >= 2) {
if (PL_scopestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
- "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
(long)PL_scopestack_ix);
if (PL_savestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
- "Unbalanced saves: %ld more saves than restores\n",
+ warn("Unbalanced saves: %ld more saves than restores\n",
(long)PL_savestack_ix);
if (PL_tmps_floor != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
+ warn("Unbalanced tmps: %ld more allocs than frees\n",
(long)PL_tmps_floor + 1);
if (cxstack_ix != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
+ warn("Unbalanced context: %ld more PUSHes than POPs\n",
(long)cxstack_ix + 1);
}
/* 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,
@@ -662,9 +522,8 @@ perl_destruct(pTHXx)
array = HvARRAY(PL_strtab);
hent = array[0];
for (;;) {
- if (hent && ckWARN_d(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,
- "Unbalanced string table refcount: (%d) for \"%s\"",
+ if (hent) {
+ warn("Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
HeVAL(hent) = Nullsv;
hent = HeNEXT(hent);
@@ -678,32 +537,17 @@ perl_destruct(pTHXx)
}
SvREFCNT_dec(PL_strtab);
- /* free special SVs */
-
- 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);
+ if (PL_sv_count != 0)
+ warn("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_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
nuke_stacks();
@@ -713,8 +557,8 @@ perl_destruct(pTHXx)
#ifdef USE_THREADS
MUTEX_DESTROY(&PL_strtab_mutex);
MUTEX_DESTROY(&PL_sv_mutex);
- MUTEX_DESTROY(&PL_eval_mutex);
MUTEX_DESTROY(&PL_cred_mutex);
+ MUTEX_DESTROY(&PL_eval_mutex);
COND_DESTROY(&PL_eval_cond);
#ifdef EMULATE_ATOMIC_REFCOUNTS
MUTEX_DESTROY(&PL_svref_mutex);
@@ -726,7 +570,7 @@ perl_destruct(pTHXx)
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) {
@@ -742,7 +586,7 @@ perl_destruct(pTHXx)
}
}
/* we know that type >= SVt_PV */
- (void)SvOOK_off(PL_mess_sv);
+ SvOOK_off(PL_mess_sv);
Safefree(SvPVX(PL_mess_sv));
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
@@ -750,32 +594,28 @@ perl_destruct(pTHXx)
}
}
-/*
-=for apidoc perl_free
-
-Releases a Perl interpreter. See L<perlembed>.
-
-=cut
-*/
-
void
-perl_free(pTHXx)
+#ifdef PERL_OBJECT
+CPerlObj::perl_free(void)
+#else
+perl_free(PerlInterpreter *sv_interp)
+#endif
{
-#if defined(PERL_OBJECT)
- PerlMem_free(this);
+#ifdef PERL_OBJECT
+ Safefree(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
+ if (!(PL_curinterp = sv_interp))
+ return;
+ Safefree(sv_interp);
#endif
}
void
-Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
+#ifdef PERL_OBJECT
+CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
+#else
+perl_atexit(void (*fn) (void *), void *ptr)
+#endif
{
Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
PL_exitlist[PL_exitlistlen].fn = fn;
@@ -783,34 +623,39 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
++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)
+#ifdef PERL_OBJECT
+CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
+#else
+perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
+#endif
{
dTHR;
+ register SV *sv;
+ register char *s;
+ char *scriptname = NULL;
+ VOL bool dosearch = FALSE;
+ char *validarg = "";
I32 oldscope;
- int ret;
+ AV* comppadlist;
dJMPENV;
-#ifdef USE_THREADS
- dTHX;
-#endif
+ int ret;
+ int fdscript = -1;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
- Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
+ croak("suidperl is no longer needed since the kernel can now execute\n\
setuid perl scripts securely.\n");
#endif
#endif
-#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return 255;
+#endif
+
+#if defined(NeXT) && defined(__DYNAMIC__)
_dyld_lookup_and_bind
("__environ", (unsigned long *) &environ_pointer, NULL);
#endif /* environ */
@@ -844,22 +689,9 @@ setuid perl scripts securely.\n");
time(&PL_basetime);
oldscope = PL_scopestack_ix;
- PL_dowarn = G_WARN_OFF;
-#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:
-#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 */
@@ -869,47 +701,18 @@ setuid perl scripts securely.\n");
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_checkav)
- call_list(oldscope, PL_checkav);
- ret = STATUS_NATIVE_EXPORT;
- break;
+ if (PL_endav)
+ call_list(oldscope, PL_endav);
+ JMPENV_POP;
+ return STATUS_NATIVE_EXPORT;
case 3:
- PerlIO_printf(Perl_error_log, "panic: top_env\n");
- ret = 1;
- break;
+ JMPENV_POP;
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
+ return 1;
}
- 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_ char **env, XSINIT_t xsinit)
-{
- dTHR;
- int argc = PL_origargc;
- char **argv = PL_origargv;
- char *scriptname = NULL;
- int fdscript = -1;
- VOL bool dosearch = FALSE;
- char *validarg = "";
- AV* comppadlist;
- register SV *sv;
- register char *s;
- char *cddir = Nullch;
sv_setpvn(PL_linestr,"",0);
- sv = newSVpvn("",0); /* first used for -I flags */
+ sv = newSVpv("",0); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
@@ -925,11 +728,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
s = argv[0]+1;
reswitch:
switch (*s) {
- case 'C':
-#ifdef WIN32
- win32_argv2utf8(argc-1, argv+1);
- /* FALL THROUGH */
-#endif
#ifndef PERL_STRICT_CR
case '\r':
#endif
@@ -951,10 +749,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
case 'u':
case 'U':
case 'v':
- case 'W':
- case 'X':
case 'w':
- if ((s = moreswitches(s)))
+ if (s = moreswitches(s))
goto reswitch;
break;
@@ -965,9 +761,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
case 'e':
if (PL_euid != PL_uid || PL_egid != PL_gid)
- Perl_croak(aTHX_ "No -e allowed in setuid scripts");
+ croak("No -e allowed in setuid scripts");
if (!PL_e_script) {
- PL_e_script = newSVpvn("",0);
+ PL_e_script = newSVpv("",0);
filter_add(read_e_script, NULL);
}
if (*++s)
@@ -977,7 +773,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
argc--,argv++;
}
else
- Perl_croak(aTHX_ "No code specified for -e");
+ croak("No code specified for -e");
sv_catpv(PL_e_script, "\n");
break;
@@ -986,18 +782,18 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
if (!*++s && (s=argv[1]) != Nullch) {
argc--,argv++;
}
+ while (s && isSPACE(*s))
+ ++s;
if (s && *s) {
- char *p;
- STRLEN len = strlen(s);
- p = savepvn(s, len);
- incpush(p, TRUE, TRUE);
- sv_catpvn(sv, "-I", 2);
- sv_catpvn(sv, p, len);
- sv_catpvn(sv, " ", 1);
+ char *e, *p;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ sv_catpv(sv,"-I");
+ sv_catpv(sv,p);
+ sv_catpv(sv," ");
Safefree(p);
- }
- else
- Perl_croak(aTHX_ "No directory specified for -I");
+ } /* XXX else croak? */
break;
case 'P':
forbid_setid("-P");
@@ -1020,61 +816,35 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
#else
sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
+#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
sv_catpv(PL_Sv,"\" Compile-time options:");
# ifdef DEBUGGING
sv_catpv(PL_Sv," DEBUGGING");
# endif
+# ifdef NO_EMBED
+ sv_catpv(PL_Sv," NO_EMBED");
+# endif
# ifdef MULTIPLICITY
sv_catpv(PL_Sv," MULTIPLICITY");
# endif
-# 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
-# ifdef PERL_IMPLICIT_CONTEXT
- sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
-# endif
-# ifdef PERL_IMPLICIT_SYS
- sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
-# endif
sv_catpv(PL_Sv,"\\n\",");
-
+#endif
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0) {
int i;
sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
if (PL_localpatches[i])
- Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
+ sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]);
}
}
#endif
- Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
+ sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
#ifdef __DATE__
# ifdef __TIME__
- Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
+ sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
# else
- Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
+ sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
# endif
#endif
sv_catpv(PL_Sv, "; \
@@ -1096,7 +866,7 @@ print \" \\@INC:\\n @INC\\n\";");
PL_doextract = TRUE;
s++;
if (*s)
- cddir = s;
+ PL_cddir = savepv(s);
break;
case 0:
break;
@@ -1117,36 +887,25 @@ print \" \\@INC:\\n @INC\\n\";");
s--;
/* FALL THROUGH */
default:
- Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
+ croak("Unrecognized switch: -%s (-h will show valid options)",s);
}
}
switch_end:
- if (
-#ifndef SECURE_INTERNAL_GETENV
- !PL_tainting &&
-#endif
- (s = PerlEnv_getenv("PERL5OPT")))
- {
- while (isSPACE(*s))
- s++;
- if (*s == '-' && *(s+1) == 'T')
- PL_tainting = TRUE;
- else {
- while (s && *s) {
- while (isSPACE(*s))
- s++;
- if (*s == '-') {
- s++;
- if (isSPACE(*s))
- continue;
- }
- if (!*s)
- break;
- if (!strchr("DIMUdmw", *s))
- Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
- s = moreswitches(s);
+ if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+ while (s && *s) {
+ while (isSPACE(*s))
+ s++;
+ if (*s == '-') {
+ s++;
+ if (isSPACE(*s))
+ continue;
}
+ if (!*s)
+ break;
+ if (!strchr("DIMUdmw", *s))
+ croak("Illegal switch in PERL5OPT: -%c", *s);
+ s = moreswitches(s);
}
}
@@ -1170,27 +929,8 @@ print \" \\@INC:\\n @INC\\n\";");
validate_suid(validarg, scriptname,fdscript);
-#if defined(SIGCHLD) || defined(SIGCLD)
- {
-#ifndef SIGCHLD
-# define SIGCHLD SIGCLD
-#endif
- Sighandler_t sigstate = rsignal_state(SIGCHLD);
- if (sigstate == SIG_IGN) {
- if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ WARN_SIGNAL,
- "Can't ignore signal CHLD, forcing to default");
- (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
- }
- }
-#endif
-
- if (PL_doextract) {
+ if (PL_doextract)
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);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
@@ -1204,7 +944,7 @@ print \" \\@INC:\\n @INC\\n\";");
PL_min_intro_pending = 0;
PL_padix = 0;
#ifdef USE_THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
+ av_store(PL_comppad_name, 0, newSVpv("@_", 2));
PL_curpad[0] = (SV*)newAV();
SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
CvOWNER(PL_compcv) = 0;
@@ -1219,20 +959,13 @@ print \" \\@INC:\\n @INC\\n\";");
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) || defined(__CYGWIN__)
+ (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
init_os_extras();
#endif
-#ifdef USE_SOCKS
- SOCKSinit(argv[0]);
-#endif
-
init_predump_symbols();
/* init_postdump_symbols not currently designed to be called */
/* more than once (ENV isn't cleared first, for example) */
@@ -1248,13 +981,13 @@ print \" \\@INC:\\n @INC\\n\";");
PL_error_count = 0;
if (yyparse() || PL_error_count) {
if (PL_minus_c)
- Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
+ croak("%s had compilation errors.\n", PL_origfilename);
else {
- Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
- PL_origfilename);
+ croak("Execution of %s aborted due to compilation errors.\n",
+ PL_origfilename);
}
}
- CopLINE_set(PL_curcop, 0);
+ PL_curcop->cop_line = 0;
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
if (PL_e_script) {
@@ -1265,15 +998,12 @@ print \" \\@INC:\\n @INC\\n\";");
/* now that script is parsed, we can modify record separator */
SvREFCNT_dec(PL_rs);
PL_rs = SvREFCNT_inc(PL_nrs);
- sv_setsv(get_sv("/", TRUE), PL_rs);
+ sv_setsv(perl_get_sv("/", TRUE), PL_rs);
if (PL_do_undump)
my_unexec();
- if (isWARN_ONCE) {
- SAVECOPFILE(PL_curcop);
- SAVECOPLINE(PL_curcop);
+ if (PL_dowarn)
gv_check(PL_defstash);
- }
LEAVE;
FREETMPS;
@@ -1285,105 +1015,74 @@ print \" \\@INC:\\n @INC\\n\";");
ENTER;
PL_restartop = 0;
- return NULL;
+ JMPENV_POP;
+ return 0;
}
-/*
-=for apidoc perl_run
-
-Tells a Perl interpreter to run. See L<perlembed>.
-
-=cut
-*/
-
int
-perl_run(pTHXx)
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
+#endif
{
- dTHR;
+ dSP;
I32 oldscope;
- int ret = 0;
dJMPENV;
-#ifdef USE_THREADS
- dTHX;
+ int ret;
+
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return 255;
#endif
oldscope = PL_scopestack_ix;
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- 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 */
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- run_body(oldscope);
-#endif
- /* FALL THROUGH */
- case 2: /* my_exit() */
+ break;
+ case 2:
+ /* my_exit() was called */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (PL_endav && !PL_minus_c)
+ if (PL_endav)
call_list(oldscope, PL_endav);
#ifdef MYMALLOC
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- ret = STATUS_NATIVE_EXPORT;
- break;
+ JMPENV_POP;
+ return STATUS_NATIVE_EXPORT;
case 3:
- if (PL_restartop) {
- POPSTACK_TO(PL_mainstack);
- goto redo_body;
+ if (!PL_restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ FREETMPS;
+ JMPENV_POP;
+ return 1;
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
- FREETMPS;
- ret = 1;
+ POPSTACK_TO(PL_mainstack);
break;
}
- JMPENV_POP;
- return ret;
-}
-
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vrun_body(pTHX_ va_list args)
-{
- 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"));
if (!PL_restartop) {
DEBUG_x(dump_all());
DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
- DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
- PTR2UV(thr)));
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+ (unsigned long) thr));
if (PL_minus_c) {
- PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
+ PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ sv_setiv(PL_DBsingle, 1);
if (PL_initav)
call_list(oldscope, PL_initav);
}
@@ -1393,31 +1092,21 @@ S_run_body(pTHX_ I32 oldscope)
if (PL_restartop) {
PL_op = PL_restartop;
PL_restartop = 0;
- CALLRUNOPS(aTHX);
+ CALLRUNOPS();
}
else if (PL_main_start) {
CvDEPTH(PL_main_cv) = 1;
PL_op = PL_main_start;
- CALLRUNOPS(aTHX);
+ CALLRUNOPS();
}
my_exit(0);
/* NOTREACHED */
- return NULL;
+ return 0;
}
-/*
-=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)
+perl_get_sv(char *name, I32 create)
{
GV *gv;
#ifdef USE_THREADS
@@ -1435,18 +1124,8 @@ 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)
+perl_get_av(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVAV);
if (create)
@@ -1456,18 +1135,8 @@ 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)
+perl_get_hv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVHV);
if (create)
@@ -1477,25 +1146,11 @@ 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)
+perl_get_cv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
/* XXX unsafe for threads if eval_owner isn't held */
- /* XXX this is probably not what they think they're getting.
- * It has the same effect as "sub name;", i.e. just a forward
- * declaration! */
if (create && !GvCVu(gv))
return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
@@ -1508,16 +1163,8 @@ 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)
+perl_call_argv(char *sub_name, I32 flags, register char **argv)
/* See G_* flags in cop.h */
/* null terminated arg list */
@@ -1532,65 +1179,37 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
}
PUTBACK;
}
- return call_pv(sub_name, flags);
+ return perl_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)
+perl_call_pv(char *sub_name, I32 flags)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- return call_sv((SV*)get_cv(sub_name, TRUE), flags);
+ return perl_call_sv((SV*)perl_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)
+perl_call_method(char *methname, I32 flags)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
dSP;
OP myop;
- if (!PL_op) {
- Zero(&myop, 1, OP);
+ if (!PL_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);
+ pp_method(ARGS);
+ if(PL_op == &myop)
+ PL_op = Nullop;
+ return perl_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)
+perl_call_sv(SV *sv, I32 flags)
/* See G_* flags in cop.h */
{
@@ -1600,9 +1219,9 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
I32 retval;
I32 oldscope;
bool oldcatch = CATCH_GET;
+ dJMPENV;
int ret;
OP* oldop = PL_op;
- dJMPENV;
if (flags & G_DISCARD) {
ENTER;
@@ -1633,13 +1252,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
&& !(flags & G_NODEBUG))
PL_op->op_private |= OPpENTERSUB_DB;
- if (!(flags & G_EVAL)) {
- CATCH_SET(TRUE);
- call_body((OP*)&myop, FALSE);
- retval = PL_stack_sp - (PL_stack_base + oldmark);
- CATCH_SET(oldcatch);
- }
- else {
+ if (flags & G_EVAL) {
cLOGOP->op_other = PL_op;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
@@ -1651,34 +1264,21 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
SAVETMPS;
push_return(PL_op->op_next);
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
+ PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
PUSHEVAL(cx, 0, 0);
PL_eval_root = PL_op; /* Only needed so that goto works right. */
- PL_in_eval = EVAL_INEVAL;
+ PL_in_eval = 1;
if (flags & G_KEEPERR)
- PL_in_eval |= EVAL_KEEPERR;
+ PL_in_eval |= 4;
else
sv_setpv(ERRSV,"");
}
PL_markstack_ptr++;
-#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,"");
break;
case 1:
STATUS_ALL_FAILURE;
@@ -1688,15 +1288,15 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
PL_curstash = PL_defstash;
FREETMPS;
JMPENV_POP;
- if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
- Perl_croak(aTHX_ "Callback called exit");
+ if (PL_statusvalue)
+ croak("Callback called exit");
my_exit_jump();
/* NOTREACHED */
case 3:
if (PL_restartop) {
PL_op = PL_restartop;
PL_restartop = 0;
- goto redo_body;
+ break;
}
PL_stack_sp = PL_stack_base + oldmark;
if (flags & G_ARRAY)
@@ -1705,9 +1305,22 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
retval = 1;
*++PL_stack_sp = &PL_sv_undef;
}
- break;
+ goto cleanup;
}
+ }
+ else
+ CATCH_SET(TRUE);
+
+ if (PL_op == (OP*)&myop)
+ PL_op = pp_entersub(ARGS);
+ if (PL_op)
+ CALLRUNOPS();
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if ((flags & G_EVAL) && !(flags & G_KEEPERR))
+ sv_setpv(ERRSV,"");
+ cleanup:
+ if (flags & G_EVAL) {
if (PL_scopestack_ix > oldscope) {
SV **newsp;
PMOP *newpm;
@@ -1723,6 +1336,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
}
JMPENV_POP;
}
+ else
+ CATCH_SET(oldcatch);
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
@@ -1734,45 +1349,10 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
return retval;
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vcall_body(pTHX_ va_list args)
-{
- OP *myop = va_arg(args, OP*);
- int is_eval = va_arg(args, int);
-
- call_body(myop, is_eval);
- return NULL;
-}
-#endif
-
-STATIC void
-S_call_body(pTHX_ OP *myop, int is_eval)
-{
- dTHR;
-
- if (PL_op == myop) {
- if (is_eval)
- PL_op = Perl_pp_entereval(aTHX);
- else
- PL_op = Perl_pp_entersub(aTHX);
- }
- if (PL_op)
- CALLRUNOPS(aTHX);
-}
-
/* 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)
+perl_eval_sv(SV *sv, I32 flags)
/* See G_* flags in cop.h */
{
@@ -1781,9 +1361,9 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
I32 oldmark = SP - PL_stack_base;
I32 retval;
I32 oldscope;
+ dJMPENV;
int ret;
OP* oldop = PL_op;
- dJMPENV;
if (flags & G_DISCARD) {
ENTER;
@@ -1807,22 +1387,9 @@ 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_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,"");
break;
case 1:
STATUS_ALL_FAILURE;
@@ -1832,15 +1399,15 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
PL_curstash = PL_defstash;
FREETMPS;
JMPENV_POP;
- if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
- Perl_croak(aTHX_ "Callback called exit");
+ if (PL_statusvalue)
+ croak("Callback called exit");
my_exit_jump();
/* NOTREACHED */
case 3:
if (PL_restartop) {
PL_op = PL_restartop;
PL_restartop = 0;
- goto redo_body;
+ break;
}
PL_stack_sp = PL_stack_base + oldmark;
if (flags & G_ARRAY)
@@ -1849,9 +1416,18 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
retval = 1;
*++PL_stack_sp = &PL_sv_undef;
}
- break;
+ goto cleanup;
}
+ if (PL_op == (OP*)&myop)
+ PL_op = pp_entereval(ARGS);
+ if (PL_op)
+ CALLRUNOPS();
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if (!(flags & G_KEEPERR))
+ sv_setpv(ERRSV,"");
+
+ cleanup:
JMPENV_POP;
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
@@ -1863,22 +1439,14 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
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)
+perl_eval_pv(char *p, I32 croak_on_error)
{
dSP;
SV* sv = newSVpv(p, 0);
PUSHMARK(SP);
- eval_sv(sv, G_SCALAR);
+ perl_eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
SPAGAIN;
@@ -1887,7 +1455,7 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
if (croak_on_error && SvTRUE(ERRSV)) {
STRLEN n_a;
- Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
+ croak(SvPVx(ERRSV, n_a));
}
return sv;
@@ -1895,16 +1463,8 @@ 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)
+perl_require_pv(char *pv)
{
SV* sv;
dSP;
@@ -1914,22 +1474,23 @@ Perl_require_pv(pTHX_ const char *pv)
sv_setpv(sv, "require '");
sv_catpv(sv, pv);
sv_catpv(sv, "'");
- eval_sv(sv, G_DISCARD);
+ perl_eval_sv(sv, G_DISCARD);
SPAGAIN;
POPSTACK;
}
void
-Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
+magicname(char *sym, char *name, I32 namlen)
{
register GV *gv;
- if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
+ if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
STATIC void
-S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
+usage(char *name) /* XXX move this out into a module ? */
+
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that opton. Others? */
@@ -1937,29 +1498,26 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
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)",
-"-e 'command' one line of program (several -e's allowed, omit programfile)",
-"-F/pattern/ split() pattern for -a switch (//'s are optional)",
-"-i[extension] edit <> files in place (makes backup if extension supplied)",
-"-Idirectory specify @INC/#include directory (several -I's allowed)",
+"-d[:debugger] run scripts under debugger",
+"-D[number/list] set debugging flags (argument is a bit mask or flags)",
+"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
+"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
+"-i[extension] edit <> files in place (make backup if extension supplied)",
+"-Idirectory specify @INC/#include directory (may be used more than once)",
"-l[octal] enable line ending processing, specifies line terminator",
-"-[mM][-]module execute `use/no module...' before executing program",
-"-n assume 'while (<>) { ... }' loop around program",
-"-p assume loop like -n but print line also, like sed",
-"-P run program through C preprocessor before compilation",
-"-s enable rudimentary parsing for switches after programfile",
-"-S look for programfile using PATH environment variable",
-"-T enable tainting checks",
-"-u dump core after parsing program",
+"-[mM][-]module.. executes `use/no module...' before executing your script.",
+"-n assume 'while (<>) { ... }' loop around your script",
+"-p assume loop like -n but print line also like sed",
+"-P run script through C preprocessor before compilation",
+"-s enable some switch parsing for switches after script name",
+"-S look for the script using PATH environment variable",
+"-T turn on tainting checks",
+"-u dump core after parsing script",
"-U allow unsafe operations",
-"-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",
+"-v print version number, patchlevel plus VERY IMPORTANT perl info",
+"-V[:variable] print perl configuration information",
+"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
"\n",
NULL
@@ -1974,7 +1532,7 @@ NULL
/* This routine handles any switches that can be given during run */
char *
-Perl_moreswitches(pTHX_ char *s)
+moreswitches(char *s)
{
I32 numlen;
U32 rschar;
@@ -1983,22 +1541,18 @@ Perl_moreswitches(pTHX_ char *s)
case '0':
{
dTHR;
- rschar = (U32)scan_oct(s, 4, &numlen);
+ rschar = scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
if (rschar & ~((U8)~0))
PL_nrs = &PL_sv_undef;
else if (!rschar && numlen >= 2)
- PL_nrs = newSVpvn("", 0);
+ PL_nrs = newSVpv("", 0);
else {
char ch = rschar;
- PL_nrs = newSVpvn(&ch, 1);
+ PL_nrs = newSVpv(&ch, 1);
}
return s + numlen;
}
- case 'C':
- PL_widesyscalls = TRUE;
- s++;
- return s;
case 'F':
PL_minus_F = TRUE;
PL_splitstr = savepv(s + 1);
@@ -2016,7 +1570,7 @@ Perl_moreswitches(pTHX_ char *s)
forbid_setid("-d");
s++;
if (*s == ':' || *s == '=') {
- my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
+ my_setenv("PERL5DB", form("use Devel::%s;", ++s));
s += strlen(s);
}
if (!PL_perldb) {
@@ -2025,7 +1579,6 @@ Perl_moreswitches(pTHX_ char *s)
}
return s;
case 'D':
- {
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
@@ -2041,15 +1594,11 @@ Perl_moreswitches(pTHX_ char *s)
}
PL_debug |= 0x80000000;
#else
- dTHR;
- if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING,
- "Recompile perl with -DDEBUGGING to use -D switch\n");
+ warn("Recompile perl with -DDEBUGGING to use -D switch\n");
for (s++; isALNUM(*s); s++) ;
#endif
/*SUPPRESS 530*/
return s;
- }
case 'h':
usage(PL_origargv[0]);
PerlProc_exit(0);
@@ -2072,23 +1621,14 @@ Perl_moreswitches(pTHX_ char *s)
++s;
if (*s) {
char *e, *p;
- 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, TRUE);
- Safefree(e);
- s = p;
- if (*s == '-')
- s++;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ Safefree(p);
+ s = e;
}
else
- Perl_croak(aTHX_ "No directory specified for -I");
+ croak("No space allowed after -I");
return s;
case 'l':
PL_minus_l = TRUE;
@@ -2098,7 +1638,7 @@ Perl_moreswitches(pTHX_ char *s)
if (isDIGIT(*s)) {
PL_ors = savepv("\n");
PL_orslen = 1;
- *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
+ *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
s += numlen;
}
else {
@@ -2131,7 +1671,7 @@ Perl_moreswitches(pTHX_ char *s)
sv_catpv(sv, start);
if (*(start-1) == 'm') {
if (*s != '\0')
- Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
+ croak("Can't use '%c' after -mname", *s);
sv_catpv( sv, " ()");
}
} else {
@@ -2141,12 +1681,12 @@ Perl_moreswitches(pTHX_ char *s)
sv_catpv(sv, "})");
}
s += strlen(s);
- if (!PL_preambleav)
+ if (PL_preambleav == NULL)
PL_preambleav = newAV();
av_push(PL_preambleav, sv);
}
else
- Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
+ croak("No space allowed after -%c", *(s-1));
return s;
case 'n':
PL_minus_n = TRUE;
@@ -2163,7 +1703,7 @@ Perl_moreswitches(pTHX_ char *s)
return s;
case 'T':
if (!PL_tainting)
- Perl_croak(aTHX_ "Too late for \"-T\" option");
+ croak("Too late for \"-T\" option");
s++;
return s;
case 'u':
@@ -2175,52 +1715,48 @@ Perl_moreswitches(pTHX_ char *s)
s++;
return s;
case 'v':
- printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
- PL_patchlevel, ARCHNAME));
+#if defined(SUBVERSION) && SUBVERSION > 0
+ printf("\nThis is perl, version 5.%03d_%02d built for %s",
+ PATCHLEVEL, SUBVERSION, ARCHNAME);
+#else
+ printf("\nThis is perl, version %s built for %s",
+ PL_patchlevel, ARCHNAME);
+#endif
#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" : "");
+ LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- printf("\n\nCopyright 1987-2000, Larry Wall\n");
+ printf("\n\nCopyright 1987-1999, Larry Wall\n");
#ifdef MSDOS
printf("\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");
+ printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\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");
+ "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
printf("atariST series port, ++jrb bammi@cadence.com\n");
#endif
#ifdef __BEOS__
- printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
+ printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
#endif
#ifdef MPE
- printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
+ printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
#endif
#ifdef OEMVS
- printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
#endif
#ifdef __VOS__
printf("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");
-#endif
-#ifdef POSIX_BC
- printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\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");
+ printf("MiNT port by Guido Flohr, 1997\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
@@ -2233,18 +1769,7 @@ 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");
PerlProc_exit(0);
case 'w':
- if (! (PL_dowarn & G_WARN_ALL_MASK))
- PL_dowarn |= G_WARN_ON;
- s++;
- return s;
- case 'W':
- PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
- PL_compiling.cop_warnings = pWARN_ALL ;
- s++;
- return s;
- case 'X':
- PL_dowarn = G_WARN_ALL_OFF;
- PL_compiling.cop_warnings = pWARN_NONE ;
+ PL_dowarn = TRUE;
s++;
return s;
case '*':
@@ -2269,7 +1794,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
return s+1;
/* FALL THROUGH */
default:
- Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
+ croak("Can't emulate -%.1s on #! line",s);
}
return Nullch;
}
@@ -2280,7 +1805,7 @@ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
void
-Perl_my_unexec(pTHX)
+my_unexec(void)
{
#ifdef UNEXEC
SV* prog;
@@ -2308,7 +1833,7 @@ Perl_my_unexec(pTHX)
/* initialize curinterp */
STATIC void
-S_init_interp(pTHX)
+init_interp(void)
{
#ifdef PERL_OBJECT /* XXX kludge */
@@ -2319,7 +1844,7 @@ S_init_interp(pTHX)
PL_curcop = &PL_compiling;\
PL_curcopdb = NULL; \
PL_dbargs = 0; \
- PL_dumpindent = 4; \
+ PL_dlmax = 128; \
PL_laststatval = -1; \
PL_laststype = OP_STAT; \
PL_maxscream = -1; \
@@ -2328,6 +1853,7 @@ S_init_interp(pTHX)
PL_tmps_floor = -1; \
PL_tmps_ix = -1; \
PL_op_mask = NULL; \
+ PL_dlmax = 128; \
PL_laststatval = -1; \
PL_laststype = OP_STAT; \
PL_mess_sv = Nullsv; \
@@ -2341,36 +1867,22 @@ S_init_interp(pTHX)
PL_profiledata = NULL; \
PL_rsfp = Nullfp; \
PL_rsfp_filters = Nullav; \
- PL_dirty = FALSE; \
} STMT_END
I_REINIT;
#else
# ifdef MULTIPLICITY
# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
-# if defined(PERL_IMPLICIT_CONTEXT)
-# if defined(USE_THREADS)
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# else /* !USE_THREADS */
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
-# endif /* USE_THREADS */
-# else
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# endif
+# define PERLVARI(var,type,init) PL_curinterp->var = init;
+# define PERLVARIC(var,type,init) PL_curinterp->var = init;
# include "intrpvar.h"
# ifndef USE_THREADS
# include "thrdvar.h"
# endif
# undef PERLVAR
-# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# else
+# else
# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
@@ -2378,7 +1890,6 @@ S_init_interp(pTHX)
# include "thrdvar.h"
# endif
# undef PERLVAR
-# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
# endif
@@ -2387,7 +1898,7 @@ S_init_interp(pTHX)
}
STATIC void
-S_init_main_stash(pTHX)
+init_main_stash(void)
{
dTHR;
GV *gv;
@@ -2403,7 +1914,7 @@ S_init_main_stash(pTHX)
hv_ksplit(PL_strtab, 512);
PL_curstash = PL_defstash = newHV();
- PL_curstname = newSVpvn("main",4);
+ PL_curstname = newSVpv("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
@@ -2418,21 +1929,22 @@ S_init_main_stash(pTHX)
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
- (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
+ (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
sv_setpvn(ERRSV, "", 0);
PL_curstash = PL_defstash;
- CopSTASH_set(&PL_compiling, PL_defstash);
+ PL_compiling.cop_stash = 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. */
- sv_setpvn(get_sv("/", TRUE), "\n", 1);
+ sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
}
STATIC void
-S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
+open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
dTHR;
+ register char *s;
*fdscript = -1;
@@ -2456,7 +1968,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
}
}
- CopFILE_set(PL_curcop, PL_origfilename);
+ PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
if (strEQ(PL_origfilename,"-"))
scriptname = "";
if (*fdscript >= 0) {
@@ -2468,18 +1980,18 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
}
else if (PL_preprocess) {
char *cpp_cfg = CPPSTDIN;
- SV *cpp = newSVpvn("",0);
+ SV *cpp = newSVpv("",0);
SV *cmd = NEWSV(0,0);
if (strEQ(cpp_cfg, "cppstdin"))
- Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
+ sv_catpvf(cpp, "%s/", BIN_EXP);
sv_catpv(cpp, cpp_cfg);
- sv_catpvn(sv, "-I", 2);
+ sv_catpv(sv,"-I");
sv_catpv(sv,PRIVLIB_EXP);
#ifdef MSDOS
- Perl_sv_setpvf(aTHX_ cmd, "\
+ sv_setpvf(cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
-e \"/^#[ ]*define[ ]/b\" \
@@ -2491,11 +2003,10 @@ sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*undef[ ]/b\" \
-e \"/^#[ ]*endif/b\" \
-e \"s/^#.*//\" \
- %s | %"SVf" -C %"SVf" %s",
+ %s | %_ -C %_ %s",
(PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
-# ifdef __OPEN_VM
- Perl_sv_setpvf(aTHX_ cmd, "\
+ sv_setpvf(cmd, "\
%s %s -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
@@ -2507,22 +2018,7 @@ sed %s -e \"/^[^#]/b\" \
-e '/^#[ ]*undef[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
- %s | %"SVf" %"SVf" %s",
-# else
- Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ ]*include[ ]/b' \
- -e '/^#[ ]*define[ ]/b' \
- -e '/^#[ ]*if[ ]/b' \
- -e '/^#[ ]*ifdef[ ]/b' \
- -e '/^#[ ]*ifndef[ ]/b' \
- -e '/^#[ ]*else/b' \
- -e '/^#[ ]*elif[ ]/b' \
- -e '/^#[ ]*undef[ ]/b' \
- -e '/^#[ ]*endif/b' \
- -e 's/^[ ]*#.*//' \
- %s | %"SVf" -C %"SVf" %s",
-# endif
+ %s | %_ -C %_ %s",
#ifdef LOC_SED
LOC_SED,
#else
@@ -2548,7 +2044,7 @@ sed %s -e \"/^[^#]/b\" \
#endif
#endif
if (PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
+ croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
@@ -2570,42 +2066,31 @@ sed %s -e \"/^[^#]/b\" \
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
if (PL_euid &&
- PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
+ PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
PL_statbuf.st_mode & (S_ISUID|S_ISGID))
{
/* try again */
- 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");
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+ croak("Can't do setuid\n");
}
#endif
#endif
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
+ croak("Can't open perl script \"%s\": %s\n",
+ SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
}
}
-/* Mention
- * I_SYSSTATVFS HAS_FSTATVFS
- * I_SYSMOUNT
- * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
- * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
- * here so that metaconfig picks them up. */
-
#ifdef IAMSUID
-STATIC int
-S_fd_on_nosuid_fs(pTHX_ int fd)
+static int
+fd_on_nosuid_fs(int fd)
{
- int check_okay = 0; /* able to do all the required sys/libcalls */
- int on_nosuid = 0; /* the fd is on a nosuid fs */
+ int on_nosuid = 0;
+ int check_okay = 0;
/*
- * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
+ * Preferred order: fstatvfs(), fstatfs(), getmntent().
* fstatvfs() is UNIX98.
- * fstatfs() is 4.3 BSD.
- * ustat()+getmnt() is pre-4.3 BSD.
- * getmntent() is O(number-of-mounted-filesystems) and can hang on
- * an irrelevant filesystem while trying to reach the right one.
+ * fstatfs() is BSD.
+ * getmntent() is O(number-of-mounted-filesystems) and can hang.
*/
# ifdef HAS_FSTATVFS
@@ -2613,45 +2098,24 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
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)
+# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
struct statfs stfs;
check_okay = fstatfs(fd, &stfs) == 0;
+# undef PERL_MOUNT_NOSUID
+# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
+# define PERL_MOUNT_NOSUID MNT_NOSUID
+# endif
+# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
+# define PERL_MOUNT_NOSUID MS_NOSUID
+# endif
+# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
+# define PERL_MOUNT_NOSUID M_NOSUID
+# endif
+# ifdef PERL_MOUNT_NOSUID
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)
- 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. */
- 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 */
+# endif
# else
-# if defined(HAS_GETMNTENT) && \
- defined(HAS_HASMNTOPT) && \
- defined(MNTOPT_NOSUID)
+# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
FILE *mtab = fopen("/etc/mtab", "r");
struct mntent *entry;
struct stat stb, fsb;
@@ -2671,22 +2135,20 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
}
if (mtab)
fclose(mtab);
-# endif /* getmntent+hasmntopt */
-# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
+# endif /* mntent */
+# endif /* statfs */
# endif /* statvfs */
-
if (!check_okay)
- Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
+ croak("Can't check filesystem of script \"%s\" for nosuid",
+ PL_origfilename);
return on_nosuid;
}
#endif /* IAMSUID */
STATIC void
-S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
+validate_suid(char *validarg, char *scriptname, int fdscript)
{
-#ifdef IAMSUID
int which;
-#endif
/* do we need to emulate setuid on scripts? */
@@ -2713,7 +2175,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
- Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
+ croak("Can't stat script \"%s\"",PL_origfilename);
if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
STRLEN n_a;
@@ -2728,8 +2190,8 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
- Perl_croak(aTHX_ "Permission denied");
+ if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
+ croak("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
* with a simple stat of the file, and then compare device and
@@ -2748,27 +2210,27 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
# endif
#endif
|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
- if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
- Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
+ croak("Can't swap uid and euid"); /* really paranoid */
+ if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
+ croak("Permission denied"); /* testing full pathname here */
#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
- Perl_croak(aTHX_ "Permission denied");
+ croak("Permission denied");
#endif
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,
+"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
+(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
+ (long)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);
+ SvPVX(GvSV(PL_curcop->cop_filegv)),
+ (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
(void)PerlProc_pclose(PL_rsfp);
}
- Perl_croak(aTHX_ "Permission denied\n");
+ croak("Permission denied\n");
}
if (
#ifdef HAS_SETREUID
@@ -2779,29 +2241,29 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
# endif
#endif
|| PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
- Perl_croak(aTHX_ "Can't reswap uid and euid");
+ croak("Can't reswap uid and euid");
if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
- Perl_croak(aTHX_ "Permission denied\n");
+ croak("Permission denied\n");
}
#endif /* HAS_SETREUID */
#endif /* IAMSUID */
if (!S_ISREG(PL_statbuf.st_mode))
- Perl_croak(aTHX_ "Permission denied");
+ croak("Permission denied");
if (PL_statbuf.st_mode & S_IWOTH)
- Perl_croak(aTHX_ "Setuid/gid script is writable by world");
+ croak("Setuid/gid script is writable by world");
PL_doswitches = FALSE; /* -s is insecure in suid */
- CopLINE_inc(PL_curcop);
+ PL_curcop->cop_line++;
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");
+ croak("No #! line");
s = SvPV(PL_linestr,n_a)+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
(isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
- Perl_croak(aTHX_ "Not a perl script");
+ croak("Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
* #! arg must be what we saw above. They can invoke it by
@@ -2811,13 +2273,13 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
len = strlen(validarg);
if (strEQ(validarg," PHOOEY ") ||
strnNE(s,validarg,len) || !isSPACE(s[len]))
- Perl_croak(aTHX_ "Args must match #! line");
+ croak("Args must match #! line");
#ifndef IAMSUID
if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
PL_euid == PL_statbuf.st_uid)
if (!PL_do_undump)
- Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+ croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* IAMSUID */
@@ -2825,11 +2287,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
(void)PerlIO_close(PL_rsfp);
#ifndef IAMSUID
/* try again */
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
- (int)PERL_REVISION, (int)PERL_VERSION,
- (int)PERL_SUBVERSION), PL_origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
#endif
- Perl_croak(aTHX_ "Can't do setuid\n");
+ croak("Can't do setuid\n");
}
if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
@@ -2847,7 +2307,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif
#endif
if (PerlProc_getegid() != PL_statbuf.st_gid)
- Perl_croak(aTHX_ "Can't do setegid!\n");
+ croak("Can't do setegid!\n");
}
if (PL_statbuf.st_mode & S_ISUID) {
if (PL_statbuf.st_uid != PL_euid)
@@ -2865,7 +2325,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif
#endif
if (PerlProc_geteuid() != PL_statbuf.st_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
+ croak("Can't do seteuid!\n");
}
else if (PL_uid) { /* oops, mustn't run as root */
#ifdef HAS_SETEUID
@@ -2882,19 +2342,19 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif
#endif
if (PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
+ croak("Can't do seteuid!\n");
}
init_ids();
if (!cando(S_IXUSR,TRUE,&PL_statbuf))
- Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
+ croak("Permission denied\n"); /* they can't do this */
}
#ifdef IAMSUID
else if (PL_preprocess)
- Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
+ croak("-P not allowed for setuid/setgid script\n");
else if (fdscript >= 0)
- Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
+ croak("fd script not allowed in suidperl\n");
else
- Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
+ croak("Script is not setuid/setgid in suidperl\n");
/* We absolutely must clear out any saved ids here, so we */
/* exec the real perl, substituting fd script for scriptname. */
@@ -2903,16 +2363,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
if (!PL_origargv[which])
- Perl_croak(aTHX_ "Permission denied");
- PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
+ croak("Permission denied");
+ PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
PerlIO_fileno(PL_rsfp), PL_origargv[which]));
#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"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");
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
+ croak("Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
@@ -2924,7 +2382,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
(PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
)
if (!PL_do_undump)
- Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+ croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* not set-id, must be wrapped */
@@ -2933,7 +2391,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
}
STATIC void
-S_find_beginning(pTHX)
+find_beginning(void)
{
register char *s, *s2;
@@ -2942,7 +2400,7 @@ S_find_beginning(pTHX)
forbid_setid("-x");
while (PL_doextract) {
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
- Perl_croak(aTHX_ "No Perl script found in input\n");
+ croak("No Perl script found in input\n");
if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
@@ -2953,21 +2411,22 @@ S_find_beginning(pTHX)
while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
if (strnEQ(s2-4,"perl",4))
/*SUPPRESS 530*/
- while ((s = moreswitches(s)))
- ;
+ while (s = moreswitches(s)) ;
}
+ if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
+ croak("Can't chdir to %s",PL_cddir);
}
}
}
STATIC void
-S_init_ids(pTHX)
+init_ids(void)
{
- PL_uid = PerlProc_getuid();
- PL_euid = PerlProc_geteuid();
- PL_gid = PerlProc_getgid();
- PL_egid = PerlProc_getegid();
+ PL_uid = (int)PerlProc_getuid();
+ PL_euid = (int)PerlProc_geteuid();
+ PL_gid = (int)PerlProc_getgid();
+ PL_egid = (int)PerlProc_getegid();
#ifdef VMS
PL_uid |= PL_gid << 16;
PL_euid |= PL_egid << 16;
@@ -2976,34 +2435,31 @@ S_init_ids(pTHX)
}
STATIC void
-S_forbid_setid(pTHX_ char *s)
+forbid_setid(char *s)
{
if (PL_euid != PL_uid)
- Perl_croak(aTHX_ "No %s allowed while running setuid", s);
+ croak("No %s allowed while running setuid", s);
if (PL_egid != PL_gid)
- Perl_croak(aTHX_ "No %s allowed while running setgid", s);
+ croak("No %s allowed while running setgid", s);
}
-void
-Perl_init_debugger(pTHX)
+STATIC void
+init_debugger(void)
{
dTHR;
- HV *ostash = PL_curstash;
-
PL_curstash = PL_debstash;
PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(PL_dbargs);
PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
- sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_curstash = ostash;
+ PL_curstash = PL_defstash;
}
#ifndef STRESS_REALLOC
@@ -3013,7 +2469,7 @@ Perl_init_debugger(pTHX)
#endif
void
-Perl_init_stacks(pTHX)
+init_stacks(ARGSproto)
{
/* start with 128-item stack and 8K cxstack */
PL_curstackinfo = new_stackinfo(REASONABLE(128),
@@ -3035,7 +2491,7 @@ Perl_init_stacks(pTHX)
PL_markstack_ptr = PL_markstack;
PL_markstack_max = PL_markstack + REASONABLE(32);
- SET_MARK_OFFSET;
+ SET_MARKBASE;
New(54,PL_scopestack,REASONABLE(32),I32);
PL_scopestack_ix = 0;
@@ -3053,7 +2509,7 @@ Perl_init_stacks(pTHX)
#undef REASONABLE
STATIC void
-S_nuke_stacks(pTHX)
+nuke_stacks(void)
{
dTHR;
while (PL_curstackinfo->si_next)
@@ -3070,6 +2526,10 @@ S_nuke_stacks(pTHX)
Safefree(PL_scopestack);
Safefree(PL_savestack);
Safefree(PL_retstack);
+ DEBUG( {
+ Safefree(PL_debname);
+ Safefree(PL_debdelim);
+ } )
}
#ifndef PERL_OBJECT
@@ -3077,7 +2537,7 @@ static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
#endif
STATIC void
-S_init_lexer(pTHX)
+init_lexer(void)
{
#ifdef PERL_OBJECT
PerlIO *tmpfp;
@@ -3086,41 +2546,38 @@ S_init_lexer(pTHX)
PL_rsfp = Nullfp;
lex_start(PL_linestr);
PL_rsfp = tmpfp;
- PL_subname = newSVpvn("main",4);
+ PL_subname = newSVpv("main",4);
}
STATIC void
-S_init_predump_symbols(pTHX)
+init_predump_symbols(void)
{
dTHR;
GV *tmpgv;
- IO *io;
+ GV *othergv;
- sv_setpvn(get_sv("\"", TRUE), " ", 1);
+ sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(PL_stdingv);
- io = GvIOp(PL_stdingv);
- IoIFP(io) = PerlIO_stdin();
+ IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
GvMULTI_on(tmpgv);
- io = GvIOp(tmpgv);
- IoOFP(io) = IoIFP(io) = PerlIO_stdout();
+ IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
setdefout(tmpgv);
tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
- PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
- GvMULTI_on(PL_stderrgv);
- io = GvIOp(PL_stderrgv);
- IoOFP(io) = IoIFP(io) = PerlIO_stderr();
+ othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
+ GvMULTI_on(othergv);
+ IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
PL_statname = NEWSV(66,0); /* last filename we did stat on */
@@ -3129,7 +2586,7 @@ S_init_predump_symbols(pTHX)
}
STATIC void
-S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+init_postdump_symbols(register int argc, register char **argv, register char **env)
{
dTHR;
char *s;
@@ -3141,11 +2598,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
for (; argc > 0 && **argv == '-'; argc--,argv++) {
if (!argv[0][1])
break;
- if (argv[0][1] == '-' && !argv[0][2]) {
+ if (argv[0][1] == '-') {
argc--,argv++;
break;
}
- if ((s = strchr(argv[0], '='))) {
+ if (s = strchr(argv[0], '=')) {
*s++ = '\0';
sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
}
@@ -3162,33 +2619,26 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
PL_formtarget = PL_bodytarget;
TAINT;
- if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
+ if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
sv_setpv(GvSV(tmpgv),PL_origfilename);
magicname("0", "0", 1);
}
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
-#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname());
-#else
+ if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
-#endif
- if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
+ if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
GvMULTI_on(PL_argvgv);
(void)gv_AVadd(PL_argvgv);
av_clear(GvAVn(PL_argvgv));
for (; argc > 0; argc--,argv++) {
- SV *sv = newSVpv(argv[0],0);
- av_push(GvAVn(PL_argvgv),sv);
- if (PL_widesyscalls)
- sv_utf8_upgrade(sv);
+ av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
}
}
- if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
+ if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
HV *hv;
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 */
+#ifndef VMS /* 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
@@ -3219,21 +2669,21 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
#endif
}
TAINT_NOT;
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
- sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
+ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
}
STATIC void
-S_init_perllib(pTHX)
+init_perllib(void)
{
char *s;
if (!PL_tainting) {
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE, TRUE);
+ incpush(s, TRUE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), 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
@@ -3242,73 +2692,43 @@ S_init_perllib(pTHX)
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
#endif /* VMS */
}
/* Use the ~-expanded versions of APPLLIB (undocumented),
- ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
+ ARCHLIB PRIVLIB SITEARCH and SITELIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE);
+ incpush(ARCHLIB_EXP, FALSE);
#endif
#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, FALSE);
+ incpush(PRIVLIB_EXP, TRUE);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE);
+ incpush(PRIVLIB_EXP, 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
+ incpush(SITEARCH_EXP, FALSE);
#endif
-
#ifdef SITELIB_EXP
-# 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
-
-#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
+#if defined(WIN32)
+ incpush(SITELIB_EXP, TRUE);
+#else
+ incpush(SITELIB_EXP, FALSE);
#endif
-
-#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
- incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
#endif
-
if (!PL_tainting)
- incpush(".", FALSE, FALSE);
+ incpush(".", FALSE);
}
#if defined(DOSISH)
@@ -3325,15 +2745,26 @@ S_init_perllib(pTHX)
#endif
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
+incpush(char *p, int addsubdirs)
{
SV *subdir = Nullsv;
- if (!p || !*p)
+ if (!p)
return;
- if (addsubdirs || addoldvers) {
+ 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);
+ sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
+#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 */
@@ -3344,7 +2775,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
/* skip any consecutive separators */
while ( *p == PERLLIB_SEP ) {
/* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
+ /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
p++;
}
@@ -3362,12 +2793,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
*/
- if (addsubdirs || addoldvers) {
-#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
+ if (addsubdirs) {
struct stat tmpstatbuf;
#ifdef VMS
char *unix;
@@ -3379,46 +2805,25 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
sv_usepvn(libdir,unix,len);
}
else
- PerlIO_printf(Perl_error_log,
+ PerlIO_printf(PerlIO_stderr(),
"Failed to unixify @INC element \"%s\"\n",
SvPV(libdir,len));
#endif
- if (addsubdirs) {
- /* .../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));
- }
-
-#ifdef PERL_INC_VERSION_LIST
- if (addoldvers) {
- 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
+ /* .../archname/version if -d .../archname/version/auto */
+ sv_setsv(subdir, libdir);
+ sv_catpv(subdir, PL_archpat_auto);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+
+ /* .../archname if -d .../archname/auto */
+ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
+ strlen(PL_patchlevel) + 1, "", 0);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
}
/* finally push this lib directory on the end of @INC */
@@ -3428,20 +2833,18 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
#ifdef USE_THREADS
STATIC struct perl_thread *
-S_init_main_thread(pTHX)
+init_main_thread()
{
-#if !defined(PERL_IMPLICIT_CONTEXT)
struct perl_thread *thr;
-#endif
XPV *xpv;
Newz(53, thr, 1, struct perl_thread);
PL_curcop = &PL_compiling;
- thr->interp = PERL_GET_INTERP;
thr->cvcache = newHV();
thr->threadsv = newAV();
/* thr->threadsvp is set when find_threadsv is called */
thr->specific = newAV();
+ thr->errhv = newHV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
/* Handcraft thrsv similarly to mess_sv */
@@ -3456,7 +2859,6 @@ S_init_main_thread(pTHX)
*SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
thr->oursv = PL_thrsv;
PL_chopset = " \n-";
- PL_dumpindent = 4;
MUTEX_LOCK(&PL_threads_mutex);
PL_nthreads++;
@@ -3466,7 +2868,7 @@ S_init_main_thread(pTHX)
MUTEX_UNLOCK(&PL_threads_mutex);
#ifdef HAVE_THREAD_INTERN
- Perl_init_thread_intern(thr);
+ init_thread_intern(thr);
#endif
#ifdef SET_THREAD_SELF
@@ -3474,7 +2876,7 @@ S_init_main_thread(pTHX)
#else
thr->self = pthread_self();
#endif /* SET_THREAD_SELF */
- PERL_SET_THX(thr);
+ SET_THR(thr);
/*
* These must come after the SET_THR because sv_setpvn does
@@ -3487,15 +2889,12 @@ S_init_main_thread(pTHX)
sv_upgrade(PL_bodytarget, SVt_PVFM);
sv_setpvn(PL_bodytarget, "", 0);
PL_formtarget = PL_bodytarget;
- thr->errsv = newSVpvn("", 0);
+ thr->errsv = newSVpv("", 0);
(void) find_threadsv("@"); /* Ensure $@ is initialised early */
PL_maxscream = -1;
- PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
- PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
- PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
- PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
- PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
+ PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
+ PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
PL_regindent = 0;
PL_reginterp_cnt = 0;
@@ -3504,47 +2903,38 @@ S_init_main_thread(pTHX)
#endif /* USE_THREADS */
void
-Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
+call_list(I32 oldscope, AV *paramList)
{
dTHR;
- SV *atsv;
- line_t oldline = CopLINE(PL_curcop);
- CV *cv;
+ line_t oldline = PL_curcop->cop_line;
STRLEN len;
- int ret;
dJMPENV;
+ int ret;
while (AvFILL(paramList) >= 0) {
- cv = (CV*)av_shift(paramList);
+ CV *cv = (CV*)av_shift(paramList);
+
SAVEFREESV(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) {
- STRLEN n_a;
- PL_curcop = &PL_compiling;
- 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_checkav ? "CHECK"
- : paramList == PL_initav ? "INIT"
- : "END");
- while (PL_scopestack_ix > oldscope)
- LEAVE;
- JMPENV_POP;
- Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
+ case 0: {
+ SV* atsv = ERRSV;
+ PUSHMARK(PL_stack_sp);
+ perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
+ (void)SvPV(atsv, len);
+ if (len) {
+ JMPENV_POP;
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ if (paramList == PL_beginav)
+ sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ else
+ sv_catpv(atsv, "END failed--cleanup aborted");
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ croak("%s", SvPVX(atsv));
+ }
}
break;
case 1:
@@ -3556,53 +2946,36 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- PL_curcop = &PL_compiling;
- CopLINE_set(PL_curcop, oldline);
+ if (PL_endav)
+ call_list(oldscope, PL_endav);
JMPENV_POP;
- if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ if (PL_statusvalue) {
if (paramList == PL_beginav)
- Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
+ croak("BEGIN failed--compilation aborted");
else
- Perl_croak(aTHX_ "%s failed--call queue aborted",
- paramList == PL_checkav ? "CHECK"
- : paramList == PL_initav ? "INIT"
- : "END");
+ croak("END failed--cleanup aborted");
}
my_exit_jump();
/* NOTREACHED */
case 3:
- if (PL_restartop) {
- PL_curcop = &PL_compiling;
- CopLINE_set(PL_curcop, oldline);
- JMPENV_JUMP(3);
+ if (!PL_restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ FREETMPS;
+ break;
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
- FREETMPS;
- break;
+ JMPENV_POP;
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ JMPENV_JUMP(3);
}
JMPENV_POP;
}
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vcall_list_body(pTHX_ va_list args)
-{
- 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;
-}
-
void
-Perl_my_exit(pTHX_ U32 status)
+my_exit(U32 status)
{
dTHR;
@@ -3623,7 +2996,7 @@ Perl_my_exit(pTHX_ U32 status)
}
void
-Perl_my_failure_exit(pTHX)
+my_failure_exit(void)
{
#ifdef VMS
if (vaxc$errno & 1) {
@@ -3652,9 +3025,9 @@ Perl_my_failure_exit(pTHX)
}
STATIC void
-S_my_exit_jump(pTHX)
+my_exit_jump(void)
{
- dTHR;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
@@ -3676,11 +3049,17 @@ S_my_exit_jump(pTHX)
}
#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif /* PERL_OBJECT */
+
#include "XSUB.h"
-#endif
static I32
-read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
+#ifdef PERL_OBJECT
+read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
+#else
+read_e_script(int idx, SV *buf_sv, int maxlen)
+#endif
{
char *p, *nl;
p = SvPVX(PL_e_script);
@@ -3694,3 +3073,5 @@ read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
sv_chop(PL_e_script, nl);
return 1;
}
+
+
diff --git a/contrib/perl5/perl.h b/contrib/perl5/perl.h
index 2f302189782f..b463595ad129 100644
--- a/contrib/perl5/perl.h
+++ b/contrib/perl5/perl.h
@@ -1,6 +1,6 @@
/* perl.h
*
- * Copyright (c) 1987-2000, Larry Wall
+ * Copyright (c) 1987-1999, 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.
@@ -8,6 +8,7 @@
*/
#ifndef H_PERL
#define H_PERL 1
+#define OVERLOAD
#ifdef PERL_FOR_X2P
/*
@@ -15,68 +16,14 @@
* Above symbol is defined via -D in 'x2p/Makefile.SH'
* Decouple x2p stuff from some of perls more extreme eccentricities.
*/
+#undef EMBED
+#undef NO_EMBED
+#define NO_EMBED
#undef MULTIPLICITY
#undef USE_STDIO
#define USE_STDIO
#endif /* PERL_FOR_X2P */
-#define VOIDUSED 1
-#include "config.h"
-
-#if defined(USE_ITHREADS) && defined(USE_5005THREADS)
-# include "error: USE_ITHREADS and USE_5005THREADS are incompatible"
-#endif
-
-/* XXX This next guard can disappear if the sources are revised
- to use USE_5005THREADS throughout. -- A.D 1/6/2000
-*/
-#if defined(USE_ITHREADS) && defined(USE_THREADS)
-# include "error: USE_ITHREADS and USE_THREADS are incompatible"
-#endif
-
-/* See L<perlguts/"The Perl API"> for detailed notes on
- * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */
-
-#ifdef USE_ITHREADS
-# if !defined(MULTIPLICITY) && !defined(PERL_OBJECT)
-# define MULTIPLICITY
-# endif
-#endif
-
-#ifdef USE_THREADS
-# ifndef PERL_IMPLICIT_CONTEXT
-# define PERL_IMPLICIT_CONTEXT
-# endif
-#endif
-
-#if defined(MULTIPLICITY)
-# ifndef PERL_IMPLICIT_CONTEXT
-# define PERL_IMPLICIT_CONTEXT
-# endif
-#endif
-
-#ifdef PERL_CAPI
-# undef PERL_OBJECT
-# ifndef MULTIPLICITY
-# define MULTIPLICITY
-# endif
-# ifndef PERL_IMPLICIT_CONTEXT
-# define PERL_IMPLICIT_CONTEXT
-# endif
-# ifndef PERL_IMPLICIT_SYS
-# define PERL_IMPLICIT_SYS
-# endif
-#endif
-
-#ifdef PERL_OBJECT
-# ifndef PERL_IMPLICIT_CONTEXT
-# define PERL_IMPLICIT_CONTEXT
-# endif
-# ifndef PERL_IMPLICIT_SYS
-# define PERL_IMPLICIT_SYS
-# endif
-#endif
-
#ifdef PERL_OBJECT
/* PERL_OBJECT explained - DickH and DougL @ ActiveState.com
@@ -100,8 +47,8 @@ the perl interpreter.
| Perl Host |
+-----------+
^
- |
- v
+ |
+ v
+-----------+ +-----------+
| Perl Core |<->| Extension |
+-----------+ +-----------+ ...
@@ -114,9 +61,9 @@ PERL CORE
variables or functions needed are made member functions
3. all writable static variables are made member variables
4. all global variables and functions are defined as:
- #define var CPerlObj::PL_var
+ #define var CPerlObj::Perl_var
#define func CPerlObj::Perl_func
- * these are in embed.h
+ * these are in objpp.h
This necessitated renaming some local variables and functions that
had the same name as a global variable or function. This was
probably a _good_ thing anyway.
@@ -126,7 +73,7 @@ EXTENSIONS
1. Access to global variables and perl functions is through a
pointer to the PERL_OBJECT. This pointer type is CPerlObj*. This is
made transparent to extension developers by the following macros:
- #define var pPerl->PL_var
+ #define var pPerl->Perl_var
#define func pPerl->Perl_func
* these are done in objXSUB.h
This requires that the extension be compiled as C++, which means
@@ -155,102 +102,41 @@ functions are now member functions of the PERL_OBJECT.
class CPerlObj;
#define STATIC
-#define CPERLscope(x) CPerlObj::x
-#define CALL_FPTR(fptr) (aTHXo->*fptr)
-
-#define pTHXo CPerlObj *pPerl
-#define pTHXo_ pTHXo,
-#define aTHXo this
-#define aTHXo_ this,
-#define PERL_OBJECT_THIS aTHXo
-#define PERL_OBJECT_THIS_ aTHXo_
-#define dTHXoa(a) pTHXo = a
-#define dTHXo dTHXoa(PERL_GET_THX)
-
-#define pTHXx void
-#define pTHXx_
-#define aTHXx
-#define aTHXx_
+#define CPERLscope(x) CPerlObj::x
+#define CPERLproto CPerlObj *
+#define _CPERLproto ,CPERLproto
+#define CPERLarg CPerlObj *pPerl
+#define CPERLarg_ CPERLarg,
+#define _CPERLarg ,CPERLarg
+#define PERL_OBJECT_THIS this
+#define _PERL_OBJECT_THIS ,this
+#define PERL_OBJECT_THIS_ this,
+#define CALLRUNOPS (this->*PL_runops)
+#define CALLREGCOMP (this->*PL_regcompp)
+#define CALLREGEXEC (this->*PL_regexecp)
#else /* !PERL_OBJECT */
-#ifdef PERL_IMPLICIT_CONTEXT
-# ifdef USE_THREADS
-struct perl_thread;
-# define pTHX register struct perl_thread *thr
-# define aTHX thr
-# define dTHR dNOOP
-# else
-# ifndef MULTIPLICITY
-# define MULTIPLICITY
-# endif
-# define pTHX register PerlInterpreter *my_perl
-# define aTHX my_perl
-# endif
-# define dTHXa(a) pTHX = a
-# define dTHX dTHXa(PERL_GET_THX)
-# define pTHX_ pTHX,
-# define aTHX_ aTHX,
-# define pTHX_1 2
-# define pTHX_2 3
-# define pTHX_3 4
-# define pTHX_4 5
-#endif
-
#define STATIC static
#define CPERLscope(x) x
+#define CPERLproto
+#define _CPERLproto
#define CPERLarg void
#define CPERLarg_
#define _CPERLarg
#define PERL_OBJECT_THIS
#define _PERL_OBJECT_THIS
#define PERL_OBJECT_THIS_
-#define CALL_FPTR(fptr) (*fptr)
+#define CALLRUNOPS PL_runops
+#define CALLREGCOMP (*PL_regcompp)
+#define CALLREGEXEC (*PL_regexecp)
#endif /* PERL_OBJECT */
-#define CALLRUNOPS CALL_FPTR(PL_runops)
-#define CALLREGCOMP CALL_FPTR(PL_regcompp)
-#define CALLREGEXEC CALL_FPTR(PL_regexecp)
-#define CALLREG_INTUIT_START CALL_FPTR(PL_regint_start)
-#define CALLREG_INTUIT_STRING CALL_FPTR(PL_regint_string)
-#define CALLREGFREE CALL_FPTR(PL_regfree)
-
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-# define CALLPROTECT CALL_FPTR(PL_protect)
-#endif
-
-#define NOOP (void)0
-#define dNOOP extern int Perl___notused
-
-#ifndef pTHX
-# define pTHX void
-# define pTHX_
-# define aTHX
-# define aTHX_
-# define dTHXa(a) dNOOP
-# define dTHX dNOOP
-# define pTHX_1 1
-# define pTHX_2 2
-# define pTHX_3 3
-# define pTHX_4 4
-#endif
-
-#ifndef pTHXo
-# define pTHXo pTHX
-# define pTHXo_ pTHX_
-# define aTHXo aTHX
-# define aTHXo_ aTHX_
-# define dTHXo dTHX
-#endif
+#define VOIDUSED 1
+#include "config.h"
-#ifndef pTHXx
-# define pTHXx register PerlInterpreter *my_perl
-# define pTHXx_ pTHXx,
-# define aTHXx my_perl
-# define aTHXx_ aTHXx,
-# define dTHXx dTHX
-#endif
+#include "embed.h"
#undef START_EXTERN_C
#undef END_EXTERN_C
@@ -262,14 +148,18 @@ struct perl_thread;
#else
# define START_EXTERN_C
# define END_EXTERN_C
-# define EXTERN_C extern
+# define EXTERN_C
#endif
#ifdef OP_IN_REGISTER
# ifdef __GNUC__
# define stringify_immed(s) #s
# define stringify(s) stringify_immed(s)
+#ifdef EMBED
register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
+#else
+register struct op *op asm(stringify(OP_IN_REGISTER));
+#endif
# endif
#endif
@@ -296,7 +186,8 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
# endif
#endif
-#define WITH_THX(s) STMT_START { dTHX; s; } STMT_END
+#define NOOP (void)0
+
#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END
/*
@@ -337,11 +228,11 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
#define DOSISH 1
#endif
-#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) || defined( EPOC)
+#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
# define STANDARD_C 1
#endif
-#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX) || defined( EPOC) || defined(__QNX__)
+#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX)
# define DONT_DECLARE_STD 1
#endif
@@ -411,14 +302,6 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
# endif
#endif
-/* HP-UX 10.X CMA (Common Multithreaded Architecure) insists that
- pthread.h must be included before all other header files.
-*/
-#if (defined(USE_THREADS) || defined(USE_ITHREADS)) \
- && defined(PTHREAD_H_FIRST) && defined(I_PTHREAD)
-# include <pthread.h>
-#endif
-
#ifndef _TYPES_ /* If types.h defines this it's easy. */
# ifndef major /* Does everyone's types.h define this? */
# include <sys/types.h>
@@ -439,17 +322,15 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
# endif
#endif
+#include "iperlsys.h"
+
#ifdef USE_NEXT_CTYPE
-#if NX_CURRENT_COMPILER_RELEASE >= 500
-# include <bsd/ctypes.h>
-#else
-# if NX_CURRENT_COMPILER_RELEASE >= 400
-# include <objc/NXCType.h>
-# else /* NX_CURRENT_COMPILER_RELEASE < 400 */
-# include <appkit/NXCType.h>
-# endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
-#endif /* NX_CURRENT_COMPILER_RELEASE >= 500 */
+#if NX_CURRENT_COMPILER_RELEASE >= 400
+#include <objc/NXCType.h>
+#else /* NX_CURRENT_COMPILER_RELEASE < 400 */
+#include <appkit/NXCType.h>
+#endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
#else /* !USE_NEXT_CTYPE */
#include <ctype.h>
@@ -486,21 +367,69 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
# include <sys/param.h>
#endif
+/* needed for IAMSUID case for 4.4BSD systems
+ * XXX there should probably be a Configure variable
+ */
+
+#ifdef I_SYS_PARAM
+#if (defined (BSD) && (BSD >= 199306))
+# include <sys/mount.h>
+#endif /* !BSD */
+#endif /* !I_SYS_PARAM */
/* Use all the "standard" definitions? */
#if defined(STANDARD_C) && defined(I_STDLIB)
# include <stdlib.h>
#endif
-#ifdef PERL_MICRO /* Last chance to export Perl_my_swap */
-# define MYSWAP
-#endif
+#define MEM_SIZE Size_t
+
+/* This comes after <stdlib.h> so we don't try to change the standard
+ * library prototypes; we'll use our own in proto.h instead. */
+
+#ifdef MYMALLOC
-#if !defined(PERL_FOR_X2P) && !defined(WIN32)
-# include "embed.h"
+# ifdef HIDEMYMALLOC
+# define malloc Mymalloc
+# define calloc Mycalloc
+# define realloc Myrealloc
+# define free Myfree
+Malloc_t Mymalloc _((MEM_SIZE nbytes));
+Malloc_t Mycalloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t Myrealloc _((Malloc_t where, MEM_SIZE nbytes));
+Free_t Myfree _((Malloc_t where));
+# endif
+# ifdef EMBEDMYMALLOC
+# define malloc Perl_malloc
+# define calloc Perl_calloc
+# define realloc Perl_realloc
+/* VMS' external symbols are case-insensitive, and there's already a */
+/* perl_free in perl.h */
+#ifdef VMS
+# define free Perl_myfree
+#else
+# define free Perl_free
+#endif
+Malloc_t Perl_malloc _((MEM_SIZE nbytes));
+Malloc_t Perl_calloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t Perl_realloc _((Malloc_t where, MEM_SIZE nbytes));
+#ifdef VMS
+Free_t Perl_myfree _((Malloc_t where));
+#else
+Free_t Perl_free _((Malloc_t where));
#endif
+# endif
-#define MEM_SIZE Size_t
+# undef safemalloc
+# undef safecalloc
+# undef saferealloc
+# undef safefree
+# define safemalloc malloc
+# define safecalloc calloc
+# define saferealloc realloc
+# define safefree free
+
+#endif /* MYMALLOC */
#if defined(STANDARD_C) && defined(I_STDDEF)
# include <stddef.h>
@@ -515,51 +444,6 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
# include <strings.h>
#endif
-/* This comes after <stdlib.h> so we don't try to change the standard
- * library prototypes; we'll use our own in proto.h instead. */
-
-#ifdef MYMALLOC
-# ifdef PERL_POLLUTE_MALLOC
-# ifndef PERL_EXTMALLOC_DEF
-# define Perl_malloc malloc
-# define Perl_calloc calloc
-# define Perl_realloc realloc
-# define Perl_mfree free
-# endif
-# else
-# define EMBEDMYMALLOC /* for compatibility */
-# endif
-Malloc_t Perl_malloc (MEM_SIZE nbytes);
-Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size);
-Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes);
-/* 'mfree' rather than 'free', since there is already a 'perl_free'
- * that causes clashes with case-insensitive linkers */
-Free_t Perl_mfree (Malloc_t where);
-
-typedef struct perl_mstats perl_mstats_t;
-
-struct perl_mstats {
- unsigned long *nfree;
- unsigned long *ntotal;
- long topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain;
- long total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains;
- long minbucket;
- /* Level 1 info */
- unsigned long *bucket_mem_size;
- unsigned long *bucket_available_size;
-};
-
-# define safemalloc Perl_malloc
-# define safecalloc Perl_calloc
-# define saferealloc Perl_realloc
-# define safefree Perl_mfree
-#else /* MYMALLOC */
-# define safemalloc safesysmalloc
-# define safecalloc safesyscalloc
-# define saferealloc safesysrealloc
-# define safefree safesysfree
-#endif /* MYMALLOC */
-
#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
#define strchr index
#define strrchr rindex
@@ -572,7 +456,7 @@ struct perl_mstats {
#ifdef HAS_MEMCPY
# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
# ifndef memcpy
- extern char * memcpy (char*, char*, int);
+ extern char * memcpy _((char*, char*, int));
# endif
# endif
#else
@@ -588,7 +472,7 @@ struct perl_mstats {
#ifdef HAS_MEMSET
# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
# ifndef memset
- extern char *memset (char*, int, int);
+ extern char *memset _((char*, int, int));
# endif
# endif
#else
@@ -614,7 +498,7 @@ struct perl_mstats {
#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP)
# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
# ifndef memcmp
- extern int memcmp (char*, char*, int);
+ extern int memcmp _((char*, char*, int));
# endif
# endif
# ifdef BUGGY_MSC
@@ -638,12 +522,6 @@ struct perl_mstats {
# endif
#endif
-#ifndef memchr
-# ifndef HAS_MEMCHR
-# define memchr(s,c,n) ninstr((char*)(s), ((char*)(s)) + n, &(c), &(c) + 1)
-# endif
-#endif
-
#ifndef HAS_BCMP
# ifndef bcmp
# define bcmp(s1,s2,l) memcmp(s1,s2,l)
@@ -727,30 +605,26 @@ struct perl_mstats {
#ifdef USE_THREADS
# define ERRSV (thr->errsv)
+# define ERRHV (thr->errhv)
# define DEFSV THREADSV(0)
# define SAVE_DEFSV save_threadsv(0)
#else
# define ERRSV GvSV(PL_errgv)
+# define ERRHV GvHV(PL_errgv)
# define DEFSV GvSV(PL_defgv)
# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
#endif /* USE_THREADS */
-#define ERRHV GvHV(PL_errgv) /* XXX unused, here for compatibility */
-
#ifndef errno
- extern int errno; /* ANSI allows errno to be an lvalue expr.
- * For example in multithreaded environments
- * something like this might happen:
- * extern int *_errno(void);
- * #define errno (*_errno()) */
+ extern int errno; /* ANSI allows errno to be an lvalue expr */
#endif
#ifdef HAS_STRERROR
# ifdef VMS
- char *strerror (int,...);
+ char *strerror _((int,...));
# else
#ifndef DONT_DECLARE_STD
- char *strerror (int);
+ char *strerror _((int));
#endif
# endif
# ifndef Strerror
@@ -793,8 +667,7 @@ struct perl_mstats {
/* Configure already sets Direntry_t */
#if defined(I_DIRENT)
# include <dirent.h>
- /* NeXT needs dirent + sys/dir.h */
-# if defined(I_SYS_DIR) && (defined(NeXT) || defined(__NeXT__))
+# if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */
# include <sys/dir.h>
# endif
#else
@@ -824,10 +697,6 @@ struct perl_mstats {
* in the face of half-implementations.)
*/
-#ifdef I_SYSMODE
-#include <sys/mode.h>
-#endif
-
#ifndef S_IFMT
# ifdef _S_IFMT
# define S_IFMT _S_IFMT
@@ -906,30 +775,12 @@ struct perl_mstats {
# define S_IWUSR 0200
# define S_IXUSR 0100
# endif
-#endif
-
-#ifndef S_IRGRP
-# ifdef S_IRUSR
-# define S_IRGRP (S_IRUSR>>3)
-# define S_IWGRP (S_IWUSR>>3)
-# define S_IXGRP (S_IXUSR>>3)
-# else
-# define S_IRGRP 0040
-# define S_IWGRP 0020
-# define S_IXGRP 0010
-# endif
-#endif
-
-#ifndef S_IROTH
-# ifdef S_IRUSR
-# define S_IROTH (S_IRUSR>>6)
-# define S_IWOTH (S_IWUSR>>6)
-# define S_IXOTH (S_IXUSR>>6)
-# else
-# define S_IROTH 0040
-# define S_IWOTH 0020
-# define S_IXOTH 0010
-# endif
+# define S_IRGRP (S_IRUSR>>3)
+# define S_IWGRP (S_IWUSR>>3)
+# define S_IXGRP (S_IXUSR>>3)
+# define S_IROTH (S_IRUSR>>6)
+# define S_IWOTH (S_IWUSR>>6)
+# define S_IXOTH (S_IXUSR>>6)
#endif
#ifndef S_ISUID
@@ -940,30 +791,6 @@ struct perl_mstats {
# define S_ISGID 02000
#endif
-#ifndef S_IRWXU
-# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR)
-#endif
-
-#ifndef S_IRWXG
-# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP)
-#endif
-
-#ifndef S_IRWXO
-# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH)
-#endif
-
-#ifndef S_IREAD
-# define S_IREAD S_IRUSR
-#endif
-
-#ifndef S_IWRITE
-# define S_IWRITE S_IWUSR
-#endif
-
-#ifndef S_IEXEC
-# define S_IEXEC S_IXUSR
-#endif
-
#ifdef ff_next
# undef ff_next
#endif
@@ -976,219 +803,55 @@ struct perl_mstats {
#undef UV
#endif
-/*
+/* XXX QUAD stuff is not currently supported on most systems.
+ Specifically, perl internals don't support long long. Among
+ the many problems is that some compilers support long long,
+ but the underlying library functions (such as sprintf) don't.
+ Some things do work (such as quad pack/unpack on convex);
+ also some systems use long long for the fpos_t typedef. That
+ seems to work too.
+
The IV type is supposed to be long enough to hold any integral
value or a pointer.
--Andy Dougherty August 1996
*/
-typedef IVTYPE IV;
-typedef UVTYPE UV;
-
-#if defined(USE_64_BIT_INT) && defined(HAS_QUAD)
-# if QUADKIND == QUAD_IS_INT64_T && defined(INT64_MAX)
-# define IV_MAX INT64_MAX
-# define IV_MIN INT64_MIN
-# define UV_MAX UINT64_MAX
-# ifndef UINT64_MIN
-# define UINT64_MIN 0
-# endif
-# define UV_MIN UINT64_MIN
-# else
-# define IV_MAX PERL_QUAD_MAX
-# define IV_MIN PERL_QUAD_MIN
-# define UV_MAX PERL_UQUAD_MAX
-# define UV_MIN PERL_UQUAD_MIN
-# endif
-# define IV_IS_QUAD
-# define UV_IS_QUAD
-#else
-# if defined(INT32_MAX) && IVSIZE == 4
-# define IV_MAX INT32_MAX
-# define IV_MIN INT32_MIN
-# ifndef UINT32_MAX_BROKEN /* e.g. HP-UX with gcc messes this up */
-# define UV_MAX UINT32_MAX
-# else
-# define UV_MAX 4294967295U
-# endif
-# ifndef UINT32_MIN
-# define UINT32_MIN 0
-# endif
-# define UV_MIN UINT32_MIN
-# else
-# define IV_MAX PERL_LONG_MAX
-# define IV_MIN PERL_LONG_MIN
-# define UV_MAX PERL_ULONG_MAX
-# define UV_MIN PERL_ULONG_MIN
-# endif
-# if IVSIZE == 8
-# define IV_IS_QUAD
-# define UV_IS_QUAD
-# ifndef HAS_QUAD
-# define HAS_QUAD
-# endif
-# else
-# undef IV_IS_QUAD
-# undef UV_IS_QUAD
-# undef HAS_QUAD
-# endif
-#endif
-
-#define IV_DIG (BIT_DIGITS(IVSIZE * 8))
-#define UV_DIG (BIT_DIGITS(UVSIZE * 8))
-
-/*
- * The macros INT2PTR and NUM2PTR are (despite their names)
- * bi-directional: they will convert int/float to or from pointers.
- * However the conversion to int/float are named explicitly:
- * PTR2IV, PTR2UV, PTR2NV.
- *
- * For int conversions we do not need two casts if pointers are
- * the same size as IV and UV. Otherwise we need an explicit
- * cast (PTRV) to avoid compiler warnings.
- */
-#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
-# define PTRV UV
-# define INT2PTR(any,d) (any)(d)
-#else
-# if PTRSIZE == LONGSIZE
-# define PTRV unsigned long
-# else
-# define PTRV unsigned
-# endif
-# define INT2PTR(any,d) (any)(PTRV)(d)
-#endif
-#define NUM2PTR(any,d) (any)(PTRV)(d)
-#define PTR2IV(p) INT2PTR(IV,p)
-#define PTR2UV(p) INT2PTR(UV,p)
-#define PTR2NV(p) NUM2PTR(NV,p)
-
-#ifdef USE_LONG_DOUBLE
-# if !(defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE))
-# undef USE_LONG_DOUBLE /* Ouch! */
-# endif
-#endif
-
-#ifdef OVR_DBL_DIG
-/* Use an overridden DBL_DIG */
-# ifdef DBL_DIG
-# undef DBL_DIG
-# endif
-# define DBL_DIG OVR_DBL_DIG
-#else
-/* The following is all to get DBL_DIG, in order to pick a nice
- default value for printing floating point numbers in Gconvert.
- (see config.h)
-*/
-#ifdef I_LIMITS
-#include <limits.h>
-#endif
-#ifdef I_FLOAT
-#include <float.h>
-#endif
-#ifndef HAS_DBL_DIG
-#define DBL_DIG 15 /* A guess that works lots of places */
-#endif
-#endif
-#ifdef I_FLOAT
-#include <float.h>
-#endif
-#ifndef HAS_DBL_DIG
-#define DBL_DIG 15 /* A guess that works lots of places */
-#endif
-
-#ifdef OVR_LDBL_DIG
-/* Use an overridden LDBL_DIG */
-# ifdef LDBL_DIG
-# undef LDBL_DIG
-# endif
-# define LDBL_DIG OVR_LDBL_DIG
+#ifdef cray
+# define Quad_t int
#else
-/* The following is all to get LDBL_DIG, in order to pick a nice
- default value for printing floating point numbers in Gconvert.
- (see config.h)
-*/
-# ifdef I_LIMITS
-# include <limits.h>
-# endif
-# ifdef I_FLOAT
-# include <float.h>
-# endif
-# ifndef HAS_LDBL_DIG
-# if LONG_DOUBLESIZE == 10
-# define LDBL_DIG 18 /* assume IEEE */
-# else
-# if LONG_DOUBLESIZE == 12
-# define LDBL_DIG 18 /* gcc? */
+# ifdef convex
+# define Quad_t long long
# else
-# if LONG_DOUBLESIZE == 16
-# define LDBL_DIG 33 /* assume IEEE */
-# else
-# if LONG_DOUBLESIZE == DOUBLESIZE
-# define LDBL_DIG DBL_DIG /* bummer */
-# endif
-# endif
+# if LONGSIZE == 8
+# define Quad_t long
+# endif
# endif
-# endif
-# endif
#endif
-typedef NVTYPE NV;
-
-#ifdef I_IEEEFP
-# include <ieeefp.h>
+/* XXX Experimental set-up for long long. Just add -DUSE_LONG_LONG
+ to your ccflags. --Andy Dougherty 4/1998
+*/
+#ifdef USE_LONG_LONG
+# if defined(HAS_LONG_LONG) && LONGLONGSIZE == 8
+# define Quad_t long long
+# endif
#endif
-#ifdef USE_LONG_DOUBLE
-# ifdef I_SUNMATH
-# include <sunmath.h>
-# endif
-# define NV_DIG LDBL_DIG
-# ifdef HAS_SQRTL
- /* libsunmath doesn't have modfl and frexpl as of mid-March 2000 */
- /* XXX Configure probe for modfl and frexpl needed XXX */
-# if defined(__sun) && defined(__svr4)
-# define Perl_modf(x,y) ((long double)modf((double)(x),(double*)(y)))
-# define Perl_frexp(x) ((long double)frexp((double)(x)))
-# else
-# define Perl_modf modfl
-# define Perl_frexp frexpl
-# endif
-# define Perl_cos cosl
-# define Perl_sin sinl
-# define Perl_sqrt sqrtl
-# define Perl_exp expl
-# define Perl_log logl
-# define Perl_atan2 atan2l
-# define Perl_pow powl
-# define Perl_floor floorl
-# define Perl_fmod fmodl
-# endif
+#ifdef Quad_t
+# define HAS_QUAD
+ typedef Quad_t IV;
+ typedef unsigned Quad_t UV;
+# define IV_MAX PERL_QUAD_MAX
+# define IV_MIN PERL_QUAD_MIN
+# define UV_MAX PERL_UQUAD_MAX
+# define UV_MIN PERL_UQUAD_MIN
#else
-# define NV_DIG DBL_DIG
-# define Perl_modf modf
-# define Perl_frexp frexp
-# define Perl_cos cos
-# define Perl_sin sin
-# define Perl_sqrt sqrt
-# define Perl_exp exp
-# define Perl_log log
-# define Perl_atan2 atan2
-# define Perl_pow pow
-# define Perl_floor floor
-# define Perl_fmod fmod
-#endif
-
-#if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
-# if !defined(Perl_atof) && defined(HAS_STRTOLD)
-# define Perl_atof(s) strtold(s, (char**)NULL)
-# endif
-# if !defined(Perl_atof) && defined(HAS_ATOLF)
-# define Perl_atof atolf
-# endif
-#endif
-#if !defined(Perl_atof)
-# define Perl_atof atof /* we assume atof being available anywhere */
+ typedef long IV;
+ typedef unsigned long UV;
+# define IV_MAX PERL_LONG_MAX
+# define IV_MIN PERL_LONG_MIN
+# define UV_MAX PERL_ULONG_MAX
+# define UV_MIN PERL_ULONG_MIN
#endif
/* Previously these definitions used hardcoded figures.
@@ -1360,7 +1023,7 @@ typedef NVTYPE NV;
# endif
#endif
-#ifdef UV_IS_QUAD
+#ifdef HAS_QUAD
# ifdef UQUAD_MAX
# define PERL_UQUAD_MAX ((UV)UQUAD_MAX)
@@ -1392,13 +1055,18 @@ typedef struct unop UNOP;
typedef struct binop BINOP;
typedef struct listop LISTOP;
typedef struct logop LOGOP;
+typedef struct condop CONDOP;
typedef struct pmop PMOP;
typedef struct svop SVOP;
-typedef struct padop PADOP;
+typedef struct gvop GVOP;
typedef struct pvop PVOP;
typedef struct loop LOOP;
+typedef struct Outrec Outrec;
typedef struct interpreter PerlInterpreter;
+#ifndef __BORLANDC__
+typedef struct ff FF; /* XXX not defined anywhere, should go? */
+#endif
typedef struct sv SV;
typedef struct av AV;
typedef struct hv HV;
@@ -1427,118 +1095,18 @@ typedef struct xpvfm XPVFM;
typedef struct xpvio XPVIO;
typedef struct mgvtbl MGVTBL;
typedef union any ANY;
-typedef struct ptr_tbl_ent PTR_TBL_ENT_t;
-typedef struct ptr_tbl PTR_TBL_t;
#include "handy.h"
-#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO)
-# if LSEEKSIZE == 8 && !defined(USE_64_BIT_RAWIO)
-# define USE_64_BIT_RAWIO /* implicit */
-# endif
-#endif
-
-/* Notice the use of HAS_FSEEKO: now we are obligated to always use
- * fseeko/ftello if possible. Don't go #defining ftell to ftello yourself,
- * however, because operating systems like to do that themself. */
-#ifndef FSEEKSIZE
-# ifdef HAS_FSEEKO
-# define FSEEKSIZE LSEEKSIZE
-# else
-# define FSEEKSIZE LONGSIZE
-# endif
-#endif
-
-#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO)
-# if FSEEKSIZE == 8 && !defined(USE_64_BIT_STDIO)
-# define USE_64_BIT_STDIO /* implicit */
-# endif
-#endif
-
-#ifdef USE_64_BIT_RAWIO
-# ifdef HAS_OFF64_T
-# undef Off_t
-# define Off_t off64_t
-# undef LSEEKSIZE
-# define LSEEKSIZE 8
-# endif
-/* Most 64-bit environments have defines like _LARGEFILE_SOURCE that
- * will trigger defines like the ones below. Some 64-bit environments,
- * however, do not. Therefore we have to explicitly mix and match. */
-# if defined(USE_OPEN64)
-# define open open64
-# endif
-# if defined(USE_LSEEK64)
-# define lseek lseek64
-# else
-# if defined(USE_LLSEEK)
-# define lseek llseek
-# endif
-# endif
-# if defined(USE_STAT64)
-# define stat stat64
-# endif
-# if defined(USE_FSTAT64)
-# define fstat fstat64
-# endif
-# if defined(USE_LSTAT64)
-# define lstat lstat64
-# endif
-# if defined(USE_FLOCK64)
-# define flock flock64
-# endif
-# if defined(USE_LOCKF64)
-# define lockf lockf64
-# endif
-# if defined(USE_FCNTL64)
-# define fcntl fcntl64
-# endif
-# if defined(USE_TRUNCATE64)
-# define truncate truncate64
-# endif
-# if defined(USE_FTRUNCATE64)
-# define ftruncate ftruncate64
-# endif
-#endif
-
-#ifdef USE_64_BIT_STDIO
-# ifdef HAS_FPOS64_T
-# undef Fpos_t
-# define Fpos_t fpos64_t
-# endif
-/* Most 64-bit environments have defines like _LARGEFILE_SOURCE that
- * will trigger defines like the ones below. Some 64-bit environments,
- * however, do not. */
-# if defined(USE_FOPEN64)
-# define fopen fopen64
-# endif
-# if defined(USE_FSEEK64)
-# define fseek fseek64 /* don't do fseeko here, see perlio.c */
-# endif
-# if defined(USE_FTELL64)
-# define ftell ftell64 /* don't do ftello here, see perlio.c */
-# endif
-# if defined(USE_FSETPOS64)
-# define fsetpos fsetpos64
-# endif
-# if defined(USE_FGETPOS64)
-# define fgetpos fgetpos64
-# endif
-# if defined(USE_TMPFILE64)
-# define tmpfile tmpfile64
-# endif
-# if defined(USE_FREOPEN64)
-# define freopen freopen64
-# endif
-#endif
-
-#if defined(OS2)
-# include "iperlsys.h"
+#ifdef PERL_OBJECT
+typedef I32 (*filter_t) _((CPerlObj*, int, SV *, int));
+#else
+typedef I32 (*filter_t) _((int, SV *, int));
#endif
-#if defined(__OPEN_VM)
-# include "vmesa/vmesaish.h"
-#endif
+#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
+#define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx])
+#define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters))
#ifdef DOSISH
# if defined(OS2)
@@ -1559,45 +1127,15 @@ typedef struct ptr_tbl PTR_TBL_t;
# if defined(__VOS__)
# include "vosish.h"
# else
-# if defined(EPOC)
-# include "epocish.h"
-# else
-# if defined(MACOS_TRADITIONAL)
-# include "macos/macish.h"
-# else
-# include "unixish.h"
-# endif
-# endif
+# include "unixish.h"
# endif
# endif
# endif
# endif
#endif
-#ifndef PERL_SYS_INIT3
-# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp)
-#endif
-
-#ifndef MAXPATHLEN
-# ifdef PATH_MAX
-# ifdef _POSIX_PATH_MAX
-# if PATH_MAX > _POSIX_PATH_MAX
-/* MAXPATHLEN is supposed to include the final null character,
- * as opposed to PATH_MAX and _POSIX_PATH_MAX. */
-# define MAXPATHLEN (PATH_MAX+1)
-# else
-# define MAXPATHLEN (_POSIX_PATH_MAX+1)
-# endif
-# else
-# define MAXPATHLEN (PATH_MAX+1)
-# endif
-# else
-# ifdef _POSIX_PATH_MAX
-# define MAXPATHLEN (_POSIX_PATH_MAX+1)
-# else
-# define MAXPATHLEN 1024 /* Err on the large side. */
-# endif
-# endif
+#ifndef FUNC_NAME_TO_PTR
+#define FUNC_NAME_TO_PTR(name) name
#endif
/*
@@ -1607,12 +1145,11 @@ typedef struct ptr_tbl PTR_TBL_t;
* May make sense to have threads after "*ish.h" anyway
*/
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
-# if defined(USE_THREADS)
+#ifdef USE_THREADS
/* pending resolution of licensing issues, we avoid the erstwhile
* atomic.h everywhere */
# define EMULATE_ATOMIC_REFCOUNTS
-# endif
+
# ifdef FAKE_THREADS
# include "fakethr.h"
# else
@@ -1624,7 +1161,7 @@ typedef struct ptr_tbl PTR_TBL_t;
# else
# ifdef I_MACH_CTHREADS
# include <mach/cthreads.h>
-# if (defined(NeXT) || defined(__NeXT__)) && defined(PERL_POLLUTE_MALLOC)
+# ifdef NeXT
# define MUTEX_INIT_CALLS_MALLOC
# endif
typedef cthread_t perl_os_thread;
@@ -1632,9 +1169,7 @@ typedef mutex_t perl_mutex;
typedef condition_t perl_cond;
typedef void * perl_key;
# else /* Posix threads */
-# ifdef I_PTHREAD
-# include <pthread.h>
-# endif
+# include <pthread.h>
typedef pthread_t perl_os_thread;
typedef pthread_mutex_t perl_mutex;
typedef pthread_cond_t perl_cond;
@@ -1643,16 +1178,14 @@ typedef pthread_key_t perl_key;
# endif /* OS2 */
# endif /* WIN32 */
# endif /* FAKE_THREADS */
-#endif /* USE_THREADS || USE_ITHREADS */
+#endif /* USE_THREADS */
-#ifdef WIN32
-# include "win32.h"
-#endif
+
#ifdef VMS
# define STATUS_NATIVE PL_statusvalue_vms
# define STATUS_NATIVE_EXPORT \
- (((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) | (VMSISH_HUSHED ? 0x10000000 : 0))
+ ((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms)
# define STATUS_NATIVE_SET(n) \
STMT_START { \
PL_statusvalue_vms = (n); \
@@ -1698,70 +1231,6 @@ typedef pthread_key_t perl_key;
# define STATUS_ALL_FAILURE (PL_statusvalue = 1)
#endif
-/* flags in PL_exit_flags for nature of exit() */
-#define PERL_EXIT_EXPECTED 0x01
-
-#ifndef MEMBER_TO_FPTR
-# define MEMBER_TO_FPTR(name) name
-#endif
-
-/* format to use for version numbers in file/directory names */
-/* XXX move to Configure? */
-#ifndef PERL_FS_VER_FMT
-# define PERL_FS_VER_FMT "%d.%d.%d"
-#endif
-
-/* This defines a way to flush all output buffers. This may be a
- * performance issue, so we allow people to disable it.
- */
-#ifndef PERL_FLUSHALL_FOR_CHILD
-# if defined(FFLUSH_NULL) || defined(USE_SFIO)
-# define PERL_FLUSHALL_FOR_CHILD PerlIO_flush((PerlIO*)NULL)
-# else
-# ifdef FFLUSH_ALL
-# define PERL_FLUSHALL_FOR_CHILD my_fflush_all()
-# else
-# define PERL_FLUSHALL_FOR_CHILD NOOP
-# endif
-# endif
-#endif
-
-#ifndef PERL_WAIT_FOR_CHILDREN
-# define PERL_WAIT_FOR_CHILDREN NOOP
-#endif
-
-/* the traditional thread-unsafe notion of "current interpreter". */
-#ifndef PERL_SET_INTERP
-# define PERL_SET_INTERP(i) (PL_curinterp = (PerlInterpreter*)(i))
-#endif
-
-#ifndef PERL_GET_INTERP
-# define PERL_GET_INTERP (PL_curinterp)
-#endif
-
-#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_GET_THX)
-# ifdef USE_THREADS
-# define PERL_GET_THX ((struct perl_thread *)PERL_GET_CONTEXT)
-# else
-# ifdef MULTIPLICITY
-# define PERL_GET_THX ((PerlInterpreter *)PERL_GET_CONTEXT)
-# else
-# ifdef PERL_OBJECT
-# define PERL_GET_THX ((CPerlObj *)PERL_GET_CONTEXT)
-# endif
-# endif
-# endif
-# define PERL_SET_THX(t) PERL_SET_CONTEXT(t)
-#endif
-
-#ifndef SVf
-# ifdef CHECK_FORMAT
-# define SVf "p"
-# else
-# define SVf "_"
-# endif
-#endif
-
/* Some unistd.h's give a prototype for pause() even though
HAS_PAUSE ends up undefined. This causes the #define
below to be rejected by the compmiler. Sigh.
@@ -1782,18 +1251,6 @@ typedef pthread_key_t perl_key;
# endif
#endif
-#if defined(__CYGWIN__)
-/* USEMYBINMODE
- * This symbol, if defined, indicates that the program should
- * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure
- * that a file is in "binary" mode -- that is, that no translation
- * of bytes occurs on read or write operations.
- */
-# define USEMYBINMODE / **/
-# define my_binmode(fp, iotype, mode) \
- (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1 ? TRUE : FALSE)
-#endif
-
#ifdef UNION_ANY_DEFINITION
UNION_ANY_DEFINITION;
#else
@@ -1802,41 +1259,36 @@ union any {
I32 any_i32;
IV any_iv;
long any_long;
- void (*any_dptr) (void*);
- void (*any_dxptr) (pTHXo_ void*);
+ void (CPERLscope(*any_dptr)) _((void*));
};
#endif
#ifdef USE_THREADS
#define ARGSproto struct perl_thread *thr
#else
-#define ARGSproto
+#define ARGSproto void
#endif /* USE_THREADS */
-typedef I32 (*filter_t) (pTHXo_ int, SV *, int);
-
-#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
-#define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx])
-#define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters))
-
-#if !defined(OS2)
-# include "iperlsys.h"
+/* Work around some cygwin32 problems with importing global symbols */
+#if defined(CYGWIN32) && defined(DLLIMPORT)
+# include "cw32imp.h"
#endif
+
#include "regexp.h"
#include "sv.h"
#include "util.h"
#include "form.h"
#include "gv.h"
#include "cv.h"
-#include "opnames.h"
+#include "opcode.h"
#include "op.h"
#include "cop.h"
#include "av.h"
#include "hv.h"
#include "mg.h"
#include "scope.h"
-#include "warnings.h"
-#include "utf8.h"
+#include "bytecode.h"
+#include "byterun.h"
/* Current curly descriptor */
typedef struct curcur CURCUR;
@@ -1857,28 +1309,40 @@ struct _sublex_info {
I32 super_state; /* lexer state to save */
I32 sub_inwhat; /* "lex_inwhat" to use */
OP *sub_op; /* "lex_op" to use */
- char *super_bufptr; /* PL_bufptr that was */
- char *super_bufend; /* PL_bufend that was */
};
-typedef struct magic_state MGS; /* struct magic_state defined in mg.c */
-
-struct scan_data_t; /* Used in S_* functions in regcomp.c */
-struct regnode_charclass_class; /* Used in S_* functions in regcomp.c */
+#ifdef PERL_OBJECT
+struct magic_state {
+ SV* mgs_sv;
+ U32 mgs_flags;
+};
+typedef struct magic_state MGS;
+
+typedef struct {
+ I32 len_min;
+ I32 len_delta;
+ I32 pos_min;
+ I32 pos_delta;
+ SV *last_found;
+ I32 last_end; /* min value, <0 unless valid. */
+ I32 last_start_min;
+ I32 last_start_max;
+ SV **longest; /* Either &l_fixed, or &l_float. */
+ SV *longest_fixed;
+ I32 offset_fixed;
+ SV *longest_float;
+ I32 offset_float_min;
+ I32 offset_float_max;
+ I32 flags;
+} scan_data_t;
typedef I32 CHECKPOINT;
+#endif /* PERL_OBJECT */
-struct ptr_tbl_ent {
- struct ptr_tbl_ent* next;
- void* oldval;
- void* newval;
-};
-
-struct ptr_tbl {
- struct ptr_tbl_ent** tbl_ary;
- UV tbl_max;
- UV tbl_items;
-};
+/* work around some libPW problems */
+#ifdef DOINIT
+EXT char Error[1];
+#endif
#if defined(iAPX286) || defined(M_I286) || defined(I80286)
# define I286
@@ -1943,9 +1407,10 @@ struct ptr_tbl {
#define U_I(what) ((unsigned int)(what))
#define U_L(what) ((U32)(what))
#else
-#define U_S(what) ((U16)cast_ulong((NV)(what)))
-#define U_I(what) ((unsigned int)cast_ulong((NV)(what)))
-#define U_L(what) (cast_ulong((NV)(what)))
+EXTERN_C U32 cast_ulong _((double));
+#define U_S(what) ((U16)cast_ulong((double)(what)))
+#define U_I(what) ((unsigned int)cast_ulong((double)(what)))
+#define U_L(what) (cast_ulong((double)(what)))
#endif
#ifdef CASTI32
@@ -1953,43 +1418,41 @@ struct ptr_tbl {
#define I_V(what) ((IV)(what))
#define U_V(what) ((UV)(what))
#else
-#define I_32(what) (cast_i32((NV)(what)))
-#define I_V(what) (cast_iv((NV)(what)))
-#define U_V(what) (cast_uv((NV)(what)))
+START_EXTERN_C
+I32 cast_i32 _((double));
+IV cast_iv _((double));
+UV cast_uv _((double));
+END_EXTERN_C
+#define I_32(what) (cast_i32((double)(what)))
+#define I_V(what) (cast_iv((double)(what)))
+#define U_V(what) (cast_uv((double)(what)))
#endif
-/* These do not care about the fractional part, only about the range. */
-#define NV_WITHIN_IV(nv) (I_V(nv) >= IV_MIN && I_V(nv) <= IV_MAX)
-#define NV_WITHIN_UV(nv) ((nv)>=0.0 && U_V(nv) >= UV_MIN && U_V(nv) <= UV_MAX)
-
-/* Used with UV/IV arguments: */
- /* XXXX: need to speed it up */
-#define CLUMP_2UV(iv) ((iv) < 0 ? 0 : (UV)(iv))
-#define CLUMP_2IV(uv) ((uv) > (UV)IV_MAX ? IV_MAX : (IV)(uv))
+struct Outrec {
+ I32 o_lines;
+ char *o_str;
+ U32 o_len;
+};
#ifndef MAXSYSFD
# define MAXSYSFD 2
#endif
-#ifndef __cplusplus
-Uid_t getuid (void);
-Uid_t geteuid (void);
-Gid_t getgid (void);
-Gid_t getegid (void);
+#ifndef TMPPATH
+# define TMPPATH "/tmp/perl-eXXXXXX"
#endif
-#ifndef Perl_debug_log
-# define Perl_debug_log PerlIO_stderr()
-#endif
-
-#ifndef Perl_error_log
-# define Perl_error_log (PL_stderrgv \
- && IoOFP(GvIOp(PL_stderrgv)) \
- ? IoOFP(GvIOp(PL_stderrgv)) \
- : PerlIO_stderr())
+#ifndef __cplusplus
+Uid_t getuid _((void));
+Uid_t geteuid _((void));
+Gid_t getgid _((void));
+Gid_t getegid _((void));
#endif
#ifdef DEBUGGING
+#ifndef Perl_debug_log
+#define Perl_debug_log PerlIO_stderr()
+#endif
#undef YYDEBUG
#define YYDEBUG 1
#define DEB(a) a
@@ -2001,14 +1464,7 @@ Gid_t getegid (void);
#define DEBUG_o(a) if (PL_debug & 16) a
#define DEBUG_c(a) if (PL_debug & 32) a
#define DEBUG_P(a) if (PL_debug & 64) a
-# if defined(PERL_OBJECT)
-# define DEBUG_m(a) if (PL_debug & 128) a
-# else
-# define DEBUG_m(a) \
- STMT_START { \
- if (PERL_GET_INTERP) { dTHX; if (PL_debug & 128) { a; } } \
- } STMT_END
-# endif
+#define DEBUG_m(a) if (PL_curinterp && PL_debug & 128) a
#define DEBUG_f(a) if (PL_debug & 256) a
#define DEBUG_r(a) if (PL_debug & 512) a
#define DEBUG_x(a) if (PL_debug & 1024) a
@@ -2048,31 +1504,29 @@ Gid_t getegid (void);
#ifndef assert /* <assert.h> might have been included somehow */
#define assert(what) DEB( { \
if (!(what)) { \
- Perl_croak(aTHX_ "Assertion failed: file \"%s\", line %d", \
+ croak("Assertion failed: file \"%s\", line %d", \
__FILE__, __LINE__); \
- PerlProc_exit(1); \
+ PerlProc_exit(1); \
}})
#endif
struct ufuncs {
- I32 (*uf_val)(IV, SV*);
- I32 (*uf_set)(IV, SV*);
+ I32 (*uf_val)_((IV, SV*));
+ I32 (*uf_set)_((IV, SV*));
IV uf_index;
};
/* Fix these up for __STDC__ */
#ifndef DONT_DECLARE_STD
-char *mktemp (char*);
-#ifndef atof
-double atof (const char*);
-#endif
+char *mktemp _((char*));
+double atof _((const char*));
#endif
#ifndef STANDARD_C
/* All of these are in stdlib.h or time.h for ANSI C */
Time_t time();
struct tm *gmtime(), *localtime();
-#if defined(OEMVS) || defined(__OPEN_VM)
+#ifdef OEMVS
char *(strchr)(), *(strrchr)();
char *(strcpy)(), *(strcat)();
#else
@@ -2086,42 +1540,40 @@ char *strcpy(), *strcat();
# include <math.h>
#else
START_EXTERN_C
- double exp (double);
- double log (double);
- double log10 (double);
- double sqrt (double);
- double frexp (double,int*);
- double ldexp (double,int);
- double modf (double,double*);
- double sin (double);
- double cos (double);
- double atan2 (double,double);
- double pow (double,double);
+ double exp _((double));
+ double log _((double));
+ double log10 _((double));
+ double sqrt _((double));
+ double frexp _((double,int*));
+ double ldexp _((double,int));
+ double modf _((double,double*));
+ double sin _((double));
+ double cos _((double));
+ double atan2 _((double,double));
+ double pow _((double,double));
END_EXTERN_C
#endif
#ifndef __cplusplus
-# if defined(NeXT) || defined(__NeXT__) /* or whatever catches all NeXTs */
+# ifdef __NeXT__ /* or whatever catches all NeXTs */
char *crypt (); /* Maybe more hosts will need the unprototyped version */
# else
-# if !defined(WIN32)
-char *crypt (const char*, const char*);
-# endif /* !WIN32 */
-# endif /* !NeXT && !__NeXT__ */
+# if !defined(WIN32) || !defined(HAVE_DES_FCRYPT)
+char *crypt _((const char*, const char*));
+# endif /* !WIN32 && !HAVE_CRYPT_SOURCE */
+# endif /* !__NeXT__ */
# ifndef DONT_DECLARE_STD
# ifndef getenv
-char *getenv (const char*);
+char *getenv _((const char*));
# endif /* !getenv */
-# if !defined(EPOC) && !(defined(__hpux) && defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS == 64) && !defined(HAS_LSEEK_PROTO)
-Off_t lseek (int,Off_t,int);
-# endif
+Off_t lseek _((int,Off_t,int));
# endif /* !DONT_DECLARE_STD */
-char *getlogin (void);
+char *getlogin _((void));
#endif /* !__cplusplus */
#ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */
#define UNLINK unlnk
-I32 unlnk (char*);
+I32 unlnk _((char*));
#else
#define UNLINK PerlLIO_unlink
#endif
@@ -2139,7 +1591,7 @@ I32 unlnk (char*);
# endif
#endif
-/* Sighandler_t defined in iperlsys.h */
+typedef Signal_t (*Sighandler_t) _((int));
#ifdef HAS_SIGACTION
typedef struct sigaction Sigsave_t;
@@ -2156,10 +1608,10 @@ typedef Sighandler_t Sigsave_t;
# define register
# endif
# define PAD_SV(po) pad_sv(po)
-# define RUNOPS_DEFAULT Perl_runops_debug
+# define RUNOPS_DEFAULT runops_debug
#else
# define PAD_SV(po) PL_curpad[po]
-# define RUNOPS_DEFAULT Perl_runops_standard
+# define RUNOPS_DEFAULT runops_standard
#endif
#ifdef MYMALLOC
@@ -2185,90 +1637,95 @@ typedef Sighandler_t Sigsave_t;
#endif
-typedef int (CPERLscope(*runops_proc_t)) (pTHX);
-typedef OP* (CPERLscope(*PPADDR_t)[]) (pTHX);
+/*
+ * These need prototyping here because <proto.h> isn't
+ * included until after runops is initialised.
+ */
+
+#ifndef PERL_OBJECT
+typedef int runops_proc_t _((void));
+int runops_standard _((void));
+#ifdef DEBUGGING
+int runops_debug _((void));
+#endif
+#endif /* PERL_OBJECT */
/* _ (for $_) must be first in the following list (DEFSV requires it) */
#define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@"
-/* NeXT has problems with crt0.o globals */
-#if defined(__DYNAMIC__) && \
- (defined(NeXT) || defined(__NeXT__) || defined(__APPLE__))
-# if defined(NeXT) || defined(__NeXT)
-# include <mach-o/dyld.h>
-# define environ (*environ_pointer)
-EXT char *** environ_pointer;
-# else
-# if defined(__APPLE__)
-# include <crt_externs.h> /* for the env array */
-# define environ (*_NSGetEnviron())
-# endif
-# endif
-#else
- /* VMS and some other platforms don't use the environ array */
-# if !defined(VMS)
-# if !defined(DONT_DECLARE_STD) || \
- (defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \
- defined(__sgi) || \
- defined(__DGUX) || defined(EPOC)
+/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
+#if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__))
+#if !defined(DONT_DECLARE_STD) \
+ || (defined(__svr4__) && defined(__GNUC__) && defined(sun)) \
+ || defined(__sgi) || defined(__DGUX)
extern char ** environ; /* environment variables supplied via exec */
-# endif
-# endif
#endif
+#else
+# if defined(NeXT) && defined(__DYNAMIC__)
+
+# include <mach-o/dyld.h>
+EXT char *** environ_pointer;
+# define environ (*environ_pointer)
+# endif
+#endif /* environ processing */
-START_EXTERN_C
+
+/* for tmp use in stupid debuggers */
+EXT int * di;
+EXT short * ds;
+EXT char * dc;
/* handy constants */
-EXTCONST char PL_warn_uninit[]
- INIT("Use of uninitialized value%s%s");
-EXTCONST char PL_warn_nosemi[]
+EXTCONST char warn_uninit[]
+ INIT("Use of uninitialized value");
+EXTCONST char warn_nosemi[]
INIT("Semicolon seems to be missing");
-EXTCONST char PL_warn_reserved[]
+EXTCONST char warn_reserved[]
INIT("Unquoted string \"%s\" may clash with future reserved word");
-EXTCONST char PL_warn_nl[]
+EXTCONST char warn_nl[]
INIT("Unsuccessful %s on filename containing newline");
-EXTCONST char PL_no_wrongref[]
+EXTCONST char no_wrongref[]
INIT("Can't use %s ref as %s ref");
-EXTCONST char PL_no_symref[]
+EXTCONST char no_symref[]
INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
-EXTCONST char PL_no_usym[]
+EXTCONST char no_usym[]
INIT("Can't use an undefined value as %s reference");
-EXTCONST char PL_no_aelem[]
+EXTCONST char no_aelem[]
INIT("Modification of non-creatable array value attempted, subscript %d");
-EXTCONST char PL_no_helem[]
+EXTCONST char no_helem[]
INIT("Modification of non-creatable hash value attempted, subscript \"%s\"");
-EXTCONST char PL_no_modify[]
+EXTCONST char no_modify[]
INIT("Modification of a read-only value attempted");
-EXTCONST char PL_no_mem[]
+EXTCONST char no_mem[]
INIT("Out of memory!\n");
-EXTCONST char PL_no_security[]
+EXTCONST char no_security[]
INIT("Insecure dependency in %s%s");
-EXTCONST char PL_no_sock_func[]
+EXTCONST char no_sock_func[]
INIT("Unsupported socket function \"%s\" called");
-EXTCONST char PL_no_dir_func[]
+EXTCONST char no_dir_func[]
INIT("Unsupported directory function \"%s\" called");
-EXTCONST char PL_no_func[]
+EXTCONST char no_func[]
INIT("The %s function is unimplemented");
-EXTCONST char PL_no_myglob[]
+EXTCONST char no_myglob[]
INIT("\"my\" variable %s can't be in a package");
-EXTCONST char PL_uuemap[65]
- INIT("`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_");
-
-
#ifdef DOINIT
-EXT char *PL_sig_name[] = { SIG_NAME };
-EXT int PL_sig_num[] = { SIG_NUM };
+EXT char *sig_name[] = { SIG_NAME };
+EXT int sig_num[] = { SIG_NUM };
+EXT SV * psig_ptr[sizeof(sig_num)/sizeof(*sig_num)];
+EXT SV * psig_name[sizeof(sig_num)/sizeof(*sig_num)];
#else
-EXT char *PL_sig_name[];
-EXT int PL_sig_num[];
+EXT char *sig_name[];
+EXT int sig_num[];
+EXT SV * psig_ptr[];
+EXT SV * psig_name[];
#endif
/* fast case folding tables */
#ifdef DOINIT
#ifdef EBCDIC
-EXT unsigned char PL_fold[] = { /* fast EBCDIC case folding table */
+EXT unsigned char fold[] = { /* fast EBCDIC case folding table */
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15,
16, 17, 18, 19, 20, 21, 22, 23,
@@ -2303,7 +1760,7 @@ EXT unsigned char PL_fold[] = { /* fast EBCDIC case folding table */
248, 249, 250, 251, 252, 253, 254, 255
};
#else /* ascii rather than ebcdic */
-EXTCONST unsigned char PL_fold[] = {
+EXTCONST unsigned char fold[] = {
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15,
16, 17, 18, 19, 20, 21, 22, 23,
@@ -2339,11 +1796,11 @@ EXTCONST unsigned char PL_fold[] = {
};
#endif /* !EBCDIC */
#else
-EXTCONST unsigned char PL_fold[];
+EXTCONST unsigned char fold[];
#endif
#ifdef DOINIT
-EXT unsigned char PL_fold_locale[] = {
+EXT unsigned char fold_locale[] = {
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15,
16, 17, 18, 19, 20, 21, 22, 23,
@@ -2378,12 +1835,12 @@ EXT unsigned char PL_fold_locale[] = {
248, 249, 250, 251, 252, 253, 254, 255
};
#else
-EXT unsigned char PL_fold_locale[];
+EXT unsigned char fold_locale[];
#endif
#ifdef DOINIT
#ifdef EBCDIC
-EXT unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */
+EXT unsigned char freq[] = {/* EBCDIC frequencies for mixed English/C */
1, 2, 84, 151, 154, 155, 156, 157,
165, 246, 250, 3, 158, 7, 18, 29,
40, 51, 62, 73, 85, 96, 107, 118,
@@ -2418,7 +1875,7 @@ EXT unsigned char PL_freq[] = {/* EBCDIC frequencies for mixed English/C */
191, 183, 141, 142, 143, 144, 145, 146
};
#else /* ascii rather than ebcdic */
-EXTCONST unsigned char PL_freq[] = { /* letter frequencies for mixed English/C */
+EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */
1, 2, 84, 151, 154, 155, 156, 157,
165, 246, 250, 3, 158, 7, 18, 29,
40, 51, 62, 73, 85, 96, 107, 118,
@@ -2454,12 +1911,12 @@ EXTCONST unsigned char PL_freq[] = { /* letter frequencies for mixed English/C *
};
#endif
#else
-EXTCONST unsigned char PL_freq[];
+EXTCONST unsigned char freq[];
#endif
#ifdef DEBUGGING
#ifdef DOINIT
-EXTCONST char* PL_block_type[] = {
+EXTCONST char* block_type[] = {
"NULL",
"SUB",
"EVAL",
@@ -2468,12 +1925,10 @@ EXTCONST char* PL_block_type[] = {
"BLOCK",
};
#else
-EXTCONST char* PL_block_type[];
+EXTCONST char* block_type[];
#endif
#endif
-END_EXTERN_C
-
/*****************************************************************************/
/* This lexer/parser stuff is currently global since yacc is hard to reenter */
/*****************************************************************************/
@@ -2489,8 +1944,6 @@ typedef enum {
XREF,
XSTATE,
XBLOCK,
- XATTRBLOCK,
- XATTRTERM,
XTERMBLOCK
} expectation;
@@ -2520,24 +1973,18 @@ enum { /* pass one of these to get_vtbl */
want_vtbl_regexp,
want_vtbl_collxfrm,
want_vtbl_amagic,
- want_vtbl_amagicelem,
+ want_vtbl_amagicelem
#ifdef USE_THREADS
- want_vtbl_mutex,
+ ,
+ want_vtbl_mutex
#endif
- want_vtbl_regdata,
- want_vtbl_regdatum,
- want_vtbl_backref
};
+
/* Note: the lowest 8 bits are reserved for
stuffing into op->op_private */
-#define HINT_PRIVATE_MASK 0x000000ff
#define HINT_INTEGER 0x00000001
#define HINT_STRICT_REFS 0x00000002
-/* #define HINT_notused4 0x00000004 */
-#define HINT_BYTE 0x00000008
-/* #define HINT_notused10 0x00000010 */
- /* Note: 20,40,80 used for NATIVE_HINTS */
#define HINT_BLOCK_SCOPE 0x00000100
#define HINT_STRICT_SUBS 0x00000200
@@ -2554,70 +2001,78 @@ enum { /* pass one of these to get_vtbl */
#define HINT_RE_TAINT 0x00100000
#define HINT_RE_EVAL 0x00200000
-#define HINT_FILETEST_ACCESS 0x00400000
-#define HINT_UTF8 0x00800000
-
/* Various states of an input record separator SV (rs, nrs) */
#define RsSNARF(sv) (! SvOK(sv))
-#define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv)))
-#define RsPARA(sv) (SvPOK(sv) && ! SvCUR(sv))
+#define RsSIMPLE(sv) (SvOK(sv) && SvCUR(sv))
+#define RsPARA(sv) (SvOK(sv) && ! SvCUR(sv))
#define RsRECORD(sv) (SvROK(sv) && (SvIV(SvRV(sv)) > 0))
/* Enable variables which are pointers to functions */
-typedef regexp*(CPERLscope(*regcomp_t)) (pTHX_ char* exp, char* xend, PMOP* pm);
-typedef I32 (CPERLscope(*regexec_t)) (pTHX_ regexp* prog, char* stringarg,
- char* strend, char* strbeg, I32 minend,
- SV* screamer, void* data, U32 flags);
-typedef char* (CPERLscope(*re_intuit_start_t)) (pTHX_ regexp *prog, SV *sv,
- char *strpos, char *strend,
- U32 flags,
- struct re_scream_pos_data_s *d);
-typedef SV* (CPERLscope(*re_intuit_string_t)) (pTHX_ regexp *prog);
-typedef void (CPERLscope(*regfree_t)) (pTHX_ struct regexp* r);
-
-#ifdef USE_PURE_BISON
-int Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp);
-#endif
-
-typedef void (*DESTRUCTORFUNC_NOCONTEXT_t) (void*);
-typedef void (*DESTRUCTORFUNC_t) (pTHXo_ void*);
-typedef void (*SVFUNC_t) (pTHXo_ SV*);
-typedef I32 (*SVCOMPARE_t) (pTHXo_ SV*, SV*);
-typedef void (*XSINIT_t) (pTHXo);
-typedef void (*ATEXIT_t) (pTHXo_ void*);
-typedef void (*XSUBADDR_t) (pTHXo_ CV *);
+#ifdef PERL_OBJECT
+typedef regexp*(CPerlObj::*regcomp_t) _((char* exp, char* xend, PMOP* pm));
+typedef I32 (CPerlObj::*regexec_t) _((regexp* prog, char* stringarg,
+ char* strend, char* strbeg,
+ I32 minend, SV* screamer, void* data,
+ U32 flags));
+#else
+typedef regexp*(*regcomp_t) _((char* exp, char* xend, PMOP* pm));
+typedef I32 (*regexec_t) _((regexp* prog, char* stringarg, char* strend, char*
+ strbeg, I32 minend, SV* screamer, void* data,
+ U32 flags));
+
+#endif
/* Set up PERLVAR macros for populating structs */
#define PERLVAR(var,type) type var;
-#define PERLVARA(var,n,type) type var[n];
#define PERLVARI(var,type,init) type var;
#define PERLVARIC(var,type,init) type var;
/* Interpreter exitlist entry */
typedef struct exitlistentry {
- void (*fn) (pTHXo_ void*);
+#ifdef PERL_OBJECT
+ void (*fn) _((CPerlObj*, void*));
+#else
+ void (*fn) _((void*));
+#endif
void *ptr;
} PerlExitListEntry;
+#ifdef PERL_OBJECT
+extern "C" CPerlObj* perl_alloc _((IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*));
+
+typedef int (CPerlObj::*runops_proc_t) _((void));
+#undef EXT
+#define EXT
+#undef EXTCONST
+#define EXTCONST
+#undef INIT
+#define INIT(x)
+
+class CPerlObj {
+public:
+ CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
+ void Init(void);
+ void* operator new(size_t nSize, IPerlMem *pvtbl);
+#endif /* PERL_OBJECT */
+
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars {
-# include "perlvars.h"
+#include "perlvars.h"
};
-# ifdef PERL_CORE
+#ifdef PERL_CORE
EXT struct perl_vars PL_Vars;
EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
-# else /* PERL_CORE */
-# if !defined(__GNUC__) || !defined(WIN32)
+#else /* PERL_CORE */
+#if !defined(__GNUC__) || !defined(WIN32)
EXT
-# endif /* WIN32 */
+#endif /* WIN32 */
struct perl_vars *PL_VarsPtr;
-# define PL_Vars (*((PL_VarsPtr) \
- ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars(aTHX))))
-# endif /* PERL_CORE */
+#define PL_Vars (*((PL_VarsPtr) ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars())))
+#endif /* PERL_CORE */
#endif /* PERL_GLOBAL_STRUCT */
-#if defined(MULTIPLICITY) || defined(PERL_OBJECT)
+#ifdef MULTIPLICITY
/* If we have multiple interpreters define a struct
holding variables which must be per-interpreter
If we don't have threads anything that would have
@@ -2625,22 +2080,17 @@ struct perl_vars *PL_VarsPtr;
*/
struct interpreter {
-# ifndef USE_THREADS
-# include "thrdvar.h"
-# endif
-# include "intrpvar.h"
-/*
- * The following is a buffer where new variables must
- * be defined to maintain binary compatibility with PERL_OBJECT
- */
-PERLVARA(object_compatibility,30, char)
+#ifndef USE_THREADS
+#include "thrdvar.h"
+#endif
+#include "intrpvar.h"
};
#else
struct interpreter {
char broiled;
};
-#endif /* MULTIPLICITY || PERL_OBJECT */
+#endif
#ifdef USE_THREADS
/* If we have threads define a struct with all the variables
@@ -2660,51 +2110,24 @@ typedef void *Thread;
/* Done with PERLVAR macros for now ... */
#undef PERLVAR
-#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#include "thread.h"
#include "pp.h"
-
-#ifndef PERL_CALLCONV
-# define PERL_CALLCONV
-#endif
-
-#ifndef NEXT30_NO_ATTRIBUTE
-# ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */
-# ifdef __attribute__ /* Avoid possible redefinition errors */
-# undef __attribute__
-# endif
-# define __attribute__(attr)
-# endif
-#endif
-
-#ifdef PERL_OBJECT
-# define PERL_DECL_PROT
-#endif
-
-#undef PERL_CKDEF
-#undef PERL_PPDEF
-#define PERL_CKDEF(s) OP *s (pTHX_ OP *o);
-#define PERL_PPDEF(s) OP *s (pTHX);
-
#include "proto.h"
-#ifdef PERL_OBJECT
-# undef PERL_DECL_PROT
-#endif
-
-#ifndef PERL_OBJECT
-/* this has structure inits, so it cannot be included before here */
-# include "opcode.h"
+#ifdef EMBED
+#define Perl_sv_setptrobj(rv,ptr,name) Perl_sv_setref_iv(rv,name,(IV)ptr)
+#define Perl_sv_setptrref(rv,ptr) Perl_sv_setref_iv(rv,Nullch,(IV)ptr)
+#else
+#define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,(IV)ptr)
+#define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,(IV)ptr)
#endif
/* The following must follow proto.h as #defines mess up syntax */
-#if !defined(PERL_FOR_X2P)
-# include "embedvar.h"
-#endif
+#include "embedvar.h"
/* Now include all the 'global' variables
* If we don't have threads or multiple interpreters
@@ -2712,219 +2135,226 @@ typedef void *Thread;
*/
#define PERLVAR(var,type) EXT type PL_##var;
-#define PERLVARA(var,n,type) EXT type PL_##var[n];
#define PERLVARI(var,type,init) EXT type PL_##var INIT(init);
#define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init);
-#if !defined(MULTIPLICITY) && !defined(PERL_OBJECT)
-START_EXTERN_C
+#ifndef PERL_GLOBAL_STRUCT
+#include "perlvars.h"
+#endif
+
+#ifndef MULTIPLICITY
+
# include "intrpvar.h"
# ifndef USE_THREADS
# include "thrdvar.h"
# endif
-END_EXTERN_C
+
#endif
#ifdef PERL_OBJECT
-# include "embed.h"
+/* from perly.c */
+#undef yydebug
+#undef yynerrs
+#undef yyerrflag
+#undef yychar
+#undef yyssp
+#undef yyvsp
+#undef yyval
+#undef yylval
+#define yydebug PL_yydebug
+#define yynerrs PL_yynerrs
+#define yyerrflag PL_yyerrflag
+#define yychar PL_yychar
+#define yyssp PL_yyssp
+#define yyvsp PL_yyvsp
+#define yyval PL_yyval
+#define yylval PL_yylval
+PERLVAR(yydebug, int)
+PERLVAR(yynerrs, int)
+PERLVAR(yyerrflag, int)
+PERLVAR(yychar, int)
+PERLVAR(yyssp, short*)
+PERLVAR(yyvsp, YYSTYPE*)
+PERLVAR(yyval, YYSTYPE)
+PERLVAR(yylval, YYSTYPE)
+
+#define efloatbuf PL_efloatbuf
+#define efloatsize PL_efloatsize
+PERLVAR(efloatbuf, char *)
+PERLVAR(efloatsize, STRLEN)
+
+#define glob_index PL_glob_index
+#define srand_called PL_srand_called
+#define uudmap PL_uudmap
+#define bitcount PL_bitcount
+#define filter_debug PL_filter_debug
+PERLVAR(glob_index, int)
+PERLVAR(srand_called, bool)
+PERLVAR(uudmap[256], char)
+PERLVAR(bitcount, char*)
+PERLVAR(filter_debug, int)
+PERLVAR(super_bufptr, char*) /* PL_bufptr that was */
+PERLVAR(super_bufend, char*) /* PL_bufend that was */
-# ifdef DOINIT
-# include "INTERN.h"
-# else
-# include "EXTERN.h"
-# endif
-
-/* this has structure inits, so it cannot be included before here */
-# include "opcode.h"
+/*
+ * The following is a buffer where new variables must
+ * be defined to maintain binary compatibility with PERL_OBJECT
+ * for 5.005
+ */
+PERLVAR(object_compatibility[30], char)
+};
+#include "objpp.h"
+#ifdef DOINIT
+#include "INTERN.h"
#else
-# if defined(WIN32)
-# include "embed.h"
-# endif
+#include "EXTERN.h"
+#endif
#endif /* PERL_OBJECT */
-#ifndef PERL_GLOBAL_STRUCT
-START_EXTERN_C
-
-# include "perlvars.h"
-
-END_EXTERN_C
-#endif
#undef PERLVAR
-#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
-START_EXTERN_C
+#if defined(HASATTRIBUTE) && defined(WIN32)
+/*
+ * This provides a layer of functions and macros to ensure extensions will
+ * get to use the same RTL functions as the core.
+ * It has to go here or #define of printf messes up __attribute__
+ * stuff in proto.h
+ */
+#ifndef PERL_OBJECT
+# include <win32iop.h>
+#endif /* PERL_OBJECT */
+#endif /* WIN32 */
#ifdef DOINIT
-EXT MGVTBL PL_vtbl_sv = {MEMBER_TO_FPTR(Perl_magic_get),
- MEMBER_TO_FPTR(Perl_magic_set),
- MEMBER_TO_FPTR(Perl_magic_len),
+EXT MGVTBL vtbl_sv = {magic_get,
+ magic_set,
+ magic_len,
0, 0};
-EXT MGVTBL PL_vtbl_env = {0, MEMBER_TO_FPTR(Perl_magic_set_all_env),
- 0, MEMBER_TO_FPTR(Perl_magic_clear_all_env),
+EXT MGVTBL vtbl_env = {0, magic_set_all_env,
+ 0, magic_clear_all_env,
0};
-EXT MGVTBL PL_vtbl_envelem = {0, MEMBER_TO_FPTR(Perl_magic_setenv),
- 0, MEMBER_TO_FPTR(Perl_magic_clearenv),
+EXT MGVTBL vtbl_envelem = {0, magic_setenv,
+ 0, magic_clearenv,
0};
-EXT MGVTBL PL_vtbl_sig = {0, 0, 0, 0, 0};
-EXT MGVTBL PL_vtbl_sigelem = {MEMBER_TO_FPTR(Perl_magic_getsig),
- MEMBER_TO_FPTR(Perl_magic_setsig),
- 0, MEMBER_TO_FPTR(Perl_magic_clearsig),
+EXT MGVTBL vtbl_sig = {0, 0, 0, 0, 0};
+EXT MGVTBL vtbl_sigelem = {magic_getsig,
+ magic_setsig,
+ 0, magic_clearsig,
0};
-EXT MGVTBL PL_vtbl_pack = {0, 0, MEMBER_TO_FPTR(Perl_magic_sizepack), MEMBER_TO_FPTR(Perl_magic_wipepack),
+EXT MGVTBL vtbl_pack = {0, 0, magic_sizepack, magic_wipepack,
0};
-EXT MGVTBL PL_vtbl_packelem = {MEMBER_TO_FPTR(Perl_magic_getpack),
- MEMBER_TO_FPTR(Perl_magic_setpack),
- 0, MEMBER_TO_FPTR(Perl_magic_clearpack),
+EXT MGVTBL vtbl_packelem = {magic_getpack,
+ magic_setpack,
+ 0, magic_clearpack,
0};
-EXT MGVTBL PL_vtbl_dbline = {0, MEMBER_TO_FPTR(Perl_magic_setdbline),
+EXT MGVTBL vtbl_dbline = {0, magic_setdbline,
0, 0, 0};
-EXT MGVTBL PL_vtbl_isa = {0, MEMBER_TO_FPTR(Perl_magic_setisa),
- 0, MEMBER_TO_FPTR(Perl_magic_setisa),
+EXT MGVTBL vtbl_isa = {0, magic_setisa,
+ 0, magic_setisa,
0};
-EXT MGVTBL PL_vtbl_isaelem = {0, MEMBER_TO_FPTR(Perl_magic_setisa),
+EXT MGVTBL vtbl_isaelem = {0, magic_setisa,
0, 0, 0};
-EXT MGVTBL PL_vtbl_arylen = {MEMBER_TO_FPTR(Perl_magic_getarylen),
- MEMBER_TO_FPTR(Perl_magic_setarylen),
+EXT MGVTBL vtbl_arylen = {magic_getarylen,
+ magic_setarylen,
0, 0, 0};
-EXT MGVTBL PL_vtbl_glob = {MEMBER_TO_FPTR(Perl_magic_getglob),
- MEMBER_TO_FPTR(Perl_magic_setglob),
+EXT MGVTBL vtbl_glob = {magic_getglob,
+ magic_setglob,
0, 0, 0};
-EXT MGVTBL PL_vtbl_mglob = {0, MEMBER_TO_FPTR(Perl_magic_setmglob),
+EXT MGVTBL vtbl_mglob = {0, magic_setmglob,
0, 0, 0};
-EXT MGVTBL PL_vtbl_nkeys = {MEMBER_TO_FPTR(Perl_magic_getnkeys),
- MEMBER_TO_FPTR(Perl_magic_setnkeys),
+EXT MGVTBL vtbl_nkeys = {magic_getnkeys,
+ magic_setnkeys,
0, 0, 0};
-EXT MGVTBL PL_vtbl_taint = {MEMBER_TO_FPTR(Perl_magic_gettaint),MEMBER_TO_FPTR(Perl_magic_settaint),
+EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint,
0, 0, 0};
-EXT MGVTBL PL_vtbl_substr = {MEMBER_TO_FPTR(Perl_magic_getsubstr), MEMBER_TO_FPTR(Perl_magic_setsubstr),
+EXT MGVTBL vtbl_substr = {magic_getsubstr, magic_setsubstr,
0, 0, 0};
-EXT MGVTBL PL_vtbl_vec = {MEMBER_TO_FPTR(Perl_magic_getvec),
- MEMBER_TO_FPTR(Perl_magic_setvec),
+EXT MGVTBL vtbl_vec = {magic_getvec,
+ magic_setvec,
0, 0, 0};
-EXT MGVTBL PL_vtbl_pos = {MEMBER_TO_FPTR(Perl_magic_getpos),
- MEMBER_TO_FPTR(Perl_magic_setpos),
+EXT MGVTBL vtbl_pos = {magic_getpos,
+ magic_setpos,
0, 0, 0};
-EXT MGVTBL PL_vtbl_bm = {0, MEMBER_TO_FPTR(Perl_magic_setbm),
+EXT MGVTBL vtbl_bm = {0, magic_setbm,
0, 0, 0};
-EXT MGVTBL PL_vtbl_fm = {0, MEMBER_TO_FPTR(Perl_magic_setfm),
+EXT MGVTBL vtbl_fm = {0, magic_setfm,
0, 0, 0};
-EXT MGVTBL PL_vtbl_uvar = {MEMBER_TO_FPTR(Perl_magic_getuvar),
- MEMBER_TO_FPTR(Perl_magic_setuvar),
+EXT MGVTBL vtbl_uvar = {magic_getuvar,
+ magic_setuvar,
0, 0, 0};
#ifdef USE_THREADS
-EXT MGVTBL PL_vtbl_mutex = {0, 0, 0, 0, MEMBER_TO_FPTR(Perl_magic_mutexfree)};
+EXT MGVTBL vtbl_mutex = {0, 0, 0, 0, magic_mutexfree};
#endif /* USE_THREADS */
-EXT MGVTBL PL_vtbl_defelem = {MEMBER_TO_FPTR(Perl_magic_getdefelem),MEMBER_TO_FPTR(Perl_magic_setdefelem),
+EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem,
0, 0, 0};
-EXT MGVTBL PL_vtbl_regexp = {0,0,0,0, MEMBER_TO_FPTR(Perl_magic_freeregexp)};
-EXT MGVTBL PL_vtbl_regdata = {0, 0, MEMBER_TO_FPTR(Perl_magic_regdata_cnt), 0, 0};
-EXT MGVTBL PL_vtbl_regdatum = {MEMBER_TO_FPTR(Perl_magic_regdatum_get), 0, 0, 0, 0};
+EXT MGVTBL vtbl_regexp = {0,0,0,0, magic_freeregexp};
#ifdef USE_LOCALE_COLLATE
-EXT MGVTBL PL_vtbl_collxfrm = {0,
- MEMBER_TO_FPTR(Perl_magic_setcollxfrm),
+EXT MGVTBL vtbl_collxfrm = {0,
+ magic_setcollxfrm,
0, 0, 0};
#endif
-EXT MGVTBL PL_vtbl_amagic = {0, MEMBER_TO_FPTR(Perl_magic_setamagic),
- 0, 0, MEMBER_TO_FPTR(Perl_magic_setamagic)};
-EXT MGVTBL PL_vtbl_amagicelem = {0, MEMBER_TO_FPTR(Perl_magic_setamagic),
- 0, 0, MEMBER_TO_FPTR(Perl_magic_setamagic)};
-
-EXT MGVTBL PL_vtbl_backref = {0, 0,
- 0, 0, MEMBER_TO_FPTR(Perl_magic_killbackrefs)};
+#ifdef OVERLOAD
+EXT MGVTBL vtbl_amagic = {0, magic_setamagic,
+ 0, 0, magic_setamagic};
+EXT MGVTBL vtbl_amagicelem = {0, magic_setamagic,
+ 0, 0, magic_setamagic};
+#endif /* OVERLOAD */
#else /* !DOINIT */
-EXT MGVTBL PL_vtbl_sv;
-EXT MGVTBL PL_vtbl_env;
-EXT MGVTBL PL_vtbl_envelem;
-EXT MGVTBL PL_vtbl_sig;
-EXT MGVTBL PL_vtbl_sigelem;
-EXT MGVTBL PL_vtbl_pack;
-EXT MGVTBL PL_vtbl_packelem;
-EXT MGVTBL PL_vtbl_dbline;
-EXT MGVTBL PL_vtbl_isa;
-EXT MGVTBL PL_vtbl_isaelem;
-EXT MGVTBL PL_vtbl_arylen;
-EXT MGVTBL PL_vtbl_glob;
-EXT MGVTBL PL_vtbl_mglob;
-EXT MGVTBL PL_vtbl_nkeys;
-EXT MGVTBL PL_vtbl_taint;
-EXT MGVTBL PL_vtbl_substr;
-EXT MGVTBL PL_vtbl_vec;
-EXT MGVTBL PL_vtbl_pos;
-EXT MGVTBL PL_vtbl_bm;
-EXT MGVTBL PL_vtbl_fm;
-EXT MGVTBL PL_vtbl_uvar;
+EXT MGVTBL vtbl_sv;
+EXT MGVTBL vtbl_env;
+EXT MGVTBL vtbl_envelem;
+EXT MGVTBL vtbl_sig;
+EXT MGVTBL vtbl_sigelem;
+EXT MGVTBL vtbl_pack;
+EXT MGVTBL vtbl_packelem;
+EXT MGVTBL vtbl_dbline;
+EXT MGVTBL vtbl_isa;
+EXT MGVTBL vtbl_isaelem;
+EXT MGVTBL vtbl_arylen;
+EXT MGVTBL vtbl_glob;
+EXT MGVTBL vtbl_mglob;
+EXT MGVTBL vtbl_nkeys;
+EXT MGVTBL vtbl_taint;
+EXT MGVTBL vtbl_substr;
+EXT MGVTBL vtbl_vec;
+EXT MGVTBL vtbl_pos;
+EXT MGVTBL vtbl_bm;
+EXT MGVTBL vtbl_fm;
+EXT MGVTBL vtbl_uvar;
#ifdef USE_THREADS
-EXT MGVTBL PL_vtbl_mutex;
+EXT MGVTBL vtbl_mutex;
#endif /* USE_THREADS */
-EXT MGVTBL PL_vtbl_defelem;
-EXT MGVTBL PL_vtbl_regexp;
-EXT MGVTBL PL_vtbl_regdata;
-EXT MGVTBL PL_vtbl_regdatum;
+EXT MGVTBL vtbl_defelem;
+EXT MGVTBL vtbl_regexp;
#ifdef USE_LOCALE_COLLATE
-EXT MGVTBL PL_vtbl_collxfrm;
+EXT MGVTBL vtbl_collxfrm;
#endif
-EXT MGVTBL PL_vtbl_amagic;
-EXT MGVTBL PL_vtbl_amagicelem;
-
-EXT MGVTBL PL_vtbl_backref;
+#ifdef OVERLOAD
+EXT MGVTBL vtbl_amagic;
+EXT MGVTBL vtbl_amagicelem;
+#endif /* OVERLOAD */
#endif /* !DOINIT */
-enum {
- fallback_amg, abs_amg,
- bool__amg, nomethod_amg,
- string_amg, numer_amg,
- add_amg, add_ass_amg,
- subtr_amg, subtr_ass_amg,
- mult_amg, mult_ass_amg,
- div_amg, div_ass_amg,
- modulo_amg, modulo_ass_amg,
- pow_amg, pow_ass_amg,
- lshift_amg, lshift_ass_amg,
- rshift_amg, rshift_ass_amg,
- band_amg, band_ass_amg,
- bor_amg, bor_ass_amg,
- bxor_amg, bxor_ass_amg,
- lt_amg, le_amg,
- gt_amg, ge_amg,
- eq_amg, ne_amg,
- ncmp_amg, scmp_amg,
- slt_amg, sle_amg,
- sgt_amg, sge_amg,
- seq_amg, sne_amg,
- not_amg, compl_amg,
- inc_amg, dec_amg,
- atan2_amg, cos_amg,
- sin_amg, exp_amg,
- log_amg, sqrt_amg,
- repeat_amg, repeat_ass_amg,
- concat_amg, concat_ass_amg,
- copy_amg, neg_amg,
- to_sv_amg, to_av_amg,
- to_hv_amg, to_gv_amg,
- to_cv_amg, iter_amg,
- max_amg_code
- /* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
-};
-
-#define NofAMmeth max_amg_code
+#ifdef OVERLOAD
+#define NofAMmeth 58
#ifdef DOINIT
-EXTCONST char * PL_AMG_names[NofAMmeth] = {
+EXTCONST char * AMG_names[NofAMmeth] = {
"fallback", "abs", /* "fallback" should be the first. */
"bool", "nomethod",
"\"\"", "0+",
@@ -2953,17 +2383,12 @@ EXTCONST char * PL_AMG_names[NofAMmeth] = {
"log", "sqrt",
"x", "x=",
".", ".=",
- "=", "neg",
- "${}", "@{}",
- "%{}", "*{}",
- "&{}", "<>",
+ "=", "neg"
};
#else
-EXTCONST char * PL_AMG_names[NofAMmeth];
+EXTCONST char * AMG_names[NofAMmeth];
#endif /* def INITAMAGIC */
-END_EXTERN_C
-
struct am_table {
long was_ok_sub;
long was_ok_am;
@@ -2988,6 +2413,37 @@ typedef struct am_table_short AMTS;
#define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC)
#define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC)
+enum {
+ fallback_amg, abs_amg,
+ bool__amg, nomethod_amg,
+ string_amg, numer_amg,
+ add_amg, add_ass_amg,
+ subtr_amg, subtr_ass_amg,
+ mult_amg, mult_ass_amg,
+ div_amg, div_ass_amg,
+ modulo_amg, modulo_ass_amg,
+ pow_amg, pow_ass_amg,
+ lshift_amg, lshift_ass_amg,
+ rshift_amg, rshift_ass_amg,
+ band_amg, band_ass_amg,
+ bor_amg, bor_ass_amg,
+ bxor_amg, bxor_ass_amg,
+ lt_amg, le_amg,
+ gt_amg, ge_amg,
+ eq_amg, ne_amg,
+ ncmp_amg, scmp_amg,
+ slt_amg, sle_amg,
+ sgt_amg, sge_amg,
+ seq_amg, sne_amg,
+ not_amg, compl_amg,
+ inc_amg, dec_amg,
+ atan2_amg, cos_amg,
+ sin_amg, exp_amg,
+ log_amg, sqrt_amg,
+ repeat_amg, repeat_ass_amg,
+ concat_amg, concat_ass_amg,
+ copy_amg, neg_amg
+};
/*
* some compilers like to redefine cos et alia as faster
@@ -3020,22 +2476,18 @@ typedef struct am_table_short AMTS;
# endif
#endif /* _FASTMATH */
-#define PERLDB_ALL (PERLDBf_SUB | PERLDBf_LINE | \
- PERLDBf_NOOPT | PERLDBf_INTER | \
- PERLDBf_SUBLINE| PERLDBf_SINGLE| \
- PERLDBf_NAMEEVAL| PERLDBf_NAMEANON)
- /* No _NONAME, _GOTO */
-#define PERLDBf_SUB 0x01 /* Debug sub enter/exit */
-#define PERLDBf_LINE 0x02 /* Keep line # */
-#define PERLDBf_NOOPT 0x04 /* Switch off optimizations */
-#define PERLDBf_INTER 0x08 /* Preserve more data for
- later inspections */
-#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines */
-#define PERLDBf_SINGLE 0x20 /* Start with single-step on */
-#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr */
-#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto */
-#define PERLDBf_NAMEEVAL 0x100 /* Informative names for evals */
-#define PERLDBf_NAMEANON 0x200 /* Informative names for anon subs */
+#endif /* OVERLOAD */
+
+#define PERLDB_ALL 0x3f /* No _NONAME, _GOTO */
+#define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */
+#define PERLDBf_LINE 0x02 /* Keep line #. */
+#define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */
+#define PERLDBf_INTER 0x08 /* Preserve more data for
+ later inspections. */
+#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */
+#define PERLDBf_SINGLE 0x20 /* Start with single-step on. */
+#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr. */
+#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto. */
#define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB))
#define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE))
@@ -3045,144 +2497,42 @@ typedef struct am_table_short AMTS;
#define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE))
#define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME)))
#define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO))
-#define PERLDB_NAMEEVAL (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL))
-#define PERLDB_NAMEANON (PL_perldb && (PL_perldb & PERLDBf_NAMEANON))
#ifdef USE_LOCALE_NUMERIC
#define SET_NUMERIC_STANDARD() \
STMT_START { \
- if (! PL_numeric_standard) \
- set_numeric_standard(); \
+ if (! PL_numeric_standard) \
+ perl_set_numeric_standard(); \
} STMT_END
#define SET_NUMERIC_LOCAL() \
STMT_START { \
if (! PL_numeric_local) \
- set_numeric_local(); \
+ perl_set_numeric_local(); \
} STMT_END
-#define IS_NUMERIC_RADIX(c) \
- ((PL_hints & HINT_LOCALE) && \
- PL_numeric_radix && (c) == PL_numeric_radix)
-
-#define RESTORE_NUMERIC_LOCAL() if ((PL_hints & HINT_LOCALE) && PL_numeric_standard) SET_NUMERIC_LOCAL()
-#define RESTORE_NUMERIC_STANDARD() if ((PL_hints & HINT_LOCALE) && PL_numeric_local) SET_NUMERIC_STANDARD()
-#define Atof my_atof
-
#else /* !USE_LOCALE_NUMERIC */
-#define SET_NUMERIC_STANDARD() /**/
-#define SET_NUMERIC_LOCAL() /**/
-#define IS_NUMERIC_RADIX(c) (0)
-#define RESTORE_NUMERIC_LOCAL() /**/
-#define RESTORE_NUMERIC_STANDARD() /**/
-#define Atof Perl_atof
+#define SET_NUMERIC_STANDARD() /**/
+#define SET_NUMERIC_LOCAL() /**/
#endif /* !USE_LOCALE_NUMERIC */
-#if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG
-# ifdef __hpux
-# define strtoll __strtoll /* secret handshake */
-# endif
-# if !defined(Strtol) && defined(HAS_STRTOLL)
-# define Strtol strtoll
-# endif
-/* is there atoq() anywhere? */
-#endif
-#if !defined(Strtol) && defined(HAS_STRTOL)
-# define Strtol strtol
-#endif
-#ifndef Atol
-/* It would be more fashionable to use Strtol() to define atol()
- * (as is done for Atoul(), see below) but for backward compatibility
- * we just assume atol(). */
-# if defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_ATOLL)
-# define Atol atoll
-# else
-# define Atol atol
-# endif
-#endif
-
-#if !defined(Strtoul) && defined(USE_64_BIT_INT) && defined(UV_IS_QUAD) && QUADKIND == QUAD_IS_LONG_LONG
-# ifdef __hpux
-# define strtoull __strtoull /* secret handshake */
-# endif
-# if !defined(Strtoul) && defined(HAS_STRTOULL)
-# define Strtoul strtoull
-# endif
-# if !defined(Strtoul) && defined(HAS_STRTOUQ)
-# define Strtoul strtouq
-# endif
-/* is there atouq() anywhere? */
-#endif
-#if !defined(Strtoul) && defined(HAS_STRTOUL)
-# define Strtoul strtoul
-#endif
-#ifndef Atoul
-# define Atoul(s) Strtoul(s, (char **)NULL, 10)
-#endif
-
#if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE)
/*
* Now we have __attribute__ out of the way
* Remap printf
*/
-#undef printf
#define printf PerlIO_stdoutf
#endif
-/* if these never got defined, they need defaults */
-#ifndef PERL_SET_CONTEXT
-# define PERL_SET_CONTEXT(i) PERL_SET_INTERP(i)
-#endif
-
-#ifndef PERL_GET_CONTEXT
-# define PERL_GET_CONTEXT PERL_GET_INTERP
-#endif
-
-#ifndef PERL_GET_THX
-# define PERL_GET_THX ((void*)NULL)
-#endif
-
-#ifndef PERL_SET_THX
-# define PERL_SET_THX(t) NOOP
-#endif
-
#ifndef PERL_SCRIPT_MODE
#define PERL_SCRIPT_MODE "r"
#endif
/*
- * Some operating systems are stingy with stack allocation,
- * so perl may have to guard against stack overflow.
- */
-#ifndef PERL_STACK_OVERFLOW_CHECK
-#define PERL_STACK_OVERFLOW_CHECK() NOOP
-#endif
-
-/*
- * Some nonpreemptive operating systems find it convenient to
- * check for asynchronous conditions after each op execution.
- * Keep this check simple, or it may slow down execution
- * massively.
- */
-#ifndef PERL_ASYNC_CHECK
-#define PERL_ASYNC_CHECK() NOOP
-#endif
-
-/*
- * On some operating systems, a memory allocation may succeed,
- * but put the process too close to the system's comfort limit.
- * In this case, PERL_ALLOC_CHECK frees the pointer and sets
- * it to NULL.
- */
-#ifndef PERL_ALLOC_CHECK
-#define PERL_ALLOC_CHECK(p) NOOP
-#endif
-
-/*
* nice_chunk and nice_chunk size need to be set
* and queried under the protection of sv_mutex
*/
@@ -3203,55 +2553,21 @@ typedef struct am_table_short AMTS;
# include <sys/sem.h>
# ifndef HAS_UNION_SEMUN /* Provide the union semun. */
union semun {
- int val;
- struct semid_ds *buf;
- unsigned short *array;
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
};
# endif
# ifdef USE_SEMCTL_SEMUN
-# ifdef IRIX32_SEMUN_BROKEN_BY_GCC
- union gccbug_semun {
- int val;
- struct semid_ds *buf;
- unsigned short *array;
- char __dummy[5];
- };
-# define semun gccbug_semun
-# endif
# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun)
# else
# ifdef USE_SEMCTL_SEMID_DS
-# ifdef EXTRA_F_IN_SEMUN_BUF
-# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buff)
-# else
-# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf)
-# endif
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf)
# endif
# endif
-#endif
-
-#ifdef I_FCNTL
-# include <fcntl.h>
-#endif
-
-#ifdef I_SYS_FILE
-# include <sys/file.h>
-#endif
-
-#ifndef O_RDONLY
-/* Assume UNIX defaults */
-# define O_RDONLY 0000
-# define O_WRONLY 0001
-# define O_RDWR 0002
-# define O_CREAT 0100
-#endif
-
-#ifndef O_BINARY
-# define O_BINARY 0
-#endif
-
-#ifndef O_TEXT
-# define O_TEXT 0
+# ifndef Semctl /* Place our bets on the semun horse. */
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun)
+# endif
#endif
#ifdef IAMSUID
@@ -3265,63 +2581,7 @@ typedef struct am_table_short AMTS;
#ifdef I_MNTENT
# include <mntent.h> /* for getmntent() */
#endif
-#ifdef I_SYS_STATFS
-# include <sys/statfs.h> /* for some statfs() */
-#endif
-#ifdef I_SYS_VFS
-# ifdef __sgi
-# define sv IRIX_sv /* kludge: IRIX has an sv of its own */
-# endif
-# include <sys/vfs.h> /* for some statfs() */
-# ifdef __sgi
-# undef IRIX_sv
-# endif
-#endif
-#ifdef I_USTAT
-# include <ustat.h> /* for ustat() */
-#endif
-
-#if !defined(PERL_MOUNT_NOSUID) && defined(MOUNT_NOSUID)
-# define PERL_MOUNT_NOSUID MOUNT_NOSUID
-#endif
-#if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
-# define PERL_MOUNT_NOSUID MNT_NOSUID
-#endif
-#if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
-# define PERL_MOUNT_NOSUID MS_NOSUID
-#endif
-#if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
-# define PERL_MOUNT_NOSUID M_NOSUID
-#endif
#endif /* IAMSUID */
-/* and finally... */
-#define PERL_PATCHLEVEL_H_IMPLICIT
-#include "patchlevel.h"
-#undef PERL_PATCHLEVEL_H_IMPLICIT
-
-/* Mention
-
- NV_PRESERVES_UV
-
- HAS_ICONV
- I_ICONV
-
- HAS_MKSTEMP
- HAS_MKSTEMPS
- HAS_MKDTEMP
-
- HAS_GETCWD
-
- HAS_MMAP
- HAS_MPROTECT
- HAS_MSYNC
- HAS_MADVISE
- HAS_MUNMAP
- I_SYSMMAN
- Mmap_t
-
- so that Configure picks them up. */
-
#endif /* Include guard */
diff --git a/contrib/perl5/pp.c b/contrib/perl5/pp.c
index a59664e4d1f8..1d4dbcc83d34 100644
--- a/contrib/perl5/pp.c
+++ b/contrib/perl5/pp.c
@@ -1,10 +1,11 @@
/* pp.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-1999, 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.
*
+ * $FreeBSD$
*/
/*
@@ -13,7 +14,6 @@
*/
#include "EXTERN.h"
-#define PERL_IN_PP_C
#include "perl.h"
/*
@@ -28,6 +28,37 @@ static double UV_MAX_cxux = ((double)UV_MAX);
#endif
/*
+ * Types used in bitwise operations.
+ *
+ * Normally we'd just use IV and UV. However, some hardware and
+ * software combinations (e.g. Alpha and current OSF/1) don't have a
+ * floating-point type to use for NV that has adequate bits to fully
+ * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
+ *
+ * It just so happens that "int" is the right size almost everywhere.
+ */
+typedef int IBW;
+typedef unsigned UBW;
+
+/*
+ * Mask used after bitwise operations.
+ *
+ * There is at least one realm (Cray word machines) that doesn't
+ * have an integral type (except char) small enough to be represented
+ * in a double without loss; that is, it has no 32-bit type.
+ */
+#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
+# define BW_BITS 32
+# define BW_MASK ((1 << BW_BITS) - 1)
+# define BW_SIGN (1 << (BW_BITS - 1))
+# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
+# define BWu(u) ((u) & BW_MASK)
+#else
+# define BWi(i) (i)
+# define BWu(u) (u)
+#endif
+
+/*
* Offset for integer pack/unpack.
*
* On architectures where I16 and I32 aren't really 16 and 32 bits,
@@ -48,14 +79,7 @@ static double UV_MAX_cxux = ((double)UV_MAX);
#define SIZE16 2
#define SIZE32 4
-/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
- --jhi Feb 1999 */
-
-#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
-# define PERL_NATINT_PACK
-#endif
-
-#if LONGSIZE > 4 && defined(_CRAY)
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
# if BYTEORDER == 0x12345678
# define OFF16(p) (char*)(p)
# define OFF32(p) (char*)(p)
@@ -69,17 +93,23 @@ static double UV_MAX_cxux = ((double)UV_MAX);
# endif
# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
-# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
#else
# define COPY16(s,p) Copy(s, p, SIZE16, char)
# define COPY32(s,p) Copy(s, p, SIZE32, char)
-# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
#endif
+#ifndef PERL_OBJECT
+static void doencodes _((SV* sv, char* s, I32 len));
+static SV* refto _((SV* sv));
+static U32 seed _((void));
+static bool srand_called = FALSE;
+#endif
+
+
/* variations on pp_null */
#ifdef I_UNISTD
@@ -155,12 +185,12 @@ PP(pp_padhv)
RETURN;
gimme = GIMME_V;
if (gimme == G_ARRAY) {
- RETURNOP(do_kv());
+ RETURNOP(do_kv(ARGS));
}
else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
if (HvFILL((HV*)TARG))
- Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
+ sv_setpvf(sv, "%ld/%ld",
(long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
else
sv_setiv(sv, 0);
@@ -171,19 +201,17 @@ PP(pp_padhv)
PP(pp_padany)
{
- DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
+ DIE("NOT IMPL LINE %d",__LINE__);
}
/* Translations. */
PP(pp_rv2gv)
{
- djSP; dTOPss;
+ djSP; dTOPss;
if (SvROK(sv)) {
wasref:
- tryAMAGICunDEREF(to_gv);
-
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV *gv = (GV*) sv_newmortal();
@@ -191,9 +219,8 @@ PP(pp_rv2gv)
GvIOp(gv) = (IO *)sv;
(void)SvREFCNT_inc(sv);
sv = (SV*) gv;
- }
- else if (SvTYPE(sv) != SVt_PVGV)
- DIE(aTHX_ "Not a GLOB reference");
+ } else if (SvTYPE(sv) != SVt_PVGV)
+ DIE("Not a GLOB reference");
}
else {
if (SvTYPE(sv) != SVt_PVGV) {
@@ -205,50 +232,18 @@ PP(pp_rv2gv)
if (SvROK(sv))
goto wasref;
}
- if (!SvOK(sv) && sv != &PL_sv_undef) {
- /* If this is a 'my' scalar and flag is set then vivify
- * NI-S 1999/05/07
- */
- if (PL_op->op_private & OPpDEREF) {
- char *name;
- GV *gv;
- if (cUNOP->op_targ) {
- STRLEN len;
- SV *namesv = PL_curpad[cUNOP->op_targ];
- name = SvPV(namesv, len);
- gv = (GV*)NEWSV(0,0);
- gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
- }
- else {
- name = CopSTASHPV(PL_curcop);
- gv = newGVgen(name);
- }
- sv_upgrade(sv, SVt_RV);
- SvRV(sv) = (SV*)gv;
- SvROK_on(sv);
- SvSETMAGIC(sv);
- goto wasref;
- }
+ if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "a symbol");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ DIE(no_usym, "a symbol");
+ if (PL_dowarn)
+ warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, n_a);
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
- if (!sv)
- RETSETUNDEF;
- }
- else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a symbol");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
- }
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a symbol");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
if (PL_op->op_private & OPpLVAL_INTRO)
@@ -263,14 +258,12 @@ PP(pp_rv2sv)
if (SvROK(sv)) {
wasref:
- tryAMAGICunDEREF(to_sv);
-
sv = SvRV(sv);
switch (SvTYPE(sv)) {
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
- DIE(aTHX_ "Not a SCALAR reference");
+ DIE("Not a SCALAR reference");
}
}
else {
@@ -287,24 +280,15 @@ PP(pp_rv2sv)
if (!SvOK(sv)) {
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_usym, "a SCALAR");
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ DIE(no_usym, "a SCALAR");
+ if (PL_dowarn)
+ warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, n_a);
- if ((PL_op->op_flags & OPf_SPECIAL) &&
- !(PL_op->op_flags & OPf_MOD))
- {
- gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
- if (!gv)
- RETSETUNDEF;
- }
- else {
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
- }
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a SCALAR");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
}
@@ -357,10 +341,7 @@ PP(pp_pos)
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
mg = mg_find(sv, 'g');
if (mg && mg->mg_len >= 0) {
- I32 i = mg->mg_len;
- if (DO_UTF8(sv))
- sv_pos_b2u(sv, &i);
- PUSHi(i + PL_curcop->cop_arybase);
+ PUSHi(mg->mg_len + PL_curcop->cop_arybase);
RETURN;
}
}
@@ -380,8 +361,6 @@ PP(pp_rv2cv)
if (cv) {
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
- if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
- DIE(aTHX_ "Can't modify non-lvalue subroutine call");
}
else
cv = (CV*)&PL_sv_undef;
@@ -411,22 +390,18 @@ PP(pp_prototype)
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
while (i < MAXO) { /* The slow way. */
- if (strEQ(s + 6, PL_op_name[i])
- || strEQ(s + 6, PL_op_desc[i]))
- {
+ if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
goto found;
- }
i++;
}
goto nonesuch; /* Should not happen... */
found:
- oa = PL_opargs[i] >> OASHIFT;
+ oa = opargs[i] >> OASHIFT;
while (oa) {
if (oa & OA_OPTIONAL) {
seen_question = 1;
str[n++] = ';';
- }
- else if (n && str[0] == ';' && seen_question)
+ } else if (seen_question)
goto set; /* XXXX system, exec */
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
@@ -437,19 +412,18 @@ PP(pp_prototype)
oa = oa >> 4;
}
str[n++] = '\0';
- ret = sv_2mortal(newSVpvn(str, n - 1));
- }
- else if (code) /* Non-Overridable */
+ ret = sv_2mortal(newSVpv(str, n - 1));
+ } else if (code) /* Non-Overridable */
goto set;
else { /* None such */
nonesuch:
- DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
+ croak("Cannot find an opnumber for \"%s\"", s+6);
}
}
}
cv = sv_2cv(TOPs, &stash, &gv, FALSE);
if (cv && SvPOK(cv))
- ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
+ ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
set:
SETs(ret);
RETURN;
@@ -492,7 +466,7 @@ PP(pp_refgen)
}
STATIC SV*
-S_refto(pTHX_ SV *sv)
+refto(SV *sv)
{
SV* rv;
@@ -501,14 +475,6 @@ S_refto(pTHX_ SV *sv)
vivify_defelem(sv);
if (!(sv = LvTARG(sv)))
sv = &PL_sv_undef;
- else
- (void)SvREFCNT_inc(sv);
- }
- else if (SvTYPE(sv) == SVt_PVAV) {
- if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
- av_reify((AV*)sv);
- SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
}
else if (SvPADTMP(sv))
sv = newSVsv(sv);
@@ -549,14 +515,13 @@ PP(pp_bless)
HV *stash;
if (MAXARG == 1)
- stash = CopSTASH(PL_curcop);
+ stash = PL_curcop->cop_stash;
else {
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
- if (ckWARN(WARN_MISC) && len == 0)
- Perl_warner(aTHX_ WARN_MISC,
- "Explicit blessing to '' (assuming package main)");
+ if (PL_dowarn && len == 0)
+ warn("Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
@@ -572,7 +537,7 @@ PP(pp_gelem)
char *elem;
djSP;
STRLEN n_a;
-
+
sv = POPs;
elem = SvPV(sv, n_a);
gv = (GV*)POPs;
@@ -606,7 +571,7 @@ PP(pp_gelem)
break;
case 'N':
if (strEQ(elem, "NAME"))
- sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
+ sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
break;
case 'P':
if (strEQ(elem, "PACKAGE"))
@@ -632,6 +597,7 @@ PP(pp_gelem)
PP(pp_study)
{
djSP; dPOPss;
+ register UNOP *unop = cUNOP;
register unsigned char *s;
register I32 pos;
register I32 ch;
@@ -671,7 +637,7 @@ PP(pp_study)
snext = PL_screamnext;
if (!sfirst || !snext)
- DIE(aTHX_ "do_study: out of memory");
+ DIE("do_study: out of memory");
for (ch = 256; ch; --ch)
*sfirst++ = -1;
@@ -703,7 +669,7 @@ PP(pp_trans)
EXTEND(SP,1);
}
TARG = sv_newmortal();
- PUSHi(do_trans(sv));
+ PUSHi(do_trans(sv, PL_op));
RETURN;
}
@@ -788,8 +754,15 @@ PP(pp_undef)
if (!sv)
RETPUSHUNDEF;
- if (SvTHINKFIRST(sv))
- sv_force_normal(sv);
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (PL_curcop != &PL_compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
switch (SvTYPE(sv)) {
case SVt_NULL:
@@ -801,17 +774,14 @@ PP(pp_undef)
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
- Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
+ if (PL_dowarn && cv_const_sv((CV*)sv))
+ warn("Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
- {
- /* let user-undef'd sub keep its identity */
- GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
- cv_undef((CV*)sv);
- CvGV((CV*)sv) = gv;
- }
+ { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
+ cv_undef((CV*)sv);
+ CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
break;
case SVt_PVGV:
if (SvFAKE(sv))
@@ -822,7 +792,7 @@ PP(pp_undef)
Newz(602, gp, 1, GP);
GvGP(sv) = gp_ref(gp);
GvSV(sv) = NEWSV(72,0);
- GvLINE(sv) = CopLINE(PL_curcop);
+ GvLINE(sv) = PL_curcop->cop_line;
GvEGV(sv) = (GV*)sv;
GvMULTI_on(sv);
}
@@ -845,8 +815,8 @@ PP(pp_predec)
{
djSP;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ croak(no_modify);
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
--SvIVX(TOPs);
@@ -862,9 +832,9 @@ PP(pp_postinc)
{
djSP; dTARGET;
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
+ croak(no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MAX)
{
++SvIVX(TOPs);
@@ -882,10 +852,10 @@ PP(pp_postinc)
PP(pp_postdec)
{
djSP; dTARGET;
- if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
- DIE(aTHX_ PL_no_modify);
+ if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
SvIVX(TOPs) != IV_MIN)
{
--SvIVX(TOPs);
@@ -905,7 +875,7 @@ PP(pp_pow)
djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
dPOPTOPnnrl;
- SETn( Perl_pow( left, right) );
+ SETn( pow( left, right) );
RETURN;
}
}
@@ -925,19 +895,18 @@ PP(pp_divide)
djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
dPOPPOPnnrl;
- NV value;
+ double value;
if (right == 0.0)
- DIE(aTHX_ "Illegal division by zero");
+ DIE("Illegal division by zero");
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
IV k;
- if ((NV)I_V(left) == left &&
- (NV)I_V(right) == right &&
+ if ((double)I_V(left) == left &&
+ (double)I_V(right) == right &&
(k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
value = k;
- }
- else {
+ } else {
value = left / right;
}
}
@@ -953,99 +922,48 @@ PP(pp_modulo)
{
djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
{
- UV left;
- UV right;
- bool left_neg;
- bool right_neg;
- bool use_double = 0;
- NV dright;
- NV dleft;
-
- if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- IV i = SvIVX(POPs);
- right = (right_neg = (i < 0)) ? -i : i;
- }
- else {
- dright = POPn;
- use_double = 1;
- right_neg = dright < 0;
- if (right_neg)
- dright = -dright;
- }
-
- if (!use_double && SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
- IV i = SvIVX(POPs);
- left = (left_neg = (i < 0)) ? -i : i;
- }
- else {
- dleft = POPn;
- if (!use_double) {
- use_double = 1;
- dright = right;
- }
- left_neg = dleft < 0;
- if (left_neg)
- dleft = -dleft;
- }
-
- if (use_double) {
- NV dans;
-
-#if 1
-/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
-# if CASTFLAGS & 2
-# define CAST_D2UV(d) U_V(d)
-# else
-# define CAST_D2UV(d) ((UV)(d))
-# endif
- /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
- * or, in other words, precision of UV more than of NV.
- * But in fact the approach below turned out to be an
- * optimization - floor() may be slow */
- if (dright <= UV_MAX && dleft <= UV_MAX) {
- right = CAST_D2UV(dright);
- left = CAST_D2UV(dleft);
- goto do_uv;
- }
-#endif
-
- /* Backward-compatibility clause: */
- dright = Perl_floor(dright + 0.5);
- dleft = Perl_floor(dleft + 0.5);
+ UV left;
+ UV right;
+ bool left_neg;
+ bool right_neg;
+ UV ans;
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ right = (right_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ double n = POPn;
+ right = U_V((right_neg = (n < 0)) ? -n : n);
+ }
- if (!dright)
- DIE(aTHX_ "Illegal modulus zero");
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ left = (left_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ double n = POPn;
+ left = U_V((left_neg = (n < 0)) ? -n : n);
+ }
- dans = Perl_fmod(dleft, dright);
- if ((left_neg != right_neg) && dans)
- dans = dright - dans;
- if (right_neg)
- dans = -dans;
- sv_setnv(TARG, dans);
- }
- else {
- UV ans;
-
- do_uv:
- if (!right)
- DIE(aTHX_ "Illegal modulus zero");
-
- ans = left % right;
- if ((left_neg != right_neg) && ans)
- ans = right - ans;
- if (right_neg) {
- /* XXX may warn: unary minus operator applied to unsigned type */
- /* could change -foo to be (~foo)+1 instead */
- if (ans <= ~((UV)IV_MAX)+1)
- sv_setiv(TARG, ~ans+1);
- else
- sv_setnv(TARG, -(NV)ans);
- }
- else
- sv_setuv(TARG, ans);
- }
- PUSHTARG;
- RETURN;
+ if (!right)
+ DIE("Illegal modulus zero");
+
+ ans = left % right;
+ if ((left_neg != right_neg) && ans)
+ ans = right - ans;
+ if (right_neg) {
+ /* XXX may warn: unary minus operator applied to unsigned type */
+ /* could change -foo to be (~foo)+1 instead */
+ if (ans <= ~((UV)IV_MAX)+1)
+ sv_setiv(TARG, ~ans+1);
+ else
+ sv_setnv(TARG, -(double)ans);
+ }
+ else
+ sv_setuv(TARG, ans);
+ PUSHTARG;
+ RETURN;
}
}
@@ -1080,6 +998,12 @@ PP(pp_repeat)
STRLEN len;
tmpstr = POPs;
+ if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
+ if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
+ DIE("Can't x= to readonly value");
+ if (SvROK(tmpstr))
+ sv_unref(tmpstr);
+ }
SvSetSV(TARG, tmpstr);
SvPV_force(TARG, len);
if (count != 1) {
@@ -1113,14 +1037,16 @@ PP(pp_left_shift)
{
djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
- IV shift = POPi;
+ IBW shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IV i = TOPi;
- SETi(i << shift);
+ IBW i = TOPi;
+ i = BWi(i) << shift;
+ SETi(BWi(i));
}
else {
- UV u = TOPu;
- SETu(u << shift);
+ UBW u = TOPu;
+ u <<= shift;
+ SETu(BWu(u));
}
RETURN;
}
@@ -1130,14 +1056,16 @@ PP(pp_right_shift)
{
djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
- IV shift = POPi;
+ IBW shift = POPi;
if (PL_op->op_private & HINT_INTEGER) {
- IV i = TOPi;
- SETi(i >> shift);
+ IBW i = TOPi;
+ i = BWi(i) >> shift;
+ SETi(BWi(i));
}
else {
- UV u = TOPu;
- SETu(u >> shift);
+ UBW u = TOPu;
+ u >>= shift;
+ SETu(BWu(u));
}
RETURN;
}
@@ -1199,21 +1127,7 @@ PP(pp_ncmp)
{
dPOPTOPnnrl;
I32 value;
-#ifdef __osf__ /* XXX Configure probe for isnan and isnanl needed XXX */
-#if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
-#define Perl_isnan isnanl
-#else
-#define Perl_isnan isnan
-#endif
-#endif
-#ifdef __osf__ /* XXX fix in 5.6.1 --jhi */
- if (Perl_isnan(left) || Perl_isnan(right)) {
- SETs(&PL_sv_undef);
- RETURN;
- }
- value = (left > right) - (left < right);
-#else
if (left == right)
value = 0;
else if (left < right)
@@ -1224,7 +1138,6 @@ PP(pp_ncmp)
SETs(&PL_sv_undef);
RETURN;
}
-#endif
SETi(value);
RETURN;
}
@@ -1322,12 +1235,12 @@ PP(pp_bit_and)
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = SvIV(left) & SvIV(right);
- SETi(i);
+ IBW value = SvIV(left) & SvIV(right);
+ SETi(BWi(value));
}
else {
- UV u = SvUV(left) & SvUV(right);
- SETu(u);
+ UBW value = SvUV(left) & SvUV(right);
+ SETu(BWu(value));
}
}
else {
@@ -1345,12 +1258,12 @@ PP(pp_bit_xor)
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
- SETi(i);
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ SETi(BWi(value));
}
else {
- UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
- SETu(u);
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ SETu(BWu(value));
}
}
else {
@@ -1368,12 +1281,12 @@ PP(pp_bit_or)
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
- SETi(i);
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ SETi(BWi(value));
}
else {
- UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
- SETu(u);
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ SETu(BWu(value));
}
}
else {
@@ -1391,23 +1304,9 @@ PP(pp_negate)
dTOPss;
if (SvGMAGICAL(sv))
mg_get(sv);
- if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
- if (SvIsUV(sv)) {
- if (SvIVX(sv) == IV_MIN) {
- SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
- RETURN;
- }
- else if (SvUVX(sv) <= IV_MAX) {
- SETi(-SvIVX(sv));
- RETURN;
- }
- }
- else if (SvIVX(sv) != IV_MIN) {
- SETi(-SvIVX(sv));
- RETURN;
- }
- }
- if (SvNIOKp(sv))
+ if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
+ SETi(-SvIVX(sv));
+ else if (SvNIOKp(sv))
SETn(-SvNV(sv));
else if (SvPOKp(sv)) {
STRLEN len;
@@ -1420,10 +1319,6 @@ PP(pp_negate)
sv_setsv(TARG, sv);
*SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
}
- else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
- sv_setpvn(TARG, "-", 1);
- sv_catsv(TARG, sv);
- }
else
sv_setnv(TARG, -SvNV(sv));
SETTARG;
@@ -1436,7 +1331,9 @@ PP(pp_negate)
PP(pp_not)
{
+#ifdef OVERLOAD
djSP; tryAMAGICunSET(not);
+#endif /* OVERLOAD */
*PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
return NORMAL;
}
@@ -1448,12 +1345,12 @@ PP(pp_complement)
dTOPss;
if (SvNIOKp(sv)) {
if (PL_op->op_private & HINT_INTEGER) {
- IV i = ~SvIV(sv);
- SETi(i);
+ IBW value = ~SvIV(sv);
+ SETi(BWi(value));
}
else {
- UV u = ~SvUV(sv);
- SETu(u);
+ UBW value = ~SvUV(sv);
+ SETu(BWu(value));
}
}
else {
@@ -1500,7 +1397,7 @@ PP(pp_i_divide)
{
dPOPiv;
if (value == 0)
- DIE(aTHX_ "Illegal division by zero");
+ DIE("Illegal division by zero");
value = POPi / value;
PUSHi( value );
RETURN;
@@ -1513,7 +1410,7 @@ PP(pp_i_modulo)
{
dPOPTOPiirl;
if (!right)
- DIE(aTHX_ "Illegal modulus zero");
+ DIE("Illegal modulus zero");
SETi( left % right );
RETURN;
}
@@ -1631,7 +1528,7 @@ PP(pp_atan2)
djSP; dTARGET; tryAMAGICbin(atan2,0);
{
dPOPTOPnnrl;
- SETn(Perl_atan2(left, right));
+ SETn(atan2(left, right));
RETURN;
}
}
@@ -1640,9 +1537,9 @@ PP(pp_sin)
{
djSP; dTARGET; tryAMAGICun(sin);
{
- NV value;
+ double value;
value = POPn;
- value = Perl_sin(value);
+ value = sin(value);
XPUSHn(value);
RETURN;
}
@@ -1652,9 +1549,9 @@ PP(pp_cos)
{
djSP; dTARGET; tryAMAGICun(cos);
{
- NV value;
+ double value;
value = POPn;
- value = Perl_cos(value);
+ value = cos(value);
XPUSHn(value);
RETURN;
}
@@ -1666,30 +1563,40 @@ PP(pp_cos)
compatibility by calling rand() but allow the user to override it.
See INSTALL for details. --Andy Dougherty 15 July 1998
*/
-/* Now it's after 5.005, and Configure supports drand48() and random(),
- in addition to rand(). So the overrides should not be needed any more.
- --Jarkko Hietaniemi 27 September 1998
- */
-
-#ifndef HAS_DRAND48_PROTO
-extern double drand48 (void);
+#ifndef my_rand
+# define my_rand rand
+#endif
+#ifndef my_srand
+# define my_srand srand
#endif
PP(pp_rand)
{
djSP; dTARGET;
- NV value;
+ double value;
if (MAXARG < 1)
value = 1.0;
else
value = POPn;
if (value == 0.0)
value = 1.0;
- if (!PL_srand_called) {
- (void)seedDrand01((Rand_seed_t)seed());
- PL_srand_called = TRUE;
+ if (!srand_called) {
+ (void)my_srand((unsigned)seed());
+ srand_called = TRUE;
}
- value *= Drand01();
+#if RANDBITS == 31
+ value = my_rand() * value / 2147483648.0;
+#else
+#if RANDBITS == 16
+ value = my_rand() * value / 65536.0;
+#else
+#if RANDBITS == 15
+ value = my_rand() * value / 32768.0;
+#else
+ value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
+#endif
+#endif
+#endif
XPUSHn(value);
RETURN;
}
@@ -1702,22 +1609,22 @@ PP(pp_srand)
anum = seed();
else
anum = POPu;
- (void)seedDrand01((Rand_seed_t)anum);
- PL_srand_called = TRUE;
+ (void)my_srand((unsigned)anum);
+ srand_called = TRUE;
EXTEND(SP, 1);
RETPUSHYES;
}
STATIC U32
-S_seed(pTHX)
+seed(void)
{
/*
* This is really just a quick hack which grabs various garbage
* values. It really should be a real hash algorithm which
* spreads the effect of every input bit onto every output bit,
- * if someone who knows about such things would bother to write it.
+ * if someone who knows about such tings would bother to write it.
* Might be a good idea to add that function to CORE as well.
- * No numbers below come from careful analysis or anything here,
+ * No numbers below come from careful analysis or anyting here,
* except they are primes and SEED_C1 > 1E6 to get a full-width
* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
* probably be bigger too.
@@ -1782,10 +1689,10 @@ S_seed(pTHX)
u = (U32)SEED_C1 * when;
# endif
#endif
- u += SEED_C3 * (U32)PerlProc_getpid();
- u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
+ u += SEED_C3 * (U32)getpid();
+ u += SEED_C4 * (U32)(UV)PL_stack_sp;
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
- u += SEED_C5 * (U32)PTR2UV(&when);
+ u += SEED_C5 * (U32)(UV)&when;
#endif
return u;
}
@@ -1794,9 +1701,9 @@ PP(pp_exp)
{
djSP; dTARGET; tryAMAGICun(exp);
{
- NV value;
+ double value;
value = POPn;
- value = Perl_exp(value);
+ value = exp(value);
XPUSHn(value);
RETURN;
}
@@ -1806,13 +1713,13 @@ PP(pp_log)
{
djSP; dTARGET; tryAMAGICun(log);
{
- NV value;
+ double value;
value = POPn;
if (value <= 0.0) {
- RESTORE_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %g", value);
+ SET_NUMERIC_STANDARD();
+ DIE("Can't take log of %g", value);
}
- value = Perl_log(value);
+ value = log(value);
XPUSHn(value);
RETURN;
}
@@ -1822,13 +1729,13 @@ PP(pp_sqrt)
{
djSP; dTARGET; tryAMAGICun(sqrt);
{
- NV value;
+ double value;
value = POPn;
if (value < 0.0) {
- RESTORE_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %g", value);
+ SET_NUMERIC_STANDARD();
+ DIE("Can't take sqrt of %g", value);
}
- value = Perl_sqrt(value);
+ value = sqrt(value);
XPUSHn(value);
RETURN;
}
@@ -1838,7 +1745,7 @@ PP(pp_int)
{
djSP; dTARGET;
{
- NV value = TOPn;
+ double value = TOPn;
IV iv;
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
@@ -1847,9 +1754,9 @@ PP(pp_int)
}
else {
if (value >= 0.0)
- (void)Perl_modf(value, &value);
+ (void)modf(value, &value);
else {
- (void)Perl_modf(-value, &value);
+ (void)modf(-value, &value);
value = -value;
}
iv = I_V(value);
@@ -1866,7 +1773,7 @@ PP(pp_abs)
{
djSP; dTARGET; tryAMAGICun(abs);
{
- NV value = TOPn;
+ double value = TOPn;
IV iv;
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
@@ -1892,14 +1799,14 @@ PP(pp_hex)
STRLEN n_a;
tmps = POPpx;
- XPUSHn(scan_hex(tmps, 99, &argtype));
+ XPUSHu(scan_hex(tmps, 99, &argtype));
RETURN;
}
PP(pp_oct)
{
djSP; dTARGET;
- NV value;
+ UV value;
I32 argtype;
char *tmps;
STRLEN n_a;
@@ -1911,11 +1818,9 @@ PP(pp_oct)
tmps++;
if (*tmps == 'x')
value = scan_hex(++tmps, 99, &argtype);
- else if (*tmps == 'b')
- value = scan_bin(++tmps, 99, &argtype);
else
value = scan_oct(tmps, 99, &argtype);
- XPUSHn(value);
+ XPUSHu(value);
RETURN;
}
@@ -1924,12 +1829,7 @@ PP(pp_oct)
PP(pp_length)
{
djSP; dTARGET;
- SV *sv = TOPs;
-
- if (DO_UTF8(sv))
- SETi(sv_len_utf8(sv));
- else
- SETi(sv_len(sv));
+ SETi( sv_len(TOPs) );
RETURN;
}
@@ -1939,7 +1839,6 @@ PP(pp_substr)
SV *sv;
I32 len;
STRLEN curlen;
- STRLEN utfcurlen;
I32 pos;
I32 rem;
I32 fail;
@@ -1950,7 +1849,6 @@ PP(pp_substr)
STRLEN repl_len;
SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
if (MAXARG > 2) {
if (MAXARG > 3) {
sv = POPs;
@@ -1962,16 +1860,6 @@ PP(pp_substr)
sv = POPs;
PUTBACK;
tmps = SvPV(sv, curlen);
- if (DO_UTF8(sv)) {
- utfcurlen = sv_len_utf8(sv);
- if (utfcurlen == curlen)
- utfcurlen = 0;
- else
- curlen = utfcurlen;
- }
- else
- utfcurlen = 0;
-
if (pos >= arybase) {
pos -= arybase;
rem = curlen-pos;
@@ -2006,29 +1894,20 @@ PP(pp_substr)
rem -= pos;
}
if (fail < 0) {
- if (lvalue || repl)
- Perl_croak(aTHX_ "substr outside of string");
- if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
+ if (PL_dowarn || lvalue || repl)
+ warn("substr outside of string");
RETPUSHUNDEF;
}
else {
- if (utfcurlen) {
- sv_pos_u2b(sv, &pos, &rem);
- SvUTF8_on(TARG);
- }
tmps += pos;
sv_setpvn(TARG, tmps, rem);
- if (repl)
- sv_insert(sv, pos, rem, repl, repl_len);
- else if (lvalue) { /* it's an lvalue! */
+ if (lvalue) { /* it's an lvalue! */
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
STRLEN n_a;
SvPV_force(sv,n_a);
- if (ckWARN(WARN_SUBSTR))
- Perl_warner(aTHX_ WARN_SUBSTR,
- "Attempt to use reference as lvalue in substr");
+ if (PL_dowarn)
+ warn("Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only(sv);
@@ -2050,6 +1929,8 @@ PP(pp_substr)
LvTARGOFF(TARG) = pos;
LvTARGLEN(TARG) = rem;
}
+ else if (repl)
+ sv_insert(sv, pos, rem, repl, repl_len);
}
SPAGAIN;
PUSHs(TARG); /* avoid SvSETMAGIC here */
@@ -2063,24 +1944,74 @@ PP(pp_vec)
register I32 offset = POPi;
register SV *src = POPs;
I32 lvalue = PL_op->op_flags & OPf_MOD;
+ STRLEN srclen;
+ unsigned char *s = (unsigned char*)SvPV(src, srclen);
+ unsigned long retnum;
+ I32 len;
- SvTAINTED_off(TARG); /* decontaminate */
- if (lvalue) { /* it's an lvalue! */
- if (SvTYPE(TARG) < SVt_PVLV) {
- sv_upgrade(TARG, SVt_PVLV);
- sv_magic(TARG, Nullsv, 'v', Nullch, 0);
+ SvTAINTED_off(TARG); /* decontaminate */
+ offset *= size; /* turn into bit offset */
+ len = (offset + size + 7) / 8;
+ if (offset < 0 || size < 1)
+ retnum = 0;
+ else {
+ if (lvalue) { /* it's an lvalue! */
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, 'v', Nullch, 0);
+ }
+
+ LvTYPE(TARG) = 'v';
+ if (LvTARG(TARG) != src) {
+ if (LvTARG(TARG))
+ SvREFCNT_dec(LvTARG(TARG));
+ LvTARG(TARG) = SvREFCNT_inc(src);
+ }
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
}
- LvTYPE(TARG) = 'v';
- if (LvTARG(TARG) != src) {
- if (LvTARG(TARG))
- SvREFCNT_dec(LvTARG(TARG));
- LvTARG(TARG) = SvREFCNT_inc(src);
+ if (len > srclen) {
+ if (size <= 8)
+ retnum = 0;
+ else {
+ offset >>= 3;
+ if (size == 16) {
+ if (offset >= srclen)
+ retnum = 0;
+ else
+ retnum = (unsigned long) s[offset] << 8;
+ }
+ else if (size == 32) {
+ if (offset >= srclen)
+ retnum = 0;
+ else if (offset + 1 >= srclen)
+ retnum = (unsigned long) s[offset] << 24;
+ else if (offset + 2 >= srclen)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16);
+ else
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8);
+ }
+ }
+ }
+ else if (size < 8)
+ retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+ else {
+ offset >>= 3;
+ if (size == 8)
+ retnum = s[offset];
+ else if (size == 16)
+ retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
}
- LvTARGOFF(TARG) = offset;
- LvTARGLEN(TARG) = size;
}
- sv_setuv(TARG, do_vecget(src, offset, size));
+ sv_setuv(TARG, (UV)retnum);
PUSHs(TARG);
RETURN;
}
@@ -2104,20 +2035,16 @@ PP(pp_index)
little = POPs;
big = POPs;
tmps = SvPV(big, biglen);
- if (offset > 0 && DO_UTF8(big))
- sv_pos_u2b(big, &offset, 0);
if (offset < 0)
offset = 0;
else if (offset > biglen)
offset = biglen;
if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
(unsigned char*)tmps + biglen, little, 0)))
- retval = -1;
+ retval = -1 + arybase;
else
- retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
- sv_pos_b2u(big, &retval);
- PUSHi(retval + arybase);
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
RETURN;
}
@@ -2128,6 +2055,7 @@ PP(pp_rindex)
SV *little;
STRLEN blen;
STRLEN llen;
+ SV *offstr;
I32 offset;
I32 retval;
char *tmps;
@@ -2135,36 +2063,37 @@ PP(pp_rindex)
I32 arybase = PL_curcop->cop_arybase;
if (MAXARG >= 3)
- offset = POPi;
+ offstr = POPs;
little = POPs;
big = POPs;
tmps2 = SvPV(little, llen);
tmps = SvPV(big, blen);
if (MAXARG < 3)
offset = blen;
- else {
- if (offset > 0 && DO_UTF8(big))
- sv_pos_u2b(big, &offset, 0);
- offset = offset - arybase + llen;
- }
+ else
+ offset = SvIV(offstr) - arybase + llen;
if (offset < 0)
offset = 0;
else if (offset > blen)
offset = blen;
if (!(tmps2 = rninstr(tmps, tmps + offset,
tmps2, tmps2 + llen)))
- retval = -1;
+ retval = -1 + arybase;
else
- retval = tmps2 - tmps;
- if (retval > 0 && DO_UTF8(big))
- sv_pos_b2u(big, &retval);
- PUSHi(retval + arybase);
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
RETURN;
}
PP(pp_sprintf)
{
djSP; dMARK; dORIGMARK; dTARGET;
+#ifdef USE_LOCALE_NUMERIC
+ if (PL_op->op_private & OPpLOCALE)
+ SET_NUMERIC_LOCAL();
+ else
+ SET_NUMERIC_STANDARD();
+#endif
do_sprintf(TARG, SP-MARK, MARK+1);
TAINT_IF(SvTAINTED(TARG));
SP = ORIGMARK;
@@ -2175,17 +2104,20 @@ PP(pp_sprintf)
PP(pp_ord)
{
djSP; dTARGET;
- UV value;
+ I32 value;
+ char *tmps;
STRLEN n_a;
- SV *tmpsv = POPs;
- U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
- I32 retlen;
- if ((*tmps & 0x80) && DO_UTF8(tmpsv))
- value = utf8_to_uv(tmps, &retlen);
- else
- value = (UV)(*tmps & 255);
- XPUSHu(value);
+#ifndef I286
+ tmps = POPpx;
+ value = (I32) (*tmps & 255);
+#else
+ I32 anum;
+ tmps = POPpx;
+ anum = (I32) *tmps;
+ value = (I32) (anum & 255);
+#endif
+ XPUSHi(value);
RETURN;
}
@@ -2193,28 +2125,13 @@ PP(pp_chr)
{
djSP; dTARGET;
char *tmps;
- U32 value = POPu;
(void)SvUPGRADE(TARG,SVt_PV);
-
- if (value > 255 && !IN_BYTE) {
- SvGROW(TARG, UTF8_MAXLEN+1);
- tmps = SvPVX(TARG);
- tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
- SvCUR_set(TARG, tmps - SvPVX(TARG));
- *tmps = '\0';
- (void)SvPOK_only(TARG);
- SvUTF8_on(TARG);
- XPUSHs(TARG);
- RETURN;
- }
-
SvGROW(TARG,2);
SvCUR_set(TARG, 1);
tmps = SvPVX(TARG);
- *tmps++ = value;
+ *tmps++ = POPi;
*tmps = '\0';
- SvUTF8_off(TARG); /* decontaminate */
(void)SvPOK_only(TARG);
XPUSHs(TARG);
RETURN;
@@ -2232,7 +2149,7 @@ PP(pp_crypt)
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
#endif
#else
- DIE(aTHX_
+ DIE(
"The crypt() function is unimplemented due to excessive paranoia.");
#endif
SETs(TARG);
@@ -2243,55 +2160,24 @@ PP(pp_ucfirst)
{
djSP;
SV *sv = TOPs;
- register U8 *s;
- STRLEN slen;
-
- if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
- I32 ulen;
- U8 tmpbuf[UTF8_MAXLEN];
- U8 *tend;
- UV uv = utf8_to_uv(s, &ulen);
+ register char *s;
+ STRLEN n_a;
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, n_a);
+ if (*s) {
if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
- uv = toTITLE_LC_uni(uv);
+ *s = toUPPER_LC(*s);
}
else
- uv = toTITLE_utf8(s);
-
- tend = uv_to_utf8(tmpbuf, uv);
-
- if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
- dTARGET;
- sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
- SvUTF8_on(TARG);
- SETs(TARG);
- }
- else {
- s = (U8*)SvPV_force(sv, slen);
- Copy(tmpbuf, s, ulen, U8);
- }
- }
- else {
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toUPPER_LC(*s);
- }
- else
- *s = toUPPER(*s);
- }
+ *s = toUPPER(*s);
}
if (SvSMAGICAL(sv))
mg_set(sv);
@@ -2302,56 +2188,27 @@ PP(pp_lcfirst)
{
djSP;
SV *sv = TOPs;
- register U8 *s;
- STRLEN slen;
-
- if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
- I32 ulen;
- U8 tmpbuf[UTF8_MAXLEN];
- U8 *tend;
- UV uv = utf8_to_uv(s, &ulen);
+ register char *s;
+ STRLEN n_a;
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, n_a);
+ if (*s) {
if (PL_op->op_private & OPpLOCALE) {
TAINT;
SvTAINTED_on(sv);
- uv = toLOWER_LC_uni(uv);
+ *s = toLOWER_LC(*s);
}
else
- uv = toLOWER_utf8(s);
-
- tend = uv_to_utf8(tmpbuf, uv);
-
- if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
- dTARGET;
- sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
- sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
- SvUTF8_on(TARG);
- SETs(TARG);
- }
- else {
- s = (U8*)SvPV_force(sv, slen);
- Copy(tmpbuf, s, ulen, U8);
- }
- }
- else {
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, slen);
- if (*s) {
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- *s = toLOWER_LC(*s);
- }
- else
- *s = toLOWER(*s);
- }
+ *s = toLOWER(*s);
}
+
+ SETs(sv);
if (SvSMAGICAL(sv))
mg_set(sv);
RETURN;
@@ -2361,69 +2218,29 @@ PP(pp_uc)
{
djSP;
SV *sv = TOPs;
- register U8 *s;
+ register char *s;
STRLEN len;
- if (DO_UTF8(sv)) {
+ if (!SvPADTMP(sv)) {
dTARGET;
- I32 ulen;
- register U8 *d;
- U8 *send;
-
- s = (U8*)SvPV(sv,len);
- if (!len) {
- SvUTF8_off(TARG); /* decontaminate */
- sv_setpvn(TARG, "", 0);
- SETs(TARG);
- }
- else {
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
- s += ulen;
- }
- }
- else {
- while (s < send) {
- d = uv_to_utf8(d, toUPPER_utf8( s ));
- s += UTF8SKIP(s);
- }
- }
- *d = '\0';
- SvUTF8_on(TARG);
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
- SETs(TARG);
- }
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- else {
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
+
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *send = s + len;
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toUPPER_LC(*s);
}
- s = (U8*)SvPV_force(sv, len);
- if (len) {
- register U8 *send = s + len;
-
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toUPPER_LC(*s);
- }
- else {
- for (; s < send; s++)
- *s = toUPPER(*s);
- }
+ else {
+ for (; s < send; s++)
+ *s = toUPPER(*s);
}
}
if (SvSMAGICAL(sv))
@@ -2435,70 +2252,29 @@ PP(pp_lc)
{
djSP;
SV *sv = TOPs;
- register U8 *s;
+ register char *s;
STRLEN len;
- if (DO_UTF8(sv)) {
+ if (!SvPADTMP(sv)) {
dTARGET;
- I32 ulen;
- register U8 *d;
- U8 *send;
-
- s = (U8*)SvPV(sv,len);
- if (!len) {
- SvUTF8_off(TARG); /* decontaminate */
- sv_setpvn(TARG, "", 0);
- SETs(TARG);
- }
- else {
- (void)SvUPGRADE(TARG, SVt_PV);
- SvGROW(TARG, (len * 2) + 1);
- (void)SvPOK_only(TARG);
- d = (U8*)SvPVX(TARG);
- send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(TARG);
- while (s < send) {
- d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
- s += ulen;
- }
- }
- else {
- while (s < send) {
- d = uv_to_utf8(d, toLOWER_utf8(s));
- s += UTF8SKIP(s);
- }
- }
- *d = '\0';
- SvUTF8_on(TARG);
- SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
- SETs(TARG);
- }
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
}
- else {
- if (!SvPADTMP(sv) || SvREADONLY(sv)) {
- dTARGET;
- SvUTF8_off(TARG); /* decontaminate */
- sv_setsv(TARG, sv);
- sv = TARG;
- SETs(sv);
- }
- s = (U8*)SvPV_force(sv, len);
- if (len) {
- register U8 *send = s + len;
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *send = s + len;
- if (PL_op->op_private & OPpLOCALE) {
- TAINT;
- SvTAINTED_on(sv);
- for (; s < send; s++)
- *s = toLOWER_LC(*s);
- }
- else {
- for (; s < send; s++)
- *s = toLOWER(*s);
- }
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toLOWER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toLOWER(*s);
}
}
if (SvSMAGICAL(sv))
@@ -2514,36 +2290,14 @@ PP(pp_quotemeta)
register char *s = SvPV(sv,len);
register char *d;
- SvUTF8_off(TARG); /* decontaminate */
if (len) {
(void)SvUPGRADE(TARG, SVt_PV);
SvGROW(TARG, (len * 2) + 1);
d = SvPVX(TARG);
- if (DO_UTF8(sv)) {
- while (len) {
- if (*s & 0x80) {
- STRLEN ulen = UTF8SKIP(s);
- if (ulen > len)
- ulen = len;
- len -= ulen;
- while (ulen--)
- *d++ = *s++;
- }
- else {
- if (!isALNUM(*s))
- *d++ = '\\';
- *d++ = *s++;
- len--;
- }
- }
- SvUTF8_on(TARG);
- }
- else {
- while (len--) {
- if (!isALNUM(*s))
- *d++ = '\\';
- *d++ = *s++;
- }
+ while (len--) {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
}
*d = '\0';
SvCUR_set(TARG, d - SvPVX(TARG));
@@ -2587,7 +2341,7 @@ PP(pp_aslice)
svp = av_fetch(av, elem, lval);
if (lval) {
if (!svp || *svp == &PL_sv_undef)
- DIE(aTHX_ PL_no_aelem, elem);
+ DIE(no_aelem, elem);
if (PL_op->op_private & OPpLVAL_INTRO)
save_aelem(av, elem, svp);
}
@@ -2606,7 +2360,7 @@ PP(pp_aslice)
PP(pp_each)
{
- djSP;
+ djSP; dTARGET;
HV *hash = (HV*)POPs;
HE *entry;
I32 gimme = GIMME_V;
@@ -2621,13 +2375,12 @@ PP(pp_each)
if (entry) {
PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (gimme == G_ARRAY) {
- SV *val;
PUTBACK;
/* might clobber stack_sp */
- val = realhv ?
- hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
+ sv_setsv(TARG, realhv ?
+ hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
SPAGAIN;
- PUSHs(val);
+ PUSHs(TARG);
}
}
else if (gimme == G_SCALAR)
@@ -2638,12 +2391,12 @@ PP(pp_each)
PP(pp_values)
{
- return do_kv();
+ return do_kv(ARGS);
}
PP(pp_keys)
{
- return do_kv();
+ return do_kv(ARGS);
}
PP(pp_delete)
@@ -2659,28 +2412,13 @@ PP(pp_delete)
U32 hvtype;
hv = (HV*)POPs;
hvtype = SvTYPE(hv);
- if (hvtype == SVt_PVHV) { /* hash element */
- while (++MARK <= SP) {
+ while (++MARK <= SP) {
+ if (hvtype == SVt_PVHV)
sv = hv_delete_ent(hv, *MARK, discard, 0);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
- else if (hvtype == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- while (++MARK <= SP) {
- sv = av_delete((AV*)hv, SvIV(*MARK), discard);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
- else { /* pseudo-hash element */
- while (++MARK <= SP) {
- sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
- *MARK = sv ? sv : &PL_sv_undef;
- }
- }
+ else
+ DIE("Not a HASH reference");
+ *MARK = sv ? sv : &PL_sv_undef;
}
- else
- DIE(aTHX_ "Not a HASH reference");
if (discard)
SP = ORIGMARK;
else if (gimme == G_SCALAR) {
@@ -2694,14 +2432,8 @@ PP(pp_delete)
hv = (HV*)POPs;
if (SvTYPE(hv) == SVt_PVHV)
sv = hv_delete_ent(hv, keysv, discard, 0);
- else if (SvTYPE(hv) == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL)
- sv = av_delete((AV*)hv, SvIV(keysv), discard);
- else
- sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
- }
else
- DIE(aTHX_ "Not a HASH reference");
+ DIE("Not a HASH reference");
if (!sv)
sv = &PL_sv_undef;
if (!discard)
@@ -2713,36 +2445,16 @@ PP(pp_delete)
PP(pp_exists)
{
djSP;
- SV *tmpsv;
- HV *hv;
-
- if (PL_op->op_private & OPpEXISTS_SUB) {
- GV *gv;
- CV *cv;
- SV *sv = POPs;
- cv = sv_2cv(sv, &hv, &gv, FALSE);
- if (cv)
- RETPUSHYES;
- if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
- RETPUSHYES;
- RETPUSHNO;
- }
- tmpsv = POPs;
- hv = (HV*)POPs;
+ SV *tmpsv = POPs;
+ HV *hv = (HV*)POPs;
if (SvTYPE(hv) == SVt_PVHV) {
if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
- }
- else if (SvTYPE(hv) == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
- if (av_exists((AV*)hv, SvIV(tmpsv)))
- RETPUSHYES;
- }
- else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
+ } else if (SvTYPE(hv) == SVt_PVAV) {
+ if (avhv_exists_ent((AV*)hv, tmpsv, 0))
RETPUSHYES;
- }
- else {
- DIE(aTHX_ "Not a HASH reference");
+ } else {
+ DIE("Not a HASH reference");
}
RETPUSHNO;
}
@@ -2755,7 +2467,7 @@ PP(pp_hslice)
I32 realhv = (SvTYPE(hv) == SVt_PVHV);
if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
- DIE(aTHX_ "Can't localize pseudo-hash element");
+ DIE("Can't localize pseudo-hash element");
if (realhv || SvTYPE(hv) == SVt_PVAV) {
while (++MARK <= SP) {
@@ -2764,14 +2476,13 @@ PP(pp_hslice)
if (realhv) {
HE *he = hv_fetch_ent(hv, keysv, lval, 0);
svp = he ? &HeVAL(he) : 0;
- }
- else {
+ } else {
svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
}
if (lval) {
if (!svp || *svp == &PL_sv_undef) {
STRLEN n_a;
- DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
+ DIE(no_helem, SvPV(keysv, n_a));
}
if (PL_op->op_private & OPpLVAL_INTRO)
save_helem(hv, keysv, svp);
@@ -2838,17 +2549,20 @@ PP(pp_lslice)
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
ix = SvIVx(*lelem);
- if (ix < 0)
+ if (ix < 0) {
ix += max;
- else
- ix -= arybase;
- if (ix < 0 || ix >= max)
- *lelem = &PL_sv_undef;
+ if (ix < 0)
+ *lelem = &PL_sv_undef;
+ else if (!(*lelem = firstrelem[ix]))
+ *lelem = &PL_sv_undef;
+ }
else {
- is_something_there = TRUE;
- if (!(*lelem = firstrelem[ix]))
+ ix -= arybase;
+ if (ix >= max || !(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
}
+ if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
+ is_something_there = TRUE;
}
if (is_something_there)
SP = lastlelem;
@@ -2877,8 +2591,8 @@ PP(pp_anonhash)
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+ else if (PL_dowarn)
+ warn("Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
@@ -2901,12 +2615,12 @@ PP(pp_splice)
SV **tmparyval = 0;
MAGIC *mg;
- if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
- call_method("SPLICE",GIMME_V);
+ perl_call_method("SPLICE",GIMME_V);
LEAVE;
SPAGAIN;
RETURN;
@@ -2921,7 +2635,7 @@ PP(pp_splice)
else
offset -= PL_curcop->cop_arybase;
if (offset < 0)
- DIE(aTHX_ PL_no_aelem, i);
+ DIE(no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0) {
@@ -2951,8 +2665,12 @@ PP(pp_splice)
newlen = SP - MARK;
diff = newlen - length;
- if (newlen && !AvREAL(ary) && AvREIFY(ary))
- av_reify(ary);
+ if (newlen && !AvREAL(ary)) {
+ if (AvREIFY(ary))
+ av_reify(ary);
+ else
+ assert(AvREAL(ary)); /* would leak, so croak */
+ }
if (diff < 0) { /* shrinking the area */
if (newlen) {
@@ -3095,12 +2813,12 @@ PP(pp_push)
register SV *sv = &PL_sv_undef;
MAGIC *mg;
- if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
- call_method("PUSH",G_SCALAR|G_DISCARD);
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
}
@@ -3151,12 +2869,12 @@ PP(pp_unshift)
register I32 i = 0;
MAGIC *mg;
- if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
*MARK-- = SvTIED_obj((SV*)ary, mg);
PUSHMARK(MARK);
PUTBACK;
ENTER;
- call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
}
@@ -3186,7 +2904,6 @@ PP(pp_reverse)
*MARK++ = *SP;
*SP-- = tmp;
}
- /* safe as long as stack cannot get extended in the above */
SP = oldsp;
}
else {
@@ -3196,40 +2913,12 @@ PP(pp_reverse)
dTARGET;
STRLEN len;
- SvUTF8_off(TARG); /* decontaminate */
if (SP - MARK > 1)
do_join(TARG, &PL_sv_no, MARK, SP);
else
sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
up = SvPV_force(TARG, len);
if (len > 1) {
- if (DO_UTF8(TARG)) { /* first reverse each character */
- U8* s = (U8*)SvPVX(TARG);
- U8* send = (U8*)(s + len);
- while (s < send) {
- if (*s < 0x80) {
- s++;
- continue;
- }
- else {
- up = (char*)s;
- s += UTF8SKIP(s);
- down = (char*)(s - 1);
- if (s > send || !((*down & 0xc0) == 0x80)) {
- if (ckWARN_d(WARN_UTF8))
- Perl_warner(aTHX_ WARN_UTF8,
- "Malformed UTF-8 character");
- break;
- }
- while (down > up) {
- tmp = *up;
- *up++ = *down;
- *down-- = tmp;
- }
- }
- }
- up = SvPVX(TARG);
- }
down = SvPVX(TARG) + len - 1;
while (down > up) {
tmp = *up;
@@ -3244,8 +2933,8 @@ PP(pp_reverse)
RETURN;
}
-STATIC SV *
-S_mul128(pTHX_ SV *sv, U8 m)
+STATIC SV *
+mul128(SV *sv, U8 m)
{
STRLEN len;
char *s = SvPV(sv, len);
@@ -3253,7 +2942,7 @@ S_mul128(pTHX_ SV *sv, U8 m)
U32 i = 0;
if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
- SV *tmpNew = newSVpvn("0000000000", 10);
+ SV *tmpNew = newSVpv("0000000000", 10);
sv_catsv(tmpNew, sv);
SvREFCNT_dec(sv); /* free old sv */
@@ -3273,6 +2962,11 @@ S_mul128(pTHX_ SV *sv, U8 m)
/* Explosives and implosives. */
+static const char uuemap[] =
+ "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+#ifndef PERL_OBJECT
+static char uudmap[256]; /* Initialised on first use */
+#endif
#if 'I' == 73 && 'J' == 74
/* On an ASCII/ISO kind of system */
#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
@@ -3281,14 +2975,14 @@ S_mul128(pTHX_ SV *sv, U8 m)
Some other sort of character set - use memchr() so we don't match
the null byte.
*/
-#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
+#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
#endif
PP(pp_unpack)
{
djSP;
dPOPPOPssrl;
- I32 start_sp_offset = SP - PL_stack_base;
+ SV **oldsp = SP;
I32 gimme = GIMME_V;
SV *sv;
STRLEN llen;
@@ -3301,7 +2995,6 @@ PP(pp_unpack)
I32 datumtype;
register I32 len;
register I32 bits;
- register char *str;
/* These must not be in registers: */
I16 ashort;
@@ -3314,20 +3007,18 @@ PP(pp_unpack)
unsigned int auint;
U32 aulong;
#ifdef HAS_QUAD
- Uquad_t auquad;
+ unsigned Quad_t auquad;
#endif
char *aptr;
float afloat;
double adouble;
I32 checksum = 0;
register U32 culong;
- NV cdouble;
- int commas = 0;
- int star;
-#ifdef PERL_NATINT_PACK
- int natint; /* native integer */
- int unatint; /* unsigned native integer */
+ double cdouble;
+#ifndef PERL_OBJECT
+ static char* bitcount = 0;
#endif
+ int commas = 0;
if (gimme != G_ARRAY) { /* arrange to do first one only */
/*SUPPRESS 530*/
@@ -3343,54 +3034,27 @@ PP(pp_unpack)
while (pat < patend) {
reparse:
datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
- natint = 0;
-#endif
if (isSPACE(datumtype))
continue;
- if (datumtype == '#') {
- while (pat < patend && *pat != '\n')
- pat++;
- continue;
- }
- if (*pat == '!') {
- char *natstr = "sSiIlL";
-
- if (strchr(natstr, datumtype)) {
-#ifdef PERL_NATINT_PACK
- natint = 1;
-#endif
- pat++;
- }
- else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
- }
- star = 0;
if (pat >= patend)
len = 1;
else if (*pat == '*') {
len = strend - strbeg; /* long enough */
pat++;
- star = 1;
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat)) {
+ while (isDIGIT(*pat))
len = (len * 10) + (*pat++ - '0');
- if (len < 0)
- DIE(aTHX_ "Repeat count in unpack overflows");
- }
}
else
len = (datumtype != '@');
- redo_switch:
switch(datumtype) {
default:
- DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && ckWARN(WARN_UNPACK))
- Perl_warner(aTHX_ WARN_UNPACK,
- "Invalid type in unpack: '%c'", (int)datumtype);
+ if (commas++ == 0 && PL_dowarn)
+ warn("Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
@@ -3403,30 +3067,19 @@ PP(pp_unpack)
break;
case '@':
if (len > strend - strbeg)
- DIE(aTHX_ "@ outside of string");
+ DIE("@ outside of string");
s = strbeg + len;
break;
case 'X':
if (len > s - strbeg)
- DIE(aTHX_ "X outside of string");
+ DIE("X outside of string");
s -= len;
break;
case 'x':
if (len > strend - s)
- DIE(aTHX_ "x outside of string");
+ DIE("x outside of string");
s += len;
break;
- case '/':
- if (start_sp_offset >= SP - PL_stack_base)
- DIE(aTHX_ "/ must follow a numeric type");
- datumtype = *pat++;
- if (*pat == '*')
- pat++; /* ignore '*' for compatibility with pack */
- if (isDIGIT(*pat))
- DIE(aTHX_ "/ cannot take a count" );
- len = POPi;
- star = 0;
- goto redo_switch;
case 'A':
case 'Z':
case 'a':
@@ -3457,24 +3110,24 @@ PP(pp_unpack)
break;
case 'B':
case 'b':
- if (star || len > (strend - s) * 8)
+ if (pat[-1] == '*' || len > (strend - s) * 8)
len = (strend - s) * 8;
if (checksum) {
- if (!PL_bitcount) {
- Newz(601, PL_bitcount, 256, char);
+ if (!bitcount) {
+ Newz(601, bitcount, 256, char);
for (bits = 1; bits < 256; bits++) {
- if (bits & 1) PL_bitcount[bits]++;
- if (bits & 2) PL_bitcount[bits]++;
- if (bits & 4) PL_bitcount[bits]++;
- if (bits & 8) PL_bitcount[bits]++;
- if (bits & 16) PL_bitcount[bits]++;
- if (bits & 32) PL_bitcount[bits]++;
- if (bits & 64) PL_bitcount[bits]++;
- if (bits & 128) PL_bitcount[bits]++;
+ if (bits & 1) bitcount[bits]++;
+ if (bits & 2) bitcount[bits]++;
+ if (bits & 4) bitcount[bits]++;
+ if (bits & 8) bitcount[bits]++;
+ if (bits & 16) bitcount[bits]++;
+ if (bits & 32) bitcount[bits]++;
+ if (bits & 64) bitcount[bits]++;
+ if (bits & 128) bitcount[bits]++;
}
}
while (len >= 8) {
- culong += PL_bitcount[*(unsigned char*)s++];
+ culong += bitcount[*(unsigned char*)s++];
len -= 8;
}
if (len) {
@@ -3497,7 +3150,8 @@ PP(pp_unpack)
sv = NEWSV(35, len + 1);
SvCUR_set(sv, len);
SvPOK_on(sv);
- str = SvPVX(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
if (datumtype == 'b') {
aint = len;
for (len = 0; len < aint; len++) {
@@ -3505,7 +3159,7 @@ PP(pp_unpack)
bits >>= 1;
else
bits = *s++;
- *str++ = '0' + (bits & 1);
+ *pat++ = '0' + (bits & 1);
}
}
else {
@@ -3515,20 +3169,22 @@ PP(pp_unpack)
bits <<= 1;
else
bits = *s++;
- *str++ = '0' + ((bits & 128) != 0);
+ *pat++ = '0' + ((bits & 128) != 0);
}
}
- *str = '\0';
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
XPUSHs(sv_2mortal(sv));
break;
case 'H':
case 'h':
- if (star || len > (strend - s) * 2)
+ if (pat[-1] == '*' || len > (strend - s) * 2)
len = (strend - s) * 2;
sv = NEWSV(35, len + 1);
SvCUR_set(sv, len);
SvPOK_on(sv);
- str = SvPVX(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
if (datumtype == 'h') {
aint = len;
for (len = 0; len < aint; len++) {
@@ -3536,7 +3192,7 @@ PP(pp_unpack)
bits >>= 4;
else
bits = *s++;
- *str++ = PL_hexdigit[bits & 15];
+ *pat++ = PL_hexdigit[bits & 15];
}
}
else {
@@ -3546,10 +3202,11 @@ PP(pp_unpack)
bits <<= 4;
else
bits = *s++;
- *str++ = PL_hexdigit[(bits >> 4) & 15];
+ *pat++ = PL_hexdigit[(bits >> 4) & 15];
}
}
- *str = '\0';
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
XPUSHs(sv_2mortal(sv));
break;
case 'c':
@@ -3597,166 +3254,75 @@ PP(pp_unpack)
}
}
break;
- case 'U':
- if (len > strend - s)
- len = strend - s;
- if (checksum) {
- while (len-- > 0 && s < strend) {
- auint = utf8_to_uv((U8*)s, &along);
- s += along;
- if (checksum > 32)
- cdouble += (NV)auint;
- else
- culong += auint;
- }
- }
- else {
- EXTEND(SP, len);
- EXTEND_MORTAL(len);
- while (len-- > 0 && s < strend) {
- auint = utf8_to_uv((U8*)s, &along);
- s += along;
- sv = NEWSV(37, 0);
- sv_setuv(sv, (UV)auint);
- PUSHs(sv_2mortal(sv));
- }
- }
- break;
case 's':
-#if SHORTSIZE == SIZE16
along = (strend - s) / SIZE16;
-#else
- along = (strend - s) / (natint ? sizeof(short) : SIZE16);
-#endif
if (len > along)
len = along;
if (checksum) {
-#if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
- while (len-- > 0) {
- COPYNN(s, &ashort, sizeof(short));
- s += sizeof(short);
- culong += ashort;
-
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY16(s, &ashort);
+ while (len-- > 0) {
+ COPY16(s, &ashort);
#if SHORTSIZE > SIZE16
- if (ashort > 32767)
- ashort -= 65536;
+ if (ashort > 32767)
+ ashort -= 65536;
#endif
- s += SIZE16;
- culong += ashort;
- }
+ s += SIZE16;
+ culong += ashort;
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
-#if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
- while (len-- > 0) {
- COPYNN(s, &ashort, sizeof(short));
- s += sizeof(short);
- sv = NEWSV(38, 0);
- sv_setiv(sv, (IV)ashort);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY16(s, &ashort);
+ while (len-- > 0) {
+ COPY16(s, &ashort);
#if SHORTSIZE > SIZE16
- if (ashort > 32767)
- ashort -= 65536;
+ if (ashort > 32767)
+ ashort -= 65536;
#endif
- s += SIZE16;
- sv = NEWSV(38, 0);
- sv_setiv(sv, (IV)ashort);
- PUSHs(sv_2mortal(sv));
- }
+ s += SIZE16;
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (IV)ashort);
+ PUSHs(sv_2mortal(sv));
}
}
break;
case 'v':
case 'n':
case 'S':
-#if SHORTSIZE == SIZE16
along = (strend - s) / SIZE16;
-#else
- unatint = natint && datumtype == 'S';
- along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
-#endif
if (len > along)
len = along;
if (checksum) {
-#if SHORTSIZE != SIZE16
- if (unatint) {
- unsigned short aushort;
- while (len-- > 0) {
- COPYNN(s, &aushort, sizeof(unsigned short));
- s += sizeof(unsigned short);
- culong += aushort;
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY16(s, &aushort);
- s += SIZE16;
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = PerlSock_ntohs(aushort);
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
#endif
- culong += aushort;
- }
+ culong += aushort;
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
-#if SHORTSIZE != SIZE16
- if (unatint) {
- unsigned short aushort;
- while (len-- > 0) {
- COPYNN(s, &aushort, sizeof(unsigned short));
- s += sizeof(unsigned short);
- sv = NEWSV(39, 0);
- sv_setiv(sv, (UV)aushort);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY16(s, &aushort);
- s += SIZE16;
- sv = NEWSV(39, 0);
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
+ sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
- if (datumtype == 'n')
- aushort = PerlSock_ntohs(aushort);
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
#endif
#ifdef HAS_VTOHS
- if (datumtype == 'v')
- aushort = vtohs(aushort);
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
#endif
- sv_setiv(sv, (UV)aushort);
- PUSHs(sv_2mortal(sv));
- }
+ sv_setiv(sv, (IV)aushort);
+ PUSHs(sv_2mortal(sv));
}
}
break;
@@ -3769,7 +3335,7 @@ PP(pp_unpack)
Copy(s, &aint, 1, int);
s += sizeof(int);
if (checksum > 32)
- cdouble += (NV)aint;
+ cdouble += (double)aint;
else
culong += aint;
}
@@ -3784,25 +3350,7 @@ PP(pp_unpack)
#ifdef __osf__
/* Without the dummy below unpack("i", pack("i",-1))
* return 0xFFffFFff instead of -1 for Digital Unix V4.0
- * cc with optimization turned on.
- *
- * The bug was detected in
- * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
- * with optimization (-O4) turned on.
- * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
- * does not have this problem even with -O4.
- *
- * This bug was reported as DECC_BUGS 1431
- * and tracked internally as GEM_BUGS 7775.
- *
- * The bug is fixed in
- * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
- * UNIX V4.0F support: DEC C V5.9-006 or later
- * UNIX V4.0E support: DEC C V5.8-011 or later
- * and also in DTK.
- *
- * See also few lines later for the same bug.
- */
+ * cc with optimization turned on */
(aint) ?
sv_setiv(sv, (IV)aint) :
#endif
@@ -3820,7 +3368,7 @@ PP(pp_unpack)
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
if (checksum > 32)
- cdouble += (NV)auint;
+ cdouble += (double)auint;
else
culong += auint;
}
@@ -3834,8 +3382,12 @@ PP(pp_unpack)
sv = NEWSV(41, 0);
#ifdef __osf__
/* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
- * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
- * See details few lines earlier. */
+ * returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
+ * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
+ * with optimization turned on.
+ * (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
+ * does not have this problem even with -O4)
+ */
(auint) ?
sv_setuv(sv, (UV)auint) :
#endif
@@ -3845,151 +3397,80 @@ PP(pp_unpack)
}
break;
case 'l':
-#if LONGSIZE == SIZE32
along = (strend - s) / SIZE32;
-#else
- along = (strend - s) / (natint ? sizeof(long) : SIZE32);
-#endif
if (len > along)
len = along;
if (checksum) {
-#if LONGSIZE != SIZE32
- if (natint) {
- long along;
- while (len-- > 0) {
- COPYNN(s, &along, sizeof(long));
- s += sizeof(long);
- if (checksum > 32)
- cdouble += (NV)along;
- else
- culong += along;
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY32(s, &along);
+ while (len-- > 0) {
+ COPY32(s, &along);
#if LONGSIZE > SIZE32
- if (along > 2147483647)
- along -= 4294967296;
+ if (along > 2147483647)
+ along -= 4294967296;
#endif
- s += SIZE32;
- if (checksum > 32)
- cdouble += (NV)along;
- else
- culong += along;
- }
+ s += SIZE32;
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
-#if LONGSIZE != SIZE32
- if (natint) {
- long along;
- while (len-- > 0) {
- COPYNN(s, &along, sizeof(long));
- s += sizeof(long);
- sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)along);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY32(s, &along);
+ while (len-- > 0) {
+ COPY32(s, &along);
#if LONGSIZE > SIZE32
- if (along > 2147483647)
- along -= 4294967296;
+ if (along > 2147483647)
+ along -= 4294967296;
#endif
- s += SIZE32;
- sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)along);
- PUSHs(sv_2mortal(sv));
- }
+ s += SIZE32;
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (IV)along);
+ PUSHs(sv_2mortal(sv));
}
}
break;
case 'V':
case 'N':
case 'L':
-#if LONGSIZE == SIZE32
along = (strend - s) / SIZE32;
-#else
- unatint = natint && datumtype == 'L';
- along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
-#endif
if (len > along)
len = along;
if (checksum) {
-#if LONGSIZE != SIZE32
- if (unatint) {
- unsigned long aulong;
- while (len-- > 0) {
- COPYNN(s, &aulong, sizeof(unsigned long));
- s += sizeof(unsigned long);
- if (checksum > 32)
- cdouble += (NV)aulong;
- else
- culong += aulong;
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
#endif
- if (checksum > 32)
- cdouble += (NV)aulong;
- else
- culong += aulong;
- }
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
}
}
else {
EXTEND(SP, len);
EXTEND_MORTAL(len);
-#if LONGSIZE != SIZE32
- if (unatint) {
- unsigned long aulong;
- while (len-- > 0) {
- COPYNN(s, &aulong, sizeof(unsigned long));
- s += sizeof(unsigned long);
- sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)aulong);
- PUSHs(sv_2mortal(sv));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- COPY32(s, &aulong);
- s += SIZE32;
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
- if (datumtype == 'N')
- aulong = PerlSock_ntohl(aulong);
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
#endif
#ifdef HAS_VTOHL
- if (datumtype == 'V')
- aulong = vtohl(aulong);
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
#endif
- sv = NEWSV(43, 0);
- sv_setuv(sv, (UV)aulong);
- PUSHs(sv_2mortal(sv));
- }
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
+ PUSHs(sv_2mortal(sv));
}
}
break;
@@ -4033,7 +3514,7 @@ PP(pp_unpack)
char *t;
STRLEN n_a;
- sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
+ sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
@@ -4051,7 +3532,7 @@ PP(pp_unpack)
}
}
if ((s >= strend) && bytes)
- DIE(aTHX_ "Unterminated compressed integer");
+ croak("Unterminated compressed integer");
}
break;
case 'P':
@@ -4085,7 +3566,7 @@ PP(pp_unpack)
if (aquad >= IV_MIN && aquad <= IV_MAX)
sv_setiv(sv, (IV)aquad);
else
- sv_setnv(sv, (NV)aquad);
+ sv_setnv(sv, (double)aquad);
PUSHs(sv_2mortal(sv));
}
break;
@@ -4096,17 +3577,17 @@ PP(pp_unpack)
EXTEND(SP, len);
EXTEND_MORTAL(len);
while (len-- > 0) {
- if (s + sizeof(Uquad_t) > strend)
+ if (s + sizeof(unsigned Quad_t) > strend)
auquad = 0;
else {
- Copy(s, &auquad, 1, Uquad_t);
- s += sizeof(Uquad_t);
+ Copy(s, &auquad, 1, unsigned Quad_t);
+ s += sizeof(unsigned Quad_t);
}
sv = NEWSV(43, 0);
if (auquad <= UV_MAX)
sv_setuv(sv, (UV)auquad);
else
- sv_setnv(sv, (NV)auquad);
+ sv_setnv(sv, (double)auquad);
PUSHs(sv_2mortal(sv));
}
break;
@@ -4131,7 +3612,7 @@ PP(pp_unpack)
Copy(s, &afloat, 1, float);
s += sizeof(float);
sv = NEWSV(47, 0);
- sv_setnv(sv, (NV)afloat);
+ sv_setnv(sv, (double)afloat);
PUSHs(sv_2mortal(sv));
}
}
@@ -4155,7 +3636,7 @@ PP(pp_unpack)
Copy(s, &adouble, 1, double);
s += sizeof(double);
sv = NEWSV(48, 0);
- sv_setnv(sv, (NV)adouble);
+ sv_setnv(sv, (double)adouble);
PUSHs(sv_2mortal(sv));
}
}
@@ -4166,16 +3647,16 @@ PP(pp_unpack)
* algorithm, the code will be character-set independent
* (and just as fast as doing character arithmetic)
*/
- if (PL_uudmap['M'] == 0) {
+ if (uudmap['M'] == 0) {
int i;
- for (i = 0; i < sizeof(PL_uuemap); i += 1)
- PL_uudmap[(U8)PL_uuemap[i]] = i;
+ for (i = 0; i < sizeof(uuemap); i += 1)
+ uudmap[uuemap[i]] = i;
/*
* Because ' ' and '`' map to the same value,
* we need to decode them both the same.
*/
- PL_uudmap[' '] = 0;
+ uudmap[' '] = 0;
}
along = (strend - s) * 3 / 4;
@@ -4187,22 +3668,22 @@ PP(pp_unpack)
char hunk[4];
hunk[3] = '\0';
- len = PL_uudmap[*(U8*)s++] & 077;
+ len = uudmap[*s++] & 077;
while (len > 0) {
if (s < strend && ISUUCHAR(*s))
- a = PL_uudmap[*(U8*)s++] & 077;
+ a = uudmap[*s++] & 077;
else
a = 0;
if (s < strend && ISUUCHAR(*s))
- b = PL_uudmap[*(U8*)s++] & 077;
+ b = uudmap[*s++] & 077;
else
b = 0;
if (s < strend && ISUUCHAR(*s))
- c = PL_uudmap[*(U8*)s++] & 077;
+ c = uudmap[*s++] & 077;
else
c = 0;
if (s < strend && ISUUCHAR(*s))
- d = PL_uudmap[*(U8*)s++] & 077;
+ d = uudmap[*s++] & 077;
else
d = 0;
hunk[0] = (a << 2) | (b >> 4);
@@ -4222,8 +3703,8 @@ PP(pp_unpack)
if (checksum) {
sv = NEWSV(42, 0);
if (strchr("fFdD", datumtype) ||
- (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
- NV trouble;
+ (checksum > 32 && strchr("iIlLN", datumtype)) ) {
+ double trouble;
adouble = 1.0;
while (checksum >= 16) {
@@ -4239,7 +3720,7 @@ PP(pp_unpack)
along = (1 << checksum) - 1;
while (cdouble < 0.0)
cdouble += adouble;
- cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
+ cdouble = modf(cdouble / adouble, &trouble) * adouble;
sv_setnv(sv, cdouble);
}
else {
@@ -4253,44 +3734,44 @@ PP(pp_unpack)
checksum = 0;
}
}
- if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
+ if (SP == oldsp && gimme == G_SCALAR)
PUSHs(&PL_sv_undef);
RETURN;
}
STATIC void
-S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
+doencodes(register SV *sv, register char *s, register I32 len)
{
char hunk[5];
- *hunk = PL_uuemap[len];
+ *hunk = uuemap[len];
sv_catpvn(sv, hunk, 1);
hunk[4] = '\0';
while (len > 2) {
- hunk[0] = PL_uuemap[(077 & (*s >> 2))];
- hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
- hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
- hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
+ hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
+ hunk[3] = uuemap[(077 & (s[2] & 077))];
sv_catpvn(sv, hunk, 4);
s += 3;
len -= 3;
}
if (len > 0) {
char r = (len > 1 ? s[1] : '\0');
- hunk[0] = PL_uuemap[(077 & (*s >> 2))];
- hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
- hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
- hunk[3] = PL_uuemap[0];
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
+ hunk[2] = uuemap[(077 & ((r << 2) & 074))];
+ hunk[3] = uuemap[0];
sv_catpvn(sv, hunk, 4);
}
sv_catpvn(sv, "\n", 1);
}
-STATIC SV *
-S_is_an_int(pTHX_ char *s, STRLEN l)
+STATIC SV *
+is_an_int(char *s, STRLEN l)
{
- STRLEN n_a;
- SV *result = newSVpvn(s, l);
+ STRLEN n_a;
+ SV *result = newSVpv("", l);
char *result_c = SvPV(result, n_a); /* convenience */
char *out = result_c;
bool skip = 1;
@@ -4335,9 +3816,10 @@ S_is_an_int(pTHX_ char *s, STRLEN l)
return (result);
}
-/* pnum must be '\0' terminated */
STATIC int
-S_div128(pTHX_ SV *pnum, bool *done)
+div128(SV *pnum, bool *done)
+ /* must be '\0' terminated */
+
{
STRLEN len;
char *s = SvPV(pnum, len);
@@ -4387,76 +3869,41 @@ PP(pp_pack)
U32 aulong;
#ifdef HAS_QUAD
Quad_t aquad;
- Uquad_t auquad;
+ unsigned Quad_t auquad;
#endif
char *aptr;
float afloat;
double adouble;
int commas = 0;
-#ifdef PERL_NATINT_PACK
- int natint; /* native integer */
-#endif
items = SP - MARK;
MARK++;
sv_setpvn(cat, "", 0);
while (pat < patend) {
- SV *lengthcode = Nullsv;
-#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
+#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
datumtype = *pat++ & 0xFF;
-#ifdef PERL_NATINT_PACK
- natint = 0;
-#endif
if (isSPACE(datumtype))
continue;
- if (datumtype == '#') {
- while (pat < patend && *pat != '\n')
- pat++;
- continue;
- }
- if (*pat == '!') {
- char *natstr = "sSiIlL";
-
- if (strchr(natstr, datumtype)) {
-#ifdef PERL_NATINT_PACK
- natint = 1;
-#endif
- pat++;
- }
- else
- DIE(aTHX_ "'!' allowed only after types %s", natstr);
- }
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
pat++;
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
- while (isDIGIT(*pat)) {
+ while (isDIGIT(*pat))
len = (len * 10) + (*pat++ - '0');
- if (len < 0)
- DIE(aTHX_ "Repeat count in pack overflows");
- }
}
else
len = 1;
- if (*pat == '/') {
- ++pat;
- if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
- DIE(aTHX_ "/ must be followed by a*, A* or Z*");
- lengthcode = sv_2mortal(newSViv(sv_len(items > 0
- ? *MARK : &PL_sv_no)));
- }
switch(datumtype) {
default:
- DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
+ croak("Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && ckWARN(WARN_PACK))
- Perl_warner(aTHX_ WARN_PACK,
- "Invalid type in pack: '%c'", (int)datumtype);
+ if (commas++ == 0 && PL_dowarn)
+ warn("Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
- DIE(aTHX_ "%% may only be used in unpack");
+ DIE("%% may only be used in unpack");
case '@':
len -= SvCUR(cat);
if (len > 0)
@@ -4468,7 +3915,7 @@ PP(pp_pack)
case 'X':
shrink:
if (SvCUR(cat) < len)
- DIE(aTHX_ "X outside of string");
+ DIE("X outside of string");
SvCUR(cat) -= len;
*SvEND(cat) = '\0';
break;
@@ -4485,16 +3932,10 @@ PP(pp_pack)
case 'a':
fromstr = NEXTFROM;
aptr = SvPV(fromstr, fromlen);
- if (pat[-1] == '*') {
+ if (pat[-1] == '*')
len = fromlen;
- if (datumtype == 'Z')
- ++len;
- }
- if (fromlen >= len) {
+ if (fromlen > len)
sv_catpvn(cat, aptr, len);
- if (datumtype == 'Z')
- *(SvEND(cat)-1) = '\0';
- }
else {
sv_catpvn(cat, aptr, fromlen);
len -= fromlen;
@@ -4517,14 +3958,15 @@ PP(pp_pack)
case 'B':
case 'b':
{
- register char *str;
+ char *savepat = pat;
I32 saveitems;
fromstr = NEXTFROM;
saveitems = items;
- str = SvPV(fromstr, fromlen);
+ aptr = SvPV(fromstr, fromlen);
if (pat[-1] == '*')
len = fromlen;
+ pat = aptr;
aint = SvCUR(cat);
SvCUR(cat) += (len+7)/8;
SvGROW(cat, SvCUR(cat) + 1);
@@ -4535,7 +3977,7 @@ PP(pp_pack)
items = 0;
if (datumtype == 'B') {
for (len = 0; len++ < aint;) {
- items |= *str++ & 1;
+ items |= *pat++ & 1;
if (len & 7)
items <<= 1;
else {
@@ -4546,7 +3988,7 @@ PP(pp_pack)
}
else {
for (len = 0; len++ < aint;) {
- if (*str++ & 1)
+ if (*pat++ & 1)
items |= 128;
if (len & 7)
items >>= 1;
@@ -4563,24 +4005,26 @@ PP(pp_pack)
items >>= 7 - (aint & 7);
*aptr++ = items & 0xff;
}
- str = SvPVX(cat) + SvCUR(cat);
- while (aptr <= str)
+ pat = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= pat)
*aptr++ = '\0';
+ pat = savepat;
items = saveitems;
}
break;
case 'H':
case 'h':
{
- register char *str;
+ char *savepat = pat;
I32 saveitems;
fromstr = NEXTFROM;
saveitems = items;
- str = SvPV(fromstr, fromlen);
+ aptr = SvPV(fromstr, fromlen);
if (pat[-1] == '*')
len = fromlen;
+ pat = aptr;
aint = SvCUR(cat);
SvCUR(cat) += (len+1)/2;
SvGROW(cat, SvCUR(cat) + 1);
@@ -4591,10 +4035,10 @@ PP(pp_pack)
items = 0;
if (datumtype == 'H') {
for (len = 0; len++ < aint;) {
- if (isALPHA(*str))
- items |= ((*str++ & 15) + 9) & 15;
+ if (isALPHA(*pat))
+ items |= ((*pat++ & 15) + 9) & 15;
else
- items |= *str++ & 15;
+ items |= *pat++ & 15;
if (len & 1)
items <<= 4;
else {
@@ -4605,10 +4049,10 @@ PP(pp_pack)
}
else {
for (len = 0; len++ < aint;) {
- if (isALPHA(*str))
- items |= (((*str++ & 15) + 9) & 15) << 4;
+ if (isALPHA(*pat))
+ items |= (((*pat++ & 15) + 9) & 15) << 4;
else
- items |= (*str++ & 15) << 4;
+ items |= (*pat++ & 15) << 4;
if (len & 1)
items >>= 4;
else {
@@ -4619,10 +4063,11 @@ PP(pp_pack)
}
if (aint & 1)
*aptr++ = items & 0xff;
- str = SvPVX(cat) + SvCUR(cat);
- while (aptr <= str)
+ pat = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= pat)
*aptr++ = '\0';
+ pat = savepat;
items = saveitems;
}
break;
@@ -4635,16 +4080,6 @@ PP(pp_pack)
sv_catpvn(cat, &achar, sizeof(char));
}
break;
- case 'U':
- while (len-- > 0) {
- fromstr = NEXTFROM;
- auint = SvUV(fromstr);
- SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
- SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
- - SvPVX(cat));
- }
- *SvEND(cat) = '\0';
- break;
/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
case 'f':
case 'F':
@@ -4683,48 +4118,11 @@ PP(pp_pack)
}
break;
case 'S':
-#if SHORTSIZE != SIZE16
- if (natint) {
- unsigned short aushort;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aushort = SvUV(fromstr);
- sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
- }
- }
- else
-#endif
- {
- U16 aushort;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aushort = (U16)SvUV(fromstr);
- CAT16(cat, &aushort);
- }
-
- }
- break;
case 's':
-#if SHORTSIZE != SIZE16
- if (natint) {
- short ashort;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = SvIV(fromstr);
- sv_catpvn(cat, (char *)&ashort, sizeof(short));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- fromstr = NEXTFROM;
- ashort = (I16)SvIV(fromstr);
- CAT16(cat, &ashort);
- }
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+ CAT16(cat, &ashort);
}
break;
case 'I':
@@ -4737,22 +4135,26 @@ PP(pp_pack)
case 'w':
while (len-- > 0) {
fromstr = NEXTFROM;
- adouble = Perl_floor(SvNV(fromstr));
+ adouble = floor(SvNV(fromstr));
if (adouble < 0)
- DIE(aTHX_ "Cannot compress negative numbers");
+ croak("Cannot compress negative numbers");
if (
+#ifdef BW_BITS
+ adouble <= BW_MASK
+#else
#ifdef CXUX_BROKEN_CONSTANT_CONVERT
adouble <= UV_MAX_cxux
#else
adouble <= UV_MAX
#endif
+#endif
)
{
char buf[1 + sizeof(UV)];
char *in = buf + sizeof(buf);
- UV auv = U_V(adouble);
+ UV auv = U_V(adouble);;
do {
*--in = (auv & 0x7f) | 0x80;
@@ -4770,7 +4172,7 @@ PP(pp_pack)
/* Copy string and check for compliance */
from = SvPV(fromstr, len);
if ((norm = is_an_int(from, len)) == NULL)
- DIE(aTHX_ "can compress only unsigned integer");
+ croak("can compress only unsigned integer");
New('w', result, len, char);
in = result + len;
@@ -4790,14 +4192,14 @@ PP(pp_pack)
double next = floor(adouble / 128);
*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
if (--in < buf) /* this cannot happen ;-) */
- DIE(aTHX_ "Cannot compress integer");
+ croak ("Cannot compress integer");
adouble = next;
} while (adouble > 0);
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
}
else
- DIE(aTHX_ "Cannot compress non integer");
+ croak("Cannot compress non integer");
}
break;
case 'i':
@@ -4828,53 +4230,25 @@ PP(pp_pack)
}
break;
case 'L':
-#if LONGSIZE != SIZE32
- if (natint) {
- unsigned long aulong;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- fromstr = NEXTFROM;
- aulong = SvUV(fromstr);
- CAT32(cat, &aulong);
- }
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
}
break;
case 'l':
-#if LONGSIZE != SIZE32
- if (natint) {
- long along;
-
- while (len-- > 0) {
- fromstr = NEXTFROM;
- along = SvIV(fromstr);
- sv_catpvn(cat, (char *)&along, sizeof(long));
- }
- }
- else
-#endif
- {
- while (len-- > 0) {
- fromstr = NEXTFROM;
- along = SvIV(fromstr);
- CAT32(cat, &along);
- }
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIV(fromstr);
+ CAT32(cat, &along);
}
break;
#ifdef HAS_QUAD
case 'Q':
while (len-- > 0) {
fromstr = NEXTFROM;
- auquad = (Uquad_t)SvUV(fromstr);
- sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
+ auquad = (unsigned Quad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
}
break;
case 'q':
@@ -4884,7 +4258,7 @@ PP(pp_pack)
sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
}
break;
-#endif
+#endif /* HAS_QUAD */
case 'P':
len = 1; /* assume SV is correct length */
/* FALL THROUGH */
@@ -4900,13 +4274,8 @@ PP(pp_pack)
* of pack() (and all copies of the result) are
* gone.
*/
- if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
- || (SvPADTMP(fromstr)
- && !SvREADONLY(fromstr))))
- {
- Perl_warner(aTHX_ WARN_PACK,
- "Attempt to pack pointer to temporary value");
- }
+ if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warn("Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,n_a);
else
@@ -4977,19 +4346,14 @@ PP(pp_split)
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE(aTHX_ "panic: do_split");
+ DIE("panic: do_split");
rx = pm->op_pmregexp;
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
- if (pm->op_pmreplroot) {
-#ifdef USE_ITHREADS
- ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
-#else
+ if (pm->op_pmreplroot)
ary = GvAVn((GV*)pm->op_pmreplroot);
-#endif
- }
else if (gimme != G_ARRAY)
#ifdef USE_THREADS
ary = (AV*)PL_curpad[0];
@@ -5004,14 +4368,13 @@ PP(pp_split)
av_extend(ary,0);
av_clear(ary);
SPAGAIN;
- if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
+ if (mg = SvTIED_mg((SV*)ary, 'P')) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj((SV*)ary, mg));
}
else {
if (!AvREAL(ary)) {
AvREAL_on(ary);
- AvREIFY_off(ary);
for (i = AvFILLp(ary); i >= 0; i--)
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
@@ -5077,19 +4440,15 @@ PP(pp_split)
s = m;
}
}
- else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
+ else if (rx->check_substr && !rx->nparens
&& (rx->reganch & ROPT_CHECK_ALL)
&& !(rx->reganch & ROPT_ANCH)) {
- int tail = (rx->reganch & RE_INTUIT_TAIL);
- SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
- char c;
-
- len = rx->minlen;
- if (len == 1 && !tail) {
- c = *SvPV(csv,len);
+ i = SvCUR(rx->check_substr);
+ if (i == 1 && !SvTAIL(rx->check_substr)) {
+ i = *SvPVX(rx->check_substr);
while (--limit) {
/*SUPPRESS 530*/
- for (m = s; m < strend && *m != c; m++) ;
+ for (m = s; m < strend && *m != i; m++) ;
if (m >= strend)
break;
dstr = NEWSV(30, m-s);
@@ -5103,8 +4462,8 @@ PP(pp_split)
else {
#ifndef lint
while (s < strend && --limit &&
- (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
- csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
+ (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
+ rx->check_substr, 0)) )
#endif
{
dstr = NEWSV(31, m-s);
@@ -5112,28 +4471,25 @@ PP(pp_split)
if (make_mortal)
sv_2mortal(dstr);
XPUSHs(dstr);
- s = m + len; /* Fake \n at the end */
+ s = m + i;
}
}
}
else {
maxiters += (strend - s) * rx->nparens;
- while (s < strend && --limit
-/* && (!rx->check_substr
- || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
- 0, NULL))))
-*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
- 1 /* minend */, sv, NULL, 0))
+ while (s < strend && --limit &&
+ CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
{
TAINT_IF(RX_MATCH_TAINTED(rx));
- if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
+ if (rx->subbase
+ && rx->subbase != orig) {
m = s;
s = orig;
- orig = rx->subbeg;
+ orig = rx->subbase;
s = orig + (m - s);
strend = s + (strend - m);
}
- m = rx->startp[0] + orig;
+ m = rx->startp[0];
dstr = NEWSV(32, m-s);
sv_setpvn(dstr, s, m-s);
if (make_mortal)
@@ -5141,8 +4497,8 @@ PP(pp_split)
XPUSHs(dstr);
if (rx->nparens) {
for (i = 1; i <= rx->nparens; i++) {
- s = rx->startp[i] + orig;
- m = rx->endp[i] + orig;
+ s = rx->startp[i];
+ m = rx->endp[i];
if (m && s) {
dstr = NEWSV(33, m-s);
sv_setpvn(dstr, s, m-s);
@@ -5154,14 +4510,14 @@ PP(pp_split)
XPUSHs(dstr);
}
}
- s = rx->endp[0] + orig;
+ s = rx->endp[0];
}
}
LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
- DIE(aTHX_ "Split loop");
+ DIE("Split loop");
/* keep field after final delim? */
if (s < strend || (iters && origlimit)) {
@@ -5195,7 +4551,7 @@ PP(pp_split)
else {
PUTBACK;
ENTER;
- call_method("PUSH",G_SCALAR|G_DISCARD);
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
LEAVE;
SPAGAIN;
if (gimme == G_ARRAY) {
@@ -5223,20 +4579,20 @@ PP(pp_split)
#ifdef USE_THREADS
void
-Perl_unlock_condpair(pTHX_ void *svv)
+unlock_condpair(void *svv)
{
dTHR;
MAGIC *mg = mg_find((SV*)svv, 'm');
if (!mg)
- Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
+ croak("panic: unlock_condpair unlocking non-mutex");
MUTEX_LOCK(MgMUTEXP(mg));
if (MgOWNER(mg) != thr)
- Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
+ croak("panic: unlock_condpair unlocking mutex that we don't own");
MgOWNER(mg) = 0;
COND_SIGNAL(MgOWNERCONDP(mg));
- DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(svv));)
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)svv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
}
#endif /* USE_THREADS */
@@ -5260,10 +4616,10 @@ PP(pp_lock)
while (MgOWNER(mg))
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
MgOWNER(mg) = thr;
- DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(sv));)
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
MUTEX_UNLOCK(MgMUTEXP(mg));
- SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
+ save_destructor(unlock_condpair, sv);
}
#endif /* USE_THREADS */
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
@@ -5276,8 +4632,8 @@ PP(pp_lock)
PP(pp_threadsv)
{
-#ifdef USE_THREADS
djSP;
+#ifdef USE_THREADS
EXTEND(SP, 1);
if (PL_op->op_private & OPpLVAL_INTRO)
PUSHs(*save_threadsv(PL_op->op_targ));
@@ -5285,6 +4641,6 @@ PP(pp_threadsv)
PUSHs(THREADSV(PL_op->op_targ));
RETURN;
#else
- DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
+ DIE("tried to access per-thread data in non-threaded perl");
#endif /* USE_THREADS */
}
diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL
index 0b0208b0ca40..977fad6e9849 100644
--- a/contrib/perl5/utils/h2ph.PL
+++ b/contrib/perl5/utils/h2ph.PL
@@ -46,7 +46,7 @@ die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
my $Exit = 0;
-my $Dest_dir = $opt_d || $Config{installsitearch};
+my $Dest_dir = $opt_d || $Config{installarchlib};
die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
unless -d $Dest_dir;
@@ -528,7 +528,7 @@ sub inc_dirs
sub build_preamble_if_necessary
{
# Increment $VERSION every time this function is modified:
- my $VERSION = 2;
+ my $VERSION = 1;
my $preamble = "$Dest_dir/_h2ph_pre.ph";
# Can we skip building the preamble file?
@@ -556,9 +556,6 @@ sub build_preamble_if_necessary
if ($define{$_} =~ /^\d+$/) {
print PREAMBLE
"unless (defined &$_) { sub $_() { $define{$_} } }\n\n";
- } elsif ($define{$_} =~ /^\w+$/) {
- print PREAMBLE
- "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
} else {
print PREAMBLE
"unless (defined &$_) { sub $_() { \"",
@@ -579,7 +576,8 @@ sub _extract_cc_defines
# Split compiler pre-definitions into `key=value' pairs:
foreach (split /\s+/, $allsymbols) {
- /(.+?)=(.+)/ and $define{$1} = $2;
+ /(.*?)=(.*)/;
+ $define{$1} = $2;
if ($opt_D) {
print STDERR "$_: $1 -> $2\n";
@@ -629,7 +627,7 @@ If run with no arguments, filters standard input to standard output.
=item -d destination_dir
Put the resulting B<.ph> files beneath B<destination_dir>, instead of
-beneath the default Perl library location (C<$Config{'installsitsearch'}>).
+beneath the default Perl library location (C<$Config{'installarchlib'}>).
=item -r
diff --git a/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL
index 208da3667c4a..7bd88f44825b 100644
--- a/contrib/perl5/utils/perlbug.PL
+++ b/contrib/perl5/utils/perlbug.PL
@@ -3,7 +3,6 @@
use Config;
use File::Basename qw(&basename &dirname);
use Cwd;
-use File::Spec::Functions;
# List explicitly here the variables you want Configure to
# generate. Metaconfig only looks for shell variables, so you
@@ -24,8 +23,7 @@ open OUT, ">$file" or die "Can't create $file: $!";
# extract patchlevel.h information
-open PATCH_LEVEL, "<" . catfile(updir, "patchlevel.h")
- or die "Can't open patchlevel.h: $!";
+open PATCH_LEVEL, "<../patchlevel.h" or open PATCH_LEVEL, "<patchlevel.h" or die "Can't open patchlevel.h: $!";
my $patchlevel_date = (stat PATCH_LEVEL)[9];
@@ -37,8 +35,8 @@ my @patches;
while (<PATCH_LEVEL>) {
last if /^\s*}/;
chomp;
- s/^\s+,?\s*"?//;
- s/"?\s*,?$//;
+ s/^\s+,?"?//;
+ s/"?,?$//;
s/(['\\])/\\$1/g;
push @patches, $_ unless $_ eq 'NULL';
}
@@ -57,14 +55,12 @@ print "Extracting $file (with variable substitutions)\n";
# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.
-my $extract_version = sprintf("v%vd", $^V);
-
print OUT <<"!GROK!THIS!";
$Config{startperl}
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
-my \$config_tag1 = '$extract_version - $Config{cf_time}';
+my \$config_tag1 = '$] - $Config{cf_time}';
my \$patchlevel_date = $patchlevel_date;
my \$patch_tags = '$patch_tags';
@@ -78,7 +74,6 @@ my \@patches = (
print OUT <<'!NO!SUBS!';
use Config;
-use File::Spec; # keep perlbug Perl 5.005 compatible
use Getopt::Std;
use strict;
@@ -91,7 +86,7 @@ BEGIN {
$::HaveUtil = ($@ eq "");
};
-my $Version = "1.28";
+my $Version = "1.26";
# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
# Changed in 1.07 to see more sendmail execs, and added pipe output.
@@ -122,8 +117,6 @@ my $Version = "1.28";
# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
-# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
-# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
# TODO: - Allow the user to re-name the file on mail failure, and
# make sure failure (transmission-wise) of Mail::Send is
@@ -131,12 +124,10 @@ my $Version = "1.28";
# - Test -b option
my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
- $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity,
+ $subject, $from, $verbose, $ed, $outfile,
$fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok);
-my $perl_version = $^V ? sprintf("v%vd", $^V) : $];
-
-my $config_tag2 = "$perl_version - $Config{cf_time}";
+my $config_tag2 = "$] - $Config{cf_time}";
Init();
@@ -158,43 +149,11 @@ Send();
exit;
-sub ask_for_alternatives {
- my $name = shift;
- my $default = shift;
- my @alts = @_;
- my $alt = "";
- paraprint <<EOF;
-Please pick a \u$name from the following:
-
- @alts
-
-EOF
- my $err = 0;
- my $joined_alts = join('|', @alts);
- do {
- if ($err++ > 5) {
- die "Invalid $name: aborting.\n";
- }
- print "Please enter a \u$name [$default]: ";
- $alt = <>;
- chomp $alt;
- if ($alt =~ /^\s*$/) {
- $alt = $default;
- }
- } while ($alt !~ /^($joined_alts)$/i);
- lc $alt;
-}
-
sub Init {
# -------- Setup --------
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_VMS = $^O eq 'VMS';
- $Is_MacOS = $^O eq 'MacOS';
-
- @ARGV = split m/\s+/,
- MacPerl::Ask('Provide command-line args here (-h for help):')
- if $Is_MacOS && $MacPerl::Version =~ /App/;
if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
@@ -237,7 +196,6 @@ sub Init {
$ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
|| ($Is_VMS && "edit/tpu")
|| ($Is_MSWin32 && "notepad")
- || ($Is_MacOS && '')
|| "vi";
# Not OK - provide build failure template by finessing OK report
@@ -274,10 +232,8 @@ EOF
$::opt_C = 1; # don't send a copy to the local admin
$::opt_s = 1; # we have a subject line
$subject = ($::opt_n ? 'Not ' : '')
- . "OK: perl $perl_version ${patch_tags}on"
+ . "OK: perl $] ${patch_tags}on"
." $::Config{'archname'} $::Config{'osvers'} $subject";
- $category = "install";
- $severity = "none";
$ok = 1;
} else {
Help();
@@ -299,7 +255,6 @@ EOF
# My username
$me = $Is_MSWin32 ? $ENV{'USERNAME'}
: $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
- : $Is_MacOS ? $ENV{'USER'}
: eval { getpwuid($<) }; # May be missing
$from = $::Config{'cf_email'}
@@ -352,13 +307,6 @@ EOF
my $guess;
$guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
- if ($Is_MacOS) {
- require Mac::InternetConfig;
- $guess = $Mac::InternetConfig::InternetConfig{
- Mac::InternetConfig::kICEmail()
- };
- }
-
unless ($guess) {
my $domain;
if ($::HaveUtil) {
@@ -467,16 +415,6 @@ EOF
}
}
- # Prompt for category of bug
- $category ||= ask_for_alternatives("category", "core",
- qw(core docs install
- library utilities));
-
- # Prompt for severity of bug
- $severity ||= ask_for_alternatives("severity", "low",
- qw(critical high medium
- low wishlist none));
-
# Generate scratch file to edit report in
$filename = filename();
@@ -514,7 +452,7 @@ EOF
print REP <<EOF;
This is a $reptype report for perl from $from,
-generated with the help of perlbug $Version running under perl $perl_version.
+generated with the help of perlbug $Version running under perl $].
EOF
@@ -556,19 +494,13 @@ EOF
sub Dump {
local(*OUT) = @_;
- print OUT <<EFF;
----
-Flags:
- category=$category
- severity=$severity
----
-EFF
- print OUT "This perlbug was built using Perl $config_tag1\n",
+ print REP "\n---\n";
+ print REP "This perlbug was built using Perl $config_tag1\n",
"It is being executed now by Perl $config_tag2.\n\n"
if $config_tag2 ne $config_tag1;
print OUT <<EOF;
-Site configuration information for perl $perl_version:
+Site configuration information for perl $]:
EOF
if ($::Config{cf_by} and $::Config{cf_time}) {
@@ -584,7 +516,7 @@ EOF
print OUT <<EOF;
---
-\@INC for perl $perl_version:
+\@INC for perl $]:
EOF
for my $i (@INC) {
print OUT " $i\n";
@@ -593,21 +525,18 @@ EOF
print OUT <<EOF;
---
-Environment for perl $perl_version:
+Environment for perl $]:
EOF
- my @env =
- qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
- push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
- push @env, grep /^(?:PERL|LC_|LANG)/, keys %ENV;
- my %env;
- @env{@env} = @env;
- for my $env (sort keys %env) {
+ for my $env (sort
+ (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE),
+ grep /^(?:PERL|LC_)/, keys %ENV)
+ ) {
print OUT " $env",
exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
"\n";
}
if ($verbose) {
- print OUT "\nComplete configuration data for perl $perl_version:\n\n";
+ print OUT "\nComplete configuration data for perl $]:\n\n";
my $value;
foreach (sort keys %::Config) {
$value = $::Config{$_};
@@ -630,15 +559,7 @@ EOF
}
tryagain:
- my $sts = system("$ed $filename") unless $Is_MacOS;
- if ($Is_MacOS) {
- require ExtUtils::MakeMaker;
- ExtUtils::MM_MacOS::launch_file($filename);
- paraprint <<EOF;
-Press Enter when done.
-EOF
- scalar <>;
- }
+ my $sts = system("$ed $filename");
if ($sts) {
paraprint <<EOF;
The editor you chose (`$ed') could apparently not be run!
@@ -862,7 +783,7 @@ Options:
-v Include Verbose configuration data in the report
-f File containing the body of the report. Use this to
quickly send a prepared message.
- -F File to output the resulting mail message to, instead of mailing.
+ -F File to output the resulting mail message to, instead of mailing.
-S Send without asking for confirmation.
-a Address to send the report to. Defaults to `$address'.
-c Address to send copy of report to. Defaults to `$cc'.
@@ -875,7 +796,7 @@ Options:
this if you don't give it here.
-e Editor to use.
-t Test mode. The target address defaults to `$testaddress'.
- -d Data mode (the default if you redirect or pipe output.)
+ -d Data mode (the default if you redirect or pipe output.)
This prints out your configuration data, without mailing
anything. You can use this with -v to get more complete data.
-ok Report successful build on this system to perl porters
@@ -894,12 +815,11 @@ EOF
sub filename {
my $dir = $Is_VMS ? 'sys$scratch:'
: ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'}
- : $Is_MacOS ? $ENV{'TMPDIR'}
- : '/tmp';
+ : '/tmp/';
$filename = "bugrep0$$";
-# $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|;
- $filename++ while -e File::Spec->catfile($dir, $filename);
- $filename = File::Spec->catfile($dir, $filename);
+ $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|;
+ $filename++ while -e "$dir$filename";
+ $filename = "$dir$filename";
}
sub paraprint {
@@ -958,7 +878,7 @@ this checklist:
=over 4
-=item What version of Perl you are running?
+=item What version of perl you are running?
Type C<perl -v> at the command line to find out.
@@ -966,16 +886,16 @@ Type C<perl -v> at the command line to find out.
Look at http://www.perl.com/ to find out. If it is not the latest
released version, get that one and see whether your bug has been
-fixed. Note that bug reports about old versions of Perl, especially
+fixed. Note that bug reports about old versions of perl, especially
those prior to the 5.0 release, are likely to fall upon deaf ears.
You are on your own if you continue to use perl1 .. perl4.
=item Are you sure what you have is a bug?
A significant number of the bug reports we get turn out to be documented
-features in Perl. Make sure the behavior you are witnessing doesn't fall
+features in perl. Make sure the behavior you are witnessing doesn't fall
under that category, by glancing through the documentation that comes
-with Perl (we'll admit this is no mean task, given the sheer volume of
+with perl (we'll admit this is no mean task, given the sheer volume of
it all, but at least have a look at the sections that I<seem> relevant).
Be aware of the familiar traps that perl programmers of various hues
@@ -985,10 +905,10 @@ Check in L<perldiag> to see what any Perl error message(s) mean.
If message isn't in perldiag, it probably isn't generated by Perl.
Consult your operating system documentation instead.
-If you are on a non-UNIX platform check also L<perlport>, as some
-features may be unimplemented or work differently.
+If you are on a non-UNIX platform check also L<perlport>, some
+features may not be implemented or work differently.
-Try to study the problem under the Perl debugger, if necessary.
+Try to study the problem under the perl debugger, if necessary.
See L<perldebug>.
=item Do you have a proper test case?
@@ -1010,7 +930,7 @@ If you get a core dump (or equivalent), you may use a debugger
(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
report. NOTE: unless your Perl has been compiled with debug info
(often B<-g>), the stack trace is likely to be somewhat hard to use
-because it will most probably contain only the function names and not
+because it will most probably contain only the function names, not
their arguments. If possible, recompile your Perl with debug info and
reproduce the dump and the stack trace.
@@ -1018,8 +938,8 @@ reproduce the dump and the stack trace.
The easier it is to understand a reproducible bug, the more likely it
will be fixed. Anything you can provide by way of insight into the
-problem helps a great deal. In other words, try to analyze the
-problem (to the extent you can) and report your discoveries.
+problem helps a great deal. In other words, try to analyse the
+problem to the extent you feel qualified and report your discoveries.
=item Can you fix the bug yourself?
@@ -1053,14 +973,14 @@ C<perlbug> at all on your system, be sure to include the entire output
produced by running C<perl -V> (note the uppercase V).
Whether you use C<perlbug> or send the email manually, please make
-your Subject line informative. "a bug" not informative. Neither is
-"perl crashes" nor "HELP!!!". These don't help.
-A compact description of what's wrong is fine.
+your subject informative. "a bug" not informative. Neither is "perl
+crashes" nor "HELP!!!", these all are null information. A compact
+description of what's wrong is fine.
=back
Having done your bit, please be prepared to wait, to be told the bug
-is in your code, or even to get no reply at all. The Perl maintainers
+is in your code, or even to get no reply at all. The perl maintainers
are busy folks, so if your problem is a small one or if it is difficult
to understand or already known, they may not respond with a personal reply.
If it is important to you that your bug be fixed, do monitor the
@@ -1171,14 +1091,12 @@ Include verbose configuration data in the report.
=head1 AUTHORS
Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored
-by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>), Tom Christiansen
+by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen
(E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>),
Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>),
-Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>),
-Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
-(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
-and Richard Foley (E<lt>richard@rfi.netE<gt>).
+Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>), and
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>).
=head1 SEE ALSO
diff --git a/contrib/perl5/utils/splain.PL b/contrib/perl5/utils/splain.PL
index a638dbae7174..0a71544de3a4 100644
--- a/contrib/perl5/utils/splain.PL
+++ b/contrib/perl5/utils/splain.PL
@@ -21,7 +21,12 @@ $file .= '.com' if $^O eq 'VMS';
# Open input file before creating output file.
$IN = '../lib/diagnostics.pm';
-open IN or die "Can't open $IN: $!\n";
+$in = open IN;
+if (!$in) {
+ $inmsg = "Can't open $IN: $!\n";
+ $IN = 'diagnostics.pm';
+ $in = open IN or die $inmsg, "Can't open $IN: $!\n";
+}
# Create output file.
open OUT,">$file" or die "Can't create $file: $!";
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-01 14:46:38 +0000