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