X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=84670ba9c05a9af3896d6a380b04b870b269739e;hb=6a1b87e5041a5273b1c9d83ca925b79765943e03;hp=1c9369135bbddc913ba4769bbfcb070a29ff52e6;hpb=ddcf38b7f9d5581245fd5ce960320c0768ea6d39;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 1c93691..84670ba 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-1994, Larry Wall + * Copyright (c) 1991-1997, 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. @@ -19,6 +19,10 @@ #include #endif +#ifndef SIG_ERR +# define SIG_ERR ((Sighandler_t) -1) +#endif + /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include @@ -42,13 +46,17 @@ # include #endif +#ifdef I_SYS_WAIT +# include +#endif + #define FLUSH #ifdef LEAKTEST static void xstat _((void)); #endif -#ifndef safemalloc +#ifndef MYMALLOC /* paranoid version of malloc */ @@ -60,19 +68,15 @@ static void xstat _((void)); Malloc_t safemalloc(size) -#ifdef MSDOS -unsigned long size; -#else MEM_SIZE size; -#endif /* MSDOS */ { Malloc_t ptr; -#ifdef MSDOS +#ifdef HAS_64K_LIMIT if (size > 0xffff) { PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } -#endif /* MSDOS */ +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0) croak("panic: malloc"); @@ -99,23 +103,20 @@ MEM_SIZE size; Malloc_t saferealloc(where,size) Malloc_t where; -#ifndef MSDOS MEM_SIZE size; -#else -unsigned long size; -#endif /* MSDOS */ { Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) Malloc_t realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ -#ifdef MSDOS - if (size > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; - my_exit(1); - } -#endif /* MSDOS */ +#ifdef HAS_64K_LIMIT + if (size > 0xffff) { + PerlIO_printf(PerlIO_stderr(), + "Reallocation too large: %lx\n", size) FLUSH; + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ if (!where) croak("Null realloc"); #ifdef DEBUGGING @@ -149,7 +150,7 @@ unsigned long size; /* safe version of free */ -void +Free_t safefree(where) Malloc_t where; { @@ -173,23 +174,24 @@ MEM_SIZE size; { Malloc_t ptr; -#ifdef MSDOS - if (size * count > 0xffff) { - PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; - my_exit(1); - } -#endif /* MSDOS */ +#ifdef HAS_64K_LIMIT + if (size * count > 0xffff) { + PerlIO_printf(PerlIO_stderr(), + "Allocation too large: %lx\n", size * count) FLUSH; + my_exit(1); + } +#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((long)size < 0 || (long)count < 0) croak("panic: calloc"); #endif + size *= count; + ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #if !(defined(I286) || defined(atarist)) DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #else DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #endif - size *= count; - ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ if (ptr != Nullch) { memset((void*)ptr, 0, size); return ptr; @@ -203,7 +205,7 @@ MEM_SIZE size; /*NOTREACHED*/ } -#endif /* !safemalloc */ +#endif /* !MYMALLOC */ #ifdef LEAKTEST @@ -404,20 +406,135 @@ char *lend; return Nullch; } -/* Initialize the fold[] array. */ -int -perl_init_fold() +/* + * Set up for a new ctype locale. + */ +void +perl_new_ctype(newctype) + char *newctype; +{ +#ifdef USE_LOCALE_CTYPE + + int i; + + for (i = 0; i < 256; i++) { + if (isUPPER_LC(i)) + fold_locale[i] = toLOWER_LC(i); + else if (isLOWER_LC(i)) + fold_locale[i] = toUPPER_LC(i); + else + fold_locale[i] = i; + } + +#endif /* USE_LOCALE_CTYPE */ +} + +/* + * Set up for a new collation locale. + */ +void +perl_new_collate(newcoll) + char *newcoll; +{ +#ifdef USE_LOCALE_COLLATE + + if (! newcoll) { + if (collation_name) { + ++collation_ix; + Safefree(collation_name); + collation_name = NULL; + collation_standard = TRUE; + collxfrm_base = 0; + collxfrm_mult = 2; + } + return; + } + + if (! collation_name || strNE(collation_name, newcoll)) { + ++collation_ix; + Safefree(collation_name); + collation_name = savepv(newcoll); + collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); + + { + /* 2: at most so many chars ('a', 'b'). */ + /* 50: surely no system expands a char more. */ +#define XFRMBUFSIZE (2 * 50) + char xbuf[XFRMBUFSIZE]; + Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); + Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); + SSize_t mult = fb - fa; + if (mult < 1) + croak("strxfrm() gets absurd"); + collxfrm_base = (fa > mult) ? (fa - mult) : 0; + collxfrm_mult = mult; + } + } + +#endif /* USE_LOCALE_COLLATE */ +} + +/* + * Set up for a new numeric locale. + */ +void +perl_new_numeric(newnum) + char *newnum; +{ +#ifdef USE_LOCALE_NUMERIC + + if (! newnum) { + if (numeric_name) { + Safefree(numeric_name); + numeric_name = NULL; + numeric_standard = TRUE; + numeric_local = TRUE; + } + return; + } + + if (! numeric_name || strNE(numeric_name, newnum)) { + Safefree(numeric_name); + numeric_name = savepv(newnum); + numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); + numeric_local = TRUE; + } + +#endif /* USE_LOCALE_NUMERIC */ +} + +void +perl_set_numeric_standard() +{ +#ifdef USE_LOCALE_NUMERIC + + if (! numeric_standard) { + setlocale(LC_NUMERIC, "C"); + numeric_standard = TRUE; + numeric_local = FALSE; + } + +#endif /* USE_LOCALE_NUMERIC */ +} + +void +perl_set_numeric_local() { - int i; +#ifdef USE_LOCALE_NUMERIC + + if (! numeric_local) { + setlocale(LC_NUMERIC, numeric_name); + numeric_standard = FALSE; + numeric_local = TRUE; + } - for (i = 0; i < 256; i++) { - if (isUPPER(i)) fold[i] = toLOWER(i); - else if (isLOWER(i)) fold[i] = toUPPER(i); - else fold[i] = i; - } +#endif /* USE_LOCALE_NUMERIC */ } -/* Initialize locale (and the fold[] array).*/ + +/* + * Initialize locale awareness. + */ int perl_init_i18nl10n(printwarn) int printwarn; @@ -428,175 +545,298 @@ perl_init_i18nl10n(printwarn) * 0 = fallback to C locale, * -1 = fallback to C locale failed */ -#if defined(HAS_SETLOCALE) - char * lc_all = getenv("LC_ALL"); - char * lc_ctype = getenv("LC_CTYPE"); - char * lc_collate = getenv("LC_COLLATE"); - char * lang = getenv("LANG"); - int setlocale_failure = 0; - -#define SETLOCALE_LC_CTYPE 0x01 -#define SETLOCALE_LC_COLLATE 0x02 - -#ifdef LC_CTYPE - if (setlocale(LC_CTYPE, "") == 0) - setlocale_failure |= SETLOCALE_LC_CTYPE; -#endif -#ifdef LC_COLLATE - if (setlocale(LC_COLLATE, "") == 0) - setlocale_failure |= SETLOCALE_LC_COLLATE; - else - lc_collate_active = 1; -#endif - - if (setlocale_failure && (lc_all || lang)) { - char *perl_badlang; - - if (printwarn > 1 || - printwarn && - (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) { - - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Setting locale failed for the categories:\n\t"); -#ifdef LC_CTYPE - if (setlocale_failure & SETLOCALE_LC_CTYPE) +#ifdef USE_LOCALE + +#ifdef USE_LOCALE_CTYPE + char *curctype = NULL; +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + char *curcoll = NULL; +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + char *curnum = NULL; +#endif /* USE_LOCALE_NUMERIC */ + char *lc_all = getenv("LC_ALL"); + char *lang = getenv("LANG"); + bool setlocale_failure = FALSE; + +#ifdef LOCALE_ENVIRON_REQUIRED + + /* + * Ultrix setlocale(..., "") fails if there are no environment + * variables from which to get a locale name. + */ + + bool done = FALSE; + +#ifdef LC_ALL + if (lang) { + if (setlocale(LC_ALL, "")) + done = TRUE; + else + setlocale_failure = TRUE; + } + if (!setlocale_failure) +#endif /* LC_ALL */ + { +#ifdef USE_LOCALE_CTYPE + if (! (curctype = setlocale(LC_CTYPE, + (!done && (lang || getenv("LC_CTYPE"))) + ? "" : Nullch))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! (curcoll = setlocale(LC_COLLATE, + (!done && (lang || getenv("LC_COLLATE"))) + ? "" : Nullch))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! (curnum = setlocale(LC_NUMERIC, + (!done && (lang || getenv("LC_NUMERIC"))) + ? "" : Nullch))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_NUMERIC */ + } + +#else /* !LOCALE_ENVIRON_REQUIRED */ + +#ifdef LC_ALL + + if (! setlocale(LC_ALL, "")) + setlocale_failure = TRUE; + else { +#ifdef USE_LOCALE_CTYPE + curctype = setlocale(LC_CTYPE, Nullch); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + curcoll = setlocale(LC_COLLATE, Nullch); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + curnum = setlocale(LC_NUMERIC, Nullch); +#endif /* USE_LOCALE_NUMERIC */ + } + +#else /* !LC_ALL */ + +#ifdef USE_LOCALE_CTYPE + if (! (curctype = setlocale(LC_CTYPE, ""))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! (curcoll = setlocale(LC_COLLATE, ""))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! (curnum = setlocale(LC_NUMERIC, ""))) + setlocale_failure = TRUE; +#endif /* USE_LOCALE_NUMERIC */ + +#endif /* LC_ALL */ + +#endif /* !LOCALE_ENVIRON_REQUIRED */ + + if (setlocale_failure) { + char *p; + bool locwarn = (printwarn > 1 || + printwarn && + (!(p = getenv("PERL_BADLANG")) || atoi(p))); + + if (locwarn) { +#ifdef LC_ALL + PerlIO_printf(PerlIO_stderr(), - "LC_CTYPE "); -#endif -#ifdef LC_COLLATE - if (setlocale_failure & SETLOCALE_LC_COLLATE) + "perl: warning: Setting locale failed.\n"); + +#else /* !LC_ALL */ + PerlIO_printf(PerlIO_stderr(), - "LC_COLLATE "); -#endif - PerlIO_printf(PerlIO_stderr(), - "\n"); + "perl: warning: Setting locale failed for the categories:\n\t"); +#ifdef USE_LOCALE_CTYPE + if (! curctype) + PerlIO_printf(PerlIO_stderr(), "LC_CTYPE "); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (! curcoll) + PerlIO_printf(PerlIO_stderr(), "LC_COLLATE "); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (! curnum) + PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC "); +#endif /* USE_LOCALE_NUMERIC */ + PerlIO_printf(PerlIO_stderr(), "\n"); + +#endif /* LC_ALL */ PerlIO_printf(PerlIO_stderr(), - "perl: warning: Please check that your locale settings:\n"); - - PerlIO_printf(PerlIO_stderr(), - "\tLC_ALL = %c%s%c,\n", - lc_all ? '"' : '(', - lc_all ? lc_all : "unset", - lc_all ? '"' : ')' - ); -#ifdef LC_CTYPE - if (setlocale_failure & SETLOCALE_LC_CTYPE) + "perl: warning: Please check that your locale settings:\n"); + PerlIO_printf(PerlIO_stderr(), - "\tLC_CTYPE = %c%s%c,\n", - lc_ctype ? '"' : '(', - lc_ctype ? lc_ctype : "unset", - lc_ctype ? '"' : ')' - ); -#endif -#ifdef LC_COLLATE - if (setlocale_failure & SETLOCALE_LC_COLLATE) + "\tLC_ALL = %c%s%c,\n", + lc_all ? '"' : '(', + lc_all ? lc_all : "unset", + lc_all ? '"' : ')'); + + { + char **e; + for (e = environ; *e; e++) { + if (strnEQ(*e, "LC_", 3) + && strnNE(*e, "LC_ALL=", 7) + && (p = strchr(*e, '='))) + PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n", + (p - *e), *e, p + 1); + } + } + PerlIO_printf(PerlIO_stderr(), - "\tLC_COLLATE = %c%s%c,\n", - lc_collate ? '"' : '(', - lc_collate ? lc_collate : "unset", - lc_collate ? '"' : ')' - ); -#endif - PerlIO_printf(PerlIO_stderr(), - "\tLANG = %c%s%c\n", - lang ? '"' : ')', - lang ? lang : "unset", - lang ? '"' : ')' - ); - - PerlIO_printf(PerlIO_stderr(), - " are supported and installed on your system.\n"); - - ok = 0; - + "\tLANG = %c%s%c\n", + lang ? '"' : '(', + lang ? lang : "unset", + lang ? '"' : ')'); + + PerlIO_printf(PerlIO_stderr(), + " are supported and installed on your system.\n"); } + #ifdef LC_ALL - if (setlocale_failure) { - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Falling back to the \"C\" locale.\n"); - if (setlocale(LC_ALL, "C") == NULL) { + + if (setlocale(LC_ALL, "C")) { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Falling back to the standard locale (\"C\").\n"); + ok = 0; + } + else { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); ok = -1; - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Failed to fall back to the \"C\" locale.\n"); - } - } -#else - PerlIO_printf(PerlIO_stderr(), - "perl: warning: Cannot fall back to the \"C\" locale.\n"); -#endif + } + +#else /* ! LC_ALL */ + + if (0 +#ifdef USE_LOCALE_CTYPE + || !(curctype || setlocale(LC_CTYPE, "C")) +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + || !(curcoll || setlocale(LC_COLLATE, "C")) +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + || !(curnum || setlocale(LC_NUMERIC, "C")) +#endif /* USE_LOCALE_NUMERIC */ + ) + { + if (locwarn) + PerlIO_printf(PerlIO_stderr(), + "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); + ok = -1; + } + +#endif /* ! LC_ALL */ + +#ifdef USE_LOCALE_CTYPE + curctype = setlocale(LC_CTYPE, Nullch); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + curcoll = setlocale(LC_COLLATE, Nullch); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + curnum = setlocale(LC_NUMERIC, Nullch); +#endif /* USE_LOCALE_NUMERIC */ } - if (setlocale_failure & SETLOCALE_LC_CTYPE == 0) - perl_init_fold(); +#ifdef USE_LOCALE_CTYPE + perl_new_ctype(curctype); +#endif /* USE_LOCALE_CTYPE */ -#endif /* #if defined(HAS_SETLOCALE) */ +#ifdef USE_LOCALE_COLLATE + perl_new_collate(curcoll); +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + perl_new_numeric(curnum); +#endif /* USE_LOCALE_NUMERIC */ + +#endif /* USE_LOCALE */ return ok; } +/* Backwards compatibility. */ +int +perl_init_i18nl14n(printwarn) + int printwarn; +{ + return perl_init_i18nl10n(printwarn); +} + +#ifdef USE_LOCALE_COLLATE + +/* + * mem_collxfrm() is a bit like strxfrm() but with two important + * differences. First, it handles embedded NULs. Second, it allocates + * a bit more memory than needed for the transformed data itself. + * The real transformed data begins at offset sizeof(collationix). + * Please see sv_collxfrm() to see how this is used. + */ char * -mem_collxfrm(m, n, nx) /* mem_collxfrm() does strxfrm() for (data,size) */ - const char *m; /* "strings", that is, transforms normal eight-bit */ - const Size_t n; /* data into a format that can be memcmp()ed to get */ - Size_t * nx; /* 'the right' result for each locale. */ -{ /* Uses strxfrm() but handles embedded NULs. */ - char * mx = 0; - -#ifdef HAS_STRXFRM - Size_t ma; - - /* the expansion factor of 16 has been seen with strxfrm() */ - ma = (lc_collate_active ? 16 : 1) * n + 1; - -#define RENEW_mx() \ - do { \ - ma = 2 * ma + 1; \ - Renew(mx, ma, char); \ - if (mx == 0) \ - goto out; \ - } while (0) - - New(171, mx, ma, char); - - if (mx) { - Size_t xc, dx; - int xok; - - for (*nx = 0, xc = 0; xc < n; ) { - if (m[xc] == 0) - do { - if (*nx == ma) - RENEW_mx(); - mx[*nx++] = m[xc++]; - } while (xc < n && m[xc] == 0); - else { - do { - dx = strxfrm(mx + *nx, m + xc, ma - *nx); - if (dx + *nx > ma) { - RENEW_mx(); - xok = 0; - } else - xok = 1; - } while (!xok); - xc += strlen(mx + *nx); - *nx += dx; - } - } - } - -out: - -#endif /* HAS_STRXFRM */ - - return mx; +mem_collxfrm(s, len, xlen) + const char *s; + STRLEN len; + STRLEN *xlen; +{ + char *xbuf; + STRLEN xalloc, xin, xout; + + /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ + /* the +1 is for the terminating NUL. */ + + xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1; + New(171, xbuf, xalloc, char); + if (! xbuf) + goto bad; + + *(U32*)xbuf = collation_ix; + xout = sizeof(collation_ix); + for (xin = 0; xin < len; ) { + SSize_t xused; + + for (;;) { + xused = strxfrm(xbuf + xout, s + xin, xalloc - xout); + if (xused == -1) + goto bad; + if (xused < xalloc - xout) + break; + xalloc = (2 * xalloc) + 1; + Renew(xbuf, xalloc, char); + if (! xbuf) + goto bad; + } + + xin += strlen(s + xin) + 1; + xout += xused; + + /* Embedded NULs are understood but silently skipped + * because they make no sense in locale collation. */ + } + + xbuf[xout] = '\0'; + *xlen = xout - sizeof(collation_ix); + return xbuf; + + bad: + Safefree(xbuf); + *xlen = 0; + return NULL; } +#endif /* USE_LOCALE_COLLATE */ + void -fbm_compile(sv, iflag) +fbm_compile(sv) SV *sv; -I32 iflag; { register unsigned char *s; register unsigned char *table; @@ -616,47 +856,19 @@ I32 iflag; i = 0; while (s >= (unsigned char*)(SvPVX(sv))) { - if (table[*s] == len) { -#ifndef pdp11 - if (iflag) - table[*s] = table[fold[*s]] = i; -#else - if (iflag) { - I32 j; - j = fold[*s]; - table[j] = i; - table[*s] = i; - } -#endif /* pdp11 */ - else - table[*s] = i; - } + if (table[*s] == len) + table[*s] = i; s--,i++; } sv_upgrade(sv, SVt_PVBM); - sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ + sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ - if (iflag) { - register U32 tmp, foldtmp; - SvCASEFOLD_on(sv); - for (i = 0; i < len; i++) { - tmp=freq[s[i]]; - foldtmp=freq[fold[s[i]]]; - if (tmp < frequency && foldtmp < frequency) { - rarest = i; - /* choose most frequent among the two */ - frequency = (tmp > foldtmp) ? tmp : foldtmp; - } - } - } - else { - for (i = 0; i < len; i++) { - if (freq[s[i]] < frequency) { - rarest = i; - frequency = freq[s[i]]; - } + for (i = 0; i < len; i++) { + if (freq[s[i]] < frequency) { + rarest = i; + frequency = freq[s[i]]; } } BmRARE(sv) = s[rarest]; @@ -691,91 +903,50 @@ SV *littlestr; if (littlelen > bigend - big) return Nullch; little = (unsigned char*)SvPVX(littlestr); - if (SvCASEFOLD(littlestr)) { /* oops, fake it */ - big = bigend - littlelen; /* just start near end */ - if (bigend[-1] == '\n' && little[littlelen-1] != '\n') - big--; - } - else { - s = bigend - littlelen; - if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) - return (char*)s; /* how sweet it is */ - else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' - && s > big) { - s--; - if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) - return (char*)s; - } - return Nullch; + s = bigend - littlelen; + if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) + return (char*)s; /* how sweet it is */ + else if (bigend[-1] == '\n' && little[littlelen-1] != '\n' + && s > big) { + s--; + if (*s == *little && memEQ((char*)s,(char*)little,littlelen)) + return (char*)s; } + return Nullch; } table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1); if (--littlelen >= bigend - big) return Nullch; s = big + littlelen; oldlittle = little = table - 2; - if (SvCASEFOLD(littlestr)) { /* case insensitive? */ - if (s < bigend) { - top1: - /*SUPPRESS 560*/ - if (tmp = table[*s]) { + if (s < bigend) { + top2: + /*SUPPRESS 560*/ + if (tmp = table[*s]) { #ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top1; - } + if (bigend - s > tmp) { + s += tmp; + goto top2; + } #else - if ((s += tmp) < bigend) - goto top1; + if ((s += tmp) < bigend) + goto top2; #endif - return Nullch; - } - else { - tmp = littlelen; /* less expensive than calling strncmp() */ - olds = s; - while (tmp--) { - if (*--s == *--little || fold[*s] == *little) - continue; - s = olds + 1; /* here we pay the price for failure */ - little = oldlittle; - if (s < bigend) /* fake up continue to outer loop */ - goto top1; - return Nullch; - } - return (char *)s; - } + return Nullch; } - } - else { - if (s < bigend) { - top2: - /*SUPPRESS 560*/ - if (tmp = table[*s]) { -#ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top2; - } -#else - if ((s += tmp) < bigend) + else { + tmp = littlelen; /* less expensive than calling strncmp() */ + olds = s; + while (tmp--) { + if (*--s == *--little) + continue; + s = olds + 1; /* here we pay the price for failure */ + little = oldlittle; + if (s < bigend) /* fake up continue to outer loop */ goto top2; -#endif return Nullch; } - else { - tmp = littlelen; /* less expensive than calling strncmp() */ - olds = s; - while (tmp--) { - if (*--s == *--little) - continue; - s = olds + 1; /* here we pay the price for failure */ - little = oldlittle; - if (s < bigend) /* fake up continue to outer loop */ - goto top2; - return Nullch; - } - return (char *)s; - } + return (char *)s; } } return Nullch; @@ -808,96 +979,66 @@ SV *littlestr; return Nullch; } #ifdef POINTERRIGOR - if (SvCASEFOLD(littlestr)) { /* case insignificant? */ - do { - if (big[pos-previous] != first && big[pos-previous] != fold[first]) - continue; - for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { - s--; - break; - } - } - if (s == littleend) - return (char *)(big+pos-previous); - } while ( - pos += screamnext[pos] /* does this goof up anywhere? */ - ); - } - else { - do { - if (big[pos-previous] != first) - continue; - for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++) { - s--; - break; - } + do { + if (big[pos-previous] != first) + continue; + for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { + if (x >= bigend) + return Nullch; + if (*s++ != *x++) { + s--; + break; } - if (s == littleend) - return (char *)(big+pos-previous); - } while ( pos += screamnext[pos] ); - } + } + if (s == littleend) + return (char *)(big+pos-previous); + } while ( pos += screamnext[pos] ); #else /* !POINTERRIGOR */ big -= previous; - if (SvCASEFOLD(littlestr)) { /* case insignificant? */ - do { - if (big[pos] != first && big[pos] != fold[first]) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) { - s--; - break; - } - } - if (s == littleend) - return (char *)(big+pos); - } while ( - pos += screamnext[pos] /* does this goof up anywhere? */ - ); - } - else { - do { - if (big[pos] != first) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (x >= bigend) - return Nullch; - if (*s++ != *x++) { - s--; - break; - } + do { + if (big[pos] != first) + continue; + for (x=big+pos+1,s=little; s < littleend; /**/ ) { + if (x >= bigend) + return Nullch; + if (*s++ != *x++) { + s--; + break; } - if (s == littleend) - return (char *)(big+pos); - } while ( - pos += screamnext[pos] - ); - } + } + if (s == littleend) + return (char *)(big+pos); + } while ( pos += screamnext[pos] ); #endif /* POINTERRIGOR */ return Nullch; } I32 -ibcmp(a,b,len) -register U8 *a; -register U8 *b; +ibcmp(s1, s2, len) +char *s1, *s2; register I32 len; { + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; while (len--) { - if (*a == *b) { - a++,b++; - continue; - } - if (fold[*a++] == *b++) - continue; - return 1; + if (*a != *b && *a != fold[*b]) + return 1; + a++,b++; + } + return 0; +} + +I32 +ibcmp_locale(s1, s2, len) +char *s1, *s2; +register I32 len; +{ + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; + while (len--) { + if (*a != *b && *a != fold_locale[*b]) + return 1; + a++,b++; } return 0; } @@ -930,237 +1071,147 @@ register I32 len; return newaddr; } -#if !defined(I_STDARG) && !defined(I_VARARGS) - -/* - * Fallback on the old hackers way of doing varargs - */ - -/*VARARGS1*/ +#ifdef I_STDARG char * -mess(pat,a1,a2,a3,a4) -char *pat; -long a1, a2, a3, a4; +form(const char* pat, ...) +#else +/*VARARGS0*/ +char * +form(pat, va_alist) + const char *pat; + va_dcl +#endif { - char *s; - char *s_start; - I32 usermess = strEQ(pat,"%s"); - SV *tmpstr; - - s = s_start = buf; - if (usermess) { - tmpstr = sv_newmortal(); - sv_setpv(tmpstr, (char*)a1); - *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1]; + va_list args; +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + if (mess_sv == &sv_undef) { + /* All late-destruction message must be short */ + vsprintf(tokenbuf, pat, args); } else { - (void)sprintf(s,pat,a1,a2,a3,a4); - s += strlen(s); + if (!mess_sv) + mess_sv = NEWSV(905, 0); + sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, + Null(SV**), 0, Null(bool)); } + va_end(args); + return (mess_sv == &sv_undef) ? tokenbuf : SvPVX(mess_sv); +} - if (s[-1] != '\n') { +char * +mess(pat, args) + const char *pat; + va_list *args; +{ + SV *sv; + static char dgd[] = " during global destruction.\n"; + + if (mess_sv == &sv_undef) { + /* All late-destruction message must be short */ + vsprintf(tokenbuf, pat, *args); + if (!tokenbuf[0] && tokenbuf[strlen(tokenbuf) - 1] != '\n') + strcat(tokenbuf, dgd); + return tokenbuf; + } + if (!mess_sv) + mess_sv = NEWSV(905, 0); + sv = mess_sv; + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool)); + if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { if (dirty) - strcpy(s, " during global destruction.\n"); + sv_catpv(sv, dgd); else { - if (curcop->cop_line) { - (void)sprintf(s," at %s line %ld", - SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); - s += strlen(s); - } - if (GvIO(last_in_gv) && - IoLINES(GvIOp(last_in_gv)) ) { - (void)sprintf(s,", <%s> %s %ld", - last_in_gv == argvgv ? "" : GvENAME(last_in_gv), - strEQ(rs,"\n") ? "line" : "chunk", - (long)IoLINES(GvIOp(last_in_gv))); - s += strlen(s); + if (curcop->cop_line) + sv_catpvf(sv, " at %S line %ld", + GvSV(curcop->cop_filegv), (long)curcop->cop_line); + if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { + bool line_mode = (RsSIMPLE(rs) && + SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); + sv_catpvf(sv, ", <%s> %s %ld", + last_in_gv == argvgv ? "" : GvNAME(last_in_gv), + line_mode ? "line" : "chunk", + (long)IoLINES(GvIOp(last_in_gv))); } - (void)strcpy(s,".\n"); - s += 2; + sv_catpv(sv, ".\n"); } - if (usermess) - sv_catpv(tmpstr,buf+1); - } - - if (s - s_start >= sizeof(buf)) { /* Ooops! */ - if (usermess) - PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); - else - PerlIO_puts(PerlIO_stderr(), buf); - PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n"); - my_exit(1); } - if (usermess) - return SvPVX(tmpstr); - else - return buf; + return SvPVX(sv); } -/*VARARGS1*/ -void croak(pat,a1,a2,a3,a4) -char *pat; -long a1, a2, a3, a4; +#ifdef I_STDARG +OP * +die(const char* pat, ...) +#else +/*VARARGS0*/ +OP * +die(pat, va_alist) + const char *pat; + va_dcl +#endif { - char *tmps; + va_list args; char *message; + I32 oldrunlevel = runlevel; + int was_in_eval = in_eval; HV *stash; GV *gv; CV *cv; - message = mess(pat,a1,a2,a3,a4); + /* We have to switch back to mainstack or die_where may try to pop + * the eval block from the wrong stack if die is being called from a + * signal handler. - dkindred@cs.cmu.edu */ + if (curstack != mainstack) { + dSP; + SWITCHSTACK(curstack, mainstack); + } + +#ifdef I_STDARG + va_start(args, pat); +#else + va_start(args); +#endif + message = mess(pat, &args); + va_end(args); + if (diehook) { + /* sv_2cv might call croak() */ SV *olddiehook = diehook; - diehook = Nullsv; /* sv_2cv might call croak() */ + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; cv = sv_2cv(olddiehook, &stash, &gv, 0); - diehook = olddiehook; - if (cv && !CvDEPTH(cv)) { + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; + SV *msg; - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - } - } - if (in_eval) { - restartop = die_where(message); - Siglongjmp(top_env, 3); - } - PerlIO_puts(PerlIO_stderr(),message); - (void)PerlIO_flush(PerlIO_stderr()); - if (e_tmpname) { - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; - } - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; - } - statusvalue = SHIFTSTATUS(statusvalue); -#ifdef VMS - my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT); -#else - my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); -#endif -} - -/*VARARGS1*/ -void warn(pat,a1,a2,a3,a4) -char *pat; -long a1, a2, a3, a4; -{ - char *message; - SV *sv; - HV *stash; - GV *gv; - CV *cv; + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); - message = mess(pat,a1,a2,a3,a4); - if (warnhook) { - SV *oldwarnhook = warnhook; - warnhook = Nullsv; /* sv_2cv might end up calling warn() */ - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - warnhook = oldwarnhook; - if (cv && !CvDEPTH(cv)) { - dSP; - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); + XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - return; - } - } - PerlIO_puts(PerlIO_stderr(),message); -#ifdef LEAKTEST - DEBUG_L(xstat()); -#endif - (void)PerlIO_flush(PerlIO_stderr()); -} - -#else /* !defined(I_STDARG) && !defined(I_VARARGS) */ -#ifdef I_STDARG -char * -mess(char *pat, va_list *args) -#else -/*VARARGS0*/ -char * -mess(pat, args) - char *pat; - va_list *args; -#endif -{ - char *s; - char *s_start; - SV *tmpstr; - I32 usermess; -#ifndef HAS_VPRINTF -#ifdef USE_CHAR_VSPRINTF - char *vsprintf(); -#else - I32 vsprintf(); -#endif -#endif - - s = s_start = buf; - usermess = strEQ(pat, "%s"); - if (usermess) { - tmpstr = sv_newmortal(); - sv_setpv(tmpstr, va_arg(*args, char *)); - *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1]; - } - else { - (void) vsprintf(s,pat,*args); - s += strlen(s); - } - va_end(*args); - - if (s[-1] != '\n') { - if (dirty) - strcpy(s, " during global destruction.\n"); - else { - if (curcop->cop_line) { - (void)sprintf(s," at %s line %ld", - SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); - s += strlen(s); - } - if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) { - bool line_mode = (RsSIMPLE(rs) && - SvLEN(rs) == 1 && *SvPVX(rs) == '\n'); - (void)sprintf(s,", <%s> %s %ld", - last_in_gv == argvgv ? "" : GvNAME(last_in_gv), - line_mode ? "line" : "chunk", - (long)IoLINES(GvIOp(last_in_gv))); - s += strlen(s); - } - (void)strcpy(s,".\n"); - s += 2; + LEAVE; } - if (usermess) - sv_catpv(tmpstr,buf+1); } - if (s - s_start >= sizeof(buf)) { /* Ooops! */ - if (usermess) - PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); - else - PerlIO_puts(PerlIO_stderr(), buf); - PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n"); - my_exit(1); - } - if (usermess) - return SvPVX(tmpstr); - else - return buf; + restartop = die_where(message); + if ((!restartop && was_in_eval) || oldrunlevel > 1) + JMPENV_JUMP(3); + return restartop; } #ifdef I_STDARG void -croak(char* pat, ...) +croak(const char* pat, ...) #else /*VARARGS0*/ void @@ -1183,50 +1234,46 @@ croak(pat, va_alist) message = mess(pat, &args); va_end(args); if (diehook) { + /* sv_2cv might call croak() */ SV *olddiehook = diehook; - diehook = Nullsv; /* sv_2cv might call croak() */ + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; cv = sv_2cv(olddiehook, &stash, &gv, 0); - diehook = olddiehook; - if (cv && !CvDEPTH(cv)) { + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); + XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; } } if (in_eval) { restartop = die_where(message); - Siglongjmp(top_env, 3); + JMPENV_JUMP(3); } PerlIO_puts(PerlIO_stderr(),message); (void)PerlIO_flush(PerlIO_stderr()); - if (e_tmpname) { - if (e_fp) { - PerlIO_close(e_fp); - e_fp = Nullfp; - } - (void)UNLINK(e_tmpname); - Safefree(e_tmpname); - e_tmpname = Nullch; - } - statusvalue = SHIFTSTATUS(statusvalue); -#ifdef VMS - my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44))); -#else - my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); -#endif + my_failure_exit(); } void #ifdef I_STDARG -warn(char* pat,...) +warn(const char* pat,...) #else /*VARARGS0*/ warn(pat,va_alist) - char *pat; + const char *pat; va_dcl #endif { @@ -1245,18 +1292,28 @@ warn(pat,va_alist) va_end(args); if (warnhook) { + /* sv_2cv might call warn() */ SV *oldwarnhook = warnhook; - warnhook = Nullsv; /* sv_2cv might end up calling warn() */ + ENTER; + SAVESPTR(warnhook); + warnhook = Nullsv; cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - warnhook = oldwarnhook; - if (cv && !CvDEPTH(cv)) { + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); + XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; return; } } @@ -1266,9 +1323,9 @@ warn(pat,va_alist) #endif (void)PerlIO_flush(PerlIO_stderr()); } -#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ #ifndef VMS /* VMS' my_setenv() is in VMS.c */ +#ifndef _WIN32 void my_setenv(nam,val) char *nam, *val; @@ -1289,6 +1346,7 @@ char *nam, *val; environ = tmpenv; /* tell exec where it is now */ } if (!val) { + Safefree(environ[i]); while (environ[i]) { environ[i] = environ[i+1]; i++; @@ -1327,6 +1385,36 @@ char *nam; } /* potential SEGV's */ return i; } + +#else /* if _WIN32 */ + +void +my_setenv(nam,val) +char *nam, *val; +{ + register char *envstr; + STRLEN namlen = strlen(nam); + STRLEN vallen = strlen(val ? val : ""); + + New(9040, envstr, namlen + vallen + 3, char); + (void)sprintf(envstr,"%s=%s",nam,val); + if (!vallen) { + /* An attempt to delete the entry. + * We try to fix a Win32 process handling goof: Children + * of the current process will end up seeing the + * grandparent's entry if the current process has never + * modified the entry being deleted. So we call _putenv() + * twice: once to pretend to modify the entry, and the + * second time to actually delete it. GSAR 97-03-19 + */ + envstr[namlen+1] = 'X'; envstr[namlen+2] = '\0'; + (void)_putenv(envstr); + envstr[namlen+1] = '\0'; + } + (void)_putenv(envstr); +} + +#endif /* _WIN32 */ #endif /* !VMS */ #ifdef UNLINK_ALL_VERSIONS @@ -1378,22 +1466,24 @@ register I32 len; } #endif -#ifndef HAS_MEMCMP +#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 my_memcmp(s1,s2,len) -register unsigned char *s1; -register unsigned char *s2; +char *s1; +char *s2; register I32 len; { + register U8 *a = (U8 *)s1; + register U8 *b = (U8 *)s2; register I32 tmp; while (len--) { - if (tmp = *s1++ - *s2++) + if (tmp = *a++ - *b++) return tmp; } return 0; } -#endif /* HAS_MEMCMP */ +#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ #if defined(I_STDARG) || defined(I_VARARGS) #ifndef HAS_VPRINTF @@ -1404,7 +1494,9 @@ char * int #endif vsprintf(dest, pat, args) -char *dest, *pat, *args; +char *dest; +const char *pat; +char *args; { FILE fakebuf; @@ -1576,8 +1668,8 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif -#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in - VMS.c, same with OS/2. */ + /* VMS' my_popen() is in VMS.c, same with OS/2. */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) PerlIO * my_popen(cmd,mode) char *cmd; @@ -1598,11 +1690,9 @@ char *mode; return Nullfp; this = (*mode == 'w'); that = !this; - if (tainting) { - if (doexec) { - taint_env(); - taint_proper("Insecure %s%s", "EXEC"); - } + if (doexec && tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); } while ((pid = (doexec?vfork():fork())) < 0) { if (errno != EAGAIN) { @@ -1638,7 +1728,7 @@ char *mode; } /*SUPPRESS 560*/ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv),(I32)getpid()); + sv_setiv(GvSV(tmpgv), (IV)getpid()); forkprocess = 0; hv_clear(pidstatus); /* we have no children */ return Nullfp; @@ -1659,7 +1749,7 @@ char *mode; return PerlIO_fdopen(p[this], mode); } #else -#if defined(atarist) +#if defined(atarist) || defined(DJGPP) FILE *popen(); PerlIO * my_popen(cmd,mode) @@ -1667,7 +1757,8 @@ char *cmd; char *mode; { /* Needs work for PerlIO ! */ - return popen(PerlIO_exportFILE(cmd), mode); + /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */ + return popen(PerlIO_exportFILE(cmd, 0), mode); } #endif @@ -1717,12 +1808,126 @@ int newfd; } #endif -#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ + +#ifdef HAS_SIGACTION + +Sighandler_t +rsignal(signo, handler) +int signo; +Sighandler_t handler; +{ + struct sigaction act, oact; + + act.sa_handler = handler; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ +#endif + if (sigaction(signo, &act, &oact) == -1) + return SIG_ERR; + else + return oact.sa_handler; +} + +Sighandler_t +rsignal_state(signo) +int signo; +{ + struct sigaction oact; + + if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) + return SIG_ERR; + else + return oact.sa_handler; +} + +int +rsignal_save(signo, handler, save) +int signo; +Sighandler_t handler; +Sigsave_t *save; +{ + struct sigaction act; + + act.sa_handler = handler; + sigemptyset(&act.sa_mask); + act.sa_flags = 0; +#ifdef SA_RESTART + act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ +#endif + return sigaction(signo, &act, save); +} + +int +rsignal_restore(signo, save) +int signo; +Sigsave_t *save; +{ + return sigaction(signo, save, (struct sigaction *)NULL); +} + +#else /* !HAS_SIGACTION */ + +Sighandler_t +rsignal(signo, handler) +int signo; +Sighandler_t handler; +{ + return signal(signo, handler); +} + +static int sig_trapped; + +static +Signal_t +sig_trap(signo) +int signo; +{ + sig_trapped++; +} + +Sighandler_t +rsignal_state(signo) +int signo; +{ + Sighandler_t oldsig; + + sig_trapped = 0; + oldsig = signal(signo, sig_trap); + signal(signo, oldsig); + if (sig_trapped) + kill(getpid(), signo); + return oldsig; +} + +int +rsignal_save(signo, handler, save) +int signo; +Sighandler_t handler; +Sigsave_t *save; +{ + *save = signal(signo, handler); + return (*save == SIG_ERR) ? -1 : 0; +} + +int +rsignal_restore(signo, save) +int signo; +Sigsave_t *save; +{ + return (signal(signo, *save) == SIG_ERR) ? -1 : 0; +} + +#endif /* !HAS_SIGACTION */ + + /* VMS' my_pclose() is in VMS.c; same with OS/2 */ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) I32 my_pclose(ptr) PerlIO *ptr; { - Signal_t (*hstat)(), (*istat)(), (*qstat)(); + Sigsave_t hstat, istat, qstat; int status; SV **svp; int pid; @@ -1740,15 +1945,15 @@ PerlIO *ptr; #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif - hstat = signal(SIGHUP, SIG_IGN); - istat = signal(SIGINT, SIG_IGN); - qstat = signal(SIGQUIT, SIG_IGN); + rsignal_save(SIGHUP, SIG_IGN, &hstat); + rsignal_save(SIGINT, SIG_IGN, &istat); + rsignal_save(SIGQUIT, SIG_IGN, &qstat); do { pid = wait4pid(pid, &status, 0); } while (pid == -1 && errno == EINTR); - signal(SIGHUP, hstat); - signal(SIGINT, istat); - signal(SIGQUIT, qstat); + rsignal_restore(SIGHUP, &hstat); + rsignal_restore(SIGINT, &istat); + rsignal_restore(SIGQUIT, &qstat); return(pid < 0 ? pid : status); } #endif /* !DOSISH */ @@ -1762,7 +1967,7 @@ int flags; { SV *sv; SV** svp; - char spid[16]; + char spid[sizeof(int) * 3 + 1]; if (!pid) return -1; @@ -1818,7 +2023,7 @@ int pid; int status; { register SV *sv; - char spid[16]; + char spid[sizeof(int) * 3 + 1]; sprintf(spid, "%d", pid); sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); @@ -1827,7 +2032,7 @@ int status; return; } -#if defined(atarist) || defined(OS2) +#if defined(atarist) || defined(OS2) || defined(DJGPP) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -1956,10 +2161,7 @@ char *b; char *fb = strrchr(b,'/'); struct stat tmpstatbuf1; struct stat tmpstatbuf2; -#ifndef MAXPATHLEN -#define MAXPATHLEN 1024 -#endif - char tmpbuf[MAXPATHLEN+1]; + SV *tmpsv = sv_newmortal(); if (fa) fa++; @@ -1972,34 +2174,39 @@ char *b; if (strNE(a,b)) return FALSE; if (fa == a) - strcpy(tmpbuf,"."); + sv_setpv(tmpsv, "."); else - strncpy(tmpbuf, a, fa - a); - if (Stat(tmpbuf, &tmpstatbuf1) < 0) + sv_setpvn(tmpsv, a, fa - a); + if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - strcpy(tmpbuf,"."); + sv_setpv(tmpsv, "."); else - strncpy(tmpbuf, b, fb - b); - if (Stat(tmpbuf, &tmpstatbuf2) < 0) + sv_setpvn(tmpsv, b, fb - b); + if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; } #endif /* !HAS_RENAME */ -unsigned long +UV scan_oct(start, len, retlen) char *start; I32 len; I32 *retlen; { register char *s = start; - register unsigned long retval = 0; + register UV retval = 0; + bool overflowed = FALSE; while (len && *s >= '0' && *s <= '7') { - retval <<= 3; - retval |= *s++ - '0'; + register UV n = retval << 3; + if (!overflowed && (n >> 3) != retval) { + warn("Integer overflow in octal number"); + overflowed = TRUE; + } + retval = n | (*s++ - '0'); len--; } if (dowarn && len && (*s == '8' || *s == '9')) @@ -2008,19 +2215,24 @@ I32 *retlen; return retval; } -unsigned long +UV scan_hex(start, len, retlen) char *start; I32 len; I32 *retlen; { register char *s = start; - register unsigned long retval = 0; + register UV retval = 0; + bool overflowed = FALSE; char *tmp; while (len-- && *s && (tmp = strchr(hexdigit, *s))) { - retval <<= 4; - retval |= (tmp - hexdigit) & 15; + register UV n = retval << 4; + if (!overflowed && (n >> 4) != retval) { + warn("Integer overflow in hex number"); + overflowed = TRUE; + } + retval = n | (tmp - hexdigit) & 15; s++; } *retlen = s - start;