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