X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ea6641ad56e3d849f16fe61b8121cb626a6be049;hb=9a200e1b073bb063f06b3f44c2c596ce14d3211a;hp=1ebb847abe2caa093ef6982923bc7710fe992eb3;hpb=85e6fe838fb25b257a1b363debf8691c0992ef71;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 1ebb847..ea6641a 100644 --- a/util.c +++ b/util.c @@ -1,48 +1,16 @@ -/* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:00 $ +/* util.c * - * Copyright (c) 1991, Larry Wall + * Copyright (c) 1991-1994, 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. * - * $Log: util.c,v $ - * Revision 4.1 92/08/07 18:29:00 lwall - * - * Revision 4.0.1.6 92/06/11 21:18:47 lwall - * patch34: boneheaded typo in my_bcopy() - * - * Revision 4.0.1.5 92/06/08 16:08:37 lwall - * patch20: removed implicit int declarations on functions - * patch20: Perl now distinguishes overlapped copies from non-overlapped - * patch20: fixed confusion between a *var's real name and its effective name - * patch20: bcopy() and memcpy() now tested for overlap safety - * patch20: added Atari ST portability - * - * Revision 4.0.1.4 91/11/11 16:48:54 lwall - * patch19: study was busted by 4.018 - * patch19: added little-endian pack/unpack options - * - * Revision 4.0.1.3 91/11/05 19:18:26 lwall - * patch11: safe malloc code now integrated into Perl's malloc when possible - * patch11: strchr("little", "longer string") could visit faraway places - * patch11: warn '-' x 10000 dumped core - * patch11: forked exec on non-existent program now issues a warning - * - * Revision 4.0.1.2 91/06/07 12:10:42 lwall - * patch4: new copyright notice - * patch4: made some allowances for "semi-standard" C - * patch4: strchr() could blow up searching for null string - * patch4: taintchecks could improperly modify parent in vfork() - * patch4: exec would close files even if you cleared close-on-exec flag - * - * Revision 4.0.1.1 91/04/12 09:19:25 lwall - * patch1: random cleanup in cpp namespace - * - * Revision 4.0 91/03/20 01:56:39 lwall - * 4.0 baseline. - * */ -/*SUPPRESS 112*/ + +/* + * "Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content." --Gandalf + */ #include "EXTERN.h" #include "perl.h" @@ -51,6 +19,7 @@ #include #endif +/* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include #endif @@ -59,6 +28,13 @@ # include #endif +/* Put this after #includes because fork and vfork prototypes may + conflict. +*/ +#ifndef HAS_VFORK +# define vfork fork +#endif + #ifdef I_FCNTL # include #endif @@ -68,6 +44,10 @@ #define FLUSH +#ifdef LEAKTEST +static void xstat _((void)); +#endif + #ifndef safemalloc /* paranoid version of malloc */ @@ -75,9 +55,10 @@ /* NOTE: Do not call the next three routines directly. Use the macros * in handy.h, so that we can easily redefine everything to do tracking of * allocated hunks back to the original New to track down any memory leaks. + * XXX This advice seems to be widely ignored :-( --AD August 1996. */ -char * +Malloc_t safemalloc(size) #ifdef MSDOS unsigned long size; @@ -85,10 +66,10 @@ unsigned long size; MEM_SIZE size; #endif /* MSDOS */ { - char *ptr; + Malloc_t ptr; #ifdef MSDOS if (size > 0xffff) { - fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH; + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ @@ -98,16 +79,16 @@ MEM_SIZE size; #endif ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); #else - DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); #endif if (ptr != Nullch) return ptr; else if (nomemok) return Nullch; else { - fputs(no_mem,stderr) FLUSH; + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ @@ -115,23 +96,23 @@ MEM_SIZE size; /* paranoid version of realloc */ -char * +Malloc_t saferealloc(where,size) -char *where; +Malloc_t where; #ifndef MSDOS MEM_SIZE size; #else unsigned long size; #endif /* MSDOS */ { - char *ptr; -#ifndef STANDARD_C - char *realloc(); -#endif /* ! STANDARD_C */ + 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) { - fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH; + PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ @@ -145,13 +126,13 @@ unsigned long size; #if !(defined(I286) || defined(atarist)) DEBUG_m( { - fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++); - fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); } ) #else DEBUG_m( { - fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++); - fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); } ) #endif @@ -160,7 +141,7 @@ unsigned long size; else if (nomemok) return Nullch; else { - fputs(no_mem,stderr) FLUSH; + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ @@ -170,12 +151,12 @@ unsigned long size; void safefree(where) -char *where; +Malloc_t where; { #if !(defined(I286) || defined(atarist)) - DEBUG_m( fprintf(stderr,"0x%x: (%05d) free\n",where,an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++)); #else - DEBUG_m( fprintf(stderr,"0x%lx: (%05d) free\n",where,an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++)); #endif if (where) { /*SUPPRESS 701*/ @@ -183,18 +164,57 @@ char *where; } } +/* safe version of calloc */ + +Malloc_t +safecalloc(count, size) +MEM_SIZE count; +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 DEBUGGING + if ((long)size < 0 || (long)count < 0) + croak("panic: calloc"); +#endif +#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; + } + else if (nomemok) + return Nullch; + else { + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + my_exit(1); + } + /*NOTREACHED*/ +} + #endif /* !safemalloc */ #ifdef LEAKTEST #define ALIGN sizeof(long) -char * +Malloc_t safexmalloc(x,size) I32 x; MEM_SIZE size; { - register char *where; + register Malloc_t where; where = safemalloc(size + ALIGN); xcount[x]++; @@ -203,17 +223,18 @@ MEM_SIZE size; return where + ALIGN; } -char * +Malloc_t safexrealloc(where,size) -char *where; +Malloc_t where; MEM_SIZE size; { - return saferealloc(where - ALIGN, size + ALIGN) + ALIGN; + register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN); + return new + ALIGN; } void safexfree(where) -char *where; +Malloc_t where; { I32 x; @@ -225,6 +246,22 @@ char *where; safefree(where); } +Malloc_t +safexcalloc(x,count,size) +I32 x; +MEM_SIZE count; +MEM_SIZE size; +{ + register Malloc_t where; + + where = safexmalloc(x, size * count + ALIGN); + xcount[x]++; + memset((void*)where + ALIGN, 0, size * count); + where[0] = x % 100; + where[1] = x / 100; + return where + ALIGN; +} + static void xstat() { @@ -232,7 +269,7 @@ xstat() for (i = 0; i < MAXXCOUNT; i++) { if (xcount[i] > lastxcount[i]) { - fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); + PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); lastxcount[i] = xcount[i]; } } @@ -247,7 +284,7 @@ cpytill(to,from,fromend,delim,retlen) register char *to; register char *from; register char *fromend; -register I32 delim; +register int delim; I32 *retlen; { char *origto = to; @@ -314,7 +351,7 @@ char *lend; register I32 first = *little; register char *littleend = lend; - if (!first && little > littleend) + if (!first && little >= littleend) return big; if (bigend - big < littleend - little) return Nullch; @@ -348,7 +385,7 @@ char *lend; register I32 first = *little; register char *littleend = lend; - if (!first && little > littleend) + if (!first && little >= littleend) return bigend; bigbeg = big; big = bigend - (littleend - little++); @@ -367,6 +404,195 @@ char *lend; return Nullch; } +/* Initialize the fold[] array. */ +int +perl_init_fold() +{ + int i; + + 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; + } +} + +/* Initialize locale (and the fold[] array).*/ +int +perl_init_i18nl10n(printwarn) + int printwarn; +{ + int ok = 1; + /* returns + * 1 = set ok or not applicable, + * 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) + PerlIO_printf(PerlIO_stderr(), + "LC_CTYPE "); +#endif +#ifdef LC_COLLATE + if (setlocale_failure & SETLOCALE_LC_COLLATE) + PerlIO_printf(PerlIO_stderr(), + "LC_COLLATE "); +#endif + PerlIO_printf(PerlIO_stderr(), + "\n"); + + 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) + 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) + 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; + + } +#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) { + 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 + } + + if (setlocale_failure & SETLOCALE_LC_CTYPE == 0) + perl_init_fold(); + +#endif /* #if defined(HAS_SETLOCALE) */ + + return ok; +} + +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; +} + void fbm_compile(sv, iflag) SV *sv; @@ -379,6 +605,8 @@ I32 iflag; I32 rarest = 0; U32 frequency = 256; + if (len > 255) + return; /* can't have offsets that big */ Sv_Grow(sv,len+258); table = (unsigned char*)(SvPVX(sv) + len + 1); s = table - 2; @@ -406,7 +634,7 @@ I32 iflag; s--,i++; } sv_upgrade(sv, SVt_PVBM); - sv_magic(sv, 0, 'B', 0, 0); /* deep magic */ + sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ @@ -433,7 +661,7 @@ I32 iflag; } BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; - DEBUG_r(fprintf(stderr,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); } char * @@ -451,10 +679,11 @@ SV *littlestr; register unsigned char *oldlittle; if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { - if (!SvPOK(littlestr) || !SvPVX(littlestr)) + STRLEN len; + char *l = SvPV(littlestr,len); + if (!len) return (char*)big; - return ninstr((char*)big,(char*)bigend, - SvPVX(littlestr), SvPVX(littlestr) + SvCUR(littlestr)); + return ninstr((char*)big,(char*)bigend, l, l + len); } littlelen = SvCUR(littlestr); @@ -469,12 +698,12 @@ SV *littlestr; } else { s = bigend - littlelen; - if (*s == *little && bcmp(s,little,littlelen)==0) + 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 && bcmp(s,little,littlelen)==0) + if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) return (char*)s; } return Nullch; @@ -657,8 +886,8 @@ SV *littlestr; I32 ibcmp(a,b,len) -register char *a; -register char *b; +register U8 *a; +register U8 *b; register I32 len; { while (len--) { @@ -676,7 +905,7 @@ register I32 len; /* copy a string to a safe spot */ char * -savestr(sv) +savepv(sv) char *sv; { register char *newaddr; @@ -689,7 +918,7 @@ char *sv; /* same thing but with a known length */ char * -nsavestr(sv, len) +savepvn(sv, len) char *sv; register I32 len; { @@ -701,7 +930,7 @@ register I32 len; return newaddr; } -#if !defined(STANDARD_C) && !defined(I_VARARGS) +#if !defined(I_STDARG) && !defined(I_VARARGS) /* * Fallback on the old hackers way of doing varargs @@ -714,10 +943,11 @@ char *pat; long a1, a2, a3, a4; { char *s; + char *s_start; I32 usermess = strEQ(pat,"%s"); SV *tmpstr; - s = buf; + s = s_start = buf; if (usermess) { tmpstr = sv_newmortal(); sv_setpv(tmpstr, (char*)a1); @@ -737,20 +967,29 @@ long a1, a2, a3, a4; SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); s += strlen(s); } - if (last_in_gv && - GvIO(last_in_gv) && - IoLINES(GvIO(last_in_gv)) ) { + 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(GvIO(last_in_gv))); + (long)IoLINES(GvIOp(last_in_gv))); s += strlen(s); } (void)strcpy(s,".\n"); + s += 2; } 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 @@ -764,14 +1003,47 @@ long a1, a2, a3, a4; { char *tmps; char *message; + HV *stash; + GV *gv; + CV *cv; message = mess(pat,a1,a2,a3,a4); - fputs(message,stderr); - (void)fflush(stderr); - if (e_fp) + if (diehook) { + SV *olddiehook = diehook; + diehook = Nullsv; /* sv_2cv might call croak() */ + cv = sv_2cv(olddiehook, &stash, &gv, 0); + diehook = olddiehook; + if (cv && !CvDEPTH(cv)) { + dSP; + + 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); - statusvalue >>= 8; - my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); + 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*/ @@ -780,18 +1052,38 @@ char *pat; long a1, a2, a3, a4; { char *message; + SV *sv; + HV *stash; + GV *gv; + CV *cv; message = mess(pat,a1,a2,a3,a4); - fputs(message,stderr); + 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))); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + return; + } + } + PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST DEBUG_L(xstat()); #endif - (void)fflush(stderr); + (void)PerlIO_flush(PerlIO_stderr()); } -#else /* !defined(STANDARD_C) && !defined(I_VARARGS) */ +#else /* !defined(I_STDARG) && !defined(I_VARARGS) */ -#ifdef STANDARD_C +#ifdef I_STDARG char * mess(char *pat, va_list *args) #else @@ -803,6 +1095,7 @@ mess(pat, args) #endif { char *s; + char *s_start; SV *tmpstr; I32 usermess; #ifndef HAS_VPRINTF @@ -813,7 +1106,7 @@ mess(pat, args) #endif #endif - s = buf; + s = s_start = buf; usermess = strEQ(pat, "%s"); if (usermess) { tmpstr = sv_newmortal(); @@ -835,28 +1128,37 @@ mess(pat, args) SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line); s += strlen(s); } - if (last_in_gv && - GvIO(last_in_gv) && - IoLINES(GvIO(last_in_gv)) ) { + 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), - strEQ(rs,"\n") ? "line" : "chunk", - (long)IoLINES(GvIO(last_in_gv))); + line_mode ? "line" : "chunk", + (long)IoLINES(GvIOp(last_in_gv))); s += strlen(s); } (void)strcpy(s,".\n"); + s += 2; } 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; } -#ifdef STANDARD_C +#ifdef I_STDARG void croak(char* pat, ...) #else @@ -868,28 +1170,58 @@ croak(pat, va_alist) #endif { va_list args; - char *tmps; char *message; + HV *stash; + GV *gv; + CV *cv; -#ifdef STANDARD_C +#ifdef I_STDARG va_start(args, pat); #else va_start(args); #endif message = mess(pat, &args); va_end(args); - if (restartop = die_where(message)) - longjmp(top_env, 3); - fputs(message,stderr); - (void)fflush(stderr); - if (e_fp) + if (diehook) { + SV *olddiehook = diehook; + diehook = Nullsv; /* sv_2cv might call croak() */ + cv = sv_2cv(olddiehook, &stash, &gv, 0); + diehook = olddiehook; + if (cv && !CvDEPTH(cv)) { + dSP; + + 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); - statusvalue >>= 8; - my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255))); + 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 } void -#ifdef STANDARD_C +#ifdef I_STDARG warn(char* pat,...) #else /*VARARGS0*/ @@ -900,8 +1232,11 @@ warn(pat,va_alist) { va_list args; char *message; + HV *stash; + GV *gv; + CV *cv; -#ifdef STANDARD_C +#ifdef I_STDARG va_start(args, pat); #else va_start(args); @@ -909,14 +1244,31 @@ warn(pat,va_alist) message = mess(pat, &args); va_end(args); - fputs(message,stderr); + 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))); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + return; + } + } + PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST DEBUG_L(xstat()); #endif - (void)fflush(stderr); + (void)PerlIO_flush(PerlIO_stderr()); } -#endif /* !defined(STANDARD_C) && !defined(I_VARARGS) */ +#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ +#ifndef VMS /* VMS' my_setenv() is in VMS.c */ void my_setenv(nam,val) char *nam, *val; @@ -932,7 +1284,7 @@ char *nam, *val; for (max = i; environ[max]; max++) ; New(901,tmpenv, max+2, char*); for (j=0; j= 0) - fprintf(stderr," %d",fd); + if (Fstat(fd,&tmpstatbuf) >= 0) + PerlIO_printf(PerlIO_stderr()," %d",fd); } - fprintf(stderr,"\n"); + PerlIO_printf(PerlIO_stderr(),"\n"); } #endif #ifndef HAS_DUP2 +int dup2(oldfd,newfd) int oldfd; int newfd; { -#if defined(HAS_FCNTL) && defined(FFt_DUPFD) +#if defined(HAS_FCNTL) && defined(F_DUPFD) + if (oldfd == newfd) + return oldfd; close(newfd); - fcntl(oldfd, FFt_DUPFD, newfd); + return fcntl(oldfd, F_DUPFD, newfd); #else int fdtmp[256]; I32 fdx = 0; int fd; if (oldfd == newfd) - return 0; + return oldfd; close(newfd); - while ((fd = dup(oldfd)) != newfd) /* good enough for low fd's */ + while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */ fdtmp[fdx++] = fd; while (fdx > 0) close(fdtmp[--fdx]); + return fd; #endif } #endif -#ifndef DOSISH +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) -FILE *ptr; +PerlIO *ptr; { -#ifdef VOIDSIG - void (*hstat)(), (*istat)(), (*qstat)(); -#else - int (*hstat)(), (*istat)(), (*qstat)(); -#endif + Signal_t (*hstat)(), (*istat)(), (*qstat)(); int status; - SV *sv; + SV **svp; int pid; - sv = *av_fetch(fdpid,fileno(ptr),TRUE); - pid = SvIVX(sv); - av_store(fdpid,fileno(ptr),Nullsv); - fclose(ptr); + svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); + pid = (int)SvIVX(*svp); + SvREFCNT_dec(*svp); + *svp = &sv_undef; + PerlIO_close(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); - pid = wait4pid(pid, &status, 0); + do { + pid = wait4pid(pid, &status, 0); + } while (pid == -1 && errno == EINTR); signal(SIGHUP, hstat); signal(SIGINT, istat); signal(SIGQUIT, qstat); return(pid < 0 ? pid : status); } +#endif /* !DOSISH */ +#if !defined(DOSISH) || defined(OS2) I32 wait4pid(pid,statusp,flags) int pid; int *statusp; int flags; { - I32 result; SV *sv; SV** svp; char spid[16]; @@ -1407,7 +1761,7 @@ int flags; svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE); if (svp && *svp != &sv_undef) { *statusp = SvIVX(*svp); - hv_delete(pidstatus,spid,strlen(spid)); + (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); return pid; } } @@ -1416,29 +1770,32 @@ int flags; hv_iterinit(pidstatus); if (entry = hv_iternext(pidstatus)) { - pid = atoi(hv_iterkey(entry,statusp)); + pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(pidstatus,entry); *statusp = SvIVX(sv); sprintf(spid, "%d", pid); - hv_delete(pidstatus,spid,strlen(spid)); + (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD); return pid; } } -#ifdef HAS_WAIT4 - return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); -#else #ifdef HAS_WAITPID return waitpid(pid,statusp,flags); #else - if (flags) - croak("Can't do waitpid with flags"); - else { - while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) - pidgone(result,*statusp); - if (result < 0) - *statusp = -1; +#ifdef HAS_WAIT4 + return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); +#else + { + I32 result; + if (flags) + croak("Can't do waitpid with flags"); + else { + while ((result = wait(statusp)) != pid && pid > 0 && result >= 0) + pidgone(result,*statusp); + if (result < 0) + *statusp = -1; + } + return result; } - return result; #endif #endif } @@ -1455,18 +1812,22 @@ int status; sprintf(spid, "%d", pid); sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE); - SvUPGRADE(sv,SVt_IV); + (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = status; return; } -#ifdef atarist +#if defined(atarist) || (defined(OS2) && !defined(HAS_FORK)) int pclose(); I32 my_pclose(ptr) -FILE *ptr; +PerlIO *ptr; { - return pclose(ptr); + /* Needs work for PerlIO ! */ + FILE *f = PerlIO_findFILE(ptr); + I32 result = pclose(f); + PerlIO_releaseFILE(ptr,f); + return result; } #endif @@ -1515,20 +1876,58 @@ double f; #endif #ifndef CASTI32 + +/* Unfortunately, on some systems the cast_uv() function doesn't + work with the system-supplied definition of ULONG_MAX. The + comparison (f >= ULONG_MAX) always comes out true. It must be a + problem with the compiler constant folding. + + In any case, this workaround should be fine on any two's complement + system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your + ccflags. + --Andy Dougherty +*/ + +/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead + of LONG_(MIN/MAX). + -- Kenneth Albanowski +*/ + +#ifndef MY_UV_MAX +# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) +#endif + I32 cast_i32(f) double f; { -# define BIGDOUBLE 2147483648.0 /* Assume 32 bit int's ! */ -# define BIGNEGDOUBLE (-2147483648.0) - if (f >= BIGDOUBLE) - return (I32)fmod(f, BIGDOUBLE); - if (f <= BIGNEGDOUBLE) - return (I32)fmod(f, BIGNEGDOUBLE); + if (f >= I32_MAX) + return (I32) I32_MAX; + if (f <= I32_MIN) + return (I32) I32_MIN; return (I32) f; } -# undef BIGDOUBLE -# undef BIGNEGDOUBLE + +IV +cast_iv(f) +double f; +{ + if (f >= IV_MAX) + return (IV) IV_MAX; + if (f <= IV_MIN) + return (IV) IV_MIN; + return (IV) f; +} + +UV +cast_uv(f) +double f; +{ + if (f >= MY_UV_MAX) + return (UV) MY_UV_MAX; + return (UV) f; +} + #endif #ifndef HAS_RENAME @@ -1560,13 +1959,13 @@ char *b; strcpy(tmpbuf,"."); else strncpy(tmpbuf, a, fa - a); - if (stat(tmpbuf, &tmpstatbuf1) < 0) + if (Stat(tmpbuf, &tmpstatbuf1) < 0) return FALSE; if (fb == b) strcpy(tmpbuf,"."); else strncpy(tmpbuf, b, fb - b); - if (stat(tmpbuf, &tmpstatbuf2) < 0) + if (Stat(tmpbuf, &tmpstatbuf2) < 0) return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; @@ -1582,10 +1981,13 @@ I32 *retlen; register char *s = start; register unsigned long retval = 0; - while (len-- && *s >= '0' && *s <= '7') { + while (len && *s >= '0' && *s <= '7') { retval <<= 3; retval |= *s++ - '0'; + len--; } + if (dowarn && len && (*s == '8' || *s == '9')) + warn("Illegal octal digit ignored"); *retlen = s - start; return retval; } @@ -1608,3 +2010,17 @@ I32 *retlen; *retlen = s - start; return retval; } + + +#ifdef HUGE_VAL +/* + * This hack is to force load of "huge" support from libm.a + * So it is in perl for (say) POSIX to use. + * Needed for SunOS with Sun's 'acc' for example. + */ +double +Perl_huge() +{ + return HUGE_VAL; +} +#endif