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