Index: head/contrib/perl5/ext/POSIX/Makefile.PL =================================================================== --- head/contrib/perl5/ext/POSIX/Makefile.PL (revision 62079) +++ head/contrib/perl5/ext/POSIX/Makefile.PL (revision 62080) @@ -1,8 +1,19 @@ +# $FreeBSD$ 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', - ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])), + @libs, MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'POSIX.pm', ); Index: head/contrib/perl5/ext/POSIX/POSIX.xs =================================================================== --- head/contrib/perl5/ext/POSIX/POSIX.xs (revision 62079) +++ head/contrib/perl5/ext/POSIX/POSIX.xs (revision 62080) @@ -1,3732 +1,3955 @@ /* $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" -#ifdef PERL_OBJECT /* XXX _very_ temporary hacks */ +#if defined(PERL_OBJECT) || defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS) # undef signal # undef open # undef setmode # define open PerlLIO_open3 #endif #include #ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */ #include #endif #include #ifdef I_FLOAT #include #endif #ifdef I_LIMITS #include #endif #include #include #ifdef I_PWD #include #endif #include #include #include #ifdef I_STDDEF #include #endif /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD */ #if defined(I_TERMIOS) #include #endif #ifdef I_STDLIB #include #endif #include #include #include #include #ifdef I_UNISTD #include #endif #include #if defined(__VMS) && !defined(__POSIX_SOURCE) # include /* LIB$_INVARG constant */ # include /* prototype for lib$ediv() */ # include /* prototype for sys$gettim() */ # if DECC_VERSION < 50000000 # define pid_t int /* old versions of DECC miss this in types.h */ # endif # undef mkfifo # define mkfifo(a,b) (not_here("mkfifo"),-1) # define tzset() not_here("tzset") #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) # define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */ # include # endif /* __VMS_VER >= 70000000 or Dec C 5.6 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; # define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL) /* 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 */ # if defined(__DECC) && defined (__ALPHA) # include uint64 vmstime; _ckvmssts(sys$gettim(&vmstime)); vmstime /= 100000; retval = vmstime & 0x7fffffff; # else /* (Older hw or ccs don't have an atomic 64-bit type, so we * juggle 32-bit ints (and a float) to produce a time_t result * with minimal loss of information.) */ long int vmstime[2],remainder,divisor = 100000; _ckvmssts(sys$gettim((unsigned long int *)vmstime)); vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */ _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); # endif /* Fill in the struct tms using the CRTL routine . . .*/ times((tbuffer_t *)PL_bufptr); return (clock_t) retval; } # 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") # define ttyname(a) (char*)not_here("ttyname") # define sigset_t long # define pid_t long # ifdef __BORLANDC__ # define tzname _tzname # endif # ifdef _MSC_VER # define mode_t short # endif # ifdef __MINGW32__ # define mode_t short # ifndef tzset # define tzset() not_here("tzset") # endif # ifndef _POSIX_OPEN_MAX # define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */ # endif # endif # define sigaction(a,b,c) not_here("sigaction") # define sigpending(a) not_here("sigpending") # define sigprocmask(a,b,c) not_here("sigprocmask") # define sigsuspend(a) not_here("sigsuspend") # define sigemptyset(a) not_here("sigemptyset") # define sigaddset(a,b) not_here("sigaddset") # define sigdelset(a,b) not_here("sigdelset") # define sigfillset(a) not_here("sigfillset") # define sigismember(a,b) not_here("sigismember") #else # ifndef HAS_MKFIFO -# ifndef mkfifo -# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) +# 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 # endif # endif /* !HAS_MKFIFO */ # include # include # ifdef HAS_UNAME # include # endif # include # ifdef I_UTIME # include # endif #endif /* WIN32 */ #endif /* __VMS */ typedef int SysRet; typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; typedef HV* POSIX__SigAction; #ifdef I_TERMIOS typedef struct termios* POSIX__Termios; #else /* Define termios types to int, and call not_here for the functions.*/ #define POSIX__Termios int #define speed_t int #define tcflag_t int #define cc_t int #define cfgetispeed(x) not_here("cfgetispeed") #define cfgetospeed(x) not_here("cfgetospeed") #define tcdrain(x) not_here("tcdrain") #define tcflush(x,y) not_here("tcflush") #define tcsendbreak(x,y) not_here("tcsendbreak") #define cfsetispeed(x,y) not_here("cfsetispeed") #define cfsetospeed(x,y) not_here("cfsetospeed") #define ctermid(x) (char *) not_here("ctermid") #define tcflow(x,y) not_here("tcflow") #define tcgetattr(x,y) not_here("tcgetattr") #define tcsetattr(x,y,z) not_here("tcsetattr") #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") #endif #ifndef HAS_DIFFTIME #ifndef difftime #define difftime(a,b) not_here("difftime") #endif #endif #ifndef HAS_FPATHCONF #define fpathconf(f,n) (SysRetLong) not_here("fpathconf") #endif #ifndef HAS_MKTIME #define mktime(a) not_here("mktime") #endif #ifndef HAS_NICE #define nice(a) not_here("nice") #endif #ifndef HAS_PATHCONF #define pathconf(f,n) (SysRetLong) not_here("pathconf") #endif #ifndef HAS_SYSCONF #define sysconf(n) (SysRetLong) not_here("sysconf") #endif #ifndef HAS_READLINK #define readlink(a,b,c) not_here("readlink") #endif #ifndef HAS_SETPGID #define setpgid(a,b) not_here("setpgid") #endif #ifndef HAS_SETSID #define setsid() not_here("setsid") #endif #ifndef HAS_STRCOLL #define strcoll(s1,s2) not_here("strcoll") #endif #ifndef HAS_STRTOD #define strtod(s1,s2) not_here("strtod") #endif #ifndef HAS_STRTOL #define strtol(s1,s2,b) not_here("strtol") #endif #ifndef HAS_STRTOUL #define strtoul(s1,s2,b) not_here("strtoul") #endif #ifndef HAS_STRXFRM #define strxfrm(s1,s2,n) not_here("strxfrm") #endif #ifndef HAS_TCGETPGRP #define tcgetpgrp(a) not_here("tcgetpgrp") #endif #ifndef HAS_TCSETPGRP #define tcsetpgrp(a,b) not_here("tcsetpgrp") #endif #ifndef HAS_TIMES #define times(a) not_here("times") #endif #ifndef HAS_UNAME #define uname(a) not_here("uname") #endif #ifndef HAS_WAITPID #define waitpid(a,b,c) not_here("waitpid") #endif #ifndef HAS_MBLEN #ifndef mblen #define mblen(a,b) not_here("mblen") #endif #endif #ifndef HAS_MBSTOWCS #define mbstowcs(s, pwcs, n) not_here("mbstowcs") #endif #ifndef HAS_MBTOWC #define mbtowc(pwc, s, n) not_here("mbtowc") #endif #ifndef HAS_WCSTOMBS #define wcstombs(s, pwcs, n) not_here("wcstombs") #endif #ifndef HAS_WCTOMB #define wctomb(s, wchar) not_here("wcstombs") #endif #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB) /* If we don't have these functions, then we wouldn't have gotten a typedef for wchar_t, the wide character type. Defining wchar_t allows the functions referencing it to compile. Its actual type is then meaningless, since without the above functions, all sections using it end up calling not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */ #ifndef wchar_t #define wchar_t char #endif #endif #ifndef HAS_LOCALECONV #define localeconv() not_here("localeconv") #endif #ifdef HAS_TZNAME -# ifndef WIN32 +# if !defined(WIN32) && !defined(__CYGWIN__) extern char *tzname[]; # endif #else #if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname)) char *tzname[] = { "" , "" }; #endif #endif /* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) * fields for which we don't have Configure support yet: * char *tm_zone; -- abbreviation of timezone name * long tm_gmtoff; -- offset from GMT in seconds * To workaround core dumps from the uninitialised tm_zone we get the * system to give us a reasonable struct to copy. This fix means that * strftime uses the tm_zone and tm_gmtoff values returned by * localtime(time()). That should give the desired result most of the * time. But probably not always! * * This is a temporary workaround to be removed once Configure * support is added and NETaa14816 is considered in full. * It does not address tzname aspects of NETaa14816. */ #ifdef HAS_GNULIBC # ifndef STRUCT_TM_HASZONE -# define STRUCT_TM_HAS_ZONE +# define STRUCT_TM_HASZONE # endif #endif #ifdef STRUCT_TM_HASZONE static void -init_tm(ptm) /* see mktime, strftime and asctime */ - struct tm *ptm; +init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ { Time_t now; (void)time(&now); Copy(localtime(&now), ptm, 1, struct tm); } #else # 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 # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */ # endif #endif #ifndef HAS_LONG_DOUBLE #ifdef LDBL_MAX #undef LDBL_MAX #endif #ifdef LDBL_MIN #undef LDBL_MIN #endif #ifdef LDBL_EPSILON #undef LDBL_EPSILON #endif #endif static int not_here(char *s) { croak("POSIX::%s not implemented on this architecture", s); return -1; } static -#ifdef HAS_LONG_DOUBLE +#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE) long double #else double #endif constant(char *name, int arg) { errno = 0; switch (*name) { case 'A': if (strEQ(name, "ARG_MAX")) #ifdef ARG_MAX return ARG_MAX; #else goto not_there; #endif break; case 'B': if (strEQ(name, "BUFSIZ")) #ifdef BUFSIZ return BUFSIZ; #else goto not_there; #endif if (strEQ(name, "BRKINT")) #ifdef BRKINT return BRKINT; #else goto not_there; #endif if (strEQ(name, "B9600")) #ifdef B9600 return B9600; #else goto not_there; #endif if (strEQ(name, "B19200")) #ifdef B19200 return B19200; #else goto not_there; #endif if (strEQ(name, "B38400")) #ifdef B38400 return B38400; #else goto not_there; #endif if (strEQ(name, "B0")) #ifdef B0 return B0; #else goto not_there; #endif if (strEQ(name, "B110")) #ifdef B110 return B110; #else goto not_there; #endif if (strEQ(name, "B1200")) #ifdef B1200 return B1200; #else goto not_there; #endif if (strEQ(name, "B134")) #ifdef B134 return B134; #else goto not_there; #endif if (strEQ(name, "B150")) #ifdef B150 return B150; #else goto not_there; #endif if (strEQ(name, "B1800")) #ifdef B1800 return B1800; #else goto not_there; #endif if (strEQ(name, "B200")) #ifdef B200 return B200; #else goto not_there; #endif if (strEQ(name, "B2400")) #ifdef B2400 return B2400; #else goto not_there; #endif if (strEQ(name, "B300")) #ifdef B300 return B300; #else goto not_there; #endif if (strEQ(name, "B4800")) #ifdef B4800 return B4800; #else goto not_there; #endif if (strEQ(name, "B50")) #ifdef B50 return B50; #else goto not_there; #endif if (strEQ(name, "B600")) #ifdef B600 return B600; #else goto not_there; #endif if (strEQ(name, "B75")) #ifdef B75 return B75; #else goto not_there; #endif break; case 'C': if (strEQ(name, "CHAR_BIT")) #ifdef CHAR_BIT return CHAR_BIT; #else goto not_there; #endif if (strEQ(name, "CHAR_MAX")) #ifdef CHAR_MAX return CHAR_MAX; #else goto not_there; #endif if (strEQ(name, "CHAR_MIN")) #ifdef CHAR_MIN return CHAR_MIN; #else goto not_there; #endif if (strEQ(name, "CHILD_MAX")) #ifdef CHILD_MAX return CHILD_MAX; #else goto not_there; #endif if (strEQ(name, "CLK_TCK")) #ifdef CLK_TCK return CLK_TCK; #else goto not_there; #endif if (strEQ(name, "CLOCAL")) #ifdef CLOCAL return CLOCAL; #else goto not_there; #endif if (strEQ(name, "CLOCKS_PER_SEC")) #ifdef CLOCKS_PER_SEC return CLOCKS_PER_SEC; #else goto not_there; #endif if (strEQ(name, "CREAD")) #ifdef CREAD return CREAD; #else goto not_there; #endif if (strEQ(name, "CS5")) #ifdef CS5 return CS5; #else goto not_there; #endif if (strEQ(name, "CS6")) #ifdef CS6 return CS6; #else goto not_there; #endif if (strEQ(name, "CS7")) #ifdef CS7 return CS7; #else goto not_there; #endif if (strEQ(name, "CS8")) #ifdef CS8 return CS8; #else goto not_there; #endif if (strEQ(name, "CSIZE")) #ifdef CSIZE return CSIZE; #else goto not_there; #endif if (strEQ(name, "CSTOPB")) #ifdef CSTOPB return CSTOPB; #else goto not_there; #endif break; case 'D': if (strEQ(name, "DBL_MAX")) #ifdef DBL_MAX return DBL_MAX; #else goto not_there; #endif if (strEQ(name, "DBL_MIN")) #ifdef DBL_MIN return DBL_MIN; #else goto not_there; #endif if (strEQ(name, "DBL_DIG")) #ifdef DBL_DIG return DBL_DIG; #else goto not_there; #endif if (strEQ(name, "DBL_EPSILON")) #ifdef DBL_EPSILON return DBL_EPSILON; #else goto not_there; #endif if (strEQ(name, "DBL_MANT_DIG")) #ifdef DBL_MANT_DIG return DBL_MANT_DIG; #else goto not_there; #endif if (strEQ(name, "DBL_MAX_10_EXP")) #ifdef DBL_MAX_10_EXP return DBL_MAX_10_EXP; #else goto not_there; #endif if (strEQ(name, "DBL_MAX_EXP")) #ifdef DBL_MAX_EXP return DBL_MAX_EXP; #else goto not_there; #endif if (strEQ(name, "DBL_MIN_10_EXP")) #ifdef DBL_MIN_10_EXP return DBL_MIN_10_EXP; #else goto not_there; #endif if (strEQ(name, "DBL_MIN_EXP")) #ifdef DBL_MIN_EXP return DBL_MIN_EXP; #else goto not_there; #endif break; case 'E': switch (name[1]) { case 'A': if (strEQ(name, "EACCES")) #ifdef EACCES return EACCES; #else goto not_there; #endif if (strEQ(name, "EADDRINUSE")) #ifdef EADDRINUSE return EADDRINUSE; #else goto not_there; #endif if (strEQ(name, "EADDRNOTAVAIL")) #ifdef EADDRNOTAVAIL return EADDRNOTAVAIL; #else goto not_there; #endif if (strEQ(name, "EAFNOSUPPORT")) #ifdef EAFNOSUPPORT return EAFNOSUPPORT; #else goto not_there; #endif if (strEQ(name, "EAGAIN")) #ifdef EAGAIN return EAGAIN; #else goto not_there; #endif if (strEQ(name, "EALREADY")) #ifdef EALREADY return EALREADY; #else goto not_there; #endif break; case 'B': if (strEQ(name, "EBADF")) #ifdef EBADF return EBADF; #else goto not_there; #endif if (strEQ(name, "EBUSY")) #ifdef EBUSY return EBUSY; #else goto not_there; #endif break; case 'C': if (strEQ(name, "ECHILD")) #ifdef ECHILD return ECHILD; #else goto not_there; #endif if (strEQ(name, "ECHO")) #ifdef ECHO return ECHO; #else goto not_there; #endif if (strEQ(name, "ECHOE")) #ifdef ECHOE return ECHOE; #else goto not_there; #endif if (strEQ(name, "ECHOK")) #ifdef ECHOK return ECHOK; #else goto not_there; #endif if (strEQ(name, "ECHONL")) #ifdef ECHONL return ECHONL; #else goto not_there; #endif if (strEQ(name, "ECONNABORTED")) #ifdef ECONNABORTED return ECONNABORTED; #else goto not_there; #endif if (strEQ(name, "ECONNREFUSED")) #ifdef ECONNREFUSED return ECONNREFUSED; #else goto not_there; #endif if (strEQ(name, "ECONNRESET")) #ifdef ECONNRESET return ECONNRESET; #else goto not_there; #endif break; case 'D': if (strEQ(name, "EDEADLK")) #ifdef EDEADLK return EDEADLK; #else goto not_there; #endif if (strEQ(name, "EDESTADDRREQ")) #ifdef EDESTADDRREQ return EDESTADDRREQ; #else goto not_there; #endif if (strEQ(name, "EDOM")) #ifdef EDOM return EDOM; #else goto not_there; #endif if (strEQ(name, "EDQUOT")) #ifdef EDQUOT return EDQUOT; #else goto not_there; #endif break; case 'E': if (strEQ(name, "EEXIST")) #ifdef EEXIST return EEXIST; #else goto not_there; #endif break; case 'F': if (strEQ(name, "EFAULT")) #ifdef EFAULT return EFAULT; #else goto not_there; #endif if (strEQ(name, "EFBIG")) #ifdef EFBIG return EFBIG; #else goto not_there; #endif break; case 'H': if (strEQ(name, "EHOSTDOWN")) #ifdef EHOSTDOWN return EHOSTDOWN; #else goto not_there; #endif if (strEQ(name, "EHOSTUNREACH")) #ifdef EHOSTUNREACH return EHOSTUNREACH; #else goto not_there; #endif break; case 'I': if (strEQ(name, "EINPROGRESS")) #ifdef EINPROGRESS return EINPROGRESS; #else goto not_there; #endif if (strEQ(name, "EINTR")) #ifdef EINTR return EINTR; #else goto not_there; #endif if (strEQ(name, "EINVAL")) #ifdef EINVAL return EINVAL; #else goto not_there; #endif if (strEQ(name, "EIO")) #ifdef EIO return EIO; #else goto not_there; #endif if (strEQ(name, "EISCONN")) #ifdef EISCONN return EISCONN; #else goto not_there; #endif if (strEQ(name, "EISDIR")) #ifdef EISDIR return EISDIR; #else goto not_there; #endif break; case 'L': if (strEQ(name, "ELOOP")) #ifdef ELOOP return ELOOP; #else goto not_there; #endif break; case 'M': if (strEQ(name, "EMFILE")) #ifdef EMFILE return EMFILE; #else goto not_there; #endif if (strEQ(name, "EMLINK")) #ifdef EMLINK return EMLINK; #else goto not_there; #endif if (strEQ(name, "EMSGSIZE")) #ifdef EMSGSIZE return EMSGSIZE; #else goto not_there; #endif break; case 'N': if (strEQ(name, "ENETDOWN")) #ifdef ENETDOWN return ENETDOWN; #else goto not_there; #endif if (strEQ(name, "ENETRESET")) #ifdef ENETRESET return ENETRESET; #else goto not_there; #endif if (strEQ(name, "ENETUNREACH")) #ifdef ENETUNREACH return ENETUNREACH; #else goto not_there; #endif if (strEQ(name, "ENOBUFS")) #ifdef ENOBUFS return ENOBUFS; #else goto not_there; #endif if (strEQ(name, "ENOEXEC")) #ifdef ENOEXEC return ENOEXEC; #else goto not_there; #endif if (strEQ(name, "ENOMEM")) #ifdef ENOMEM return ENOMEM; #else goto not_there; #endif if (strEQ(name, "ENOPROTOOPT")) #ifdef ENOPROTOOPT return ENOPROTOOPT; #else goto not_there; #endif if (strEQ(name, "ENOSPC")) #ifdef ENOSPC return ENOSPC; #else goto not_there; #endif if (strEQ(name, "ENOTBLK")) #ifdef ENOTBLK return ENOTBLK; #else goto not_there; #endif if (strEQ(name, "ENOTCONN")) #ifdef ENOTCONN return ENOTCONN; #else goto not_there; #endif if (strEQ(name, "ENOTDIR")) #ifdef ENOTDIR return ENOTDIR; #else goto not_there; #endif if (strEQ(name, "ENOTEMPTY")) #ifdef ENOTEMPTY return ENOTEMPTY; #else goto not_there; #endif if (strEQ(name, "ENOTSOCK")) #ifdef ENOTSOCK return ENOTSOCK; #else goto not_there; #endif if (strEQ(name, "ENOTTY")) #ifdef ENOTTY return ENOTTY; #else goto not_there; #endif if (strEQ(name, "ENFILE")) #ifdef ENFILE return ENFILE; #else goto not_there; #endif if (strEQ(name, "ENODEV")) #ifdef ENODEV return ENODEV; #else goto not_there; #endif if (strEQ(name, "ENOENT")) #ifdef ENOENT return ENOENT; #else goto not_there; #endif if (strEQ(name, "ENOLCK")) #ifdef ENOLCK return ENOLCK; #else goto not_there; #endif if (strEQ(name, "ENOSYS")) #ifdef ENOSYS return ENOSYS; #else goto not_there; #endif if (strEQ(name, "ENXIO")) #ifdef ENXIO return ENXIO; #else goto not_there; #endif if (strEQ(name, "ENAMETOOLONG")) #ifdef ENAMETOOLONG return ENAMETOOLONG; #else goto not_there; #endif break; case 'O': if (strEQ(name, "EOF")) #ifdef EOF return EOF; #else goto not_there; #endif if (strEQ(name, "EOPNOTSUPP")) #ifdef EOPNOTSUPP return EOPNOTSUPP; #else goto not_there; #endif break; case 'P': if (strEQ(name, "EPERM")) #ifdef EPERM return EPERM; #else goto not_there; #endif if (strEQ(name, "EPFNOSUPPORT")) #ifdef EPFNOSUPPORT return EPFNOSUPPORT; #else goto not_there; #endif if (strEQ(name, "EPIPE")) #ifdef EPIPE return EPIPE; #else goto not_there; #endif if (strEQ(name, "EPROCLIM")) #ifdef EPROCLIM return EPROCLIM; #else goto not_there; #endif if (strEQ(name, "EPROTONOSUPPORT")) #ifdef EPROTONOSUPPORT return EPROTONOSUPPORT; #else goto not_there; #endif if (strEQ(name, "EPROTOTYPE")) #ifdef EPROTOTYPE return EPROTOTYPE; #else goto not_there; #endif break; case 'R': if (strEQ(name, "ERANGE")) #ifdef ERANGE return ERANGE; #else goto not_there; #endif if (strEQ(name, "EREMOTE")) #ifdef EREMOTE return EREMOTE; #else goto not_there; #endif if (strEQ(name, "ERESTART")) #ifdef ERESTART return ERESTART; #else goto not_there; #endif if (strEQ(name, "EROFS")) #ifdef EROFS return EROFS; #else goto not_there; #endif break; case 'S': if (strEQ(name, "ESHUTDOWN")) #ifdef ESHUTDOWN return ESHUTDOWN; #else goto not_there; #endif if (strEQ(name, "ESOCKTNOSUPPORT")) #ifdef ESOCKTNOSUPPORT return ESOCKTNOSUPPORT; #else goto not_there; #endif if (strEQ(name, "ESPIPE")) #ifdef ESPIPE return ESPIPE; #else goto not_there; #endif if (strEQ(name, "ESRCH")) #ifdef ESRCH return ESRCH; #else goto not_there; #endif if (strEQ(name, "ESTALE")) #ifdef ESTALE return ESTALE; #else goto not_there; #endif break; case 'T': if (strEQ(name, "ETIMEDOUT")) #ifdef ETIMEDOUT return ETIMEDOUT; #else goto not_there; #endif if (strEQ(name, "ETOOMANYREFS")) #ifdef ETOOMANYREFS return ETOOMANYREFS; #else goto not_there; #endif if (strEQ(name, "ETXTBSY")) #ifdef ETXTBSY return ETXTBSY; #else goto not_there; #endif break; case 'U': if (strEQ(name, "EUSERS")) #ifdef EUSERS return EUSERS; #else goto not_there; #endif break; case 'W': if (strEQ(name, "EWOULDBLOCK")) #ifdef EWOULDBLOCK return EWOULDBLOCK; #else goto not_there; #endif break; case 'X': if (strEQ(name, "EXIT_FAILURE")) #ifdef EXIT_FAILURE return EXIT_FAILURE; #else return 1; #endif if (strEQ(name, "EXIT_SUCCESS")) #ifdef EXIT_SUCCESS return EXIT_SUCCESS; #else return 0; #endif if (strEQ(name, "EXDEV")) #ifdef EXDEV return EXDEV; #else goto not_there; #endif break; } if (strEQ(name, "E2BIG")) #ifdef E2BIG return E2BIG; #else goto not_there; #endif break; case 'F': if (strnEQ(name, "FLT_", 4)) { if (strEQ(name, "FLT_MAX")) #ifdef FLT_MAX return FLT_MAX; #else goto not_there; #endif if (strEQ(name, "FLT_MIN")) #ifdef FLT_MIN return FLT_MIN; #else goto not_there; #endif if (strEQ(name, "FLT_ROUNDS")) #ifdef FLT_ROUNDS return FLT_ROUNDS; #else goto not_there; #endif if (strEQ(name, "FLT_DIG")) #ifdef FLT_DIG return FLT_DIG; #else goto not_there; #endif if (strEQ(name, "FLT_EPSILON")) #ifdef FLT_EPSILON return FLT_EPSILON; #else goto not_there; #endif if (strEQ(name, "FLT_MANT_DIG")) #ifdef FLT_MANT_DIG return FLT_MANT_DIG; #else goto not_there; #endif if (strEQ(name, "FLT_MAX_10_EXP")) #ifdef FLT_MAX_10_EXP return FLT_MAX_10_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_MAX_EXP")) #ifdef FLT_MAX_EXP return FLT_MAX_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_MIN_10_EXP")) #ifdef FLT_MIN_10_EXP return FLT_MIN_10_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_MIN_EXP")) #ifdef FLT_MIN_EXP return FLT_MIN_EXP; #else goto not_there; #endif if (strEQ(name, "FLT_RADIX")) #ifdef FLT_RADIX return FLT_RADIX; #else goto not_there; #endif break; } if (strnEQ(name, "F_", 2)) { if (strEQ(name, "F_DUPFD")) #ifdef F_DUPFD return F_DUPFD; #else goto not_there; #endif if (strEQ(name, "F_GETFD")) #ifdef F_GETFD return F_GETFD; #else goto not_there; #endif if (strEQ(name, "F_GETFL")) #ifdef F_GETFL return F_GETFL; #else goto not_there; #endif if (strEQ(name, "F_GETLK")) #ifdef F_GETLK return F_GETLK; #else goto not_there; #endif if (strEQ(name, "F_OK")) #ifdef F_OK return F_OK; #else goto not_there; #endif if (strEQ(name, "F_RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif if (strEQ(name, "F_SETFD")) #ifdef F_SETFD return F_SETFD; #else goto not_there; #endif if (strEQ(name, "F_SETFL")) #ifdef F_SETFL return F_SETFL; #else goto not_there; #endif if (strEQ(name, "F_SETLK")) #ifdef F_SETLK return F_SETLK; #else goto not_there; #endif if (strEQ(name, "F_SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif if (strEQ(name, "F_UNLCK")) #ifdef F_UNLCK return F_UNLCK; #else goto not_there; #endif if (strEQ(name, "F_WRLCK")) #ifdef F_WRLCK return F_WRLCK; #else goto not_there; #endif break; } if (strEQ(name, "FD_CLOEXEC")) #ifdef FD_CLOEXEC return FD_CLOEXEC; #else goto not_there; #endif if (strEQ(name, "FILENAME_MAX")) #ifdef FILENAME_MAX return FILENAME_MAX; #else goto not_there; #endif break; case 'H': if (strEQ(name, "HUGE_VAL")) #ifdef HUGE_VAL return HUGE_VAL; #else goto not_there; #endif if (strEQ(name, "HUPCL")) #ifdef HUPCL return HUPCL; #else goto not_there; #endif break; case 'I': if (strEQ(name, "INT_MAX")) #ifdef INT_MAX return INT_MAX; #else goto not_there; #endif if (strEQ(name, "INT_MIN")) #ifdef INT_MIN return INT_MIN; #else goto not_there; #endif if (strEQ(name, "ICANON")) #ifdef ICANON return ICANON; #else goto not_there; #endif if (strEQ(name, "ICRNL")) #ifdef ICRNL return ICRNL; #else goto not_there; #endif if (strEQ(name, "IEXTEN")) #ifdef IEXTEN return IEXTEN; #else goto not_there; #endif if (strEQ(name, "IGNBRK")) #ifdef IGNBRK return IGNBRK; #else goto not_there; #endif if (strEQ(name, "IGNCR")) #ifdef IGNCR return IGNCR; #else goto not_there; #endif if (strEQ(name, "IGNPAR")) #ifdef IGNPAR return IGNPAR; #else goto not_there; #endif if (strEQ(name, "INLCR")) #ifdef INLCR return INLCR; #else goto not_there; #endif if (strEQ(name, "INPCK")) #ifdef INPCK return INPCK; #else goto not_there; #endif if (strEQ(name, "ISIG")) #ifdef ISIG return ISIG; #else goto not_there; #endif if (strEQ(name, "ISTRIP")) #ifdef ISTRIP return ISTRIP; #else goto not_there; #endif if (strEQ(name, "IXOFF")) #ifdef IXOFF return IXOFF; #else goto not_there; #endif if (strEQ(name, "IXON")) #ifdef IXON return IXON; #else goto not_there; #endif break; case 'L': if (strnEQ(name, "LC_", 3)) { if (strEQ(name, "LC_ALL")) #ifdef LC_ALL return LC_ALL; #else goto not_there; #endif if (strEQ(name, "LC_COLLATE")) #ifdef LC_COLLATE return LC_COLLATE; #else goto not_there; #endif if (strEQ(name, "LC_CTYPE")) #ifdef LC_CTYPE return LC_CTYPE; #else goto not_there; #endif if (strEQ(name, "LC_MONETARY")) #ifdef LC_MONETARY return LC_MONETARY; #else goto not_there; #endif if (strEQ(name, "LC_NUMERIC")) #ifdef LC_NUMERIC return LC_NUMERIC; #else goto not_there; #endif if (strEQ(name, "LC_TIME")) #ifdef LC_TIME return LC_TIME; #else goto not_there; #endif break; } if (strnEQ(name, "LDBL_", 5)) { if (strEQ(name, "LDBL_MAX")) #ifdef LDBL_MAX return LDBL_MAX; #else goto not_there; #endif if (strEQ(name, "LDBL_MIN")) #ifdef LDBL_MIN return LDBL_MIN; #else goto not_there; #endif if (strEQ(name, "LDBL_DIG")) #ifdef LDBL_DIG return LDBL_DIG; #else goto not_there; #endif if (strEQ(name, "LDBL_EPSILON")) #ifdef LDBL_EPSILON return LDBL_EPSILON; #else goto not_there; #endif if (strEQ(name, "LDBL_MANT_DIG")) #ifdef LDBL_MANT_DIG return LDBL_MANT_DIG; #else goto not_there; #endif if (strEQ(name, "LDBL_MAX_10_EXP")) #ifdef LDBL_MAX_10_EXP return LDBL_MAX_10_EXP; #else goto not_there; #endif if (strEQ(name, "LDBL_MAX_EXP")) #ifdef LDBL_MAX_EXP return LDBL_MAX_EXP; #else goto not_there; #endif if (strEQ(name, "LDBL_MIN_10_EXP")) #ifdef LDBL_MIN_10_EXP return LDBL_MIN_10_EXP; #else goto not_there; #endif if (strEQ(name, "LDBL_MIN_EXP")) #ifdef LDBL_MIN_EXP return LDBL_MIN_EXP; #else goto not_there; #endif break; } if (strnEQ(name, "L_", 2)) { if (strEQ(name, "L_ctermid")) #ifdef L_ctermid return L_ctermid; #else goto not_there; #endif if (strEQ(name, "L_cuserid")) #ifdef L_cuserid return L_cuserid; #else goto not_there; #endif - if (strEQ(name, "L_tmpname")) -#ifdef L_tmpname - return L_tmpname; + /* L_tmpnam[e] was a typo--retained for compatibility */ + if (strEQ(name, "L_tmpname") || strEQ(name, "L_tmpnam")) +#ifdef L_tmpnam + return L_tmpnam; #else goto not_there; #endif break; } if (strEQ(name, "LONG_MAX")) #ifdef LONG_MAX return LONG_MAX; #else goto not_there; #endif if (strEQ(name, "LONG_MIN")) #ifdef LONG_MIN return LONG_MIN; #else goto not_there; #endif if (strEQ(name, "LINK_MAX")) #ifdef LINK_MAX return LINK_MAX; #else goto not_there; #endif break; case 'M': if (strEQ(name, "MAX_CANON")) #ifdef MAX_CANON return MAX_CANON; #else goto not_there; #endif if (strEQ(name, "MAX_INPUT")) #ifdef MAX_INPUT return MAX_INPUT; #else goto not_there; #endif if (strEQ(name, "MB_CUR_MAX")) #ifdef MB_CUR_MAX return MB_CUR_MAX; #else goto not_there; #endif if (strEQ(name, "MB_LEN_MAX")) #ifdef MB_LEN_MAX return MB_LEN_MAX; #else goto not_there; #endif break; case 'N': if (strEQ(name, "NULL")) return 0; if (strEQ(name, "NAME_MAX")) #ifdef NAME_MAX return NAME_MAX; #else goto not_there; #endif if (strEQ(name, "NCCS")) #ifdef NCCS return NCCS; #else goto not_there; #endif if (strEQ(name, "NGROUPS_MAX")) #ifdef NGROUPS_MAX return NGROUPS_MAX; #else goto not_there; #endif if (strEQ(name, "NOFLSH")) #ifdef NOFLSH return NOFLSH; #else goto not_there; #endif break; case 'O': if (strnEQ(name, "O_", 2)) { if (strEQ(name, "O_APPEND")) #ifdef O_APPEND return O_APPEND; #else goto not_there; #endif if (strEQ(name, "O_CREAT")) #ifdef O_CREAT return O_CREAT; #else goto not_there; #endif if (strEQ(name, "O_TRUNC")) #ifdef O_TRUNC return O_TRUNC; #else goto not_there; #endif if (strEQ(name, "O_RDONLY")) #ifdef O_RDONLY return O_RDONLY; #else goto not_there; #endif if (strEQ(name, "O_RDWR")) #ifdef O_RDWR return O_RDWR; #else goto not_there; #endif if (strEQ(name, "O_WRONLY")) #ifdef O_WRONLY return O_WRONLY; #else goto not_there; #endif if (strEQ(name, "O_EXCL")) #ifdef O_EXCL return O_EXCL; #else goto not_there; #endif if (strEQ(name, "O_NOCTTY")) #ifdef O_NOCTTY return O_NOCTTY; #else goto not_there; #endif if (strEQ(name, "O_NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif if (strEQ(name, "O_ACCMODE")) #ifdef O_ACCMODE return O_ACCMODE; #else goto not_there; #endif break; } if (strEQ(name, "OPEN_MAX")) #ifdef OPEN_MAX return OPEN_MAX; #else goto not_there; #endif if (strEQ(name, "OPOST")) #ifdef OPOST return OPOST; #else goto not_there; #endif break; case 'P': if (strEQ(name, "PATH_MAX")) #ifdef PATH_MAX return PATH_MAX; #else goto not_there; #endif if (strEQ(name, "PARENB")) #ifdef PARENB return PARENB; #else goto not_there; #endif if (strEQ(name, "PARMRK")) #ifdef PARMRK return PARMRK; #else goto not_there; #endif if (strEQ(name, "PARODD")) #ifdef PARODD return PARODD; #else goto not_there; #endif if (strEQ(name, "PIPE_BUF")) #ifdef PIPE_BUF return PIPE_BUF; #else goto not_there; #endif break; case 'R': if (strEQ(name, "RAND_MAX")) #ifdef RAND_MAX return RAND_MAX; #else goto not_there; #endif if (strEQ(name, "R_OK")) #ifdef R_OK return R_OK; #else goto not_there; #endif break; case 'S': if (strnEQ(name, "SIG", 3)) { if (name[3] == '_') { if (strEQ(name, "SIG_BLOCK")) #ifdef SIG_BLOCK return SIG_BLOCK; #else goto not_there; #endif #ifdef SIG_DFL if (strEQ(name, "SIG_DFL")) return (IV)SIG_DFL; #endif #ifdef SIG_ERR if (strEQ(name, "SIG_ERR")) return (IV)SIG_ERR; #endif #ifdef SIG_IGN if (strEQ(name, "SIG_IGN")) return (IV)SIG_IGN; #endif if (strEQ(name, "SIG_SETMASK")) #ifdef SIG_SETMASK return SIG_SETMASK; #else goto not_there; #endif if (strEQ(name, "SIG_UNBLOCK")) #ifdef SIG_UNBLOCK return SIG_UNBLOCK; #else goto not_there; #endif break; } if (strEQ(name, "SIGABRT")) #ifdef SIGABRT return SIGABRT; #else goto not_there; #endif if (strEQ(name, "SIGALRM")) #ifdef SIGALRM return SIGALRM; #else goto not_there; #endif if (strEQ(name, "SIGCHLD")) #ifdef SIGCHLD return SIGCHLD; #else goto not_there; #endif if (strEQ(name, "SIGCONT")) #ifdef SIGCONT return SIGCONT; #else goto not_there; #endif if (strEQ(name, "SIGFPE")) #ifdef SIGFPE return SIGFPE; #else goto not_there; #endif if (strEQ(name, "SIGHUP")) #ifdef SIGHUP return SIGHUP; #else goto not_there; #endif if (strEQ(name, "SIGILL")) #ifdef SIGILL return SIGILL; #else goto not_there; #endif if (strEQ(name, "SIGINT")) #ifdef SIGINT return SIGINT; #else goto not_there; #endif if (strEQ(name, "SIGKILL")) #ifdef SIGKILL return SIGKILL; #else goto not_there; #endif if (strEQ(name, "SIGPIPE")) #ifdef SIGPIPE return SIGPIPE; #else goto not_there; #endif if (strEQ(name, "SIGQUIT")) #ifdef SIGQUIT return SIGQUIT; #else goto not_there; #endif if (strEQ(name, "SIGSEGV")) #ifdef SIGSEGV return SIGSEGV; #else goto not_there; #endif if (strEQ(name, "SIGSTOP")) #ifdef SIGSTOP return SIGSTOP; #else goto not_there; #endif if (strEQ(name, "SIGTERM")) #ifdef SIGTERM return SIGTERM; #else goto not_there; #endif if (strEQ(name, "SIGTSTP")) #ifdef SIGTSTP return SIGTSTP; #else goto not_there; #endif if (strEQ(name, "SIGTTIN")) #ifdef SIGTTIN return SIGTTIN; #else goto not_there; #endif if (strEQ(name, "SIGTTOU")) #ifdef SIGTTOU return SIGTTOU; #else goto not_there; #endif if (strEQ(name, "SIGUSR1")) #ifdef SIGUSR1 return SIGUSR1; #else goto not_there; #endif if (strEQ(name, "SIGUSR2")) #ifdef SIGUSR2 return SIGUSR2; #else goto not_there; #endif break; } if (name[1] == '_') { if (strEQ(name, "S_ISGID")) #ifdef S_ISGID return S_ISGID; #else goto not_there; #endif if (strEQ(name, "S_ISUID")) #ifdef S_ISUID return S_ISUID; #else goto not_there; #endif if (strEQ(name, "S_IRGRP")) #ifdef S_IRGRP return S_IRGRP; #else goto not_there; #endif if (strEQ(name, "S_IROTH")) #ifdef S_IROTH return S_IROTH; #else goto not_there; #endif if (strEQ(name, "S_IRUSR")) #ifdef S_IRUSR return S_IRUSR; #else goto not_there; #endif if (strEQ(name, "S_IRWXG")) #ifdef S_IRWXG return S_IRWXG; #else goto not_there; #endif if (strEQ(name, "S_IRWXO")) #ifdef S_IRWXO return S_IRWXO; #else goto not_there; #endif if (strEQ(name, "S_IRWXU")) #ifdef S_IRWXU return S_IRWXU; #else goto not_there; #endif if (strEQ(name, "S_IWGRP")) #ifdef S_IWGRP return S_IWGRP; #else goto not_there; #endif if (strEQ(name, "S_IWOTH")) #ifdef S_IWOTH return S_IWOTH; #else goto not_there; #endif if (strEQ(name, "S_IWUSR")) #ifdef S_IWUSR return S_IWUSR; #else goto not_there; #endif if (strEQ(name, "S_IXGRP")) #ifdef S_IXGRP return S_IXGRP; #else goto not_there; #endif if (strEQ(name, "S_IXOTH")) #ifdef S_IXOTH return S_IXOTH; #else goto not_there; #endif if (strEQ(name, "S_IXUSR")) #ifdef S_IXUSR return S_IXUSR; #else goto not_there; #endif errno = EAGAIN; /* the following aren't constants */ #ifdef S_ISBLK if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg); #endif #ifdef S_ISCHR if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg); #endif #ifdef S_ISDIR if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg); #endif #ifdef S_ISFIFO if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg); #endif #ifdef S_ISREG if (strEQ(name, "S_ISREG")) return S_ISREG(arg); #endif break; } if (strEQ(name, "SEEK_CUR")) #ifdef SEEK_CUR return SEEK_CUR; #else goto not_there; #endif if (strEQ(name, "SEEK_END")) #ifdef SEEK_END return SEEK_END; #else goto not_there; #endif if (strEQ(name, "SEEK_SET")) #ifdef SEEK_SET return SEEK_SET; #else goto not_there; #endif if (strEQ(name, "STREAM_MAX")) #ifdef STREAM_MAX return STREAM_MAX; #else goto not_there; #endif if (strEQ(name, "SHRT_MAX")) #ifdef SHRT_MAX return SHRT_MAX; #else goto not_there; #endif if (strEQ(name, "SHRT_MIN")) #ifdef SHRT_MIN return SHRT_MIN; #else goto not_there; #endif if (strnEQ(name, "SA_", 3)) { if (strEQ(name, "SA_NOCLDSTOP")) #ifdef SA_NOCLDSTOP return SA_NOCLDSTOP; #else goto not_there; #endif if (strEQ(name, "SA_NOCLDWAIT")) #ifdef SA_NOCLDWAIT return SA_NOCLDWAIT; #else goto not_there; #endif if (strEQ(name, "SA_NODEFER")) #ifdef SA_NODEFER return SA_NODEFER; #else goto not_there; #endif if (strEQ(name, "SA_ONSTACK")) #ifdef SA_ONSTACK return SA_ONSTACK; #else goto not_there; #endif if (strEQ(name, "SA_RESETHAND")) #ifdef SA_RESETHAND return SA_RESETHAND; #else goto not_there; #endif if (strEQ(name, "SA_RESTART")) #ifdef SA_RESTART return SA_RESTART; #else goto not_there; #endif if (strEQ(name, "SA_SIGINFO")) #ifdef SA_SIGINFO return SA_SIGINFO; #else goto not_there; #endif break; } if (strEQ(name, "SCHAR_MAX")) #ifdef SCHAR_MAX return SCHAR_MAX; #else goto not_there; #endif if (strEQ(name, "SCHAR_MIN")) #ifdef SCHAR_MIN return SCHAR_MIN; #else goto not_there; #endif if (strEQ(name, "SSIZE_MAX")) #ifdef SSIZE_MAX return SSIZE_MAX; #else goto not_there; #endif if (strEQ(name, "STDIN_FILENO")) #ifdef STDIN_FILENO return STDIN_FILENO; #else goto not_there; #endif if (strEQ(name, "STDOUT_FILENO")) #ifdef STDOUT_FILENO return STDOUT_FILENO; #else goto not_there; #endif if (strEQ(name, "STRERR_FILENO")) #ifdef STRERR_FILENO return STRERR_FILENO; #else goto not_there; #endif break; case 'T': if (strEQ(name, "TCIFLUSH")) #ifdef TCIFLUSH return TCIFLUSH; #else goto not_there; #endif if (strEQ(name, "TCIOFF")) #ifdef TCIOFF return TCIOFF; #else goto not_there; #endif if (strEQ(name, "TCIOFLUSH")) #ifdef TCIOFLUSH return TCIOFLUSH; #else goto not_there; #endif if (strEQ(name, "TCION")) #ifdef TCION return TCION; #else goto not_there; #endif if (strEQ(name, "TCOFLUSH")) #ifdef TCOFLUSH return TCOFLUSH; #else goto not_there; #endif if (strEQ(name, "TCOOFF")) #ifdef TCOOFF return TCOOFF; #else goto not_there; #endif if (strEQ(name, "TCOON")) #ifdef TCOON return TCOON; #else goto not_there; #endif if (strEQ(name, "TCSADRAIN")) #ifdef TCSADRAIN return TCSADRAIN; #else goto not_there; #endif if (strEQ(name, "TCSAFLUSH")) #ifdef TCSAFLUSH return TCSAFLUSH; #else goto not_there; #endif if (strEQ(name, "TCSANOW")) #ifdef TCSANOW return TCSANOW; #else goto not_there; #endif if (strEQ(name, "TMP_MAX")) #ifdef TMP_MAX return TMP_MAX; #else goto not_there; #endif if (strEQ(name, "TOSTOP")) #ifdef TOSTOP return TOSTOP; #else goto not_there; #endif if (strEQ(name, "TZNAME_MAX")) #ifdef TZNAME_MAX return TZNAME_MAX; #else goto not_there; #endif break; case 'U': if (strEQ(name, "UCHAR_MAX")) #ifdef UCHAR_MAX return UCHAR_MAX; #else goto not_there; #endif if (strEQ(name, "UINT_MAX")) #ifdef UINT_MAX return UINT_MAX; #else goto not_there; #endif if (strEQ(name, "ULONG_MAX")) #ifdef ULONG_MAX return ULONG_MAX; #else goto not_there; #endif if (strEQ(name, "USHRT_MAX")) #ifdef USHRT_MAX return USHRT_MAX; #else goto not_there; #endif break; case 'V': if (strEQ(name, "VEOF")) #ifdef VEOF return VEOF; #else goto not_there; #endif if (strEQ(name, "VEOL")) #ifdef VEOL return VEOL; #else goto not_there; #endif if (strEQ(name, "VERASE")) #ifdef VERASE return VERASE; #else goto not_there; #endif if (strEQ(name, "VINTR")) #ifdef VINTR return VINTR; #else goto not_there; #endif if (strEQ(name, "VKILL")) #ifdef VKILL return VKILL; #else goto not_there; #endif if (strEQ(name, "VMIN")) #ifdef VMIN return VMIN; #else goto not_there; #endif if (strEQ(name, "VQUIT")) #ifdef VQUIT return VQUIT; #else goto not_there; #endif if (strEQ(name, "VSTART")) #ifdef VSTART return VSTART; #else goto not_there; #endif if (strEQ(name, "VSTOP")) #ifdef VSTOP return VSTOP; #else goto not_there; #endif if (strEQ(name, "VSUSP")) #ifdef VSUSP return VSUSP; #else goto not_there; #endif if (strEQ(name, "VTIME")) #ifdef VTIME return VTIME; #else goto not_there; #endif break; case 'W': if (strEQ(name, "W_OK")) #ifdef W_OK return W_OK; #else goto not_there; #endif if (strEQ(name, "WNOHANG")) #ifdef WNOHANG return WNOHANG; #else goto not_there; #endif if (strEQ(name, "WUNTRACED")) #ifdef WUNTRACED return WUNTRACED; #else goto not_there; #endif errno = EAGAIN; /* the following aren't constants */ #ifdef WEXITSTATUS if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg); #endif #ifdef WIFEXITED if (strEQ(name, "WIFEXITED")) return WIFEXITED(arg); #endif #ifdef WIFSIGNALED if (strEQ(name, "WIFSIGNALED")) return WIFSIGNALED(arg); #endif #ifdef WIFSTOPPED if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg); #endif #ifdef WSTOPSIG if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg); #endif #ifdef WTERMSIG if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg); #endif break; case 'X': if (strEQ(name, "X_OK")) #ifdef X_OK return X_OK; #else goto not_there; #endif break; case '_': if (strnEQ(name, "_PC_", 4)) { if (strEQ(name, "_PC_CHOWN_RESTRICTED")) #if defined(_PC_CHOWN_RESTRICTED) || HINT_SC_EXIST return _PC_CHOWN_RESTRICTED; #else goto not_there; #endif if (strEQ(name, "_PC_LINK_MAX")) #if defined(_PC_LINK_MAX) || HINT_SC_EXIST return _PC_LINK_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_CANON")) #if defined(_PC_MAX_CANON) || HINT_SC_EXIST return _PC_MAX_CANON; #else goto not_there; #endif if (strEQ(name, "_PC_MAX_INPUT")) #if defined(_PC_MAX_INPUT) || HINT_SC_EXIST return _PC_MAX_INPUT; #else goto not_there; #endif if (strEQ(name, "_PC_NAME_MAX")) #if defined(_PC_NAME_MAX) || HINT_SC_EXIST return _PC_NAME_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_NO_TRUNC")) #if defined(_PC_NO_TRUNC) || HINT_SC_EXIST return _PC_NO_TRUNC; #else goto not_there; #endif if (strEQ(name, "_PC_PATH_MAX")) #if defined(_PC_PATH_MAX) || HINT_SC_EXIST return _PC_PATH_MAX; #else goto not_there; #endif if (strEQ(name, "_PC_PIPE_BUF")) #if defined(_PC_PIPE_BUF) || HINT_SC_EXIST return _PC_PIPE_BUF; #else goto not_there; #endif if (strEQ(name, "_PC_VDISABLE")) #if defined(_PC_VDISABLE) || HINT_SC_EXIST return _PC_VDISABLE; #else goto not_there; #endif break; } if (strnEQ(name, "_POSIX_", 7)) { if (strEQ(name, "_POSIX_ARG_MAX")) #ifdef _POSIX_ARG_MAX return _POSIX_ARG_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_CHILD_MAX")) #ifdef _POSIX_CHILD_MAX return _POSIX_CHILD_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_CHOWN_RESTRICTED")) #ifdef _POSIX_CHOWN_RESTRICTED return _POSIX_CHOWN_RESTRICTED; #else return 0; #endif if (strEQ(name, "_POSIX_JOB_CONTROL")) #ifdef _POSIX_JOB_CONTROL return _POSIX_JOB_CONTROL; #else return 0; #endif if (strEQ(name, "_POSIX_LINK_MAX")) #ifdef _POSIX_LINK_MAX return _POSIX_LINK_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_MAX_CANON")) #ifdef _POSIX_MAX_CANON return _POSIX_MAX_CANON; #else return 0; #endif if (strEQ(name, "_POSIX_MAX_INPUT")) #ifdef _POSIX_MAX_INPUT return _POSIX_MAX_INPUT; #else return 0; #endif if (strEQ(name, "_POSIX_NAME_MAX")) #ifdef _POSIX_NAME_MAX return _POSIX_NAME_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_NGROUPS_MAX")) #ifdef _POSIX_NGROUPS_MAX return _POSIX_NGROUPS_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_NO_TRUNC")) #ifdef _POSIX_NO_TRUNC return _POSIX_NO_TRUNC; #else return 0; #endif if (strEQ(name, "_POSIX_OPEN_MAX")) #ifdef _POSIX_OPEN_MAX return _POSIX_OPEN_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_PATH_MAX")) #ifdef _POSIX_PATH_MAX return _POSIX_PATH_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_PIPE_BUF")) #ifdef _POSIX_PIPE_BUF return _POSIX_PIPE_BUF; #else return 0; #endif if (strEQ(name, "_POSIX_SAVED_IDS")) #ifdef _POSIX_SAVED_IDS return _POSIX_SAVED_IDS; #else return 0; #endif if (strEQ(name, "_POSIX_SSIZE_MAX")) #ifdef _POSIX_SSIZE_MAX return _POSIX_SSIZE_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_STREAM_MAX")) #ifdef _POSIX_STREAM_MAX return _POSIX_STREAM_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_TZNAME_MAX")) #ifdef _POSIX_TZNAME_MAX return _POSIX_TZNAME_MAX; #else return 0; #endif if (strEQ(name, "_POSIX_VDISABLE")) #ifdef _POSIX_VDISABLE return _POSIX_VDISABLE; #else return 0; #endif if (strEQ(name, "_POSIX_VERSION")) #ifdef _POSIX_VERSION return _POSIX_VERSION; #else return 0; #endif break; } if (strnEQ(name, "_SC_", 4)) { if (strEQ(name, "_SC_ARG_MAX")) #if defined(_SC_ARG_MAX) || HINT_SC_EXIST return _SC_ARG_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CHILD_MAX")) #if defined(_SC_CHILD_MAX) || HINT_SC_EXIST return _SC_CHILD_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_CLK_TCK")) #if defined(_SC_CLK_TCK) || HINT_SC_EXIST return _SC_CLK_TCK; #else goto not_there; #endif if (strEQ(name, "_SC_JOB_CONTROL")) #if defined(_SC_JOB_CONTROL) || HINT_SC_EXIST return _SC_JOB_CONTROL; #else goto not_there; #endif if (strEQ(name, "_SC_NGROUPS_MAX")) #if defined(_SC_NGROUPS_MAX) || HINT_SC_EXIST return _SC_NGROUPS_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_OPEN_MAX")) #if defined(_SC_OPEN_MAX) || HINT_SC_EXIST return _SC_OPEN_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_SAVED_IDS")) #if defined(_SC_SAVED_IDS) || HINT_SC_EXIST return _SC_SAVED_IDS; #else goto not_there; #endif if (strEQ(name, "_SC_STREAM_MAX")) #if defined(_SC_STREAM_MAX) || HINT_SC_EXIST return _SC_STREAM_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_TZNAME_MAX")) #if defined(_SC_TZNAME_MAX) || HINT_SC_EXIST return _SC_TZNAME_MAX; #else goto not_there; #endif if (strEQ(name, "_SC_VERSION")) #if defined(_SC_VERSION) || HINT_SC_EXIST return _SC_VERSION; #else goto not_there; #endif break; } } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig POSIX::SigSet new(packname = "POSIX::SigSet", ...) char * packname CODE: { int i; New(0, RETVAL, 1, sigset_t); sigemptyset(RETVAL); for (i = 1; i < items; i++) sigaddset(RETVAL, SvIV(ST(i))); } OUTPUT: RETVAL void DESTROY(sigset) POSIX::SigSet sigset CODE: Safefree(sigset); SysRet sigaddset(sigset, sig) POSIX::SigSet sigset int sig SysRet sigdelset(sigset, sig) POSIX::SigSet sigset int sig SysRet sigemptyset(sigset) POSIX::SigSet sigset SysRet sigfillset(sigset) POSIX::SigSet sigset int sigismember(sigset, sig) POSIX::SigSet sigset int sig MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf POSIX::Termios new(packname = "POSIX::Termios", ...) char * packname CODE: { #ifdef I_TERMIOS New(0, RETVAL, 1, struct termios); #else not_here("termios"); RETVAL = 0; #endif } OUTPUT: RETVAL void DESTROY(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS Safefree(termios_ref); #else not_here("termios"); #endif SysRet getattr(termios_ref, fd = 0) POSIX::Termios termios_ref int fd CODE: RETVAL = tcgetattr(fd, termios_ref); OUTPUT: RETVAL SysRet setattr(termios_ref, fd = 0, optional_actions = 0) POSIX::Termios termios_ref int fd int optional_actions CODE: RETVAL = tcsetattr(fd, optional_actions, termios_ref); OUTPUT: RETVAL speed_t cfgetispeed(termios_ref) POSIX::Termios termios_ref speed_t cfgetospeed(termios_ref) POSIX::Termios termios_ref tcflag_t getiflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_iflag; #else not_here("getiflag"); RETVAL = 0; #endif OUTPUT: RETVAL tcflag_t getoflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_oflag; #else not_here("getoflag"); RETVAL = 0; #endif OUTPUT: RETVAL tcflag_t getcflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_cflag; #else not_here("getcflag"); RETVAL = 0; #endif OUTPUT: RETVAL tcflag_t getlflag(termios_ref) POSIX::Termios termios_ref CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ RETVAL = termios_ref->c_lflag; #else not_here("getlflag"); RETVAL = 0; #endif OUTPUT: RETVAL cc_t getcc(termios_ref, ccix) POSIX::Termios termios_ref int ccix CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ if (ccix >= NCCS) croak("Bad getcc subscript"); RETVAL = termios_ref->c_cc[ccix]; #else not_here("getcc"); RETVAL = 0; #endif OUTPUT: RETVAL SysRet cfsetispeed(termios_ref, speed) POSIX::Termios termios_ref speed_t speed SysRet cfsetospeed(termios_ref, speed) POSIX::Termios termios_ref speed_t speed void setiflag(termios_ref, iflag) POSIX::Termios termios_ref tcflag_t iflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_iflag = iflag; #else not_here("setiflag"); #endif void setoflag(termios_ref, oflag) POSIX::Termios termios_ref tcflag_t oflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_oflag = oflag; #else not_here("setoflag"); #endif void setcflag(termios_ref, cflag) POSIX::Termios termios_ref tcflag_t cflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_cflag = cflag; #else not_here("setcflag"); #endif void setlflag(termios_ref, lflag) POSIX::Termios termios_ref tcflag_t lflag CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ termios_ref->c_lflag = lflag; #else not_here("setlflag"); #endif void setcc(termios_ref, ccix, cc) POSIX::Termios termios_ref int ccix cc_t cc CODE: #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */ if (ccix >= NCCS) croak("Bad setcc subscript"); termios_ref->c_cc[ccix] = cc; #else not_here("setcc"); #endif MODULE = POSIX PACKAGE = POSIX double constant(name,arg) char * name int arg int isalnum(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isalnum(*s)) RETVAL = 0; OUTPUT: RETVAL int isalpha(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isalpha(*s)) RETVAL = 0; OUTPUT: RETVAL int iscntrl(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!iscntrl(*s)) RETVAL = 0; OUTPUT: RETVAL int isdigit(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isdigit(*s)) RETVAL = 0; OUTPUT: RETVAL int isgraph(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isgraph(*s)) RETVAL = 0; OUTPUT: RETVAL int islower(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!islower(*s)) RETVAL = 0; OUTPUT: RETVAL int isprint(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isprint(*s)) RETVAL = 0; OUTPUT: RETVAL int ispunct(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!ispunct(*s)) RETVAL = 0; OUTPUT: RETVAL int isspace(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isspace(*s)) RETVAL = 0; OUTPUT: RETVAL int isupper(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isupper(*s)) RETVAL = 0; OUTPUT: RETVAL int isxdigit(charstring) unsigned char * charstring CODE: unsigned char *s = charstring; unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */ for (RETVAL = 1; RETVAL && s < e; s++) if (!isxdigit(*s)) RETVAL = 0; OUTPUT: RETVAL SysRet open(filename, flags = O_RDONLY, mode = 0666) char * filename int flags Mode_t mode CODE: if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL)) TAINT_PROPER("open"); RETVAL = open(filename, flags, mode); OUTPUT: RETVAL HV * localeconv() CODE: #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); if (lcbuf = localeconv()) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) hv_store(RETVAL, "decimal_point", 13, newSVpv(lcbuf->decimal_point, 0), 0); if (lcbuf->thousands_sep && *lcbuf->thousands_sep) hv_store(RETVAL, "thousands_sep", 13, newSVpv(lcbuf->thousands_sep, 0), 0); #ifndef NO_LOCALECONV_GROUPING if (lcbuf->grouping && *lcbuf->grouping) hv_store(RETVAL, "grouping", 8, newSVpv(lcbuf->grouping, 0), 0); #endif if (lcbuf->int_curr_symbol && *lcbuf->int_curr_symbol) hv_store(RETVAL, "int_curr_symbol", 15, newSVpv(lcbuf->int_curr_symbol, 0), 0); if (lcbuf->currency_symbol && *lcbuf->currency_symbol) hv_store(RETVAL, "currency_symbol", 15, newSVpv(lcbuf->currency_symbol, 0), 0); if (lcbuf->mon_decimal_point && *lcbuf->mon_decimal_point) hv_store(RETVAL, "mon_decimal_point", 17, newSVpv(lcbuf->mon_decimal_point, 0), 0); #ifndef NO_LOCALECONV_MON_THOUSANDS_SEP if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep) hv_store(RETVAL, "mon_thousands_sep", 17, newSVpv(lcbuf->mon_thousands_sep, 0), 0); #endif #ifndef NO_LOCALECONV_MON_GROUPING if (lcbuf->mon_grouping && *lcbuf->mon_grouping) hv_store(RETVAL, "mon_grouping", 12, newSVpv(lcbuf->mon_grouping, 0), 0); #endif if (lcbuf->positive_sign && *lcbuf->positive_sign) hv_store(RETVAL, "positive_sign", 13, newSVpv(lcbuf->positive_sign, 0), 0); if (lcbuf->negative_sign && *lcbuf->negative_sign) hv_store(RETVAL, "negative_sign", 13, newSVpv(lcbuf->negative_sign, 0), 0); /* the integers */ if (lcbuf->int_frac_digits != CHAR_MAX) hv_store(RETVAL, "int_frac_digits", 15, newSViv(lcbuf->int_frac_digits), 0); if (lcbuf->frac_digits != CHAR_MAX) hv_store(RETVAL, "frac_digits", 11, newSViv(lcbuf->frac_digits), 0); if (lcbuf->p_cs_precedes != CHAR_MAX) hv_store(RETVAL, "p_cs_precedes", 13, newSViv(lcbuf->p_cs_precedes), 0); if (lcbuf->p_sep_by_space != CHAR_MAX) hv_store(RETVAL, "p_sep_by_space", 14, newSViv(lcbuf->p_sep_by_space), 0); if (lcbuf->n_cs_precedes != CHAR_MAX) hv_store(RETVAL, "n_cs_precedes", 13, newSViv(lcbuf->n_cs_precedes), 0); if (lcbuf->n_sep_by_space != CHAR_MAX) hv_store(RETVAL, "n_sep_by_space", 14, newSViv(lcbuf->n_sep_by_space), 0); if (lcbuf->p_sign_posn != CHAR_MAX) hv_store(RETVAL, "p_sign_posn", 11, newSViv(lcbuf->p_sign_posn), 0); if (lcbuf->n_sign_posn != CHAR_MAX) hv_store(RETVAL, "n_sign_posn", 11, newSViv(lcbuf->n_sign_posn), 0); } #else localeconv(); /* A stub to call not_here(). */ #endif OUTPUT: RETVAL char * setlocale(category, locale = 0) int category char * locale CODE: RETVAL = setlocale(category, locale); if (RETVAL) { #ifdef USE_LOCALE_CTYPE if (category == LC_CTYPE #ifdef LC_ALL || category == LC_ALL #endif ) { char *newctype; #ifdef LC_ALL if (category == LC_ALL) newctype = setlocale(LC_CTYPE, NULL); else #endif newctype = RETVAL; - perl_new_ctype(newctype); + new_ctype(newctype); } #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (category == LC_COLLATE #ifdef LC_ALL || category == LC_ALL #endif ) { char *newcoll; #ifdef LC_ALL if (category == LC_ALL) newcoll = setlocale(LC_COLLATE, NULL); else #endif newcoll = RETVAL; - perl_new_collate(newcoll); + new_collate(newcoll); } #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (category == LC_NUMERIC #ifdef LC_ALL || category == LC_ALL #endif ) { char *newnum; #ifdef LC_ALL if (category == LC_ALL) newnum = setlocale(LC_NUMERIC, NULL); else #endif newnum = RETVAL; - perl_new_numeric(newnum); + new_numeric(newnum); } #endif /* USE_LOCALE_NUMERIC */ } OUTPUT: RETVAL double acos(x) double x double asin(x) double x double atan(x) double x double ceil(x) double x double cosh(x) double x double floor(x) double x double fmod(x,y) double x double y void frexp(x) double x PPCODE: int expvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); PUSHs(sv_2mortal(newSViv(expvar))); double ldexp(x,exp) double x int exp double log10(x) double x void modf(x) double x PPCODE: double intvar; /* (We already know stack is long enough.) */ PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); double sinh(x) double x double tan(x) double x double tanh(x) double x SysRet sigaction(sig, action, oldaction = 0) int sig POSIX::SigAction action POSIX::SigAction oldaction CODE: #ifdef WIN32 RETVAL = not_here("sigaction"); #else # 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(PL_siggv), - sig_name[sig], - strlen(sig_name[sig]), + SV** sigsvp = hv_fetch(GvHVn(siggv), + PL_sig_name[sig], + strlen(PL_sig_name[sig]), TRUE); STRLEN n_a; /* Remember old handler name if desired. */ if (oldaction) { char *hand = SvPVx(*sigsvp, n_a); svp = hv_fetch(oldaction, "HANDLER", 7, TRUE); sv_setpv(*svp, *hand ? hand : "DEFAULT"); } if (action) { /* Vector new handler through %SIG. (We always use sighandler for the C signal handler, which reads %SIG to dispatch.) */ svp = hv_fetch(action, "HANDLER", 7, FALSE); if (!svp) 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 = sighandler; + act.sa_handler = PL_sighandlerp; /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); if (svp && sv_isa(*svp, "POSIX::SigSet")) { unsigned long tmp; tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); sigset = (sigset_t*) tmp; act.sa_mask = *sigset; } else sigemptyset(& act.sa_mask); /* Set up any desired flags. */ svp = hv_fetch(action, "FLAGS", 5, FALSE); act.sa_flags = svp ? SvIV(*svp) : 0; } /* Now work around sigaction oddities */ if (action && oldaction) RETVAL = sigaction(sig, & act, & oact); else if (action) RETVAL = sigaction(sig, & act, (struct sigaction *)0); else if (oldaction) RETVAL = sigaction(sig, (struct sigaction *)0, & oact); else RETVAL = -1; if (oldaction) { /* Get back the mask. */ svp = hv_fetch(oldaction, "MASK", 4, TRUE); if (sv_isa(*svp, "POSIX::SigSet")) { unsigned long tmp; tmp = (unsigned long)SvNV((SV*)SvRV(*svp)); sigset = (sigset_t*) tmp; } else { New(0, sigset, 1, sigset_t); sv_setptrobj(*svp, sigset, "POSIX::SigSet"); } *sigset = oact.sa_mask; /* Get back the flags. */ svp = hv_fetch(oldaction, "FLAGS", 5, TRUE); sv_setiv(*svp, oact.sa_flags); } } #endif OUTPUT: RETVAL SysRet sigpending(sigset) POSIX::SigSet sigset SysRet sigprocmask(how, sigset, oldsigset = 0) int how POSIX::SigSet sigset POSIX::SigSet oldsigset = NO_INIT INIT: if ( items < 3 ) { oldsigset = 0; } else if (sv_derived_from(ST(2), "POSIX::SigSet")) { IV tmp = SvIV((SV*)SvRV(ST(2))); - oldsigset = (POSIX__SigSet) tmp; + oldsigset = INT2PTR(POSIX__SigSet,tmp); } else { New(0, oldsigset, 1, sigset_t); sigemptyset(oldsigset); sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset); } SysRet sigsuspend(signal_mask) POSIX::SigSet signal_mask void _exit(status) int status SysRet close(fd) int fd SysRet dup(fd) int fd SysRet dup2(fd1, fd2) int fd1 int fd2 SysRetLong lseek(fd, offset, whence) int fd Off_t offset int whence SysRet nice(incr) int incr int pipe() PPCODE: int fds[2]; if (pipe(fds) != -1) { EXTEND(SP,2); PUSHs(sv_2mortal(newSViv(fds[0]))); PUSHs(sv_2mortal(newSViv(fds[1]))); } SysRet read(fd, buffer, nbytes) PREINIT: SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: int fd size_t nbytes char * buffer = sv_grow( sv_buffer, nbytes+1 ); CLEANUP: if (RETVAL >= 0) { SvCUR(sv_buffer) = RETVAL; SvPOK_only(sv_buffer); *SvEND(sv_buffer) = '\0'; SvTAINTED_on(sv_buffer); } SysRet setpgid(pid, pgid) pid_t pid pid_t pgid pid_t setsid() pid_t tcgetpgrp(fd) int fd SysRet tcsetpgrp(fd, pgrp_id) int fd pid_t pgrp_id int uname() PPCODE: #ifdef HAS_UNAME struct utsname buf; if (uname(&buf) >= 0) { EXTEND(SP, 5); PUSHs(sv_2mortal(newSVpv(buf.sysname, 0))); PUSHs(sv_2mortal(newSVpv(buf.nodename, 0))); PUSHs(sv_2mortal(newSVpv(buf.release, 0))); PUSHs(sv_2mortal(newSVpv(buf.version, 0))); PUSHs(sv_2mortal(newSVpv(buf.machine, 0))); } #else uname((char *) 0); /* A stub to call not_here(). */ #endif SysRet write(fd, buffer, nbytes) int fd char * buffer size_t nbytes -char * -tmpnam(s = 0) - char * s = 0; +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 void abort() int mblen(s, n) char * s size_t n size_t mbstowcs(s, pwcs, n) wchar_t * s char * pwcs size_t n int mbtowc(pwc, s, n) wchar_t * pwc char * s size_t n int wcstombs(s, pwcs, n) char * s wchar_t * pwcs size_t n int wctomb(s, wchar) char * s wchar_t wchar int strcoll(s1, s2) char * s1 char * s2 void strtod(str) char * str PREINIT: double num; char *unparsed; PPCODE: SET_NUMERIC_LOCAL(); num = strtod(str, &unparsed); PUSHs(sv_2mortal(newSVnv(num))); if (GIMME == G_ARRAY) { EXTEND(SP, 1); if (unparsed) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } void strtol(str, base = 0) char * str int base PREINIT: long num; char *unparsed; PPCODE: num = strtol(str, &unparsed, base); - if (num >= IV_MIN && num <= IV_MAX) - PUSHs(sv_2mortal(newSViv((IV)num))); - else +#if IVSIZE <= LONGSIZE + if (num < IV_MIN || num > IV_MAX) PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); if (GIMME == G_ARRAY) { EXTEND(SP, 1); if (unparsed) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } void strtoul(str, base = 0) char * str int base PREINIT: unsigned long num; char *unparsed; PPCODE: num = strtoul(str, &unparsed, base); if (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) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } SV * strxfrm(src) SV * src CODE: { STRLEN srclen; STRLEN dstlen; char *p = SvPV(src,srclen); srclen++; ST(0) = sv_2mortal(NEWSV(800,srclen)); dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen); if (dstlen > srclen) { dstlen++; SvGROW(ST(0), dstlen); strxfrm(SvPVX(ST(0)), p, (size_t)dstlen); dstlen--; } SvCUR(ST(0)) = dstlen; SvPOK_only(ST(0)); } SysRet mkfifo(filename, mode) char * filename Mode_t mode CODE: TAINT_PROPER("mkfifo"); RETVAL = mkfifo(filename, mode); OUTPUT: RETVAL SysRet tcdrain(fd) int fd SysRet tcflow(fd, action) int fd int action SysRet tcflush(fd, queue_selector) int fd int queue_selector SysRet tcsendbreak(fd, duration) int fd int duration char * asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) int sec int min int hour int mday int mon int year int wday int yday int isdst CODE: { struct tm mytm; init_tm(&mytm); /* XXX workaround - see init_tm() above */ mytm.tm_sec = sec; mytm.tm_min = min; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; RETVAL = asctime(&mytm); } OUTPUT: RETVAL long clock() char * ctime(time) Time_t &time void times() PPCODE: struct tms tms; clock_t realtime; realtime = times( &tms ); EXTEND(SP,5); PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) ); PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) ); PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) ); PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) ); PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) ); double difftime(time1, time2) Time_t time1 Time_t time2 SysRetLong mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) int sec int min int hour int mday int mon int year int wday int yday int isdst CODE: { struct tm mytm; init_tm(&mytm); /* XXX workaround - see init_tm() above */ mytm.tm_sec = sec; mytm.tm_min = min; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; RETVAL = mktime(&mytm); } OUTPUT: RETVAL char * strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) char * fmt int sec int min int hour int mday int mon int year int wday int yday int isdst CODE: { 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; mytm.tm_hour = hour; mytm.tm_mday = mday; mytm.tm_mon = mon; mytm.tm_year = year; mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; #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); + mini_mktime(&mytm); #endif len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); /* ** The following is needed to handle to the situation where ** tmpbuf overflows. Basically we want to allocate a buffer ** and try repeatedly. The reason why it is so complicated ** is that getting a return value of 0 from strftime can indicate ** one of the following: ** 1. buffer overflowed, ** 2. illegal conversion specifier, or ** 3. the format string specifies nothing to be returned(not ** an error). This could be because format is an empty string ** or it specifies %p that yields an empty string in some locale. ** If there is a better way to make it portable, go ahead by ** all means. */ - if ( ( len > 0 && len < sizeof(tmpbuf) ) - || ( len == 0 && strlen(fmt) == 0 ) ) { + if ((len > 0 && len < sizeof(tmpbuf)) || (len == 0 && *fmt == '\0')) ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); - } else { + else { /* Possibly buf overflowed - try again with a bigger buf */ - int bufsize = strlen(fmt) + sizeof(tmpbuf); + int fmtlen = strlen(fmt); + int bufsize = fmtlen + 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; + if (buflen > 0 && buflen < bufsize) + break; + /* heuristic to prevent out-of-memory errors */ + if (bufsize > 100*fmtlen) { + Safefree(buf); + buf = NULL; + break; + } bufsize *= 2; Renew(buf, bufsize, char); } - if ( buf ) { - ST(0) = sv_2mortal(newSVpv(buf, buflen)); + if (buf) { + ST(0) = sv_2mortal(newSVpvn(buf, buflen)); Safefree(buf); - } else { - ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); } + else + ST(0) = sv_2mortal(newSVpvn(tmpbuf, len)); } } void tzset() void tzname() PPCODE: EXTEND(SP,2); - PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0])))); - PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1])))); + PUSHs(sv_2mortal(newSVpvn(tzname[0],strlen(tzname[0])))); + PUSHs(sv_2mortal(newSVpvn(tzname[1],strlen(tzname[1])))); SysRet access(filename, mode) char * filename Mode_t mode char * ctermid(s = 0) char * s = 0; char * cuserid(s = 0) char * s = 0; SysRetLong fpathconf(fd, name) int fd int name SysRetLong pathconf(filename, name) char * filename int name SysRet pause() SysRetLong sysconf(name) int name char * ttyname(fd) int fd Index: head/contrib/perl5/hints/freebsd.sh =================================================================== --- head/contrib/perl5/hints/freebsd.sh (revision 62079) +++ head/contrib/perl5/hints/freebsd.sh (revision 62080) @@ -1,237 +1,235 @@ +# $FreeBSD$ # Original based on info from # Carl M. Fongheiser # Date: Thu, 28 Jul 1994 19:17:05 -0500 (CDT) # # Additional 1.1.5 defines from # Ollivier Robert # Date: Wed, 28 Sep 1994 00:37:46 +0100 (MET) # # Additional 2.* defines from # Ollivier Robert # Date: Sat, 8 Apr 1995 20:53:41 +0200 (MET DST) # # Additional 2.0.5 and 2.1 defined from # Ollivier Robert # Date: Fri, 12 May 1995 14:30:38 +0200 (MET DST) # # Additional 2.2 defines from # Mark Murray # Date: Wed, 6 Nov 1996 09:44:58 +0200 (MET) # # Modified to ensure we replace -lc with -lc_r, and # to put in place-holders for various specific hints. # Andy Dougherty # Date: Tue Mar 10 16:07:00 EST 1998 # # Support for FreeBSD/ELF # Ollivier Robert # Date: Wed Sep 2 16:22:12 CEST 1998 # # The two flags "-fpic -DPIC" are used to indicate a # will-be-shared object. Configure will guess the -fpic, (and the # -DPIC is not used by perl proper) but the full define is included to # be consistent with the FreeBSD general shared libs building process. # # setreuid and friends are inherently broken in all versions of FreeBSD # before 2.1-current (before approx date 4/15/95). It is fixed in 2.0.5 # and what-will-be-2.1 # case "$osvers" in 0.*|1.0*) usedl="$undef" ;; 1.1*) malloctype='void *' groupstype='int' d_setregid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' ;; 2.0-release*) d_setregid='undef' d_setreuid='undef' d_setrgid='undef' d_setruid='undef' ;; # # Trying to cover 2.0.5, 2.1-current and future 2.1/2.2 # It does not covert all 2.1-current versions as the output of uname # changed a few times. # # Even though seteuid/setegid are available, they've been turned off # because perl isn't coded with saved set[ug]id variables in mind. # In addition, a small patch is requried to suidperl to avoid a security # problem with FreeBSD. # 2.0.5*|2.0-built*|2.1*) usevfork='true' usemymalloc='n' d_setregid='define' d_setreuid='define' d_setegid='undef' d_seteuid='undef' test -r ./broken-db.msg && . ./broken-db.msg ;; # # 2.2 and above have phkmalloc(3). # don't use -lmalloc (maybe there's an old one from 1.1.5.1 floating around) 2.2*) usevfork='true' usemymalloc='n' libswanted=`echo $libswanted | sed 's/ malloc / /'` d_setregid='define' d_setreuid='define' d_setegid='undef' d_seteuid='undef' ;; # # Guesses at what will be needed after 2.2 *) usevfork='true' usemymalloc='n' libswanted=`echo $libswanted | sed 's/ malloc / /'` ;; esac # Dynamic Loading flags have not changed much, so they are separated # out here to avoid duplicating them everywhere. case "$osvers" in 0.*|1.0*) ;; -# 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' +1*|2*) cccdlflags='-DPIC -fpic' + lddlflags="-Bshareable $lddlflags" ;; -3.*|4.0*) + +*) objformat=`/usr/bin/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" + libpth="/usr/lib/aout /usr/local/lib /usr/lib" + glibpth="/usr/lib/aout /usr/local/lib /usr/lib" + fi + lddlflags='-Bshareable' fi - lddlflags='-Bshareable' - fi cccdlflags='-DPIC -fpic' ;; +esac -*) cccdlflags='-DPIC -fpic' - lddlflags="-Bshareable $lddlflags" - ;; +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 + ;; esac cat <<'EOM' >&4 Some users have reported that Configure halts when testing for the O_NONBLOCK symbol with a syntax error. This is apparently a sh error. Rerunning Configure with ksh apparently fixes the problem. Try ksh Configure [your options] EOM # From: Anton Berezin # To: perl5-porters@perl.org # Subject: [PATCH 5.005_54] Configure - hints/freebsd.sh signal handler type # Date: 30 Nov 1998 19:46:24 +0100 # Message-ID: <864srhhvcv.fsf@lion.plab.ku.dk> signal_t='void' d_voidsig='define' # set libperl.so.X.X for 2.2.X case "$osvers" in 2.2*) # unfortunately this code gets executed before # 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[ ]+PATCHLEVEL/ {print $3}' $src/patchlevel.h` - subversion=`awk '/define[ ]+SUBVERSION/ {print $3}' $src/patchlevel.h` + patchlevel=`awk '/define[ ]+PERL_VERSION/ {print $3}' $src/patchlevel.h` + subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $src/patchlevel.h` else patchlevel=0 subversion=0 fi libperl="libperl.so.$patchlevel.$subversion" unset patchlevel unset subversion ;; esac # This script UU/usethreads.cbu will get 'called-back' by Configure # after it has prompted the user for whether to use threads. cat > UU/usethreads.cbu <<'EOCBU' case "$usethreads" in $define|true|[yY]*) - lc_r=`/sbin/ldconfig -r|grep ':-lc_r'|awk '{print $NF}'` + lc_r=`/sbin/ldconfig -r|grep ':-lc_r'|awk '{print $NF}'|tail -1` case "$osvers" in - 2.2.8*|3.*|4.*) - if [ ! -r "$lc_r" ]; then - cat <&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). + 0*|1*|2.0*|2.1*) cat <&4 +I did not know that FreeBSD $osvers supports POSIX threads. -Consider using the latest STABLE release. +Feel free to tell perlbug@perl.com otherwise. EOM - exit 1 - fi - ldflags="-pthread $ldflags" + exit 1 ;; - 2.2*) + + 2.2.[0-7]*) cat <&4 POSIX threads are not supported well by FreeBSD $osvers. Please consider upgrading to at least FreeBSD 2.2.8, or preferably to 3.something. (While 2.2.7 does have pthreads, it has some problems with the combination of threads and pipes and therefore many Perl tests will either hang or fail.) EOM exit 1 ;; - *) cat <&4 -I did not know that FreeBSD $osvers supports POSIX threads. -Feel free to tell perlbug@perl.com otherwise. + *) + if [ ! -r "$lc_r" ]; then + cat <&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. EOM - exit 1 + exit 1 + fi + ldflags="-pthread $ldflags" ;; + esac set `echo X "$libswanted "| sed -e 's/ c / c_r /'` shift libswanted="$*" # Configure will probably pick the wrong libc to use for nm scan. # The safest quick-fix is just to not use nm at all... usenm=false case "$osvers" in 2.2.8*) # ... but this does not apply for 2.2.8 - we know it's safe libc="$lc_r" usenm=true ;; esac unset lc_r esac EOCBU Index: head/contrib/perl5/lib/Cwd.pm =================================================================== --- head/contrib/perl5/lib/Cwd.pm (revision 62079) +++ head/contrib/perl5/lib/Cwd.pm (revision 62080) @@ -1,385 +1,401 @@ +# $FreeBSD$ package Cwd; require 5.000; =head1 NAME getcwd - get pathname of current working directory =head1 SYNOPSIS use Cwd; $dir = cwd; use Cwd; $dir = getcwd; use Cwd; $dir = fastgetcwd; use Cwd 'chdir'; chdir "/tmp"; print $ENV{'PWD'}; - use Cwd 'abs_path'; + use Cwd 'abs_path'; # aka realpath() print abs_path($ENV{'PWD'}); use Cwd 'fast_abs_path'; print fast_abs_path($ENV{'PWD'}); =head1 DESCRIPTION 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(".")) +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(). The fastcwd() function looks the same as getcwd(), but runs faster. It's also more dangerous because it might conceivably chdir() you out of a directory that it can't chdir() you back into. If fastcwd encounters a problem it will return undef but will probably leave you in a different directory. For a measure of extra security, if everything appears to have worked, the fastcwd() function will check that it leaves you in the same directory that it started in. If it has changed it will C with the message "Unstable directory path, current directory changed unexpectedly". That should never happen. The fast_abs_path() function looks the same as abs_path(), but runs faster. And like fastcwd() is more dangerous. The cwd() function looks the same as getcwd and fastgetcwd but is implemented using the most natural and safe form for the current architecture. For most systems it is identical to `pwd` (but without the trailing line terminator). It is recommended that cwd (or another *cwd() function) is used in I code to ensure portability. If you ask to override your chdir() built-in function, then your PWD environment variable will be kept up to date. (See L.) Note that it will only be kept up to date if all packages which use chdir import it from Cwd. =cut ## use strict; use Carp; -$VERSION = '2.01'; +$VERSION = '2.02'; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(cwd getcwd fastcwd fastgetcwd); -@EXPORT_OK = qw(chdir abs_path fast_abs_path); +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); # The 'natural and safe form' for UNIX (pwd may be setuid root) sub _backtick_pwd { my $cwd; chop($cwd = `/bin/pwd`); $cwd; } # Since some ports may predefine cwd internally (e.g., NT) # we take care not to override an existing definition for cwd(). *cwd = \&_backtick_pwd unless defined &cwd; # By Brandon S. Allbery # # Usage: $cwd = getcwd(); sub getcwd { abs_path('.'); } # By John Bazik # # Usage: $cwd = &fastcwd; # # 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); local(*DIR); my($orig_cdev, $orig_cino) = stat('.'); ($cdev, $cino) = ($orig_cdev, $orig_cino); for (;;) { my $direntry; ($odev, $oino) = ($cdev, $cino); CORE::chdir('..') || return undef; ($cdev, $cino) = stat('.'); last if $odev == $cdev && $oino == $cino; opendir(DIR, '.') || return undef; for (;;) { $direntry = readdir(DIR); last unless defined $direntry; next if $direntry eq '.'; next if $direntry eq '..'; ($tdev, $tino) = lstat($direntry); last unless $tdev != $odev || $tino != $oino; } closedir(DIR); return undef unless defined $direntry; # should never happen 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 =~ /^(.*)$/; # untaint + $path = $1 if $path =~ /^(.*)\z/s; # untaint CORE::chdir($path) || return undef; ($cdev, $cino) = stat('.'); die "Unstable directory path, current directory changed unexpectedly" if $cdev != $orig_cdev || $cino != $orig_cino; $path; } # Keeps track of current working directory in PWD environment var # Usage: # use Cwd 'chdir'; # chdir $newdir; my $chdir_init = 0; sub chdir_init { if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') { my($dd,$di) = stat('.'); my($pd,$pi) = stat($ENV{'PWD'}); if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { $ENV{'PWD'} = cwd(); } } else { $ENV{'PWD'} = cwd(); } # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) - if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) { + if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { my($pd,$pi) = stat($2); my($dd,$di) = stat($1); if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { $ENV{'PWD'}="$2$3"; } } $chdir_init = 1; } sub chdir { my $newdir = shift || ''; # allow for no arg (chdir to HOME dir) $newdir =~ s|///*|/|g; chdir_init() unless $chdir_init; return 0 unless CORE::chdir $newdir; if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} } - if ($newdir =~ m#^/#) { + if ($newdir =~ m#^/#s) { $ENV{'PWD'} = $newdir; } else { my @curdir = split(m#/#,$ENV{'PWD'}); @curdir = ('') unless @curdir; my $component; foreach $component (split(m#/#, $newdir)) { next if $component eq '.'; pop(@curdir),next if $component eq '..'; push(@curdir,$component); } $ENV{'PWD'} = join('/',@curdir) || '/'; } 1; } # Taken from Cwd.pm It is really getcwd with an optional # parameter instead of '.' # sub abs_path { my $start = @_ ? shift : '.'; my($dotdots, $cwd, @pst, @cst, $dir, @tst); unless (@cst = stat( $start )) { carp "stat($start): $!"; return ''; } $cwd = ''; $dotdots = $start; do { $dotdots .= '/..'; @pst = @cst; unless (opendir(PARENT, $dotdots)) { carp "opendir($dotdots): $!"; return ''; } unless (@cst = stat($dotdots)) { carp "stat($dotdots): $!"; closedir(PARENT); return ''; } if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) { $dir = undef; } else { do { unless (defined ($dir = readdir(PARENT))) { carp "readdir($dotdots): $!"; closedir(PARENT); return ''; } $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) } while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || $tst[1] != $pst[1]); } $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; closedir(PARENT); } while (defined $dir); chop($cwd) unless $cwd eq '/'; # drop the trailing / $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 || '.'; CORE::chdir($path) || croak "Cannot chdir to $path:$!"; my $realpath = getcwd(); CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!"; $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 --- # VMS: $ENV{'DEFAULT'} points to default directory at all times # 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu # Note: Use of Cwd::chdir() causes the logical name PWD to be defined # in the process logical name table as the default device and directory # seen by Perl. This may not be the same as the default device # and directory seen by DCL after Perl exits, since the effects # the CRTL chdir() function persist only until Perl exits. sub _vms_cwd { return $ENV{'DEFAULT'}; } sub _vms_abs_path { return $ENV{'DEFAULT'} unless @_; my $path = VMS::Filespec::pathify($_[0]); croak("Invalid path name $_[0]") unless defined $path; return VMS::Filespec::rmsexpand($path); } sub _os2_cwd { $ENV{'PWD'} = `cmd /c cd`; chop $ENV{'PWD'}; $ENV{'PWD'} =~ s:\\:/:g ; return $ENV{'PWD'}; } sub _win32_cwd { $ENV{'PWD'} = Win32::GetCwd(); $ENV{'PWD'} =~ s:\\:/:g ; return $ENV{'PWD'}; } *_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd && defined &Win32::GetCwd); *_NT_cwd = \&_os2_cwd unless defined &_NT_cwd; sub _dos_cwd { if (!defined &Dos::GetCwd) { $ENV{'PWD'} = `command /c cd`; chop $ENV{'PWD'}; $ENV{'PWD'} =~ s:\\:/:g ; } else { $ENV{'PWD'} = Dos::GetCwd(); } return $ENV{'PWD'}; } sub _qnx_cwd { $ENV{'PWD'} = `/usr/bin/fullpath -t`; chop $ENV{'PWD'}; return $ENV{'PWD'}; } sub _qnx_abs_path { my $path = shift || '.'; my $realpath=`/usr/bin/fullpath -t $path`; chop $realpath; return $realpath; } { - local $^W = 0; # assignments trigger 'subroutine redefined' warning + no warnings; # assignments trigger 'subroutine redefined' warning if ($^O eq 'VMS') { *cwd = \&_vms_cwd; *getcwd = \&_vms_cwd; *fastcwd = \&_vms_cwd; *fastgetcwd = \&_vms_cwd; *abs_path = \&_vms_abs_path; *fast_abs_path = \&_vms_abs_path; } elsif ($^O eq 'NT' or $^O eq 'MSWin32') { # We assume that &_NT_cwd is defined as an XSUB or in the core. *cwd = \&_NT_cwd; *getcwd = \&_NT_cwd; *fastcwd = \&_NT_cwd; *fastgetcwd = \&_NT_cwd; *abs_path = \&fast_abs_path; } elsif ($^O eq 'os2') { # sys_cwd may keep the builtin command *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; *getcwd = \&cwd; *fastgetcwd = \&cwd; *fastcwd = \&cwd; *abs_path = \&fast_abs_path; } elsif ($^O eq 'dos') { *cwd = \&_dos_cwd; *getcwd = \&_dos_cwd; *fastgetcwd = \&_dos_cwd; *fastcwd = \&_dos_cwd; *abs_path = \&fast_abs_path; } elsif ($^O eq 'qnx') { *cwd = \&_qnx_cwd; *getcwd = \&_qnx_cwd; *fastgetcwd = \&_qnx_cwd; *fastcwd = \&_qnx_cwd; *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('',) || die $@; # quick test 1; __END__ BEGIN { import Cwd qw(:DEFAULT chdir); } print join("\n", cwd, getcwd, fastcwd, ""); chdir('..'); print join("\n", cwd, getcwd, fastcwd, ""); print "$ENV{PWD}\n"; Index: head/contrib/perl5/lib/ExtUtils/Install.pm =================================================================== --- head/contrib/perl5/lib/ExtUtils/Install.pm (revision 62079) +++ head/contrib/perl5/lib/ExtUtils/Install.pm (revision 62080) @@ -1,380 +1,375 @@ +# $FreeBSD$ 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'; 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; -#use vars qw( @EXPORT @ISA $Is_VMS ); +#our(@EXPORT, @ISA, $Is_VMS); #use strict; sub forceunlink { chmod 0666, $_[0]; unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!") } sub install { my($hash,$verbose,$nonono,$inc_uninstall) = @_; $verbose ||= 0; $nonono ||= 0; use Cwd qw(cwd); use ExtUtils::MakeMaker; # to implement a MY class use ExtUtils::Packlist; use File::Basename qw(dirname); use File::Copy qw(copy); use File::Find qw(find); use File::Path qw(mkpath); use File::Compare qw(compare); my(%hash) = %$hash; my(%pack, $dir, $warn_permissions); my($packlist) = ExtUtils::Packlist->new(); # -w doesn't work reliably on FAT dirs $warn_permissions++ if $^O eq 'MSWin32'; local(*DIR); for (qw/read write/) { $pack{$_}=$hash{$_}; delete $hash{$_}; } my($source_dir_or_file); foreach $source_dir_or_file (sort keys %hash) { #Check if there are files, and if yes, look if the corresponding #target directory is writable for us opendir DIR, $source_dir_or_file or next; for (readdir DIR) { next if $_ eq "." || $_ eq ".." || $_ eq ".exists"; if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) { last; } else { warn "Warning: You do not have permissions to " . "install into $hash{$source_dir_or_file}" unless $warn_permissions++; } } closedir DIR; } $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) { #copy the tree to the target directory without altering #timestamp and permission and remember for the .packlist #file. The packlist file contains the absolute paths of the #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. my $targetroot = $hash{$source}; if ($source eq "blib/lib" and 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 dependend library tree!\n" - ; #if $verbose>1; + print "Files found in blib/arch: installing files in blib/lib into architecture dependent library tree\n"; } chdir($source) or next; find(sub { my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat; return unless -f _; return if $_ eq ".exists"; my $targetdir = MY->catdir($targetroot,$File::Find::dir); my $targetfile = MY->catfile($targetdir,$_); my $diff = 0; if ( -f $targetfile && -s _ == $size) { # We have a good chance, we can skip this one $diff = compare($_,$targetfile); } else { 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){ forceunlink($targetfile) unless $nonono; } else { mkpath($targetdir,0,0755) unless $nonono; print "mkpath($targetdir,0,0755)\n" if $verbose>1; } copy($_,$targetfile) unless $nonono; print "Installing $targetfile\n"; utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1; print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); chmod $mode, $targetfile; print "chmod($mode, $targetfile)\n" if $verbose>1; } else { print "Skipping $targetfile (unchanged)\n" if $verbose; } if (! defined $inc_uninstall) { # it's called } elsif ($inc_uninstall == 0){ inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1 } else { inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0 } $packlist->{$targetfile}++; }, "."); 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); print "Writing $pack{'write'}\n"; $packlist->write($pack{'write'}); } } sub directory_not_empty ($) { my($dir) = @_; my $files = 0; find(sub { return if $_ eq ".exists"; if (-f) { $File::Find::prune++; $files = 1; } }, $dir); return $files; } sub install_default { @_ < 2 or die "install_default should be called with 0 or 1 argument"; my $FULLEXT = @_ ? shift : $ARGV[0]; defined $FULLEXT or die "Do not know to where to write install log"; my $INST_LIB = MM->catdir(MM->curdir,"blib","lib"); my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch"); my $INST_BIN = MM->catdir(MM->curdir,'blib','bin'); my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script'); my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1'); my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3'); install({ read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? $Config{installsitearch} : $Config{installsitelib}, $INST_ARCHLIB => $Config{installsitearch}, $INST_BIN => $Config{installbin} , $INST_SCRIPT => $Config{installscript}, $INST_MAN1DIR => $Config{installman1dir}, $INST_MAN3DIR => $Config{installman3dir}, },1,0,0); } sub uninstall { use ExtUtils::Packlist; my($fil,$verbose,$nonono) = @_; die "no packlist file found: $fil" unless -f $fil; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first my ($packlist) = ExtUtils::Packlist->new($fil); foreach (sort(keys(%$packlist))) { chomp; print "unlink $_\n" if $verbose; forceunlink($_) unless $nonono; } print "unlink $fil\n" if $verbose; - close P; forceunlink($fil) unless $nonono; } sub inc_uninstall { my($file,$libdir,$verbose,$nonono) = @_; my($dir); my %seen_dir = (); foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp privlibexp sitearchexp sitelibexp)}) { next if $dir eq "."; next if $seen_dir{$dir}++; my($targetfile) = MY->catfile($dir,$libdir,$file); next unless -f $targetfile; # The reason why we compare file's contents is, that we cannot # know, which is the file we just installed (AFS). So we leave # an identical file in place my $diff = 0; if ( -f $targetfile && -s _ == -s $file) { # We have a good chance, we can skip this one $diff = compare($file,$targetfile); } else { print "#$file and $targetfile differ\n" if $verbose>1; $diff++; } next unless $diff; if ($nonono) { if ($verbose) { $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn; - $libdir =~ s|^\./|| ; # That's just cosmetics, no need to port. It looks prettier. + $libdir =~ s|^\./||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 } else { print "Unlinking $targetfile (shadowing?)\n"; forceunlink($targetfile); } } } sub pm_to_blib { my($fromto,$autodir) = @_; use File::Basename qw(dirname); use File::Copy qw(copy); use File::Path qw(mkpath); use File::Compare qw(compare); use AutoSplit; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first if (!ref($fromto) && -r $fromto) { # Win32 has severe command line length limitations, but # can generate temporary files on-the-fly # so we pass name of file here - eval it to get hash open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!"; my $str = '$fromto = {qw{'.join('',).'}}'; eval $str; close(FROMTO); } - my $umask = umask 0022 unless $Is_VMS; mkpath($autodir,0,0755); foreach (keys %$fromto) { next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_; unless (compare($_,$fromto->{$_})){ print "Skip $fromto->{$_} (unchanged)\n"; next; } if (-f $fromto->{$_}){ forceunlink($fromto->{$_}); } else { mkpath(dirname($fromto->{$_}),0,0755); } copy($_,$fromto->{$_}); my($mode,$atime,$mtime) = (stat)[2,8,9]; utime($atime,$mtime+$Is_VMS,$fromto->{$_}); chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_}); print "cp $_ $fromto->{$_}\n"; - next unless /\.pm$/; + next unless /\.pm\z/; autosplit($fromto->{$_},$autodir); } - umask $umask unless $Is_VMS; } package ExtUtils::Install::Warn; sub new { bless {}, shift } sub add { my($self,$file,$targetfile) = @_; push @{$self->{$file}}, $targetfile; } sub DESTROY { my $self = shift; my($file,$i,$plural); foreach $file (sort keys %$self) { $plural = @{$self->{$file}} > 1 ? "s" : ""; print "## Differing version$plural of $file found. You might like to\n"; for (0..$#{$self->{$file}}) { print "rm ", $self->{$file}[$_], "\n"; $i++; } } $plural = $i>1 ? "all those files" : "this file"; print "## Running 'make install UNINST=1' will unlink $plural for you.\n"; } 1; __END__ =head1 NAME ExtUtils::Install - install files from here to there =head1 SYNOPSIS B B B B =head1 DESCRIPTION Both install() and uninstall() are specific to the way ExtUtils::MakeMaker handles the installation and deinstallation of perl modules. They are not designed as general purpose tools. install() takes three arguments. A reference to a hash, a verbose switch and a don't-really-do-it switch. The hash ref contains a mapping of directories: each key/value pair is a combination of directories to be copied. Key is a directory to copy from, value is a directory to copy to. The whole tree below the "from" directory will be copied preserving timestamps and permissions. There are two keys with a special meaning in the hash: "read" and "write". After the copying is done, install will write the list of target files to the file named by C<$hashref-E{write}>. If there is another file named by C<$hashref-E{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, people are installing to a +identical, but on AFS it is quite likely that 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 specified, it takes $ARGV[0] as if it was specified as an argument. The argument is the value of MakeMaker's C key, like F. This function calls install() with the same arguments as the defaults the MakeMaker would use. 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 populated F +Assuming this command is executed in a directory with a populated F directory, it will proceed as if the F was build by MakeMaker on this machine. This is useful for binary distributions. uninstall() takes as first argument a file containing filenames to be unlinked. The second argument is a verbose switch, the third is a no-don't-really-do-it-now switch. pm_to_blib() takes a hashref as the first argument and copies all keys of the hash to the corresponding values efficiently. Filenames with the extension pm are autosplit. Second argument is the autosplit directory. =cut Index: head/contrib/perl5/lib/ExtUtils/Liblist.pm =================================================================== --- head/contrib/perl5/lib/ExtUtils/Liblist.pm (revision 62079) +++ head/contrib/perl5/lib/ExtUtils/Liblist.pm (revision 62080) @@ -1,754 +1,753 @@ +# $FreeBSD$ package ExtUtils::Liblist; -use vars qw($VERSION); + +use 5.005_64; # Broken out of MakeMaker from version 4.11 -$VERSION = substr q$Revision: 1.1.1.2 $, 10; +our $VERSION = substr q$Revision: 1.25 $, 10; use Config; use Cwd 'cwd'; use File::Basename; sub ext { if ($^O eq 'VMS') { return &_vms_ext; } elsif($^O eq 'MSWin32') { return &_win32_ext; } else { return &_unix_os2_ext; } } sub _unix_os2_ext { my($self,$potential_libs, $verbose) = @_; if ($^O =~ 'os2' and $Config{libs}) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll again. $potential_libs .= " " if $potential_libs; $potential_libs .= $Config{libs}; } return ("", "", "", "") unless $potential_libs; warn "Potential libraries are '$potential_libs':\n" if $verbose; my($so) = $Config{'so'}; my($libs) = $Config{'libs'}; my $Config_libext = $Config{lib_ext} || ".a"; # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs # this is a rewrite of Andy Dougherty's extliblist in perl my(@searchpath); # from "-L/path" entries in $potential_libs my(@libpath) = split " ", $Config{'libpth'}; my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen); my($fullname, $thislib, $thispth, @fullname); my($pwd) = cwd(); # from Cwd.pm my($found) = 0; foreach $thislib (split ' ', $potential_libs){ # Handle possible linker path arguments. if ($thislib =~ s/^(-[LR])//){ # save path flag type my($ptype) = $1; unless (-d $thislib){ warn "$ptype$thislib ignored, directory does not exist\n" if $verbose; next; } unless ($self->file_name_is_absolute($thislib)) { warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; $thislib = $self->catdir($pwd,$thislib); } push(@searchpath, $thislib); push(@extralibs, "$ptype$thislib"); push(@ldloadlibs, "$ptype$thislib"); next; } # Handle possible library arguments. unless ($thislib =~ s/^-l//){ warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; next; } my($found_lib)=0; foreach $thispth (@searchpath, @libpath){ # Try to find the full name of the library. We need this to # determine whether it's a dynamically-loadable library or not. # This tends to be subject to various os-specific quirks. # For gcc-2.6.2 on linux (March 1995), DLD can not load # .sa libraries, with the exception of libm.sa, so we # deliberately skip them. if (@fullname = $self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+")){ # Take care that libfoo.so.10 wins against libfoo.so.9. # Compare two libraries to find the most recent version # number. E.g. if you have libfoo.so.9.0.7 and # libfoo.so.10.1, first convert all digits into two # decimal places. Then we'll add ".00" to the shorter # strings so that we're comparing strings of equal length # Thus we'll compare libfoo.so.09.07.00 with # libfoo.so.10.01.00. Some libraries might have letters # in the version. We don't know what they mean, but will # try to skip them gracefully -- we'll set any letter to # '0'. Finally, sort in reverse so we can take the # first element. #TODO: iterate through the directory instead of sorting $fullname = "$thispth/" . (sort { my($ma) = $a; my($mb) = $b; $ma =~ tr/A-Za-z/0/s; $ma =~ s/\b(\d)\b/0$1/g; $mb =~ tr/A-Za-z/0/s; $mb =~ s/\b(\d)\b/0$1/g; while (length($ma) < length($mb)) { $ma .= ".00"; } while (length($mb) < length($ma)) { $mb .= ".00"; } # Comparison deliberately backwards $mb cmp $ma;} @fullname)[0]; } 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:/) { + && readlink($fullname) =~ /^elink:/s) { # Some of DG's libraries look like misconnected symbolic # links, but development tools can follow them. (They # look like this: # # libm.a -> elink:${SDE_PATH:-/usr}/sde/\ # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a # # , the compilation tools expand the environment variables.) } else { warn "$thislib not found in $thispth\n" if $verbose; next; } warn "'-l$thislib' found at $fullname\n" if $verbose; my($fullnamedir) = dirname($fullname); push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++; $found++; $found_lib++; # Now update library lists # what do we know about this library... - my $is_dyna = ($fullname !~ /\Q$Config_libext\E$/); + my $is_dyna = ($fullname !~ /\Q$Config_libext\E\z/); my $in_perl = ($libs =~ /\B-l\Q$ {thislib}\E\b/s); # Do not add it into the list if it is already linked in # with the main perl executable. # We have to special-case the NeXT, because math and ndbm # are both in libsys_s unless ($in_perl || ($Config{'osname'} eq 'next' && ($thislib eq 'm' || $thislib eq 'ndbm')) ){ push(@extralibs, "-l$thislib"); } # We might be able to load this archive file dynamically if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0') || ($Config{'dlsrc'} =~ /dl_dld/) ) { # We push -l$thislib instead of $fullname because # it avoids hardwiring a fixed path into the .bs file. # Mkbootstrap will automatically add dl_findfile() to # the .bs file if it sees a name in the -l format. # USE THIS, when dl_findfile() is fixed: # push(@bsloadlibs, "-l$thislib"); # OLD USE WAS while checking results against old_extliblist push(@bsloadlibs, "$fullname"); } else { if ($is_dyna){ # For SunOS4, do not add in this shared library if # it is already linked in the main perl executable push(@ldloadlibs, "-l$thislib") unless ($in_perl and $^O eq 'sunos'); } else { push(@ldloadlibs, "-l$thislib"); } } last; # found one here so don't bother looking further } warn "Note (probably harmless): " ."No library found for -l$thislib\n" unless $found_lib>0; } return ('','','','') unless $found; ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path)); } sub _win32_ext { require Text::ParseWords; my($self, $potential_libs, $verbose) = @_; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) return ("", "", "", "") unless $potential_libs; my $cc = $Config{cc}; my $VC = 1 if $cc =~ /^cl/i; my $BC = 1 if $cc =~ /^bcc/i; my $GC = 1 if $cc =~ /^gcc/i; my $so = $Config{'so'}; my $libs = $Config{'libs'}; my $libpth = $Config{'libpth'}; my $libext = $Config{'lib_ext'} || ".lib"; if ($libs and $potential_libs !~ /:nodefault/i) { # If Config.pm defines a set of default libs, we always # tack them on to the user-supplied list, unless the user # specified :nodefault $potential_libs .= " " if $potential_libs; $potential_libs .= $libs; } warn "Potential libraries are '$potential_libs':\n" if $verbose; # normalize to forward slashes $libpth =~ s,\\,/,g; $potential_libs =~ s,\\,/,g; # compute $extralibs from $potential_libs my @searchpath; # from "-L/path" in $potential_libs my @libpath = Text::ParseWords::quotewords('\s+', 0, $libpth); my @extralibs; my $pwd = cwd(); # from Cwd.pm my $lib = ''; my $found = 0; my $search = 1; my($fullname, $thislib, $thispth); # add "$Config{installarchlib}/CORE" to default search path push @libpath, "$Config{installarchlib}/CORE"; foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){ $thislib = $_; # see if entry is a flag if (/^:\w+$/) { $search = 0 if lc eq ':nosearch'; $search = 1 if lc eq ':search'; warn "Ignoring unknown flag '$thislib'\n" if $verbose and !/^:(no)?(search|default)$/i; next; } # if searching is disabled, do compiler-specific translations unless ($search) { s/^-l(.+)$/$1.lib/ unless $GC; s/^-L/-libpath:/ if $VC; push(@extralibs, $_); $found++; next; } # handle possible linker path arguments if (s/^-L// and not -d) { warn "$thislib ignored, directory does not exist\n" if $verbose; next; } elsif (-d) { unless ($self->file_name_is_absolute($_)) { warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; $_ = $self->catdir($pwd,$_); } push(@searchpath, $_); next; } # handle possible library arguments if (s/^-l// and $GC and !/^lib/i) { $_ = "lib$_"; } $_ .= $libext if !/\Q$libext\E$/i; my $secondpass = 0; LOOKAGAIN: # look for the file itself if (-f) { warn "'$thislib' found as '$_'\n" if $verbose; $found++; push(@extralibs, $_); next; } my $found_lib = 0; foreach $thispth (@searchpath, @libpath){ unless (-f ($fullname="$thispth\\$_")) { warn "'$thislib' not found as '$fullname'\n" if $verbose; next; } warn "'$thislib' found as '$fullname'\n" if $verbose; $found++; $found_lib++; push(@extralibs, $fullname); last; } # do another pass with (or without) leading 'lib' if they used -l if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) { if ($GC) { goto LOOKAGAIN if s/^lib//i; } elsif (!/^lib/i) { $_ = "lib$_"; goto LOOKAGAIN; } } # give up warn "Note (probably harmless): " ."No library found for '$thislib'\n" unless $found_lib>0; } return ('','','','') unless $found; # make sure paths with spaces are properly quoted @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs; $lib = join(' ',@extralibs); # normalize back to backward slashes (to help braindead tools) # XXX this may break equally braindead GNU tools that don't understand # backslashes, either. Seems like one can't win here. Cursed be CP/M. $lib =~ s,/,\\,g; warn "Result: $lib\n" if $verbose; wantarray ? ($lib, '', $lib, '') : $lib; } sub _vms_ext { my($self, $potential_libs,$verbose) = @_; my(@crtls,$crtlstr); my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} || $self->{CCFLAS} || $Config{'ccflags'}; @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '') . 'PerlShr/Share' ); push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'}); push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'}); # In general, we pass through the basic libraries from %Config unchanged. # The one exception is that if we're building in the Perl source tree, and # a library spec could be resolved via a logical name, we go to some trouble # to insure that the copy in the local tree is used, rather than one to # which a system-wide logical may point. if ($self->{PERL_SRC}) { my($lib,$locspec,$type); foreach $lib (@crtls) { if (($locspec,$type) = $lib =~ m-^([\w$\-]+)(/\w+)?- and $locspec =~ /perl/i) { if (lc $type eq '/share') { $locspec .= $Config{'exe_ext'}; } elsif (lc $type eq '/library') { $locspec .= $Config{'lib_ext'}; } else { $locspec .= $Config{'obj_ext'}; } $locspec = $self->catfile($self->{PERL_SRC},$locspec); $lib = "$locspec$type" if -e $locspec; } } } $crtlstr = @crtls ? join(' ',@crtls) : ''; unless ($potential_libs) { warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; return ('', '', $crtlstr, ''); } - my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj,$ldlib); + my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$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 # (VMS equivalent of '' indicates that the library is automatially # searched by the linker, and should be skipped here.) my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', 'socket' => '', 'X11' => 'DECW$XLIBSHR', 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', 'Xmu' => 'DECW$XMULIBSHR'); if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; } warn "Potential libraries are '$potential_libs'\n" if $verbose; # First, sort out directories and library names in the input foreach $lib (split ' ',$potential_libs) { push(@dirs,$1), next if $lib =~ /^-L(.*)/; push(@dirs,$lib), next if $lib =~ /[:>\]]$/; push(@dirs,$lib), next if -d $lib; push(@libs,$1), next if $lib =~ /^-l(.*)/; push(@libs,$lib); } push(@dirs,split(' ',$Config{'libpth'})); # Now make sure we've got VMS-syntax absolute directory specs # (We don't, however, check whether someone's hidden a relative # path in a logical name.) foreach $dir (@dirs) { unless (-d $dir) { warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; $dir = ''; next; } warn "Resolving directory $dir\n" if $verbose; if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); } else { $dir = $self->catdir($cwd,$dir); } } @dirs = grep { length($_) } @dirs; unshift(@dirs,''); # Check each $lib without additions first LIB: foreach $lib (@libs) { if (exists $libmap{$lib}) { next unless length $libmap{$lib}; $lib = $libmap{$lib}; } my(@variants,$variant,$name,$test,$cand); my($ctype) = ''; # If we don't have a file type, consider it a possibly abbreviated name and # check for common variants. We try these first to grab libraries before # a like-named executable image (e.g. -lperl resolves to perlshr.exe # before perl.exe). if ($lib !~ /\.[^:>\]]*$/) { push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); push(@variants,"lib$lib") if $lib !~ /[:>\]]/; } push(@variants,$lib); warn "Looking for $lib\n" if $verbose; foreach $variant (@variants) { foreach $dir (@dirs) { my($type); $name = "$dir$variant"; 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 = 'sh'; } - elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; } + if ($test =~ /(?:$so|exe)$/i) { $type = 'SHR'; } + 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 = 'sh'; + $type = 'SHR'; } } elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) { - $type = 'sh'; + $type = 'SHR'; $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 ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or -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 'sh'; + last if $ctype eq 'SHR'; } } if ($ctype) { - eval '$' . $ctype . "{'$cand'}++"; - die "Error recording library: $@" if $@; + # 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; } warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1; next LIB; } } warn "Note (probably harmless): " ."No library found for $lib\n"; } - @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); + 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); $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; wantarray ? ($lib, '', $ldlib, '') : $lib; } 1; __END__ =head1 NAME ExtUtils::Liblist - determine libraries to use and how to use them =head1 SYNOPSIS C C =head1 DESCRIPTION This utility takes a list of libraries in the form C<-llib1 -llib2 -llib3> and prints out lines suitable for inclusion in an extension Makefile. Extra library paths may be included with the form C<-L/another/path> this will affect the searches for all subsequent libraries. It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS, LDLOADLIBS, and LD_RUN_PATH. Some of these don't mean anything on VMS and Win32. See the details about those platform specifics below. Dependent libraries can be linked in one of three ways: =over 2 =item * For static extensions by the ld command when the perl binary is linked with the extension library. See EXTRALIBS below. =item * For dynamic extensions by the ld command when the shared object is built/linked. See LDLOADLIBS below. =item * For dynamic extensions by the DynaLoader when the shared object is loaded. See BSLOADLIBS below. =back =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. =head2 LDLOADLIBS and LD_RUN_PATH List of those libraries which can or must be linked into the shared library when created using ld. These may be static or dynamic libraries. LD_RUN_PATH is a colon separated list of the directories in LDLOADLIBS. It is passed as an environment variable to the process that links the shared library. =head2 BSLOADLIBS List of those libraries that are needed but can be linked in dynamically at run time on this platform. SunOS/Solaris does not need this because ld records the information (from LDLOADLIBS) into the 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 Bs in the code. +few architecture specific Cs in the code. =head2 VMS implementation The version of ext() which is executed under VMS differs from the Unix-OS/2 version in several respects: =over 2 =item * Input library and path specifications are accepted with or without the C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is present, a token is considered a directory to search if it is in fact a directory, and a library to search for otherwise. Authors who wish their extensions to be portable to Unix or OS/2 should use the Unix prefixes, since the Unix-OS/2 version of ext() requires them. =item * Wherever possible, shareable images are preferred to object libraries, and object libraries to plain object files. In accordance with VMS naming conventions, ext() looks for files named Ishr and Irtl; it also looks for Ilib and libI to accommodate Unix conventions used in some ported software. =item * For each library that is found, an appropriate directive for a linker options file is generated. The return values are space-separated strings of these directives, rather than elements used on the linker command line. =item * LDLOADLIBS contains both the libraries found based on C<$potential_libs> and the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH are always empty. =back In addition, an attempt is made to recognize several common Unix library names, and filter them out or convert them to their VMS equivalents, as appropriate. In general, the VMS version of ext() should properly handle input from extensions originally designed for a Unix or VMS environment. If you encounter problems, or discover cases where the search could be improved, please let us know. =head2 Win32 implementation The version of ext() which is executed under Win32 differs from the Unix-OS/2 version in several respects: =over 2 =item * If C<$potential_libs> is empty, the return value will be empty. Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm) will be appended to the list of C<$potential_libs>. The libraries will be searched for in the directories specified in C<$potential_libs>, C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. For each library that is found, a space-separated list of fully qualified library pathnames is generated. =item * Input library and path specifications are accepted with or without the C<-l> and C<-L> prefixes used by Unix linkers. An entry of the form C<-La:\foo> specifies the C directory to look for the libraries that follow. An entry of the form C<-lfoo> specifies the library C, which may be spelled differently depending on what kind of compiler you are using. If you are using GCC, it gets translated to C, but for other win32 compilers, it becomes C. If no files are found by those translated names, one more attempt is made to find them using either C or C, depending on whether GCC or some other win32 compiler is being used, respectively. If neither the C<-L> or C<-l> prefix is present in an entry, the entry is considered a directory to search if it is in fact a directory, and a library to search for otherwise. The C<$Config{lib_ext}> suffix will be appended to any entries that are not directories and don't already have the suffix. Note that the C<-L> and C<-l> prefixes are B, but authors who wish their extensions to be portable to Unix or OS/2 should use the prefixes, since the Unix-OS/2 version of ext() requires them. =item * Entries cannot be plain object files, as many Win32 compilers will not handle object files in the place of libraries. =item * Entries in C<$potential_libs> beginning with a colon and followed by alphanumeric characters are treated as flags. Unknown flags will be ignored. An entry that matches C disables the appending of default libraries found in C<$Config{libs}> (this should be only needed very rarely). An entry that matches C disables all searching for the libraries specified after it. Translation of C<-Lfoo> and C<-lfoo> still happens as appropriate (depending on compiler being used, as reflected by C<$Config{cc}>), but the entries are not verified to be valid files or directories. An entry that matches C reenables searching for the libraries specified after it. You can put it at the end to enable searching for default libraries specified by C<$Config{libs}>. =item * 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 * LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS and LD_RUN_PATH are always empty (this may change in future). =item * You must make sure that any paths and path components are properly surrounded with double-quotes if they contain spaces. For example, C<$potential_libs> could be (literally): "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" Note how the first and last entries are protected by quotes in order to protect the spaces. =item * Since this module is most often used only indirectly from extension C files, here is an example C entry to add a library to the build process for an extension: LIBS => ['-lgl'] When using GCC, that entry specifies that MakeMaker should first look for C (followed by C) in all the locations specified by C<$Config{libpth}>. When using a compiler other than GCC, the above entry will search for C (followed by C). If the library happens to be in a location not in C<$Config{libpth}>, you need: LIBS => ['-Lc:\gllibs -lgl'] Here is a less often used example: LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32'] This specifies a search for library C as before. If that search fails to find the library, it looks at the next item in the list. The C<:nosearch> flag will prevent searching for the libraries that follow, so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>, since GCC can use that value as is with its linker. When using the Visual C compiler, the second item is returned as C<-libpath:d:\mesalibs mesa.lib user32.lib>. When using the Borland compiler, the second item is returned as C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of moving the C<-Ld:\mesalibs> to the correct place in the linker command line. =back =head1 SEE ALSO L =cut Index: head/contrib/perl5/lib/ExtUtils/MM_Unix.pm =================================================================== --- head/contrib/perl5/lib/ExtUtils/MM_Unix.pm (revision 62079) +++ head/contrib/perl5/lib/ExtUtils/MM_Unix.pm (revision 62080) @@ -1,3573 +1,3820 @@ +# $FreeBSD$ package ExtUtils::MM_Unix; use Exporter (); use Config; use File::Basename qw(basename dirname fileparse); use DirHandle; 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.1.1.2 $, 10; -# $Id: MM_Unix.pm,v 1.1.1.2 1999/05/02 14:25:31 markm Exp $ +$VERSION = substr q$Revision: 1.12603 $, 10; +# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $ -Exporter::import('ExtUtils::MakeMaker', - qw( $Verbose &neatvalue)); +Exporter::import('ExtUtils::MakeMaker', qw($Verbose &neatvalue)); $Is_OS2 = $^O eq 'os2'; $Is_Mac = $^O eq 'MacOS'; $Is_Win32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; $Is_PERL_OBJECT = $Config{'ccflags'} =~ /-DPERL_OBJECT/; if ($Is_VMS = $^O eq 'VMS') { require VMS::Filespec; import VMS::Filespec qw( &vmsify ); } =head1 NAME ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker =head1 SYNOPSIS C =head1 DESCRIPTION The methods provided by this package are designed to be used in conjunction with ExtUtils::MakeMaker. When MakeMaker writes a Makefile, it creates one or more objects that inherit their methods from a package C. MM itself doesn't provide any methods, but it ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating specific packages take the responsibility for all the methods provided by MM_Unix. We are trying to reduce the number of the necessary overrides by defining rather primitive operations within ExtUtils::MM_Unix. If you are going to write a platform specific MM package, please try to limit the necessary overrides to primitive methods, and if it is not possible to do so, let's work out how to achieve that gain. If you are overriding any of these methods in your Makefile.PL (in the MY class), please report that to the makemaker mailing list. We are trying to minimize the necessary method overrides and switch to data driven Makefile.PLs wherever possible. In the long run less methods will be overridable via the MY class. =head1 METHODS The following description of methods is still under development. Please refer to the code for not suitably documented sections and complain loudly to the makemaker mailing list. Not all of the methods below are overridable in a Makefile.PL. Overridable methods are marked as (o). All methods are overridable by a platform specific MM_*.pm file (See L) and L). =head2 Preloaded methods =over 2 =item canonpath No physical check on the filesystem, but a logical cleanup of a path. On UNIX eliminated successive slashes and successive "/.". =cut sub canonpath { my($self,$path) = @_; my $node = ''; - if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/| ) { + if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/|s ) { $node = $1; } $path =~ s|(?<=[^/])/+|/|g ; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx - $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx - $path =~ s|(?<=[^/])/$|| ; # xx/ -> xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|(?<=[^/])/\z|| ; # xx/ -> xx "$node$path"; } =item catdir Concatenate two or more directory names to form a complete path ending with a directory. But remove the trailing slash from the resulting string, because it doesn't look good, isn't necessary and confuses OS2. Of course, if this is the root directory, don't cut off the trailing slash :-) =cut # '; sub catdir { my $self = shift @_; my @args = @_; for (@args) { # append a slash to each argument unless it has one there $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; } $self->canonpath(join('', @args)); } =item catfile Concatenate one or more directory names and a filename to form a complete path ending with a filename =cut sub catfile { my $self = shift @_; my $file = pop @_; return $self->canonpath($file) unless @_; my $dir = $self->catdir(@_); for ($dir) { $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; } return $self->canonpath($dir.$file); } =item curdir Returns a string representing of the current directory. "." on UNIX. =cut sub curdir { return "." ; } =item rootdir Returns a string representing of the root directory. "/" on UNIX. =cut sub rootdir { return "/"; } =item updir Returns a string representing of the parent directory. ".." on UNIX. =cut sub updir { return ".."; } sub ExtUtils::MM_Unix::c_o ; sub ExtUtils::MM_Unix::clean ; sub ExtUtils::MM_Unix::const_cccmd ; sub ExtUtils::MM_Unix::const_config ; sub ExtUtils::MM_Unix::const_loadlibs ; sub ExtUtils::MM_Unix::constants ; sub ExtUtils::MM_Unix::depend ; sub ExtUtils::MM_Unix::dir_target ; sub ExtUtils::MM_Unix::dist ; sub ExtUtils::MM_Unix::dist_basics ; sub ExtUtils::MM_Unix::dist_ci ; sub ExtUtils::MM_Unix::dist_core ; sub ExtUtils::MM_Unix::dist_dir ; sub ExtUtils::MM_Unix::dist_test ; sub ExtUtils::MM_Unix::dlsyms ; sub ExtUtils::MM_Unix::dynamic ; sub ExtUtils::MM_Unix::dynamic_bs ; sub ExtUtils::MM_Unix::dynamic_lib ; sub ExtUtils::MM_Unix::exescan ; sub ExtUtils::MM_Unix::export_list ; sub ExtUtils::MM_Unix::extliblist ; sub ExtUtils::MM_Unix::file_name_is_absolute ; sub ExtUtils::MM_Unix::find_perl ; 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 ; sub ExtUtils::MM_Unix::install ; sub ExtUtils::MM_Unix::installbin ; sub ExtUtils::MM_Unix::libscan ; sub ExtUtils::MM_Unix::linkext ; sub ExtUtils::MM_Unix::lsdir ; sub ExtUtils::MM_Unix::macro ; sub ExtUtils::MM_Unix::makeaperl ; sub ExtUtils::MM_Unix::makefile ; sub ExtUtils::MM_Unix::manifypods ; sub ExtUtils::MM_Unix::maybe_command ; sub ExtUtils::MM_Unix::maybe_command_in_dirs ; sub ExtUtils::MM_Unix::needs_linking ; sub ExtUtils::MM_Unix::nicetext ; sub ExtUtils::MM_Unix::parse_version ; sub ExtUtils::MM_Unix::pasthru ; sub ExtUtils::MM_Unix::path ; sub ExtUtils::MM_Unix::perl_archive; sub ExtUtils::MM_Unix::perl_script ; sub ExtUtils::MM_Unix::perldepend ; sub ExtUtils::MM_Unix::pm_to_blib ; sub ExtUtils::MM_Unix::post_constants ; sub ExtUtils::MM_Unix::post_initialize ; sub ExtUtils::MM_Unix::postamble ; sub ExtUtils::MM_Unix::ppd ; sub ExtUtils::MM_Unix::prefixify ; sub ExtUtils::MM_Unix::processPL ; sub ExtUtils::MM_Unix::realclean ; sub ExtUtils::MM_Unix::replace_manpage_separator ; sub ExtUtils::MM_Unix::static ; sub ExtUtils::MM_Unix::static_lib ; sub ExtUtils::MM_Unix::staticmake ; sub ExtUtils::MM_Unix::subdir_x ; sub ExtUtils::MM_Unix::subdirs ; sub ExtUtils::MM_Unix::test ; sub ExtUtils::MM_Unix::test_via_harness ; sub ExtUtils::MM_Unix::test_via_script ; sub ExtUtils::MM_Unix::tool_autosplit ; sub ExtUtils::MM_Unix::tool_xsubpp ; sub ExtUtils::MM_Unix::tools_other ; sub ExtUtils::MM_Unix::top_targets ; sub ExtUtils::MM_Unix::writedoc ; sub ExtUtils::MM_Unix::xs_c ; sub ExtUtils::MM_Unix::xs_cpp ; sub ExtUtils::MM_Unix::xs_o ; sub ExtUtils::MM_Unix::xsubpp_version ; package ExtUtils::MM_Unix; use SelfLoader; 1; __DATA__ =back =head2 SelfLoaded methods =over 2 =item c_o (o) Defines the suffix rules to compile different flavors of C files to object files. =cut sub c_o { # --- Translation Sections --- my($self) = shift; return '' unless $self->needs_linking(); my(@m); push @m, ' .c$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; push @m, ' .C$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C ' if $^O ne 'os2' and $^O ne 'MSWin32' and $^O ne 'dos'; #Case-specific push @m, ' .cpp$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp .cxx$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cxx .cc$(OBJ_EXT): $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cc '; join "", @m; } =item cflags (o) Does very much the same as the cflags script in the perl distribution. It doesn't return the whole compiler command line, but initializes all of its parts. The const_cccmd method then actually returns the definition of the CCCMD macro which uses these parts. =cut #' sub cflags { my($self,$libperl)=@_; return $self->{CFLAGS} if $self->{CFLAGS}; return '' unless $self->needs_linking(); my($prog, $uc, $perltype, %cflags); $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; @cflags{qw(cc ccflags optimize large split shellflags)} = @Config{qw(cc ccflags optimize large split shellflags)}; my($optdebug) = ""; $cflags{shellflags} ||= ''; my(%map) = ( D => '-DDEBUGGING', E => '-DEMBED', DE => '-DDEBUGGING -DEMBED', M => '-DEMBED -DMULTIPLICITY', DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY', ); if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){ $uc = uc($1); } else { $uc = ""; # avoid warning } $perltype = $map{$uc} ? $map{$uc} : ""; if ($uc =~ /^D/) { $optdebug = "-g"; } my($name); ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; if ($prog = $Config::Config{$name}) { # Expand hints for this extension via the shell print STDOUT "Processing $name hint:\n" if $Verbose; my(@o)=`cc=\"$cflags{cc}\" ccflags=\"$cflags{ccflags}\" optimize=\"$cflags{optimize}\" perltype=\"$cflags{perltype}\" optdebug=\"$cflags{optdebug}\" large=\"$cflags{large}\" split=\"$cflags{'split'}\" eval '$prog' echo cc=\$cc echo ccflags=\$ccflags echo optimize=\$optimize echo perltype=\$perltype echo optdebug=\$optdebug echo large=\$large echo split=\$split `; my($line); foreach $line (@o){ chomp $line; if ($line =~ /(.*?)=\s*(.*)\s*$/){ $cflags{$1} = $2; print STDOUT " $1 = $2\n" if $Verbose; } else { print STDOUT "Unrecognised result from hint: '$line'\n"; } } } if ($optdebug) { $cflags{optimize} = $optdebug; } for (qw(ccflags optimize perltype large split)) { $cflags{$_} =~ s/^\s+//; $cflags{$_} =~ s/\s+/ /g; $cflags{$_} =~ s/\s+$//; $self->{uc $_} ||= $cflags{$_} } - 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 ($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->{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 }; } =item clean (o) Defines the clean target. =cut sub clean { # --- Cleanup and Distribution Sections --- my($self, %attribs) = @_; my(@m,$dir); push(@m, ' # Delete temporary files but do not touch installed files. We don\'t delete # the Makefile here so a later make realclean still has a makefile to use. clean :: '); # clean subdirectories first for $dir (@{$self->{DIR}}) { - push @m, "\t-cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean\n"; + if ($Is_Win32 && Win32::IsWin95()) { + push @m, <{MAKEFILE} + \$(MAKE) clean + cd .. +EOT + } + else { + push @m, <{MAKEFILE} && \$(MAKE) clean +EOT + } } 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 so_locations pm_to_blib + perlmain.c mon.out core core.*perl.*.? + *perl.core so_locations pm_to_blib *~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp ]); push @m, "\t-$self->{RM_RF} @otherfiles\n"; # See realclean and ext/utils/make_ext for usage of Makefile.old push(@m, "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old \$(DEV_NULL)\n"); push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; join("", @m); } =item const_cccmd (o) Returns the full compiler call for C programs and stores the definition in CONST_CCCMD. =cut sub const_cccmd { my($self,$libperl)=@_; return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; return '' unless $self->needs_linking(); return $self->{CONST_CCCMD} = q{CCCMD = $(CC) -c $(INC) $(CCFLAGS) $(OPTIMIZE) \\ - $(PERLTYPE) $(LARGE) $(SPLIT) $(DEFINE_VERSION) \\ + $(PERLTYPE) $(LARGE) $(SPLIT) $(MPOLLUTE) $(DEFINE_VERSION) \\ $(XS_DEFINE_VERSION)}; } =item const_config (o) Defines a couple of constants in the Makefile that are imported from %Config. =cut sub const_config { # --- Constants Sections --- my($self) = shift; my(@m,$m); push(@m,"\n# These definitions are from config.sh (via $INC{'Config.pm'})\n"); push(@m,"\n# They may have been overridden via Makefile.PL or on the command line\n"); my(%once_only); foreach $m (@{$self->{CONFIG}}){ # SITE*EXP macros are defined in &constants; avoid duplicates here next if $once_only{$m} or $m eq 'sitelibexp' or $m eq 'sitearchexp'; push @m, "\U$m\E = ".$self->{uc $m}."\n"; $once_only{$m} = 1; } join('', @m); } =item const_loadlibs (o) Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See L for details. =cut sub const_loadlibs { my($self) = shift; return "" unless $self->needs_linking; my @m; push @m, qq{ # $self->{NAME} might depend on some other libraries: # See ExtUtils::Liblist for details # }; my($tmp); for $tmp (qw/ EXTRALIBS LDLOADLIBS BSLOADLIBS LD_RUN_PATH /) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } return join "", @m; } =item constants (o) Initializes lots of constants and .SUFFIXES and .PHONY =cut sub constants { my($self) = @_; my(@m,$tmp); for $tmp (qw/ AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC - PERL_INC PERL FULLPERL + PERL_INC PERL FULLPERL FULL_AR / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } push @m, qq{ 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{ MAKEMAKER = $INC{'ExtUtils/MakeMaker.pm'} MM_VERSION = $ExtUtils::MakeMaker::VERSION }; push @m, q{ # FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) # ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!! # PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. }; for $tmp (qw/ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT LDFROM LINKTYPE / ) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } push @m, " # Handy lists of source code files: 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_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT + INST_HTMLPRIVLIBDIR INSTALLHTMLPRIVLIBDIR + INST_HTMLSITELIBDIR INSTALLHTMLSITELIBDIR + INST_HTMLSCRIPTDIR INSTALLHTMLSCRIPTDIR + INST_HTMLLIBDIR HTMLEXT + INST_MAN1DIR INSTALLMAN1DIR MAN1EXT + INST_MAN3DIR INSTALLMAN3DIR MAN3EXT /) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } for $tmp (qw( PERM_RW PERM_RWX ) ) { my $method = lc($tmp); # warn "self[$self] method[$method]"; push @m, "$tmp = ", $self->$method(), "\n"; } push @m, q{ .NO_CONFIG_REC: Makefile } if $ENV{CLEARCASE_ROOT}; # why not q{} ? -- emacs push @m, qq{ # work around a famous dec-osf make(1) feature(?): makemakerdflt: all .SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT) # Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that # some make implementations will delete the Makefile when we rebuild it. Because # we call false(1) when we rebuild it. So make(1) is not completely wrong when it # does so. Our milage may vary. # .PRECIOUS: Makefile # seems to be not necessary anymore .PHONY: all config static dynamic test linkext manifest # Where is the Config information that we are using/depend on CONFIGDEP = \$(PERL_ARCHLIB)/Config.pm \$(PERL_INC)/config.h }; my @parentdir = split(/::/, $self->{PARENT_NAME}); push @m, q{ # Where to put things: INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{ INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{ INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{ INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{ }; if ($self->has_link_code()) { push @m, ' INST_STATIC = $(INST_ARCHAUTODIR)/$(BASEEXT)$(LIB_EXT) INST_DYNAMIC = $(INST_ARCHAUTODIR)/$(DLBASE).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)/$(BASEEXT).bs '; } else { push @m, ' INST_STATIC = INST_DYNAMIC = INST_BOOT = '; } $tmp = $self->export_list; push @m, " EXPORT_LIST = $tmp "; $tmp = $self->perl_archive; push @m, " PERL_ARCHIVE = $tmp "; # push @m, q{ #INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{ # #PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ #}; push @m, q{ TO_INST_PM = }.join(" \\\n\t", sort keys %{$self->{PM}}).q{ PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{ }; join('',@m); } =item depend (o) Same as macro for the depend attribute. =cut sub depend { my($self,%attribs) = @_; my(@m,$key,$val); while (($key,$val) = each %attribs){ last unless defined $key; push @m, "$key: $val\n"; } join "", @m; } =item dir_target (o) Takes an array of directories that need to exist and returns a Makefile entry for a .exists file in these directories. Returns nothing, if the entry has already been processed. We're helpless though, if the same directory comes as $(FOO) _and_ as "bar". Both of them get an entry, that's why we use "::". =cut sub dir_target { # --- Make-Directories section (internal method) --- # dir_target(@array) returns a Makefile entry for the file .exists in each # named directory. Returns nothing, if the entry has already been processed. # We're helpless though, if the same directory comes as $(FOO) _and_ as "bar". # Both of them get an entry, that's why we use "::". I chose '$(PERL)' as the # prerequisite, because there has to be one, something that doesn't change # too often :) my($self,@dirs) = @_; my(@m,$dir,$targdir); foreach $dir (@dirs) { my($src) = $self->catfile($self->{PERL_INC},'perl.h'); 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$::; + ($targdir = $targ) =~ s:/?\.exists\z::; } else { # while elsewhere we expect to see the dir separator in $targ $targdir = dirname($targ); } next if $self->{DIR_TARGET}{$self}{$targdir}++; push @m, qq{ $targ :: $src $self->{NOECHO}\$(MKPATH) $targdir $self->{NOECHO}\$(EQUALIZE_TIMESTAMP) $src $targ }; push(@m, qq{ -$self->{NOECHO}\$(CHMOD) \$(PERM_RWX) $targdir }) unless $Is_VMS; } join "", @m; } =item dist (o) Defines a lot of macros for distribution support. =cut sub dist { my($self, %attribs) = @_; my(@m); # VERSION should be sanitised before use as a file name my($version) = $attribs{VERSION} || '$(VERSION)'; my($name) = $attribs{NAME} || '$(DISTNAME)'; my($tar) = $attribs{TAR} || 'tar'; # eg /usr/bin/gnutar my($tarflags) = $attribs{TARFLAGS} || 'cvf'; my($zip) = $attribs{ZIP} || 'zip'; # eg pkzip Yuck! my($zipflags) = $attribs{ZIPFLAGS} || '-r'; my($compress) = $attribs{COMPRESS} || 'gzip --best'; my($suffix) = $attribs{SUFFIX} || '.gz'; # eg .gz my($shar) = $attribs{SHAR} || 'shar'; # eg "shar --gzip" my($preop) = $attribs{PREOP} || "$self->{NOECHO}\$(NOOP)"; # eg update MANIFEST my($postop) = $attribs{POSTOP} || "$self->{NOECHO}\$(NOOP)"; # eg remove the distdir my($to_unix) = $attribs{TO_UNIX} || ($Is_OS2 ? "$self->{NOECHO}" . '$(TEST_F) tmp.zip && $(RM) tmp.zip;' . ' $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM) tmp.zip' : "$self->{NOECHO}\$(NOOP)"); my($ci) = $attribs{CI} || 'ci -u'; my($rcs_label)= $attribs{RCS_LABEL}|| 'rcs -Nv$(VERSION_SYM): -q'; my($dist_cp) = $attribs{DIST_CP} || 'best'; my($dist_default) = $attribs{DIST_DEFAULT} || 'tardist'; push @m, " DISTVNAME = ${name}-$version TAR = $tar TARFLAGS = $tarflags ZIP = $zip ZIPFLAGS = $zipflags COMPRESS = $compress SUFFIX = $suffix SHAR = $shar PREOP = $preop POSTOP = $postop TO_UNIX = $to_unix CI = $ci RCS_LABEL = $rcs_label DIST_CP = $dist_cp DIST_DEFAULT = $dist_default "; join "", @m; } =item dist_basics (o) Defines the targets distclean, distcheck, skipcheck, manifest. =cut sub dist_basics { my($self) = shift; my @m; push @m, q{ distclean :: realclean distcheck }; push @m, q{ distcheck : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \\ -e fullcheck }; push @m, q{ skipcheck : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \\ -e skipcheck }; push @m, q{ manifest : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\ -e mkmanifest }; join "", @m; } =item dist_ci (o) Defines a check in target for RCS. =cut sub dist_ci { my($self) = shift; my @m; push @m, q{ ci : $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\ -e "@all = keys %{ maniread() };" \\ -e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \\ -e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");' }; join "", @m; } =item dist_core (o) Defines the targets dist, tardist, zipdist, uutardist, shdist =cut sub dist_core { my($self) = shift; my @m; push @m, q{ dist : $(DIST_DEFAULT) }.$self->{NOECHO}.q{$(PERL) -le 'print "Warning: Makefile possibly out of date with $$vf" if ' \ -e '-e ($$vf="$(VERSION_FROM)") and -M $$vf < -M "}.$self->{MAKEFILE}.q{";' tardist : $(DISTVNAME).tar$(SUFFIX) zipdist : $(DISTVNAME).zip $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(POSTOP) $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(POSTOP) uutardist : $(DISTVNAME).tar$(SUFFIX) uuencode $(DISTVNAME).tar$(SUFFIX) \\ $(DISTVNAME).tar$(SUFFIX) > \\ $(DISTVNAME).tar$(SUFFIX)_uu shdist : distdir $(PREOP) $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar $(RM_RF) $(DISTVNAME) $(POSTOP) }; join "", @m; } =item dist_dir (o) Defines the scratch directory target that will hold the distribution before tar-ing (or shar-ing). =cut sub dist_dir { my($self) = shift; my @m; push @m, q{ distdir : $(RM_RF) $(DISTVNAME) $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \\ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" }; join "", @m; } =item dist_test (o) Defines a target that produces the distribution in the scratchdirectory, and runs 'perl Makefile.PL; make ;make test' in that subdirectory. =cut sub dist_test { my($self) = shift; my @m; push @m, q{ disttest : distdir cd $(DISTVNAME) && $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) Makefile.PL cd $(DISTVNAME) && $(MAKE) cd $(DISTVNAME) && $(MAKE) test }; join "", @m; } =item dlsyms (o) Used by AIX and VMS to define DL_FUNCS and DL_VARS and write the *.exp files. =cut sub dlsyms { my($self,%attribs) = @_; return '' unless ($^O eq 'aix' && $self->needs_linking() ); my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}; my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || []; my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || []; my(@m); push(@m," dynamic :: $self->{BASEEXT}.exp ") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so... push(@m," static :: $self->{BASEEXT}.exp ") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them push(@m," $self->{BASEEXT}.exp: Makefile.PL ",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\ Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ', neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist), ', "DL_VARS" => ', neatvalue($vars), ');\' '); join('',@m); } =item dynamic (o) Defines the dynamic target. =cut sub dynamic { # --- Dynamic Loading Sections --- my($self) = shift; ' ## $(INST_PM) has been moved to the all: target. ## It remains here for awhile to allow for old usage: "make dynamic" #dynamic :: '.$self->{MAKEFILE}.' $(INST_DYNAMIC) $(INST_BOOT) $(INST_PM) dynamic :: '.$self->{MAKEFILE}.' $(INST_DYNAMIC) $(INST_BOOT) '.$self->{NOECHO}.'$(NOOP) '; } =item dynamic_bs (o) Defines targets for bootstrap files. =cut sub dynamic_bs { my($self, %attribs) = @_; return ' BOOTSTRAP = ' unless $self->has_link_code(); return ' BOOTSTRAP = '."$self->{BASEEXT}.bs".' # As Mkbootstrap might not write a file (if none is required) # we use touch to prevent make continually trying to remake it. # The DynaLoader only reads a non-empty file. $(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exists '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))" '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \ -MExtUtils::Mkbootstrap \ -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');" '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP) $(CHMOD) $(PERM_RW) $@ $(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT) -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT) $(CHMOD) $(PERM_RW) $@ '; } =item dynamic_lib (o) Defines how to produce the *.so (or equivalent) files. =cut sub dynamic_lib { my($self, %attribs) = @_; return '' unless $self->needs_linking(); #might be because of a subdir return '' unless $self->has_link_code; my($otherldflags) = $attribs{OTHERLDFLAGS} || ""; my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || ""; my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":"; my($ldfrom) = '$(LDFROM)'; $armaybe = 'ar' if ($^O eq 'dec_osf' and $armaybe eq ':'); my(@m); push(@m,' # This section creates the dynamically loadable $(INST_DYNAMIC) # from $(OBJECT) and possibly $(MYEXTLIB). ARMAYBE = '.$armaybe.' OTHERLDFLAGS = '.$otherldflags.' INST_DYNAMIC_DEP = '.$inst_dynamic_dep.' $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) '); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n"); push(@m,' $(RANLIB) '."$ldfrom\n"); } $ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf'); # Brain dead solaris linker does not use LD_RUN_PATH? # This fixes dynamic extensions which need shared libs my $ldrun = ''; $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH} if ($^O eq 'solaris'); # The IRIX linker also doesn't use LD_RUN_PATH $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"} if ($^O eq 'irix' && $self->{LD_RUN_PATH}); push(@m,' $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom. ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)'); push @m, ' $(CHMOD) $(PERM_RWX) $@ '; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('',@m); } =item exescan Deprecated method. Use libscan instead. =cut sub exescan { my($self,$path) = @_; $path; } =item extliblist Called by init_others, and calls ext ExtUtils::Liblist. See L for details. =cut sub extliblist { my($self,$libs) = @_; require ExtUtils::Liblist; $self->ext($libs, $Verbose); } =item file_name_is_absolute Takes as argument a path and returns true, if it is an absolute path. =cut sub file_name_is_absolute { my($self,$file) = @_; if ($Is_Dos){ - $file =~ m{^([a-z]:)?[\\/]}i ; + $file =~ m{^([a-z]:)?[\\/]}is ; } else { - $file =~ m:^/: ; + $file =~ m:^/:s ; } } =item find_perl Finds the executables PERL and FULLPERL =cut sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; my($name, $dir); if ($trace >= 2){ print "Looking for perl $ver by these names: @$names in these dirs: @$dirs "; } foreach $dir (@$dirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ my ($abs, $val); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo $abs = $self->catfile($dir, $name); } else { # foo/bar $abs = $self->canonpath($self->catfile($self->curdir, $name)); } print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); print "Executing $abs\n" if ($trace >= 2); $val = `$abs -e 'require $ver; print "VER_OK\n" ' 2>&1`; if ($val =~ /VER_OK/) { print "Using PERL=$abs\n" if $trace; return $abs; } elsif ($trace >= 2) { print "Result: `$val'\n"; } } } print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; 0; # false and not empty } =back =head2 Methods to actually produce chunks of text for the Makefile The methods here are called for each MakeMaker object in the order specified by @ExtUtils::MakeMaker::MM_Sections. =over 2 =item fixin Inserts the sharpbang or equivalent magic number to a script =cut sub fixin { # stolen from the pink Camel book, more or less my($self,@files) = @_; my($does_shbang) = $Config::Config{'sharpbang'} =~ /^\s*\#\!/; my($file,$interpreter); for $file (@files) { local(*FIXIN); local(*FIXOUT); open(FIXIN, $file) or Carp::croak "Can't process '$file': $!"; local $/ = "\n"; chomp(my $line = ); next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file. # Now figure out the interpreter name. my($cmd,$arg) = split ' ', $line, 2; $cmd =~ s!^.*/!!; # Now look (in reverse) for interpreter in absolute PATH (unless perl). if ($cmd eq "perl") { if ($Config{startperl} =~ m,^\#!.*/perl,) { $interpreter = $Config{startperl}; $interpreter =~ s,^\#!,,; } else { $interpreter = $Config{perlpath}; } } else { my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path; $interpreter = ''; my($dir); foreach $dir (@absdirs) { if ($self->maybe_command($cmd)) { warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; $interpreter = $self->catfile($dir,$cmd); } } } # Figure out how to invoke interpreter on this machine. my($shb) = ""; if ($interpreter) { print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose; # this is probably value-free on DOSISH platforms if ($does_shbang) { $shb .= "$Config{'sharpbang'}$interpreter"; $shb .= ' ' . $arg if defined $arg; $shb .= "\n"; } $shb .= qq{ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' if 0; # not running under some shell } unless $Is_Win32; # this won't work on win32, so don't } else { warn "Can't find $cmd in PATH, $file unchanged" if $Verbose; next; } unless ( open(FIXOUT,">$file.new") ) { warn "Can't create new $file: $!\n"; next; } my($dev,$ino,$mode) = stat FIXIN; # If they override perm_rwx, we won't notice it during fixin, # because fixin is run through a new instance of MakeMaker. # That is why we must run another CHMOD later. $mode = oct($self->perm_rwx) unless $dev; chmod $mode, $file; # Print out the new #! line (or equivalent). local $\; undef $/; print FIXOUT $shb, ; close FIXIN; close FIXOUT; # can't rename open files on some DOSISH platforms unless ( rename($file, "$file.bak") ) { warn "Can't rename $file to $file.bak: $!"; next; } unless ( rename("$file.new", $file) ) { warn "Can't rename $file.new to $file: $!"; unless ( rename("$file.bak", $file) ) { warn "Can't rename $file.bak back to $file either: $!"; warn "Leaving $file renamed as $file.bak\n"; } next; } unlink "$file.bak"; } continue { chmod oct($self->perm_rwx), $file or die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; } } =item force (o) Just writes FORCE: =cut sub force { my($self) = shift; '# Phony target to force checking subdirectories. FORCE: '.$self->{NOECHO}.'$(NOOP) '; } =item guess_name Guess the name of this package by examining the working directory's name. MakeMaker calls this only if the developer has not supplied a NAME attribute. =cut # '; sub guess_name { my($self) = @_; use Cwd 'cwd'; my $name = basename(cwd()); - $name =~ s|[\-_][\d\.\-]+$||; # this is new with MM 5.00, we + $name =~ s|[\-_][\d\.\-]+\z||; # 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"; $name; } =item has_link_code Returns true if C, XS, MYEXTLIB or similar objects exist within this object that need a compiler. Does not descend into subdirectories as needs_linking() does. =cut sub has_link_code { my($self) = shift; return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE}; if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){ $self->{HAS_LINK_CODE} = 1; return 1; } 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 <{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, MAN*PODS, EXE_FILES. +Initializes DIR, XS, PM, C, O_FILES, H, PL_FILES, HTML*PODS, MAN*PODS, EXE_FILES. =cut sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($self) = @_; my($name, %dir, %xs, %c, %h, %ignore, %pl_files, %manifypods); local(%pm); #the sub in find() has to see this hash @ignore{qw(Makefile.PL test.pl)} = (1,1); $ignore{'makefile.pl'} = 1 if $Is_VMS; foreach $name ($self->lsdir($self->curdir)){ next if $name =~ /\#/; next if $name eq $self->curdir or $name eq $self->updir or $ignore{$name}; next unless $self->libscan($name); 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$/){ - my($c); ($c = $name) =~ s/\.xs$/.c/; + } elsif ($name =~ /\.xs\z/){ + my($c); ($c = $name) =~ s/\.xs\z/.c/; $xs{$name} = $c; $c{$c} = 1; - } elsif ($name =~ /\.c(pp|xx|c)?$/i){ # .c .C .cpp .cxx .cc + } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc $c{$name} = 1 unless $name =~ m/perlmain\.c/; # See MAP_TARGET - } elsif ($name =~ /\.h$/i){ + } elsif ($name =~ /\.h\z/i){ $h{$name} = 1; - } elsif ($name =~ /\.PL$/) { - ($pl_files{$name} = $name) =~ s/\.PL$// ; - } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem + } 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 local($/); open(PL,$name); my $txt = ; close PL; if ($txt =~ /Extracting \S+ \(with variable substitutions/) { - ($pl_files{$name} = $name) =~ s/\.pl$// ; + ($pl_files{$name} = $name) =~ s/[._]pl\z//i ; } else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } - } elsif ($name =~ /\.(p[ml]|pod)$/){ + } elsif ($name =~ /\.(p[ml]|pod)\z/){ $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); } } # Some larger extensions often wish to install a number of *.pm/pl # files into the library in various locations. # The attribute PMLIBDIRS holds an array reference which lists # subdirectories which we should search for library files to # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We # recursively search through the named directories (skipping any # which don't exist or contain Makefile.PL files). # For each *.pm or *.pl file found $self->libscan() is called with # the default installation path in $_[1]. The return value of # libscan defines the actual installation location. The default # libscan function simply returns the path. The file is skipped # if libscan returns false. # The default installation location passed to libscan in $_[1] is: # # ./*.pm => $(INST_LIBDIR)/*.pm # ./xyz/... => $(INST_LIBDIR)/xyz/... # ./lib/... => $(INST_LIB)/... # # In this way the 'lib' directory is seen as the root of the actual # perl library whereas the others are relative to INST_LIBDIR # (which includes PARENT_NAME). This is a subtle distinction but one # that's important for nested modules. $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}] unless $self->{PMLIBDIRS}; #only existing directories that aren't in $dir are allowed # Avoid $_ wherever possible: # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}}; my (@pmlibdirs) = @{$self->{PMLIBDIRS}}; my ($pmlibdir); @{$self->{PMLIBDIRS}} = (); foreach $pmlibdir (@pmlibdirs) { -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir; } if (@{$self->{PMLIBDIRS}}){ print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n" if ($Verbose >= 2); require File::Find; File::Find::find(sub { if (-d $_){ if ($_ eq "CVS" || $_ eq "RCS"){ $File::Find::prune = 1; } return; } return if /\#/; my($path, $prefix) = ($File::Find::name, '$(INST_LIBDIR)'); my($striplibpath,$striplibname); $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:i); ($striplibname,$striplibpath) = fileparse($striplibpath); my($inst) = $self->catfile($prefix,$striplibpath,$striplibname); local($_) = $inst; # for backwards compatibility $inst = $self->libscan($inst); print "libscan($path) => '$inst'\n" if ($Verbose >= 2); return unless $inst; $pm{$path} = $inst; }, @{$self->{PMLIBDIRS}}); } $self->{DIR} = [sort keys %dir] unless $self->{DIR}; $self->{XS} = \%xs unless $self->{XS}; $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)?$/$self->{OBJ_EXT}/i, @o_files] ; + $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$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 - if ($self->{MAN1PODS}) { - } elsif ( $self->{INST_MAN1DIR} =~ /^(none|\s*)$/ ) { - $self->{MAN1PODS} = {}; - } else { - my %manifypods = (); + 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 ( 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 () { 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; } - if( $ispod ) { - $manifypods{$name} = - $self->catfile('$(INST_MAN1DIR)', - basename($name).'.$(MAN1EXT)'); + 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)"); + } } } - $self->{MAN1PODS} = \%manifypods; } - if ($self->{MAN3PODS}) { - } elsif ( $self->{INST_MAN3DIR} =~ /^(none|\s*)$/ ) { - $self->{MAN3PODS} = {}; - } else { + if ($pods{MAN3} || $pods{HTMLLIB}) { 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$/ ) { + if ($name =~ /\.pod\z/ ) { $manifypods{$name} = $self->{PM}{$name}; - } elsif ($name =~ /\.p[ml]$/ ) { -# use FileHandle (); -# my $fh = new FileHandle; + } elsif ($name =~ /\.p[ml]\z/ ) { local *FH; my($ispod)=0; -# $fh->open("<$name"); if (open(FH,"<$name")) { - # while (<$fh>) { while () { if (/^=head1\s+\w+/) { $ispod=1; last; } } - # $fh->close; close FH; } else { $ispod = 1; } if( $ispod ) { $manifypods{$name} = $self->{PM}{$name}; } } } # 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/i) { + if ($name =~ /(config|setup).*\.pm/is) { delete $manifypods{$name}; next; } my($manpagename) = $name; - unless ($manpagename =~ s!^\W*lib\W+!!) { # everything below lib is ok + $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 $manpagename = $self->catfile(split(/::/,$self->{PARENT_NAME}),$manpagename); } - $manpagename =~ s/\.p(od|m|l)$//; - $manpagename = $self->replace_manpage_separator($manpagename); - $manifypods{$name} = $self->catfile("\$(INST_MAN3DIR)","$manpagename.\$(MAN3EXT)"); + if ($pods{MAN3}) { + $manpagename = $self->replace_manpage_separator($manpagename); + $self->{MAN3PODS}->{$name} = + $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); + } } - $self->{MAN3PODS} = \%manifypods; } } =item init_main Initializes NAME, FULLEXT, BASEEXT, PARENT_NAME, DLBASE, PERL_SRC, PERL_LIB, PERL_ARCHLIB, PERL_INC, INSTALLDIRS, INST_*, INSTALL*, PREFIX, CONFIG, AR, AR_STATIC_ARGS, LD, OBJ_EXT, LIB_EXT, EXE_EXT, MAP_TARGET, LIBPERL_A, VERSION_FROM, VERSION, DISTNAME, VERSION_SYM. =cut sub init_main { my($self) = @_; # --- Initialize Module Name and Paths # NAME = Foo::Bar::Oracle # FULLEXT = Foo/Bar/Oracle # BASEEXT = Oracle # ROOTEXT = Directory part of FULLEXT with leading /. !!! Deprecated from MM 5.32 !!! # PARENT_NAME = Foo::Bar ### Only UNIX: ### ($self->{FULLEXT} = ### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME}); # Copied from DynaLoader: my(@modparts) = split(/::/,$self->{NAME}); my($modfname) = $modparts[-1]; # Some systems have restrictions on files names for DLL's etc. # mod2fname returns appropriate file base name (typically truncated) # It may also edit @modparts if required. if (defined &DynaLoader::mod2fname) { $modfname = &DynaLoader::mod2fname(\@modparts); } - ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)$! ; + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ; if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' $self->{DLBASE} = $modfname; } else { $self->{DLBASE} = '$(BASEEXT)'; } ### ROOTEXT deprecated from MM 5.32 ### ($self->{ROOTEXT} = ### $self->{FULLEXT}) =~ s#/?\Q$self->{BASEEXT}\E$## ; #eg. /BSD/Foo ### $self->{ROOTEXT} = ($Is_VMS ? '' : '/') . $self->{ROOTEXT} if $self->{ROOTEXT}; # --- Initialize PERL_LIB, INST_LIB, PERL_SRC # *Real* information: where did we get these two from? ... my $inc_config_dir = dirname($INC{'Config.pm'}); my $inc_carp_dir = dirname($INC{'Carp.pm'}); unless ($self->{PERL_SRC}){ my($dir); foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){ if ( -f $self->catfile($dir,"config.sh") && -f $self->catfile($dir,"perl.h") && -f $self->catfile($dir,"lib","Exporter.pm") ) { $self->{PERL_SRC}=$dir ; last; } } } if ($self->{PERL_SRC}){ $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib"); $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; $self->{PERL_INC} = ($Is_Win32) ? $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; # catch a situation that has occurred a few times in the past: unless ( -s $self->catfile($self->{PERL_SRC},'cflags') or $Is_VMS && -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') or $Is_Mac or $Is_Win32 ){ warn qq{ You cannot build extensions below the perl source tree after executing a 'make clean' in the perl source tree. To rebuild extensions distributed with the perl source you should simply Configure (to include those extensions) and then build perl as normal. After installing perl the source tree can be deleted. It is not needed for building extensions by running 'perl Makefile.PL' usually without extra arguments. It is recommended that you unpack and build additional extensions away 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 <catfile($self->{PERL_INC},"perl.h"))){ die qq{ Error: Unable to locate installed Perl libraries or Perl source code. It is recommended that you install perl in a standard location before building extensions. Some precompiled versions of perl do not contain these header files, so you cannot build extensions. In such a case, please build and install your perl from a fresh perl distribution. It usually solves this kind of problem. \(You get this message, because MakeMaker could not find "$perl_h"\) }; } # print STDOUT "Using header files found in $self->{PERL_INC}\n" # if $Verbose && $self->needs_linking(); } # We get SITELIBEXP and SITEARCHEXP directly via # Get_from_Config. When we are running standard modules, these # won't matter, we will set INSTALLDIRS to "perl". Otherwise we # set it to "site". I prefer that INSTALLDIRS be set from outside # MakeMaker. $self->{INSTALLDIRS} ||= "site"; # INST_LIB typically pre-set if building an extension after # perl has been built and installed. Setting INST_LIB allows # you to build directly into, say $Config::Config{privlibexp}. unless ($self->{INST_LIB}){ ##### XXXXX We have to change this nonsense if (defined $self->{PERL_SRC} and $self->{INSTALLDIRS} eq "perl") { $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB}; } else { $self->{INST_LIB} = $self->catdir($self->curdir,"blib","lib"); } } $self->{INST_ARCHLIB} ||= $self->catdir($self->curdir,"blib","arch"); $self->{INST_BIN} ||= $self->catdir($self->curdir,'blib','bin'); # We need to set up INST_LIBDIR before init_libscan() for VMS my @parentdir = split(/::/, $self->{PARENT_NAME}); $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)',@parentdir); $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)',@parentdir); $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)','auto','$(FULLEXT)'); $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)'); # INST_EXE is deprecated, should go away March '97 $self->{INST_EXE} ||= $self->catdir($self->curdir,'blib','script'); $self->{INST_SCRIPT} ||= $self->catdir($self->curdir,'blib','script'); # The user who requests an installation directory explicitly # should not have to tell us a architecture installation directory # as well. We look if a directory exists that is named after the # architecture. If not we take it as a sign that it should be the # same as the requested installation directory. Otherwise we take # the found one. # We do the same thing twice: for privlib/archlib and for sitelib/sitearch my($libpair); for $libpair ({l=>"privlib", a=>"archlib"}, {l=>"sitelib", a=>"sitearch"}) { my $lib = "install$libpair->{l}"; my $Lib = uc $lib; my $Arch = uc "install$libpair->{a}"; if( $self->{$Lib} && ! $self->{$Arch} ){ my($ilib) = $Config{$lib}; $ilib = VMS::Filespec::unixify($ilib) if $Is_VMS; $self->prefixify($Arch,$ilib,$self->{$Lib}); unless (-d $self->{$Arch}) { print STDOUT "Directory $self->{$Arch} not found, thusly\n" if $Verbose; $self->{$Arch} = $self->{$Lib}; } print STDOUT "Defaulting $Arch to $self->{$Arch}\n" if $Verbose; } } # we have to look at the relation between $Config{prefix} and the # requested values. We're going to set the $Config{prefix} part of # all the installation path variables to literally $(PREFIX), so # the user can still say make PREFIX=foo my($configure_prefix) = $Config{'prefix'}; $configure_prefix = VMS::Filespec::unixify($configure_prefix) if $Is_VMS; $self->{PREFIX} ||= $configure_prefix; my($install_variable,$search_prefix,$replace_prefix); - # The rule, taken from Configure, is that if prefix contains perl, - # we shape the tree + # If the prefix contains perl, Configure shapes the tree as follows: # perlprefix/lib/ INSTALLPRIVLIB # perlprefix/lib/pod/ # perlprefix/lib/site_perl/ INSTALLSITELIB # perlprefix/bin/ INSTALLBIN # perlprefix/man/ INSTALLMAN1DIR # else # prefix/lib/perl5/ INSTALLPRIVLIB # prefix/lib/perl5/pod/ # 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,$search_prefix,$replace_prefix); } - $search_prefix = $configure_prefix =~ /perl/ ? - $self->catdir($configure_prefix,"lib") : - $self->catdir($configure_prefix,"lib","perl5"); + my $funkylibdir = $self->catdir($configure_prefix,"lib","perl5"); + $funkylibdir = '' unless -d $funkylibdir; + $search_prefix = $funkylibdir || $self->catdir($configure_prefix,"lib"); if ($self->{LIB}) { $self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB}; $self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} = $self->catdir($self->{LIB},$Config{'archname'}); - } else { - $replace_prefix = $self->{PREFIX} =~ /perl/ ? - $self->catdir(qq[\$\(PREFIX\)],"lib") : - $self->catdir(qq[\$\(PREFIX\)],"lib","perl5"); + } + 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"); + } for $install_variable (qw/ INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB INSTALLSITEARCH - /) { + /) + { $self->prefixify($install_variable,$search_prefix,$replace_prefix); } } - $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"); + 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"); + } for $install_variable (qw/ INSTALLMAN1DIR INSTALLMAN3DIR - /) { + /) + { $self->prefixify($install_variable,$search_prefix,$replace_prefix); } # Now we head at the manpages. Maybe they DO NOT want manpages # installed $self->{INSTALLMAN1DIR} = $Config::Config{installman1dir} unless defined $self->{INSTALLMAN1DIR}; unless (defined $self->{INST_MAN1DIR}){ if ($self->{INSTALLMAN1DIR} =~ /^(none|\s*)$/){ $self->{INST_MAN1DIR} = $self->{INSTALLMAN1DIR}; } else { $self->{INST_MAN1DIR} = $self->catdir($self->curdir,'blib','man1'); } } $self->{MAN1EXT} ||= $Config::Config{man1ext}; $self->{INSTALLMAN3DIR} = $Config::Config{installman3dir} unless defined $self->{INSTALLMAN3DIR}; unless (defined $self->{INST_MAN3DIR}){ if ($self->{INSTALLMAN3DIR} =~ /^(none|\s*)$/){ $self->{INST_MAN3DIR} = $self->{INSTALLMAN3DIR}; } else { $self->{INST_MAN3DIR} = $self->catdir($self->curdir,'blib','man3'); } } $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" if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY'); $self->{CONFIG} = [] unless (ref $self->{CONFIG}); push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config); push(@{$self->{CONFIG}}, 'shellflags') if $Config::Config{shellflags}; my(%once_only,$m); foreach $m (@{$self->{CONFIG}}){ next if $once_only{$m}; print STDOUT "CONFIG key '$m' does not exist in Config.pm\n" unless exists $Config::Config{$m}; $self->{uc $m} ||= $Config::Config{$m}; $once_only{$m} = 1; } # This is too dangerous: # if ($^O eq "next") { # $self->{AR} = "libtool"; # $self->{AR_STATIC_ARGS} = "-o"; # } # But I leave it as a placeholder $self->{AR_STATIC_ARGS} ||= "cr"; # These should never be needed $self->{LD} ||= 'ld'; $self->{OBJ_EXT} ||= '.o'; $self->{LIB_EXT} ||= '.a'; $self->{MAP_TARGET} ||= "perl"; $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}"; # make a simple check if we find Exporter warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory (Exporter.pm not found)" unless -f $self->catfile("$self->{PERL_LIB}","Exporter.pm") || $self->{NAME} eq "ExtUtils::MakeMaker"; # Determine VERSION and VERSION_FROM ($self->{DISTNAME}=$self->{NAME}) =~ s#(::)#-#g unless $self->{DISTNAME}; if ($self->{VERSION_FROM}){ $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}) or Carp::carp "WARNING: Setting VERSION via file '$self->{VERSION_FROM}' failed\n" } # strip blanks if ($self->{VERSION}) { $self->{VERSION} =~ s/^\s+//; $self->{VERSION} =~ s/\s+$//; } $self->{VERSION} ||= "0.10"; ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g; # Graham Barr and Paul Marquess had some ideas how to ensure # version compatibility between the *.pm file and the # corresponding *.xs file. The bottomline was, that we need an # XS_VERSION macro that defaults to VERSION: $self->{XS_VERSION} ||= $self->{VERSION}; # --- Initialize Perl Binary Locations # Find Perl 5. The only contract here is that both 'PERL' and 'FULLPERL' # will be working versions of perl 5. miniperl has priority over perl # for PERL to ensure that $(PERL) is usable while building ./ext/* my ($component,@defpath); foreach $component ($self->{PERL_SRC}, $self->path(), $Config::Config{binexp}) { push @defpath, $component if defined $component; } $self->{PERL} ||= - $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ], + $self->find_perl(5.0, [ $self->canonpath($^X), 'miniperl', + 'perl','perl5',"perl$Config{version}" ], \@defpath, $Verbose ); # don't check if perl is executable, maybe they have decided to # supply switches with perl # Define 'FULLPERL' to be a non-miniperl (used in test: target) ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/perl/i unless ($self->{FULLPERL}); } =item init_others Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, NOOP, FIRST_MAKEFILE, MAKEFILE, NOECHO, RM_F, RM_RF, TEST_F, TOUCH, CP, MV, CHMOD, UMASK_NULL =cut sub init_others { # --- Initialize Other Attributes my($self) = shift; # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS} # Lets look at $self->{LIBS} carefully: It may be an anon array, a string or # undefined. In any case we turn it into an anon array: # May check $Config{libs} too, thus not empty. $self->{LIBS}=[''] unless $self->{LIBS}; $self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq 'SCALAR'; $self->{LD_RUN_PATH} = ""; my($libs); foreach $libs ( @{$self->{LIBS}} ){ $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace my(@libs) = $self->extliblist($libs); if ($libs[0] or $libs[1] or $libs[2]){ # LD_RUN_PATH now computed by ExtUtils::Liblist ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs; last; } } if ( $self->{OBJECT} ) { $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; } else { # init_dirscan should have found out, if we have C files $self->{OBJECT} = ""; $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]}; } $self->{OBJECT} =~ s/\n+/ \\\n\t/g; $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : ""; $self->{PERLMAINCC} ||= '$(CC)'; $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM}; # Sanity check: don't define LINKTYPE = dynamic if we're skipping # the 'dynamic' section of MM. We don't have this problem with # 'static', since we either must use it (%Config says we can't # use dynamic loading) or the caller asked for it explicitly. if (!$self->{LINKTYPE}) { $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'} ? 'static' : ($Config::Config{usedl} ? 'dynamic' : 'static'); }; # These get overridden for VMS and maybe some other systems $self->{NOOP} ||= '$(SHELL) -c true'; $self->{FIRST_MAKEFILE} ||= "Makefile"; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{MAKE_APERL_FILE} ||= "Makefile.aperl"; $self->{NOECHO} = '@' unless defined $self->{NOECHO}; $self->{RM_F} ||= "rm -f"; $self->{RM_RF} ||= "rm -rf"; $self->{TOUCH} ||= "touch"; $self->{TEST_F} ||= "test -f"; $self->{CP} ||= "cp"; $self->{MV} ||= "mv"; $self->{CHMOD} ||= "chmod"; $self->{UMASK_NULL} ||= "umask 0"; $self->{DEV_NULL} ||= "> /dev/null 2>&1"; } =item install (o) Defines the install target. =cut sub install { my($self, %attribs) = @_; my(@m); push @m, q{ install :: all pure_install doc_install install_perl :: all pure_perl_install doc_perl_install install_site :: all pure_site_install doc_site_install install_ :: install_site @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site pure_install :: pure_$(INSTALLDIRS)_install doc_install :: doc_$(INSTALLDIRS)_install }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod pure__install : pure_site_install @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site doc__install : doc_site_install @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site pure_perl_install :: }.$self->{NOECHO}.q{$(MOD_INSTALL) \ read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ write }.$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \ $(INST_LIB) $(INSTALLPRIVLIB) \ $(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) \ }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{ pure_site_install :: }.$self->{NOECHO}.q{$(MOD_INSTALL) \ read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \ write }.$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \ $(INST_LIB) $(INSTALLSITELIB) \ $(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)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ doc_site_install :: + -}.$self->{NOECHO}.q{$(MKPATH) $(INSTALLARCHLIB) -}.$self->{NOECHO}.q{$(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ }; push @m, q{ uninstall :: uninstall_from_$(INSTALLDIRS)dirs uninstall_from_perldirs :: }.$self->{NOECHO}. q{$(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ uninstall_from_sitedirs :: }.$self->{NOECHO}. q{$(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ }; join("",@m); } =item installbin (o) Defines targets to make and to install EXE_FILES. =cut sub installbin { my($self) = shift; return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; return "" unless @{$self->{EXE_FILES}}; my(@m, $from, $to, %fromto, @to); push @m, $self->dir_target(qw[$(INST_SCRIPT)]); for $from (@{$self->{EXE_FILES}}) { my($path)= $self->catfile('$(INST_SCRIPT)', basename($from)); local($_) = $path; # for backwards compatibility $to = $self->libscan($path); print "libscan($from) => '$to'\n" if ($Verbose >=2); $fromto{$from}=$to; } @to = values %fromto; push(@m, qq{ EXE_FILES = @{$self->{EXE_FILES}} } . ($Is_Win32 ? q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ -e "system qq[pl2bat.bat ].shift" } : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \ -e "MY->fixin(shift)" }).qq{ pure_all :: @to $self->{NOECHO}\$(NOOP) realclean :: $self->{RM_F} @to }); while (($from,$to) = each %fromto) { last unless defined $from; my $todir = dirname($to); push @m, " $to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . " $self->{NOECHO}$self->{RM_F} $to $self->{CP} $from $to \$(FIXIN) $to -$self->{NOECHO}\$(CHMOD) \$(PERM_RWX) $to "; } join "", @m; } =item libscan (o) Takes a path to a file that is found by init_dirscan and returns false if we don't want to include this file in the library. Mainly used to exclude RCS, CVS, and SCCS directories from installation. =cut # '; sub libscan { my($self,$path) = @_; return '' if $path =~ m:\b(RCS|CVS|SCCS)\b: ; $path; } =item linkext (o) Defines the linkext target which in turn defines the LINKTYPE. =cut sub linkext { my($self, %attribs) = @_; # LINKTYPE => static or dynamic or '' my($linktype) = defined $attribs{LINKTYPE} ? $attribs{LINKTYPE} : '$(LINKTYPE)'; " linkext :: $linktype $self->{NOECHO}\$(NOOP) "; } =item lsdir Takes as arguments a directory name and a regular expression. Returns all entries in the directory that match the regular expression. =cut sub lsdir { my($self) = shift; my($dir, $regex) = @_; my(@ls); my $dh = new DirHandle; $dh->open($dir || ".") or return (); @ls = $dh->read; $dh->close; @ls = grep(/$regex/, @ls) if $regex; @ls; } =item macro (o) Simple subroutine to insert the macros defined by the macro attribute into the Makefile. =cut sub macro { my($self,%attribs) = @_; my(@m,$key,$val); while (($key,$val) = each %attribs){ last unless defined $key; push @m, "$key = $val\n"; } join "", @m; } =item makeaperl (o) Called by staticmake. Defines how to write the Makefile to produce a static new perl. By default the Makefile produced includes all the static extensions in the perl library. (Purified versions of library files, e.g., DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) =cut sub makeaperl { my($self, %attribs) = @_; my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; my(@m); push @m, " # --- MakeMaker makeaperl section --- MAP_TARGET = $target FULLPERL = $self->{FULLPERL} "; return join '', @m if $self->{PARENT}; my($dir) = join ":", @{$self->{DIR}}; unless ($self->{MAKEAPERL}) { push @m, q{ $(MAP_TARGET) :: static $(MAKE_APERL_FILE) $(MAKE) -f $(MAKE_APERL_FILE) $@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) }.$self->{NOECHO}.q{echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) }.$self->{NOECHO}.q{$(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ Makefile.PL DIR=}, $dir, q{ \ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=}; foreach (@ARGV){ if( /\s/ ){ s/=(.*)/='$1'/; } push @m, " \\\n\t\t$_"; } # push @m, map( " \\\n\t\t$_", @ARGV ); push @m, "\n"; return join '', @m; } my($cccmd, $linkcmd, $lperl); $cccmd = $self->const_cccmd($libperl); $cccmd =~ s/^CCCMD\s*=\s*//; $cccmd =~ s/\$\(INC\)/ -I$self->{PERL_INC} /; $cccmd .= " $Config::Config{cccdlflags}" if ($Config::Config{useshrplib} eq 'true'); $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; # The front matter of the linkcommand... $linkcmd = join ' ', "\$(CC)", grep($_, @Config{qw(large split ldflags ccdlflags)}); $linkcmd =~ s/\s+/ /g; $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; # Which *.a files could we make use of... local(%static); require File::Find; File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; return if m/^libperl/; # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a) return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; my $incl; my $xx; - ($xx = $File::Find::name) =~ s,.*?/auto/,,; + ($xx = $File::Find::name) =~ s,.*?/auto/,,s; $xx =~ s,/?$_,,; $xx =~ s,/,::,g; # Throw away anything not explicitly marked for inclusion. # DynaLoader is implied. foreach $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ if( $xx eq $incl ){ $found++; last; } } return unless $found; } elsif( exists $self->{EXCLUDE_EXT} ){ my $excl; my $xx; - ($xx = $File::Find::name) =~ s,.*?/auto/,,; + ($xx = $File::Find::name) =~ s,.*?/auto/,,s; $xx =~ s,/?$_,,; $xx =~ s,/,::,g; # Throw away anything explicitly marked for exclusion foreach $excl (@{$self->{EXCLUDE_EXT}}){ return if( $xx eq $excl ); } } # don't include the installed version of this extension. I # leave this line here, although it is not necessary anymore: # I patched minimod.PL instead, so that Miniperl.pm won't # enclude duplicates # 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}$:; + return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:; use Cwd 'cwd'; $static{cwd() . "/" . $_}++; }, grep( -d $_, @{$searchdirs || []}) ); # We trust that what has been handed in as argument, will be buildable $static = [] unless $static; @static{@{$static}} = (1) x @{$static}; $extra = [] unless $extra && ref $extra eq 'ARRAY'; for (sort keys %static) { - next unless /\Q$self->{LIB_EXT}\E$/; + next unless /\Q$self->{LIB_EXT}\E\z/; $_ = dirname($_) . "/extralibs.ld"; push @$extra, $_; } grep(s/^/-I/, @{$perlinc || []}); $target = "perl" unless $target; $tmp = "." unless $tmp; # MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we # regenerate the Makefiles, MAP_STATIC and the dependencies for # extralibs.all are computed correctly push @m, " MAP_LINKCMD = $linkcmd MAP_PERLINC = @{$perlinc || []} MAP_STATIC = ", join(" \\\n\t", reverse sort keys %static), " MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib} "; if (defined $libperl) { ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/; } unless ($libperl && -f $lperl) { # Ilya's code... my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; $libperl ||= "libperl$self->{LIB_EXT}"; $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; $lperl = "$dir/$lperl"; if (! -f $libperl and ! -f $lperl) { # We did not find a static libperl. Maybe there is a shared one? if ($^O eq 'solaris' or $^O eq 'sunos') { $lperl = $libperl = "$dir/$Config::Config{libperl}"; # SUNOS ld does not take the full path to a shared library $libperl = '' if $^O eq 'sunos'; } } print STDOUT "Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed otherwise ignore this warning\n" unless (-f $lperl || defined($self->{PERL_SRC})); } push @m, " MAP_LIBPERL = $libperl "; push @m, " \$(INST_ARCHAUTODIR)/extralibs.all: \$(INST_ARCHAUTODIR)/.exists ".join(" \\\n\t", @$extra)." $self->{NOECHO}$self->{RM_F} \$\@ $self->{NOECHO}\$(TOUCH) \$\@ "; my $catfile; foreach $catfile (@$extra){ push @m, "\tcat $catfile >> \$\@\n"; } # SUNOS ld does not take the full path to a shared library my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl'; # Brain dead solaris linker does not use LD_RUN_PATH? # This fixes dynamic extensions which need shared libs my $ldfrom = ($^O eq 'solaris')? join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):''; push @m, " \$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS) $self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call' $self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)' $self->{NOECHO}echo 'To remove the intermediate files say' $self->{NOECHO}echo ' make -f $makefilename map_clean' $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c "; push @m, "\tcd $tmp && $cccmd -I\$(PERL_INC) perlmain.c\n"; push @m, qq{ $tmp/perlmain.c: $makefilename}, q{ }.$self->{NOECHO}.q{echo Writing $@ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\ - -e "writemain(grep s#.*/auto/##, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@ + -e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@ }; push @m, "\t",$self->{NOECHO}.q{$(PERL) $(INSTALLSCRIPT)/fixpmain } if (defined (&Dos::UseLFN) && Dos::UseLFN()==0); 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)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ MAP_LIBPERL "$(MAP_LIBPERL)" \ >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{ }; push @m, q{ inst_perl: pure_inst_perl doc_inst_perl pure_inst_perl: $(MAP_TARGET) }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(INSTALLBIN)','$(MAP_TARGET)').q{ clean :: map_clean map_clean : }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all }; join '', @m; } =item makefile (o) Defines how to rewrite the Makefile. =cut sub makefile { my($self) = shift; my @m; # We do not know what target was originally specified so we # must force a manual rerun to be sure. But as it should only # happen very rarely it is not a significant problem. push @m, ' $(OBJECT) : $(FIRST_MAKEFILE) ' if $self->{OBJECT}; push @m, q{ # We take a very conservative approach here, but it\'s worth it. # We move Makefile to Makefile.old here to avoid gnu make looping. }.$self->{MAKEFILE}.q{ : Makefile.PL $(CONFIGDEP) }.$self->{NOECHO}.q{echo "Makefile out-of-date with respect to $?" }.$self->{NOECHO}.q{echo "Cleaning current config before rebuilding Makefile..." -}.$self->{NOECHO}.q{$(RM_F) }."$self->{MAKEFILE}.old".q{ -}.$self->{NOECHO}.q{$(MV) }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{ -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean $(DEV_NULL) || $(NOOP) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{ }.$self->{NOECHO}.q{echo "==> Your Makefile has been rebuilt. <==" }.$self->{NOECHO}.q{echo "==> Please rerun the make command. <==" false # To change behavior to :: would be nice, but would break Tk b9.02 # so you find such a warning below the dist target. #}.$self->{MAKEFILE}.q{ :: $(VERSION_FROM) # }.$self->{NOECHO}.q{echo "Warning: Makefile possibly out of date with $(VERSION_FROM)" }; join "", @m; } =item manifypods (o) Defines targets and routines to translate the pods into manpages and put them into the INST_* directories. =cut sub manifypods { my($self, %attribs) = @_; return "\nmanifypods : pure_all\n\t$self->{NOECHO}\$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}}; my($dist); my($pod2man_exe); if (defined $self->{PERL_SRC}) { $pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man'); } else { $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man'); } - unless ($self->perl_script($pod2man_exe)) { + 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)) { # No pod2man but some MAN3PODS to be installed print <{MAKEFILE}, q[";' \\ -e 'print "Manifying $$m{$$_}\n";' \\ -e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2MAN_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, "\nmanifypods : pure_all "; push @m, join " \\\n\t", keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}; push(@m,"\n"); if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) { push @m, "\t$self->{NOECHO}\$(POD2MAN) \\\n\t"; push @m, join " \\\n\t", %{$self->{MAN1PODS}}, %{$self->{MAN3PODS}}; } join('', @m); } =item maybe_command Returns true, if the argument is likely to be a command. =cut sub maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d $file; return; } =item maybe_command_in_dirs method under development. Not yet used. Ask Ilya :-) =cut sub maybe_command_in_dirs { # $ver is optional argument if looking for perl # Ilya's suggestion. Not yet used, want to understand it first, but at least the code is here my($self, $names, $dirs, $trace, $ver) = @_; my($name, $dir); foreach $dir (@$dirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined foreach $name (@$names){ my($abs,$tryabs); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # bar $abs = $self->catfile($dir, $name); } else { # foo/bar $abs = $self->catfile($self->curdir, $name); } print "Checking $abs for $name\n" if ($trace >= 2); next unless $tryabs = $self->maybe_command($abs); print "Substituting $tryabs instead of $abs\n" if ($trace >= 2 and $tryabs ne $abs); $abs = $tryabs; if (defined $ver) { print "Executing $abs\n" if ($trace >= 2); if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) { print "Using PERL=$abs\n" if $trace; return $abs; } } else { # Do not look for perl return $abs; } } } } =item needs_linking (o) Does this module need linking? Looks into subdirectory objects (see also has_link_code()) =cut sub needs_linking { my($self) = shift; my($child,$caller); $caller = (caller(0))[3]; Carp::confess("Needs_linking called too early") if $caller =~ /^ExtUtils::MakeMaker::/; return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING}; if ($self->has_link_code or $self->{MAKEAPERL}){ $self->{NEEDS_LINKING} = 1; return 1; } foreach $child (keys %{$self->{CHILDREN}}) { if ($self->{CHILDREN}->{$child}->needs_linking) { $self->{NEEDS_LINKING} = 1; return 1; } } return $self->{NEEDS_LINKING} = 0; } =item nicetext misnamed method (will have to be changed). The MM_Unix method just returns the argument without further processing. On VMS used to insure that colons marking targets are preceded by space - most Unix Makes don't need this, but it's necessary under VMS to distinguish the target delimiter from a colon appearing as part of a filespec. =cut sub nicetext { my($self,$text) = @_; $text; } =item parse_version -parse a file and return what you think is $VERSION in this file set to +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. =cut sub parse_version { my($self,$parsefile) = @_; my $result; local *FH; local $/ = "\n"; open(FH,$parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; while () { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod; chop; # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/; my $eval = qq{ package ExtUtils::MakeMaker::_version; no strict; local $1$2; \$$2=undef; do { $_ }; \$$2 }; - local($^W) = 0; + no warnings; $result = eval($eval); - die "Could not eval '$eval' in $parsefile: $@" if $@; + warn "Could not eval '$eval' in $parsefile: $@" if $@; $result = "undef" unless defined $result; last; } close FH; return $result; } =item parse_abstract parse a file and return what you think is the ABSTRACT =cut sub parse_abstract { my($self,$parsefile) = @_; my $result; local *FH; local $/ = "\n"; open(FH,$parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; my $package = $self->{DISTNAME}; - $package =~ s/-/::/; + $package =~ s/-/::/g; while () { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if !$inpod; chop; next unless /^($package\s-\s)(.*)/; $result = $2; last; } close FH; return $result; } =item pasthru (o) Defines the string that is passed to recursive make calls in subdirectories. =cut sub pasthru { my($self) = shift; my(@m,$key); my(@pasthru); my($sep) = $Is_VMS ? ',' : ''; $sep .= "\\\n\t"; foreach $key (qw(LIB LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){ push @pasthru, "$key=\"\$($key)\""; } push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; join "", @m; } =item path Takes no argument, returns the environment variable PATH as an array. =cut sub path { my($self) = @_; my $path_sep = ($Is_OS2 || $Is_Dos) ? ";" : ":"; my $path = $ENV{PATH}; $path =~ s:\\:/:g if $Is_OS2; my @path = split $path_sep, $path; foreach(@path) { $_ = '.' if $_ eq '' } @path; } =item perl_script Takes one argument, a file name, and returns the file name, if the argument is likely to be a perl script. On MM_Unix this is true for any ordinary, readable file. =cut sub perl_script { my($self,$file) = @_; return $file if -r $file && -f _; return; } =item perldepend (o) Defines the dependency from all *.h files that come with the perl distribution. =cut sub perldepend { my($self) = shift; my(@m); push @m, q{ # Check for unpropogated config.sh changes. Should never happen. # We do NOT just update config.h because that is not sufficient. # An out of date config.h is not fatal but complains loudly! $(PERL_INC)/config.h: $(PERL_SRC)/config.sh -}.$self->{NOECHO}.q{echo "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; false $(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh }.$self->{NOECHO}.q{echo "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" cd $(PERL_SRC) && $(MAKE) lib/Config.pm } if $self->{PERL_SRC}; return join "", @m unless $self->needs_linking; push @m, q{ PERL_HDRS = \ -$(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 + $(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 $(OBJECT) : $(PERL_HDRS) } if $self->{OBJECT}; push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}}; join "\n", @m; } =item ppd Defines target that creates a PPD (Perl Package Description) file for a binary distribution. =cut sub ppd { my($self) = @_; my(@m); if ($self->{ABSTRACT_FROM}){ $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or Carp::carp "WARNING: Setting ABSTRACT via file '$self->{ABSTRACT_FROM}' failed\n"; } my ($pack_ver) = join ",", (split (/\./, $self->{VERSION}), (0) x 4) [0 .. 3]; push(@m, "# Creates a PPD (Perl Package Description) for a binary distribution.\n"); push(@m, "ppd:\n"); push(@m, "\t\@\$(PERL) -e \"print qq{{DISTNAME}\\\" VERSION=\\\"$pack_ver\\\">\\n}"); push(@m, ". qq{\\t$self->{DISTNAME}\\n}"); my $abstract = $self->{ABSTRACT}; $abstract =~ s/\n/\\n/sg; $abstract =~ s//>/g; push(@m, ". qq{\\t$abstract\\n}"); my ($author) = $self->{AUTHOR}; $author =~ s//>/g; $author =~ s/@/\\@/g; push(@m, ". qq{\\t$author\\n}"); push(@m, ". qq{\\t\\n}"); my ($prereq); foreach $prereq (sort keys %{$self->{PREREQ_PM}}) { my $pre_req = $prereq; $pre_req =~ s/::/-/g; my ($dep_ver) = join ",", (split (/\./, $self->{PREREQ_PM}{$prereq}), (0) x 4) [0 .. 3]; push(@m, ". qq{\\t\\t\\n}"); } push(@m, ". qq{\\t\\t\\n}"); push(@m, ". qq{\\t\\t\\n}"); my ($bin_location) = $self->{BINARY_LOCATION}; $bin_location =~ s/\\/\\\\/g; if ($self->{PPM_INSTALL_SCRIPT}) { if ($self->{PPM_INSTALL_EXEC}) { push(@m, " . qq{\\t\\t{PPM_INSTALL_EXEC}\\\">$self->{PPM_INSTALL_SCRIPT}\\n}"); } else { push(@m, " . qq{\\t\\t$self->{PPM_INSTALL_SCRIPT}\\n}"); } } push(@m, ". qq{\\t\\t\\n}"); push(@m, ". qq{\\t\\n}"); push(@m, ". qq{\\n}\" > $self->{DISTNAME}.ppd"); join("", @m); } =item perm_rw (o) Returns the attribute C or the string C<644>. Used as the string that is passed to the C command to set the permissions for read/writeable files. MakeMaker chooses C<644> because it has turned out in the past that relying on the umask provokes hard-to-track bug reports. When the return value is used by the perl function C, it is interpreted as an octal value. =cut sub perm_rw { shift->{PERM_RW} || "644"; } =item perm_rwx (o) Returns the attribute C or the string C<755>, i.e. the string that is passed to the C command to set the permissions for executable files. See also perl_rw. =cut sub perm_rwx { shift->{PERM_RWX} || "755"; } =item pm_to_blib Defines target that copies all files in the hash PM to their destination and autosplits them. See L =cut sub pm_to_blib { my $self = shift; my($autodir) = $self->catdir('$(INST_LIB)','auto'); return q{ pm_to_blib: $(TO_INST_PM) }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \ -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')" }.$self->{NOECHO}.q{$(TOUCH) $@ }; } =item post_constants (o) Returns an empty string per default. Dedicated to overrides from within Makefile.PL after all constants have been defined. =cut sub post_constants{ my($self) = shift; ""; } =item post_initialize (o) Returns an empty string per default. Used in Makefile.PLs to add some chunk of text to the Makefile after the object is initialized. =cut sub post_initialize { my($self) = shift; ""; } =item postamble (o) Returns an empty string. Can be used in Makefile.PLs to write some text to the Makefile at the end. =cut sub postamble { my($self) = shift; ""; } =item prefixify Check a path variable in $self from %Config, if it contains a prefix, and replace it with another one. Takes as arguments an attribute name, a search prefix and a replacement prefix. Changes the attribute in the object. =cut 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/; + $self->{uc $var} =~ s/\Q$sprefix\E/$rprefix/s; } =item processPL (o) Defines targets to run *.PL files. =cut sub processPL { my($self) = shift; return "" unless $self->{PL_FILES}; my(@m, $plfile); foreach $plfile (sort keys %{$self->{PL_FILES}}) { my $list = ref($self->{PL_FILES}->{$plfile}) ? $self->{PL_FILES}->{$plfile} : [$self->{PL_FILES}->{$plfile}]; foreach $target (@$list) { push @m, " all :: $target $self->{NOECHO}\$(NOOP) $target :: $plfile \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile $target "; } } join "", @m; } =item realclean (o) Defines the realclean target. =cut sub realclean { my($self, %attribs) = @_; my(@m); push(@m,' # Delete temporary files (via clean) and also delete installed files realclean purge :: clean '); # realclean subdirectories first (already cleaned) - my $sub = "\t-cd %s && \$(TEST_F) %s && \$(MAKE) %s realclean\n"; + 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"; foreach(@{$self->{DIR}}){ push(@m, sprintf($sub,$_,"$self->{MAKEFILE}.old","-f $self->{MAKEFILE}.old")); push(@m, sprintf($sub,$_,"$self->{MAKEFILE}",'')); } push(@m, " $self->{RM_RF} \$(INST_AUTODIR) \$(INST_ARCHAUTODIR)\n"); if( $self->has_link_code ){ push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n"); push(@m, " $self->{RM_F} \$(INST_STATIC)\n"); } push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n") if keys %{$self->{PM}}; my(@otherfiles) = ($self->{MAKEFILE}, "$self->{MAKEFILE}.old"); # Makefiles last push(@otherfiles, $attribs{FILES}) if $attribs{FILES}; push(@m, " $self->{RM_RF} @otherfiles\n") if @otherfiles; push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP}; join("", @m); } =item replace_manpage_separator Takes the name of a package, which may be a nested package, in the form Foo/Bar and replaces the slash with C<::>. Returns the replacement. =cut sub replace_manpage_separator { my($self,$man) = @_; if ($^O eq 'uwin') { $man =~ s,/+,.,g; } else { $man =~ s,/+,::,g; } $man; } =item static (o) Defines the static target. =cut sub static { # --- Static Loading Sections --- my($self) = shift; ' ## $(INST_PM) has been moved to the all: target. ## It remains here for awhile to allow for old usage: "make static" #static :: '.$self->{MAKEFILE}.' $(INST_STATIC) $(INST_PM) static :: '.$self->{MAKEFILE}.' $(INST_STATIC) '.$self->{NOECHO}.'$(NOOP) '; } =item static_lib (o) Defines how to produce the *.a (or equivalent) files. =cut sub static_lib { my($self) = @_; # Come to think of it, if there are subdirs with linkcode, we still have no INST_STATIC # return '' unless $self->needs_linking(); #might be because of a subdir return '' unless $self->has_link_code; my(@m); push(@m, <<'END'); $(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists $(RM_RF) $@ END # If this extension has it's own library (eg SDBM_File) # 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, -q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ - $(CHMOD) $(PERM_RWX) $@ + "\t\$($ar) ".'$(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@'."\n"; + push @m, +q{ $(CHMOD) $(PERM_RWX) $@ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld }; # Old mechanism - still available: push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs } if $self->{PERL_SRC} && $self->{EXTRALIBS}; push @m, "\n"; push @m, $self->dir_target('$(INST_ARCHAUTODIR)'); join('', "\n",@m); } =item staticmake (o) Calls makeaperl. =cut sub staticmake { my($self, %attribs) = @_; my(@static); my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB}); # And as it's not yet built, we add the current extension # but only if it has some C code (or XS code, which implies C code) if (@{$self->{C}}) { @static = $self->catfile($self->{INST_ARCHLIB}, "auto", $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" ); } # Either we determine now, which libraries we will produce in the # subdirectories or we do it at runtime of the make. # We could ask all subdir objects, but I cannot imagine, why it # would be necessary. # Instead we determine all libraries for the new perl at # runtime. my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB}); $self->makeaperl(MAKE => $self->{MAKEFILE}, DIRS => \@searchdirs, STAT => \@static, INCL => \@perlinc, TARGET => $self->{MAP_TARGET}, TMP => "", LIBPERL => $self->{LIBPERL_A} ); } =item subdir_x (o) Helper subroutine for subdirs =cut sub subdir_x { my($self, $subdir) = @_; my(@m); - qq{ + if ($Is_Win32 && Win32::IsWin95()) { + # XXX: dmake-specific, like rest of Win95 port + return <{NOECHO}cd $subdir && \$(MAKE) all \$(PASTHRU) -}; +EOT + } } =item subdirs (o) Defines targets to process subdirectories. =cut sub subdirs { # --- Sub-directory Sections --- my($self) = shift; my(@m,$dir); # This method provides a mechanism to automatically deal with # subdirectories containing further Makefile.PL scripts. # It calls the subdir_x() method for each subdirectory. foreach $dir (@{$self->{DIR}}){ push(@m, $self->subdir_x($dir)); #### print "Including $dir subdirectory\n"; } if (@m){ unshift(@m, " # The default clean, realclean and test targets in this Makefile # have automatically been given entries for each subdir. "); } else { push(@m, "\n# none") } join('',@m); } =item test (o) Defines the test targets. =cut sub test { # --- Test and Installation Sections --- my($self, %attribs) = @_; my $tests = $attribs{TESTS}; if (!$tests && -d 't') { $tests = $Is_Win32 ? join(' ', ) : 't/*.t'; } # note: 'test.pl' name is also hardcoded in init_dirscan() my(@m); push(@m," TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) TEST_FILE = test.pl TEST_FILES = $tests TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) test :: \$(TEST_TYPE) "); push(@m, map("\t$self->{NOECHO}cd $_ && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) test \$(PASTHRU)\n", @{$self->{DIR}})); push(@m, "\t$self->{NOECHO}echo 'No tests defined for \$(NAME) extension.'\n") unless $tests or -f "test.pl" or @{$self->{DIR}}; push(@m, "\n"); push(@m, "test_dynamic :: pure_all\n"); push(@m, $self->test_via_harness('$(FULLPERL)', '$(TEST_FILES)')) if $tests; push(@m, $self->test_via_script('$(FULLPERL)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_dynamic :: pure_all\n"); push(@m, $self->test_via_script('$(FULLPERL) $(TESTDB_SW)', '$(TEST_FILE)')); push(@m, "\n"); # Occasionally we may face this degenerate target: push @m, "test_ : test_dynamic\n\n"; if ($self->needs_linking()) { push(@m, "test_static :: pure_all \$(MAP_TARGET)\n"); push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests; push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl"; push(@m, "\n"); push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n"); push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)')); push(@m, "\n"); } else { push @m, "test_static :: test_dynamic\n"; push @m, "testdb_static :: testdb_dynamic\n"; } join("", @m); } =item test_via_harness (o) Helper method to write the test targets =cut sub test_via_harness { my($self, $perl, $tests) = @_; $perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32; "\t$perl".q! -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' !."$tests\n"; } =item test_via_script (o) Other helper method for test. =cut sub test_via_script { my($self, $perl, $script) = @_; $perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32; qq{\t$perl}.q{ -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) }.qq{$script }; } =item tool_autosplit (o) Defines a simple perl call that runs autosplit. May be deprecated by pm_to_blib soon. =cut sub tool_autosplit { # --- Tool Sections --- my($self, %attribs) = @_; my($asl) = ""; $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN}; q{ # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e 'use AutoSplit;}.$asl.q{autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) ;' }; } =item tools_other (o) Defines SHELL, LD, TOUCH, CP, MV, RM_F, RM_RF, CHMOD, UMASK_NULL in the Makefile. Also defines the perl programs MKPATH, WARN_IF_OLD_PACKLIST, MOD_INSTALL. DOC_INSTALL, and UNINSTALL. =cut sub tools_other { my($self) = shift; my @m; my $bin_sh = $Config{sh} || '/bin/sh'; push @m, qq{ SHELL = $bin_sh }; for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) { push @m, "$_ = $self->{$_}\n"; } push @m, q{ # The following is a portable way to say mkdir -p # To see which directories are created, change the if 0 to if 1 MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath # This helps us to minimize the effect of the .exists files A yet # better solution would be to have a stable file in the perl # distribution with a timestamp of zero. But this solution doesn't # need any changes to the core distribution and works with older perls EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime }; return join "", @m if $self->{PARENT}; push @m, q{ # Here we warn users that an old packlist file was found somewhere, # and that they should call some uninstall routine WARN_IF_OLD_PACKLIST = $(PERL) -we 'exit unless -f $$ARGV[0];' \\ -e 'print "WARNING: I have found an old package in\n";' \\ -e 'print "\t$$ARGV[0].\n";' \\ -e 'print "Please make sure the two installations are not conflicting\n";' UNINST=0 VERBINST=1 MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \ -e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');" DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \ -e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \ -e 'print "=over 4";' \ -e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \ -e 'print "=back";' UNINSTALL = $(PERL) -MExtUtils::Install \ -e 'uninstall($$ARGV[0],1,1); print "\nUninstall is deprecated. Please check the";' \ -e 'print " packlist above carefully.\n There may be errors. Remove the";' \ -e 'print " appropriate files manually.\n Sorry for the inconveniences.\n"' }; return join "", @m; } =item tool_xsubpp (o) Determines typemaps, xsubpp version, prototype behaviour. =cut sub tool_xsubpp { my($self) = shift; return "" unless $self->needs_linking; my($xsdir) = $self->catdir($self->{PERL_LIB},"ExtUtils"); my(@tmdeps) = $self->catdir('$(XSUBPPDIR)','typemap'); if( $self->{TYPEMAPS} ){ my $typemap; foreach $typemap (@{$self->{TYPEMAPS}}){ if( ! -f $typemap ){ warn "Typemap $typemap not found.\n"; } else{ push(@tmdeps, $typemap); } } } push(@tmdeps, "typemap") if -f "typemap"; my(@tmargs) = map("-typemap $_", @tmdeps); if( exists $self->{XSOPT} ){ unshift( @tmargs, $self->{XSOPT} ); } my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,"xsubpp")); # What are the correct thresholds for version 1 && 2 Paul? if ( $xsubpp_version > 1.923 ){ $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG}; } else { if (defined $self->{XSPROTOARG} && $self->{XSPROTOARG} =~ /\-prototypes/) { print STDOUT qq{Warning: This extension wants to pass the switch "-prototypes" to xsubpp. Your version of xsubpp is $xsubpp_version and cannot handle this. Please upgrade to a more recent version of xsubpp. }; } else { $self->{XSPROTOARG} = ""; } } - my $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp"; + my $xsubpp = "xsubpp"; return qq{ XSUBPPDIR = $xsdir XSUBPP = \$(XSUBPPDIR)/$xsubpp XSPROTOARG = $self->{XSPROTOARG} -XSUBPPDEPS = @tmdeps +XSUBPPDEPS = @tmdeps \$(XSUBPP) XSUBPPARGS = @tmargs }; }; sub xsubpp_version { my($self,$xsubpp) = @_; return $Xsubpp_Version if defined $Xsubpp_Version; # global variable my ($version) ; # try to figure out the version number of the xsubpp on the system # first try the -v flag, introduced in 1.921 & 2.000a2 return "" unless $self->needs_linking; my $command = "$self->{PERL} -I$self->{PERL_LIB} $xsubpp -v 2>&1"; print "Running $command\n" if $Verbose >= 2; $version = `$command` ; warn "Running '$command' exits with status " . ($?>>8) if $?; chop $version ; return $Xsubpp_Version = $1 if $version =~ /^xsubpp version (.*)/ ; # nope, then try something else my $counter = '000'; my ($file) = 'temp' ; $counter++ while -e "$file$counter"; # don't overwrite anything $file .= $counter; open(F, ">$file") or die "Cannot open file '$file': $!\n" ; print F <= 2; my $text = `$command` ; warn "Running '$command' exits with status " . ($?>>8) if $?; unlink $file ; # gets 1.2 -> 1.92 and 2.000a1 return $Xsubpp_Version = $1 if $text =~ /automatically by xsubpp version ([\S]+)\s*/ ; # it is either 1.0 or 1.1 return $Xsubpp_Version = 1.1 if $text =~ /^Warning: ignored semicolon/ ; # none of the above, so 1.0 return $Xsubpp_Version = "1.0" ; } =item top_targets (o) Defines the targets all, subdirs, config, and O_FILES =cut sub top_targets { # --- Target Sections --- my($self) = shift; my(@m); push @m, ' #all :: config $(INST_PM) subdirs linkext manifypods '; push @m, ' -all :: pure_all manifypods +all :: pure_all htmlifypods manifypods '.$self->{NOECHO}.'$(NOOP) ' unless $self->{SKIPHASH}{'all'}; push @m, ' pure_all :: config pm_to_blib subdirs linkext '.$self->{NOECHO}.'$(NOOP) subdirs :: $(MYEXTLIB) '.$self->{NOECHO}.'$(NOOP) config :: '.$self->{MAKEFILE}.' $(INST_LIBDIR)/.exists '.$self->{NOECHO}.'$(NOOP) config :: $(INST_ARCHAUTODIR)/.exists '.$self->{NOECHO}.'$(NOOP) config :: $(INST_AUTODIR)/.exists '.$self->{NOECHO}.'$(NOOP) '; - push @m, qq{ -config :: Version_check + push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); + + if (%{$self->{HTMLLIBPODS}}) { + push @m, qq[ +config :: \$(INST_HTMLLIBDIR)/.exists $self->{NOECHO}\$(NOOP) -} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC}; +]; + push @m, $self->dir_target(qw[$(INST_HTMLLIBDIR)]); + } - push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]); + if (%{$self->{HTMLSCRIPTPODS}}) { + push @m, qq[ +config :: \$(INST_HTMLSCRIPTDIR)/.exists + $self->{NOECHO}\$(NOOP) +]; + push @m, $self->dir_target(qw[$(INST_HTMLSCRIPTDIR)]); + } + if (%{$self->{MAN1PODS}}) { push @m, qq[ config :: \$(INST_MAN1DIR)/.exists $self->{NOECHO}\$(NOOP) ]; push @m, $self->dir_target(qw[$(INST_MAN1DIR)]); } if (%{$self->{MAN3PODS}}) { push @m, qq[ config :: \$(INST_MAN3DIR)/.exists $self->{NOECHO}\$(NOOP) ]; push @m, $self->dir_target(qw[$(INST_MAN3DIR)]); } push @m, ' $(O_FILES): $(H_FILES) ' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; push @m, q{ help: perldoc ExtUtils::MakeMaker }; push @m, q{ Version_check: }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \ -MExtUtils::MakeMaker=Version_check \ -e "Version_check('$(MM_VERSION)')" }; join('',@m); } =item writedoc Obsolete, deprecated method. Not used since Version 5.21. =cut sub writedoc { # --- perllocal.pod section --- my($self,$what,$name,@attribs)=@_; my $time = localtime; print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n"; print join "\n\n=item *\n\n", map("C<$_>",@attribs); print "\n\n=back\n\n"; } =item xs_c (o) Defines the suffix rules to compile XS files to C. =cut sub xs_c { my($self) = shift; return '' unless $self->needs_linking(); ' .xs.c: - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c '; } =item xs_cpp (o) Defines the suffix rules to compile XS files to C++. =cut sub xs_cpp { my($self) = shift; return '' unless $self->needs_linking(); ' .xs.cpp: - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.cpp + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp '; } =item xs_o (o) Defines suffix rules to go from XS to object files directly. This is only intended for broken make implementations. =cut sub xs_o { # many makes are too dumb to use xs_c then c_o my($self) = shift; return '' unless $self->needs_linking(); ' .xs$(OBJ_EXT): - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c + $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c '; } =item perl_archive This is internal method that returns path to libperl.a equivalent to be linked to dynamic extensions. UNIX does not have one but OS2 and Win32 do. =cut sub perl_archive { return '$(PERL_INC)' . "/$Config{libperl}" if $^O eq "beos"; return ""; } =item export_list This is internal method that returns name of a file that is passed to linker to define symbols to be exported. UNIX does not have one but OS2 and Win32 do. =cut sub export_list { return ""; } 1; =back =head1 SEE ALSO L =cut __END__ Index: head/contrib/perl5/lib/ExtUtils/MakeMaker.pm =================================================================== --- head/contrib/perl5/lib/ExtUtils/MakeMaker.pm (revision 62079) +++ head/contrib/perl5/lib/ExtUtils/MakeMaker.pm (revision 62080) @@ -1,1989 +1,2041 @@ # $FreeBSD$ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatible with perl5.001m package ExtUtils::MakeMaker; -$VERSION = "5.4302"; +$VERSION = "5.45"; $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+$//; require Exporter; use Config; use Carp (); #use FileHandle (); use vars qw( @ISA @EXPORT @EXPORT_OK $AUTOLOAD - $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $Setup_done + $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $VERSION $Verbose $Version_OK %Config %Keep_after_flush %MM_Sections %Prepend_dot_dot %Recognized_Att_Keys @Get_from_Config @MM_Sections @Overridable @Parent ); # use strict; # &DynaLoader::mod2fname should be available to miniperl, thus # should be a pseudo-builtin (cmp. os2.c). #eval {require DynaLoader;}; # # Set up the inheritance before we pull in the MM_* packages, because they # import variables and functions from here # @ISA = qw(Exporter); @EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt); @EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists); # # Dummy package MM inherits actual methods from OS-specific # default packages. We use this intermediate package so # MY::XYZ->func() can call MM->func() and get the proper # default routine without having to know under what OS # it's running. # @MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist ExtUtils::MakeMaker]; # # Setup dummy package: # MY exists for overriding methods to be defined within # { package MY; @MY::ISA = qw(MM); ### sub AUTOLOAD { use Devel::Symdump; print Devel::Symdump->rnew->as_string; Carp::confess "hey why? $AUTOLOAD" } package MM; sub DESTROY {} } # "predeclare the package: we only load it via AUTOLOAD # but we have already mentioned it in @ISA package ExtUtils::Liblist; package ExtUtils::MakeMaker; # # Now we can pull in the friends # $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; if ($Is_VMS) { require ExtUtils::MM_VMS; require VMS::Filespec; # is a noop as long as we require it within MM_VMS } if ($Is_OS2) { require ExtUtils::MM_OS2; } if ($Is_Mac) { require ExtUtils::MM_Mac; } if ($Is_Win32) { require ExtUtils::MM_Win32; } - -# 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 = ; - $/ = $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; +if ($Is_Cygwin) { + require ExtUtils::MM_Cygwin; } -# 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 :-( +full_setup(); +# 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. + sub Version_check { my($checkversion) = @_; die "Your Makefile was built with ExtUtils::MakeMaker v $checkversion. Current Version is $ExtUtils::MakeMaker::VERSION. There have been considerable changes in the meantime. Please rerun 'perl Makefile.PL' to regenerate the Makefile.\n" if $checkversion < $Version_OK; printf STDOUT "%s %s %s %s.\n", "Makefile built with ExtUtils::MakeMaker v", $checkversion, "Current Version is", $VERSION unless $checkversion == $VERSION; } sub warnhandler { $_[0] =~ /^Use of uninitialized value/ && return; $_[0] =~ /used only once/ && return; $_[0] =~ /^Subroutine\s+[\w:]+\s+redefined/ && return; 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; } sub prompt ($;$) { my($mess,$def)=@_; $ISA_TTY = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? Carp::confess("prompt function called without an argument") unless defined $mess; my $dispdef = defined $def ? "[$def] " : " "; $def = defined $def ? $def : ""; my $ans; local $|=1; print "$mess $dispdef"; if ($ISA_TTY) { chomp($ans = ); } else { print "$def\n"; } return ($ans ne '') ? $ans : $def; } sub eval_in_subdirs { my($self) = @_; my($dir); use Cwd 'cwd'; my $pwd = cwd(); foreach $dir (@{$self->{DIR}}){ my($abs) = $self->catdir($pwd,$dir); $self->eval_in_x($abs); } chdir $pwd; } sub eval_in_x { my($self,$dir) = @_; package main; chdir $dir or Carp::carp("Couldn't change to directory $dir: $!"); # use FileHandle (); # my $fh = new FileHandle; # $fh->open("Makefile.PL") or Carp::carp("Couldn't open Makefile.PL in $dir"); local *FH; open(FH,"Makefile.PL") or Carp::carp("Couldn't open Makefile.PL in $dir"); # my $eval = join "", <$fh>; my $eval = join "", ; # $fh->close; close FH; eval $eval; if ($@) { # if ($@ =~ /prerequisites/) { # die "MakeMaker WARNING: $@"; # } else { # warn "WARNING from evaluation of $dir/Makefile.PL: $@"; # } warn "WARNING from evaluation of $dir/Makefile.PL: $@"; } } sub full_setup { $Verbose ||= 0; - $^W=1; # package name for the classes into which the first object will be blessed $PACKNAME = "PACK000"; @Attrib_help = qw/ 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 IMPORTS - INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERL FUNCLIST H + HTMLLIBPODS HTMLSCRIPTPOD IMPORTS + INC INCLUDE_EXT INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLHTMLPRIVLIBDIR + INSTALLHTMLSCRIPTDIR INSTALLHTMLSITELIBDIR 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 PPM_INSTALL_EXEC PPM_INSTALL_SCRIPT PREFIX + PL_FILES PM PMLIBDIRS POLLUTE 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 /; # IMPORTS is used under OS/2 and Win32 # @Overridable is close to @MM_Sections but not identical. The # order is important. Many subroutines declare macros. These # depend on each other. Let's try to collect the macros up front, # then pasthru, then the rules. # MM_Sections are the sections we have to call explicitly # in Overridable we have subroutines that are used indirectly @MM_Sections = qw( post_initialize const_config constants tool_autosplit tool_xsubpp tools_other dist macro depend cflags const_loadlibs const_cccmd post_constants pasthru c_o xs_c xs_o top_targets linkext dlsyms dynamic dynamic_bs - dynamic_lib static static_lib manifypods processPL installbin subdirs + dynamic_lib static static_lib htmlifypods manifypods processPL + installbin subdirs clean realclean dist_basics dist_core dist_dir dist_test dist_ci install force perldepend makefile staticmake test ppd ); # loses section ordering @Overridable = @MM_Sections; push @Overridable, qw[ dir_target libscan makeaperl needs_linking perm_rw perm_rwx subdir_x test_via_harness test_via_script ]; push @MM_Sections, qw[ pm_to_blib selfdocument ]; # Postamble needs to be the last that was always the case push @MM_Sections, "postamble"; push @Overridable, "postamble"; # All sections are valid keys. @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections; # we will use all these variables in the Makefile @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 + lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so + exe_ext full_ar ); my $item; foreach $item (@Attrib_help){ $Recognized_Att_Keys{$item} = 1; } foreach $item (@Get_from_Config) { $Recognized_Att_Keys{uc $item} = $Config{$item}; print "Attribute '\U$item\E' => '$Config{$item}'\n" if ($Verbose >= 2); } # # When we eval a Makefile.PL in a subdirectory, that one will ask # us (the parent) for the values and will prepend "..", so that # all files to be installed end up below OUR ./blib # %Prepend_dot_dot = qw( - 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 + 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 ); my @keep = qw/ NEEDS_LINKING HAS_LINK_CODE /; @Keep_after_flush{@keep} = (1) x @keep; } sub writeMakefile { die <{PREREQ_PM}}) { - my $eval = "use $prereq $self->{PREREQ_PM}->{$prereq}"; + my $eval = "require $prereq"; eval $eval; - if ($@){ + + if ($@) { + warn "Warning: prerequisite $prereq failed to load: $@"; + } + elsif ($prereq->VERSION < $self->{PREREQ_PM}->{$prereq} ){ 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 { # delete $self->{PREREQ_PM}{$prereq}; } } # if (@unsatisfied){ # unless (defined $ExtUtils::MakeMaker::useCPAN) { # print qq{MakeMaker WARNING: prerequisites not found (@unsatisfied) # Please install these modules first and rerun 'perl Makefile.PL'.\n}; # if ($ExtUtils::MakeMaker::hasCPAN) { # $ExtUtils::MakeMaker::useCPAN = prompt(qq{Should I try to use the CPAN module to fetch them for you?},"yes"); # } else { # print qq{Hint: You may want to install the CPAN module to autofetch the needed modules\n}; # $ExtUtils::MakeMaker::useCPAN=0; # } # } # if ($ExtUtils::MakeMaker::useCPAN) { # require CPAN; # CPAN->import(@unsatisfied); # } else { # die qq{prerequisites not found (@unsatisfied)}; # } # warn qq{WARNING: prerequisites not found (@unsatisfied)}; # } if (defined $self->{CONFIGURE}) { if (ref $self->{CONFIGURE} eq 'CODE') { $self = { %$self, %{&{$self->{CONFIGURE}}}}; } else { Carp::croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n"; } } # This is for old Makefiles written pre 5.00, will go away if ( Carp::longmess("") =~ /runsubdirpl/s ){ Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n"); } my $newclass = ++$PACKNAME; local @Parent = @Parent; # Protect against non-local exits { # no strict; print "Blessing Object into class [$newclass]\n" if $Verbose>=2; mv_all_methods("MY",$newclass); bless $self, $newclass; push @Parent, $self; @{"$newclass\:\:ISA"} = 'MM'; } if (defined $Parent[-2]){ $self->{PARENT} = $Parent[-2]; my $key; for $key (keys %Prepend_dot_dot) { next unless defined $self->{PARENT}{$key}; $self->{$key} = $self->{PARENT}{$key}; # PERL and FULLPERL may be command verbs instead of full # file specifications under VMS. If so, don't turn them # into a filespec. $self->{$key} = $self->catdir("..",$self->{$key}) unless $self->file_name_is_absolute($self->{$key}) || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/)); } if ($self->{PARENT}) { $self->{PARENT}->{CHILDREN}->{$newclass} = $self; - if (exists $self->{PARENT}->{CAPI} - and not exists $self->{CAPI}) - { - # inherit, but only if already unspecified - $self->{CAPI} = $self->{PARENT}->{CAPI}; + 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}; + } } } } else { parse_args($self,split(' ', $ENV{PERL_MM_OPT} || ''),@ARGV); } $self->{NAME} ||= $self->guess_name; ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g; $self->init_main(); if (! $self->{PERL_SRC} ) { my($pthinks) = $self->canonpath($INC{'Config.pm'}); my($cthinks) = $self->catfile($Config{'archlibexp'},'Config.pm'); $pthinks = VMS::Filespec::vmsify($pthinks) if $Is_VMS; if ($pthinks ne $cthinks && !($Is_Win32 and lc($pthinks) eq lc($cthinks))) { print "Have $pthinks expected $cthinks\n"; if ($Is_Win32) { $pthinks =~ s![/\\]Config\.pm$!!i; $pthinks =~ s!.*[/\\]!!; } else { $pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!; } - print STDOUT <{UNINSTALLED_PERL}; Your perl and your Config.pm seem to have different ideas about the architecture they are running on. Perl thinks: [$pthinks] Config says: [$Config{archname}] This may or may not cause problems. Please check your installation of perl if you have problems building this extension. END } } $self->init_dirscan(); $self->init_others(); my($argv) = neatvalue(\@ARGV); $argv =~ s/^\[/(/; $argv =~ s/\]$/)/; push @{$self->{RESULT}}, <{NAME} extension to perl. # # It was generated automatically by MakeMaker version # $VERSION (Revision: $Revision) from the contents of # Makefile.PL. Don't edit this file, edit Makefile.PL instead. # # ANY CHANGES MADE HERE WILL BE LOST! # # MakeMaker ARGV: $argv # # MakeMaker Parameters: END foreach $key (sort keys %initial_att){ my($v) = neatvalue($initial_att{$key}); $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; $v =~ tr/\n/ /s; push @{$self->{RESULT}}, "# $key => $v"; } # turn the SKIP array into a SKIPHASH hash my (%skip,$skip); for $skip (@{$self->{SKIP} || []}) { $self->{SKIPHASH}{$skip} = 1; } delete $self->{SKIP}; # free memory if ($self->{PARENT}) { for (qw/install dist dist_basics dist_core dist_dir dist_test dist_ci/) { $self->{SKIPHASH}{$_} = 1; } } # We run all the subdirectories now. They don't have much to query # from the parent, but the parent has to query them: if they need linking! unless ($self->{NORECURS}) { $self->eval_in_subdirs if @{$self->{DIR}}; } my $section; foreach $section ( @MM_Sections ){ print "Processing Makefile '$section' section\n" if ($Verbose >= 2); my($skipit) = $self->skipcheck($section); if ($skipit){ push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit."; } else { my(%a) = %{$self->{$section} || {}}; push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:"; push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a; push @{$self->{RESULT}}, $self->nicetext($self->$section( %a )); } } push @{$self->{RESULT}}, "\n# End."; $self; } sub WriteEmptyMakefile { if (-f 'Makefile.old') { chmod 0666, 'Makefile.old'; unlink 'Makefile.old' or warn "unlink Makefile.old: $!"; } rename 'Makefile', 'Makefile.old' or warn "rename Makefile Makefile.old: $!" if -f 'Makefile'; open MF, '> Makefile' or die "open Makefile for write: $!"; print MF <<'EOP'; all: clean: install: makemakerdflt: test: EOP close MF or die "close Makefile for write: $!"; } sub check_manifest { print STDOUT "Checking if your kit is complete...\n"; require ExtUtils::Manifest; $ExtUtils::Manifest::Quiet=$ExtUtils::Manifest::Quiet=1; #avoid warning my(@missed)=ExtUtils::Manifest::manicheck(); if (@missed){ print STDOUT "Warning: the following files are missing in your kit:\n"; print "\t", join "\n\t", @missed; print STDOUT "\n"; print STDOUT "Please inform the author.\n"; } else { print STDOUT "Looks good\n"; } } sub parse_args{ my($self, @args) = @_; foreach (@args){ unless (m/(.*?)=(.*)/){ help(),exit 1 if m/^help$/; ++$Verbose if m/^verb/; next; } my($name, $value) = ($1, $2); if ($value =~ m/^~(\w+)?/){ # tilde with optional username $value =~ s [^~(\w*)] [$1 ? ((getpwnam($1))[7] || "~$1") : (getpwuid($>))[7] ]ex; } $self->{uc($name)} = $value; } # catch old-style 'potential_libs' and inform user how to 'upgrade' if (defined $self->{potential_libs}){ my($msg)="'potential_libs' => '$self->{potential_libs}' should be"; if ($self->{potential_libs}){ print STDOUT "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n"; } else { print STDOUT "$msg deleted.\n"; } $self->{LIBS} = [$self->{potential_libs}]; delete $self->{potential_libs}; } # catch old-style 'ARMAYBE' and inform user how to 'upgrade' if (defined $self->{ARMAYBE}){ my($armaybe) = $self->{ARMAYBE}; print STDOUT "ARMAYBE => '$armaybe' should be changed to:\n", "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n"; my(%dl) = %{$self->{dynamic_lib} || {}}; $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe}; delete $self->{ARMAYBE}; } if (defined $self->{LDTARGET}){ print STDOUT "LDTARGET should be changed to LDFROM\n"; $self->{LDFROM} = $self->{LDTARGET}; delete $self->{LDTARGET}; } # Turn a DIR argument on the command line into an array if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') { # So they can choose from the command line, which extensions they want # the grep enables them to have some colons too much in case they # have to build a list with the shell $self->{DIR} = [grep $_, split ":", $self->{DIR}]; } # Turn a INCLUDE_EXT argument on the command line into an array if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') { $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}]; } # Turn a EXCLUDE_EXT argument on the command line into an array if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') { $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}]; } my $mmkey; foreach $mmkey (sort keys %$self){ print STDOUT " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose; print STDOUT "'$mmkey' is not a known MakeMaker parameter name.\n" unless exists $Recognized_Att_Keys{$mmkey}; } $| = 1 if $Verbose; } sub check_hints { my($self) = @_; # We allow extension-specific hints files. return unless -d "hints"; # First we look for the best hintsfile we have my(@goodhints); my($hint)="${^O}_$Config{osvers}"; $hint =~ s/\./_/g; $hint =~ s/_$//; return unless $hint; # Also try without trailing minor version numbers. while (1) { last if -f "hints/$hint.pl"; # found } continue { last unless $hint =~ s/_[^_]*$//; # nothing to cut off } return unless -f "hints/$hint.pl"; # really there # execute the hintsfile: # use FileHandle (); # my $fh = new FileHandle; # $fh->open("hints/$hint.pl"); local *FH; open(FH,"hints/$hint.pl"); # @goodhints = <$fh>; @goodhints = ; # $fh->close; close FH; print STDOUT "Processing hints file hints/$hint.pl\n"; eval join('',@goodhints); print STDOUT $@ if $@; } sub mv_all_methods { my($from,$to) = @_; my($method); my($symtab) = \%{"${from}::"}; # no strict; # Here you see the *current* list of methods that are overridable # from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm # still trying to reduce the list to some reasonable minimum -- # because I want to make it easier for the user. A.K. foreach $method (@Overridable) { # We cannot say "next" here. Nick might call MY->makeaperl # which isn't defined right now # Above statement was written at 4.23 time when Tk-b8 was # around. As Tk-b9 only builds with 5.002something and MM 5 is # standard, we try to enable the next line again. It was # commented out until MM 5.23 next unless defined &{"${from}::$method"}; *{"${to}::$method"} = \&{"${from}::$method"}; # delete would do, if we were sure, nobody ever called # MY->makeaperl directly # delete $symtab->{$method}; # If we delete a method, then it will be undefined and cannot # be called. But as long as we have Makefile.PLs that rely on # %MY:: being intact, we have to fill the hole with an # inheriting method: eval "package MY; sub $method { shift->SUPER::$method(\@_); }"; } # We have to clean out %INC also, because the current directory is # changed frequently and Graham Barr prefers to get his version # out of a History.pl file which is "required" so woudn't get # loaded again in another extension requiring a History.pl # With perl5.002_01 the deletion of entries in %INC caused Tk-b11 # to core dump in the middle of a require statement. The required # file was Tk/MMutil.pm. The consequence is, we have to be # extremely careful when we try to give perl a reason to reload a # library with same name. The workaround prefers to drop nothing # from %INC and teach the writers not to use such libraries. # my $inc; # foreach $inc (keys %INC) { # #warn "***$inc*** deleted"; # delete $INC{$inc}; # } } sub skipcheck { my($self) = shift; my($section) = @_; if ($section eq 'dynamic') { print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ", "in skipped section 'dynamic_bs'\n" if $self->{SKIPHASH}{dynamic_bs} && $Verbose; print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ", "in skipped section 'dynamic_lib'\n" if $self->{SKIPHASH}{dynamic_lib} && $Verbose; } if ($section eq 'dynamic_lib') { print STDOUT "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ", "targets in skipped section 'dynamic_bs'\n" if $self->{SKIPHASH}{dynamic_bs} && $Verbose; } if ($section eq 'static') { print STDOUT "Warning (non-fatal): Target 'static' depends on targets ", "in skipped section 'static_lib'\n" if $self->{SKIPHASH}{static_lib} && $Verbose; } return 'skipped' if $self->{SKIPHASH}{$section}; return ''; } sub flush { my $self = shift; my($chunk); # use FileHandle (); # my $fh = new FileHandle; local *FH; print STDOUT "Writing $self->{MAKEFILE} for $self->{NAME}\n"; unlink($self->{MAKEFILE}, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ''); # $fh->open(">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!"; open(FH,">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!"; for $chunk (@{$self->{RESULT}}) { # print $fh "$chunk\n"; print FH "$chunk\n"; } # $fh->close; close FH; my($finalname) = $self->{MAKEFILE}; rename("MakeMaker.tmp", $finalname); chmod 0644, $finalname unless $Is_VMS; if ($self->{PARENT}) { foreach (keys %$self) { # safe memory delete $self->{$_} unless $Keep_after_flush{$_}; } } system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":"; } # The following mkbootstrap() is only for installations that are calling # the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker # writes Makefiles, that use ExtUtils::Mkbootstrap directly. sub mkbootstrap { die <".neatvalue($val)) ; } return "{ ".join(', ',@m)." }"; } sub selfdocument { my($self) = @_; my(@m); if ($Verbose){ push @m, "\n# Full list of MakeMaker attribute values:"; foreach $key (sort keys %$self){ next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/; my($v) = neatvalue($self->{$key}); $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; $v =~ tr/\n/ /s; push @m, "# $key => $v"; } } join "\n", @m; } package ExtUtils::MakeMaker; 1; __END__ =head1 NAME ExtUtils::MakeMaker - create an extension Makefile =head1 SYNOPSIS C C VALUE [, ...] );> which is really Cnew(\%att)-Eflush;> =head1 DESCRIPTION This utility is designed to write a Makefile for an extension module from a Makefile.PL. It is based on the Makefile.SH model provided by Andy Dougherty and the perl5-porters. It splits the task of generating the Makefile into several subroutines that can be individually overridden. Each subroutine returns the text it wishes to have written to the Makefile. MakeMaker is object oriented. Each directory below the current directory that contains a Makefile.PL. Is treated as a separate object. This makes it possible to write an unlimited number of Makefiles with a single invocation of WriteMakefile(). =head2 How To Write A Makefile.PL The short answer is: Don't. Always begin with h2xs. Always begin with h2xs! ALWAYS BEGIN WITH H2XS! even if you're not building around a header file, and even if you don't have an XS component. Run h2xs(1) before you start thinking about writing a module. For so called pm-only modules that consist of C<*.pm> files only, h2xs has the C<-X> switch. This will generate dummy files of all kinds that are useful for the module developer. The medium answer is: use ExtUtils::MakeMaker; WriteMakefile( NAME => "Foo::Bar" ); The long answer is the rest of the manpage :-) =head2 Default Makefile Behaviour The generated Makefile enables the user of the extension to invoke perl Makefile.PL # optionally "perl Makefile.PL verbose" make make test # optionally set TEST_VERBOSE=1 make install # See below The Makefile to be produced may be altered by adding arguments of the form C. E.g. perl Makefile.PL PREFIX=/tmp/myperl5 Other interesting targets in the generated Makefile are make config # to check if the Makefile is up-to-date make clean # delete local temp files (Makefile gets renamed) make realclean # delete derived files (including ./blib) make ci # check in all the files in the MANIFEST file make dist # see below the Distribution Support section =head2 make test MakeMaker checks for the existence of a file named F in the current directory and if it exists it adds commands to the test target of the generated Makefile that will execute the script with the proper set of perl C<-I> options. MakeMaker also checks for any files matching glob("t/*.t"). It will add commands to the test target of the generated Makefile that execute all matching files via the L module with the C<-I> switches set correctly. =head2 make testdb A useful variation of the above is the target C. It runs the test under the Perl debugger (see L). If the file F exists in the current directory, it is used for the test. If you want to debug some other testfile, set C variable thusly: make testdb TEST_FILE=t/mytest.t By default the debugger is called using C<-d> option to perl. If you want to specify some other option, set C variable: make testdb TESTDB_SW=-Dx =head2 make install make alone puts all relevant files into directories that are named by -the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR, and -INST_MAN3DIR. All these default to something below ./blib if you are -I building below the perl source directory. If you I -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_HTMLLIBDIR, +INST_HTMLSCRIPTDIR, INST_MAN1DIR, and INST_MAN3DIR. All these default +to something below ./blib if you are I building below the perl +source directory. If you I building below the perl source, +INST_LIB and INST_ARCHLIB default to ../../lib, and INST_SCRIPT is not +defined. The I 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_BIN INSTALLBIN - INST_SCRIPT INSTALLSCRIPT - INST_MAN1DIR INSTALLMAN1DIR - INST_MAN3DIR INSTALLMAN3DIR + 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 The INSTALL... macros in turn default to their %Config ($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts. You can check the values of these variables on your system with perl '-V:install.*' And to check the sequence in which the library directories are searched by perl, run perl -le 'print join $/, @INC' =head2 PREFIX and LIB attribute PREFIX and LIB can be used to set several INSTALL* attributes in one go. The quickest way to install a module in a non-standard place might be perl Makefile.PL LIB=~/lib This will install the module's architecture-independent files into ~/lib, the architecture-dependent files into ~/lib/$archname/auto. Another way to specify many INSTALL directories with a single parameter is PREFIX. perl Makefile.PL PREFIX=~ This will replace the string specified by $Config{prefix} in all $Config{install*} values. Note, that in both cases the tilde expansion is done by MakeMaker, not by perl by default, nor by make. Conflicts between parameters LIB, PREFIX and the various INSTALL* arguments are resolved so that XXX If the user has superuser privileges, and is not working on AFS (Andrew File System) or relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate, and this incantation will be the best: perl Makefile.PL; make; make test make install make install per default writes some documentation of what has been done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature can be bypassed by calling make pure_install. =head2 AFS users will have to specify the installation directories as these most probably have changed since perl itself has been installed. They will have to do this by calling perl Makefile.PL INSTALLSITELIB=/afs/here/today \ INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages make Be careful to repeat this procedure every time you recompile an extension, unless you are sure the AFS installation directories are still valid. =head2 Static Linking of a new Perl Binary An extension that is built with the above steps is ready to use on systems supporting dynamic loading. On systems that do not support dynamic loading, any newly created extension has to be linked together with the available resources. MakeMaker supports the linking process by creating appropriate targets in the Makefile whenever an extension is built. You can invoke the corresponding section of the makefile with make perl That produces a new perl binary in the current directory with all extensions linked in that can be found in INST_ARCHLIB , SITELIBEXP, and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on UNIX, this is called Makefile.aperl (may be system dependent). If you want to force the creation of a new perl, it is recommended, that you delete this Makefile.aperl, so the directories are searched-through for linkable libraries again. The binary can be installed into the directory where perl normally resides on your machine with make inst_perl To produce a perl binary with a different name than C, either say perl Makefile.PL MAP_TARGET=myperl make myperl make inst_perl or say perl Makefile.PL make myperl MAP_TARGET=myperl make inst_perl MAP_TARGET=myperl In any case you will be prompted with the correct invocation of the C target that installs the new binary into INSTALLBIN. make inst_perl per default writes some documentation of what has been done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This can be bypassed by calling make pure_inst_perl. Warning: the inst_perl: target will most probably overwrite your existing perl binary. Use with care! Sometimes you might want to build a statically linked perl although your system supports dynamic loading. In this case you may explicitly set the linktype with the invocation of the Makefile.PL or make: perl Makefile.PL LINKTYPE=static # recommended or make LINKTYPE=static # works on most systems =head2 Determination of Perl Library and Installation Locations MakeMaker needs to know, or to guess, where certain things are located. Especially INST_LIB and INST_ARCHLIB (where to put the files during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read existing modules from), and PERL_INC (header files and C). Extensions may be built either using the contents of the perl source directory tree or from the installed perl library. The recommended way is to build extensions after you have run 'make install' on perl itself. You can do that in any directory on your hard disk that is not below the perl source tree. The support for extensions below the ext directory of the perl distribution is only good for the standard extensions that come with perl. If an extension is being built below the C directory of the perl source then MakeMaker will set PERL_SRC automatically (e.g., C<../..>). If PERL_SRC is defined and the extension is recognized as a standard extension, then other variables default to the following: PERL_INC = PERL_SRC PERL_LIB = PERL_SRC/lib PERL_ARCHLIB = PERL_SRC/lib INST_LIB = PERL_LIB INST_ARCHLIB = PERL_ARCHLIB If an extension is being built away from the perl source then MakeMaker will leave PERL_SRC undefined and default to using the installed copy of the perl library. The other variables default to the following: PERL_INC = $archlibexp/CORE PERL_LIB = $privlibexp PERL_ARCHLIB = $archlibexp INST_LIB = ./blib/lib INST_ARCHLIB = ./blib/arch If perl has not yet been installed then PERL_SRC can be defined on the command line as shown in the previous section. =head2 Which architecture dependent directory? If you don't want to keep the defaults for the INSTALL* macros, MakeMaker helps you to minimize the typing needed: the usual relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined by Configure at perl compilation time. MakeMaker supports the user who sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not, then MakeMaker defaults the latter to be the same subdirectory of INSTALLPRIVLIB as Configure decided for the counterparts in %Config , otherwise it defaults to INSTALLPRIVLIB. The same relationship holds for INSTALLSITELIB and INSTALLSITEARCH. 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 The following attributes can be specified as arguments to WriteMakefile() or as NAME=VALUE pairs on the command line: =over 2 =item AUTHOR String containing name (and email address) of package author(s). Is used in PPD (Perl Package Description) files for PPM (Perl Package Manager). =item ABSTRACT One line description of the module. Will be included in PPD file. =item ABSTRACT_FROM Name of the file that contains the package description. MakeMaker looks for a line in the POD matching /^($package\s-\s)(.*)/. This is typically the first line in the "=head1 NAME" section. $2 becomes the abstract. =item BINARY_LOCATION Used when creating PPD files for binary packages. It can be set to a full or relative path or URL to the binary archive for a particular architecture. For example: perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz builds a PPD package that references a binary of the C package, located in the C directory relative to the PPD itself. =item C Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not 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, but if and only if the submodule's Makefile.PL itself makes no mention of the 'CAPI' attribute. =item CCFLAGS String that will be included in the compiler call command line between the arguments INC and OPTIMIZE. =item CONFIG Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from config.sh. MakeMaker will add to CONFIG the following values anyway: ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc lib_ext obj_ext ranlib sitelibexp sitearchexp so =item CONFIGURE CODE reference. The subroutine should return a hash reference. The hash may contain further attributes, e.g. {LIBS =E ...}, that have to be determined by some evaluation method. =item DEFINE Something like C<"-DHAVE_UNISTD_H"> =item DIR Ref to array of subdirectories containing Makefile.PLs e.g. [ 'sdbm' ] in ext/SDBM_File =item DISTNAME Your name for distributing the package (by tar file). This defaults to NAME above. =item DL_FUNCS Hashref of symbol names for routines to be made available as universal symbols. Each key/value pair consists of the package name and an array of routine names in that package. Used only under AIX, OS/2, VMS and Win32 at present. The routine names supplied will be expanded in the same way as XSUB names are expanded by the XS() macro. Defaults to {"$(NAME)" => ["boot_$(NAME)" ] } e.g. {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], "NetconfigPtr" => [ 'DESTROY'] } Please see the L documentation for more information about the DL_FUNCS, DL_VARS and FUNCLIST attributes. =item DL_VARS Array of symbol names for variables to be made available as universal symbols. Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. (e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) =item EXCLUDE_EXT Array of extension names to exclude when doing a static build. This is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more details. (e.g. [ qw( Socket POSIX ) ] ) This attribute may be most useful when specified as a string on the command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' =item EXE_FILES Ref to array of executable files. The files will be copied to the INST_SCRIPT directory. Make realclean will delete them from there again. =item FIRST_MAKEFILE The name of the Makefile to be produced. Defaults to the contents of MAKEFILE, but can be overridden. This is used for the second Makefile that will be produced for the MAP_TARGET. =item FULLPERL Perl binary able to run this extension. =item FUNCLIST This provides an alternate means to specify function names to be exported from the extension. Its value is a reference to an array of function names to be exported by the extension. These names are passed through unaltered to the linker options file. =item H 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 extension. It is only used on OS/2 and Win32. =item INC Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> =item INCLUDE_EXT Array of extension names to be included when doing a static build. MakeMaker will normally build with all of the installed extensions when doing a static build, and that is usually the desired behavior. If INCLUDE_EXT is present then MakeMaker will build only with those extensions which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ]) It is not necessary to mention DynaLoader or the current extension when filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then only DynaLoader and the current extension will be included in the build. This attribute may be most useful when specified as a string on the command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' =item INSTALLARCHLIB Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to perl. =item INSTALLBIN Directory to install binary files (e.g. tkperl) into. =item INSTALLDIRS Determines which of the two sets of installation directories to 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 $Config{installman1dir}. =item INSTALLMAN3DIR This directory gets the man pages at 'make install' time. Defaults to $Config{installman3dir}. =item INSTALLPRIVLIB Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to perl. =item INSTALLSCRIPT Used by 'make install' which copies files from INST_SCRIPT to this directory. =item INSTALLSITEARCH Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to site (default). =item INSTALLSITELIB Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to site (default). =item INST_ARCHLIB Same as INST_LIB for architecture dependent files. =item INST_BIN Directory to put real binary files during 'make'. These will be copied to INSTALLBIN during 'make install' =item INST_EXE Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you need to use it. =item INST_LIB 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 =item INST_MAN3DIR Directory to hold the man pages at 'make' time =item INST_SCRIPT Directory, where executable files should be installed during -'make'. Defaults to "./blib/bin", just to have a dummy location during +'make'. Defaults to "./blib/script", 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 Negligence to set this flag in I 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 what files to link/load from (also see dynamic_lib below for how to specify ld flags) =item LIB LIB can only be set at C time. It has the effect of setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any =item LIBPERL_A The filename of the perllibrary that will be used together with this extension. Defaults to libperl.a. =item LIBS An anonymous array of alternative library specifications to be searched for (in order) until at least one library is found. E.g. 'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"] Mind, that any element of the array contains a complete set of arguments for the ld command. So do not specify 'LIBS' => ["-ltcl", "-ltk", "-lX11"] See ODBM_File/Makefile.PL for an example, where an array is needed. If you specify a scalar as in 'LIBS' => "-ltcl -ltk -lX11" MakeMaker will turn it into an array with one element. =item LINKTYPE 'static' or 'dynamic' (default unless usedl=undef in config.sh). Should only be used to force static linking (also see linkext below). =item MAKEAPERL Boolean which tells MakeMaker, that it should include the rules to make a perl. This is handled automatically as a switch by MakeMaker. The user normally does not need it. =item MAKEFILE The name of the Makefile to be produced. =item MAN1PODS 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 man pages and installed as was requested at Configure time. =item MAN3PODS 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 man pages and installed as was requested at Configure time. =item MAP_TARGET If it is intended, that a new perl binary be produced, this variable may hold a name for that binary. Defaults to perl =item MYEXTLIB If the extension links to a library that it builds set this to the name of the library (see SDBM_File) =item NAME Perl module name for this extension (DBD::Oracle). This will default to the directory name but should be explicitly defined in the 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 Defaults to C<@>. By setting it to an empty string you can generate a Makefile that echos all commands. Mainly used in debugging MakeMaker itself. =item NORECURS 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. =item OBJECT List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long string containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" =item OPTIMIZE Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is passed to subdirectory makes. =item PERL Perl binary for tasks that can be done by miniperl =item PERLMAINCC The call to the program that is able to compile perlmain.c. Defaults to $(CC). =item PERL_ARCHLIB -Same as above for architecture dependent files +Same as above for architecture dependent files. =item PERL_LIB Directory containing the Perl library to use. =item PERL_SRC Directory containing the Perl source code (use of this should be avoided, it may be undefined) =item PERM_RW Desired permission for read/writable files. Defaults to C<644>. See also L. =item PERM_RWX Desired permission for executable files. Defaults to C<755>. See also L. =item PL_FILES Ref to hash of files to be processed as perl programs. MakeMaker will default to any found *.PL file (except Makefile.PL) being keys and the basename of the file being the value. E.g. {'foobar.PL' => 'foobar'} The *.PL files are expected to produce output to the target files themselves. If multiple files can be generated from the same *.PL file then the value in the hash can be a reference to an array of target file names. E.g. {'foobar.PL' => ['foobar1','foobar2']} =item PM Hashref of .pm files and *.pl files to be installed. e.g. {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'} By default this will include *.pm and *.pl and the files found in the PMLIBDIRS directories. Defining PM in the Makefile.PL will override PMLIBDIRS. =item PMLIBDIRS Ref to array of subdirectories containing library files. Defaults to [ 'lib', $(BASEEXT) ]. The directories will be scanned and I files 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 below. (e.g. perl) =item PPM_INSTALL_SCRIPT Name of the script that gets executed by the Perl Package Manager after the installation of a package. =item PREFIX Can be used to set the three INSTALL* attributes in one go (except for probably INSTALLMAN1DIR, if it is not below PREFIX according to %Config). They will have PREFIX as a common directory node and will branch from that node into lib/, lib/ARCHNAME or whatever Configure decided at the build time of your perl (unless you override one of them, of course). =item PREREQ_PM Hashref: Names of modules that need to be available to run this extension (e.g. Fcntl for SDBM_File) are the keys of the hash and the desired version is the value. If the required version number is 0, we 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 neglectible -speedup. It may seriously damage the resulting Makefile. Only use it, +Makefile. Caution! Do not use the SKIP attribute for the negligible +speedup. It may seriously damage the resulting Makefile. Only use it if you really need it. =item TYPEMAPS Ref to array of typemap file names. Use this when the typemaps are in some directory other than the current directory or when they are not named B. The last typemap in the list takes precedence. A typemap in the current directory has highest precedence, even if it isn't listed in TYPEMAPS. The default system typemap has lowest precedence. =item VERSION Your version number for distributing the package. This defaults to 0.1. =item VERSION_FROM Instead of specifying the VERSION in the Makefile.PL you can let MakeMaker parse a file to determine the version number. The parsing routine requires that the file named by VERSION_FROM contains one single line to compute the version number. The first line in the file that contains the regular expression /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ will be evaluated with eval() and the value of the named variable B the eval() will be assigned to the VERSION attribute of the MakeMaker object. The following lines will be parsed o.k.: $VERSION = '1.00'; *VERSION = \'1.01'; ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/; $FOO::VERSION = '1.10'; *FOO::VERSION = \'1.11'; but these will fail: my $VERSION = '1.01'; local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; The file named in VERSION_FROM is not added as a dependency to Makefile. This is not really correct, but it would be a major pain during development to have to rewrite the Makefile for any smallish change in that file. If you want to make sure that the Makefile contains the correct VERSION macro after any change of the file, you would have to do something like depend => { Makefile => '$(VERSION_FROM)' } See attribute C below. =item XS Hashref of .xs files. MakeMaker will default this. e.g. {'name_of_file.xs' => 'name_of_file.c'} The .c files will automatically be included in the list of files deleted by a make clean. =item XSOPT String of options to pass to xsubpp. This might include C<-C++> or C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for that purpose. =item XSPROTOARG May be set to an empty string, which is identical to C<-prototypes>, or C<-noprototypes>. See the xsubpp documentation for details. MakeMaker defaults to the empty string. =item XS_VERSION Your version number for the .xs file of this package. This defaults to the value of the VERSION attribute. =back =head2 Additional lowercase attributes can be used to pass parameters to the methods which implement that part of the Makefile. =over 2 =item clean {FILES => "*.xyz foo"} =item depend {ANY_TARGET => ANY_DEPENDECY, ...} =item dist {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip', ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' } If you specify COMPRESS, then SUFFIX should also be altered, as it is needed to tell make the target file of the compression. Setting DIST_CP to ln can be useful, if you need to preserve the timestamps on your files. DIST_CP can take the values 'cp', which copies the file, 'ln', which links the file, and 'best' which copies symbolic links and links the rest. Default is 'best'. =item dynamic_lib {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} =item linkext {LINKTYPE => 'static', 'dynamic' or ''} 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 {ANY_MACRO => ANY_VALUE, ...} =item realclean {FILES => '$(INST_ARCHAUTODIR)/*.xyz'} +=item test + + {TESTS => 't/*.t'} + =item tool_autosplit - {MAXLEN =E 8} + {MAXLEN => 8} =back =head2 Overriding MakeMaker Methods If you cannot achieve the desired Makefile behaviour by specifying attributes you may define private subroutines in the Makefile.PL. Each subroutines returns the text it wishes to have written to the Makefile. To override a section of the Makefile you can either say: sub MY::c_o { "new literal text" } or you can edit the default by saying something like: sub MY::c_o { package MY; # so that "SUPER" works right my $inherited = shift->SUPER::c_o(@_); $inherited =~ s/old text/new text/; $inherited; } If you are running experiments with embedding perl as a library into other applications, you might find MakeMaker is not sufficient. You'd better have a look at ExtUtils::Embed which is a collection of utilities for embedding. If you still need a different solution, try to develop another subroutine that fits your needs and submit the diffs to F or F as appropriate. For a complete description of all MakeMaker methods see L. Here is a simple example of how to add a new target to the generated Makefile: sub MY::postamble { ' $(MYEXTLIB): sdbm/Makefile cd sdbm && $(MAKE) all '; } =head2 Hintsfile support MakeMaker.pm uses the architecture specific information from Config.pm. In addition it evaluates architecture specific hints files in a C directory. The hints files are expected to be named like their counterparts in C, but with an C<.pl> file name extension (eg. C). They are simply Ced by MakeMaker within the WriteMakefile() subroutine, and can be used to execute commands as well as to include special variables. The rules which hintsfile is chosen are the same as in Configure. The hintsfile is eval()ed immediately after the arguments given to WriteMakefile are stuffed into a hash reference $self but before this reference becomes blessed. So if you want to do the equivalent to override or create an attribute you would say something like $self->{LIBS} = ['-ldbm -lucb -lc']; =head2 Distribution Support For authors of extensions MakeMaker provides several Makefile targets. Most of the support comes from the ExtUtils::Manifest module, where additional documentation can be found. =over 4 =item make distcheck reports which files are below the build directory but not in the MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for details) =item make skipcheck reports which files are skipped due to the entries in the C file (See ExtUtils::Manifest::skipcheck() for 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 rewrites the MANIFEST file, adding all remaining files found (See ExtUtils::Manifest::mkmanifest() for details) =item make distdir Copies all the files that are in the MANIFEST file to a newly created directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory exists, it will be removed first. =item make disttest Makes a distdir first, and runs a C, a make, and a make test in that directory. =item make tardist First does a distdir. Then a command $(PREOP) which defaults to a null command, followed by $(TOUNIX), which defaults to a null command under UNIX, and will convert files in distribution directory to UNIX format otherwise. Next it runs C on that directory into a tarfile and deletes the directory. Finishes with a command $(POSTOP) which defaults to a null command. =item make dist Defaults to $(DIST_DEFAULT) which in turn defaults to tardist. =item make uutardist Runs a tardist first and uuencodes the tarfile. =item make shdist First does a distdir. Then a command $(PREOP) which defaults to a null command. Next it runs C on that directory into a sharfile and deletes the intermediate directory again. Finishes with a command $(POSTOP) which defaults to a null command. Note: For shdist to work properly a C program that can handle directories is mandatory. =item make zipdist First does a distdir. Then a command $(PREOP) which defaults to a null command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a zipfile. Then deletes that directory. Finishes with a command $(POSTOP) which defaults to a null command. =item make ci Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file. =back Customization of the dist targets can be done by specifying a hash reference to the dist attribute of the WriteMakefile call. The following parameters are recognized: CI ('ci -u') COMPRESS ('gzip --best') POSTOP ('@ :') PREOP ('@ :') TO_UNIX (depends on the system) RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):') SHAR ('shar') SUFFIX ('.gz') TAR ('tar') TARFLAGS ('cvf') ZIP ('zip') ZIPFLAGS ('-r') An example: WriteMakefile( 'dist' => { COMPRESS=>"bzip2", SUFFIX=>".bz2" }) =head2 Disabling an extension If some events detected in F imply that there is no way to create the Module, but this is a normal state of things, then you can create a F which does nothing, but succeeds on all the "usual" build targets. To do so, use ExtUtils::MakeMaker::WriteEmptyMakefile(); instead of WriteMakefile(). This may be useful if other modules expect this module to be I OK, as opposed to I OK (say, this system-dependent module builds in a subdirectory of some other distribution, or is listed as a dependency in a CPAN::Bundle, but the functionality is supported by different means on the current architecture). =head1 ENVIRONMENT =over 8 =item PERL_MM_OPT Command line options used by Cnew()>, and thus by C. The string is split on whitespace, and the result is processed before any actual command line arguments are processed. =back =head1 SEE ALSO ExtUtils::MM_Unix, ExtUtils::Manifest, ExtUtils::testlib, ExtUtils::Install, ExtUtils::Embed =head1 AUTHORS Andy Dougherty >, Andreas KEnig >, Tim Bunce >. VMS support by Charles Bailey >. OS/2 support by Ilya Zakharevich >. Contact the makemaker mailing list C, if you have any questions. =cut Index: head/contrib/perl5/pp.c =================================================================== --- head/contrib/perl5/pp.c (revision 62079) +++ head/contrib/perl5/pp.c (revision 62080) @@ -1,4646 +1,5291 @@ /* pp.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * * $FreeBSD$ */ /* * "It's a big house this, and very peculiar. Always a bit more to discover, * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise */ #include "EXTERN.h" +#define PERL_IN_PP_C #include "perl.h" /* * The compiler on Concurrent CX/UX systems has a subtle bug which only * seems to show up when compiling pp.c - it generates the wrong double * precision constant value for (double)UV_MAX when used inline in the body * of the code below, so this makes a static variable up front (which the * compiler seems to get correct) and uses it in place of UV_MAX below. */ #ifdef CXUX_BROKEN_CONSTANT_CONVERT 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, * which for now are all Crays, pack and unpack have to play games. */ /* * These values are required for portability of pack() output. * If they're not right on your machine, then pack() and unpack() * wouldn't work right anyway; you'll need to apply the Cray hack. * (I'd like to check them with #if, but you can't use sizeof() in * the preprocessor.) --??? */ /* The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE defines are now in config.h. --Andy Dougherty April 1998 */ #define SIZE16 2 #define SIZE32 4 -#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP) +/* 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 == 0x12345678 # define OFF16(p) (char*)(p) # define OFF32(p) (char*)(p) # else # if BYTEORDER == 0x87654321 # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) # else }}}} bad cray byte order # endif # 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 #include #endif /* XXX I can't imagine anyone who doesn't have this actually _needs_ it, since pid_t is an integral type. --AD 2/20/1998 */ #ifdef NEED_GETPID_PROTO extern Pid_t getpid (void); #endif PP(pp_stub) { djSP; if (GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); RETURN; } PP(pp_scalar) { return NORMAL; } /* Pushy stuff. */ PP(pp_padav) { djSP; dTARGET; if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PL_curpad[PL_op->op_targ]); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); RETURN; } if (GIMME == G_ARRAY) { I32 maxarg = AvFILL((AV*)TARG) + 1; EXTEND(SP, maxarg); if (SvMAGICAL(TARG)) { U32 i; for (i=0; i < maxarg; i++) { SV **svp = av_fetch((AV*)TARG, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); } SP += maxarg; } else { SV* sv = sv_newmortal(); I32 maxarg = AvFILL((AV*)TARG) + 1; sv_setiv(sv, maxarg); PUSHs(sv); } RETURN; } PP(pp_padhv) { djSP; dTARGET; I32 gimme; XPUSHs(TARG); if (PL_op->op_private & OPpLVAL_INTRO) SAVECLEARSV(PL_curpad[PL_op->op_targ]); if (PL_op->op_flags & OPf_REF) RETURN; gimme = GIMME_V; if (gimme == G_ARRAY) { - RETURNOP(do_kv(ARGS)); + RETURNOP(do_kv()); } else if (gimme == G_SCALAR) { SV* sv = sv_newmortal(); if (HvFILL((HV*)TARG)) - sv_setpvf(sv, "%ld/%ld", + Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1); else sv_setiv(sv, 0); SETs(sv); } RETURN; } PP(pp_padany) { - DIE("NOT IMPL LINE %d",__LINE__); + DIE(aTHX_ "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(); gv_init(gv, 0, "", 0, 0); GvIOp(gv) = (IO *)sv; (void)SvREFCNT_inc(sv); sv = (SV*) gv; - } else if (SvTYPE(sv) != SVt_PVGV) - DIE("Not a GLOB reference"); + } + else if (SvTYPE(sv) != SVt_PVGV) + DIE(aTHX_ "Not a GLOB reference"); } else { if (SvTYPE(sv) != SVt_PVGV) { char *sym; STRLEN n_a; if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } - if (!SvOK(sv)) { + 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 (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a symbol"); - if (PL_dowarn) - warn(warn_uninit); + DIE(aTHX_ PL_no_usym, "a symbol"); + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); RETSETUNDEF; } sym = SvPV(sv, n_a); - 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_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 & OPpLVAL_INTRO) save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); SETs(sv); RETURN; } PP(pp_rv2sv) { djSP; dTOPss; if (SvROK(sv)) { wasref: + tryAMAGICunDEREF(to_sv); + sv = SvRV(sv); switch (SvTYPE(sv)) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: - DIE("Not a SCALAR reference"); + DIE(aTHX_ "Not a SCALAR reference"); } } else { GV *gv = (GV*)sv; char *sym; STRLEN n_a; if (SvTYPE(gv) != SVt_PVGV) { if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto wasref; } if (!SvOK(sv)) { if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) - DIE(no_usym, "a SCALAR"); - if (PL_dowarn) - warn(warn_uninit); + DIE(aTHX_ PL_no_usym, "a SCALAR"); + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); RETSETUNDEF; } sym = SvPV(sv, n_a); - if (PL_op->op_private & HINT_STRICT_REFS) - DIE(no_symref, sym, "a SCALAR"); - gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV); + 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); + } } sv = GvSV(gv); } if (PL_op->op_flags & OPf_MOD) { if (PL_op->op_private & OPpLVAL_INTRO) sv = save_scalar((GV*)TOPs); else if (PL_op->op_private & OPpDEREF) vivify_ref(sv, PL_op->op_private & OPpDEREF); } SETs(sv); RETURN; } PP(pp_av2arylen) { djSP; AV *av = (AV*)TOPs; SV *sv = AvARYLEN(av); if (!sv) { AvARYLEN(av) = sv = NEWSV(0,0); sv_upgrade(sv, SVt_IV); sv_magic(sv, (SV*)av, '#', Nullch, 0); } SETs(sv); RETURN; } PP(pp_pos) { djSP; dTARGET; dPOPss; if (PL_op->op_flags & OPf_MOD) { if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, '.', Nullch, 0); } LvTYPE(TARG) = '.'; if (LvTARG(TARG) != sv) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(sv); } PUSHs(TARG); /* no SvSETMAGIC */ RETURN; } else { MAGIC* mg; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { mg = mg_find(sv, 'g'); if (mg && mg->mg_len >= 0) { - PUSHi(mg->mg_len + PL_curcop->cop_arybase); + I32 i = mg->mg_len; + if (DO_UTF8(sv)) + sv_pos_b2u(sv, &i); + PUSHi(i + PL_curcop->cop_arybase); RETURN; } } RETPUSHUNDEF; } } PP(pp_rv2cv) { djSP; GV *gv; HV *stash; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); 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; SETs((SV*)cv); RETURN; } PP(pp_prototype) { djSP; CV *cv; HV *stash; GV *gv; SV *ret; ret = &PL_sv_undef; if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { char *s = SvPVX(TOPs); if (strnEQ(s, "CORE::", 6)) { int code; code = keyword(s + 6, SvCUR(TOPs) - 6); if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) int i = 0, n = 0, seen_question = 0; I32 oa; char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ while (i < MAXO) { /* The slow way. */ - if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i])) + if (strEQ(s + 6, PL_op_name[i]) + || strEQ(s + 6, PL_op_desc[i])) + { goto found; + } i++; } goto nonesuch; /* Should not happen... */ found: - oa = opargs[i] >> OASHIFT; + oa = PL_opargs[i] >> OASHIFT; while (oa) { if (oa & OA_OPTIONAL) { seen_question = 1; str[n++] = ';'; - } else if (seen_question) + } + else if (n && str[0] == ';' && seen_question) goto set; /* XXXX system, exec */ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) { str[n++] = '\\'; } /* What to do with R ((un)tie, tied, (sys)read, recv)? */ str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; oa = oa >> 4; } str[n++] = '\0'; - ret = sv_2mortal(newSVpv(str, n - 1)); - } else if (code) /* Non-Overridable */ + ret = sv_2mortal(newSVpvn(str, n - 1)); + } + else if (code) /* Non-Overridable */ goto set; else { /* None such */ nonesuch: - croak("Cannot find an opnumber for \"%s\"", s+6); + DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } cv = sv_2cv(TOPs, &stash, &gv, FALSE); if (cv && SvPOK(cv)) - ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv))); + ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv))); set: SETs(ret); RETURN; } PP(pp_anoncode) { djSP; CV* cv = (CV*)PL_curpad[PL_op->op_targ]; if (CvCLONE(cv)) cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); EXTEND(SP,1); PUSHs((SV*)cv); RETURN; } PP(pp_srefgen) { djSP; *SP = refto(*SP); RETURN; } PP(pp_refgen) { djSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; else *MARK = &PL_sv_undef; *MARK = refto(*MARK); SP = MARK; RETURN; } EXTEND_MORTAL(SP - MARK); while (++MARK <= SP) *MARK = refto(*MARK); RETURN; } STATIC SV* -refto(SV *sv) +S_refto(pTHX_ SV *sv) { SV* rv; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { if (LvTARGLEN(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); else { SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } rv = sv_newmortal(); sv_upgrade(rv, SVt_RV); SvRV(rv) = sv; SvROK_on(rv); return rv; } PP(pp_ref) { djSP; dTARGET; SV *sv; char *pv; sv = POPs; if (sv && SvGMAGICAL(sv)) mg_get(sv); if (!sv || !SvROK(sv)) RETPUSHNO; sv = SvRV(sv); pv = sv_reftype(sv,TRUE); PUSHp(pv, strlen(pv)); RETURN; } PP(pp_bless) { djSP; HV *stash; if (MAXARG == 1) - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); else { SV *ssv = POPs; STRLEN len; char *ptr = SvPV(ssv,len); - if (PL_dowarn && len == 0) - warn("Explicit blessing to '' (assuming package main)"); + if (ckWARN(WARN_MISC) && len == 0) + Perl_warner(aTHX_ WARN_MISC, + "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, TRUE); } (void)sv_bless(TOPs, stash); RETURN; } PP(pp_gelem) { GV *gv; SV *sv; SV *tmpRef; char *elem; djSP; STRLEN n_a; - + sv = POPs; elem = SvPV(sv, n_a); gv = (GV*)POPs; tmpRef = Nullsv; sv = Nullsv; switch (elem ? *elem : '\0') { case 'A': if (strEQ(elem, "ARRAY")) tmpRef = (SV*)GvAV(gv); break; case 'C': if (strEQ(elem, "CODE")) tmpRef = (SV*)GvCVu(gv); break; case 'F': if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ tmpRef = (SV*)GvIOp(gv); break; case 'G': if (strEQ(elem, "GLOB")) tmpRef = (SV*)gv; break; case 'H': if (strEQ(elem, "HASH")) tmpRef = (SV*)GvHV(gv); break; case 'I': if (strEQ(elem, "IO")) tmpRef = (SV*)GvIOp(gv); break; case 'N': if (strEQ(elem, "NAME")) - sv = newSVpv(GvNAME(gv), GvNAMELEN(gv)); + sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); break; case 'P': if (strEQ(elem, "PACKAGE")) sv = newSVpv(HvNAME(GvSTASH(gv)), 0); break; case 'S': if (strEQ(elem, "SCALAR")) tmpRef = GvSV(gv); break; } if (tmpRef) sv = newRV(tmpRef); if (sv) sv_2mortal(sv); else sv = &PL_sv_undef; XPUSHs(sv); RETURN; } /* Pattern matching */ PP(pp_study) { djSP; dPOPss; - register UNOP *unop = cUNOP; register unsigned char *s; register I32 pos; register I32 ch; register I32 *sfirst; register I32 *snext; STRLEN len; if (sv == PL_lastscream) { if (SvSCREAM(sv)) RETPUSHYES; } else { if (PL_lastscream) { SvSCREAM_off(PL_lastscream); SvREFCNT_dec(PL_lastscream); } PL_lastscream = SvREFCNT_inc(sv); } s = (unsigned char*)(SvPV(sv, len)); pos = len; if (pos <= 0) RETPUSHNO; if (pos > PL_maxscream) { if (PL_maxscream < 0) { PL_maxscream = pos + 80; New(301, PL_screamfirst, 256, I32); New(302, PL_screamnext, PL_maxscream, I32); } else { PL_maxscream = pos + pos / 4; Renew(PL_screamnext, PL_maxscream, I32); } } sfirst = PL_screamfirst; snext = PL_screamnext; if (!sfirst || !snext) - DIE("do_study: out of memory"); + DIE(aTHX_ "do_study: out of memory"); for (ch = 256; ch; --ch) *sfirst++ = -1; sfirst -= 256; while (--pos >= 0) { ch = s[pos]; if (sfirst[ch] >= 0) snext[pos] = sfirst[ch] - pos; else snext[pos] = -pos; sfirst[ch] = pos; } SvSCREAM_on(sv); sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */ RETPUSHYES; } PP(pp_trans) { djSP; dTARG; SV *sv; if (PL_op->op_flags & OPf_STACKED) sv = POPs; else { sv = DEFSV; EXTEND(SP,1); } TARG = sv_newmortal(); - PUSHi(do_trans(sv, PL_op)); + PUSHi(do_trans(sv)); RETURN; } /* Lvalue operators. */ PP(pp_schop) { djSP; dTARGET; do_chop(TARG, TOPs); SETTARG; RETURN; } PP(pp_chop) { djSP; dMARK; dTARGET; while (SP > MARK) do_chop(TARG, POPs); PUSHTARG; RETURN; } PP(pp_schomp) { djSP; dTARGET; SETi(do_chomp(TOPs)); RETURN; } PP(pp_chomp) { djSP; dMARK; dTARGET; register I32 count = 0; while (SP > MARK) count += do_chomp(POPs); PUSHi(count); RETURN; } PP(pp_defined) { djSP; register SV* sv; sv = POPs; if (!sv || !SvANY(sv)) RETPUSHNO; switch (SvTYPE(sv)) { case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P'))) RETPUSHYES; break; case SVt_PVCV: if (CvROOT(sv) || CvXSUB(sv)) RETPUSHYES; break; default: if (SvGMAGICAL(sv)) mg_get(sv); if (SvOK(sv)) RETPUSHYES; } RETPUSHNO; } PP(pp_undef) { djSP; SV *sv; if (!PL_op->op_private) { EXTEND(SP, 1); RETPUSHUNDEF; } sv = POPs; if (!sv) RETPUSHUNDEF; - if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - dTHR; - if (PL_curcop != &PL_compiling) - croak(no_modify); - } - if (SvROK(sv)) - sv_unref(sv); - } + if (SvTHINKFIRST(sv)) + sv_force_normal(sv); switch (SvTYPE(sv)) { case SVt_NULL: break; case SVt_PVAV: av_undef((AV*)sv); break; case SVt_PVHV: hv_undef((HV*)sv); break; case SVt_PVCV: - if (PL_dowarn && cv_const_sv((CV*)sv)) - warn("Constant subroutine %s undefined", + if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) + Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: - { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv)); - cv_undef((CV*)sv); - CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */ + { + /* let user-undef'd sub keep its identity */ + GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv)); + cv_undef((CV*)sv); + CvGV((CV*)sv) = gv; + } break; case SVt_PVGV: if (SvFAKE(sv)) SvSetMagicSV(sv, &PL_sv_undef); else { GP *gp; gp_free((GV*)sv); Newz(602, gp, 1, GP); GvGP(sv) = gp_ref(gp); GvSV(sv) = NEWSV(72,0); - GvLINE(sv) = PL_curcop->cop_line; + GvLINE(sv) = CopLINE(PL_curcop); GvEGV(sv) = (GV*)sv; GvMULTI_on(sv); } break; default: if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) { (void)SvOOK_off(sv); Safefree(SvPVX(sv)); SvPV_set(sv, Nullch); SvLEN_set(sv, 0); } (void)SvOK_off(sv); SvSETMAGIC(sv); } RETPUSHUNDEF; } PP(pp_predec) { djSP; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + DIE(aTHX_ PL_no_modify); + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); SvSETMAGIC(TOPs); return NORMAL; } PP(pp_postinc) { djSP; dTARGET; if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_inc(TOPs); SvSETMAGIC(TOPs); if (!SvOK(TARG)) sv_setiv(TARG, 0); SETs(TARG); return NORMAL; } PP(pp_postdec) { djSP; dTARGET; - if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) - croak(no_modify); + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && + if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else sv_dec(TOPs); SvSETMAGIC(TOPs); SETs(TARG); return NORMAL; } /* Ordinary operators. */ PP(pp_pow) { djSP; dATARGET; tryAMAGICbin(pow,opASSIGN); { dPOPTOPnnrl; - SETn( pow( left, right) ); + SETn( Perl_pow( left, right) ); RETURN; } } PP(pp_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPnnrl; SETn( left * right ); RETURN; } } PP(pp_divide) { djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPPOPnnrl; - double value; + NV value; if (right == 0.0) - DIE("Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); #ifdef SLOPPYDIVIDE /* insure that 20./5. == 4. */ { IV k; - if ((double)I_V(left) == left && - (double)I_V(right) == right && + if ((NV)I_V(left) == left && + (NV)I_V(right) == right && (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) { value = k; - } else { + } + else { value = left / right; } } #else value = left / right; #endif PUSHn( value ); RETURN; } } PP(pp_modulo) { djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { - UV left; - UV right; - bool left_neg; - bool right_neg; - UV ans; + 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 { - double n = POPn; - right = U_V((right_neg = (n < 0)) ? -n : n); - } + 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 (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); - } + 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 (!right) - DIE("Illegal modulus zero"); + if (use_double) { + NV dans; - 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; +#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); + + if (!dright) + DIE(aTHX_ "Illegal modulus zero"); + + 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; } } PP(pp_repeat) { djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { register I32 count = POPi; if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; I32 items = SP - MARK; I32 max; max = items * count; MEXTEND(MARK, max); if (count > 1) { while (SP > MARK) { if (*SP) SvTEMP_off((*SP)); SP--; } MARK++; repeatcpy((char*)(MARK + items), (char*)MARK, items * sizeof(SV*), count - 1); SP += max; } else if (count <= 0) SP -= items; } else { /* Note: mark already snarfed by pp_list */ SV *tmpstr; 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) { if (count < 1) SvCUR_set(TARG, 0); else { SvGROW(TARG, (count * len) + 1); repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); SvCUR(TARG) *= count; } *SvEND(TARG) = '\0'; } (void)SvPOK_only(TARG); PUSHTARG; } RETURN; } } PP(pp_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPnnrl_ul; SETn( left - right ); RETURN; } } PP(pp_left_shift) { djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { - IBW shift = POPi; + IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IBW i = TOPi; - i = BWi(i) << shift; - SETi(BWi(i)); + IV i = TOPi; + SETi(i << shift); } else { - UBW u = TOPu; - u <<= shift; - SETu(BWu(u)); + UV u = TOPu; + SETu(u << shift); } RETURN; } } PP(pp_right_shift) { djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { - IBW shift = POPi; + IV shift = POPi; if (PL_op->op_private & HINT_INTEGER) { - IBW i = TOPi; - i = BWi(i) >> shift; - SETi(BWi(i)); + IV i = TOPi; + SETi(i >> shift); } else { - UBW u = TOPu; - u >>= shift; - SETu(BWu(u)); + UV u = TOPu; + SETu(u >> shift); } RETURN; } } PP(pp_lt) { djSP; tryAMAGICbinSET(lt,0); { dPOPnv; SETs(boolSV(TOPn < value)); RETURN; } } PP(pp_gt) { djSP; tryAMAGICbinSET(gt,0); { dPOPnv; SETs(boolSV(TOPn > value)); RETURN; } } PP(pp_le) { djSP; tryAMAGICbinSET(le,0); { dPOPnv; SETs(boolSV(TOPn <= value)); RETURN; } } PP(pp_ge) { djSP; tryAMAGICbinSET(ge,0); { dPOPnv; SETs(boolSV(TOPn >= value)); RETURN; } } PP(pp_ne) { djSP; tryAMAGICbinSET(ne,0); { dPOPnv; SETs(boolSV(TOPn != value)); RETURN; } } PP(pp_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); { 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) value = -1; else if (left > right) value = 1; else { SETs(&PL_sv_undef); RETURN; } +#endif SETi(value); RETURN; } } PP(pp_slt) { djSP; tryAMAGICbinSET(slt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp < 0)); RETURN; } } PP(pp_sgt) { djSP; tryAMAGICbinSET(sgt,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp > 0)); RETURN; } } PP(pp_sle) { djSP; tryAMAGICbinSET(sle,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp <= 0)); RETURN; } } PP(pp_sge) { djSP; tryAMAGICbinSET(sge,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETs(boolSV(cmp >= 0)); RETURN; } } PP(pp_seq) { djSP; tryAMAGICbinSET(seq,0); { dPOPTOPssrl; SETs(boolSV(sv_eq(left, right))); RETURN; } } PP(pp_sne) { djSP; tryAMAGICbinSET(sne,0); { dPOPTOPssrl; SETs(boolSV(!sv_eq(left, right))); RETURN; } } PP(pp_scmp) { djSP; dTARGET; tryAMAGICbin(scmp,0); { dPOPTOPssrl; int cmp = ((PL_op->op_private & OPpLOCALE) ? sv_cmp_locale(left, right) : sv_cmp(left, right)); SETi( cmp ); RETURN; } } PP(pp_bit_and) { djSP; dATARGET; tryAMAGICbin(band,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = SvIV(left) & SvIV(right); - SETi(BWi(value)); + IV i = SvIV(left) & SvIV(right); + SETi(i); } else { - UBW value = SvUV(left) & SvUV(right); - SETu(BWu(value)); + UV u = SvUV(left) & SvUV(right); + SETu(u); } } else { do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; } } PP(pp_bit_xor) { djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); - SETi(BWi(value)); + IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right); + SETi(i); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); - SETu(BWu(value)); + UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right); + SETu(u); } } else { do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; } } PP(pp_bit_or) { djSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { dPOPTOPssrl; if (SvNIOKp(left) || SvNIOKp(right)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); - SETi(BWi(value)); + IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right); + SETi(i); } else { - UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); - SETu(BWu(value)); + UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right); + SETu(u); } } else { do_vop(PL_op->op_type, TARG, left, right); SETTARG; } RETURN; } } PP(pp_negate) { djSP; dTARGET; tryAMAGICun(neg); { dTOPss; if (SvGMAGICAL(sv)) mg_get(sv); - if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN) - SETi(-SvIVX(sv)); - else if (SvNIOKp(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)) SETn(-SvNV(sv)); else if (SvPOKp(sv)) { STRLEN len; char *s = SvPV(sv, len); if (isIDFIRST(*s)) { sv_setpvn(TARG, "-", 1); sv_catsv(TARG, sv); } else if (*s == '+' || *s == '-') { 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; } else SETn(-SvNV(sv)); } RETURN; } PP(pp_not) { -#ifdef OVERLOAD djSP; tryAMAGICunSET(not); -#endif /* OVERLOAD */ *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); return NORMAL; } PP(pp_complement) { djSP; dTARGET; tryAMAGICun(compl); { dTOPss; if (SvNIOKp(sv)) { if (PL_op->op_private & HINT_INTEGER) { - IBW value = ~SvIV(sv); - SETi(BWi(value)); + IV i = ~SvIV(sv); + SETi(i); } else { - UBW value = ~SvUV(sv); - SETu(BWu(value)); + UV u = ~SvUV(sv); + SETu(u); } } else { register char *tmps; register long *tmpl; register I32 anum; STRLEN len; SvSetSV(TARG, sv); tmps = SvPV_force(TARG, len); anum = len; #ifdef LIBERAL for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) *tmps = ~*tmps; tmpl = (long*)tmps; for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) *tmpl = ~*tmpl; tmps = (char*)tmpl; #endif for ( ; anum > 0; anum--, tmps++) *tmps = ~*tmps; SETs(TARG); } RETURN; } } /* integer versions of some of the above */ PP(pp_i_multiply) { djSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { dPOPTOPiirl; SETi( left * right ); RETURN; } } PP(pp_i_divide) { djSP; dATARGET; tryAMAGICbin(div,opASSIGN); { dPOPiv; if (value == 0) - DIE("Illegal division by zero"); + DIE(aTHX_ "Illegal division by zero"); value = POPi / value; PUSHi( value ); RETURN; } } PP(pp_i_modulo) { djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) - DIE("Illegal modulus zero"); + DIE(aTHX_ "Illegal modulus zero"); SETi( left % right ); RETURN; } } PP(pp_i_add) { djSP; dATARGET; tryAMAGICbin(add,opASSIGN); { dPOPTOPiirl; SETi( left + right ); RETURN; } } PP(pp_i_subtract) { djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { dPOPTOPiirl; SETi( left - right ); RETURN; } } PP(pp_i_lt) { djSP; tryAMAGICbinSET(lt,0); { dPOPTOPiirl; SETs(boolSV(left < right)); RETURN; } } PP(pp_i_gt) { djSP; tryAMAGICbinSET(gt,0); { dPOPTOPiirl; SETs(boolSV(left > right)); RETURN; } } PP(pp_i_le) { djSP; tryAMAGICbinSET(le,0); { dPOPTOPiirl; SETs(boolSV(left <= right)); RETURN; } } PP(pp_i_ge) { djSP; tryAMAGICbinSET(ge,0); { dPOPTOPiirl; SETs(boolSV(left >= right)); RETURN; } } PP(pp_i_eq) { djSP; tryAMAGICbinSET(eq,0); { dPOPTOPiirl; SETs(boolSV(left == right)); RETURN; } } PP(pp_i_ne) { djSP; tryAMAGICbinSET(ne,0); { dPOPTOPiirl; SETs(boolSV(left != right)); RETURN; } } PP(pp_i_ncmp) { djSP; dTARGET; tryAMAGICbin(ncmp,0); { dPOPTOPiirl; I32 value; if (left > right) value = 1; else if (left < right) value = -1; else value = 0; SETi(value); RETURN; } } PP(pp_i_negate) { djSP; dTARGET; tryAMAGICun(neg); SETi(-TOPi); RETURN; } /* High falutin' math. */ PP(pp_atan2) { djSP; dTARGET; tryAMAGICbin(atan2,0); { dPOPTOPnnrl; - SETn(atan2(left, right)); + SETn(Perl_atan2(left, right)); RETURN; } } PP(pp_sin) { djSP; dTARGET; tryAMAGICun(sin); { - double value; + NV value; value = POPn; - value = sin(value); + value = Perl_sin(value); XPUSHn(value); RETURN; } } PP(pp_cos) { djSP; dTARGET; tryAMAGICun(cos); { - double value; + NV value; value = POPn; - value = cos(value); + value = Perl_cos(value); XPUSHn(value); RETURN; } } /* Support Configure command-line overrides for rand() functions. After 5.005, perhaps we should replace this by Configure support for drand48(), random(), or rand(). For 5.005, though, maintain compatibility by calling rand() but allow the user to override it. See INSTALL for details. --Andy Dougherty 15 July 1998 */ -#ifndef my_rand -# define my_rand rand +/* 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); #endif -#ifndef my_srand -# define my_srand srand -#endif PP(pp_rand) { djSP; dTARGET; - double value; + NV value; if (MAXARG < 1) value = 1.0; else value = POPn; if (value == 0.0) value = 1.0; - if (!srand_called) { - (void)my_srand((unsigned)seed()); - srand_called = TRUE; + if (!PL_srand_called) { + (void)seedDrand01((Rand_seed_t)seed()); + PL_srand_called = TRUE; } -#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 + value *= Drand01(); XPUSHn(value); RETURN; } PP(pp_srand) { djSP; UV anum; if (MAXARG < 1) anum = seed(); else anum = POPu; - (void)my_srand((unsigned)anum); - srand_called = TRUE; + (void)seedDrand01((Rand_seed_t)anum); + PL_srand_called = TRUE; EXTEND(SP, 1); RETPUSHYES; } STATIC U32 -seed(void) +S_seed(pTHX) { /* * 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 tings would bother to write it. + * if someone who knows about such things 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 anyting here, + * No numbers below come from careful analysis or anything 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. */ #if RANDBITS > 16 # define SEED_C1 1000003 #define SEED_C4 73819 #else # define SEED_C1 25747 #define SEED_C4 20639 #endif #define SEED_C2 3 #define SEED_C3 269 #define SEED_C5 26107 dTHR; #ifndef PERL_NO_DEV_RANDOM int fd; #endif U32 u; #ifdef VMS # include /* when[] = (low 32 bits, high 32 bits) of time since epoch * in 100-ns units, typically incremented ever 10 ms. */ unsigned int when[2]; #else # ifdef HAS_GETTIMEOFDAY struct timeval when; # else Time_t when; # endif #endif /* This test is an escape hatch, this symbol isn't set by Configure. */ #ifndef PERL_NO_DEV_RANDOM #ifndef PERL_RANDOM_DEVICE /* /dev/random isn't used by default because reads from it will block * if there isn't enough entropy available. You can compile with * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there * is enough real entropy to fill the seed. */ # define PERL_RANDOM_DEVICE "/dev/urandom" #endif fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); if (fd != -1) { if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) u = 0; PerlLIO_close(fd); if (u) return u; } #endif #ifdef VMS _ckvmssts(sys$gettim(when)); u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; #else # ifdef HAS_GETTIMEOFDAY gettimeofday(&when,(struct timezone *) 0); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; # else (void)time(&when); u = (U32)SEED_C1 * when; # endif #endif - u += SEED_C3 * (U32)getpid(); - u += SEED_C4 * (U32)(UV)PL_stack_sp; + u += SEED_C3 * (U32)PerlProc_getpid(); + u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); #ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */ - u += SEED_C5 * (U32)(UV)&when; + u += SEED_C5 * (U32)PTR2UV(&when); #endif return u; } PP(pp_exp) { djSP; dTARGET; tryAMAGICun(exp); { - double value; + NV value; value = POPn; - value = exp(value); + value = Perl_exp(value); XPUSHn(value); RETURN; } } PP(pp_log) { djSP; dTARGET; tryAMAGICun(log); { - double value; + NV value; value = POPn; if (value <= 0.0) { - SET_NUMERIC_STANDARD(); - DIE("Can't take log of %g", value); + RESTORE_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take log of %g", value); } - value = log(value); + value = Perl_log(value); XPUSHn(value); RETURN; } } PP(pp_sqrt) { djSP; dTARGET; tryAMAGICun(sqrt); { - double value; + NV value; value = POPn; if (value < 0.0) { - SET_NUMERIC_STANDARD(); - DIE("Can't take sqrt of %g", value); + RESTORE_NUMERIC_STANDARD(); + DIE(aTHX_ "Can't take sqrt of %g", value); } - value = sqrt(value); + value = Perl_sqrt(value); XPUSHn(value); RETURN; } } PP(pp_int) { djSP; dTARGET; { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) { iv = SvIVX(TOPs); SETi(iv); } else { if (value >= 0.0) - (void)modf(value, &value); + (void)Perl_modf(value, &value); else { - (void)modf(-value, &value); + (void)Perl_modf(-value, &value); value = -value; } iv = I_V(value); if (iv == value) SETi(iv); else SETn(value); } } RETURN; } PP(pp_abs) { djSP; dTARGET; tryAMAGICun(abs); { - double value = TOPn; + NV value = TOPn; IV iv; if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) && (iv = SvIVX(TOPs)) != IV_MIN) { if (iv < 0) iv = -iv; SETi(iv); } else { if (value < 0.0) value = -value; SETn(value); } } RETURN; } PP(pp_hex) { djSP; dTARGET; char *tmps; I32 argtype; STRLEN n_a; tmps = POPpx; - XPUSHu(scan_hex(tmps, 99, &argtype)); + XPUSHn(scan_hex(tmps, 99, &argtype)); RETURN; } PP(pp_oct) { djSP; dTARGET; - UV value; + NV value; I32 argtype; char *tmps; STRLEN n_a; tmps = POPpx; while (*tmps && isSPACE(*tmps)) tmps++; if (*tmps == '0') 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); - XPUSHu(value); + XPUSHn(value); RETURN; } /* String stuff. */ PP(pp_length) { djSP; dTARGET; - SETi( sv_len(TOPs) ); + SV *sv = TOPs; + + if (DO_UTF8(sv)) + SETi(sv_len_utf8(sv)); + else + SETi(sv_len(sv)); RETURN; } PP(pp_substr) { djSP; dTARGET; SV *sv; I32 len; STRLEN curlen; + STRLEN utfcurlen; I32 pos; I32 rem; I32 fail; I32 lvalue = PL_op->op_flags & OPf_MOD; char *tmps; I32 arybase = PL_curcop->cop_arybase; char *repl = 0; STRLEN repl_len; SvTAINTED_off(TARG); /* decontaminate */ + SvUTF8_off(TARG); /* decontaminate */ if (MAXARG > 2) { if (MAXARG > 3) { sv = POPs; repl = SvPV(sv, repl_len); } len = POPi; } pos = POPi; 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; fail = rem; if (MAXARG > 2) { if (len < 0) { rem += len; if (rem < 0) rem = 0; } else if (rem > len) rem = len; } } else { pos += curlen; if (MAXARG < 3) rem = curlen; else if (len >= 0) { rem = pos+len; if (rem > (I32)curlen) rem = curlen; } else { rem = curlen+len; if (rem < pos) rem = pos; } if (pos < 0) pos = 0; fail = rem; rem -= pos; } if (fail < 0) { - if (PL_dowarn || lvalue || repl) - warn("substr outside of string"); + if (lvalue || repl) + Perl_croak(aTHX_ "substr outside of string"); + if (ckWARN(WARN_SUBSTR)) + Perl_warner(aTHX_ WARN_SUBSTR, "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 (lvalue) { /* it's an lvalue! */ + if (repl) + sv_insert(sv, pos, rem, repl, repl_len); + else if (lvalue) { /* it's an lvalue! */ if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { STRLEN n_a; SvPV_force(sv,n_a); - if (PL_dowarn) - warn("Attempt to use reference as lvalue in substr"); + if (ckWARN(WARN_SUBSTR)) + Perl_warner(aTHX_ WARN_SUBSTR, + "Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only(sv); else sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } if (SvTYPE(TARG) < SVt_PVLV) { sv_upgrade(TARG, SVt_PVLV); sv_magic(TARG, Nullsv, 'x', Nullch, 0); } LvTYPE(TARG) = 'x'; if (LvTARG(TARG) != sv) { if (LvTARG(TARG)) SvREFCNT_dec(LvTARG(TARG)); LvTARG(TARG) = SvREFCNT_inc(sv); } LvTARGOFF(TARG) = pos; LvTARGLEN(TARG) = rem; } - else if (repl) - sv_insert(sv, pos, rem, repl, repl_len); } SPAGAIN; PUSHs(TARG); /* avoid SvSETMAGIC here */ RETURN; } PP(pp_vec) { djSP; dTARGET; register I32 size = POPi; 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 */ - 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; + 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); } - 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); - } - } + LvTYPE(TARG) = 'v'; + if (LvTARG(TARG) != src) { + if (LvTARG(TARG)) + SvREFCNT_dec(LvTARG(TARG)); + LvTARG(TARG) = SvREFCNT_inc(src); } - 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, (UV)retnum); + sv_setuv(TARG, do_vecget(src, offset, size)); PUSHs(TARG); RETURN; } PP(pp_index) { djSP; dTARGET; SV *big; SV *little; I32 offset; I32 retval; char *tmps; char *tmps2; STRLEN biglen; I32 arybase = PL_curcop->cop_arybase; if (MAXARG < 3) offset = 0; else offset = POPi - arybase; 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 + arybase; + retval = -1; else - retval = tmps2 - tmps + arybase; - PUSHi(retval); + retval = tmps2 - tmps; + if (retval > 0 && DO_UTF8(big)) + sv_pos_b2u(big, &retval); + PUSHi(retval + arybase); RETURN; } PP(pp_rindex) { djSP; dTARGET; SV *big; SV *little; STRLEN blen; STRLEN llen; - SV *offstr; I32 offset; I32 retval; char *tmps; char *tmps2; I32 arybase = PL_curcop->cop_arybase; if (MAXARG >= 3) - offstr = POPs; + offset = POPi; little = POPs; big = POPs; tmps2 = SvPV(little, llen); tmps = SvPV(big, blen); if (MAXARG < 3) offset = blen; - else - offset = SvIV(offstr) - arybase + llen; + else { + if (offset > 0 && DO_UTF8(big)) + sv_pos_u2b(big, &offset, 0); + offset = offset - arybase + llen; + } if (offset < 0) offset = 0; else if (offset > blen) offset = blen; if (!(tmps2 = rninstr(tmps, tmps + offset, tmps2, tmps2 + llen))) - retval = -1 + arybase; + retval = -1; else - retval = tmps2 - tmps + arybase; - PUSHi(retval); + retval = tmps2 - tmps; + if (retval > 0 && DO_UTF8(big)) + sv_pos_b2u(big, &retval); + PUSHi(retval + arybase); 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; PUSHTARG; RETURN; } PP(pp_ord) { djSP; dTARGET; - I32 value; - char *tmps; + UV value; STRLEN n_a; + SV *tmpsv = POPs; + U8 *tmps = (U8*)SvPVx(tmpsv,n_a); + I32 retlen; -#ifndef I286 - tmps = POPpx; - value = (I32) (*tmps & 255); -#else - I32 anum; - tmps = POPpx; - anum = (I32) *tmps; - value = (I32) (anum & 255); -#endif - XPUSHi(value); + if ((*tmps & 0x80) && DO_UTF8(tmpsv)) + value = utf8_to_uv(tmps, &retlen); + else + value = (UV)(*tmps & 255); + XPUSHu(value); RETURN; } 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++ = POPi; + *tmps++ = value; *tmps = '\0'; + SvUTF8_off(TARG); /* decontaminate */ (void)SvPOK_only(TARG); XPUSHs(TARG); RETURN; } PP(pp_crypt) { djSP; dTARGET; dPOPTOPssrl; STRLEN n_a; #ifdef HAS_CRYPT char *tmps = SvPV(left, n_a); #ifdef FCRYPT sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a))); #else sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a))); #endif #else - DIE( + DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif SETs(TARG); RETURN; } PP(pp_ucfirst) { djSP; SV *sv = TOPs; - register char *s; - STRLEN n_a; + register U8 *s; + STRLEN slen; - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } - s = SvPV_force(sv, n_a); - if (*s) { + 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); + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); - *s = toUPPER_LC(*s); + uv = toTITLE_LC_uni(uv); } else - *s = toUPPER(*s); + 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); + } + } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_lcfirst) { djSP; SV *sv = TOPs; - register char *s; - STRLEN n_a; + register U8 *s; + STRLEN slen; - if (!SvPADTMP(sv)) { - dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } - s = SvPV_force(sv, n_a); - if (*s) { + 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); + if (PL_op->op_private & OPpLOCALE) { TAINT; SvTAINTED_on(sv); - *s = toLOWER_LC(*s); + uv = toLOWER_LC_uni(uv); } else - *s = toLOWER(*s); - } + uv = toLOWER_utf8(s); + + tend = uv_to_utf8(tmpbuf, uv); - SETs(sv); + 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); + } + } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_uc) { djSP; SV *sv = TOPs; - register char *s; + register U8 *s; STRLEN len; - if (!SvPADTMP(sv)) { + if (DO_UTF8(sv)) { dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } + I32 ulen; + register U8 *d; + U8 *send; - 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(sv,len); + if (!len) { + SvUTF8_off(TARG); /* decontaminate */ + sv_setpvn(TARG, "", 0); + SETs(TARG); } else { - for (; s < send; s++) - *s = toUPPER(*s); + (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); } } + 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; + + 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); + } + } + } if (SvSMAGICAL(sv)) mg_set(sv); RETURN; } PP(pp_lc) { djSP; SV *sv = TOPs; - register char *s; + register U8 *s; STRLEN len; - if (!SvPADTMP(sv)) { + if (DO_UTF8(sv)) { dTARGET; - sv_setsv(TARG, sv); - sv = TARG; - SETs(sv); - } + I32 ulen; + register U8 *d; + U8 *send; - 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); + s = (U8*)SvPV(sv,len); + if (!len) { + SvUTF8_off(TARG); /* decontaminate */ + sv_setpvn(TARG, "", 0); + SETs(TARG); } else { - for (; s < send; s++) - *s = toLOWER(*s); + (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); } } + 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; + + 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)) mg_set(sv); RETURN; } PP(pp_quotemeta) { djSP; dTARGET; SV *sv = TOPs; STRLEN len; 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); - while (len--) { - if (!isALNUM(*s)) - *d++ = '\\'; - *d++ = *s++; + 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++; + } + } *d = '\0'; SvCUR_set(TARG, d - SvPVX(TARG)); (void)SvPOK_only(TARG); } else sv_setpvn(TARG, s, len); SETs(TARG); if (SvSMAGICAL(TARG)) mg_set(TARG); RETURN; } /* Arrays. */ PP(pp_aslice) { djSP; dMARK; dORIGMARK; register SV** svp; register AV* av = (AV*)POPs; register I32 lval = PL_op->op_flags & OPf_MOD; I32 arybase = PL_curcop->cop_arybase; I32 elem; if (SvTYPE(av) == SVt_PVAV) { if (lval && PL_op->op_private & OPpLVAL_INTRO) { I32 max = -1; for (svp = MARK + 1; svp <= SP; svp++) { elem = SvIVx(*svp); if (elem > max) max = elem; } if (max > AvMAX(av)) av_extend(av, max); } while (++MARK <= SP) { elem = SvIVx(*MARK); if (elem > 0) elem -= arybase; svp = av_fetch(av, elem, lval); if (lval) { if (!svp || *svp == &PL_sv_undef) - DIE(no_aelem, elem); + DIE(aTHX_ PL_no_aelem, elem); if (PL_op->op_private & OPpLVAL_INTRO) save_aelem(av, elem, svp); } *MARK = svp ? *svp : &PL_sv_undef; } } if (GIMME != G_ARRAY) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; } RETURN; } /* Associative arrays. */ PP(pp_each) { - djSP; dTARGET; + djSP; HV *hash = (HV*)POPs; HE *entry; I32 gimme = GIMME_V; I32 realhv = (SvTYPE(hash) == SVt_PVHV); PUTBACK; /* might clobber stack_sp */ entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash); SPAGAIN; EXTEND(SP, 2); if (entry) { PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */ if (gimme == G_ARRAY) { + SV *val; PUTBACK; /* might clobber stack_sp */ - sv_setsv(TARG, realhv ? - hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry)); + val = realhv ? + hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry); SPAGAIN; - PUSHs(TARG); + PUSHs(val); } } else if (gimme == G_SCALAR) RETPUSHUNDEF; RETURN; } PP(pp_values) { - return do_kv(ARGS); + return do_kv(); } PP(pp_keys) { - return do_kv(ARGS); + return do_kv(); } PP(pp_delete) { djSP; I32 gimme = GIMME_V; I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; SV *sv; HV *hv; if (PL_op->op_private & OPpSLICE) { dMARK; dORIGMARK; U32 hvtype; hv = (HV*)POPs; hvtype = SvTYPE(hv); - while (++MARK <= SP) { - if (hvtype == SVt_PVHV) + if (hvtype == SVt_PVHV) { /* hash element */ + while (++MARK <= SP) { sv = hv_delete_ent(hv, *MARK, discard, 0); - else - DIE("Not a HASH reference"); - *MARK = sv ? sv : &PL_sv_undef; + *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(aTHX_ "Not a HASH reference"); if (discard) SP = ORIGMARK; else if (gimme == G_SCALAR) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; } } else { SV *keysv = POPs; 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("Not a HASH reference"); + DIE(aTHX_ "Not a HASH reference"); if (!sv) sv = &PL_sv_undef; if (!discard) PUSHs(sv); } RETURN; } PP(pp_exists) { djSP; - SV *tmpsv = POPs; - HV *hv = (HV*)POPs; + 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; if (SvTYPE(hv) == SVt_PVHV) { if (hv_exists_ent(hv, tmpsv, 0)) RETPUSHYES; - } else if (SvTYPE(hv) == SVt_PVAV) { - if (avhv_exists_ent((AV*)hv, tmpsv, 0)) + } + 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 */ RETPUSHYES; - } else { - DIE("Not a HASH reference"); } + else { + DIE(aTHX_ "Not a HASH reference"); + } RETPUSHNO; } PP(pp_hslice) { djSP; dMARK; dORIGMARK; register HV *hv = (HV*)POPs; register I32 lval = PL_op->op_flags & OPf_MOD; I32 realhv = (SvTYPE(hv) == SVt_PVHV); if (!realhv && PL_op->op_private & OPpLVAL_INTRO) - DIE("Can't localize pseudo-hash element"); + DIE(aTHX_ "Can't localize pseudo-hash element"); if (realhv || SvTYPE(hv) == SVt_PVAV) { while (++MARK <= SP) { SV *keysv = *MARK; SV **svp; 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(no_helem, SvPV(keysv, n_a)); + DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a)); } if (PL_op->op_private & OPpLVAL_INTRO) save_helem(hv, keysv, svp); } *MARK = svp ? *svp : &PL_sv_undef; } } if (GIMME != G_ARRAY) { MARK = ORIGMARK; *++MARK = *SP; SP = MARK; } RETURN; } /* List operators. */ PP(pp_list) { djSP; dMARK; if (GIMME != G_ARRAY) { if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ else *MARK = &PL_sv_undef; SP = MARK; } RETURN; } PP(pp_lslice) { djSP; SV **lastrelem = PL_stack_sp; SV **lastlelem = PL_stack_base + POPMARK; SV **firstlelem = PL_stack_base + POPMARK + 1; register SV **firstrelem = lastlelem + 1; I32 arybase = PL_curcop->cop_arybase; I32 lval = PL_op->op_flags & OPf_MOD; I32 is_something_there = lval; register I32 max = lastrelem - lastlelem; register SV **lelem; register I32 ix; if (GIMME != G_ARRAY) { ix = SvIVx(*lastlelem); if (ix < 0) ix += max; else ix -= arybase; if (ix < 0 || ix >= max) *firstlelem = &PL_sv_undef; else *firstlelem = firstrelem[ix]; SP = firstlelem; RETURN; } if (max == 0) { SP = firstlelem - 1; RETURN; } for (lelem = firstlelem; lelem <= lastlelem; lelem++) { ix = SvIVx(*lelem); - if (ix < 0) { + if (ix < 0) ix += max; - if (ix < 0) - *lelem = &PL_sv_undef; - else if (!(*lelem = firstrelem[ix])) - *lelem = &PL_sv_undef; - } - else { + else ix -= arybase; - if (ix >= max || !(*lelem = firstrelem[ix])) + if (ix < 0 || ix >= max) + *lelem = &PL_sv_undef; + else { + is_something_there = TRUE; + if (!(*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; else SP = firstlelem - 1; RETURN; } PP(pp_anonlist) { djSP; dMARK; dORIGMARK; I32 items = SP - MARK; SV *av = sv_2mortal((SV*)av_make(items, MARK+1)); SP = ORIGMARK; /* av_make() might realloc stack_sp */ XPUSHs(av); RETURN; } PP(pp_anonhash) { djSP; dMARK; dORIGMARK; HV* hv = (HV*)sv_2mortal((SV*)newHV()); while (MARK < SP) { SV* key = *++MARK; SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); - else if (PL_dowarn) - warn("Odd number of elements in hash assignment"); + else if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; XPUSHs((SV*)hv); RETURN; } PP(pp_splice) { djSP; dMARK; dORIGMARK; register AV *ary = (AV*)*++MARK; register SV **src; register SV **dst; register I32 i; register I32 offset; register I32 length; I32 newlen; I32 after; I32 diff; 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; - perl_call_method("SPLICE",GIMME_V); + call_method("SPLICE",GIMME_V); LEAVE; SPAGAIN; RETURN; } SP++; if (++MARK < SP) { offset = i = SvIVx(*MARK); if (offset < 0) offset += AvFILLp(ary) + 1; else offset -= PL_curcop->cop_arybase; if (offset < 0) - DIE(no_aelem, i); + DIE(aTHX_ PL_no_aelem, i); if (++MARK < SP) { length = SvIVx(*MARK++); if (length < 0) { length += AvFILLp(ary) - offset + 1; if (length < 0) length = 0; } } else length = AvMAX(ary) + 1; /* close enough to infinity */ } else { offset = 0; length = AvMAX(ary) + 1; } if (offset > AvFILLp(ary) + 1) offset = AvFILLp(ary) + 1; after = AvFILLp(ary) + 1 - (offset + length); if (after < 0) { /* not that much array */ length += after; /* offset+length now in array */ after = 0; if (!AvALLOC(ary)) av_extend(ary, 0); } /* At this point, MARK .. SP-1 is our new LIST */ newlen = SP - MARK; diff = newlen - length; - if (newlen && !AvREAL(ary)) { - if (AvREIFY(ary)) - av_reify(ary); - else - assert(AvREAL(ary)); /* would leak, so croak */ - } + if (newlen && !AvREAL(ary) && AvREIFY(ary)) + av_reify(ary); if (diff < 0) { /* shrinking the area */ if (newlen) { New(451, tmparyval, newlen, SV*); /* so remember insertion */ Copy(MARK, tmparyval, newlen, SV*); } MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ MEXTEND(MARK, length); Copy(AvARRAY(ary)+offset, MARK, length, SV*); if (AvREAL(ary)) { EXTEND_MORTAL(length); for (i = length, dst = MARK; i; i--) { sv_2mortal(*dst); /* free them eventualy */ dst++; } } MARK += length - 1; } else { *MARK = AvARRAY(ary)[offset+length-1]; if (AvREAL(ary)) { sv_2mortal(*MARK); for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--) SvREFCNT_dec(*dst++); /* free them now */ } } AvFILLp(ary) += diff; /* pull up or down? */ if (offset < after) { /* easier to pull up */ if (offset) { /* esp. if nothing to pull */ src = &AvARRAY(ary)[offset-1]; dst = src - diff; /* diff is negative */ for (i = offset; i > 0; i--) /* can't trust Copy */ *dst-- = *src--; } dst = AvARRAY(ary); SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */ AvMAX(ary) += diff; } else { if (after) { /* anything to pull down? */ src = AvARRAY(ary) + offset + length; dst = src + diff; /* diff is negative */ Move(src, dst, after, SV*); } dst = &AvARRAY(ary)[AvFILLp(ary)+1]; /* avoid later double free */ } i = -diff; while (i) dst[--i] = &PL_sv_undef; if (newlen) { for (src = tmparyval, dst = AvARRAY(ary) + offset; newlen; newlen--) { *dst = NEWSV(46, 0); sv_setsv(*dst++, *src++); } Safefree(tmparyval); } } else { /* no, expanding (or same) */ if (length) { New(452, tmparyval, length, SV*); /* so remember deletion */ Copy(AvARRAY(ary)+offset, tmparyval, length, SV*); } if (diff > 0) { /* expanding */ /* push up or down? */ if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) { if (offset) { src = AvARRAY(ary); dst = src - diff; Move(src, dst, offset, SV*); } SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */ AvMAX(ary) += diff; AvFILLp(ary) += diff; } else { if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */ av_extend(ary, AvFILLp(ary) + diff); AvFILLp(ary) += diff; if (after) { dst = AvARRAY(ary) + AvFILLp(ary); src = dst - diff; for (i = after; i; i--) { *dst-- = *src--; } } } } for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) { *dst = NEWSV(46, 0); sv_setsv(*dst++, *src++); } MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ if (length) { Copy(tmparyval, MARK, length, SV*); if (AvREAL(ary)) { EXTEND_MORTAL(length); for (i = length, dst = MARK; i; i--) { sv_2mortal(*dst); /* free them eventualy */ dst++; } } Safefree(tmparyval); } MARK += length - 1; } else if (length--) { *MARK = tmparyval[length]; if (AvREAL(ary)) { sv_2mortal(*MARK); while (length-- > 0) SvREFCNT_dec(tmparyval[length]); } Safefree(tmparyval); } else *MARK = &PL_sv_undef; } SP = MARK; RETURN; } PP(pp_push) { djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; 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; - perl_call_method("PUSH",G_SCALAR|G_DISCARD); + call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; } else { /* Why no pre-extend of ary here ? */ for (++MARK; MARK <= SP; MARK++) { sv = NEWSV(51, 0); if (*MARK) sv_setsv(sv, *MARK); av_push(ary, sv); } } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); RETURN; } PP(pp_pop) { djSP; AV *av = (AV*)POPs; SV *sv = av_pop(av); if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; } PP(pp_shift) { djSP; AV *av = (AV*)POPs; SV *sv = av_shift(av); EXTEND(SP, 1); if (!sv) RETPUSHUNDEF; if (AvREAL(av)) (void)sv_2mortal(sv); PUSHs(sv); RETURN; } PP(pp_unshift) { djSP; dMARK; dORIGMARK; dTARGET; register AV *ary = (AV*)*++MARK; register SV *sv; 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; - perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD); + call_method("UNSHIFT",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; } else { av_unshift(ary, SP - MARK); while (MARK < SP) { sv = NEWSV(27, 0); sv_setsv(sv, *++MARK); (void)av_store(ary, i++, sv); } } SP = ORIGMARK; PUSHi( AvFILL(ary) + 1 ); RETURN; } PP(pp_reverse) { djSP; dMARK; register SV *tmp; SV **oldsp = SP; if (GIMME == G_ARRAY) { MARK++; while (MARK < SP) { tmp = *MARK; *MARK++ = *SP; *SP-- = tmp; } + /* safe as long as stack cannot get extended in the above */ SP = oldsp; } else { register char *up; register char *down; register I32 tmp; 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; *up++ = *down; *down-- = tmp; } (void)SvPOK_only(TARG); } SP = MARK + 1; SETTARG; } RETURN; } -STATIC SV * -mul128(SV *sv, U8 m) +STATIC SV * +S_mul128(pTHX_ SV *sv, U8 m) { STRLEN len; char *s = SvPV(sv, len); char *t; U32 i = 0; if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ - SV *tmpNew = newSVpv("0000000000", 10); + SV *tmpNew = newSVpvn("0000000000", 10); sv_catsv(tmpNew, sv); SvREFCNT_dec(sv); /* free old sv */ sv = tmpNew; s = SvPV(sv, len); } t = s + len - 1; while (!*t) /* trailing '\0'? */ t--; while (t > s) { i = ((*t - '0') << 7) + m; *(t--) = '0' + (i % 10); m = i / 10; } return (sv); } /* 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') #else /* Some other sort of character set - use memchr() so we don't match the null byte. */ -#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ') +#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') #endif PP(pp_unpack) { djSP; dPOPPOPssrl; - SV **oldsp = SP; + I32 start_sp_offset = SP - PL_stack_base; I32 gimme = GIMME_V; SV *sv; STRLEN llen; STRLEN rlen; register char *pat = SvPV(left, llen); register char *s = SvPV(right, rlen); char *strend = s + rlen; char *strbeg = s; register char *patend = pat + llen; I32 datumtype; register I32 len; register I32 bits; + register char *str; /* These must not be in registers: */ I16 ashort; int aint; I32 along; #ifdef HAS_QUAD Quad_t aquad; #endif U16 aushort; unsigned int auint; U32 aulong; #ifdef HAS_QUAD - unsigned Quad_t auquad; + Uquad_t auquad; #endif char *aptr; float afloat; double adouble; I32 checksum = 0; register U32 culong; - double cdouble; -#ifndef PERL_OBJECT - static char* bitcount = 0; -#endif + NV cdouble; int commas = 0; + int star; +#ifdef PERL_NATINT_PACK + int natint; /* native integer */ + int unatint; /* unsigned native integer */ +#endif if (gimme != G_ARRAY) { /* arrange to do first one only */ /*SUPPRESS 530*/ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ; if (strchr("aAZbBhHP", *patend) || *pat == '%') { patend++; while (isDIGIT(*patend) || *patend == '*') patend++; } else patend++; } 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: - croak("Invalid type in unpack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && PL_dowarn) - warn("Invalid type in unpack: '%c'", (int)datumtype); + if (commas++ == 0 && ckWARN(WARN_UNPACK)) + Perl_warner(aTHX_ WARN_UNPACK, + "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') len = 16; checksum = len; culong = 0; cdouble = 0; if (pat < patend) goto reparse; break; case '@': if (len > strend - strbeg) - DIE("@ outside of string"); + DIE(aTHX_ "@ outside of string"); s = strbeg + len; break; case 'X': if (len > s - strbeg) - DIE("X outside of string"); + DIE(aTHX_ "X outside of string"); s -= len; break; case 'x': if (len > strend - s) - DIE("x outside of string"); + DIE(aTHX_ "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': if (len > strend - s) len = strend - s; if (checksum) goto uchar_checksum; sv = NEWSV(35, len); sv_setpvn(sv, s, len); s += len; if (datumtype == 'A' || datumtype == 'Z') { aptr = s; /* borrow register */ if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ s = SvPVX(sv); while (*s) s++; } else { /* 'A' strips both nulls and spaces */ s = SvPVX(sv) + len - 1; while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) s--; *++s = '\0'; } SvCUR_set(sv, s - SvPVX(sv)); s = aptr; /* unborrow register */ } XPUSHs(sv_2mortal(sv)); break; case 'B': case 'b': - if (pat[-1] == '*' || len > (strend - s) * 8) + if (star || len > (strend - s) * 8) len = (strend - s) * 8; if (checksum) { - if (!bitcount) { - Newz(601, bitcount, 256, char); + if (!PL_bitcount) { + Newz(601, PL_bitcount, 256, char); for (bits = 1; bits < 256; 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]++; + 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]++; } } while (len >= 8) { - culong += bitcount[*(unsigned char*)s++]; + culong += PL_bitcount[*(unsigned char*)s++]; len -= 8; } if (len) { bits = *s; if (datumtype == 'b') { while (len-- > 0) { if (bits & 1) culong++; bits >>= 1; } } else { while (len-- > 0) { if (bits & 128) culong++; bits <<= 1; } } } break; } sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'b') { aint = len; for (len = 0; len < aint; len++) { if (len & 7) /*SUPPRESS 595*/ bits >>= 1; else bits = *s++; - *pat++ = '0' + (bits & 1); + *str++ = '0' + (bits & 1); } } else { aint = len; for (len = 0; len < aint; len++) { if (len & 7) bits <<= 1; else bits = *s++; - *pat++ = '0' + ((bits & 128) != 0); + *str++ = '0' + ((bits & 128) != 0); } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'H': case 'h': - if (pat[-1] == '*' || len > (strend - s) * 2) + if (star || len > (strend - s) * 2) len = (strend - s) * 2; sv = NEWSV(35, len + 1); SvCUR_set(sv, len); SvPOK_on(sv); - aptr = pat; /* borrow register */ - pat = SvPVX(sv); + str = SvPVX(sv); if (datumtype == 'h') { aint = len; for (len = 0; len < aint; len++) { if (len & 1) bits >>= 4; else bits = *s++; - *pat++ = PL_hexdigit[bits & 15]; + *str++ = PL_hexdigit[bits & 15]; } } else { aint = len; for (len = 0; len < aint; len++) { if (len & 1) bits <<= 4; else bits = *s++; - *pat++ = PL_hexdigit[(bits >> 4) & 15]; + *str++ = PL_hexdigit[(bits >> 4) & 15]; } } - *pat = '\0'; - pat = aptr; /* unborrow register */ + *str = '\0'; XPUSHs(sv_2mortal(sv)); break; case 'c': if (len > strend - s) len = strend - s; if (checksum) { while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; culong += aint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { aint = *s++; if (aint >= 128) /* fake up signed chars */ aint -= 256; sv = NEWSV(36, 0); sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } break; case 'C': if (len > strend - s) len = strend - s; if (checksum) { uchar_checksum: while (len-- > 0) { auint = *s++ & 255; culong += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { auint = *s++ & 255; sv = NEWSV(37, 0); sv_setiv(sv, (IV)auint); PUSHs(sv_2mortal(sv)); } } 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) { - while (len-- > 0) { - COPY16(s, &ashort); +#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); #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); - while (len-- > 0) { - COPY16(s, &ashort); +#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); #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) { - while (len-- > 0) { - COPY16(s, &aushort); - s += SIZE16; +#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; #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); - while (len-- > 0) { - COPY16(s, &aushort); - s += SIZE16; - sv = NEWSV(39, 0); +#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); #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, (IV)aushort); - PUSHs(sv_2mortal(sv)); + sv_setiv(sv, (UV)aushort); + PUSHs(sv_2mortal(sv)); + } } } break; case 'i': along = (strend - s) / sizeof(int); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); if (checksum > 32) - cdouble += (double)aint; + cdouble += (NV)aint; else culong += aint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &aint, 1, int); s += sizeof(int); sv = NEWSV(40, 0); #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 */ + * 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. + */ (aint) ? sv_setiv(sv, (IV)aint) : #endif sv_setiv(sv, (IV)aint); PUSHs(sv_2mortal(sv)); } } break; case 'I': along = (strend - s) / sizeof(unsigned int); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); if (checksum > 32) - cdouble += (double)auint; + cdouble += (NV)auint; else culong += auint; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &auint, 1, unsigned int); s += sizeof(unsigned int); sv = NEWSV(41, 0); #ifdef __osf__ /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) - * 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) - */ + * returns 1.84467440737096e+19 instead of 0xFFFFFFFF. + * See details few lines earlier. */ (auint) ? sv_setuv(sv, (UV)auint) : #endif sv_setuv(sv, (UV)auint); PUSHs(sv_2mortal(sv)); } } 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) { - while (len-- > 0) { - COPY32(s, &along); +#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); #if LONGSIZE > SIZE32 - if (along > 2147483647) - along -= 4294967296; + if (along > 2147483647) + along -= 4294967296; #endif - s += SIZE32; - if (checksum > 32) - cdouble += (double)along; - else - culong += along; + s += SIZE32; + if (checksum > 32) + cdouble += (NV)along; + else + culong += along; + } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); - while (len-- > 0) { - COPY32(s, &along); +#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); #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) { - while (len-- > 0) { - COPY32(s, &aulong); - s += SIZE32; +#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; #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 += (double)aulong; - else - culong += aulong; + if (checksum > 32) + cdouble += (NV)aulong; + else + culong += aulong; + } } } else { EXTEND(SP, len); EXTEND_MORTAL(len); - while (len-- > 0) { - COPY32(s, &aulong); - s += SIZE32; +#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; #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; case 'p': along = (strend - s) / sizeof(char*); if (len > along) len = along; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (sizeof(char*) > strend - s) break; else { Copy(s, &aptr, 1, char*); s += sizeof(char*); } sv = NEWSV(44, 0); if (aptr) sv_setpv(sv, aptr); PUSHs(sv_2mortal(sv)); } break; case 'w': EXTEND(SP, len); EXTEND_MORTAL(len); { UV auv = 0; U32 bytes = 0; while ((len > 0) && (s < strend)) { auv = (auv << 7) | (*s & 0x7f); if (!(*s++ & 0x80)) { bytes = 0; sv = NEWSV(40, 0); sv_setuv(sv, auv); PUSHs(sv_2mortal(sv)); len--; auv = 0; } else if (++bytes >= sizeof(UV)) { /* promote to string */ char *t; STRLEN n_a; - sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv); + sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv); while (s < strend) { sv = mul128(sv, *s & 0x7f); if (!(*s++ & 0x80)) { bytes = 0; break; } } t = SvPV(sv, n_a); while (*t == '0') t++; sv_chop(sv, t); PUSHs(sv_2mortal(sv)); len--; auv = 0; } } if ((s >= strend) && bytes) - croak("Unterminated compressed integer"); + DIE(aTHX_ "Unterminated compressed integer"); } break; case 'P': EXTEND(SP, 1); if (sizeof(char*) > strend - s) break; else { Copy(s, &aptr, 1, char*); s += sizeof(char*); } sv = NEWSV(44, 0); if (aptr) sv_setpvn(sv, aptr, len); PUSHs(sv_2mortal(sv)); break; #ifdef HAS_QUAD case 'q': along = (strend - s) / sizeof(Quad_t); if (len > along) len = along; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { if (s + sizeof(Quad_t) > strend) aquad = 0; else { Copy(s, &aquad, 1, Quad_t); s += sizeof(Quad_t); } sv = NEWSV(42, 0); if (aquad >= IV_MIN && aquad <= IV_MAX) sv_setiv(sv, (IV)aquad); else - sv_setnv(sv, (double)aquad); + sv_setnv(sv, (NV)aquad); PUSHs(sv_2mortal(sv)); } break; case 'Q': along = (strend - s) / sizeof(Quad_t); if (len > along) len = along; EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { - if (s + sizeof(unsigned Quad_t) > strend) + if (s + sizeof(Uquad_t) > strend) auquad = 0; else { - Copy(s, &auquad, 1, unsigned Quad_t); - s += sizeof(unsigned Quad_t); + Copy(s, &auquad, 1, Uquad_t); + s += sizeof(Uquad_t); } sv = NEWSV(43, 0); if (auquad <= UV_MAX) sv_setuv(sv, (UV)auquad); else - sv_setnv(sv, (double)auquad); + sv_setnv(sv, (NV)auquad); PUSHs(sv_2mortal(sv)); } break; #endif /* float and double added gnb@melba.bby.oz.au 22/11/89 */ case 'f': case 'F': along = (strend - s) / sizeof(float); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); cdouble += afloat; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &afloat, 1, float); s += sizeof(float); sv = NEWSV(47, 0); - sv_setnv(sv, (double)afloat); + sv_setnv(sv, (NV)afloat); PUSHs(sv_2mortal(sv)); } } break; case 'd': case 'D': along = (strend - s) / sizeof(double); if (len > along) len = along; if (checksum) { while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); cdouble += adouble; } } else { EXTEND(SP, len); EXTEND_MORTAL(len); while (len-- > 0) { Copy(s, &adouble, 1, double); s += sizeof(double); sv = NEWSV(48, 0); - sv_setnv(sv, (double)adouble); + sv_setnv(sv, (NV)adouble); PUSHs(sv_2mortal(sv)); } } break; case 'u': /* MKS: * Initialise the decode mapping. By using a table driven * algorithm, the code will be character-set independent * (and just as fast as doing character arithmetic) */ - if (uudmap['M'] == 0) { + if (PL_uudmap['M'] == 0) { int i; - for (i = 0; i < sizeof(uuemap); i += 1) - uudmap[uuemap[i]] = i; + for (i = 0; i < sizeof(PL_uuemap); i += 1) + PL_uudmap[(U8)PL_uuemap[i]] = i; /* * Because ' ' and '`' map to the same value, * we need to decode them both the same. */ - uudmap[' '] = 0; + PL_uudmap[' '] = 0; } along = (strend - s) * 3 / 4; sv = NEWSV(42, along); if (along) SvPOK_on(sv); while (s < strend && *s > ' ' && ISUUCHAR(*s)) { I32 a, b, c, d; char hunk[4]; hunk[3] = '\0'; - len = uudmap[*s++] & 077; + len = PL_uudmap[*(U8*)s++] & 077; while (len > 0) { if (s < strend && ISUUCHAR(*s)) - a = uudmap[*s++] & 077; + a = PL_uudmap[*(U8*)s++] & 077; else a = 0; if (s < strend && ISUUCHAR(*s)) - b = uudmap[*s++] & 077; + b = PL_uudmap[*(U8*)s++] & 077; else b = 0; if (s < strend && ISUUCHAR(*s)) - c = uudmap[*s++] & 077; + c = PL_uudmap[*(U8*)s++] & 077; else c = 0; if (s < strend && ISUUCHAR(*s)) - d = uudmap[*s++] & 077; + d = PL_uudmap[*(U8*)s++] & 077; else d = 0; hunk[0] = (a << 2) | (b >> 4); hunk[1] = (b << 4) | (c >> 2); hunk[2] = (c << 6) | d; sv_catpvn(sv, hunk, (len > 3) ? 3 : len); len -= 3; } if (*s == '\n') s++; else if (s[1] == '\n') /* possible checksum byte */ s += 2; } XPUSHs(sv_2mortal(sv)); break; } if (checksum) { sv = NEWSV(42, 0); if (strchr("fFdD", datumtype) || - (checksum > 32 && strchr("iIlLN", datumtype)) ) { - double trouble; + (checksum > 32 && strchr("iIlLNU", datumtype)) ) { + NV trouble; adouble = 1.0; while (checksum >= 16) { checksum -= 16; adouble *= 65536.0; } while (checksum >= 4) { checksum -= 4; adouble *= 16.0; } while (checksum--) adouble *= 2.0; along = (1 << checksum) - 1; while (cdouble < 0.0) cdouble += adouble; - cdouble = modf(cdouble / adouble, &trouble) * adouble; + cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; sv_setnv(sv, cdouble); } else { if (checksum < 32) { aulong = (1 << checksum) - 1; culong &= aulong; } sv_setuv(sv, (UV)culong); } XPUSHs(sv_2mortal(sv)); checksum = 0; } } - if (SP == oldsp && gimme == G_SCALAR) + if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR) PUSHs(&PL_sv_undef); RETURN; } STATIC void -doencodes(register SV *sv, register char *s, register I32 len) +S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) { char hunk[5]; - *hunk = uuemap[len]; + *hunk = PL_uuemap[len]; sv_catpvn(sv, hunk, 1); hunk[4] = '\0'; while (len > 2) { - 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))]; + 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))]; sv_catpvn(sv, hunk, 4); s += 3; len -= 3; } if (len > 0) { char r = (len > 1 ? s[1] : '\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]; + 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]; sv_catpvn(sv, hunk, 4); } sv_catpvn(sv, "\n", 1); } -STATIC SV * -is_an_int(char *s, STRLEN l) +STATIC SV * +S_is_an_int(pTHX_ char *s, STRLEN l) { - STRLEN n_a; - SV *result = newSVpv("", l); + STRLEN n_a; + SV *result = newSVpvn(s, l); char *result_c = SvPV(result, n_a); /* convenience */ char *out = result_c; bool skip = 1; bool ignore = 0; while (*s) { switch (*s) { case ' ': break; case '+': if (!skip) { SvREFCNT_dec(result); return (NULL); } break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': skip = 0; if (!ignore) { *(out++) = *s; } break; case '.': ignore = 1; break; default: SvREFCNT_dec(result); return (NULL); } s++; } *(out++) = '\0'; SvCUR_set(result, out - result_c); return (result); } +/* pnum must be '\0' terminated */ STATIC int -div128(SV *pnum, bool *done) - /* must be '\0' terminated */ - +S_div128(pTHX_ SV *pnum, bool *done) { STRLEN len; char *s = SvPV(pnum, len); int m = 0; int r = 0; char *t = s; *done = 1; while (*t) { int i; i = m * 10 + (*t - '0'); m = i & 0x7F; r = (i >> 7); /* r < 10 */ if (r) { *done = 0; } *(t++) = '0' + r; } *(t++) = '\0'; SvCUR_set(pnum, (STRLEN) (t - s)); return (m); } PP(pp_pack) { djSP; dMARK; dORIGMARK; dTARGET; register SV *cat = TARG; register I32 items; STRLEN fromlen; register char *pat = SvPVx(*++MARK, fromlen); register char *patend = pat + fromlen; register I32 len; I32 datumtype; SV *fromstr; /*SUPPRESS 442*/ static char null10[] = {0,0,0,0,0,0,0,0,0,0}; static char *space10 = " "; /* These must not be in registers: */ char achar; I16 ashort; int aint; unsigned int auint; I32 along; U32 aulong; #ifdef HAS_QUAD Quad_t aquad; - unsigned Quad_t auquad; + Uquad_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) { -#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no) + SV *lengthcode = Nullsv; +#define NEXTFROM ( lengthcode ? lengthcode : 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: - croak("Invalid type in pack: '%c'", (int)datumtype); + DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ - if (commas++ == 0 && PL_dowarn) - warn("Invalid type in pack: '%c'", (int)datumtype); + if (commas++ == 0 && ckWARN(WARN_PACK)) + Perl_warner(aTHX_ WARN_PACK, + "Invalid type in pack: '%c'", (int)datumtype); break; case '%': - DIE("%% may only be used in unpack"); + DIE(aTHX_ "%% may only be used in unpack"); case '@': len -= SvCUR(cat); if (len > 0) goto grow; len = -len; if (len > 0) goto shrink; break; case 'X': shrink: if (SvCUR(cat) < len) - DIE("X outside of string"); + DIE(aTHX_ "X outside of string"); SvCUR(cat) -= len; *SvEND(cat) = '\0'; break; case 'x': grow: while (len >= 10) { sv_catpvn(cat, null10, 10); len -= 10; } sv_catpvn(cat, null10, len); break; case 'A': case 'Z': case 'a': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); - if (pat[-1] == '*') + if (pat[-1] == '*') { len = fromlen; - if (fromlen > len) + if (datumtype == 'Z') + ++len; + } + if (fromlen >= len) { sv_catpvn(cat, aptr, len); + if (datumtype == 'Z') + *(SvEND(cat)-1) = '\0'; + } else { sv_catpvn(cat, aptr, fromlen); len -= fromlen; if (datumtype == 'A') { while (len >= 10) { sv_catpvn(cat, space10, 10); len -= 10; } sv_catpvn(cat, space10, len); } else { while (len >= 10) { sv_catpvn(cat, null10, 10); len -= 10; } sv_catpvn(cat, null10, len); } } break; case 'B': case 'b': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+7)/8; SvGROW(cat, SvCUR(cat) + 1); aptr = SvPVX(cat) + aint; if (len > fromlen) len = fromlen; aint = len; items = 0; if (datumtype == 'B') { for (len = 0; len++ < aint;) { - items |= *pat++ & 1; + items |= *str++ & 1; if (len & 7) items <<= 1; else { *aptr++ = items & 0xff; items = 0; } } } else { for (len = 0; len++ < aint;) { - if (*pat++ & 1) + if (*str++ & 1) items |= 128; if (len & 7) items >>= 1; else { *aptr++ = items & 0xff; items = 0; } } } if (aint & 7) { if (datumtype == 'B') items <<= 7 - (aint & 7); else items >>= 7 - (aint & 7); *aptr++ = items & 0xff; } - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; case 'H': case 'h': { - char *savepat = pat; + register char *str; I32 saveitems; fromstr = NEXTFROM; saveitems = items; - aptr = SvPV(fromstr, fromlen); + str = SvPV(fromstr, fromlen); if (pat[-1] == '*') len = fromlen; - pat = aptr; aint = SvCUR(cat); SvCUR(cat) += (len+1)/2; SvGROW(cat, SvCUR(cat) + 1); aptr = SvPVX(cat) + aint; if (len > fromlen) len = fromlen; aint = len; items = 0; if (datumtype == 'H') { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= ((*pat++ & 15) + 9) & 15; + if (isALPHA(*str)) + items |= ((*str++ & 15) + 9) & 15; else - items |= *pat++ & 15; + items |= *str++ & 15; if (len & 1) items <<= 4; else { *aptr++ = items & 0xff; items = 0; } } } else { for (len = 0; len++ < aint;) { - if (isALPHA(*pat)) - items |= (((*pat++ & 15) + 9) & 15) << 4; + if (isALPHA(*str)) + items |= (((*str++ & 15) + 9) & 15) << 4; else - items |= (*pat++ & 15) << 4; + items |= (*str++ & 15) << 4; if (len & 1) items >>= 4; else { *aptr++ = items & 0xff; items = 0; } } } if (aint & 1) *aptr++ = items & 0xff; - pat = SvPVX(cat) + SvCUR(cat); - while (aptr <= pat) + str = SvPVX(cat) + SvCUR(cat); + while (aptr <= str) *aptr++ = '\0'; - pat = savepat; items = saveitems; } break; case 'C': case 'c': while (len-- > 0) { fromstr = NEXTFROM; aint = SvIV(fromstr); achar = aint; 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': while (len-- > 0) { fromstr = NEXTFROM; afloat = (float)SvNV(fromstr); sv_catpvn(cat, (char *)&afloat, sizeof (float)); } break; case 'd': case 'D': while (len-- > 0) { fromstr = NEXTFROM; adouble = (double)SvNV(fromstr); sv_catpvn(cat, (char *)&adouble, sizeof (double)); } break; case 'n': while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTONS ashort = PerlSock_htons(ashort); #endif CAT16(cat, &ashort); } break; case 'v': while (len-- > 0) { fromstr = NEXTFROM; ashort = (I16)SvIV(fromstr); #ifdef HAS_HTOVS ashort = htovs(ashort); #endif CAT16(cat, &ashort); } 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': - while (len-- > 0) { - fromstr = NEXTFROM; - ashort = (I16)SvIV(fromstr); - CAT16(cat, &ashort); +#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); + } + } break; case 'I': while (len-- > 0) { fromstr = NEXTFROM; auint = SvUV(fromstr); sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); } break; case 'w': while (len-- > 0) { fromstr = NEXTFROM; - adouble = floor(SvNV(fromstr)); + adouble = Perl_floor(SvNV(fromstr)); if (adouble < 0) - croak("Cannot compress negative numbers"); + DIE(aTHX_ "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; auv >>= 7; } while (auv); buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ sv_catpvn(cat, in, (buf + sizeof(buf)) - in); } else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ char *from, *result, *in; SV *norm; STRLEN len; bool done; /* Copy string and check for compliance */ from = SvPV(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) - croak("can compress only unsigned integer"); + DIE(aTHX_ "can compress only unsigned integer"); New('w', result, len, char); in = result + len; done = FALSE; while (!done) *--in = div128(norm, &done) | 0x80; result[len - 1] &= 0x7F; /* clear continue bit */ sv_catpvn(cat, in, (result + len) - in); Safefree(result); SvREFCNT_dec(norm); /* free norm */ } else if (SvNOKp(fromstr)) { char buf[sizeof(double) * 2]; /* 8/7 <= 2 */ char *in = buf + sizeof(buf); do { double next = floor(adouble / 128); *--in = (unsigned char)(adouble - (next * 128)) | 0x80; if (--in < buf) /* this cannot happen ;-) */ - croak ("Cannot compress integer"); + DIE(aTHX_ "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 - croak("Cannot compress non integer"); + DIE(aTHX_ "Cannot compress non integer"); } break; case 'i': while (len-- > 0) { fromstr = NEXTFROM; aint = SvIV(fromstr); sv_catpvn(cat, (char*)&aint, sizeof(int)); } break; case 'N': while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); #ifdef HAS_HTONL aulong = PerlSock_htonl(aulong); #endif CAT32(cat, &aulong); } break; case 'V': while (len-- > 0) { fromstr = NEXTFROM; aulong = SvUV(fromstr); #ifdef HAS_HTOVL aulong = htovl(aulong); #endif CAT32(cat, &aulong); } break; case 'L': - while (len-- > 0) { - fromstr = NEXTFROM; - aulong = SvUV(fromstr); - CAT32(cat, &aulong); +#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); + } + } break; case 'l': - while (len-- > 0) { - fromstr = NEXTFROM; - along = SvIV(fromstr); - CAT32(cat, &along); +#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); + } + } break; #ifdef HAS_QUAD case 'Q': while (len-- > 0) { fromstr = NEXTFROM; - auquad = (unsigned Quad_t)SvIV(fromstr); - sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t)); + auquad = (Uquad_t)SvUV(fromstr); + sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); } break; case 'q': while (len-- > 0) { fromstr = NEXTFROM; aquad = (Quad_t)SvIV(fromstr); sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); } break; -#endif /* HAS_QUAD */ +#endif case 'P': len = 1; /* assume SV is correct length */ /* FALL THROUGH */ case 'p': while (len-- > 0) { fromstr = NEXTFROM; if (fromstr == &PL_sv_undef) aptr = NULL; else { STRLEN n_a; /* XXX better yet, could spirit away the string to * a safe spot and hang on to it until the result * of pack() (and all copies of the result) are * gone. */ - if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) - warn("Attempt to pack pointer to temporary value"); + if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) + || (SvPADTMP(fromstr) + && !SvREADONLY(fromstr)))) + { + Perl_warner(aTHX_ WARN_PACK, + "Attempt to pack pointer to temporary value"); + } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,n_a); else aptr = SvPV_force(fromstr,n_a); } sv_catpvn(cat, (char*)&aptr, sizeof(char*)); } break; case 'u': fromstr = NEXTFROM; aptr = SvPV(fromstr, fromlen); SvGROW(cat, fromlen * 4 / 3); if (len <= 1) len = 45; else len = len / 3 * 3; while (fromlen > 0) { I32 todo; if (fromlen > len) todo = len; else todo = fromlen; doencodes(cat, aptr, todo); fromlen -= todo; aptr += todo; } break; } } SvSETMAGIC(cat); SP = ORIGMARK; PUSHs(cat); RETURN; } #undef NEXTFROM PP(pp_split) { djSP; dTARG; AV *ary; register I32 limit = POPi; /* note, negative is forever */ SV *sv = POPs; STRLEN len; register char *s = SvPV(sv, len); char *strend = s + len; register PMOP *pm; register REGEXP *rx; register SV *dstr; register char *m; I32 iters = 0; I32 maxiters = (strend - s) + 10; I32 i; char *orig; I32 origlimit = limit; I32 realarray = 0; I32 base; AV *oldstack = PL_curstack; I32 gimme = GIMME_V; I32 oldsave = PL_savestack_ix; I32 make_mortal = 1; MAGIC *mg = (MAGIC *) NULL; #ifdef DEBUGGING Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*); #else pm = (PMOP*)POPs; #endif if (!pm || !s) - DIE("panic: do_split"); + DIE(aTHX_ "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) + if (pm->op_pmreplroot) { +#ifdef USE_ITHREADS + ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); +#else ary = GvAVn((GV*)pm->op_pmreplroot); +#endif + } else if (gimme != G_ARRAY) #ifdef USE_THREADS ary = (AV*)PL_curpad[0]; #else ary = GvAVn(PL_defgv); #endif /* USE_THREADS */ else ary = Nullav; if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) { realarray = 1; PUTBACK; 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 */ } /* temporarily switch stacks */ SWITCHSTACK(PL_curstack, ary); make_mortal = 0; } } base = SP - PL_stack_base; orig = s; if (pm->op_pmflags & PMf_SKIPWHITE) { if (pm->op_pmflags & PMf_LOCALE) { while (isSPACE_LC(*s)) s++; } else { while (isSPACE(*s)) s++; } } if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(PL_multiline); PL_multiline = pm->op_pmflags & PMf_MULTILINE; } if (!limit) limit = maxiters + 2; if (pm->op_pmflags & PMf_WHITE) { while (--limit) { m = s; while (m < strend && !((pm->op_pmflags & PMf_LOCALE) ? isSPACE_LC(*m) : isSPACE(*m))) ++m; if (m >= strend) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + 1; while (s < strend && ((pm->op_pmflags & PMf_LOCALE) ? isSPACE_LC(*s) : isSPACE(*s))) ++s; } } else if (strEQ("^", rx->precomp)) { while (--limit) { /*SUPPRESS 530*/ for (m = s; m < strend && *m != '\n'; m++) ; m++; if (m >= strend) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m; } } - else if (rx->check_substr && !rx->nparens + else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens && (rx->reganch & ROPT_CHECK_ALL) && !(rx->reganch & ROPT_ANCH)) { - i = SvCUR(rx->check_substr); - if (i == 1 && !SvTAIL(rx->check_substr)) { - i = *SvPVX(rx->check_substr); + 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); while (--limit) { /*SUPPRESS 530*/ - for (m = s; m < strend && *m != i; m++) ; + for (m = s; m < strend && *m != c; m++) ; if (m >= strend) break; dstr = NEWSV(30, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); s = m + 1; } } else { #ifndef lint while (s < strend && --limit && - (m=fbm_instr((unsigned char*)s, (unsigned char*)strend, - rx->check_substr, 0)) ) + (m = fbm_instr((unsigned char*)s, (unsigned char*)strend, + csv, PL_multiline ? FBMrf_MULTILINE : 0)) ) #endif { dstr = NEWSV(31, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); - s = m + i; + s = m + len; /* Fake \n at the end */ } } } else { maxiters += (strend - s) * rx->nparens; - while (s < strend && --limit && - CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0)) + 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)) { TAINT_IF(RX_MATCH_TAINTED(rx)); - if (rx->subbase - && rx->subbase != orig) { + if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { m = s; s = orig; - orig = rx->subbase; + orig = rx->subbeg; s = orig + (m - s); strend = s + (strend - m); } - m = rx->startp[0]; + m = rx->startp[0] + orig; dstr = NEWSV(32, m-s); sv_setpvn(dstr, s, m-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); if (rx->nparens) { for (i = 1; i <= rx->nparens; i++) { - s = rx->startp[i]; - m = rx->endp[i]; + s = rx->startp[i] + orig; + m = rx->endp[i] + orig; if (m && s) { dstr = NEWSV(33, m-s); sv_setpvn(dstr, s, m-s); } else dstr = NEWSV(33, 0); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); } } - s = rx->endp[0]; + s = rx->endp[0] + orig; } } LEAVE_SCOPE(oldsave); iters = (SP - PL_stack_base) - base; if (iters > maxiters) - DIE("Split loop"); + DIE(aTHX_ "Split loop"); /* keep field after final delim? */ if (s < strend || (iters && origlimit)) { dstr = NEWSV(34, strend-s); sv_setpvn(dstr, s, strend-s); if (make_mortal) sv_2mortal(dstr); XPUSHs(dstr); iters++; } else if (!origlimit) { while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) iters--, SP--; } if (realarray) { if (!mg) { SWITCHSTACK(ary, oldstack); if (SvSMAGICAL(ary)) { PUTBACK; mg_set((SV*)ary); SPAGAIN; } if (gimme == G_ARRAY) { EXTEND(SP, iters); Copy(AvARRAY(ary), SP + 1, iters, SV*); SP += iters; RETURN; } } else { PUTBACK; ENTER; - perl_call_method("PUSH",G_SCALAR|G_DISCARD); + call_method("PUSH",G_SCALAR|G_DISCARD); LEAVE; SPAGAIN; if (gimme == G_ARRAY) { /* EXTEND should not be needed - we just popped them */ EXTEND(SP, iters); for (i=0; i < iters; i++) { SV **svp = av_fetch(ary, i, FALSE); PUSHs((svp) ? *svp : &PL_sv_undef); } RETURN; } } } else { if (gimme == G_ARRAY) RETURN; } if (iters || !pm->op_pmreplroot) { GETTARGET; PUSHi(iters); RETURN; } RETPUSHUNDEF; } #ifdef USE_THREADS void -unlock_condpair(void *svv) +Perl_unlock_condpair(pTHX_ void *svv) { dTHR; MAGIC *mg = mg_find((SV*)svv, 'm'); if (!mg) - croak("panic: unlock_condpair unlocking non-mutex"); + Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex"); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) != thr) - croak("panic: unlock_condpair unlocking mutex that we don't own"); + Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own"); MgOWNER(mg) = 0; COND_SIGNAL(MgOWNERCONDP(mg)); - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n", - (unsigned long)thr, (unsigned long)svv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(svv));) MUTEX_UNLOCK(MgMUTEXP(mg)); } #endif /* USE_THREADS */ PP(pp_lock) { djSP; dTOPss; SV *retsv = sv; #ifdef USE_THREADS MAGIC *mg; if (SvROK(sv)) sv = SvRV(sv); mg = condpair_magic(sv); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) == thr) MUTEX_UNLOCK(MgMUTEXP(mg)); else { while (MgOWNER(mg)) COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; - DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n", - (unsigned long)thr, (unsigned long)sv);) + DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) MUTEX_UNLOCK(MgMUTEXP(mg)); - save_destructor(unlock_condpair, sv); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } #endif /* USE_THREADS */ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV || SvTYPE(retsv) == SVt_PVCV) { retsv = refto(retsv); } SETs(retsv); RETURN; } PP(pp_threadsv) { - djSP; #ifdef USE_THREADS + djSP; EXTEND(SP, 1); if (PL_op->op_private & OPpLVAL_INTRO) PUSHs(*save_threadsv(PL_op->op_targ)); else PUSHs(THREADSV(PL_op->op_targ)); RETURN; #else - DIE("tried to access per-thread data in non-threaded perl"); + DIE(aTHX_ "tried to access per-thread data in non-threaded perl"); #endif /* USE_THREADS */ } Index: head/contrib/perl5/utils/h2ph.PL =================================================================== --- head/contrib/perl5/utils/h2ph.PL (revision 62079) +++ head/contrib/perl5/utils/h2ph.PL (revision 62080) @@ -1,734 +1,737 @@ #!/usr/local/bin/perl +# $FreeBSD$ use Config; use File::Basename qw(basename dirname); use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # Wanted: $archlibexp # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. $origdir = cwd; chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; 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. print OUT <<"!GROK!THIS!"; $Config{startperl} eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; use Config; use File::Path qw(mkpath); use Getopt::Std; getopts('Dd:rlhaQ'); die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a); @inc_dirs = inc_dirs() if $opt_a; my $Exit = 0; 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; @isatype = split(' ',<-"); } else { ($outfile = $file) =~ s/\.h$/.ph/ || next; print "$file -> $outfile\n" unless $opt_Q; if ($file =~ m|^(.*)/|) { $dir = $1; mkpath "$Dest_dir/$dir"; } if ($opt_a) { # automagic mode: locate header file in @inc_dirs foreach (@inc_dirs) { chdir $_; last if -f $file; } } open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next); open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n"; } print OUT "require '_h2ph_pre.ph';\n\n"; while () { chop; while (/\\$/) { chop; $_ .= ; chop; } print OUT "# $_\n" if $opt_D; if (s:/\*:\200:g) { s:\*/:\201:g; s/\200[^\201]*\201//g; # delete single line comments if (s/\200.*//) { # begin multi-line comment? $_ .= '/*'; $_ .= ; redo; } } if (s/^\s*\#\s*//) { if (s/^define\s+(\w+)//) { $name = $1; $new = ''; s/\s+$//; if (s/^\(([\w,\s]*)\)//) { $args = $1; my $proto = '() '; if ($args ne '') { $proto = ''; foreach $arg (split(/,\s*/,$args)) { $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/; $curargs{$arg} = 1; } $args =~ s/\b(\w)/\$$1/g; $args = "local($args) = \@_;\n$t "; } s/^\s+//; expr(); $new =~ s/(["\\])/\\$1/g; #"]); $new = reindent($new); $args = reindent($args); if ($t ne '') { $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t, "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t, "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n"; } } else { print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n"; } %curargs = (); } else { s/^\s+//; expr(); $new = 1 if $new eq ''; $new = reindent($new); $args = reindent($args); if ($t ne '') { $new =~ s/(['\\])/\\$1/g; #']); if ($opt_h) { print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n"; $eval_index++; } else { print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n"; } } else { # Shunt around such directives as `#define FOO FOO': next if " \&$name" eq $new; print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n"; } } } elsif (/^(include|import)\s*[<"](.*)[>"]/) { ($incl = $2) =~ s/\.h$/.ph/; print OUT $t,"require '$incl';\n"; } elsif(/^include_next\s*[<"](.*)[>"]/) { ($incl = $1) =~ s/\.h$/.ph/; print OUT ($t, "eval {\n"); $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT ($t, "my(\%INCD) = map { \$INC{\$_} => 1 } ", "(grep { \$_ eq \"$incl\" } keys(\%INC));\n"); print OUT ($t, "my(\@REM) = map { \"\$_/$incl\" } ", "(grep { not exists(\$INCD{\"\$_/$incl\"})", "and -f \"\$_/$incl\" } \@INC);\n"); print OUT ($t, "require \"\$REM[0]\" if \@REM;\n"); $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT ($t, "};\n"); print OUT ($t, "warn(\$\@) if \$\@;\n"); } elsif (/^ifdef\s+(\w+)/) { print OUT $t,"if(defined(&$1)) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^ifndef\s+(\w+)/) { print OUT $t,"unless(defined(&$1)) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (s/^if\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; print OUT $t,"if($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (s/^elif\s+//) { $new = ''; $inif = 1; expr(); $inif = 0; $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n elsif($new) {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^else/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"} else {\n"; $tab += 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); } elsif (/^endif/) { $tab -= 4; $t = "\t" x ($tab / 8) . ' ' x ($tab % 8); print OUT $t,"}\n"; } elsif(/^undef\s+(\w+)/) { print OUT $t, "undef(&$1) if defined(&$1);\n"; } elsif(/^error\s+(".*")/) { print OUT $t, "die($1);\n"; } elsif(/^error\s+(.*)/) { print OUT $t, "die(\"", quotemeta($1), "\");\n"; } elsif(/^warning\s+(.*)/) { print OUT $t, "warn(\"", quotemeta($1), "\");\n"; } elsif(/^ident\s+(.*)/) { print OUT $t, "# $1\n"; } } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?\{/) { until(/\}.*?;/) { chomp($next = ); $_ .= $next; print OUT "# $next\n" if $opt_D; } s@/\*.*?\*/@@g; s/\s+/ /g; /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/; ($enum_subs = $3) =~ s/\s//g; @enum_subs = split(/,/, $enum_subs); $enum_val = -1; for $enum (@enum_subs) { ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/; $enum_value =~ s/^=//; $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1); if ($opt_h) { print OUT ($t, "eval(\"\\n#line $eval_index $outfile\\n", "sub $enum_name () \{ $enum_val; \}\") ", "unless defined(\&$enum_name);\n"); ++ $eval_index; } else { print OUT ($t, "eval(\"sub $enum_name () \{ $enum_val; \}\") ", "unless defined(\&$enum_name);\n"); } } } } print OUT "1;\n"; $is_converted{$file} = 1; queue_includes_from($file) if ($opt_a); } exit $Exit; sub reindent($) { my($text) = shift; $text =~ s/\n/\n /g; $text =~ s/ /\t/g; $text; } sub expr { if(keys(%curargs)) { my($joined_args) = join('|', keys(%curargs)); } while ($_ ne '') { s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of s/^(\s+)// && do {$new .= ' '; next;}; s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;}; s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;}; s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;}; s/^("(\\"|[^"])*")// && do {$new .= $1; next;}; s/^'((\\"|[^"])*)'// && do { if ($curargs{$1}) { $new .= "ord('\$$1')"; } else { $new .= "ord('$1')"; } next; }; # replace "sizeof(foo)" with "{foo}" # also, remove * (C dereference operator) to avoid perl syntax # problems. Where the %sizeof array comes from is anyone's # guess (c2ph?), but this at least avoids fatal syntax errors. # Behavior is undefined if sizeof() delimiters are unbalanced. # This code was modified to able to handle constructs like this: # sizeof(*(p)), which appear in the HP-UX 10.01 header files. s/^sizeof\s*\(// && do { $new .= '$sizeof'; my $lvl = 1; # already saw one open paren # tack { on the front, and skip it in the loop $_ = "{" . "$_"; my $index = 1; # find balanced closing paren while ($index <= length($_) && $lvl > 0) { $lvl++ if substr($_, $index, 1) eq "("; $lvl-- if substr($_, $index, 1) eq ")"; $index++; } # tack } on the end, replacing ) substr($_, $index - 1, 1) = "}"; # remove pesky * operators within the sizeof argument substr($_, 0, $index - 1) =~ s/\*//g; next; }; # Eliminate typedefs /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do { foreach (split /\s+/, $1) { # Make sure all the words are types, last unless ($isatype{$_} or $_ eq 'struct'); } s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them. }; # struct/union member, including arrays: s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do { $id = $1; $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g; $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args); while($id =~ /\[\s*([^\$\&\d\]]+)\]/) { my($index) = $1; $index =~ s/\s//g; if(exists($curargs{$index})) { $index = "\$$index"; } else { $index = "&$index"; } $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/; } $new .= " (\$$id)"; }; s/^([_a-zA-Z]\w*)// && do { $id = $1; if ($id eq 'struct') { s/^\s+(\w+)//; $id .= ' ' . $1; $isatype{$id} = 1; } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) { while (s/^\s+(\w+)//) { $id .= ' ' . $1; } $isatype{$id} = 1; } if ($curargs{$id}) { $new .= "\$$id"; $new .= '->' if /^[\[\{]/; } elsif ($id eq 'defined') { $new .= 'defined'; } elsif (/^\(/) { s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat $new .= " &$id"; } elsif ($isatype{$id}) { if ($new =~ /{\s*$/) { $new .= "'$id'"; } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) { $new =~ s/\(\s*$//; s/^[\s*]*\)//; } else { $new .= q(').$id.q('); } } else { if ($inif && $new !~ /defined\s*\($/) { $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)'; } elsif (/^\[/) { $new .= " \$$id"; } else { $new .= ' &' . $id; } } next; }; s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;}; } } # Handle recursive subdirectories without getting a grotesquely big stack. # Could this be implemented using File::Find? sub next_file { my $file; while (@ARGV) { $file = shift @ARGV; if ($file eq '-' or -f $file or -l $file) { return $file; } elsif (-d $file) { if ($opt_r) { expand_glob($file); } else { print STDERR "Skipping directory `$file'\n"; } } elsif ($opt_a) { return $file; } else { print STDERR "Skipping `$file': not a file or directory\n"; } } return undef; } # Put all the files in $directory into @ARGV for processing. sub expand_glob { my ($directory) = @_; $directory =~ s:/$::; opendir DIR, $directory; foreach (readdir DIR) { next if ($_ eq '.' or $_ eq '..'); # expand_glob() is going to be called until $ARGV[0] isn't a # directory; so push directories, and unshift everything else. if (-d "$directory/$_") { push @ARGV, "$directory/$_" } else { unshift @ARGV, "$directory/$_" } } closedir DIR; } # Given $file, a symbolic link to a directory in the C include directory, # make an equivalent symbolic link in $Dest_dir, if we can figure out how. # Otherwise, just duplicate the file or directory. sub link_if_possible { my ($dirlink) = @_; my $target = eval 'readlink($dirlink)'; if ($target =~ m:^\.\./: or $target =~ m:^/:) { # The target of a parent or absolute link could leave the $Dest_dir # hierarchy, so let's put all of the contents of $dirlink (actually, # the contents of $target) into @ARGV; as a side effect down the # line, $dirlink will get created as an _actual_ directory. expand_glob($dirlink); } else { if (-l "$Dest_dir/$dirlink") { unlink "$Dest_dir/$dirlink" or print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n"; } if (eval 'symlink($target, "$Dest_dir/$dirlink")') { print "Linking $target -> $Dest_dir/$dirlink\n"; # Make sure that the link _links_ to something: if (! -e "$Dest_dir/$target") { mkpath("$Dest_dir/$target", 0755) or print STDERR "Could not create $Dest_dir/$target/\n"; } } else { print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n"; } } } # Push all #included files in $file onto our stack, except for STDIN # and files we've already processed. sub queue_includes_from { my ($file) = @_; my $line; return if ($file eq "-"); open HEADER, $file or return; while (defined($line =
)) { while (/\\$/) { # Handle continuation lines chop $line; $line .=
; } if ($line =~ /^#\s*include\s+<(.*?)>/) { push(@ARGV, $1) unless $is_converted{$1}; } } close HEADER; } # Determine include directories; $Config{usrinc} should be enough for (all # non-GCC?) C compilers, but gcc uses an additional include directory. sub inc_dirs { my $from_gcc = `$Config{cc} -v 2>&1`; $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s; length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc}); } # Create "_h2ph_pre.ph", if it doesn't exist or was built by a different # version of h2ph. sub build_preamble_if_necessary { # Increment $VERSION every time this function is modified: - my $VERSION = 1; + my $VERSION = 2; my $preamble = "$Dest_dir/_h2ph_pre.ph"; # Can we skip building the preamble file? if (-r $preamble) { # Extract version number from first line of preamble: open PREAMBLE, $preamble or die "Cannot open $preamble: $!"; my $line = ; $line =~ /(\b\d+\b)/; close PREAMBLE or die "Cannot close $preamble: $!"; # Don't build preamble if a compatible preamble exists: return if $1 == $VERSION; } my (%define) = _extract_cc_defines(); open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!"; print PREAMBLE "# This file was created by h2ph version $VERSION\n"; foreach (sort keys %define) { if ($opt_D) { print PREAMBLE "# $_=$define{$_}\n"; } 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 $_() { \"", quotemeta($define{$_}), "\" } }\n\n"; } } close PREAMBLE or die "Cannot close $preamble: $!"; } # %Config contains information on macros that are pre-defined by the # system's compiler. We need this information to make the .ph files # function with perl as the .h files do with cc. sub _extract_cc_defines { my %define; my $allsymbols = join " ", @Config{ccsymbols, cppsymbols, cppccsymbols}; # Split compiler pre-definitions into `key=value' pairs: foreach (split /\s+/, $allsymbols) { - /(.*?)=(.*)/; - $define{$1} = $2; + /(.+?)=(.+)/ and $define{$1} = $2; if ($opt_D) { print STDERR "$_: $1 -> $2\n"; } } return %define; } 1; ############################################################################## __END__ =head1 NAME h2ph - convert .h C header files to .ph Perl header files =head1 SYNOPSIS B =head1 DESCRIPTION I converts any C header files specified to the corresponding Perl header file format. It is most easily run while in /usr/include: cd /usr/include; h2ph * sys/* or cd /usr/include; h2ph -r -l . The output files are placed in the hierarchy rooted at Perl's architecture dependent library directory. You can specify a different hierarchy with a B<-d> switch. If run with no arguments, filters standard input to standard output. =head1 OPTIONS =over 4 =item -d destination_dir Put the resulting B<.ph> files beneath B, instead of beneath the default Perl library location (C<$Config{'installarchlib'}>). =item -r Run recursively; if any of B are directories, then run I on all files in those directories (and their subdirectories, etc.). B<-r> and B<-a> are mutually exclusive. =item -a Run automagically; convert B, as well as any B<.h> files which they include. This option will search for B<.h> files in all directories which your C compiler ordinarily uses. B<-a> and B<-r> are mutually exclusive. =item -l Symbolic links will be replicated in the destination directory. If B<-l> is not specified, then links are skipped over. =item -h Put ``hints'' in the .ph files which will help in locating problems with I. In those cases when you B a B<.ph> file containing syntax errors, instead of the cryptic [ some error condition ] at (eval mmm) line nnn you will see the slightly more helpful [ some error condition ] at filename.ph line nnn However, the B<.ph> files almost double in size when built using B<-h>. =item -D Include the code from the B<.h> file as a comment in the B<.ph> file. This is primarily used for debugging I. =item -Q ``Quiet'' mode; don't print out the names of the files being converted. =back =head1 ENVIRONMENT No environment variables are used. =head1 FILES /usr/include/*.h /usr/include/sys/*.h etc. =head1 AUTHOR Larry Wall =head1 SEE ALSO perl(1) =head1 DIAGNOSTICS The usual warnings if it can't read or write the files involved. =head1 BUGS Doesn't construct the %sizeof array for you. It doesn't handle all C constructs, but it does attempt to isolate definitions inside evals so that you can get at the definitions that it can translate. It's only intended as a rough tool. You may need to dicker with the files produced. Doesn't run with C You have to run this program by hand; it's not run as part of the Perl installation. Doesn't handle complicated expressions built piecemeal, a la: enum { FIRST_VALUE, SECOND_VALUE, #ifdef ABC THIRD_VALUE #endif }; Doesn't necessarily locate all of your C compiler's internally-defined symbols. =cut !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir; Index: head/contrib/perl5/utils/perlbug.PL =================================================================== --- head/contrib/perl5/utils/perlbug.PL (revision 62079) +++ head/contrib/perl5/utils/perlbug.PL (revision 62080) @@ -1,1117 +1,1200 @@ #!/usr/local/bin/perl +# $FreeBSD$ 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 # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # $perlpath # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. $origdir = cwd; chdir dirname($0); $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; open OUT, ">$file" or die "Can't create $file: $!"; # extract patchlevel.h information -open PATCH_LEVEL, "<../patchlevel.h" or open PATCH_LEVEL, ") { last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/; } my @patches; while () { last if /^\s*}/; chomp; - s/^\s+,?"?//; - s/"?,?$//; + s/^\s+,?\s*"?//; + s/"?\s*,?$//; s/(['\\])/\\$1/g; push @patches, $_ unless $_ eq 'NULL'; } my $patch_desc = "'" . join("',\n '", @patches) . "'"; my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches; close PATCH_LEVEL; # TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is # used, compare $Config::config_sh with the stored version. If they differ then # append a list of individual differences to the bug report. 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 = '$] - $Config{cf_time}'; +my \$config_tag1 = '$extract_version - $Config{cf_time}'; my \$patchlevel_date = $patchlevel_date; my \$patch_tags = '$patch_tags'; my \@patches = ( $patch_desc ); !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; use Config; +use File::Spec; # keep perlbug Perl 5.005 compatible use Getopt::Std; use strict; sub paraprint; BEGIN { eval "use Mail::Send;"; $::HaveSend = ($@ eq ""); eval "use Mail::Util;"; $::HaveUtil = ($@ eq ""); }; -my $Version = "1.26"; +my $Version = "1.28"; # 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. # Changed in 1.08 to use correct address for sendmail. # Changed in 1.09 to close the REP file before calling it up in the editor. # Also removed some old comments duplicated elsewhere. # Changed in 1.10 to run under VMS without Mail::Send; also fixed # temp filename generation. # Changed in 1.11 to clean up some text and removed Mail::Send deactivator. # Changed in 1.12 to check for editor errors, make save/send distinction # clearer and add $ENV{REPLYTO}. # Changed in 1.13 to hopefully make it more difficult to accidentally # send mail # Changed in 1.14 to make the prompts a little more clear on providing # helpful information. Also let file read fail gracefully. # Changed in 1.15 to add warnings to stop people using perlbug for non-bugs. # Also report selected environment variables. # Changed in 1.16 to include @INC, and allow user to re-edit if no changes. # Changed in 1.17 Win32 support added. GSAR 97-04-12 # Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18 # Changed in 1.19 '-ok' default not '-v' # add local patch information # warn on '-ok' if this is an old system; add '-okay' # Changed in 1.20 Added patchlevel.h reading and version/config checks # Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05 # Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10 # Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt # Changed in 1.24 Added '-F' 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 # accounted for. # - Test -b option my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename, - $subject, $from, $verbose, $ed, $outfile, + $subject, $from, $verbose, $ed, $outfile, $Is_MacOS, $category, $severity, $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok); -my $config_tag2 = "$] - $Config{cf_time}"; +my $perl_version = $^V ? sprintf("v%vd", $^V) : $]; +my $config_tag2 = "$perl_version - $Config{cf_time}"; + Init(); if ($::opt_h) { Help(); exit; } if ($::opt_d) { Dump(*STDOUT); exit; } if (!-t STDIN && !($ok and not $::opt_n)) { paraprint < 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; }; # This comment is needed to notify metaconfig that we are # using the $perladmin, $cf_by, and $cf_time definitions. # -------- Configuration --------- # perlbug address $perlbug = 'perlbug@perl.com'; # Test address $testaddress = 'perlbug-test@perl.com'; # Target address $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug); # Users address, used in message and in Reply-To header $from = $::opt_r || ""; # Include verbose configuration information $verbose = $::opt_v || 0; # Subject of bug-report message $subject = $::opt_s || ""; # Send a file $usefile = ($::opt_f || 0); # File to send as report $file = $::opt_f || ""; # File to output to $outfile = $::opt_F || ""; # Body of report $body = $::opt_b || ""; # Editor $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 if ($::opt_n) { if (substr($::opt_n, 0, 2) eq 'ok' ) { $::opt_o = substr($::opt_n, 1); } else { Help(); exit(); } } # OK - send "OK" report for build on this system $ok = 0; if ($::opt_o) { if ($::opt_o eq 'k' or $::opt_o eq 'kay') { my $age = time - $patchlevel_date; if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) { my $date = localtime $patchlevel_date; print <<"EOF"; "perlbug -ok" and "perlbug -nok" do not report on Perl versions which are more than 60 days old. This Perl version was constructed on $date. If you really want to report this, use "perlbug -okay" or "perlbug -nokay". EOF exit(); } # force these options unless ($::opt_n) { $::opt_S = 1; # don't prompt for send $::opt_b = 1; # we have a body $body = "Perl reported to build OK on this system.\n"; } $::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 $] ${patch_tags}on" + . "OK: perl $perl_version ${patch_tags}on" ." $::Config{'archname'} $::Config{'osvers'} $subject"; + $category = "install"; + $severity = "none"; $ok = 1; } else { Help(); exit(); } } # Possible administrator addresses, in order of confidence # (Note that cf_email is not mentioned to metaconfig, since # we don't really want it. We'll just take it if we have to.) # # This has to be after the $ok stuff above because of the way # that $::opt_C is forced. $cc = $::opt_C ? "" : ( $::opt_c || $::Config{'perladmin'} || $::Config{'cf_email'} || $::Config{'cf_by'} ); # 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'} if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me && ($me eq $::Config{'cf_by'}); } # sub Init sub Query { # Explain what perlbug is unless ($ok) { paraprint <; my $err = 0; while ($subject !~ /\S/) { print "\nPlease enter a subject: "; $subject = <>; if ($err++ > 5) { die "Aborting.\n"; } } chop $subject; } # Prompt for return address, if needed unless ($from) { # Try and guess return address 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) { $domain = Mail::Util::maildomain(); } elsif ($Is_MSWin32) { $domain = $ENV{'USERDOMAIN'}; } else { require Sys::Hostname; $domain = Sys::Hostname::hostname(); } if ($domain) { if ($Is_VMS && !$::Config{'d_socket'}) { $guess = "$domain\:\:$me"; } else { $guess = "$me\@$domain" if $domain; } } } if ($guess) { unless ($ok) { paraprint <; chop $from; $from = $guess if $from eq ''; } } if ($from eq $cc or $me eq $cc) { # Try not to copy ourselves $cc = "yourself"; } # Prompt for administrator address, unless an override was given if( !$::opt_C and !$::opt_c ) { paraprint <; chop $entry; if ($entry ne "") { $cc = $entry; $cc = '' if $me eq $cc; } } $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i; $andcc = " and $cc" if $cc; # Prompt for editor, if no override is given editor: unless ($::opt_e || $::opt_f || $::opt_b) { paraprint <; chop $entry; $usefile = 0; if ($entry eq "file") { $usefile = 1; } elsif ($entry ne "") { $ed = $entry; } } + # 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(); # Prompt for file to read report from, if needed if ($usefile and !$file) { filename: paraprint <; chop $entry; if ($entry eq "") { paraprint <$filename"); my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success"; print REP <) { print REP $_ } close(F); } else { print REP <) { s/\s+//g; $REP{$_}++; } close(REP); } # sub Query sub Dump { local(*OUT) = @_; - print REP "\n---\n"; - print REP "This perlbug was built using Perl $config_tag1\n", + print OUT <; chop $entry; $ed = $entry unless $entry eq ''; } tryagain: - my $sts = system("$ed $filename"); + my $sts = system("$ed $filename") unless $Is_MacOS; + if ($Is_MacOS) { + require ExtUtils::MakeMaker; + ExtUtils::MM_MacOS::launch_file($filename); + paraprint <; + } if ($sts) { paraprint <; chop $entry; if ($entry ne "") { $ed = $entry; goto tryagain; } else { paraprint <) { s/\s+//g; $unseen++ if $_ ne '' and not exists $REP{$_}; } while ($unseen == 0) { paraprint <); if ($action =~ /^[re]/i) { # etry dit goto tryagain; } elsif ($action =~ /^[cq]/i) { # ancel, uit Cancel(); } } } # sub Edit sub Cancel { 1 while unlink($filename); # remove all versions under VMS print "\nCancelling.\n"; exit(0); } sub NowWhat { # Report is done, prompt for further action if( !$::opt_S ) { while(1) { paraprint <; chop $action; if ($action =~ /^(f|sa)/i) { # ile/ve print "\n\nName of file to save message in [perlbug.rep]: "; my $file = scalar <>; chop $file; $file = "perlbug.rep" if $file eq ""; unless (open(FILE, ">$file")) { print "\nError opening $file: $!\n\n"; goto retry; } open(REP, "<$filename"); print FILE "To: $address\nSubject: $subject\n"; print FILE "Cc: $cc\n" if $cc; print FILE "Reply-To: $from\n" if $from; print FILE "\n"; while () { print FILE } close(REP); close(FILE); print "\nMessage saved in `$file'.\n"; exit; } elsif ($action =~ /^(d|l|sh)/i ) { # isplay, ist, ow # Display the message open(REP, "<$filename"); while () { print $_ } close(REP); } elsif ($action =~ /^se/i) { # end # Send the message print "Are you certain you want to send this message?\n" . 'Please type "yes" if you are: '; my $reply = scalar ; chop $reply; if ($reply eq "yes") { last; } else { paraprint <dit, e-edit # edit the message Edit(); } elsif ($action =~ /^[qc]/i) { # ancel, uit Cancel(); } elsif ($action =~ /^s/) { paraprint <$outfile" or die "Couldn't open '$outfile': $!\n"; goto sendout; } if ($::HaveSend) { $msg = new Mail::Send Subject => $subject, To => $address; $msg->cc($cc) if $cc; $msg->add("Reply-To",$from) if $from; $fh = $msg->open; open(REP, "<$filename"); while () { print $fh $_ } close(REP); $fh->close; print "\nMessage sent.\n"; } elsif ($Is_VMS) { if ( ($address =~ /@/ and $address !~ /^\w+%"/) or ($cc =~ /@/ and $cc !~ /^\w+%"/) ) { my $prefix; foreach (qw[ IN MX SMTP UCX PONY WINS ], '') { $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"}; } $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/; $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/; } $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g; my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]); if ($sts) { die <) { print SENDMAIL $_ } close(REP); if (close(SENDMAIL)) { printf "\nMessage %s.\n", $outfile ? "saved" : "sent"; } else { warn "\nSendmail returned status '", $? >> 8, "'\n"; } } 1 while unlink($filename); # remove all versions under VMS } # sub Send sub Help { print <catfile($dir, $filename); + $filename = File::Spec->catfile($dir, $filename); } sub paraprint { my @paragraphs = split /\n{2,}/, "@_"; print "\n\n"; for (@paragraphs) { # implicit local $_ s/(\S)\s*\n/$1 /g; write; print "\n"; } } format STDOUT = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~ $_ . __END__ =head1 NAME perlbug - how to submit bug reports on Perl =head1 SYNOPSIS B S<[ B<-v> ]> S<[ B<-a> I
]> S<[ B<-s> I ]> S<[ B<-b> I | B<-f> I ]> S<[ B<-F> I ]> S<[ B<-r> I ]> S<[ B<-e> I ]> S<[ B<-c> I | B<-C> ]> S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]> B S<[ B<-v> ]> S<[ B<-r> I ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> =head1 DESCRIPTION A program to help generate bug reports about perl or the modules that come with it, and mail them. If you have found a bug with a non-standard port (one that was not part of the I), a binary distribution, or a non-standard module (such as Tk, CGI, etc), then please see the documentation that came with that distribution to determine the correct place to report bugs. C is designed to be used interactively. Normally no arguments will be needed. Simply run it, and follow the prompts. If you are unable to run B (most likely because you don't have a working setup to send mail that perlbug recognizes), you may have to compose your own report, and email it to B. You might find the B<-d> option useful to get summary information in that case. In any case, when reporting a bug, please make sure you have run through this checklist: =over 4 -=item What version of perl you are running? +=item What version of Perl you are running? Type C at the command line to find out. =item Are you running the latest released version of perl? 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 relevant). Be aware of the familiar traps that perl programmers of various hues fall into. See L. Check in L 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, some -features may not be implemented or work differently. +If you are on a non-UNIX platform check also L, as some +features may be unimplemented 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. =item Do you have a proper test case? The easier it is to reproduce your bug, the more likely it will be fixed, because if no one can duplicate the problem, no one can fix it. A good test case has most of these attributes: fewest possible number of lines; few dependencies on external commands, modules, or libraries; runs on most platforms unimpeded; and is self-documenting. A good test case is almost always a good candidate to be on the perl test suite. If you have the time, consider making your test case so that it will readily fit into the standard test suite. Remember also to include the B error messages, if any. "Perl complained something" is not an exact error message. If you get a core dump (or equivalent), you may use a debugger (B, B, 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, not +because it will most probably contain only the function names and not their arguments. If possible, recompile your Perl with debug info and reproduce the dump and the stack trace. =item Can you describe the bug in plain English? 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 analyse the -problem to the extent you feel qualified and report your discoveries. +problem helps a great deal. In other words, try to analyze the +problem (to the extent you can) and report your discoveries. =item Can you fix the bug yourself? A bug report which I will almost definitely be fixed. Use the C program to generate your patches (C is being maintained by the GNU folks as part of the B package, so you should be able to get it from any of the GNU software repositories). If you do submit a patch, the cool-dude counter at perlbug@perl.com will register you as a savior of the world. Your patch may be returned with requests for changes, or requests for more detailed explanations about your fix. Here are some clues for creating quality patches: Use the B<-c> or B<-u> switches to the diff program (to create a so-called context or unified diff). Make sure the patch is not reversed (the first argument to diff is typically the original file, the second argument your changed file). Make sure you test your patch by applying it with the C program before you send it on its way. Try to follow the same style as the code you are trying to patch. Make sure your patch really does work (C, if the thing you're patching supports it). =item Can you use C to submit the report? B will, amongst other things, ensure your report includes crucial information about your version of perl. If C is unable to mail your report after you have typed it in, you may have to compose the message yourself, add the output produced by C and email it to B. If, for some reason, you cannot run C at all on your system, be sure to include the entire output produced by running C (note the uppercase V). Whether you use C or send the email manually, please make -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. +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. =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 C file in any development releases since the time you submitted the bug, and encourage the maintainers with kind words (but never any flames!). Feel free to resend your bug report if the next released version of perl comes out and your bug is still present. =head1 OPTIONS =over 8 =item B<-a> Address to send the report to. Defaults to `perlbug@perl.com'. =item B<-b> Body of the report. If not included on the command line, or in a file with B<-f>, you will get a chance to edit the message. =item B<-C> Don't send copy to administrator. =item B<-c> Address to send copy of report to. Defaults to the address of the local perl administrator (recorded when perl was built). =item B<-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 B<-v> to get more complete data. =item B<-e> Editor to use. =item B<-f> File containing the body of the report. Use this to quickly send a prepared message. =item B<-F> File to output the results to instead of sending as an email. Useful particularly when running perlbug on a machine with no direct internet connection. =item B<-h> Prints a brief summary of the options. =item B<-ok> Report successful build on this system to perl porters. Forces B<-S> and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only prompts for a return address if it cannot guess it (for use with B). Honors return address specified with B<-r>. You can use this with B<-v> to get more complete data. Only makes a report if this system is less than 60 days old. =item B<-okay> As B<-ok> except it will report on older systems. =item B<-nok> Report unsuccessful build on this system. Forces B<-C>. Forces and supplies a value for B<-s>, then requires you to edit the report and say what went wrong. Alternatively, a prepared report may be supplied using B<-f>. Only prompts for a return address if it cannot guess it (for use with B). Honors return address specified with B<-r>. You can use this with B<-v> to get more complete data. Only makes a report if this system is less than 60 days old. =item B<-nokay> As B<-nok> except it will report on older systems. =item B<-r> Your return address. The program will ask you to confirm its default if you don't use this option. =item B<-S> Send without asking for confirmation. =item B<-s> Subject to include with the message. You will be prompted if you don't supply one on the command line. =item B<-t> Test mode. The target address defaults to `perlbug-test@perl.com'. =item B<-v> Include verbose configuration data in the report. =back =head1 AUTHORS Kenneth Albanowski (Ekjahds@kjahds.comE), subsequently Itored -by Gurusamy Sarathy (Egsar@umich.eduE), Tom Christiansen +by Gurusamy Sarathy (Egsar@activestate.comE), Tom Christiansen (Etchrist@perl.comE), Nathan Torkington (Egnat@frii.comE), Charles F. Randall (Ecfr@pobox.comE), Mike Guy (Emjtg@cam.a.ukE), Dominic Dunlop (Edomo@computer.orgE), -Hugo van der Sanden (Ehv@crypt0.demon.co.ukE), and -Jarkko Hietaniemi (Ejhi@iki.fiE). +Hugo van der Sanden (Ehv@crypt0.demon.co.ukE), +Jarkko Hietaniemi (Ejhi@iki.fiE), Chris Nandor +(Epudge@pobox.comE), Jon Orwant (Eorwant@media.mit.eduE, +and Richard Foley (Erichard@rfi.netE). =head1 SEE ALSO perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1), diff(1), patch(1), dbx(1), gdb(1) =head1 BUGS None known (guess what must have been used to report them?) =cut !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir;