3 * Copyright (c) 1991-1994, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
12 * not content." --Gandalf
18 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
22 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
31 /* Put this after #includes because fork and vfork prototypes may
42 # include <sys/file.h>
48 static void xstat _((void));
53 /* paranoid version of malloc */
55 /* NOTE: Do not call the next three routines directly. Use the macros
56 * in handy.h, so that we can easily redefine everything to do tracking of
57 * allocated hunks back to the original New to track down any memory leaks.
71 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
77 croak("panic: malloc");
79 ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
80 #if !(defined(I286) || defined(atarist))
81 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
83 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
90 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
96 /* paranoid version of realloc */
99 saferealloc(where,size)
108 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
110 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
114 PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH;
119 croak("Null realloc");
122 croak("panic: realloc");
124 ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
126 #if !(defined(I286) || defined(atarist))
128 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++);
129 PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
133 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++);
134 PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
143 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
149 /* safe version of free */
155 #if !(defined(I286) || defined(atarist))
156 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++));
158 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++));
166 /* safe version of calloc */
169 safecalloc(count, size)
176 if (size * count > 0xffff) {
177 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH;
182 if ((long)size < 0 || (long)count < 0)
183 croak("panic: calloc");
185 #if !(defined(I286) || defined(atarist))
186 DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
188 DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
191 ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
193 memset((void*)ptr, 0, size);
199 PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
205 #endif /* !safemalloc */
209 #define ALIGN sizeof(long)
216 register Malloc_t where;
218 where = safemalloc(size + ALIGN);
222 return where + ALIGN;
226 safexrealloc(where,size)
230 register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
243 x = where[0] + 100 * where[1];
249 safexcalloc(x,count,size)
254 register Malloc_t where;
256 where = safexmalloc(x, size * count + ALIGN);
258 memset((void*)where + ALIGN, 0, size * count);
261 return where + ALIGN;
269 for (i = 0; i < MAXXCOUNT; i++) {
270 if (xcount[i] > lastxcount[i]) {
271 PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
272 lastxcount[i] = xcount[i];
277 #endif /* LEAKTEST */
279 /* copy a string up to some (non-backslashed) delimiter, if any */
282 cpytill(to,from,fromend,delim,retlen)
285 register char *fromend;
291 for (; from < fromend; from++,to++) {
293 if (from[1] == delim)
295 else if (from[1] == '\\')
298 else if (*from == delim)
303 *retlen = to - origto;
307 /* return ptr to little string in big string, NULL if not found */
308 /* This routine was donated by Corey Satten. */
313 register char *little;
315 register char *s, *x;
326 for (x=big,s=little; *s; /**/ ) {
340 /* same as instr but allow embedded nulls */
343 ninstr(big, bigend, little, lend)
345 register char *bigend;
349 register char *s, *x;
350 register I32 first = *little;
351 register char *littleend = lend;
353 if (!first && little >= littleend)
355 if (bigend - big < littleend - little)
357 bigend -= littleend - little++;
358 while (big <= bigend) {
361 for (x=big,s=little; s < littleend; /**/ ) {
373 /* reverse of the above--find last substring */
376 rninstr(big, bigend, little, lend)
382 register char *bigbeg;
383 register char *s, *x;
384 register I32 first = *little;
385 register char *littleend = lend;
387 if (!first && little >= littleend)
390 big = bigend - (littleend - little++);
391 while (big >= bigbeg) {
394 for (x=big+2,s=little; s < littleend; /**/ ) {
406 /* Initialize locale (and the fold[] array).*/
408 perl_init_i18nl10n(printwarn)
413 * 1 = set ok or not applicable,
414 * 0 = fallback to C locale,
415 * -1 = fallback to C locale failed
417 #if defined(HAS_SETLOCALE) && defined(LC_CTYPE)
418 char * lang = getenv("LANG");
419 char * lc_all = getenv("LC_ALL");
420 char * lc_ctype = getenv("LC_CTYPE");
423 if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) {
425 PerlIO_printf(PerlIO_stderr(), "warning: setlocale(LC_CTYPE, \"\") failed.\n");
426 PerlIO_printf(PerlIO_stderr(),
427 "warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n",
428 lc_all ? lc_all : "(null)",
429 lc_ctype ? lc_ctype : "(null)",
430 lang ? lang : "(null)"
432 PerlIO_printf(PerlIO_stderr(), "warning: falling back to the \"C\" locale.\n");
435 if (setlocale(LC_CTYPE, "C") == NULL)
439 for (i = 0; i < 256; i++) {
440 if (isUPPER(i)) fold[i] = toLOWER(i);
441 else if (isLOWER(i)) fold[i] = toUPPER(i);
449 fbm_compile(sv, iflag)
453 register unsigned char *s;
454 register unsigned char *table;
456 register U32 len = SvCUR(sv);
461 return; /* can't have offsets that big */
463 table = (unsigned char*)(SvPVX(sv) + len + 1);
465 for (i = 0; i < 256; i++) {
469 while (s >= (unsigned char*)(SvPVX(sv)))
471 if (table[*s] == len) {
474 table[*s] = table[fold[*s]] = i;
488 sv_upgrade(sv, SVt_PVBM);
489 sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
492 s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
494 register U32 tmp, foldtmp;
496 for (i = 0; i < len; i++) {
498 foldtmp=freq[fold[s[i]]];
499 if (tmp < frequency && foldtmp < frequency) {
501 /* choose most frequent among the two */
502 frequency = (tmp > foldtmp) ? tmp : foldtmp;
507 for (i = 0; i < len; i++) {
508 if (freq[s[i]] < frequency) {
510 frequency = freq[s[i]];
514 BmRARE(sv) = s[rarest];
515 BmPREVIOUS(sv) = rarest;
516 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
520 fbm_instr(big, bigend, littlestr)
522 register unsigned char *bigend;
525 register unsigned char *s;
527 register I32 littlelen;
528 register unsigned char *little;
529 register unsigned char *table;
530 register unsigned char *olds;
531 register unsigned char *oldlittle;
533 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
535 char *l = SvPV(littlestr,len);
538 return ninstr((char*)big,(char*)bigend, l, l + len);
541 littlelen = SvCUR(littlestr);
542 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
543 if (littlelen > bigend - big)
545 little = (unsigned char*)SvPVX(littlestr);
546 if (SvCASEFOLD(littlestr)) { /* oops, fake it */
547 big = bigend - littlelen; /* just start near end */
548 if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
552 s = bigend - littlelen;
553 if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
554 return (char*)s; /* how sweet it is */
555 else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
558 if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
564 table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
565 if (--littlelen >= bigend - big)
568 oldlittle = little = table - 2;
569 if (SvCASEFOLD(littlestr)) { /* case insensitive? */
573 if (tmp = table[*s]) {
575 if (bigend - s > tmp) {
580 if ((s += tmp) < bigend)
586 tmp = littlelen; /* less expensive than calling strncmp() */
589 if (*--s == *--little || fold[*s] == *little)
591 s = olds + 1; /* here we pay the price for failure */
593 if (s < bigend) /* fake up continue to outer loop */
605 if (tmp = table[*s]) {
607 if (bigend - s > tmp) {
612 if ((s += tmp) < bigend)
618 tmp = littlelen; /* less expensive than calling strncmp() */
621 if (*--s == *--little)
623 s = olds + 1; /* here we pay the price for failure */
625 if (s < bigend) /* fake up continue to outer loop */
637 screaminstr(bigstr, littlestr)
641 register unsigned char *s, *x;
642 register unsigned char *big;
644 register I32 previous;
646 register unsigned char *little;
647 register unsigned char *bigend;
648 register unsigned char *littleend;
650 if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
652 little = (unsigned char *)(SvPVX(littlestr));
653 littleend = little + SvCUR(littlestr);
655 previous = BmPREVIOUS(littlestr);
656 big = (unsigned char *)(SvPVX(bigstr));
657 bigend = big + SvCUR(bigstr);
658 while (pos < previous) {
659 if (!(pos += screamnext[pos]))
663 if (SvCASEFOLD(littlestr)) { /* case insignificant? */
665 if (big[pos-previous] != first && big[pos-previous] != fold[first])
667 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
670 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
676 return (char *)(big+pos-previous);
678 pos += screamnext[pos] /* does this goof up anywhere? */
683 if (big[pos-previous] != first)
685 for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
694 return (char *)(big+pos-previous);
695 } while ( pos += screamnext[pos] );
697 #else /* !POINTERRIGOR */
699 if (SvCASEFOLD(littlestr)) { /* case insignificant? */
701 if (big[pos] != first && big[pos] != fold[first])
703 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
706 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
712 return (char *)(big+pos);
714 pos += screamnext[pos] /* does this goof up anywhere? */
719 if (big[pos] != first)
721 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
730 return (char *)(big+pos);
732 pos += screamnext[pos]
735 #endif /* POINTERRIGOR */
750 if (fold[*a++] == *b++)
757 /* copy a string to a safe spot */
763 register char *newaddr;
765 New(902,newaddr,strlen(sv)+1,char);
766 (void)strcpy(newaddr,sv);
770 /* same thing but with a known length */
777 register char *newaddr;
779 New(903,newaddr,len+1,char);
780 Copy(sv,newaddr,len,char); /* might not be null terminated */
781 newaddr[len] = '\0'; /* is now */
785 #if !defined(I_STDARG) && !defined(I_VARARGS)
788 * Fallback on the old hackers way of doing varargs
793 mess(pat,a1,a2,a3,a4)
799 I32 usermess = strEQ(pat,"%s");
804 tmpstr = sv_newmortal();
805 sv_setpv(tmpstr, (char*)a1);
806 *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
809 (void)sprintf(s,pat,a1,a2,a3,a4);
815 strcpy(s, " during global destruction.\n");
817 if (curcop->cop_line) {
818 (void)sprintf(s," at %s line %ld",
819 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
822 if (GvIO(last_in_gv) &&
823 IoLINES(GvIOp(last_in_gv)) ) {
824 (void)sprintf(s,", <%s> %s %ld",
825 last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
826 strEQ(rs,"\n") ? "line" : "chunk",
827 (long)IoLINES(GvIOp(last_in_gv)));
830 (void)strcpy(s,".\n");
834 sv_catpv(tmpstr,buf+1);
837 if (s - s_start >= sizeof(buf)) { /* Ooops! */
839 PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
841 PerlIO_puts(PerlIO_stderr(), buf);
842 PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n");
846 return SvPVX(tmpstr);
852 void croak(pat,a1,a2,a3,a4)
862 message = mess(pat,a1,a2,a3,a4);
863 if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
868 PUSHs(sv_2mortal(newSVpv(message,0)));
870 perl_call_sv((SV*)cv, G_DISCARD);
873 restartop = die_where(message);
874 Siglongjmp(top_env, 3);
876 PerlIO_puts(PerlIO_stderr(),message);
877 (void)PerlIO_flush(PerlIO_stderr());
883 (void)UNLINK(e_tmpname);
887 statusvalue = SHIFTSTATUS(statusvalue);
889 my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
891 my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
896 void warn(pat,a1,a2,a3,a4)
906 message = mess(pat,a1,a2,a3,a4);
907 if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
912 PUSHs(sv_2mortal(newSVpv(message,0)));
914 perl_call_sv((SV*)cv, G_DISCARD);
917 PerlIO_puts(PerlIO_stderr(),message);
921 (void)Fflush(PerlIO_stderr());
925 #else /* !defined(I_STDARG) && !defined(I_VARARGS) */
929 mess(char *pat, va_list *args)
943 #ifdef USE_CHAR_VSPRINTF
951 usermess = strEQ(pat, "%s");
953 tmpstr = sv_newmortal();
954 sv_setpv(tmpstr, va_arg(*args, char *));
955 *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
958 (void) vsprintf(s,pat,*args);
965 strcpy(s, " during global destruction.\n");
967 if (curcop->cop_line) {
968 (void)sprintf(s," at %s line %ld",
969 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
972 if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
973 bool line_mode = (RsSIMPLE(rs) &&
974 SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
975 (void)sprintf(s,", <%s> %s %ld",
976 last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
977 line_mode ? "line" : "chunk",
978 (long)IoLINES(GvIOp(last_in_gv)));
981 (void)strcpy(s,".\n");
985 sv_catpv(tmpstr,buf+1);
988 if (s - s_start >= sizeof(buf)) { /* Ooops! */
990 PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
992 PerlIO_puts(PerlIO_stderr(), buf);
993 PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
997 return SvPVX(tmpstr);
1004 croak(char* pat, ...)
1008 croak(pat, va_alist)
1020 va_start(args, pat);
1024 message = mess(pat, &args);
1026 if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
1031 PUSHs(sv_2mortal(newSVpv(message,0)));
1033 perl_call_sv((SV*)cv, G_DISCARD);
1036 restartop = die_where(message);
1037 Siglongjmp(top_env, 3);
1039 PerlIO_puts(PerlIO_stderr(),message);
1040 (void)PerlIO_flush(PerlIO_stderr());
1046 (void)UNLINK(e_tmpname);
1047 Safefree(e_tmpname);
1050 statusvalue = SHIFTSTATUS(statusvalue);
1052 my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
1054 my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1075 va_start(args, pat);
1079 message = mess(pat, &args);
1082 if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
1087 PUSHs(sv_2mortal(newSVpv(message,0)));
1089 perl_call_sv((SV*)cv, G_DISCARD);
1092 PerlIO_puts(PerlIO_stderr(),message);
1096 (void)PerlIO_flush(PerlIO_stderr());
1099 #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
1101 #ifndef VMS /* VMS' my_setenv() is in VMS.c */
1106 register I32 i=setenv_getix(nam); /* where does it go? */
1108 if (environ == origenviron) { /* need we copy environment? */
1114 for (max = i; environ[max]; max++) ;
1115 New(901,tmpenv, max+2, char*);
1116 for (j=0; j<max; j++) /* copy environment */
1117 tmpenv[j] = savepv(environ[j]);
1118 tmpenv[max] = Nullch;
1119 environ = tmpenv; /* tell exec where it is now */
1122 while (environ[i]) {
1123 environ[i] = environ[i+1];
1128 if (!environ[i]) { /* does not exist yet */
1129 Renew(environ, i+2, char*); /* just expand it a bit */
1130 environ[i+1] = Nullch; /* make sure it's null terminated */
1133 Safefree(environ[i]);
1134 New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
1136 (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
1138 /* MS-DOS requires environment variable names to be in uppercase */
1139 /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1140 * some utilities and applications may break because they only look
1141 * for upper case strings. (Fixed strupr() bug here.)]
1143 strcpy(environ[i],nam); strupr(environ[i]);
1144 (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1152 register I32 i, len = strlen(nam);
1154 for (i = 0; environ[i]; i++) {
1155 if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1156 break; /* strnEQ must come first to avoid */
1157 } /* potential SEGV's */
1162 #ifdef UNLINK_ALL_VERSIONS
1164 unlnk(f) /* unlink all versions of a file */
1169 for (i = 0; unlink(f) >= 0; i++) ;
1174 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
1176 my_bcopy(from,to,len)
1177 register char *from;
1183 if (from - to >= 0) {
1191 *(--to) = *(--from);
1197 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1213 my_memcmp(s1,s2,len)
1214 register unsigned char *s1;
1215 register unsigned char *s2;
1221 if (tmp = *s1++ - *s2++)
1226 #endif /* HAS_MEMCMP */
1228 #if defined(I_STDARG) || defined(I_VARARGS)
1231 #ifdef USE_CHAR_VSPRINTF
1236 vsprintf(dest, pat, args)
1237 char *dest, *pat, *args;
1241 fakebuf._ptr = dest;
1242 fakebuf._cnt = 32767;
1246 fakebuf._flag = _IOWRT|_IOSTRG;
1247 _doprnt(pat, args, &fakebuf); /* what a kludge */
1248 (void)putc('\0', &fakebuf);
1249 #ifdef USE_CHAR_VSPRINTF
1252 return 0; /* perl doesn't use return value */
1256 #endif /* HAS_VPRINTF */
1257 #endif /* I_VARARGS || I_STDARGS */
1260 #if BYTEORDER != 0x4321
1262 #ifndef CAN_PROTOTYPE
1269 #if (BYTEORDER & 1) == 0
1272 result = ((s & 255) << 8) + ((s >> 8) & 255);
1280 #ifndef CAN_PROTOTYPE
1289 char c[sizeof(long)];
1292 #if BYTEORDER == 0x1234
1293 u.c[0] = (l >> 24) & 255;
1294 u.c[1] = (l >> 16) & 255;
1295 u.c[2] = (l >> 8) & 255;
1299 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1300 croak("Unknown BYTEORDER\n");
1305 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1306 u.c[o & 0xf] = (l >> s) & 255;
1314 #ifndef CAN_PROTOTYPE
1323 char c[sizeof(long)];
1326 #if BYTEORDER == 0x1234
1327 u.c[0] = (l >> 24) & 255;
1328 u.c[1] = (l >> 16) & 255;
1329 u.c[2] = (l >> 8) & 255;
1333 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1334 croak("Unknown BYTEORDER\n");
1341 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1342 l |= (u.c[o & 0xf] & 255) << s;
1349 #endif /* BYTEORDER != 0x4321 */
1353 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1354 * If these functions are defined,
1355 * the BYTEORDER is neither 0x1234 nor 0x4321.
1356 * However, this is not assumed.
1360 #define HTOV(name,type) \
1367 char c[sizeof(type)]; \
1371 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1372 u.c[i] = (n >> s) & 0xFF; \
1377 #define VTOH(name,type) \
1384 char c[sizeof(type)]; \
1390 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1391 n += (u.c[i] & 0xFF) << s; \
1396 #if defined(HAS_HTOVS) && !defined(htovs)
1399 #if defined(HAS_HTOVL) && !defined(htovl)
1402 #if defined(HAS_VTOHS) && !defined(vtohs)
1405 #if defined(HAS_VTOHL) && !defined(vtohl)
1409 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in
1410 VMS.c, same with OS/2. */
1417 register I32 this, that;
1420 I32 doexec = strNE(cmd,"-");
1424 this = (*mode == 'w');
1429 taint_proper("Insecure %s%s", "EXEC");
1432 while ((pid = (doexec?vfork():fork())) < 0) {
1433 if (errno != EAGAIN) {
1436 croak("Can't fork");
1447 if (p[THIS] != (*mode == 'r')) {
1448 dup2(p[THIS], *mode == 'r');
1452 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1458 for (fd = maxsysfd + 1; fd < NOFILE; fd++)
1461 do_exec(cmd); /* may or may not use the shell */
1465 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1466 sv_setiv(GvSV(tmpgv),(I32)getpid());
1468 hv_clear(pidstatus); /* we have no children */
1473 do_execfree(); /* free any memory malloced by child on vfork */
1475 if (p[that] < p[this]) {
1476 dup2(p[this], p[that]);
1480 sv = *av_fetch(fdpid,p[this],TRUE);
1481 (void)SvUPGRADE(sv,SVt_IV);
1484 return PerlIO_fdopen(p[this], mode);
1487 #if defined(atarist)
1494 /* Needs work for PerlIO ! */
1495 return popen(PerlIO_exportFILE(cmd), mode);
1499 #endif /* !DOSISH */
1506 struct stat tmpstatbuf;
1508 PerlIO_printf(PerlIO_stderr(),"%s", s);
1509 for (fd = 0; fd < 32; fd++) {
1510 if (Fstat(fd,&tmpstatbuf) >= 0)
1511 PerlIO_printf(PerlIO_stderr()," %d",fd);
1513 PerlIO_printf(PerlIO_stderr(),"\n");
1523 #if defined(HAS_FCNTL) && defined(F_DUPFD)
1527 return fcntl(oldfd, F_DUPFD, newfd);
1536 while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
1539 close(fdtmp[--fdx]);
1545 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */
1550 Signal_t (*hstat)(), (*istat)(), (*qstat)();
1555 svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
1556 pid = (int)SvIVX(*svp);
1561 if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
1563 hstat = signal(SIGHUP, SIG_IGN);
1564 istat = signal(SIGINT, SIG_IGN);
1565 qstat = signal(SIGQUIT, SIG_IGN);
1567 pid = wait4pid(pid, &status, 0);
1568 } while (pid == -1 && errno == EINTR);
1569 signal(SIGHUP, hstat);
1570 signal(SIGINT, istat);
1571 signal(SIGQUIT, qstat);
1572 return(pid < 0 ? pid : status);
1574 #endif /* !DOSISH */
1576 #if !defined(DOSISH) || defined(OS2)
1578 wait4pid(pid,statusp,flags)
1590 sprintf(spid, "%d", pid);
1591 svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
1592 if (svp && *svp != &sv_undef) {
1593 *statusp = SvIVX(*svp);
1594 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
1601 hv_iterinit(pidstatus);
1602 if (entry = hv_iternext(pidstatus)) {
1603 pid = atoi(hv_iterkey(entry,(I32*)statusp));
1604 sv = hv_iterval(pidstatus,entry);
1605 *statusp = SvIVX(sv);
1606 sprintf(spid, "%d", pid);
1607 (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
1612 return waitpid(pid,statusp,flags);
1615 return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1620 croak("Can't do waitpid with flags");
1622 while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
1623 pidgone(result,*statusp);
1632 #endif /* !DOSISH */
1643 sprintf(spid, "%d", pid);
1644 sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
1645 (void)SvUPGRADE(sv,SVt_IV);
1650 #if defined(atarist) || (defined(OS2) && !defined(HAS_FORK))
1656 /* Needs work for PerlIO ! */
1657 FILE *f = PerlIO_findFILE(ptr);
1658 I32 result = pclose(f);
1659 PerlIO_releaseFILE(ptr,f);
1665 repeatcpy(to,from,len,count)
1667 register char *from;
1672 register char *frombase = from;
1680 while (count-- > 0) {
1681 for (todo = len; todo > 0; todo--) {
1688 #ifndef CASTNEGFLOAT
1696 # define BIGDOUBLE 2147483648.0
1698 return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
1701 return (unsigned long)f;
1703 return (unsigned long)along;
1710 /* Unfortunately, on some systems the cast_uv() function doesn't
1711 work with the system-supplied definition of ULONG_MAX. The
1712 comparison (f >= ULONG_MAX) always comes out true. It must be a
1713 problem with the compiler constant folding.
1715 In any case, this workaround should be fine on any two's complement
1716 system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
1718 --Andy Dougherty <doughera@lafcol.lafayette.edu>
1720 #ifndef MY_ULONG_MAX
1721 # define MY_ULONG_MAX ((UV)PERL_LONG_MAX * (UV)2 + (UV)1)
1728 if (f >= PERL_LONG_MAX)
1729 return (I32) PERL_LONG_MAX;
1730 if (f <= PERL_LONG_MIN)
1731 return (I32) PERL_LONG_MIN;
1739 if (f >= PERL_LONG_MAX)
1740 return (IV) PERL_LONG_MAX;
1741 if (f <= PERL_LONG_MIN)
1742 return (IV) PERL_LONG_MIN;
1750 if (f >= MY_ULONG_MAX)
1751 return (UV) MY_ULONG_MAX;
1763 char *fa = strrchr(a,'/');
1764 char *fb = strrchr(b,'/');
1765 struct stat tmpstatbuf1;
1766 struct stat tmpstatbuf2;
1768 #define MAXPATHLEN 1024
1770 char tmpbuf[MAXPATHLEN+1];
1785 strncpy(tmpbuf, a, fa - a);
1786 if (Stat(tmpbuf, &tmpstatbuf1) < 0)
1791 strncpy(tmpbuf, b, fb - b);
1792 if (Stat(tmpbuf, &tmpstatbuf2) < 0)
1794 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
1795 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
1797 #endif /* !HAS_RENAME */
1800 scan_oct(start, len, retlen)
1805 register char *s = start;
1806 register unsigned long retval = 0;
1808 while (len && *s >= '0' && *s <= '7') {
1810 retval |= *s++ - '0';
1813 if (dowarn && len && (*s == '8' || *s == '9'))
1814 warn("Illegal octal digit ignored");
1815 *retlen = s - start;
1820 scan_hex(start, len, retlen)
1825 register char *s = start;
1826 register unsigned long retval = 0;
1829 while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
1831 retval |= (tmp - hexdigit) & 15;
1834 *retlen = s - start;
1841 * This hack is to force load of "huge" support from libm.a
1842 * So it is in perl for (say) POSIX to use.
1843 * Needed for SunOS with Sun's 'acc' for example.