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 #ifdef LC_CTYPE
 400
 401 /*
 402  * Set up for a new ctype locale.
 403  */
 404 void
 405 perl_new_ctype(newctype)
 406     char *newctype;
 407 {
 408     int i;
 409
 410     for (i = 0; i < 256; i++) {
 411         if (isUPPER_LC(i))
 412             fold_locale[i] = toLOWER_LC(i);
 413         else if (isLOWER_LC(i))
 414             fold_locale[i] = toUPPER_LC(i);
 415         else
 416             fold_locale[i] = i;
 417     }
 418 }
 419
 420 #endif /* LC_CTYPE */
 421
 422 #ifdef LC_COLLATE
 423
 424 /*
 425  * Set up for a new collation locale.
 426  */
 427 void
 428 perl_new_collate(newcoll)
 429     char *newcoll;
 430 {
 431     if (! newcoll) {
 432         if (collation_name) {
 433             ++collation_ix;
 434             Safefree(collation_name);
 435             collation_name = NULL;
 436             collation_standard = TRUE;
 437 #ifdef HAS_STRXFRM
 438             collxfrm_base = 0;
 439             collxfrm_mult = 2;
 440 #endif /* HAS_STRXFRM */
 441         }
 442         return;
 443     }
 444
 445     if (! collation_name || strNE(collation_name, newcoll)) {
 446         ++collation_ix;
 447         Safefree(collation_name);
 448         collation_name = savepv(newcoll);
 449         collation_standard = strEQ(newcoll, "C");
 450
 451 #ifdef HAS_STRXFRM
 452         {
 453           /*  2: at most so many chars ('a', 'b'). */
 454           /* 50: surely no system expands a char more. */
 455 #define XFRMBUFSIZE  (2 * 50)
 456           char xbuf[XFRMBUFSIZE];
 457           Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
 458           Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
 459           SSize_t mult = fb - fa;
 460           if (mult < 1)
 461               croak("strxfrm() gets absurd");
 462           collxfrm_base = (fa > mult) ? (fa - mult) : 0;
 463           collxfrm_mult = mult;
 464         }
 465 #endif /* HAS_STRXFRM */
 466     }
 467 }
 468
 469 #endif /* LC_COLLATE */
 470
 471 #ifdef LC_NUMERIC
 472
 473 /*
 474  * Set up for a new numeric locale.
 475  */
 476 void
 477 perl_new_numeric(newnum)
 478     char *newnum;
 479 {
 480     if (! newnum) {
 481         if (numeric_name) {
 482             Safefree(numeric_name);
 483             numeric_name = NULL;
 484             numeric_standard = TRUE;
 485             numeric_local = TRUE;
 486         }
 487         return;
 488     }
 489
 490     if (! numeric_name || strNE(numeric_name, newnum)) {
 491         Safefree(numeric_name);
 492         numeric_name = savepv(newnum);
 493         numeric_standard = strEQ(newnum, "C");
 494         numeric_local = TRUE;
 495     }
 496 }
 497
 498 void
 499 perl_numeric_standard()
 500 {
 501     if (! numeric_standard) {
 502         setlocale(LC_NUMERIC, "C");
 503         numeric_standard = TRUE;
 504         numeric_local = FALSE;
 505     }
 506 }
 507
 508 void
 509 perl_numeric_local()
 510 {
 511     if (! numeric_local) {
 512         setlocale(LC_NUMERIC, numeric_name);
 513         numeric_standard = FALSE;
 514         numeric_local = TRUE;
 515     }
 516 }
 517
 518 #endif /* LC_NUMERIC */
 519
 520 /* Initialize locale awareness */
 521 int
 522 perl_init_i18nl10n(printwarn)
 523     int printwarn;
 524 {
 525     int ok = 1;
 526     /* returns
 527      *    1 = set ok or not applicable,
 528      *    0 = fallback to C locale,
 529      *   -1 = fallback to C locale failed
 530      */
 531
 532 #ifdef HAS_SETLOCALE
 533
 534     char *lc_all     = getenv("LC_ALL");
 535     char *lang       = getenv("LANG");
 536 #ifdef LC_CTYPE
 537     char *lc_ctype   = getenv("LC_CTYPE");
 538     char *curctype   = NULL;
 539 #endif /* LC_CTYPE */
 540 #ifdef LC_COLLATE
 541     char *lc_collate = getenv("LC_COLLATE");
 542     char *curcoll    = NULL;
 543 #endif /* LC_COLLATE */
 544 #ifdef LC_NUMERIC
 545     char *lc_numeric = getenv("LC_NUMERIC");
 546     char *curnum     = NULL;
 547 #endif /* LC_NUMERIC */
 548     bool setlocale_failure = FALSE;
 549     char *subloc;
 550
 551 #ifdef LC_ALL
 552     subloc = NULL;
 553     if (! setlocale(LC_ALL, ""))
 554         setlocale_failure = TRUE;
 555 #else
 556     subloc = "";
 557 #endif /* LC_ALL */
 558
 559 #ifdef LC_CTYPE
 560     if (! (curctype = setlocale(LC_CTYPE, subloc)))
 561         setlocale_failure = TRUE;
 562 #endif /* LC_CTYPE */
 563 #ifdef LC_COLLATE
 564     if (! (curcoll = setlocale(LC_COLLATE, subloc)))
 565         setlocale_failure = TRUE;
 566 #endif /* LC_COLLATE */
 567 #ifdef LC_NUMERIC
 568     if (! (curnum = setlocale(LC_NUMERIC, subloc)))
 569         setlocale_failure = TRUE;
 570 #endif /* LC_NUMERIC */
 571
 572     if (setlocale_failure && (lc_all || lang)) {
 573         char *perl_badlang;
 574
 575         if (printwarn > 1 ||
 576             printwarn &&
 577             (!(perl_badlang = getenv("PERL_BADLANG")) || atoi(perl_badlang))) {
 578
 579             PerlIO_printf(PerlIO_stderr(),
 580                "perl: warning: Setting locale failed for the categories:\n\t");
 581 #ifdef LC_CTYPE
 582             if (! curctype)
 583                 PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
 584 #endif /* LC_CTYPE */
 585 #ifdef LC_COLLATE
 586             if (! curcoll)
 587                 PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
 588 #endif /* LC_COLLATE */
 589 #ifdef LC_NUMERIC
 590             if (! curnum)
 591                 PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC ");
 592 #endif /* LC_NUMERIC */
 593             PerlIO_printf(PerlIO_stderr(), "\n");
 594
 595             PerlIO_printf(PerlIO_stderr(),
 596                 "perl: warning: Please check that your locale settings:\n");
 597
 598             PerlIO_printf(PerlIO_stderr(),
 599                           "\tLC_ALL = %c%s%c,\n",
 600                           lc_all ? '"' : '(',
 601                           lc_all ? lc_all : "unset",
 602                           lc_all ? '"' : ')');
 603 #ifdef LC_CTYPE
 604             if (! curctype)
 605                 PerlIO_printf(PerlIO_stderr(),
 606                               "\tLC_CTYPE = %c%s%c,\n",
 607                               lc_ctype ? '"' : '(',
 608                               lc_ctype ? lc_ctype : "unset",
 609                               lc_ctype ? '"' : ')');
 610 #endif /* LC_CTYPE */
 611 #ifdef LC_COLLATE
 612             if (! curcoll)
 613                 PerlIO_printf(PerlIO_stderr(),
 614                               "\tLC_COLLATE = %c%s%c,\n",
 615                               lc_collate ? '"' : '(',
 616                               lc_collate ? lc_collate : "unset",
 617                               lc_collate ? '"' : ')');
 618 #endif /* LC_COLLATE */
 619 #ifdef LC_NUMERIC
 620             if (! curcoll)
 621                 PerlIO_printf(PerlIO_stderr(),
 622                               "\tLC_NUMERIC = %c%s%c,\n",
 623                               lc_numeric ? '"' : '(',
 624                               lc_numeric ? lc_numeric : "unset",
 625                               lc_numeric ? '"' : ')');
 626 #endif /* LC_NUMERIC */
 627             PerlIO_printf(PerlIO_stderr(),
 628                           "\tLANG = %c%s%c\n",
 629                           lang ? '"' : ')',
 630                           lang ? lang : "unset",
 631                           lang ? '"' : ')');
 632
 633             PerlIO_printf(PerlIO_stderr(),
 634                           "    are supported and installed on your system.\n");
 635
 636             ok = 0;
 637         }
 638
 639 #ifdef LC_ALL
 640         if (setlocale_failure) {
 641             PerlIO_printf(PerlIO_stderr(),
 642                         "perl: warning: Falling back to the \"C\" locale.\n");
 643             if (setlocale(LC_ALL, "C")) {
 644 #ifdef LC_CTYPE
 645                 curctype = "C";
 646 #endif /* LC_CTYPE */
 647 #ifdef LC_COLLATE
 648                 curcoll = "C";
 649 #endif /* LC_COLLATE */
 650 #ifdef LC_NUMERIC
 651                 curnum = "C";
 652 #endif /* LC_NUMERIC */
 653             }
 654             else {
 655                 PerlIO_printf(PerlIO_stderr(),
 656                   "perl: warning: Failed to fall back to the \"C\" locale.\n");
 657                 ok = -1;
 658             }
 659         }
 660 #else /* ! LC_ALL */
 661         PerlIO_printf(PerlIO_stderr(),
 662                    "perl: warning: Cannot fall back to the \"C\" locale.\n");
 663 #endif /* ! LC_ALL */
 664     }
 665
 666 #ifdef LC_CTYPE
 667     perl_new_ctype(curctype);
 668 #endif /* LC_NUMERIC */
 669
 670 #ifdef LC_COLLATE
 671     perl_new_collate(curcoll);
 672 #endif /* LC_NUMERIC */
 673
 674 #ifdef LC_NUMERIC
 675     perl_new_numeric(curnum);
 676 #endif /* LC_NUMERIC */
 677
 678 #endif /* #if defined(HAS_SETLOCALE) */
 679
 680     return ok;
 681 }
 682
 683 /* Backwards compatibility. */
 684 int
 685 perl_init_i18nl14n(printwarn)
 686     int printwarn;
 687 {
 688     perl_init_i18nl10n(printwarn);
 689 }
 690
 691 #ifdef HAS_STRXFRM
 692
 693 /*
 694  * mem_collxfrm() is a bit like strxfrm() but with two important
 695  * differences. First, it handles embedded NULs. Second, it allocates
 696  * a bit more memory than needed for the transformed data itself.
 697  * The real transformed data begins at offset sizeof(collationix).
 698  * Please see sv_collxfrm() to see how this is used.
 699  */
 700 char *
 701 mem_collxfrm(s, len, xlen)
 702      const char *s;
 703      STRLEN len;
 704      STRLEN *xlen;
 705 {
 706     char *xbuf;
 707     STRLEN xalloc, xin, xout;
 708
 709     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
 710     /* the +1 is for the terminating NUL. */
 711
 712     xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
 713     New(171, xbuf, xalloc, char);
 714     if (! xbuf)
 715         goto bad;
 716
 717     *(U32*)xbuf = collation_ix;
 718     xout = sizeof(collation_ix);
 719     for (xin = 0; xin < len; ) {
 720         SSize_t xused;
 721
 722         for (;;) {
 723             xused = strxfrm(xbuf + xout, s + xin, xalloc - xout);
 724             if (xused == -1)
 725                 goto bad;
 726             if (xused < xalloc - xout)
 727                 break;
 728             xalloc = (2 * xalloc) + 1;
 729             Renew(xbuf, xalloc, char);
 730             if (! xbuf)
 731                 goto bad;
 732         }
 733
 734         xin += strlen(s + xin) + 1;
 735         xout += xused;
 736
 737         /* Embedded NULs are understood but silently skipped
 738          * because they make no sense in locale collation. */
 739     }
 740
 741     xbuf[xout] = '\0';
 742     *xlen = xout - sizeof(collation_ix);
 743     return xbuf;
 744
 745   bad:
 746     Safefree(xbuf);
 747     *xlen = 0;
 748     return NULL;
 749 }
 750
 751 #endif /* HAS_STRXFRM */
 752
 753 void
 754 fbm_compile(sv)
 755 SV *sv;
 756 {
 757     register unsigned char *s;
 758     register unsigned char *table;
 759     register U32 i;
 760     register U32 len = SvCUR(sv);
 761     I32 rarest = 0;
 762     U32 frequency = 256;
 763
 764     if (len > 255)
 765         return;                 /* can't have offsets that big */
 766     Sv_Grow(sv,len+258);
 767     table = (unsigned char*)(SvPVX(sv) + len + 1);
 768     s = table - 2;
 769     for (i = 0; i < 256; i++) {
 770         table[i] = len;
 771     }
 772     i = 0;
 773     while (s >= (unsigned char*)(SvPVX(sv)))
 774     {
 775         if (table[*s] == len)
 776             table[*s] = i;
 777         s--,i++;
 778     }
 779     sv_upgrade(sv, SVt_PVBM);
 780     sv_magic(sv, Nullsv, 'B', Nullch, 0);       /* deep magic */
 781     SvVALID_on(sv);
 782
 783     s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
 784     for (i = 0; i < len; i++) {
 785         if (freq[s[i]] < frequency) {
 786             rarest = i;
 787             frequency = freq[s[i]];
 788         }
 789     }
 790     BmRARE(sv) = s[rarest];
 791     BmPREVIOUS(sv) = rarest;
 792     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
 793 }
 794
 795 char *
 796 fbm_instr(big, bigend, littlestr)
 797 unsigned char *big;
 798 register unsigned char *bigend;
 799 SV *littlestr;
 800 {
 801     register unsigned char *s;
 802     register I32 tmp;
 803     register I32 littlelen;
 804     register unsigned char *little;
 805     register unsigned char *table;
 806     register unsigned char *olds;
 807     register unsigned char *oldlittle;
 808
 809     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 810         STRLEN len;
 811         char *l = SvPV(littlestr,len);
 812         if (!len)
 813             return (char*)big;
 814         return ninstr((char*)big,(char*)bigend, l, l + len);
 815     }
 816
 817     littlelen = SvCUR(littlestr);
 818     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 819         if (littlelen > bigend - big)
 820             return Nullch;
 821         little = (unsigned char*)SvPVX(littlestr);
 822         s = bigend - littlelen;
 823         if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
 824             return (char*)s;            /* how sweet it is */
 825         else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
 826                  && s > big) {
 827             s--;
 828             if (*s == *little && memcmp((char*)s,(char*)little,littlelen)==0)
 829                 return (char*)s;
 830         }
 831         return Nullch;
 832     }
 833     table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
 834     if (--littlelen >= bigend - big)
 835         return Nullch;
 836     s = big + littlelen;
 837     oldlittle = little = table - 2;
 838     if (s < bigend) {
 839       top2:
 840         /*SUPPRESS 560*/
 841         if (tmp = table[*s]) {
 842 #ifdef POINTERRIGOR
 843             if (bigend - s > tmp) {
 844                 s += tmp;
 845                 goto top2;
 846             }
 847 #else
 848             if ((s += tmp) < bigend)
 849                 goto top2;
 850 #endif
 851             return Nullch;
 852         }
 853         else {
 854             tmp = littlelen;    /* less expensive than calling strncmp() */
 855             olds = s;
 856             while (tmp--) {
 857                 if (*--s == *--little)
 858                     continue;
 859                 s = olds + 1;   /* here we pay the price for failure */
 860                 little = oldlittle;
 861                 if (s < bigend) /* fake up continue to outer loop */
 862                     goto top2;
 863                 return Nullch;
 864             }
 865             return (char *)s;
 866         }
 867     }
 868     return Nullch;
 869 }
 870
 871 char *
 872 screaminstr(bigstr, littlestr)
 873 SV *bigstr;
 874 SV *littlestr;
 875 {
 876     register unsigned char *s, *x;
 877     register unsigned char *big;
 878     register I32 pos;
 879     register I32 previous;
 880     register I32 first;
 881     register unsigned char *little;
 882     register unsigned char *bigend;
 883     register unsigned char *littleend;
 884
 885     if ((pos = screamfirst[BmRARE(littlestr)]) < 0)
 886         return Nullch;
 887     little = (unsigned char *)(SvPVX(littlestr));
 888     littleend = little + SvCUR(littlestr);
 889     first = *little++;
 890     previous = BmPREVIOUS(littlestr);
 891     big = (unsigned char *)(SvPVX(bigstr));
 892     bigend = big + SvCUR(bigstr);
 893     while (pos < previous) {
 894         if (!(pos += screamnext[pos]))
 895             return Nullch;
 896     }
 897 #ifdef POINTERRIGOR
 898     do {
 899         if (big[pos-previous] != first)
 900             continue;
 901         for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
 902             if (x >= bigend)
 903                 return Nullch;
 904             if (*s++ != *x++) {
 905                 s--;
 906                 break;
 907             }
 908         }
 909         if (s == littleend)
 910             return (char *)(big+pos-previous);
 911     } while ( pos += screamnext[pos] );
 912 #else /* !POINTERRIGOR */
 913     big -= previous;
 914     do {
 915         if (big[pos] != first)
 916             continue;
 917         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 918             if (x >= bigend)
 919                 return Nullch;
 920             if (*s++ != *x++) {
 921                 s--;
 922                 break;
 923             }
 924         }
 925         if (s == littleend)
 926             return (char *)(big+pos);
 927     } while ( pos += screamnext[pos] );
 928 #endif /* POINTERRIGOR */
 929     return Nullch;
 930 }
 931
 932 I32
 933 ibcmp(s1, s2, len)
 934 char *s1, *s2;
 935 register I32 len;
 936 {
 937     register U8 *a = (U8 *)s1;
 938     register U8 *b = (U8 *)s2;
 939     while (len--) {
 940         if (*a != *b && *a != fold[*b])
 941             return 1;
 942         a++,b++;
 943     }
 944     return 0;
 945 }
 946
 947 I32
 948 ibcmp_locale(s1, s2, len)
 949 char *s1, *s2;
 950 register I32 len;
 951 {
 952     register U8 *a = (U8 *)s1;
 953     register U8 *b = (U8 *)s2;
 954     while (len--) {
 955         if (*a != *b && *a != fold_locale[*b])
 956             return 1;
 957         a++,b++;
 958     }
 959     return 0;
 960 }
 961
 962 /* copy a string to a safe spot */
 963
 964 char *
 965 savepv(sv)
 966 char *sv;
 967 {
 968     register char *newaddr;
 969
 970     New(902,newaddr,strlen(sv)+1,char);
 971     (void)strcpy(newaddr,sv);
 972     return newaddr;
 973 }
 974
 975 /* same thing but with a known length */
 976
 977 char *
 978 savepvn(sv, len)
 979 char *sv;
 980 register I32 len;
 981 {
 982     register char *newaddr;
 983
 984     New(903,newaddr,len+1,char);
 985     Copy(sv,newaddr,len,char);          /* might not be null terminated */
 986     newaddr[len] = '\0';                /* is now */
 987     return newaddr;
 988 }
 989
 990 #if !defined(I_STDARG) && !defined(I_VARARGS)
 991
 992 /*
 993  * Fallback on the old hackers way of doing varargs
 994  */
 995
 996 /*VARARGS1*/
 997 char *
 998 mess(pat,a1,a2,a3,a4)
 999 char *pat;
1000 long a1, a2, a3, a4;
1001 {
1002     char *s;
1003     char *s_start;
1004     I32 usermess = strEQ(pat,"%s");
1005     SV *tmpstr;
1006
1007     s = s_start = buf;
1008     if (usermess) {
1009         tmpstr = sv_newmortal();
1010         sv_setpv(tmpstr, (char*)a1);
1011         *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
1012     }
1013     else {
1014         (void)sprintf(s,pat,a1,a2,a3,a4);
1015         s += strlen(s);
1016     }
1017
1018     if (s[-1] != '\n') {
1019         if (dirty)
1020             strcpy(s, " during global destruction.\n");
1021         else {
1022             if (curcop->cop_line) {
1023                 (void)sprintf(s," at %s line %ld",
1024                   SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
1025                 s += strlen(s);
1026             }
1027             if (GvIO(last_in_gv) &&
1028                 IoLINES(GvIOp(last_in_gv)) ) {
1029                 (void)sprintf(s,", <%s> %s %ld",
1030                   last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
1031                   strEQ(rs,"\n") ? "line" : "chunk",
1032                   (long)IoLINES(GvIOp(last_in_gv)));
1033                 s += strlen(s);
1034             }
1035             (void)strcpy(s,".\n");
1036             s += 2;
1037         }
1038         if (usermess)
1039             sv_catpv(tmpstr,buf+1);
1040     }
1041
1042     if (s - s_start >= sizeof(buf)) {   /* Ooops! */
1043         if (usermess)
1044             PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
1045         else
1046             PerlIO_puts(PerlIO_stderr(), buf);
1047         PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n");
1048         my_exit(1);
1049     }
1050     if (usermess)
1051         return SvPVX(tmpstr);
1052     else
1053         return buf;
1054 }
1055
1056 /*VARARGS1*/
1057 void croak(pat,a1,a2,a3,a4)
1058 char *pat;
1059 long a1, a2, a3, a4;
1060 {
1061     char *tmps;
1062     char *message;
1063     HV *stash;
1064     GV *gv;
1065     CV *cv;
1066
1067     message = mess(pat,a1,a2,a3,a4);
1068     if (diehook) {
1069         SV *olddiehook = diehook;
1070         diehook = Nullsv;                       /* sv_2cv might call croak() */
1071         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1072         diehook = olddiehook;
1073         if (cv && !CvDEPTH(cv)) {
1074             dSP;
1075
1076             PUSHMARK(sp);
1077             EXTEND(sp, 1);
1078             PUSHs(sv_2mortal(newSVpv(message,0)));
1079             PUTBACK;
1080             perl_call_sv((SV*)cv, G_DISCARD);
1081         }
1082     }
1083     if (in_eval) {
1084         restartop = die_where(message);
1085         Siglongjmp(top_env, 3);
1086     }
1087     PerlIO_puts(PerlIO_stderr(),message);
1088     (void)PerlIO_flush(PerlIO_stderr());
1089     if (e_tmpname) {
1090         if (e_fp) {
1091             PerlIO_close(e_fp);
1092             e_fp = Nullfp;
1093         }
1094         (void)UNLINK(e_tmpname);
1095         Safefree(e_tmpname);
1096         e_tmpname = Nullch;
1097     }
1098     statusvalue = SHIFTSTATUS(statusvalue);
1099 #ifdef VMS
1100     my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
1101 #else
1102     my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1103 #endif
1104 }
1105
1106 /*VARARGS1*/
1107 void warn(pat,a1,a2,a3,a4)
1108 char *pat;
1109 long a1, a2, a3, a4;
1110 {
1111     char *message;
1112     SV *sv;
1113     HV *stash;
1114     GV *gv;
1115     CV *cv;
1116
1117     message = mess(pat,a1,a2,a3,a4);
1118     if (warnhook) {
1119         SV *oldwarnhook = warnhook;
1120         warnhook = Nullsv;      /* sv_2cv might end up calling warn() */
1121         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1122         warnhook = oldwarnhook;
1123         if (cv && !CvDEPTH(cv)) {
1124             dSP;
1125
1126             PUSHMARK(sp);
1127             EXTEND(sp, 1);
1128             PUSHs(sv_2mortal(newSVpv(message,0)));
1129             PUTBACK;
1130             perl_call_sv((SV*)cv, G_DISCARD);
1131             return;
1132         }
1133     }
1134     PerlIO_puts(PerlIO_stderr(),message);
1135 #ifdef LEAKTEST
1136     DEBUG_L(xstat());
1137 #endif
1138     (void)PerlIO_flush(PerlIO_stderr());
1139 }
1140
1141 #else /* !defined(I_STDARG) && !defined(I_VARARGS) */
1142
1143 #ifdef I_STDARG
1144 char *
1145 mess(char *pat, va_list *args)
1146 #else
1147 /*VARARGS0*/
1148 char *
1149 mess(pat, args)
1150     char *pat;
1151     va_list *args;
1152 #endif
1153 {
1154     char *s;
1155     char *s_start;
1156     SV *tmpstr;
1157     I32 usermess;
1158 #ifndef HAS_VPRINTF
1159 #ifdef USE_CHAR_VSPRINTF
1160     char *vsprintf();
1161 #else
1162     I32 vsprintf();
1163 #endif
1164 #endif
1165
1166     s = s_start = buf;
1167     usermess = strEQ(pat, "%s");
1168     if (usermess) {
1169         tmpstr = sv_newmortal();
1170         sv_setpv(tmpstr, va_arg(*args, char *));
1171         *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
1172     }
1173     else {
1174         (void) vsprintf(s,pat,*args);
1175         s += strlen(s);
1176     }
1177     va_end(*args);
1178
1179     if (s[-1] != '\n') {
1180         if (dirty)
1181             strcpy(s, " during global destruction.\n");
1182         else {
1183             if (curcop->cop_line) {
1184                 (void)sprintf(s," at %s line %ld",
1185                   SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
1186                 s += strlen(s);
1187             }
1188             if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
1189                 bool line_mode = (RsSIMPLE(rs) &&
1190                                   SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
1191                 (void)sprintf(s,", <%s> %s %ld",
1192                   last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
1193                   line_mode ? "line" : "chunk",
1194                   (long)IoLINES(GvIOp(last_in_gv)));
1195                 s += strlen(s);
1196             }
1197             (void)strcpy(s,".\n");
1198             s += 2;
1199         }
1200         if (usermess)
1201             sv_catpv(tmpstr,buf+1);
1202     }
1203
1204     if (s - s_start >= sizeof(buf)) {   /* Ooops! */
1205         if (usermess)
1206             PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
1207         else
1208             PerlIO_puts(PerlIO_stderr(), buf);
1209         PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
1210         my_exit(1);
1211     }
1212     if (usermess)
1213         return SvPVX(tmpstr);
1214     else
1215         return buf;
1216 }
1217
1218 #ifdef I_STDARG
1219 void
1220 croak(char* pat, ...)
1221 #else
1222 /*VARARGS0*/
1223 void
1224 croak(pat, va_alist)
1225     char *pat;
1226     va_dcl
1227 #endif
1228 {
1229     va_list args;
1230     char *message;
1231     HV *stash;
1232     GV *gv;
1233     CV *cv;
1234
1235 #ifdef I_STDARG
1236     va_start(args, pat);
1237 #else
1238     va_start(args);
1239 #endif
1240     message = mess(pat, &args);
1241     va_end(args);
1242     if (diehook) {
1243         SV *olddiehook = diehook;
1244         diehook = Nullsv;                 /* sv_2cv might call croak() */
1245         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1246         diehook = olddiehook;
1247         if (cv && !CvDEPTH(cv)) {
1248             dSP;
1249
1250             PUSHMARK(sp);
1251             EXTEND(sp, 1);
1252             PUSHs(sv_2mortal(newSVpv(message,0)));
1253             PUTBACK;
1254             perl_call_sv((SV*)cv, G_DISCARD);
1255         }
1256     }
1257     if (in_eval) {
1258         restartop = die_where(message);
1259         Siglongjmp(top_env, 3);
1260     }
1261     PerlIO_puts(PerlIO_stderr(),message);
1262     (void)PerlIO_flush(PerlIO_stderr());
1263     if (e_tmpname) {
1264         if (e_fp) {
1265             PerlIO_close(e_fp);
1266             e_fp = Nullfp;
1267         }
1268         (void)UNLINK(e_tmpname);
1269         Safefree(e_tmpname);
1270         e_tmpname = Nullch;
1271     }
1272     statusvalue = SHIFTSTATUS(statusvalue);
1273 #ifdef VMS
1274     my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
1275 #else
1276     my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
1277 #endif
1278 }
1279
1280 void
1281 #ifdef I_STDARG
1282 warn(char* pat,...)
1283 #else
1284 /*VARARGS0*/
1285 warn(pat,va_alist)
1286     char *pat;
1287     va_dcl
1288 #endif
1289 {
1290     va_list args;
1291     char *message;
1292     HV *stash;
1293     GV *gv;
1294     CV *cv;
1295
1296 #ifdef I_STDARG
1297     va_start(args, pat);
1298 #else
1299     va_start(args);
1300 #endif
1301     message = mess(pat, &args);
1302     va_end(args);
1303
1304     if (warnhook) {
1305         SV *oldwarnhook = warnhook;
1306         warnhook = Nullsv;      /* sv_2cv might end up calling warn() */
1307         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1308         warnhook = oldwarnhook;
1309         if (cv && !CvDEPTH(cv)) {
1310             dSP;
1311
1312             PUSHMARK(sp);
1313             EXTEND(sp, 1);
1314             PUSHs(sv_2mortal(newSVpv(message,0)));
1315             PUTBACK;
1316             perl_call_sv((SV*)cv, G_DISCARD);
1317             return;
1318         }
1319     }
1320     PerlIO_puts(PerlIO_stderr(),message);
1321 #ifdef LEAKTEST
1322     DEBUG_L(xstat());
1323 #endif
1324     (void)PerlIO_flush(PerlIO_stderr());
1325 }
1326 #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
1327
1328 #ifndef VMS  /* VMS' my_setenv() is in VMS.c */
1329 void
1330 my_setenv(nam,val)
1331 char *nam, *val;
1332 {
1333     register I32 i=setenv_getix(nam);           /* where does it go? */
1334
1335     if (environ == origenviron) {       /* need we copy environment? */
1336         I32 j;
1337         I32 max;
1338         char **tmpenv;
1339
1340         /*SUPPRESS 530*/
1341         for (max = i; environ[max]; max++) ;
1342         New(901,tmpenv, max+2, char*);
1343         for (j=0; j<max; j++)           /* copy environment */
1344             tmpenv[j] = savepv(environ[j]);
1345         tmpenv[max] = Nullch;
1346         environ = tmpenv;               /* tell exec where it is now */
1347     }
1348     if (!val) {
1349         while (environ[i]) {
1350             environ[i] = environ[i+1];
1351             i++;
1352         }
1353         return;
1354     }
1355     if (!environ[i]) {                  /* does not exist yet */
1356         Renew(environ, i+2, char*);     /* just expand it a bit */
1357         environ[i+1] = Nullch;  /* make sure it's null terminated */
1358     }
1359     else
1360         Safefree(environ[i]);
1361     New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
1362 #ifndef MSDOS
1363     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
1364 #else
1365     /* MS-DOS requires environment variable names to be in uppercase */
1366     /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1367      * some utilities and applications may break because they only look
1368      * for upper case strings. (Fixed strupr() bug here.)]
1369      */
1370     strcpy(environ[i],nam); strupr(environ[i]);
1371     (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1372 #endif /* MSDOS */
1373 }
1374
1375 I32
1376 setenv_getix(nam)
1377 char *nam;
1378 {
1379     register I32 i, len = strlen(nam);
1380
1381     for (i = 0; environ[i]; i++) {
1382         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1383             break;                      /* strnEQ must come first to avoid */
1384     }                                   /* potential SEGV's */
1385     return i;
1386 }
1387 #endif /* !VMS */
1388
1389 #ifdef UNLINK_ALL_VERSIONS
1390 I32
1391 unlnk(f)        /* unlink all versions of a file */
1392 char *f;
1393 {
1394     I32 i;
1395
1396     for (i = 0; unlink(f) >= 0; i++) ;
1397     return i ? 0 : -1;
1398 }
1399 #endif
1400
1401 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
1402 char *
1403 my_bcopy(from,to,len)
1404 register char *from;
1405 register char *to;
1406 register I32 len;
1407 {
1408     char *retval = to;
1409
1410     if (from - to >= 0) {
1411         while (len--)
1412             *to++ = *from++;
1413     }
1414     else {
1415         to += len;
1416         from += len;
1417         while (len--)
1418             *(--to) = *(--from);
1419     }
1420     return retval;
1421 }
1422 #endif
1423
1424 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1425 char *
1426 my_bzero(loc,len)
1427 register char *loc;
1428 register I32 len;
1429 {
1430     char *retval = loc;
1431
1432     while (len--)
1433         *loc++ = 0;
1434     return retval;
1435 }
1436 #endif
1437
1438 #ifndef HAS_MEMCMP
1439 I32
1440 my_memcmp(s1,s2,len)
1441 register unsigned char *s1;
1442 register unsigned char *s2;
1443 register I32 len;
1444 {
1445     register I32 tmp;
1446
1447     while (len--) {
1448         if (tmp = *s1++ - *s2++)
1449             return tmp;
1450     }
1451     return 0;
1452 }
1453 #endif /* HAS_MEMCMP */
1454
1455 #if defined(I_STDARG) || defined(I_VARARGS)
1456 #ifndef HAS_VPRINTF
1457
1458 #ifdef USE_CHAR_VSPRINTF
1459 char *
1460 #else
1461 int
1462 #endif
1463 vsprintf(dest, pat, args)
1464 char *dest, *pat, *args;
1465 {
1466     FILE fakebuf;
1467
1468     fakebuf._ptr = dest;
1469     fakebuf._cnt = 32767;
1470 #ifndef _IOSTRG
1471 #define _IOSTRG 0
1472 #endif
1473     fakebuf._flag = _IOWRT|_IOSTRG;
1474     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1475     (void)putc('\0', &fakebuf);
1476 #ifdef USE_CHAR_VSPRINTF
1477     return(dest);
1478 #else
1479     return 0;           /* perl doesn't use return value */
1480 #endif
1481 }
1482
1483 #endif /* HAS_VPRINTF */
1484 #endif /* I_VARARGS || I_STDARGS */
1485
1486 #ifdef MYSWAP
1487 #if BYTEORDER != 0x4321
1488 short
1489 #ifndef CAN_PROTOTYPE
1490 my_swap(s)
1491 short s;
1492 #else
1493 my_swap(short s)
1494 #endif
1495 {
1496 #if (BYTEORDER & 1) == 0
1497     short result;
1498
1499     result = ((s & 255) << 8) + ((s >> 8) & 255);
1500     return result;
1501 #else
1502     return s;
1503 #endif
1504 }
1505
1506 long
1507 #ifndef CAN_PROTOTYPE
1508 my_htonl(l)
1509 register long l;
1510 #else
1511 my_htonl(long l)
1512 #endif
1513 {
1514     union {
1515         long result;
1516         char c[sizeof(long)];
1517     } u;
1518
1519 #if BYTEORDER == 0x1234
1520     u.c[0] = (l >> 24) & 255;
1521     u.c[1] = (l >> 16) & 255;
1522     u.c[2] = (l >> 8) & 255;
1523     u.c[3] = l & 255;
1524     return u.result;
1525 #else
1526 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1527     croak("Unknown BYTEORDER\n");
1528 #else
1529     register I32 o;
1530     register I32 s;
1531
1532     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1533         u.c[o & 0xf] = (l >> s) & 255;
1534     }
1535     return u.result;
1536 #endif
1537 #endif
1538 }
1539
1540 long
1541 #ifndef CAN_PROTOTYPE
1542 my_ntohl(l)
1543 register long l;
1544 #else
1545 my_ntohl(long l)
1546 #endif
1547 {
1548     union {
1549         long l;
1550         char c[sizeof(long)];
1551     } u;
1552
1553 #if BYTEORDER == 0x1234
1554     u.c[0] = (l >> 24) & 255;
1555     u.c[1] = (l >> 16) & 255;
1556     u.c[2] = (l >> 8) & 255;
1557     u.c[3] = l & 255;
1558     return u.l;
1559 #else
1560 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1561     croak("Unknown BYTEORDER\n");
1562 #else
1563     register I32 o;
1564     register I32 s;
1565
1566     u.l = l;
1567     l = 0;
1568     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1569         l |= (u.c[o & 0xf] & 255) << s;
1570     }
1571     return l;
1572 #endif
1573 #endif
1574 }
1575
1576 #endif /* BYTEORDER != 0x4321 */
1577 #endif /* MYSWAP */
1578
1579 /*
1580  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1581  * If these functions are defined,
1582  * the BYTEORDER is neither 0x1234 nor 0x4321.
1583  * However, this is not assumed.
1584  * -DWS
1585  */
1586
1587 #define HTOV(name,type)                                         \
1588         type                                                    \
1589         name (n)                                                \
1590         register type n;                                        \
1591         {                                                       \
1592             union {                                             \
1593                 type value;                                     \
1594                 char c[sizeof(type)];                           \
1595             } u;                                                \
1596             register I32 i;                                     \
1597             register I32 s;                                     \
1598             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1599                 u.c[i] = (n >> s) & 0xFF;                       \
1600             }                                                   \
1601             return u.value;                                     \
1602         }
1603
1604 #define VTOH(name,type)                                         \
1605         type                                                    \
1606         name (n)                                                \
1607         register type n;                                        \
1608         {                                                       \
1609             union {                                             \
1610                 type value;                                     \
1611                 char c[sizeof(type)];                           \
1612             } u;                                                \
1613             register I32 i;                                     \
1614             register I32 s;                                     \
1615             u.value = n;                                        \
1616             n = 0;                                              \
1617             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1618                 n += (u.c[i] & 0xFF) << s;                      \
1619             }                                                   \
1620             return n;                                           \
1621         }
1622
1623 #if defined(HAS_HTOVS) && !defined(htovs)
1624 HTOV(htovs,short)
1625 #endif
1626 #if defined(HAS_HTOVL) && !defined(htovl)
1627 HTOV(htovl,long)
1628 #endif
1629 #if defined(HAS_VTOHS) && !defined(vtohs)
1630 VTOH(vtohs,short)
1631 #endif
1632 #if defined(HAS_VTOHL) && !defined(vtohl)
1633 VTOH(vtohl,long)
1634 #endif
1635
1636 #if  (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \
1637      && !defined(VMS)  /* VMS' my_popen() is in VMS.c, same with OS/2. */
1638 PerlIO *
1639 my_popen(cmd,mode)
1640 char    *cmd;
1641 char    *mode;
1642 {
1643     int p[2];
1644     register I32 this, that;
1645     register I32 pid;
1646     SV *sv;
1647     I32 doexec =
1648 #ifdef AMIGAOS
1649         1;
1650 #else
1651         strNE(cmd,"-");
1652 #endif
1653
1654 #ifdef OS2
1655     if (doexec) {
1656         return my_syspopen(cmd,mode);
1657     }
1658 #endif
1659     if (pipe(p) < 0)
1660         return Nullfp;
1661     this = (*mode == 'w');
1662     that = !this;
1663     if (doexec && tainting) {
1664         taint_env();
1665         taint_proper("Insecure %s%s", "EXEC");
1666     }
1667     while ((pid = (doexec?vfork():fork())) < 0) {
1668         if (errno != EAGAIN) {
1669             close(p[this]);
1670             if (!doexec)
1671                 croak("Can't fork");
1672             return Nullfp;
1673         }
1674         sleep(5);
1675     }
1676     if (pid == 0) {
1677         GV* tmpgv;
1678
1679 #define THIS that
1680 #define THAT this
1681         close(p[THAT]);
1682         if (p[THIS] != (*mode == 'r')) {
1683             dup2(p[THIS], *mode == 'r');
1684             close(p[THIS]);
1685         }
1686         if (doexec) {
1687 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1688             int fd;
1689
1690 #ifndef NOFILE
1691 #define NOFILE 20
1692 #endif
1693             for (fd = maxsysfd + 1; fd < NOFILE; fd++)
1694                 close(fd);
1695 #endif
1696             do_exec(cmd);       /* may or may not use the shell */
1697             _exit(1);
1698         }
1699         /*SUPPRESS 560*/
1700         if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1701             sv_setiv(GvSV(tmpgv),(I32)getpid());
1702         forkprocess = 0;
1703         hv_clear(pidstatus);    /* we have no children */
1704         return Nullfp;
1705 #undef THIS
1706 #undef THAT
1707     }
1708     do_execfree();      /* free any memory malloced by child on vfork */
1709     close(p[that]);
1710     if (p[that] < p[this]) {
1711         dup2(p[this], p[that]);
1712         close(p[this]);
1713         p[this] = p[that];
1714     }
1715     sv = *av_fetch(fdpid,p[this],TRUE);
1716     (void)SvUPGRADE(sv,SVt_IV);
1717     SvIVX(sv) = pid;
1718     forkprocess = pid;
1719     return PerlIO_fdopen(p[this], mode);
1720 }
1721 #else
1722 #if defined(atarist) || defined(DJGPP)
1723 FILE *popen();
1724 PerlIO *
1725 my_popen(cmd,mode)
1726 char    *cmd;
1727 char    *mode;
1728 {
1729     /* Needs work for PerlIO ! */
1730     /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
1731     return popen(PerlIO_exportFILE(cmd, 0), mode);
1732 }
1733 #endif
1734
1735 #endif /* !DOSISH */
1736
1737 #ifdef DUMP_FDS
1738 dump_fds(s)
1739 char *s;
1740 {
1741     int fd;
1742     struct stat tmpstatbuf;
1743
1744     PerlIO_printf(PerlIO_stderr(),"%s", s);
1745     for (fd = 0; fd < 32; fd++) {
1746         if (Fstat(fd,&tmpstatbuf) >= 0)
1747             PerlIO_printf(PerlIO_stderr()," %d",fd);
1748     }
1749     PerlIO_printf(PerlIO_stderr(),"\n");
1750 }
1751 #endif
1752
1753 #ifndef HAS_DUP2
1754 int
1755 dup2(oldfd,newfd)
1756 int oldfd;
1757 int newfd;
1758 {
1759 #if defined(HAS_FCNTL) && defined(F_DUPFD)
1760     if (oldfd == newfd)
1761         return oldfd;
1762     close(newfd);
1763     return fcntl(oldfd, F_DUPFD, newfd);
1764 #else
1765     int fdtmp[256];
1766     I32 fdx = 0;
1767     int fd;
1768
1769     if (oldfd == newfd)
1770         return oldfd;
1771     close(newfd);
1772     while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
1773         fdtmp[fdx++] = fd;
1774     while (fdx > 0)
1775         close(fdtmp[--fdx]);
1776     return fd;
1777 #endif
1778 }
1779 #endif
1780
1781 #ifdef HAS_SIGACTION
1782
1783 Sighandler_t rsignal(signo,handler)
1784 int signo;
1785 Sighandler_t handler;
1786 {
1787     struct sigaction act,oact;
1788
1789     act.sa_handler = handler;
1790     sigemptyset(&act.sa_mask);
1791     act.sa_flags = 0;
1792 #ifdef SA_RESTART
1793     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1794 #endif
1795     if (sigaction(signo, &act, &oact) < 0)
1796         return(SIG_ERR);
1797     else
1798         return(oact.sa_handler);
1799 }
1800
1801 int rsignalsave(signo, handler, save)
1802 int signo;
1803 Sighandler_t handler;
1804 Sigsave_t *save;
1805 {
1806     struct sigaction act;
1807
1808     act.sa_handler = handler;
1809     sigemptyset(&act.sa_mask);
1810     act.sa_flags = 0;
1811 #ifdef SA_RESTART
1812     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
1813 #endif
1814     return sigaction(signo, &act, save);
1815 }
1816
1817 int rsignalrestore(signo, save)
1818 int signo;
1819 Sigsave_t *save;
1820 {
1821     return sigaction(signo, save, 0);
1822 }
1823
1824 Sighandler_t rsignalstate(signo)
1825 int signo;
1826 {
1827     struct sigaction oact;
1828     if (sigaction(signo, 0, &oact)<0)
1829         return (SIG_ERR);
1830     else
1831         return (oact.sa_handler);
1832 }
1833
1834 #else
1835
1836 static int sig_trapped;
1837
1838 static
1839 Signal_t sig_trap(signo)
1840 int signo;
1841 {
1842     sig_trapped++;
1843 }
1844
1845 Sighandler_t rsignalstate(signo)
1846 int signo;
1847 {
1848     Sighandler_t oldsig;
1849     sig_trapped=0;
1850     oldsig = signal(signo, sig_trap);
1851     signal(signo, oldsig);
1852     if (sig_trapped)
1853         kill(getpid(),signo);
1854
1855     return oldsig;
1856 }
1857
1858 Sighandler_t rsignal(signo,handler)
1859 int signo;
1860 Sighandler_t handler;
1861 {
1862     return signal(signo,handler);
1863 }
1864
1865 int rsignalsave(signo, handler, save)
1866 int signo;
1867 Sighandler_t handler;
1868 Sigsave_t *save;
1869 {
1870     *save = signal(signo,handler);
1871     return (*save == SIG_ERR) ? -1 : 0;
1872 }
1873
1874 int rsignalrestore(signo, save)
1875 int signo;
1876 Sigsave_t *save;
1877 {
1878     return (signal(signo, *save) == SIG_ERR) ? -1 : 0;
1879 }
1880
1881 #endif
1882
1883
1884 #if  (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) \
1885      && !defined(VMS)  /* VMS' my_popen() is in VMS.c */
1886 I32
1887 my_pclose(ptr)
1888 PerlIO *ptr;
1889 {
1890     Sigsave_t hstat, istat, qstat;
1891     int status;
1892     SV **svp;
1893     int pid;
1894
1895     svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
1896     pid = (int)SvIVX(*svp);
1897     SvREFCNT_dec(*svp);
1898     *svp = &sv_undef;
1899 #ifdef OS2
1900     if (pid == -1) {                    /* Opened by popen. */
1901         return my_syspclose(ptr);
1902     }
1903 #endif
1904     PerlIO_close(ptr);
1905 #ifdef UTS
1906     if(kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
1907 #endif
1908     rsignalsave(SIGHUP, SIG_IGN, &hstat);
1909     rsignalsave(SIGINT, SIG_IGN, &istat);
1910     rsignalsave(SIGQUIT, SIG_IGN, &qstat);
1911     do {
1912         pid = wait4pid(pid, &status, 0);
1913     } while (pid == -1 && errno == EINTR);
1914     rsignalrestore(SIGHUP, &hstat);
1915     rsignalrestore(SIGINT, &istat);
1916     rsignalrestore(SIGQUIT, &qstat);
1917     return(pid < 0 ? pid : status);
1918 }
1919 #endif /* !DOSISH */
1920
1921 #if  !defined(DOSISH) || defined(OS2)
1922 I32
1923 wait4pid(pid,statusp,flags)
1924 int pid;
1925 int *statusp;
1926 int flags;
1927 {
1928     SV *sv;
1929     SV** svp;
1930     char spid[16];
1931
1932     if (!pid)
1933         return -1;
1934     if (pid > 0) {
1935         sprintf(spid, "%d", pid);
1936         svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
1937         if (svp && *svp != &sv_undef) {
1938             *statusp = SvIVX(*svp);
1939             (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
1940             return pid;
1941         }
1942     }
1943     else {
1944         HE *entry;
1945
1946         hv_iterinit(pidstatus);
1947         if (entry = hv_iternext(pidstatus)) {
1948             pid = atoi(hv_iterkey(entry,(I32*)statusp));
1949             sv = hv_iterval(pidstatus,entry);
1950             *statusp = SvIVX(sv);
1951             sprintf(spid, "%d", pid);
1952             (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
1953             return pid;
1954         }
1955     }
1956 #ifdef HAS_WAITPID
1957     return waitpid(pid,statusp,flags);
1958 #else
1959 #ifdef HAS_WAIT4
1960     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
1961 #else
1962     {
1963         I32 result;
1964         if (flags)
1965             croak("Can't do waitpid with flags");
1966         else {
1967             while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
1968                 pidgone(result,*statusp);
1969             if (result < 0)
1970                 *statusp = -1;
1971         }
1972         return result;
1973     }
1974 #endif
1975 #endif
1976 }
1977 #endif /* !DOSISH */
1978
1979 void
1980 /*SUPPRESS 590*/
1981 pidgone(pid,status)
1982 int pid;
1983 int status;
1984 {
1985     register SV *sv;
1986     char spid[16];
1987
1988     sprintf(spid, "%d", pid);
1989     sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
1990     (void)SvUPGRADE(sv,SVt_IV);
1991     SvIVX(sv) = status;
1992     return;
1993 }
1994
1995 #if defined(atarist) || defined(OS2) || defined(DJGPP)
1996 int pclose();
1997 #ifdef HAS_FORK
1998 int                                     /* Cannot prototype with I32
1999                                            in os2ish.h. */
2000 my_syspclose(ptr)
2001 #else
2002 I32
2003 my_pclose(ptr)
2004 #endif
2005 PerlIO *ptr;
2006 {
2007     /* Needs work for PerlIO ! */
2008     FILE *f = PerlIO_findFILE(ptr);
2009     I32 result = pclose(f);
2010     PerlIO_releaseFILE(ptr,f);
2011     return result;
2012 }
2013 #endif
2014
2015 void
2016 repeatcpy(to,from,len,count)
2017 register char *to;
2018 register char *from;
2019 I32 len;
2020 register I32 count;
2021 {
2022     register I32 todo;
2023     register char *frombase = from;
2024
2025     if (len == 1) {
2026         todo = *from;
2027         while (count-- > 0)
2028             *to++ = todo;
2029         return;
2030     }
2031     while (count-- > 0) {
2032         for (todo = len; todo > 0; todo--) {
2033             *to++ = *from++;
2034         }
2035         from = frombase;
2036     }
2037 }
2038
2039 #ifndef CASTNEGFLOAT
2040 U32
2041 cast_ulong(f)
2042 double f;
2043 {
2044     long along;
2045
2046 #if CASTFLAGS & 2
2047 #   define BIGDOUBLE 2147483648.0
2048     if (f >= BIGDOUBLE)
2049         return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
2050 #endif
2051     if (f >= 0.0)
2052         return (unsigned long)f;
2053     along = (long)f;
2054     return (unsigned long)along;
2055 }
2056 # undef BIGDOUBLE
2057 #endif
2058
2059 #ifndef CASTI32
2060
2061 /* Unfortunately, on some systems the cast_uv() function doesn't
2062    work with the system-supplied definition of ULONG_MAX.  The
2063    comparison  (f >= ULONG_MAX) always comes out true.  It must be a
2064    problem with the compiler constant folding.
2065
2066    In any case, this workaround should be fine on any two's complement
2067    system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2068    ccflags.
2069                --Andy Dougherty      <doughera@lafcol.lafayette.edu>
2070 */
2071
2072 /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2073    of LONG_(MIN/MAX).
2074                            -- Kenneth Albanowski <kjahds@kjahds.com>
2075 */
2076
2077 #ifndef MY_UV_MAX
2078 #  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
2079 #endif
2080
2081 I32
2082 cast_i32(f)
2083 double f;
2084 {
2085     if (f >= I32_MAX)
2086         return (I32) I32_MAX;
2087     if (f <= I32_MIN)
2088         return (I32) I32_MIN;
2089     return (I32) f;
2090 }
2091
2092 IV
2093 cast_iv(f)
2094 double f;
2095 {
2096     if (f >= IV_MAX)
2097         return (IV) IV_MAX;
2098     if (f <= IV_MIN)
2099         return (IV) IV_MIN;
2100     return (IV) f;
2101 }
2102
2103 UV
2104 cast_uv(f)
2105 double f;
2106 {
2107     if (f >= MY_UV_MAX)
2108         return (UV) MY_UV_MAX;
2109     return (UV) f;
2110 }
2111
2112 #endif
2113
2114 #ifndef HAS_RENAME
2115 I32
2116 same_dirent(a,b)
2117 char *a;
2118 char *b;
2119 {
2120     char *fa = strrchr(a,'/');
2121     char *fb = strrchr(b,'/');
2122     struct stat tmpstatbuf1;
2123     struct stat tmpstatbuf2;
2124 #ifndef MAXPATHLEN
2125 #define MAXPATHLEN 1024
2126 #endif
2127     char tmpbuf[MAXPATHLEN+1];
2128
2129     if (fa)
2130         fa++;
2131     else
2132         fa = a;
2133     if (fb)
2134         fb++;
2135     else
2136         fb = b;
2137     if (strNE(a,b))
2138         return FALSE;
2139     if (fa == a)
2140         strcpy(tmpbuf,".");
2141     else
2142         strncpy(tmpbuf, a, fa - a);
2143     if (Stat(tmpbuf, &tmpstatbuf1) < 0)
2144         return FALSE;
2145     if (fb == b)
2146         strcpy(tmpbuf,".");
2147     else
2148         strncpy(tmpbuf, b, fb - b);
2149     if (Stat(tmpbuf, &tmpstatbuf2) < 0)
2150         return FALSE;
2151     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2152            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2153 }
2154 #endif /* !HAS_RENAME */
2155
2156 UV
2157 scan_oct(start, len, retlen)
2158 char *start;
2159 I32 len;
2160 I32 *retlen;
2161 {
2162     register char *s = start;
2163     register UV retval = 0;
2164     bool overflowed = FALSE;
2165
2166     while (len && *s >= '0' && *s <= '7') {
2167         register UV n = retval << 3;
2168         if (!overflowed && (n >> 3) != retval) {
2169             warn("Integer overflow in octal number");
2170             overflowed = TRUE;
2171         }
2172         retval = n | (*s++ - '0');
2173         len--;
2174     }
2175     if (dowarn && len && (*s == '8' || *s == '9'))
2176         warn("Illegal octal digit ignored");
2177     *retlen = s - start;
2178     return retval;
2179 }
2180
2181 unsigned long
2182 scan_hex(start, len, retlen)
2183 char *start;
2184 I32 len;
2185 I32 *retlen;
2186 {
2187     register char *s = start;
2188     register UV retval = 0;
2189     bool overflowed = FALSE;
2190     char *tmp;
2191
2192     while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
2193         register UV n = retval << 4;
2194         if (!overflowed && (n >> 4) != retval) {
2195             warn("Integer overflow in hex number");
2196             overflowed = TRUE;
2197         }
2198         retval = n | (tmp - hexdigit) & 15;
2199         s++;
2200     }
2201     *retlen = s - start;
2202     return retval;
2203 }
2204
2205
2206 #ifdef HUGE_VAL
2207 /*
2208  * This hack is to force load of "huge" support from libm.a
2209  * So it is in perl for (say) POSIX to use.
2210  * Needed for SunOS with Sun's 'acc' for example.
2211  */
2212 double
2213 Perl_huge()
2214 {
2215  return HUGE_VAL;
2216 }
2217 #endif