util.c

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