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