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