X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ea6641ad56e3d849f16fe61b8121cb626a6be049;hb=9a200e1b073bb063f06b3f44c2c596ce14d3211a;hp=71ef5c9ec9e3d799cfd631974c384fa0a9d34ca1;hpb=c07a80fdfe3926b5eb0585b674aa5d1f57b32ade;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 71ef5c9..ea6641a 100644 --- a/util.c +++ b/util.c @@ -19,20 +19,15 @@ #include #endif -/* Omit this -- it causes too much grief on mixed systems. +/* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include #endif -*/ #ifdef I_VFORK # include #endif -#ifdef I_LIMITS /* Needed for cast_xxx() functions below. */ -# include -#endif - /* Put this after #includes because fork and vfork prototypes may conflict. */ @@ -60,9 +55,10 @@ static void xstat _((void)); /* 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; @@ -70,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 */ @@ -83,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*/ @@ -100,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; + Malloc_t ptr; #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) - char *realloc(); + 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 */ @@ -130,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 @@ -145,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*/ @@ -155,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*/ @@ -168,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]++; @@ -188,18 +223,18 @@ MEM_SIZE size; return where + ALIGN; } -char * +Malloc_t safexrealloc(where,size) -char *where; +Malloc_t where; MEM_SIZE size; { - register char *new = saferealloc(where - ALIGN, size + ALIGN); + register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN); return new + ALIGN; } void safexfree(where) -char *where; +Malloc_t where; { I32 x; @@ -211,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() { @@ -218,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]; } } @@ -353,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; @@ -421,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 * @@ -458,12 +698,12 @@ SV *littlestr; } else { s = bigend - littlelen; - if (*s == *little && bcmp((char*)s,(char*)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((char*)s,(char*)little,littlelen)==0) + if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0) return (char*)s; } return Nullch; @@ -703,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); @@ -735,10 +976,20 @@ long a1, a2, a3, a4; 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 @@ -757,23 +1008,36 @@ long a1, a2, a3, a4; CV *cv; message = mess(pat,a1,a2,a3,a4); - if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + 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); - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } - fputs(message,stderr); - (void)fflush(stderr); - if (e_fp) + 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); @@ -794,22 +1058,27 @@ long a1, a2, a3, a4; CV *cv; message = mess(pat,a1,a2,a3,a4); - if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + 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; + } } - else { - fputs(message,stderr); + PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST - DEBUG_L(xstat()); + DEBUG_L(xstat()); #endif - (void)fflush(stderr); - } + (void)PerlIO_flush(PerlIO_stderr()); } #else /* !defined(I_STDARG) && !defined(I_VARARGS) */ @@ -826,6 +1095,7 @@ mess(pat, args) #endif { char *s; + char *s_start; SV *tmpstr; I32 usermess; #ifndef HAS_VPRINTF @@ -836,7 +1106,7 @@ mess(pat, args) #endif #endif - s = buf; + s = s_start = buf; usermess = strEQ(pat, "%s"); if (usermess) { tmpstr = sv_newmortal(); @@ -868,11 +1138,20 @@ mess(pat, args) 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 @@ -903,23 +1182,36 @@ croak(pat, va_alist) #endif message = mess(pat, &args); va_end(args); - if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + 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); - longjmp(top_env, 3); + Siglongjmp(top_env, 3); } - fputs(message,stderr); - (void)fflush(stderr); - if (e_fp) + 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))); @@ -952,22 +1244,27 @@ warn(pat,va_alist) message = mess(pat, &args); va_end(args); - if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); + 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; + } } - else { - fputs(message,stderr); + PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST - DEBUG_L(xstat()); + DEBUG_L(xstat()); #endif - (void)fflush(stderr); - } + (void)PerlIO_flush(PerlIO_stderr()); } #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ @@ -1126,14 +1423,6 @@ char *dest, *pat, *args; #endif } -int -vfprintf(fd, pat, args) -FILE *fd; -char *pat, *args; -{ - _doprnt(pat, args, fd); - return 0; /* wrong, but perl doesn't use the return value */ -} #endif /* HAS_VPRINTF */ #endif /* I_VARARGS || I_STDARGS */ @@ -1287,8 +1576,9 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif -#if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ -FILE * +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in + VMS.c, same with OS/2. */ +PerlIO * my_popen(cmd,mode) char *cmd; char *mode; @@ -1361,17 +1651,18 @@ char *mode; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; forkprocess = pid; - return fdopen(p[this], mode); + return PerlIO_fdopen(p[this], mode); } #else -#if defined(atarist) || defined(OS2) +#if defined(atarist) FILE *popen(); -FILE * +PerlIO * my_popen(cmd,mode) char *cmd; char *mode; { - return popen(cmd, mode); + /* Needs work for PerlIO ! */ + return popen(PerlIO_exportFILE(cmd), mode); } #endif @@ -1384,12 +1675,12 @@ char *s; int fd; struct stat tmpstatbuf; - fprintf(stderr,"%s", s); + PerlIO_printf(PerlIO_stderr(),"%s", s); for (fd = 0; fd < 32; fd++) { if (Fstat(fd,&tmpstatbuf) >= 0) - fprintf(stderr," %d",fd); + PerlIO_printf(PerlIO_stderr()," %d",fd); } - fprintf(stderr,"\n"); + PerlIO_printf(PerlIO_stderr(),"\n"); } #endif @@ -1421,21 +1712,21 @@ int newfd; } #endif -#if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) -FILE *ptr; +PerlIO *ptr; { Signal_t (*hstat)(), (*istat)(), (*qstat)(); int status; SV **svp; int pid; - svp = av_fetch(fdpid,fileno(ptr),TRUE); + svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); pid = (int)SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &sv_undef; - fclose(ptr); + PerlIO_close(ptr); #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif @@ -1526,13 +1817,17 @@ int status; return; } -#if defined(atarist) || defined(OS2) +#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 @@ -1582,29 +1877,6 @@ double f; #ifndef CASTI32 -/* Look for MAX and MIN integral values. If we can't find them, - we'll use 32-bit two's complement defaults. -*/ -#ifndef LONG_MAX -# ifdef MAXLONG /* Often used in */ -# define LONG_MAX MAXLONG -# else -# define LONG_MAX 2147483647L -# endif -#endif - -#ifndef LONG_MIN -# define LONG_MIN (-LONG_MAX - 1) -#endif - -#ifndef ULONG_MAX -# ifdef MAXULONG -# define LONG_MAX MAXULONG -# else -# define ULONG_MAX 4294967295L -# endif -#endif - /* 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 @@ -1615,18 +1887,24 @@ double f; ccflags. --Andy Dougherty */ -#ifndef MY_ULONG_MAX -# define MY_ULONG_MAX ((UV)LONG_MAX * (UV)2 + (UV)1) + +/* 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; { - if (f >= LONG_MAX) - return (I32) LONG_MAX; - if (f <= LONG_MIN) - return (I32) LONG_MIN; + if (f >= I32_MAX) + return (I32) I32_MAX; + if (f <= I32_MIN) + return (I32) I32_MIN; return (I32) f; } @@ -1634,10 +1912,10 @@ IV cast_iv(f) double f; { - if (f >= LONG_MAX) - return (IV) LONG_MAX; - if (f <= LONG_MIN) - return (IV) LONG_MIN; + if (f >= IV_MAX) + return (IV) IV_MAX; + if (f <= IV_MIN) + return (IV) IV_MIN; return (IV) f; } @@ -1645,8 +1923,8 @@ UV cast_uv(f) double f; { - if (f >= MY_ULONG_MAX) - return (UV) MY_ULONG_MAX; + if (f >= MY_UV_MAX) + return (UV) MY_UV_MAX; return (UV) f; } @@ -1732,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