util.c

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