util.c

   1 /*    util.c
   2  *
   3  *    Copyright (c) 1991-1994, Larry Wall
   4  *
   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.
   7  *
   8  */
   9
  10 /*
  11  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  12  * not content."  --Gandalf
  13  */
  14
  15 #include "EXTERN.h"
  16 #include "perl.h"
  17
  18 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  19 #include <signal.h>
  20 #endif
  21
  22 /* Omit this -- it causes too much grief on mixed systems.
  23 #ifdef I_UNISTD
  24 #  include <unistd.h>
  25 #endif
  26 */
  27
  28 #ifdef I_VFORK
  29 #  include <vfork.h>
  30 #endif
  31
  32 #ifdef I_LIMITS  /* Needed for cast_xxx() functions below. */
  33 #  include <limits.h>
  34 #endif
  35
  36 /* Put this after #includes because fork and vfork prototypes may
  37    conflict.
  38 */
  39 #ifndef HAS_VFORK
  40 #   define vfork fork
  41 #endif
  42
  43 #ifdef I_FCNTL
  44 #  include <fcntl.h>
  45 #endif
  46 #ifdef I_SYS_FILE
  47 #  include <sys/file.h>
  48 #endif
  49
  50 #define FLUSH
  51
  52 #ifdef LEAKTEST
  53 static void xstat _((void));
  54 #endif
  55
  56 #ifndef safemalloc
  57
  58 /* paranoid version of malloc */
  59
  60 /* NOTE:  Do not call the next three routines directly.  Use the macros
  61  * in handy.h, so that we can easily redefine everything to do tracking of
  62  * allocated hunks back to the original New to track down any memory leaks.
  63  */
  64
  65 char *
  66 safemalloc(size)
  67 #ifdef MSDOS
  68 unsigned long size;
  69 #else
  70 MEM_SIZE size;
  71 #endif /* MSDOS */
  72 {
  73     char  *ptr;
  74 #ifdef MSDOS
  75         if (size > 0xffff) {
  76                 fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH;
  77                 my_exit(1);
  78         }
  79 #endif /* MSDOS */
  80 #ifdef DEBUGGING
  81     if ((long)size < 0)
  82         croak("panic: malloc");
  83 #endif
  84     ptr = malloc(size?size:1);  /* malloc(0) is NASTY on our system */
  85 #if !(defined(I286) || defined(atarist))
  86     DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
  87 #else
  88     DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
  89 #endif
  90     if (ptr != Nullch)
  91         return ptr;
  92     else if (nomemok)
  93         return Nullch;
  94     else {
  95         fputs(no_mem,stderr) FLUSH;
  96         my_exit(1);
  97     }
  98     /*NOTREACHED*/
  99 }
 100
 101 /* paranoid version of realloc */
 102
 103 char *
 104 saferealloc(where,size)
 105 char *where;
 106 #ifndef MSDOS
 107 MEM_SIZE size;
 108 #else
 109 unsigned long size;
 110 #endif /* MSDOS */
 111 {
 112     char *ptr;
 113 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
 114     char *realloc();
 115 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 116
 117 #ifdef MSDOS
 118         if (size > 0xffff) {
 119                 fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH;
 120                 my_exit(1);
 121         }
 122 #endif /* MSDOS */
 123     if (!where)
 124         croak("Null realloc");
 125 #ifdef DEBUGGING
 126     if ((long)size < 0)
 127         croak("panic: realloc");
 128 #endif
 129     ptr = realloc(where,size?size:1);   /* realloc(0) is NASTY on our system */
 130
 131 #if !(defined(I286) || defined(atarist))
 132     DEBUG_m( {
 133         fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
 134         fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
 135     } )
 136 #else
 137     DEBUG_m( {
 138         fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
 139         fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
 140     } )
 141 #endif
 142
 143     if (ptr != Nullch)
 144         return ptr;
 145     else if (nomemok)
 146         return Nullch;
 147     else {
 148         fputs(no_mem,stderr) FLUSH;
 149         my_exit(1);
 150     }
 151     /*NOTREACHED*/
 152 }
 153
 154 /* safe version of free */
 155
 156 void
 157 safefree(where)
 158 char *where;
 159 {
 160 #if !(defined(I286) || defined(atarist))
 161     DEBUG_m( fprintf(stderr,"0x%x: (%05d) free\n",where,an++));
 162 #else
 163     DEBUG_m( fprintf(stderr,"0x%lx: (%05d) free\n",where,an++));
 164 #endif
 165     if (where) {
 166         /*SUPPRESS 701*/
 167         free(where);
 168     }
 169 }
 170
 171 #endif /* !safemalloc */
 172
 173 #ifdef LEAKTEST
 174
 175 #define ALIGN sizeof(long)
 176
 177 char *
 178 safexmalloc(x,size)
 179 I32 x;
 180 MEM_SIZE size;
 181 {
 182     register char *where;
 183
 184     where = safemalloc(size + ALIGN);
 185     xcount[x]++;
 186     where[0] = x % 100;
 187     where[1] = x / 100;
 188     return where + ALIGN;
 189 }
 190
 191 char *
 192 safexrealloc(where,size)
 193 char *where;
 194 MEM_SIZE size;
 195 {
 196     register char *new = saferealloc(where - ALIGN, size + ALIGN);
 197     return new + ALIGN;
 198 }
 199
 200 void
 201 safexfree(where)
 202 char *where;
 203 {
 204     I32 x;
 205
 206     if (!where)
 207         return;
 208     where -= ALIGN;
 209     x = where[0] + 100 * where[1];
 210     xcount[x]--;
 211     safefree(where);
 212 }
 213
 214 static void
 215 xstat()
 216 {
 217     register I32 i;
 218
 219     for (i = 0; i < MAXXCOUNT; i++) {
 220         if (xcount[i] > lastxcount[i]) {
 221             fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
 222             lastxcount[i] = xcount[i];
 223         }
 224     }
 225 }
 226
 227 #endif /* LEAKTEST */
 228
 229 /* copy a string up to some (non-backslashed) delimiter, if any */
 230
 231 char *
 232 cpytill(to,from,fromend,delim,retlen)
 233 register char *to;
 234 register char *from;
 235 register char *fromend;
 236 register int delim;
 237 I32 *retlen;
 238 {
 239     char *origto = to;
 240
 241     for (; from < fromend; from++,to++) {
 242         if (*from == '\\') {
 243             if (from[1] == delim)
 244                 from++;
 245             else if (from[1] == '\\')
 246                 *to++ = *from++;
 247         }
 248         else if (*from == delim)
 249             break;
 250         *to = *from;
 251     }
 252     *to = '\0';
 253     *retlen = to - origto;
 254     return from;
 255 }
 256
 257 /* return ptr to little string in big string, NULL if not found */
 258 /* This routine was donated by Corey Satten. */
 259
 260 char *
 261 instr(big, little)
 262 register char *big;
 263 register char *little;
 264 {
 265     register char *s, *x;
 266     register I32 first;
 267
 268     if (!little)
 269         return big;
 270     first = *little++;
 271     if (!first)
 272         return big;
 273     while (*big) {
 274         if (*big++ != first)
 275             continue;
 276         for (x=big,s=little; *s; /**/ ) {
 277             if (!*x)
 278                 return Nullch;
 279             if (*s++ != *x++) {
 280                 s--;
 281                 break;
 282             }
 283         }
 284         if (!*s)
 285             return big-1;
 286     }
 287     return Nullch;
 288 }
 289
 290 /* same as instr but allow embedded nulls */
 291
 292 char *
 293 ninstr(big, bigend, little, lend)
 294 register char *big;
 295 register char *bigend;
 296 char *little;
 297 char *lend;
 298 {
 299     register char *s, *x;
 300     register I32 first = *little;
 301     register char *littleend = lend;
 302
 303     if (!first && little >= littleend)
 304         return big;
 305     if (bigend - big < littleend - little)
 306         return Nullch;
 307     bigend -= littleend - little++;
 308     while (big <= bigend) {
 309         if (*big++ != first)
 310             continue;
 311         for (x=big,s=little; s < littleend; /**/ ) {
 312             if (*s++ != *x++) {
 313                 s--;
 314                 break;
 315             }
 316         }
 317         if (s >= littleend)
 318             return big-1;
 319     }
 320     return Nullch;
 321 }
 322
 323 /* reverse of the above--find last substring */
 324
 325 char *
 326 rninstr(big, bigend, little, lend)
 327 register char *big;
 328 char *bigend;
 329 char *little;
 330 char *lend;
 331 {
 332     register char *bigbeg;
 333     register char *s, *x;
 334     register I32 first = *little;
 335     register char *littleend = lend;
 336
 337     if (!first && little >= littleend)
 338         return bigend;
 339     bigbeg = big;
 340     big = bigend - (littleend - little++);
 341     while (big >= bigbeg) {
 342         if (*big-- != first)
 343             continue;
 344         for (x=big+2,s=little; s < littleend; /**/ ) {
 345             if (*s++ != *x++) {
 346                 s--;
 347                 break;
 348             }
 349         }
 350         if (s >= littleend)
 351             return big+1;
 352     }
 353     return Nullch;
 354 }
 355
 356 /* Initialize locale (and the fold[] array).*/
 357 int
 358 perl_init_i18nl14n(printwarn)
 359     int printwarn;
 360 {
 361     int ok = 1;
 362     /* returns
 363      *    1 = set ok or not applicable,
 364      *    0 = fallback to C locale,
 365      *   -1 = fallback to C locale failed
 366      */
 367 #if defined(HAS_SETLOCALE) && defined(LC_CTYPE)
 368     char * lang     = getenv("LANG");
 369     char * lc_all   = getenv("LC_ALL");
 370     char * lc_ctype = getenv("LC_CTYPE");
 371     int i;
 372
 373     if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) {
 374         if (printwarn) {
 375             fprintf(stderr, "warning: setlocale(LC_CTYPE, \"\") failed.\n");
 376             fprintf(stderr,
 377               "warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n",
 378               lc_all   ? lc_all   : "(null)",
 379               lc_ctype ? lc_ctype : "(null)",
 380               lang     ? lang     : "(null)"
 381               );
 382             fprintf(stderr, "warning: falling back to the \"C\" locale.\n");
 383         }
 384         ok = 0;
 385         if (setlocale(LC_CTYPE, "C") == NULL)
 386             ok = -1;
 387     }
 388
 389     for (i = 0; i < 256; i++) {
 390         if (isUPPER(i)) fold[i] = toLOWER(i);
 391         else if (isLOWER(i)) fold[i] = toUPPER(i);
 392         else fold[i] = i;
 393     }
 394 #endif
 395     return ok;
 396 }
 397
 398 void
 399 fbm_compile(sv, iflag)
 400 SV *sv;
 401 I32 iflag;
 402 {
 403     register unsigned char *s;
 404     register unsigned char *table;
 405     register U32 i;
 406     register U32 len = SvCUR(sv);
 407     I32 rarest = 0;
 408     U32 frequency = 256;
 409
 410     if (len > 255)
 411         return;                 /* can't have offsets that big */
 412     Sv_Grow(sv,len+258);
 413     table = (unsigned char*)(SvPVX(sv) + len + 1);
 414     s = table - 2;
 415     for (i = 0; i < 256; i++) {
 416         table[i] = len;
 417     }
 418     i = 0;
 419     while (s >= (unsigned char*)(SvPVX(sv)))
 420     {
 421         if (table[*s] == len) {
 422 #ifndef pdp11
 423             if (iflag)
 424                 table[*s] = table[fold[*s]] = i;
 425 #else
 426             if (iflag) {
 427                 I32 j;
 428                 j = fold[*s];
 429                 table[j] = i;
 430                 table[*s] = i;
 431             }
 432 #endif /* pdp11 */
 433             else
 434                 table[*s] = i;
 435         }
 436         s--,i++;
 437     }
 438     sv_upgrade(sv, SVt_PVBM);
 439     sv_magic(sv, Nullsv, 'B', Nullch, 0);                       /* deep magic */
 440     SvVALID_on(sv);
 441
 442     s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
 443     if (iflag) {
 444         register U32 tmp, foldtmp;
 445         SvCASEFOLD_on(sv);
 446         for (i = 0; i < len; i++) {
 447             tmp=freq[s[i]];
 448             foldtmp=freq[fold[s[i]]];
 449             if (tmp < frequency && foldtmp < frequency) {
 450                 rarest = i;
 451                 /* choose most frequent among the two */
 452                 frequency = (tmp > foldtmp) ? tmp : foldtmp;
 453             }
 454         }
 455     }
 456     else {
 457         for (i = 0; i < len; i++) {
 458             if (freq[s[i]] < frequency) {
 459                 rarest = i;
 460                 frequency = freq[s[i]];
 461             }
 462         }
 463     }
 464     BmRARE(sv) = s[rarest];
 465     BmPREVIOUS(sv) = rarest;
 466     DEBUG_r(fprintf(stderr,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
 467 }
 468
 469 char *
 470 fbm_instr(big, bigend, littlestr)
 471 unsigned char *big;
 472 register unsigned char *bigend;
 473 SV *littlestr;
 474 {
 475     register unsigned char *s;
 476     register I32 tmp;
 477     register I32 littlelen;
 478     register unsigned char *little;
 479     register unsigned char *table;
 480     register unsigned char *olds;
 481     register unsigned char *oldlittle;
 482
 483     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 484         STRLEN len;
 485         char *l = SvPV(littlestr,len);
 486         if (!len)
 487             return (char*)big;
 488         return ninstr((char*)big,(char*)bigend, l, l + len);
 489     }
 490
 491     littlelen = SvCUR(littlestr);
 492     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 493         if (littlelen > bigend - big)
 494             return Nullch;
 495         little = (unsigned char*)SvPVX(littlestr);
 496         if (SvCASEFOLD(littlestr)) {    /* oops, fake it */
 497             big = bigend - littlelen;           /* just start near end */
 498             if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
 499                 big--;
 500         }
 501         else {
 502             s = bigend - littlelen;
 503             if (*s == *little && bcmp((char*)s,(char*)little,littlelen)==0)
 504                 return (char*)s;                /* how sweet it is */
 505             else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
 506               && s > big) {
 507                     s--;
 508                 if (*s == *little && bcmp((char*)s,(char*)little,littlelen)==0)
 509                     return (char*)s;
 510             }
 511             return Nullch;
 512         }
 513     }
 514     table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
 515     if (--littlelen >= bigend - big)
 516         return Nullch;
 517     s = big + littlelen;
 518     oldlittle = little = table - 2;
 519     if (SvCASEFOLD(littlestr)) {        /* case insensitive? */
 520         if (s < bigend) {
 521           top1:
 522             /*SUPPRESS 560*/
 523             if (tmp = table[*s]) {
 524 #ifdef POINTERRIGOR
 525                 if (bigend - s > tmp) {
 526                     s += tmp;
 527                     goto top1;
 528                 }
 529 #else
 530                 if ((s += tmp) < bigend)
 531                     goto top1;
 532 #endif
 533                 return Nullch;
 534             }
 535             else {
 536                 tmp = littlelen;        /* less expensive than calling strncmp() */
 537                 olds = s;
 538                 while (tmp--) {
 539                     if (*--s == *--little || fold[*s] == *little)
 540                         continue;
 541                     s = olds + 1;       /* here we pay the price for failure */
 542                     little = oldlittle;
 543                     if (s < bigend)     /* fake up continue to outer loop */
 544                         goto top1;
 545                     return Nullch;
 546                 }
 547                 return (char *)s;
 548             }
 549         }
 550     }
 551     else {
 552         if (s < bigend) {
 553           top2:
 554             /*SUPPRESS 560*/
 555             if (tmp = table[*s]) {
 556 #ifdef POINTERRIGOR
 557                 if (bigend - s > tmp) {
 558                     s += tmp;
 559                     goto top2;
 560                 }
 561 #else
 562                 if ((s += tmp) < bigend)
 563                     goto top2;
 564 #endif
 565                 return Nullch;
 566             }
 567             else {
 568                 tmp = littlelen;        /* less expensive than calling strncmp() */
 569                 olds = s;
 570                 while (tmp--) {
 571                     if (*--s == *--little)
 572                         continue;
 573                     s = olds + 1;       /* here we pay the price for failure */
 574                     little = oldlittle;
 575                     if (s < bigend)     /* fake up continue to outer loop */
 576                         goto top2;
 577                     return Nullch;
 578                 }
 579                 return (char *)s;
 580             }
 581         }
 582     }
 583     return Nullch;
 584 }
 585
 586 char *
 587 screaminstr(bigstr, littlestr)
 588 SV *bigstr;
 589 SV *littlestr;
 590 {
 591     register unsigned char *s, *x;
 592     register unsigned char *big;
 593     register I32 pos;
 594     register I32 previous;
 595     register I32 first;
 596     register unsigned char *little;
 597     register unsigned char *bigend;
 598     register unsigned char *littleend;
 599
 600     if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
 601         return Nullch;
 602     little = (unsigned char *)(SvPVX(littlestr));
 603     littleend = little + SvCUR(littlestr);
 604     first = *little++;
 605     previous = BmPREVIOUS(littlestr);
 606     big = (unsigned char *)(SvPVX(bigstr));
 607     bigend = big + SvCUR(bigstr);
 608     while (pos < previous) {
 609         if (!(pos += screamnext[pos]))
 610             return Nullch;
 611     }
 612 #ifdef POINTERRIGOR
 613     if (SvCASEFOLD(littlestr)) {        /* case insignificant? */
 614         do {
 615             if (big[pos-previous] != first && big[pos-previous] != fold[first])
 616                 continue;
 617             for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
 618                 if (x >= bigend)
 619                     return Nullch;
 620                 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
 621                     s--;
 622                     break;
 623                 }
 624             }
 625             if (s == littleend)
 626                 return (char *)(big+pos-previous);
 627         } while (
 628                 pos += screamnext[pos]  /* does this goof up anywhere? */
 629             );
 630     }
 631     else {
 632         do {
 633             if (big[pos-previous] != first)
 634                 continue;
 635             for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
 636                 if (x >= bigend)
 637                     return Nullch;
 638                 if (*s++ != *x++) {
 639                     s--;
 640                     break;
 641                 }
 642             }
 643             if (s == littleend)
 644                 return (char *)(big+pos-previous);
 645         } while ( pos += screamnext[pos] );
 646     }
 647 #else /* !POINTERRIGOR */
 648     big -= previous;
 649     if (SvCASEFOLD(littlestr)) {        /* case insignificant? */
 650         do {
 651             if (big[pos] != first && big[pos] != fold[first])
 652                 continue;
 653             for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 654                 if (x >= bigend)
 655                     return Nullch;
 656                 if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
 657                     s--;
 658                     break;
 659                 }
 660             }
 661             if (s == littleend)
 662                 return (char *)(big+pos);
 663         } while (
 664                 pos += screamnext[pos]  /* does this goof up anywhere? */
 665             );
 666     }
 667     else {
 668         do {
 669             if (big[pos] != first)
 670                 continue;
 671             for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 672                 if (x >= bigend)
 673                     return Nullch;
 674                 if (*s++ != *x++) {
 675                     s--;
 676                     break;
 677                 }
 678             }
 679             if (s == littleend)
 680                 return (char *)(big+pos);
 681         } while (
 682                 pos += screamnext[pos]
 683             );
 684     }
 685 #endif /* POINTERRIGOR */
 686     return Nullch;
 687 }
 688
 689 I32
 690 ibcmp(a,b,len)
 691 register U8 *a;
 692 register U8 *b;
 693 register I32 len;
 694 {
 695     while (len--) {
 696         if (*a == *b) {
 697             a++,b++;
 698             continue;
 699         }
 700         if (fold[*a++] == *b++)
 701             continue;
 702         return 1;
 703     }
 704     return 0;
 705 }
 706
 707 /* copy a string to a safe spot */
 708
 709 char *
 710 savepv(sv)
 711 char *sv;
 712 {
 713     register char *newaddr;
 714
 715     New(902,newaddr,strlen(sv)+1,char);
 716     (void)strcpy(newaddr,sv);
 717     return newaddr;
 718 }
 719
 720 /* same thing but with a known length */
 721
 722 char *
 723 savepvn(sv, len)
 724 char *sv;
 725 register I32 len;
 726 {
 727     register char *newaddr;
 728
 729     New(903,newaddr,len+1,char);
 730     Copy(sv,newaddr,len,char);          /* might not be null terminated */
 731     newaddr[len] = '\0';                /* is now */
 732     return newaddr;
 733 }
 734
 735 #if !defined(I_STDARG) && !defined(I_VARARGS)
 736
 737 /*
 738  * Fallback on the old hackers way of doing varargs
 739  */
 740
 741 /*VARARGS1*/
 742 char *
 743 mess(pat,a1,a2,a3,a4)
 744 char *pat;
 745 long a1, a2, a3, a4;
 746 {
 747     char *s;
 748     char *s_start;
 749     I32 usermess = strEQ(pat,"%s");
 750     SV *tmpstr;
 751
 752     s = s_start = buf;
 753     if (usermess) {
 754         tmpstr = sv_newmortal();
 755         sv_setpv(tmpstr, (char*)a1);
 756         *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
 757     }
 758     else {
 759         (void)sprintf(s,pat,a1,a2,a3,a4);
 760         s += strlen(s);
 761     }
 762
 763     if (s[-1] != '\n') {
 764         if (dirty)
 765             strcpy(s, " during global destruction.\n");
 766         else {
 767             if (curcop->cop_line) {
 768                 (void)sprintf(s," at %s line %ld",
 769                   SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
 770                 s += strlen(s);
 771             }
 772             if (GvIO(last_in_gv) &&
 773                 IoLINES(GvIOp(last_in_gv)) ) {
 774                 (void)sprintf(s,", <%s> %s %ld",
 775                   last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
 776                   strEQ(rs,"\n") ? "line" : "chunk",
 777                   (long)IoLINES(GvIOp(last_in_gv)));
 778                 s += strlen(s);
 779             }
 780             (void)strcpy(s,".\n");
 781             s += 2;
 782         }
 783         if (usermess)
 784             sv_catpv(tmpstr,buf+1);
 785     }
 786
 787     if (s - s_start >= sizeof(buf)) {   /* Ooops! */
 788         if (usermess)
 789             fputs(SvPVX(tmpstr), stderr);
 790         else
 791             fputs(buf, stderr);
 792         fputs("panic: message overflow - memory corrupted!\n",stderr);
 793         my_exit(1);
 794     }
 795     if (usermess)
 796         return SvPVX(tmpstr);
 797     else
 798         return buf;
 799 }
 800
 801 /*VARARGS1*/
 802 void croak(pat,a1,a2,a3,a4)
 803 char *pat;
 804 long a1, a2, a3, a4;
 805 {
 806     char *tmps;
 807     char *message;
 808     HV *stash;
 809     GV *gv;
 810     CV *cv;
 811
 812     message = mess(pat,a1,a2,a3,a4);
 813     if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
 814         dSP;
 815
 816         PUSHMARK(sp);
 817         EXTEND(sp, 1);
 818         PUSHs(sv_2mortal(newSVpv(message,0)));
 819         PUTBACK;
 820         perl_call_sv((SV*)cv, G_DISCARD);
 821     }
 822     if (in_eval) {
 823         restartop = die_where(message);
 824         Siglongjmp(top_env, 3);
 825     }
 826     fputs(message,stderr);
 827     (void)Fflush(stderr);
 828     if (e_fp) {
 829         fclose(e_fp);
 830         e_fp = Nullfp;
 831         (void)UNLINK(e_tmpname);
 832     }
 833     statusvalue = SHIFTSTATUS(statusvalue);
 834 #ifdef VMS
 835     my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
 836 #else
 837     my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
 838 #endif
 839 }
 840
 841 /*VARARGS1*/
 842 void warn(pat,a1,a2,a3,a4)
 843 char *pat;
 844 long a1, a2, a3, a4;
 845 {
 846     char *message;
 847     SV *sv;
 848     HV *stash;
 849     GV *gv;
 850     CV *cv;
 851
 852     message = mess(pat,a1,a2,a3,a4);
 853     if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
 854         dSP;
 855
 856         PUSHMARK(sp);
 857         EXTEND(sp, 1);
 858         PUSHs(sv_2mortal(newSVpv(message,0)));
 859         PUTBACK;
 860         perl_call_sv((SV*)cv, G_DISCARD);
 861     }
 862     else {
 863         fputs(message,stderr);
 864 #ifdef LEAKTEST
 865         DEBUG_L(xstat());
 866 #endif
 867         (void)Fflush(stderr);
 868     }
 869 }
 870
 871 #else /* !defined(I_STDARG) && !defined(I_VARARGS) */
 872
 873 #ifdef I_STDARG
 874 char *
 875 mess(char *pat, va_list *args)
 876 #else
 877 /*VARARGS0*/
 878 char *
 879 mess(pat, args)
 880     char *pat;
 881     va_list *args;
 882 #endif
 883 {
 884     char *s;
 885     char *s_start;
 886     SV *tmpstr;
 887     I32 usermess;
 888 #ifndef HAS_VPRINTF
 889 #ifdef USE_CHAR_VSPRINTF
 890     char *vsprintf();
 891 #else
 892     I32 vsprintf();
 893 #endif
 894 #endif
 895
 896     s = s_start = buf;
 897     usermess = strEQ(pat, "%s");
 898     if (usermess) {
 899         tmpstr = sv_newmortal();
 900         sv_setpv(tmpstr, va_arg(*args, char *));
 901         *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
 902     }
 903     else {
 904         (void) vsprintf(s,pat,*args);
 905         s += strlen(s);
 906     }
 907     va_end(*args);
 908
 909     if (s[-1] != '\n') {
 910         if (dirty)
 911             strcpy(s, " during global destruction.\n");
 912         else {
 913             if (curcop->cop_line) {
 914                 (void)sprintf(s," at %s line %ld",
 915                   SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
 916                 s += strlen(s);
 917             }
 918             if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
 919                 bool line_mode = (RsSIMPLE(rs) &&
 920                                   SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
 921                 (void)sprintf(s,", <%s> %s %ld",
 922                   last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
 923                   line_mode ? "line" : "chunk",
 924                   (long)IoLINES(GvIOp(last_in_gv)));
 925                 s += strlen(s);
 926             }
 927             (void)strcpy(s,".\n");
 928             s += 2;
 929         }
 930         if (usermess)
 931             sv_catpv(tmpstr,buf+1);
 932     }
 933
 934     if (s - s_start >= sizeof(buf)) {   /* Ooops! */
 935         if (usermess)
 936             fputs(SvPVX(tmpstr), stderr);
 937         else
 938             fputs(buf, stderr);
 939         fputs("panic: message overflow - memory corrupted!\n",stderr);
 940         my_exit(1);
 941     }
 942     if (usermess)
 943         return SvPVX(tmpstr);
 944     else
 945         return buf;
 946 }
 947
 948 #ifdef I_STDARG
 949 void
 950 croak(char* pat, ...)
 951 #else
 952 /*VARARGS0*/
 953 void
 954 croak(pat, va_alist)
 955     char *pat;
 956     va_dcl
 957 #endif
 958 {
 959     va_list args;
 960     char *message;
 961     HV *stash;
 962     GV *gv;
 963     CV *cv;
 964
 965 #ifdef I_STDARG
 966     va_start(args, pat);
 967 #else
 968     va_start(args);
 969 #endif
 970     message = mess(pat, &args);
 971     va_end(args);
 972     if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
 973         dSP;
 974
 975         PUSHMARK(sp);
 976         EXTEND(sp, 1);
 977         PUSHs(sv_2mortal(newSVpv(message,0)));
 978         PUTBACK;
 979         perl_call_sv((SV*)cv, G_DISCARD);
 980     }
 981     if (in_eval) {
 982         restartop = die_where(message);
 983         Siglongjmp(top_env, 3);
 984     }
 985     fputs(message,stderr);
 986     (void)Fflush(stderr);
 987     if (e_fp) {
 988         fclose(e_fp);
 989         e_fp = Nullfp;
 990         (void)UNLINK(e_tmpname);
 991     }
 992     statusvalue = SHIFTSTATUS(statusvalue);
 993 #ifdef VMS
 994     my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
 995 #else
 996     my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
 997 #endif
 998 }
 999
1000 void
1001 #ifdef I_STDARG
1002 warn(char* pat,...)
1003 #else
1004 /*VARARGS0*/
1005 warn(pat,va_alist)
1006     char *pat;
1007     va_dcl
1008 #endif
1009 {
1010     va_list args;
1011     char *message;
1012     HV *stash;
1013     GV *gv;
1014     CV *cv;
1015
1016 #ifdef I_STDARG
1017     va_start(args, pat);
1018 #else
1019     va_start(args);
1020 #endif
1021     message = mess(pat, &args);
1022     va_end(args);
1023
1024     if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
1025         dSP;
1026
1027         PUSHMARK(sp);
1028         EXTEND(sp, 1);
1029         PUSHs(sv_2mortal(newSVpv(message,0)));
1030         PUTBACK;
1031         perl_call_sv((SV*)cv, G_DISCARD);
1032     }
1033     else {
1034         fputs(message,stderr);
1035 #ifdef LEAKTEST
1036         DEBUG_L(xstat());
1037 #endif
1038         (void)Fflush(stderr);
1039     }
1040 }
1041 #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
1042
1043 #ifndef VMS  /* VMS' my_setenv() is in VMS.c */
1044 void
1045 my_setenv(nam,val)
1046 char *nam, *val;
1047 {
1048     register I32 i=setenv_getix(nam);           /* where does it go? */
1049
1050     if (environ == origenviron) {       /* need we copy environment? */
1051         I32 j;
1052         I32 max;
1053         char **tmpenv;
1054
1055         /*SUPPRESS 530*/
1056         for (max = i; environ[max]; max++) ;
1057         New(901,tmpenv, max+2, char*);
1058         for (j=0; j<max; j++)           /* copy environment */
1059             tmpenv[j] = savepv(environ[j]);
1060         tmpenv[max] = Nullch;
1061         environ = tmpenv;               /* tell exec where it is now */
1062     }
1063     if (!val) {
1064         while (environ[i]) {
1065             environ[i] = environ[i+1];
1066             i++;
1067         }
1068         return;
1069     }
1070     if (!environ[i]) {                  /* does not exist yet */
1071         Renew(environ, i+2, char*);     /* just expand it a bit */
1072         environ[i+1] = Nullch;  /* make sure it's null terminated */
1073     }
1074     else
1075         Safefree(environ[i]);
1076     New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
1077 #ifndef MSDOS
1078     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
1079 #else
1080     /* MS-DOS requires environment variable names to be in uppercase */
1081     /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1082      * some utilities and applications may break because they only look
1083      * for upper case strings. (Fixed strupr() bug here.)]
1084      */
1085     strcpy(environ[i],nam); strupr(environ[i]);
1086     (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1087 #endif /* MSDOS */
1088 }
1089
1090 I32
1091 setenv_getix(nam)
1092 char *nam;
1093 {
1094     register I32 i, len = strlen(nam);
1095
1096     for (i = 0; environ[i]; i++) {
1097         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1098             break;                      /* strnEQ must come first to avoid */
1099     }                                   /* potential SEGV's */
1100     return i;
1101 }
1102 #endif /* !VMS */
1103
1104 #ifdef UNLINK_ALL_VERSIONS
1105 I32
1106 unlnk(f)        /* unlink all versions of a file */
1107 char *f;
1108 {
1109     I32 i;
1110
1111     for (i = 0; unlink(f) >= 0; i++) ;
1112     return i ? 0 : -1;
1113 }
1114 #endif
1115
1116 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
1117 char *
1118 my_bcopy(from,to,len)
1119 register char *from;
1120 register char *to;
1121 register I32 len;
1122 {
1123     char *retval = to;
1124
1125     if (from - to >= 0) {
1126         while (len--)
1127             *to++ = *from++;
1128     }
1129     else {
1130         to += len;
1131         from += len;
1132         while (len--)
1133             *(--to) = *(--from);
1134     }
1135     return retval;
1136 }
1137 #endif
1138
1139 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1140 char *
1141 my_bzero(loc,len)
1142 register char *loc;
1143 register I32 len;
1144 {
1145     char *retval = loc;
1146
1147     while (len--)
1148         *loc++ = 0;
1149     return retval;
1150 }
1151 #endif
1152
1153 #ifndef HAS_MEMCMP
1154 I32
1155 my_memcmp(s1,s2,len)
1156 register unsigned char *s1;
1157 register unsigned char *s2;
1158 register I32 len;
1159 {
1160     register I32 tmp;
1161
1162     while (len--) {
1163         if (tmp = *s1++ - *s2++)
1164             return tmp;
1165     }
1166     return 0;
1167 }
1168 #endif /* HAS_MEMCMP */
1169
1170 #if defined(I_STDARG) || defined(I_VARARGS)
1171 #ifndef HAS_VPRINTF
1172
1173 #ifdef USE_CHAR_VSPRINTF
1174 char *
1175 #else
1176 int
1177 #endif
1178 vsprintf(dest, pat, args)
1179 char *dest, *pat, *args;
1180 {
1181     FILE fakebuf;
1182
1183     fakebuf._ptr = dest;
1184     fakebuf._cnt = 32767;
1185 #ifndef _IOSTRG
1186 #define _IOSTRG 0
1187 #endif
1188     fakebuf._flag = _IOWRT|_IOSTRG;
1189     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1190     (void)putc('\0', &fakebuf);
1191 #ifdef USE_CHAR_VSPRINTF
1192     return(dest);
1193 #else
1194     return 0;           /* perl doesn't use return value */
1195 #endif
1196 }
1197
1198 int
1199 vfprintf(fd, pat, args)
1200 FILE *fd;
1201 char *pat, *args;
1202 {
1203     _doprnt(pat, args, fd);
1204     return 0;           /* wrong, but perl doesn't use the return value */
1205 }
1206 #endif /* HAS_VPRINTF */
1207 #endif /* I_VARARGS || I_STDARGS */
1208
1209 #ifdef MYSWAP
1210 #if BYTEORDER != 0x4321
1211 short
1212 #ifndef CAN_PROTOTYPE
1213 my_swap(s)
1214 short s;
1215 #else
1216 my_swap(short s)
1217 #endif
1218 {
1219 #if (BYTEORDER & 1) == 0
1220     short result;
1221
1222     result = ((s & 255) << 8) + ((s >> 8) & 255);
1223     return result;
1224 #else
1225     return s;
1226 #endif
1227 }
1228
1229 long
1230 #ifndef CAN_PROTOTYPE
1231 my_htonl(l)
1232 register long l;
1233 #else
1234 my_htonl(long l)
1235 #endif
1236 {
1237     union {
1238         long result;
1239         char c[sizeof(long)];
1240     } u;
1241
1242 #if BYTEORDER == 0x1234
1243     u.c[0] = (l >> 24) & 255;
1244     u.c[1] = (l >> 16) & 255;
1245     u.c[2] = (l >> 8) & 255;
1246     u.c[3] = l & 255;
1247     return u.result;
1248 #else
1249 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1250     croak("Unknown BYTEORDER\n");
1251 #else
1252     register I32 o;
1253     register I32 s;
1254
1255     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1256         u.c[o & 0xf] = (l >> s) & 255;
1257     }
1258     return u.result;
1259 #endif
1260 #endif
1261 }
1262
1263 long
1264 #ifndef CAN_PROTOTYPE
1265 my_ntohl(l)
1266 register long l;
1267 #else
1268 my_ntohl(long l)
1269 #endif
1270 {
1271     union {
1272         long l;
1273         char c[sizeof(long)];
1274     } u;
1275
1276 #if BYTEORDER == 0x1234
1277     u.c[0] = (l >> 24) & 255;
1278     u.c[1] = (l >> 16) & 255;
1279     u.c[2] = (l >> 8) & 255;
1280     u.c[3] = l & 255;
1281     return u.l;
1282 #else
1283 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1284     croak("Unknown BYTEORDER\n");
1285 #else
1286     register I32 o;
1287     register I32 s;
1288
1289     u.l = l;
1290     l = 0;
1291     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1292         l |= (u.c[o & 0xf] & 255) << s;
1293     }
1294     return l;
1295 #endif
1296 #endif
1297 }
1298
1299 #endif /* BYTEORDER != 0x4321 */
1300 #endif /* MYSWAP */
1301
1302 /*
1303  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1304  * If these functions are defined,
1305  * the BYTEORDER is neither 0x1234 nor 0x4321.
1306  * However, this is not assumed.
1307  * -DWS
1308  */
1309
1310 #define HTOV(name,type)                                         \
1311         type                                                    \
1312         name (n)                                                \
1313         register type n;                                        \
1314         {                                                       \
1315             union {                                             \
1316                 type value;                                     \
1317                 char c[sizeof(type)];                           \
1318             } u;                                                \
1319             register I32 i;                                     \
1320             register I32 s;                                     \
1321             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1322                 u.c[i] = (n >> s) & 0xFF;                       \
1323             }                                                   \
1324             return u.value;                                     \
1325         }
1326
1327 #define VTOH(name,type)                                         \
1328         type                                                    \
1329         name (n)                                                \
1330         register type n;                                        \
1331         {                                                       \
1332             union {                                             \
1333                 type value;                                     \
1334                 char c[sizeof(type)];                           \
1335             } u;                                                \
1336             register I32 i;                                     \
1337             register I32 s;                                     \
1338             u.value = n;                                        \
1339             n = 0;                                              \
1340             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1341                 n += (u.c[i] & 0xFF) << s;                      \
1342             }                                                   \
1343             return n;                                           \
1344         }
1345
1346 #if defined(HAS_HTOVS) && !defined(htovs)
1347 HTOV(htovs,short)
1348 #endif
1349 #if defined(HAS_HTOVL) && !defined(htovl)
1350 HTOV(htovl,long)
1351 #endif
1352 #if defined(HAS_VTOHS) && !defined(vtohs)
1353 VTOH(vtohs,short)
1354 #endif
1355 #if defined(HAS_VTOHL) && !defined(vtohl)
1356 VTOH(vtohl,long)
1357 #endif
1358
1359 #if  !defined(DOSISH) && !defined(VMS)  /* VMS' my_popen() is in
1360                                            VMS.c, same with OS/2. */
1361 FILE *
1362 my_popen(cmd,mode)
1363 char    *cmd;
1364 char    *mode;
1365 {
1366     int p[2];
1367     register I32 this, that;
1368     register I32 pid;
1369     SV *sv;
1370     I32 doexec = strNE(cmd,"-");
1371
1372     if (pipe(p) < 0)
1373         return Nullfp;
1374     this = (*mode == 'w');
1375     that = !this;
1376     if (tainting) {
1377         if (doexec) {
1378             taint_env();
1379             taint_proper("Insecure %s%s", "EXEC");
1380         }
1381     }
1382     while ((pid = (doexec?vfork():fork())) < 0) {
1383         if (errno != EAGAIN) {
1384             close(p[this]);
1385             if (!doexec)
1386                 croak("Can't fork");
1387             return Nullfp;
1388         }
1389         sleep(5);
1390     }
1391     if (pid == 0) {
1392         GV* tmpgv;
1393
1394 #define THIS that
1395 #define THAT this
1396         close(p[THAT]);
1397         if (p[THIS] != (*mode == 'r')) {
1398             dup2(p[THIS], *mode == 'r');
1399             close(p[THIS]);
1400         }
1401         if (doexec) {
1402 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1403             int fd;
1404
1405 #ifndef NOFILE
1406 #define NOFILE 20
1407 #endif
1408             for (fd = maxsysfd + 1; fd < NOFILE; fd++)
1409                 close(fd);
1410 #endif
1411             do_exec(cmd);       /* may or may not use the shell */
1412             _exit(1);
1413         }
1414         /*SUPPRESS 560*/
1415         if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1416             sv_setiv(GvSV(tmpgv),(I32)getpid());
1417         forkprocess = 0;
1418         hv_clear(pidstatus);    /* we have no children */
1419         return Nullfp;
1420 #undef THIS
1421 #undef THAT
1422     }
1423     do_execfree();      /* free any memory malloced by child on vfork */
1424     close(p[that]);
1425     if (p[that] < p[this]) {
1426         dup2(p[this], p[that]);
1427         close(p[this]);
1428         p[this] = p[that];
1429     }
1430     sv = *av_fetch(fdpid,p[this],TRUE);
1431     (void)SvUPGRADE(sv,SVt_IV);
1432     SvIVX(sv) = pid;
1433     forkprocess = pid;
1434     return fdopen(p[this], mode);
1435 }
1436 #else
1437 #if defined(atarist)
1438 FILE *popen();
1439 FILE *
1440 my_popen(cmd,mode)
1441 char    *cmd;
1442 char    *mode;
1443 {
1444     return popen(cmd, mode);
1445 }
1446 #endif
1447
1448 #endif /* !DOSISH */
1449
1450 #ifdef DUMP_FDS
1451 dump_fds(s)
1452 char *s;
1453 {
1454     int fd;
1455     struct stat tmpstatbuf;
1456
1457     fprintf(stderr,"%s", s);
1458     for (fd = 0; fd < 32; fd++) {
1459         if (Fstat(fd,&tmpstatbuf) >= 0)
1460             fprintf(stderr," %d",fd);
1461     }
1462     fprintf(stderr,"\n");
1463 }
1464 #endif
1465
1466 #ifndef HAS_DUP2
1467 int
1468 dup2(oldfd,newfd)
1469 int oldfd;
1470 int newfd;
1471 {
1472 #if defined(HAS_FCNTL) && defined(F_DUPFD)
1473     if (oldfd == newfd)
1474         return oldfd;
1475     close(newfd);
1476     return fcntl(oldfd, F_DUPFD, newfd);
1477 #else
1478     int fdtmp[256];
1479     I32 fdx = 0;
1480     int fd;
1481
1482     if (oldfd == newfd)
1483         return oldfd;
1484     close(newfd);
1485     while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
1486         fdtmp[fdx++] = fd;
1487     while (fdx > 0)
1488         close(fdtmp[--fdx]);
1489     return fd;
1490 #endif
1491 }
1492 #endif
1493
1494 #if  !defined(DOSISH) && !defined(VMS)  /* VMS' my_popen() is in VMS.c */
1495 I32
1496 my_pclose(ptr)
1497 FILE *ptr;
1498 {
1499     Signal_t (*hstat)(), (*istat)(), (*qstat)();
1500     int status;
1501     SV **svp;
1502     int pid;
1503
1504     svp = av_fetch(fdpid,fileno(ptr),TRUE);
1505     pid = (int)SvIVX(*svp);
1506     SvREFCNT_dec(*svp);
1507     *svp = &sv_undef;
1508     fclose(ptr);
1509 #ifdef UTS
1510     if(kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
1511 #endif
1512     hstat = signal(SIGHUP, SIG_IGN);
1513     istat = signal(SIGINT, SIG_IGN);
1514     qstat = signal(SIGQUIT, SIG_IGN);
1515     do {
1516         pid = wait4pid(pid, &status, 0);
1517     } while (pid == -1 && errno == EINTR);
1518     signal(SIGHUP, hstat);
1519     signal(SIGINT, istat);
1520     signal(SIGQUIT, qstat);
1521     return(pid < 0 ? pid : status);
1522 }
1523 #endif /* !DOSISH */
1524
1525 #if  !defined(DOSISH) || defined(OS2)
1526 I32
1527 wait4pid(pid,statusp,flags)
1528 int pid;
1529 int *statusp;
1530 int flags;
1531 {
1532     SV *sv;
1533     SV** svp;
1534     char spid[16];
1535
1536     if (!pid)
1537         return -1;
1538     if (pid > 0) {
1539         sprintf(spid, "%d", pid);
1540         svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
1541         if (svp && *svp != &sv_undef) {
1542             *statusp = SvIVX(*svp);
1543             (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
1544             return pid;
1545         }
1546     }
1547     else {
1548         HE *entry;
1549
1550         hv_iterinit(pidstatus);
1551         if (entry = hv_iternext(pidstatus)) {
1552             pid = atoi(hv_iterkey(entry,(I32*)statusp));
1553             sv = hv_iterval(pidstatus,entry);
1554             *statusp = SvIVX(sv);
1555             sprintf(spid, "%d", pid);
1556             (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
1557             return pid;
1558         }
1559     }
1560 #ifdef HAS_WAITPID
1561     return waitpid(pid,statusp,flags);
1562 #else
1563 #ifdef HAS_WAIT4
1564     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1565 #else
1566     {
1567         I32 result;
1568         if (flags)
1569             croak("Can't do waitpid with flags");
1570         else {
1571             while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
1572                 pidgone(result,*statusp);
1573             if (result < 0)
1574                 *statusp = -1;
1575         }
1576         return result;
1577     }
1578 #endif
1579 #endif
1580 }
1581 #endif /* !DOSISH */
1582
1583 void
1584 /*SUPPRESS 590*/
1585 pidgone(pid,status)
1586 int pid;
1587 int status;
1588 {
1589     register SV *sv;
1590     char spid[16];
1591
1592     sprintf(spid, "%d", pid);
1593     sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
1594     (void)SvUPGRADE(sv,SVt_IV);
1595     SvIVX(sv) = status;
1596     return;
1597 }
1598
1599 #if defined(atarist) || defined(OS2)
1600 int pclose();
1601 I32
1602 my_pclose(ptr)
1603 FILE *ptr;
1604 {
1605     return pclose(ptr);
1606 }
1607 #endif
1608
1609 void
1610 repeatcpy(to,from,len,count)
1611 register char *to;
1612 register char *from;
1613 I32 len;
1614 register I32 count;
1615 {
1616     register I32 todo;
1617     register char *frombase = from;
1618
1619     if (len == 1) {
1620         todo = *from;
1621         while (count-- > 0)
1622             *to++ = todo;
1623         return;
1624     }
1625     while (count-- > 0) {
1626         for (todo = len; todo > 0; todo--) {
1627             *to++ = *from++;
1628         }
1629         from = frombase;
1630     }
1631 }
1632
1633 #ifndef CASTNEGFLOAT
1634 U32
1635 cast_ulong(f)
1636 double f;
1637 {
1638     long along;
1639
1640 #if CASTFLAGS & 2
1641 #   define BIGDOUBLE 2147483648.0
1642     if (f >= BIGDOUBLE)
1643         return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
1644 #endif
1645     if (f >= 0.0)
1646         return (unsigned long)f;
1647     along = (long)f;
1648     return (unsigned long)along;
1649 }
1650 # undef BIGDOUBLE
1651 #endif
1652
1653 #ifndef CASTI32
1654
1655 /* Look for MAX and MIN integral values.  If we can't find them,
1656    we'll use 32-bit two's complement defaults.
1657 */
1658 #ifndef LONG_MAX
1659 #  ifdef MAXLONG    /* Often used in <values.h> */
1660 #    define LONG_MAX MAXLONG
1661 #  else
1662 #    define LONG_MAX        2147483647L
1663 #  endif
1664 #endif
1665
1666 #ifndef LONG_MIN
1667 #    define LONG_MIN        (-LONG_MAX - 1)
1668 #endif
1669
1670 #ifndef ULONG_MAX
1671 #  ifdef MAXULONG
1672 #    define LONG_MAX MAXULONG
1673 #  else
1674 #    define ULONG_MAX       4294967295L
1675 #  endif
1676 #endif
1677
1678 /* Unfortunately, on some systems the cast_uv() function doesn't
1679    work with the system-supplied definition of ULONG_MAX.  The
1680    comparison  (f >= ULONG_MAX) always comes out true.  It must be a
1681    problem with the compiler constant folding.
1682
1683    In any case, this workaround should be fine on any two's complement
1684    system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
1685    ccflags.
1686                --Andy Dougherty      <doughera@lafcol.lafayette.edu>
1687 */
1688 #ifndef MY_ULONG_MAX
1689 #  define MY_ULONG_MAX ((UV)LONG_MAX * (UV)2 + (UV)1)
1690 #endif
1691
1692 I32
1693 cast_i32(f)
1694 double f;
1695 {
1696     if (f >= LONG_MAX)
1697         return (I32) LONG_MAX;
1698     if (f <= LONG_MIN)
1699         return (I32) LONG_MIN;
1700     return (I32) f;
1701 }
1702
1703 IV
1704 cast_iv(f)
1705 double f;
1706 {
1707     if (f >= LONG_MAX)
1708         return (IV) LONG_MAX;
1709     if (f <= LONG_MIN)
1710         return (IV) LONG_MIN;
1711     return (IV) f;
1712 }
1713
1714 UV
1715 cast_uv(f)
1716 double f;
1717 {
1718     if (f >= MY_ULONG_MAX)
1719         return (UV) MY_ULONG_MAX;
1720     return (UV) f;
1721 }
1722
1723 #endif
1724
1725 #ifndef HAS_RENAME
1726 I32
1727 same_dirent(a,b)
1728 char *a;
1729 char *b;
1730 {
1731     char *fa = strrchr(a,'/');
1732     char *fb = strrchr(b,'/');
1733     struct stat tmpstatbuf1;
1734     struct stat tmpstatbuf2;
1735 #ifndef MAXPATHLEN
1736 #define MAXPATHLEN 1024
1737 #endif
1738     char tmpbuf[MAXPATHLEN+1];
1739
1740     if (fa)
1741         fa++;
1742     else
1743         fa = a;
1744     if (fb)
1745         fb++;
1746     else
1747         fb = b;
1748     if (strNE(a,b))
1749         return FALSE;
1750     if (fa == a)
1751         strcpy(tmpbuf,".");
1752     else
1753         strncpy(tmpbuf, a, fa - a);
1754     if (Stat(tmpbuf, &tmpstatbuf1) < 0)
1755         return FALSE;
1756     if (fb == b)
1757         strcpy(tmpbuf,".");
1758     else
1759         strncpy(tmpbuf, b, fb - b);
1760     if (Stat(tmpbuf, &tmpstatbuf2) < 0)
1761         return FALSE;
1762     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
1763            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
1764 }
1765 #endif /* !HAS_RENAME */
1766
1767 unsigned long
1768 scan_oct(start, len, retlen)
1769 char *start;
1770 I32 len;
1771 I32 *retlen;
1772 {
1773     register char *s = start;
1774     register unsigned long retval = 0;
1775
1776     while (len && *s >= '0' && *s <= '7') {
1777         retval <<= 3;
1778         retval |= *s++ - '0';
1779         len--;
1780     }
1781     if (dowarn && len && (*s == '8' || *s == '9'))
1782         warn("Illegal octal digit ignored");
1783     *retlen = s - start;
1784     return retval;
1785 }
1786
1787 unsigned long
1788 scan_hex(start, len, retlen)
1789 char *start;
1790 I32 len;
1791 I32 *retlen;
1792 {
1793     register char *s = start;
1794     register unsigned long retval = 0;
1795     char *tmp;
1796
1797     while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
1798         retval <<= 4;
1799         retval |= (tmp - hexdigit) & 15;
1800         s++;
1801     }
1802     *retlen = s - start;
1803     return retval;
1804 }