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