util.c

   1 /*    util.c
   2  *
   3  *    Copyright (c) 1991-1999, 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 #define PERL_IN_UTIL_C
  17 #include "perl.h"
  18
  19 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  20 #include <signal.h>
  21 #endif
  22
  23 #ifndef SIG_ERR
  24 # define SIG_ERR ((Sighandler_t) -1)
  25 #endif
  26
  27 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  28 #ifdef I_UNISTD
  29 #  include <unistd.h>
  30 #endif
  31
  32 #ifdef I_VFORK
  33 #  include <vfork.h>
  34 #endif
  35
  36 /* Put this after #includes because fork and vfork prototypes may
  37    conflict.
  38 */
  39 #ifndef HAS_VFORK
  40 #   define vfork fork
  41 #endif
  42
  43 #ifdef I_FCNTL
  44 #  include <fcntl.h>
  45 #endif
  46 #ifdef I_SYS_FILE
  47 #  include <sys/file.h>
  48 #endif
  49
  50 #ifdef I_SYS_WAIT
  51 #  include <sys/wait.h>
  52 #endif
  53
  54 #ifdef I_LOCALE
  55 #  include <locale.h>
  56 #endif
  57
  58 #define FLUSH
  59
  60 #ifdef LEAKTEST
  61
  62 long xcount[MAXXCOUNT];
  63 long lastxcount[MAXXCOUNT];
  64 long xycount[MAXXCOUNT][MAXYCOUNT];
  65 long lastxycount[MAXXCOUNT][MAXYCOUNT];
  66
  67 #endif
  68
  69 /* paranoid version of system's malloc() */
  70
  71 /* NOTE:  Do not call the next three routines directly.  Use the macros
  72  * in handy.h, so that we can easily redefine everything to do tracking of
  73  * allocated hunks back to the original New to track down any memory leaks.
  74  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  75  */
  76
  77 Malloc_t
  78 Perl_safesysmalloc(MEM_SIZE size)
  79 {
  80     Malloc_t ptr;
  81 #ifdef HAS_64K_LIMIT
  82         if (size > 0xffff) {
  83                 PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
  84                 WITH_THX(my_exit(1));
  85         }
  86 #endif /* HAS_64K_LIMIT */
  87 #ifdef DEBUGGING
  88     if ((long)size < 0)
  89         Perl_croak_nocontext("panic: malloc");
  90 #endif
  91     ptr = PerlMem_malloc(size?size:1);  /* malloc(0) is NASTY on our system */
  92 #if !(defined(I286) || defined(atarist))
  93     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
  94 #else
  95     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
  96 #endif
  97     if (ptr != Nullch)
  98         return ptr;
  99     else if (PL_nomemok)
 100         return Nullch;
 101     else {
 102         PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
 103         WITH_THX(my_exit(1));
 104         return Nullch;
 105     }
 106     /*NOTREACHED*/
 107 }
 108
 109 /* paranoid version of system's realloc() */
 110
 111 Malloc_t
 112 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 113 {
 114     Malloc_t ptr;
 115 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
 116     Malloc_t PerlMem_realloc();
 117 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 118
 119 #ifdef HAS_64K_LIMIT
 120     if (size > 0xffff) {
 121         PerlIO_printf(PerlIO_stderr(),
 122                       "Reallocation too large: %lx\n", size) FLUSH;
 123         WITH_THX(my_exit(1));
 124     }
 125 #endif /* HAS_64K_LIMIT */
 126     if (!size) {
 127         safesysfree(where);
 128         return NULL;
 129     }
 130
 131     if (!where)
 132         return safesysmalloc(size);
 133 #ifdef DEBUGGING
 134     if ((long)size < 0)
 135         Perl_croak_nocontext("panic: realloc");
 136 #endif
 137     ptr = PerlMem_realloc(where,size);
 138
 139 #if !(defined(I286) || defined(atarist))
 140     DEBUG_m( {
 141         PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++);
 142         PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
 143     } )
 144 #else
 145     DEBUG_m( {
 146         PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++);
 147         PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
 148     } )
 149 #endif
 150
 151     if (ptr != Nullch)
 152         return ptr;
 153     else if (PL_nomemok)
 154         return Nullch;
 155     else {
 156         PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
 157         WITH_THX(my_exit(1));
 158         return Nullch;
 159     }
 160     /*NOTREACHED*/
 161 }
 162
 163 /* safe version of system's free() */
 164
 165 Free_t
 166 Perl_safesysfree(Malloc_t where)
 167 {
 168 #if !(defined(I286) || defined(atarist))
 169     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++));
 170 #else
 171     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++));
 172 #endif
 173     if (where) {
 174         /*SUPPRESS 701*/
 175         PerlMem_free(where);
 176     }
 177 }
 178
 179 /* safe version of system's calloc() */
 180
 181 Malloc_t
 182 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 183 {
 184     Malloc_t ptr;
 185
 186 #ifdef HAS_64K_LIMIT
 187     if (size * count > 0xffff) {
 188         PerlIO_printf(PerlIO_stderr(),
 189                       "Allocation too large: %lx\n", size * count) FLUSH;
 190         WITH_THX(my_exit(1));
 191     }
 192 #endif /* HAS_64K_LIMIT */
 193 #ifdef DEBUGGING
 194     if ((long)size < 0 || (long)count < 0)
 195         Perl_croak_nocontext("panic: calloc");
 196 #endif
 197     size *= count;
 198     ptr = PerlMem_malloc(size?size:1);  /* malloc(0) is NASTY on our system */
 199 #if !(defined(I286) || defined(atarist))
 200     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld  x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
 201 #else
 202     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
 203 #endif
 204     if (ptr != Nullch) {
 205         memset((void*)ptr, 0, size);
 206         return ptr;
 207     }
 208     else if (PL_nomemok)
 209         return Nullch;
 210     else {
 211         PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
 212         WITH_THX(my_exit(1));
 213         return Nullch;
 214     }
 215     /*NOTREACHED*/
 216 }
 217
 218 #ifdef LEAKTEST
 219
 220 struct mem_test_strut {
 221     union {
 222         long type;
 223         char c[2];
 224     } u;
 225     long size;
 226 };
 227
 228 #    define ALIGN sizeof(struct mem_test_strut)
 229
 230 #    define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
 231 #    define typeof_chunk(ch) \
 232         (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
 233 #    define set_typeof_chunk(ch,t) \
 234         (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
 235 #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE                            \
 236                           ? MAXYCOUNT - 1                               \
 237                           : ( (size) > 40                               \
 238                               ? ((size) - 1)/8 + 5                      \
 239                               : ((size) - 1)/4))
 240
 241 Malloc_t
 242 Perl_safexmalloc(I32 x, MEM_SIZE size)
 243 {
 244     register char* where = (char*)safemalloc(size + ALIGN);
 245
 246     xcount[x] += size;
 247     xycount[x][SIZE_TO_Y(size)]++;
 248     set_typeof_chunk(where, x);
 249     sizeof_chunk(where) = size;
 250     return (Malloc_t)(where + ALIGN);
 251 }
 252
 253 Malloc_t
 254 Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
 255 {
 256     char *where = (char*)wh;
 257
 258     if (!wh)
 259         return safexmalloc(0,size);
 260
 261     {
 262         MEM_SIZE old = sizeof_chunk(where - ALIGN);
 263         int t = typeof_chunk(where - ALIGN);
 264         register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
 265
 266         xycount[t][SIZE_TO_Y(old)]--;
 267         xycount[t][SIZE_TO_Y(size)]++;
 268         xcount[t] += size - old;
 269         sizeof_chunk(new) = size;
 270         return (Malloc_t)(new + ALIGN);
 271     }
 272 }
 273
 274 void
 275 Perl_safexfree(Malloc_t wh)
 276 {
 277     I32 x;
 278     char *where = (char*)wh;
 279     MEM_SIZE size;
 280
 281     if (!where)
 282         return;
 283     where -= ALIGN;
 284     size = sizeof_chunk(where);
 285     x = where[0] + 100 * where[1];
 286     xcount[x] -= size;
 287     xycount[x][SIZE_TO_Y(size)]--;
 288     safefree(where);
 289 }
 290
 291 Malloc_t
 292 Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
 293 {
 294     register char * where = (char*)safexmalloc(x, size * count + ALIGN);
 295     xcount[x] += size;
 296     xycount[x][SIZE_TO_Y(size)]++;
 297     memset((void*)(where + ALIGN), 0, size * count);
 298     set_typeof_chunk(where, x);
 299     sizeof_chunk(where) = size;
 300     return (Malloc_t)(where + ALIGN);
 301 }
 302
 303 STATIC void
 304 S_xstat(pTHX_ int flag)
 305 {
 306     register I32 i, j, total = 0;
 307     I32 subtot[MAXYCOUNT];
 308
 309     for (j = 0; j < MAXYCOUNT; j++) {
 310         subtot[j] = 0;
 311     }
 312
 313     PerlIO_printf(PerlIO_stderr(), "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
 314     for (i = 0; i < MAXXCOUNT; i++) {
 315         total += xcount[i];
 316         for (j = 0; j < MAXYCOUNT; j++) {
 317             subtot[j] += xycount[i][j];
 318         }
 319         if (flag == 0
 320             ? xcount[i]                 /* Have something */
 321             : (flag == 2
 322                ? xcount[i] != lastxcount[i] /* Changed */
 323                : xcount[i] > lastxcount[i])) { /* Growed */
 324             PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100,
 325                           flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
 326             lastxcount[i] = xcount[i];
 327             for (j = 0; j < MAXYCOUNT; j++) {
 328                 if ( flag == 0
 329                      ? xycount[i][j]    /* Have something */
 330                      : (flag == 2
 331                         ? xycount[i][j] != lastxycount[i][j] /* Changed */
 332                         : xycount[i][j] > lastxycount[i][j])) { /* Growed */
 333                     PerlIO_printf(PerlIO_stderr(),"%3ld ",
 334                                   flag == 2
 335                                   ? xycount[i][j] - lastxycount[i][j]
 336                                   : xycount[i][j]);
 337                     lastxycount[i][j] = xycount[i][j];
 338                 } else {
 339                     PerlIO_printf(PerlIO_stderr(), "  . ", xycount[i][j]);
 340                 }
 341             }
 342             PerlIO_printf(PerlIO_stderr(), "\n");
 343         }
 344     }
 345     if (flag != 2) {
 346         PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total);
 347         for (j = 0; j < MAXYCOUNT; j++) {
 348             if (subtot[j]) {
 349                 PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]);
 350             } else {
 351                 PerlIO_printf(PerlIO_stderr(), "  . ");
 352             }
 353         }
 354         PerlIO_printf(PerlIO_stderr(), "\n");
 355     }
 356 }
 357
 358 #endif /* LEAKTEST */
 359
 360 /* copy a string up to some (non-backslashed) delimiter, if any */
 361
 362 char *
 363 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
 364 {
 365     register I32 tolen;
 366     for (tolen = 0; from < fromend; from++, tolen++) {
 367         if (*from == '\\') {
 368             if (from[1] == delim)
 369                 from++;
 370             else {
 371                 if (to < toend)
 372                     *to++ = *from;
 373                 tolen++;
 374                 from++;
 375             }
 376         }
 377         else if (*from == delim)
 378             break;
 379         if (to < toend)
 380             *to++ = *from;
 381     }
 382     if (to < toend)
 383         *to = '\0';
 384     *retlen = tolen;
 385     return from;
 386 }
 387
 388 /* return ptr to little string in big string, NULL if not found */
 389 /* This routine was donated by Corey Satten. */
 390
 391 char *
 392 Perl_instr(pTHX_ register const char *big, register const char *little)
 393 {
 394     register const char *s, *x;
 395     register I32 first;
 396
 397     if (!little)
 398         return (char*)big;
 399     first = *little++;
 400     if (!first)
 401         return (char*)big;
 402     while (*big) {
 403         if (*big++ != first)
 404             continue;
 405         for (x=big,s=little; *s; /**/ ) {
 406             if (!*x)
 407                 return Nullch;
 408             if (*s++ != *x++) {
 409                 s--;
 410                 break;
 411             }
 412         }
 413         if (!*s)
 414             return (char*)(big-1);
 415     }
 416     return Nullch;
 417 }
 418
 419 /* same as instr but allow embedded nulls */
 420
 421 char *
 422 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 423 {
 424     register const char *s, *x;
 425     register I32 first = *little;
 426     register const char *littleend = lend;
 427
 428     if (!first && little >= littleend)
 429         return (char*)big;
 430     if (bigend - big < littleend - little)
 431         return Nullch;
 432     bigend -= littleend - little++;
 433     while (big <= bigend) {
 434         if (*big++ != first)
 435             continue;
 436         for (x=big,s=little; s < littleend; /**/ ) {
 437             if (*s++ != *x++) {
 438                 s--;
 439                 break;
 440             }
 441         }
 442         if (s >= littleend)
 443             return (char*)(big-1);
 444     }
 445     return Nullch;
 446 }
 447
 448 /* reverse of the above--find last substring */
 449
 450 char *
 451 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
 452 {
 453     register const char *bigbeg;
 454     register const char *s, *x;
 455     register I32 first = *little;
 456     register const char *littleend = lend;
 457
 458     if (!first && little >= littleend)
 459         return (char*)bigend;
 460     bigbeg = big;
 461     big = bigend - (littleend - little++);
 462     while (big >= bigbeg) {
 463         if (*big-- != first)
 464             continue;
 465         for (x=big+2,s=little; s < littleend; /**/ ) {
 466             if (*s++ != *x++) {
 467                 s--;
 468                 break;
 469             }
 470         }
 471         if (s >= littleend)
 472             return (char*)(big+1);
 473     }
 474     return Nullch;
 475 }
 476
 477 /*
 478  * Set up for a new ctype locale.
 479  */
 480 void
 481 Perl_new_ctype(pTHX_ const char *newctype)
 482 {
 483 #ifdef USE_LOCALE_CTYPE
 484
 485     int i;
 486
 487     for (i = 0; i < 256; i++) {
 488         if (isUPPER_LC(i))
 489             PL_fold_locale[i] = toLOWER_LC(i);
 490         else if (isLOWER_LC(i))
 491             PL_fold_locale[i] = toUPPER_LC(i);
 492         else
 493             PL_fold_locale[i] = i;
 494     }
 495
 496 #endif /* USE_LOCALE_CTYPE */
 497 }
 498
 499 /*
 500  * Set up for a new collation locale.
 501  */
 502 void
 503 Perl_new_collate(pTHX_ const char *newcoll)
 504 {
 505 #ifdef USE_LOCALE_COLLATE
 506
 507     if (! newcoll) {
 508         if (PL_collation_name) {
 509             ++PL_collation_ix;
 510             Safefree(PL_collation_name);
 511             PL_collation_name = NULL;
 512             PL_collation_standard = TRUE;
 513             PL_collxfrm_base = 0;
 514             PL_collxfrm_mult = 2;
 515         }
 516         return;
 517     }
 518
 519     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
 520         ++PL_collation_ix;
 521         Safefree(PL_collation_name);
 522         PL_collation_name = savepv(newcoll);
 523         PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
 524
 525         {
 526           /*  2: at most so many chars ('a', 'b'). */
 527           /* 50: surely no system expands a char more. */
 528 #define XFRMBUFSIZE  (2 * 50)
 529           char xbuf[XFRMBUFSIZE];
 530           Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
 531           Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
 532           SSize_t mult = fb - fa;
 533           if (mult < 1)
 534               Perl_croak(aTHX_ "strxfrm() gets absurd");
 535           PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
 536           PL_collxfrm_mult = mult;
 537         }
 538     }
 539
 540 #endif /* USE_LOCALE_COLLATE */
 541 }
 542
 543 void
 544 perl_set_numeric_radix(void)
 545 {
 546 #ifdef USE_LOCALE_NUMERIC
 547 # ifdef HAS_LOCALECONV
 548     struct lconv* lc;
 549
 550     lc = localeconv();
 551     if (lc && lc->decimal_point)
 552         /* We assume that decimal separator aka the radix
 553          * character is always a single character.  If it
 554          * ever is a string, this needs to be rethunk. */
 555         PL_numeric_radix = *lc->decimal_point;
 556     else
 557         PL_numeric_radix = 0;
 558 # endif /* HAS_LOCALECONV */
 559 #else
 560     PL_numeric_radix = 0;
 561 #endif /* USE_LOCALE_NUMERIC */
 562 }
 563
 564 /*
 565  * Set up for a new numeric locale.
 566  */
 567 void
 568 Perl_new_numeric(pTHX_ const char *newnum)
 569 {
 570 #ifdef USE_LOCALE_NUMERIC
 571
 572     if (! newnum) {
 573         if (PL_numeric_name) {
 574             Safefree(PL_numeric_name);
 575             PL_numeric_name = NULL;
 576             PL_numeric_standard = TRUE;
 577             PL_numeric_local = TRUE;
 578         }
 579         return;
 580     }
 581
 582     if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
 583         Safefree(PL_numeric_name);
 584         PL_numeric_name = savepv(newnum);
 585         PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
 586         PL_numeric_local = TRUE;
 587         perl_set_numeric_radix();
 588     }
 589
 590 #endif /* USE_LOCALE_NUMERIC */
 591 }
 592
 593 void
 594 Perl_set_numeric_standard(pTHX)
 595 {
 596 #ifdef USE_LOCALE_NUMERIC
 597
 598     if (! PL_numeric_standard) {
 599         setlocale(LC_NUMERIC, "C");
 600         PL_numeric_standard = TRUE;
 601         PL_numeric_local = FALSE;
 602     }
 603
 604 #endif /* USE_LOCALE_NUMERIC */
 605 }
 606
 607 void
 608 Perl_set_numeric_local(pTHX)
 609 {
 610 #ifdef USE_LOCALE_NUMERIC
 611
 612     if (! PL_numeric_local) {
 613         setlocale(LC_NUMERIC, PL_numeric_name);
 614         PL_numeric_standard = FALSE;
 615         PL_numeric_local = TRUE;
 616         perl_set_numeric_radix();
 617     }
 618
 619 #endif /* USE_LOCALE_NUMERIC */
 620 }
 621
 622 /*
 623  * Initialize locale awareness.
 624  */
 625 int
 626 Perl_init_i18nl10n(pTHX_ int printwarn)
 627 {
 628     int ok = 1;
 629     /* returns
 630      *    1 = set ok or not applicable,
 631      *    0 = fallback to C locale,
 632      *   -1 = fallback to C locale failed
 633      */
 634
 635 #ifdef USE_LOCALE
 636
 637 #ifdef USE_LOCALE_CTYPE
 638     char *curctype   = NULL;
 639 #endif /* USE_LOCALE_CTYPE */
 640 #ifdef USE_LOCALE_COLLATE
 641     char *curcoll    = NULL;
 642 #endif /* USE_LOCALE_COLLATE */
 643 #ifdef USE_LOCALE_NUMERIC
 644     char *curnum     = NULL;
 645 #endif /* USE_LOCALE_NUMERIC */
 646 #ifdef __GLIBC__
 647     char *language   = PerlEnv_getenv("LANGUAGE");
 648 #endif
 649     char *lc_all     = PerlEnv_getenv("LC_ALL");
 650     char *lang       = PerlEnv_getenv("LANG");
 651     bool setlocale_failure = FALSE;
 652
 653 #ifdef LOCALE_ENVIRON_REQUIRED
 654
 655     /*
 656      * Ultrix setlocale(..., "") fails if there are no environment
 657      * variables from which to get a locale name.
 658      */
 659
 660     bool done = FALSE;
 661
 662 #ifdef LC_ALL
 663     if (lang) {
 664         if (setlocale(LC_ALL, ""))
 665             done = TRUE;
 666         else
 667             setlocale_failure = TRUE;
 668     }
 669     if (!setlocale_failure) {
 670 #ifdef USE_LOCALE_CTYPE
 671         if (! (curctype =
 672                setlocale(LC_CTYPE,
 673                          (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
 674                                     ? "" : Nullch)))
 675             setlocale_failure = TRUE;
 676 #endif /* USE_LOCALE_CTYPE */
 677 #ifdef USE_LOCALE_COLLATE
 678         if (! (curcoll =
 679                setlocale(LC_COLLATE,
 680                          (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
 681                                    ? "" : Nullch)))
 682             setlocale_failure = TRUE;
 683 #endif /* USE_LOCALE_COLLATE */
 684 #ifdef USE_LOCALE_NUMERIC
 685         if (! (curnum =
 686                setlocale(LC_NUMERIC,
 687                          (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
 688                                   ? "" : Nullch)))
 689             setlocale_failure = TRUE;
 690 #endif /* USE_LOCALE_NUMERIC */
 691     }
 692
 693 #endif /* LC_ALL */
 694
 695 #endif /* !LOCALE_ENVIRON_REQUIRED */
 696
 697 #ifdef LC_ALL
 698     if (! setlocale(LC_ALL, ""))
 699         setlocale_failure = TRUE;
 700 #endif /* LC_ALL */
 701
 702     if (!setlocale_failure) {
 703 #ifdef USE_LOCALE_CTYPE
 704         if (! (curctype = setlocale(LC_CTYPE, "")))
 705             setlocale_failure = TRUE;
 706 #endif /* USE_LOCALE_CTYPE */
 707 #ifdef USE_LOCALE_COLLATE
 708         if (! (curcoll = setlocale(LC_COLLATE, "")))
 709             setlocale_failure = TRUE;
 710 #endif /* USE_LOCALE_COLLATE */
 711 #ifdef USE_LOCALE_NUMERIC
 712         if (! (curnum = setlocale(LC_NUMERIC, "")))
 713             setlocale_failure = TRUE;
 714 #endif /* USE_LOCALE_NUMERIC */
 715     }
 716
 717     if (setlocale_failure) {
 718         char *p;
 719         bool locwarn = (printwarn > 1 ||
 720                         printwarn &&
 721                         (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
 722
 723         if (locwarn) {
 724 #ifdef LC_ALL
 725
 726             PerlIO_printf(PerlIO_stderr(),
 727                "perl: warning: Setting locale failed.\n");
 728
 729 #else /* !LC_ALL */
 730
 731             PerlIO_printf(PerlIO_stderr(),
 732                "perl: warning: Setting locale failed for the categories:\n\t");
 733 #ifdef USE_LOCALE_CTYPE
 734             if (! curctype)
 735                 PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
 736 #endif /* USE_LOCALE_CTYPE */
 737 #ifdef USE_LOCALE_COLLATE
 738             if (! curcoll)
 739                 PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
 740 #endif /* USE_LOCALE_COLLATE */
 741 #ifdef USE_LOCALE_NUMERIC
 742             if (! curnum)
 743                 PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC ");
 744 #endif /* USE_LOCALE_NUMERIC */
 745             PerlIO_printf(PerlIO_stderr(), "\n");
 746
 747 #endif /* LC_ALL */
 748
 749             PerlIO_printf(PerlIO_stderr(),
 750                 "perl: warning: Please check that your locale settings:\n");
 751
 752 #ifdef __GLIBC__
 753             PerlIO_printf(PerlIO_stderr(),
 754                           "\tLANGUAGE = %c%s%c,\n",
 755                           language ? '"' : '(',
 756                           language ? language : "unset",
 757                           language ? '"' : ')');
 758 #endif
 759
 760             PerlIO_printf(PerlIO_stderr(),
 761                           "\tLC_ALL = %c%s%c,\n",
 762                           lc_all ? '"' : '(',
 763                           lc_all ? lc_all : "unset",
 764                           lc_all ? '"' : ')');
 765
 766             {
 767               char **e;
 768               for (e = environ; *e; e++) {
 769                   if (strnEQ(*e, "LC_", 3)
 770                         && strnNE(*e, "LC_ALL=", 7)
 771                         && (p = strchr(*e, '=')))
 772                       PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n",
 773                                     (int)(p - *e), *e, p + 1);
 774               }
 775             }
 776
 777             PerlIO_printf(PerlIO_stderr(),
 778                           "\tLANG = %c%s%c\n",
 779                           lang ? '"' : '(',
 780                           lang ? lang : "unset",
 781                           lang ? '"' : ')');
 782
 783             PerlIO_printf(PerlIO_stderr(),
 784                           "    are supported and installed on your system.\n");
 785         }
 786
 787 #ifdef LC_ALL
 788
 789         if (setlocale(LC_ALL, "C")) {
 790             if (locwarn)
 791                 PerlIO_printf(PerlIO_stderr(),
 792       "perl: warning: Falling back to the standard locale (\"C\").\n");
 793             ok = 0;
 794         }
 795         else {
 796             if (locwarn)
 797                 PerlIO_printf(PerlIO_stderr(),
 798       "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
 799             ok = -1;
 800         }
 801
 802 #else /* ! LC_ALL */
 803
 804         if (0
 805 #ifdef USE_LOCALE_CTYPE
 806             || !(curctype || setlocale(LC_CTYPE, "C"))
 807 #endif /* USE_LOCALE_CTYPE */
 808 #ifdef USE_LOCALE_COLLATE
 809             || !(curcoll || setlocale(LC_COLLATE, "C"))
 810 #endif /* USE_LOCALE_COLLATE */
 811 #ifdef USE_LOCALE_NUMERIC
 812             || !(curnum || setlocale(LC_NUMERIC, "C"))
 813 #endif /* USE_LOCALE_NUMERIC */
 814             )
 815         {
 816             if (locwarn)
 817                 PerlIO_printf(PerlIO_stderr(),
 818       "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
 819             ok = -1;
 820         }
 821
 822 #endif /* ! LC_ALL */
 823
 824 #ifdef USE_LOCALE_CTYPE
 825         curctype = setlocale(LC_CTYPE, Nullch);
 826 #endif /* USE_LOCALE_CTYPE */
 827 #ifdef USE_LOCALE_COLLATE
 828         curcoll = setlocale(LC_COLLATE, Nullch);
 829 #endif /* USE_LOCALE_COLLATE */
 830 #ifdef USE_LOCALE_NUMERIC
 831         curnum = setlocale(LC_NUMERIC, Nullch);
 832 #endif /* USE_LOCALE_NUMERIC */
 833     }
 834
 835 #ifdef USE_LOCALE_CTYPE
 836     new_ctype(curctype);
 837 #endif /* USE_LOCALE_CTYPE */
 838
 839 #ifdef USE_LOCALE_COLLATE
 840     new_collate(curcoll);
 841 #endif /* USE_LOCALE_COLLATE */
 842
 843 #ifdef USE_LOCALE_NUMERIC
 844     new_numeric(curnum);
 845 #endif /* USE_LOCALE_NUMERIC */
 846
 847 #endif /* USE_LOCALE */
 848
 849     return ok;
 850 }
 851
 852 /* Backwards compatibility. */
 853 int
 854 Perl_init_i18nl14n(pTHX_ int printwarn)
 855 {
 856     return init_i18nl10n(printwarn);
 857 }
 858
 859 #ifdef USE_LOCALE_COLLATE
 860
 861 /*
 862  * mem_collxfrm() is a bit like strxfrm() but with two important
 863  * differences. First, it handles embedded NULs. Second, it allocates
 864  * a bit more memory than needed for the transformed data itself.
 865  * The real transformed data begins at offset sizeof(collationix).
 866  * Please see sv_collxfrm() to see how this is used.
 867  */
 868 char *
 869 Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
 870 {
 871     char *xbuf;
 872     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
 873
 874     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
 875     /* the +1 is for the terminating NUL. */
 876
 877     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
 878     New(171, xbuf, xAlloc, char);
 879     if (! xbuf)
 880         goto bad;
 881
 882     *(U32*)xbuf = PL_collation_ix;
 883     xout = sizeof(PL_collation_ix);
 884     for (xin = 0; xin < len; ) {
 885         SSize_t xused;
 886
 887         for (;;) {
 888             xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
 889             if (xused == -1)
 890                 goto bad;
 891             if (xused < xAlloc - xout)
 892                 break;
 893             xAlloc = (2 * xAlloc) + 1;
 894             Renew(xbuf, xAlloc, char);
 895             if (! xbuf)
 896                 goto bad;
 897         }
 898
 899         xin += strlen(s + xin) + 1;
 900         xout += xused;
 901
 902         /* Embedded NULs are understood but silently skipped
 903          * because they make no sense in locale collation. */
 904     }
 905
 906     xbuf[xout] = '\0';
 907     *xlen = xout - sizeof(PL_collation_ix);
 908     return xbuf;
 909
 910   bad:
 911     Safefree(xbuf);
 912     *xlen = 0;
 913     return NULL;
 914 }
 915
 916 #endif /* USE_LOCALE_COLLATE */
 917
 918 #define FBM_TABLE_OFFSET 2      /* Number of bytes between EOS and table*/
 919
 920 /* As a space optimization, we do not compile tables for strings of length
 921    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 922    special-cased in fbm_instr().
 923
 924    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 925
 926 void
 927 Perl_fbm_compile(pTHX_ SV *sv, U32 flags /* not used yet */)
 928 {
 929     register U8 *s;
 930     register U8 *table;
 931     register U32 i;
 932     STRLEN len;
 933     I32 rarest = 0;
 934     U32 frequency = 256;
 935
 936     if (flags & FBMcf_TAIL)
 937         sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
 938     s = (U8*)SvPV_force(sv, len);
 939     (void)SvUPGRADE(sv, SVt_PVBM);
 940     if (len == 0)               /* TAIL might be on on a zero-length string. */
 941         return;
 942     if (len > 2) {
 943         I32 mlen = len;
 944         unsigned char *sb;
 945
 946         if (mlen > 255)
 947             mlen = 255;
 948         Sv_Grow(sv,len + 256 + FBM_TABLE_OFFSET);
 949         table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
 950         s = table - 1 - FBM_TABLE_OFFSET; /* Last char */
 951         for (i = 0; i < 256; i++) {
 952             table[i] = mlen;
 953         }
 954         table[-1] = flags;              /* Not used yet */
 955         i = 0;
 956         sb = s - mlen;
 957         while (s >= sb) {
 958             if (table[*s] == mlen)
 959                 table[*s] = i;
 960             s--, i++;
 961         }
 962     }
 963     sv_magic(sv, Nullsv, 'B', Nullch, 0);       /* deep magic */
 964     SvVALID_on(sv);
 965
 966     s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
 967     for (i = 0; i < len; i++) {
 968         if (PL_freq[s[i]] < frequency) {
 969             rarest = i;
 970             frequency = PL_freq[s[i]];
 971         }
 972     }
 973     BmRARE(sv) = s[rarest];
 974     BmPREVIOUS(sv) = rarest;
 975     BmUSEFUL(sv) = 100;                 /* Initial value */
 976     if (flags & FBMcf_TAIL)
 977         SvTAIL_on(sv);
 978     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
 979 }
 980
 981 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 982 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 983    if multiline */
 984
 985 char *
 986 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
 987 {
 988     register unsigned char *s;
 989     STRLEN l;
 990     register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
 991     register STRLEN littlelen = l;
 992     register I32 multiline = flags & FBMrf_MULTILINE;
 993
 994     if (bigend - big < littlelen) {
 995       check_tail:
 996         if ( SvTAIL(littlestr)
 997              && (bigend - big == littlelen - 1)
 998              && (littlelen == 1
 999                  || *big == *little && memEQ(big, little, littlelen - 1)))
1000             return (char*)big;
1001         return Nullch;
1002     }
1003
1004     if (littlelen <= 2) {               /* Special-cased */
1005         register char c;
1006
1007         if (littlelen == 1) {
1008             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
1009                 /* Know that bigend != big.  */
1010                 if (bigend[-1] == '\n')
1011                     return (char *)(bigend - 1);
1012                 return (char *) bigend;
1013             }
1014             s = big;
1015             while (s < bigend) {
1016                 if (*s == *little)
1017                     return (char *)s;
1018                 s++;
1019             }
1020             if (SvTAIL(littlestr))
1021                 return (char *) bigend;
1022             return Nullch;
1023         }
1024         if (!littlelen)
1025             return (char*)big;          /* Cannot be SvTAIL! */
1026
1027         /* littlelen is 2 */
1028         if (SvTAIL(littlestr) && !multiline) {
1029             if (bigend[-1] == '\n' && bigend[-2] == *little)
1030                 return (char*)bigend - 2;
1031             if (bigend[-1] == *little)
1032                 return (char*)bigend - 1;
1033             return Nullch;
1034         }
1035         {
1036             /* This should be better than FBM if c1 == c2, and almost
1037                as good otherwise: maybe better since we do less indirection.
1038                And we save a lot of memory by caching no table. */
1039             register unsigned char c1 = little[0];
1040             register unsigned char c2 = little[1];
1041
1042             s = big + 1;
1043             bigend--;
1044             if (c1 != c2) {
1045                 while (s <= bigend) {
1046                     if (s[0] == c2) {
1047                         if (s[-1] == c1)
1048                             return (char*)s - 1;
1049                         s += 2;
1050                         continue;
1051                     }
1052                   next_chars:
1053                     if (s[0] == c1) {
1054                         if (s == bigend)
1055                             goto check_1char_anchor;
1056                         if (s[1] == c2)
1057                             return (char*)s;
1058                         else {
1059                             s++;
1060                             goto next_chars;
1061                         }
1062                     }
1063                     else
1064                         s += 2;
1065                 }
1066                 goto check_1char_anchor;
1067             }
1068             /* Now c1 == c2 */
1069             while (s <= bigend) {
1070                 if (s[0] == c1) {
1071                     if (s[-1] == c1)
1072                         return (char*)s - 1;
1073                     if (s == bigend)
1074                         goto check_1char_anchor;
1075                     if (s[1] == c1)
1076                         return (char*)s;
1077                     s += 3;
1078                 }
1079                 else
1080                     s += 2;
1081             }
1082         }
1083       check_1char_anchor:               /* One char and anchor! */
1084         if (SvTAIL(littlestr) && (*bigend == *little))
1085             return (char *)bigend;      /* bigend is already decremented. */
1086         return Nullch;
1087     }
1088     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
1089         s = bigend - littlelen;
1090         if (s >= big
1091             && bigend[-1] == '\n'
1092             && *s == *little
1093             /* Automatically of length > 2 */
1094             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
1095             return (char*)s;            /* how sweet it is */
1096         if (s[1] == *little && memEQ((char*)s + 2,(char*)little + 1,
1097                                      littlelen - 2))
1098             return (char*)s + 1;        /* how sweet it is */
1099         return Nullch;
1100     }
1101     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
1102         char *b = ninstr((char*)big,(char*)bigend,
1103                          (char*)little, (char*)little + littlelen);
1104
1105         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
1106             /* Chop \n from littlestr: */
1107             s = bigend - littlelen + 1;
1108             if (*s == *little && memEQ((char*)s + 1, (char*)little + 1,
1109                                        littlelen - 2))
1110                 return (char*)s;
1111             return Nullch;
1112         }
1113         return b;
1114     }
1115
1116     {   /* Do actual FBM.  */
1117         register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
1118         register unsigned char *oldlittle;
1119
1120         if (littlelen > bigend - big)
1121             return Nullch;
1122         --littlelen;                    /* Last char found by table lookup */
1123
1124         s = big + littlelen;
1125         little += littlelen;            /* last char */
1126         oldlittle = little;
1127         if (s < bigend) {
1128             register I32 tmp;
1129
1130           top2:
1131             /*SUPPRESS 560*/
1132             if (tmp = table[*s]) {
1133 #ifdef POINTERRIGOR
1134                 if (bigend - s > tmp) {
1135                     s += tmp;
1136                     goto top2;
1137                 }
1138                 s += tmp;
1139 #else
1140                 if ((s += tmp) < bigend)
1141                     goto top2;
1142 #endif
1143                 goto check_end;
1144             }
1145             else {              /* less expensive than calling strncmp() */
1146                 register unsigned char *olds = s;
1147
1148                 tmp = littlelen;
1149
1150                 while (tmp--) {
1151                     if (*--s == *--little)
1152                         continue;
1153                   differ:
1154                     s = olds + 1;       /* here we pay the price for failure */
1155                     little = oldlittle;
1156                     if (s < bigend)     /* fake up continue to outer loop */
1157                         goto top2;
1158                     goto check_end;
1159                 }
1160                 return (char *)s;
1161             }
1162         }
1163       check_end:
1164         if ( s == bigend && (table[-1] & FBMcf_TAIL)
1165              && memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) )
1166             return (char*)bigend - littlelen;
1167         return Nullch;
1168     }
1169 }
1170
1171 /* start_shift, end_shift are positive quantities which give offsets
1172    of ends of some substring of bigstr.
1173    If `last' we want the last occurence.
1174    old_posp is the way of communication between consequent calls if
1175    the next call needs to find the .
1176    The initial *old_posp should be -1.
1177
1178    Note that we take into account SvTAIL, so one can get extra
1179    optimizations if _ALL flag is set.
1180  */
1181
1182 /* If SvTAIL is actually due to \Z or \z, this gives false positives
1183    if PL_multiline.  In fact if !PL_multiline the autoritative answer
1184    is not supported yet. */
1185
1186 char *
1187 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
1188 {
1189     dTHR;
1190     register unsigned char *s, *x;
1191     register unsigned char *big;
1192     register I32 pos;
1193     register I32 previous;
1194     register I32 first;
1195     register unsigned char *little;
1196     register I32 stop_pos;
1197     register unsigned char *littleend;
1198     I32 found = 0;
1199
1200     if (*old_posp == -1
1201         ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
1202         : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
1203       cant_find:
1204         if ( BmRARE(littlestr) == '\n'
1205              && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
1206             little = (unsigned char *)(SvPVX(littlestr));
1207             littleend = little + SvCUR(littlestr);
1208             first = *little++;
1209             goto check_tail;
1210         }
1211         return Nullch;
1212     }
1213
1214     little = (unsigned char *)(SvPVX(littlestr));
1215     littleend = little + SvCUR(littlestr);
1216     first = *little++;
1217     /* The value of pos we can start at: */
1218     previous = BmPREVIOUS(littlestr);
1219     big = (unsigned char *)(SvPVX(bigstr));
1220     /* The value of pos we can stop at: */
1221     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
1222     if (previous + start_shift > stop_pos) {
1223         if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
1224             goto check_tail;
1225         return Nullch;
1226     }
1227     while (pos < previous + start_shift) {
1228         if (!(pos += PL_screamnext[pos]))
1229             goto cant_find;
1230     }
1231 #ifdef POINTERRIGOR
1232     do {
1233         if (pos >= stop_pos) break;
1234         if (big[pos-previous] != first)
1235             continue;
1236         for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
1237             if (*s++ != *x++) {
1238                 s--;
1239                 break;
1240             }
1241         }
1242         if (s == littleend) {
1243             *old_posp = pos;
1244             if (!last) return (char *)(big+pos-previous);
1245             found = 1;
1246         }
1247     } while ( pos += PL_screamnext[pos] );
1248     return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
1249 #else /* !POINTERRIGOR */
1250     big -= previous;
1251     do {
1252         if (pos >= stop_pos) break;
1253         if (big[pos] != first)
1254             continue;
1255         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
1256             if (*s++ != *x++) {
1257                 s--;
1258                 break;
1259             }
1260         }
1261         if (s == littleend) {
1262             *old_posp = pos;
1263             if (!last) return (char *)(big+pos);
1264             found = 1;
1265         }
1266     } while ( pos += PL_screamnext[pos] );
1267     if (last && found)
1268         return (char *)(big+(*old_posp));
1269 #endif /* POINTERRIGOR */
1270   check_tail:
1271     if (!SvTAIL(littlestr) || (end_shift > 0))
1272         return Nullch;
1273     /* Ignore the trailing "\n".  This code is not microoptimized */
1274     big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
1275     stop_pos = littleend - little;      /* Actual littlestr len */
1276     if (stop_pos == 0)
1277         return (char*)big;
1278     big -= stop_pos;
1279     if (*big == first
1280         && ((stop_pos == 1) || memEQ(big + 1, little, stop_pos - 1)))
1281         return (char*)big;
1282     return Nullch;
1283 }
1284
1285 I32
1286 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
1287 {
1288     register U8 *a = (U8 *)s1;
1289     register U8 *b = (U8 *)s2;
1290     while (len--) {
1291         if (*a != *b && *a != PL_fold[*b])
1292             return 1;
1293         a++,b++;
1294     }
1295     return 0;
1296 }
1297
1298 I32
1299 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
1300 {
1301     register U8 *a = (U8 *)s1;
1302     register U8 *b = (U8 *)s2;
1303     while (len--) {
1304         if (*a != *b && *a != PL_fold_locale[*b])
1305             return 1;
1306         a++,b++;
1307     }
1308     return 0;
1309 }
1310
1311 /* copy a string to a safe spot */
1312
1313 char *
1314 Perl_savepv(pTHX_ const char *sv)
1315 {
1316     register char *newaddr;
1317
1318     New(902,newaddr,strlen(sv)+1,char);
1319     (void)strcpy(newaddr,sv);
1320     return newaddr;
1321 }
1322
1323 /* same thing but with a known length */
1324
1325 char *
1326 Perl_savepvn(pTHX_ const char *sv, register I32 len)
1327 {
1328     register char *newaddr;
1329
1330     New(903,newaddr,len+1,char);
1331     Copy(sv,newaddr,len,char);          /* might not be null terminated */
1332     newaddr[len] = '\0';                /* is now */
1333     return newaddr;
1334 }
1335
1336 /* the SV for Perl_form() and mess() is not kept in an arena */
1337
1338 STATIC SV *
1339 S_mess_alloc(pTHX)
1340 {
1341     dTHR;
1342     SV *sv;
1343     XPVMG *any;
1344
1345     if (!PL_dirty)
1346         return sv_2mortal(newSVpvn("",0));
1347
1348     if (PL_mess_sv)
1349         return PL_mess_sv;
1350
1351     /* Create as PVMG now, to avoid any upgrading later */
1352     New(905, sv, 1, SV);
1353     Newz(905, any, 1, XPVMG);
1354     SvFLAGS(sv) = SVt_PVMG;
1355     SvANY(sv) = (void*)any;
1356     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1357     PL_mess_sv = sv;
1358     return sv;
1359 }
1360
1361 #ifdef PERL_IMPLICIT_CONTEXT
1362 char *
1363 Perl_form_nocontext(const char* pat, ...)
1364 {
1365     dTHX;
1366     SV *sv = mess_alloc();
1367     va_list args;
1368     va_start(args, pat);
1369     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
1370     va_end(args);
1371     return SvPVX(sv);
1372 }
1373 #endif
1374
1375 char *
1376 Perl_form(pTHX_ const char* pat, ...)
1377 {
1378     SV *sv = mess_alloc();
1379     va_list args;
1380     va_start(args, pat);
1381     sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
1382     va_end(args);
1383     return SvPVX(sv);
1384 }
1385
1386 SV *
1387 Perl_mess(pTHX_ const char *pat, va_list *args)
1388 {
1389     SV *sv = mess_alloc();
1390     static char dgd[] = " during global destruction.\n";
1391
1392     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1393     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1394         dTHR;
1395         if (PL_curcop->cop_line)
1396             Perl_sv_catpvf(aTHX_ sv, " at %_ line %ld",
1397                       GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
1398         if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1399             bool line_mode = (RsSIMPLE(PL_rs) &&
1400                               SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1401             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %ld",
1402                       PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
1403                       line_mode ? "line" : "chunk",
1404                       (long)IoLINES(GvIOp(PL_last_in_gv)));
1405         }
1406         sv_catpv(sv, PL_dirty ? dgd : ".\n");
1407     }
1408     return sv;
1409 }
1410
1411 STATIC OP *
1412 S_do_die(pTHX_ const char* pat, va_list *args)
1413 {
1414     dTHR;
1415     char *message;
1416     int was_in_eval = PL_in_eval;
1417     HV *stash;
1418     GV *gv;
1419     CV *cv;
1420     SV *msv;
1421     STRLEN msglen;
1422
1423     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
1424                           "%p: die: curstack = %p, mainstack = %p\n",
1425                           thr, PL_curstack, PL_mainstack));
1426
1427     if (pat) {
1428         msv = mess(pat, args);
1429         message = SvPV(msv,msglen);
1430     }
1431     else {
1432         message = Nullch;
1433     }
1434
1435     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
1436                           "%p: die: message = %s\ndiehook = %p\n",
1437                           thr, message, PL_diehook));
1438     if (PL_diehook) {
1439         /* sv_2cv might call Perl_croak() */
1440         SV *olddiehook = PL_diehook;
1441         ENTER;
1442         SAVESPTR(PL_diehook);
1443         PL_diehook = Nullsv;
1444         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1445         LEAVE;
1446         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1447             dSP;
1448             SV *msg;
1449
1450             ENTER;
1451             if (message) {
1452                 msg = newSVpvn(message, msglen);
1453                 SvREADONLY_on(msg);
1454                 SAVEFREESV(msg);
1455             }
1456             else {
1457                 msg = ERRSV;
1458             }
1459
1460             PUSHSTACKi(PERLSI_DIEHOOK);
1461             PUSHMARK(SP);
1462             XPUSHs(msg);
1463             PUTBACK;
1464             call_sv((SV*)cv, G_DISCARD);
1465             POPSTACK;
1466             LEAVE;
1467         }
1468     }
1469
1470     PL_restartop = die_where(message, msglen);
1471     DEBUG_S(PerlIO_printf(PerlIO_stderr(),
1472           "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1473           thr, PL_restartop, was_in_eval, PL_top_env));
1474     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1475         JMPENV_JUMP(3);
1476     return PL_restartop;
1477 }
1478
1479 #ifdef PERL_IMPLICIT_CONTEXT
1480 OP *
1481 Perl_die_nocontext(const char* pat, ...)
1482 {
1483     dTHX;
1484     OP *o;
1485     va_list args;
1486     va_start(args, pat);
1487     o = do_die(aTHX_ pat, &args);
1488     va_end(args);
1489     return o;
1490 }
1491 #endif
1492
1493 OP *
1494 Perl_die(pTHX_ const char* pat, ...)
1495 {
1496     OP *o;
1497     va_list args;
1498     va_start(args, pat);
1499     o = do_die(aTHX_ pat, &args);
1500     va_end(args);
1501     return o;
1502 }
1503
1504 STATIC void
1505 S_do_croak(pTHX_ const char* pat, va_list *args)
1506 {
1507     dTHR;
1508     char *message;
1509     HV *stash;
1510     GV *gv;
1511     CV *cv;
1512     SV *msv;
1513     STRLEN msglen;
1514
1515     msv = mess(pat, args);
1516     message = SvPV(msv,msglen);
1517     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
1518     if (PL_diehook) {
1519         /* sv_2cv might call Perl_croak() */
1520         SV *olddiehook = PL_diehook;
1521         ENTER;
1522         SAVESPTR(PL_diehook);
1523         PL_diehook = Nullsv;
1524         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1525         LEAVE;
1526         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1527             dSP;
1528             SV *msg;
1529
1530             ENTER;
1531             msg = newSVpvn(message, msglen);
1532             SvREADONLY_on(msg);
1533             SAVEFREESV(msg);
1534
1535             PUSHSTACKi(PERLSI_DIEHOOK);
1536             PUSHMARK(SP);
1537             XPUSHs(msg);
1538             PUTBACK;
1539             call_sv((SV*)cv, G_DISCARD);
1540             POPSTACK;
1541             LEAVE;
1542         }
1543     }
1544     if (PL_in_eval) {
1545         PL_restartop = die_where(message, msglen);
1546         JMPENV_JUMP(3);
1547     }
1548     {
1549 #ifdef USE_SFIO
1550         /* SFIO can really mess with your errno */
1551         int e = errno;
1552 #endif
1553         PerlIO_write(PerlIO_stderr(), message, msglen);
1554         (void)PerlIO_flush(PerlIO_stderr());
1555 #ifdef USE_SFIO
1556         errno = e;
1557 #endif
1558     }
1559     my_failure_exit();
1560 }
1561
1562 #ifdef PERL_IMPLICIT_CONTEXT
1563 void
1564 Perl_croak_nocontext(const char *pat, ...)
1565 {
1566     dTHX;
1567     va_list args;
1568     va_start(args, pat);
1569     do_croak(pat, &args);
1570     /* NOTREACHED */
1571     va_end(args);
1572 }
1573 #endif /* PERL_IMPLICIT_CONTEXT */
1574
1575 void
1576 Perl_croak(pTHX_ const char *pat, ...)
1577 {
1578     va_list args;
1579     va_start(args, pat);
1580     do_croak(pat, &args);
1581     /* NOTREACHED */
1582     va_end(args);
1583 }
1584
1585 STATIC void
1586 S_do_warn(pTHX_ const char* pat, va_list *args)
1587 {
1588     char *message;
1589     HV *stash;
1590     GV *gv;
1591     CV *cv;
1592     SV *msv;
1593     STRLEN msglen;
1594
1595     msv = mess(pat, args);
1596     message = SvPV(msv, msglen);
1597
1598     if (PL_warnhook) {
1599         /* sv_2cv might call Perl_warn() */
1600         dTHR;
1601         SV *oldwarnhook = PL_warnhook;
1602         ENTER;
1603         SAVESPTR(PL_warnhook);
1604         PL_warnhook = Nullsv;
1605         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1606         LEAVE;
1607         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1608             dSP;
1609             SV *msg;
1610
1611             ENTER;
1612             msg = newSVpvn(message, msglen);
1613             SvREADONLY_on(msg);
1614             SAVEFREESV(msg);
1615
1616             PUSHSTACKi(PERLSI_WARNHOOK);
1617             PUSHMARK(SP);
1618             XPUSHs(msg);
1619             PUTBACK;
1620             call_sv((SV*)cv, G_DISCARD);
1621             POPSTACK;
1622             LEAVE;
1623             return;
1624         }
1625     }
1626     PerlIO_write(PerlIO_stderr(), message, msglen);
1627 #ifdef LEAKTEST
1628     DEBUG_L(*message == '!'
1629             ? (xstat(message[1]=='!'
1630                      ? (message[2]=='!' ? 2 : 1)
1631                      : 0)
1632                , 0)
1633             : 0);
1634 #endif
1635     (void)PerlIO_flush(PerlIO_stderr());
1636 }
1637
1638 #ifdef PERL_IMPLICIT_CONTEXT
1639 void
1640 Perl_warn_nocontext(const char *pat, ...)
1641 {
1642     dTHX;
1643     va_list args;
1644     va_start(args, pat);
1645     do_warn(pat, &args);
1646     va_end(args);
1647 }
1648 #endif /* PERL_IMPLICIT_CONTEXT */
1649
1650 void
1651 Perl_warn(pTHX_ const char *pat, ...)
1652 {
1653     va_list args;
1654     va_start(args, pat);
1655     do_warn(pat, &args);
1656     va_end(args);
1657 }
1658
1659 void
1660 Perl_warner(pTHX_ U32  err, const char* pat,...)
1661 {
1662     dTHR;
1663     va_list args;
1664     char *message;
1665     HV *stash;
1666     GV *gv;
1667     CV *cv;
1668     SV *msv;
1669     STRLEN msglen;
1670
1671     va_start(args, pat);
1672     msv = mess(pat, &args);
1673     message = SvPV(msv, msglen);
1674     va_end(args);
1675
1676     if (ckDEAD(err)) {
1677 #ifdef USE_THREADS
1678         DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
1679 #endif /* USE_THREADS */
1680         if (PL_diehook) {
1681             /* sv_2cv might call Perl_croak() */
1682             SV *olddiehook = PL_diehook;
1683             ENTER;
1684             SAVESPTR(PL_diehook);
1685             PL_diehook = Nullsv;
1686             cv = sv_2cv(olddiehook, &stash, &gv, 0);
1687             LEAVE;
1688             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1689                 dSP;
1690                 SV *msg;
1691
1692                 ENTER;
1693                 msg = newSVpvn(message, msglen);
1694                 SvREADONLY_on(msg);
1695                 SAVEFREESV(msg);
1696
1697                 PUSHMARK(sp);
1698                 XPUSHs(msg);
1699                 PUTBACK;
1700                 call_sv((SV*)cv, G_DISCARD);
1701
1702                 LEAVE;
1703             }
1704         }
1705         if (PL_in_eval) {
1706             PL_restartop = die_where(message, msglen);
1707             JMPENV_JUMP(3);
1708         }
1709         PerlIO_write(PerlIO_stderr(), message, msglen);
1710         (void)PerlIO_flush(PerlIO_stderr());
1711         my_failure_exit();
1712
1713     }
1714     else {
1715         if (PL_warnhook) {
1716             /* sv_2cv might call Perl_warn() */
1717             dTHR;
1718             SV *oldwarnhook = PL_warnhook;
1719             ENTER;
1720             SAVESPTR(PL_warnhook);
1721             PL_warnhook = Nullsv;
1722             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1723                 LEAVE;
1724             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1725                 dSP;
1726                 SV *msg;
1727
1728                 ENTER;
1729                 msg = newSVpvn(message, msglen);
1730                 SvREADONLY_on(msg);
1731                 SAVEFREESV(msg);
1732
1733                 PUSHMARK(sp);
1734                 XPUSHs(msg);
1735                 PUTBACK;
1736                 call_sv((SV*)cv, G_DISCARD);
1737
1738                 LEAVE;
1739                 return;
1740             }
1741         }
1742         PerlIO_write(PerlIO_stderr(), message, msglen);
1743 #ifdef LEAKTEST
1744         DEBUG_L(xstat());
1745 #endif
1746         (void)PerlIO_flush(PerlIO_stderr());
1747     }
1748 }
1749
1750 #ifndef VMS  /* VMS' my_setenv() is in VMS.c */
1751 #if !defined(WIN32) && !defined(CYGWIN32)
1752 void
1753 Perl_my_setenv(pTHX_ char *nam, char *val)
1754 {
1755 #ifndef PERL_USE_SAFE_PUTENV
1756     /* most putenv()s leak, so we manipulate environ directly */
1757     register I32 i=setenv_getix(nam);           /* where does it go? */
1758
1759     if (environ == PL_origenviron) {    /* need we copy environment? */
1760         I32 j;
1761         I32 max;
1762         char **tmpenv;
1763
1764         /*SUPPRESS 530*/
1765         for (max = i; environ[max]; max++) ;
1766         tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1767         for (j=0; j<max; j++) {         /* copy environment */
1768             tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
1769             strcpy(tmpenv[j], environ[j]);
1770         }
1771         tmpenv[max] = Nullch;
1772         environ = tmpenv;               /* tell exec where it is now */
1773     }
1774     if (!val) {
1775         safesysfree(environ[i]);
1776         while (environ[i]) {
1777             environ[i] = environ[i+1];
1778             i++;
1779         }
1780         return;
1781     }
1782     if (!environ[i]) {                  /* does not exist yet */
1783         environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1784         environ[i+1] = Nullch;  /* make sure it's null terminated */
1785     }
1786     else
1787         safesysfree(environ[i]);
1788     environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
1789
1790 #ifndef MSDOS
1791     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
1792 #else
1793     /* MS-DOS requires environment variable names to be in uppercase */
1794     /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
1795      * some utilities and applications may break because they only look
1796      * for upper case strings. (Fixed strupr() bug here.)]
1797      */
1798     strcpy(environ[i],nam); strupr(environ[i]);
1799     (void)sprintf(environ[i] + strlen(nam),"=%s",val);
1800 #endif /* MSDOS */
1801
1802 #else   /* PERL_USE_SAFE_PUTENV */
1803     char *new_env;
1804
1805     new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
1806 #ifndef MSDOS
1807     (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
1808 #else
1809     strcpy(new_env,nam); strupr(new_env);
1810     (void)sprintf(new_env + strlen(nam),"=%s",val);
1811 #endif
1812     (void)putenv(new_env);
1813 #endif  /* PERL_USE_SAFE_PUTENV */
1814 }
1815
1816 #else /* if WIN32 */
1817
1818 void
1819 Perl_my_setenv(pTHX_ char *nam,char *val)
1820 {
1821
1822 #ifdef USE_WIN32_RTL_ENV
1823
1824     register char *envstr;
1825     STRLEN namlen = strlen(nam);
1826     STRLEN vallen;
1827     char *oldstr = environ[setenv_getix(nam)];
1828
1829     /* putenv() has totally broken semantics in both the Borland
1830      * and Microsoft CRTLs.  They either store the passed pointer in
1831      * the environment without making a copy, or make a copy and don't
1832      * free it. And on top of that, they dont free() old entries that
1833      * are being replaced/deleted.  This means the caller must
1834      * free any old entries somehow, or we end up with a memory
1835      * leak every time my_setenv() is called.  One might think
1836      * one could directly manipulate environ[], like the UNIX code
1837      * above, but direct changes to environ are not allowed when
1838      * calling putenv(), since the RTLs maintain an internal
1839      * *copy* of environ[]. Bad, bad, *bad* stink.
1840      * GSAR 97-06-07
1841      */
1842
1843     if (!val) {
1844         if (!oldstr)
1845             return;
1846         val = "";
1847         vallen = 0;
1848     }
1849     else
1850         vallen = strlen(val);
1851     envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char));
1852     (void)sprintf(envstr,"%s=%s",nam,val);
1853     (void)PerlEnv_putenv(envstr);
1854     if (oldstr)
1855         safesysfree(oldstr);
1856 #ifdef _MSC_VER
1857     safesysfree(envstr);        /* MSVCRT leaks without this */
1858 #endif
1859
1860 #else /* !USE_WIN32_RTL_ENV */
1861
1862     register char *envstr;
1863     STRLEN len = strlen(nam) + 3;
1864     if (!val) {
1865         val = "";
1866     }
1867     len += strlen(val);
1868     New(904, envstr, len, char);
1869     (void)sprintf(envstr,"%s=%s",nam,val);
1870     (void)PerlEnv_putenv(envstr);
1871     Safefree(envstr);
1872
1873 #endif
1874 }
1875
1876 #endif /* WIN32 */
1877
1878 I32
1879 Perl_setenv_getix(pTHX_ char *nam)
1880 {
1881     register I32 i, len = strlen(nam);
1882
1883     for (i = 0; environ[i]; i++) {
1884         if (
1885 #ifdef WIN32
1886             strnicmp(environ[i],nam,len) == 0
1887 #else
1888             strnEQ(environ[i],nam,len)
1889 #endif
1890             && environ[i][len] == '=')
1891             break;                      /* strnEQ must come first to avoid */
1892     }                                   /* potential SEGV's */
1893     return i;
1894 }
1895
1896 #endif /* !VMS */
1897
1898 #ifdef UNLINK_ALL_VERSIONS
1899 I32
1900 Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1901 {
1902     I32 i;
1903
1904     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1905     return i ? 0 : -1;
1906 }
1907 #endif
1908
1909 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
1910 char *
1911 Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len)
1912 {
1913     char *retval = to;
1914
1915     if (from - to >= 0) {
1916         while (len--)
1917             *to++ = *from++;
1918     }
1919     else {
1920         to += len;
1921         from += len;
1922         while (len--)
1923             *(--to) = *(--from);
1924     }
1925     return retval;
1926 }
1927 #endif
1928
1929 #ifndef HAS_MEMSET
1930 void *
1931 Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len)
1932 {
1933     char *retval = loc;
1934
1935     while (len--)
1936         *loc++ = ch;
1937     return retval;
1938 }
1939 #endif
1940
1941 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1942 char *
1943 Perl_my_bzero(pTHX_ register char *loc, register I32 len)
1944 {
1945     char *retval = loc;
1946
1947     while (len--)
1948         *loc++ = 0;
1949     return retval;
1950 }
1951 #endif
1952
1953 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1954 I32
1955 Perl_my_memcmp(pTHX_ const char *s1, const char *s2, register I32 len)
1956 {
1957     register U8 *a = (U8 *)s1;
1958     register U8 *b = (U8 *)s2;
1959     register I32 tmp;
1960
1961     while (len--) {
1962         if (tmp = *a++ - *b++)
1963             return tmp;
1964     }
1965     return 0;
1966 }
1967 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1968
1969 #ifndef HAS_VPRINTF
1970
1971 #ifdef USE_CHAR_VSPRINTF
1972 char *
1973 #else
1974 int
1975 #endif
1976 vsprintf(char *dest, const char *pat, char *args)
1977 {
1978     FILE fakebuf;
1979
1980     fakebuf._ptr = dest;
1981     fakebuf._cnt = 32767;
1982 #ifndef _IOSTRG
1983 #define _IOSTRG 0
1984 #endif
1985     fakebuf._flag = _IOWRT|_IOSTRG;
1986     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1987     (void)putc('\0', &fakebuf);
1988 #ifdef USE_CHAR_VSPRINTF
1989     return(dest);
1990 #else
1991     return 0;           /* perl doesn't use return value */
1992 #endif
1993 }
1994
1995 #endif /* HAS_VPRINTF */
1996
1997 #ifdef MYSWAP
1998 #if BYTEORDER != 0x4321
1999 short
2000 Perl_my_swap(pTHX_ short s)
2001 {
2002 #if (BYTEORDER & 1) == 0
2003     short result;
2004
2005     result = ((s & 255) << 8) + ((s >> 8) & 255);
2006     return result;
2007 #else
2008     return s;
2009 #endif
2010 }
2011
2012 long
2013 Perl_my_htonl(pTHX_ long l)
2014 {
2015     union {
2016         long result;
2017         char c[sizeof(long)];
2018     } u;
2019
2020 #if BYTEORDER == 0x1234
2021     u.c[0] = (l >> 24) & 255;
2022     u.c[1] = (l >> 16) & 255;
2023     u.c[2] = (l >> 8) & 255;
2024     u.c[3] = l & 255;
2025     return u.result;
2026 #else
2027 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2028     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2029 #else
2030     register I32 o;
2031     register I32 s;
2032
2033     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2034         u.c[o & 0xf] = (l >> s) & 255;
2035     }
2036     return u.result;
2037 #endif
2038 #endif
2039 }
2040
2041 long
2042 Perl_my_ntohl(pTHX_ long l)
2043 {
2044     union {
2045         long l;
2046         char c[sizeof(long)];
2047     } u;
2048
2049 #if BYTEORDER == 0x1234
2050     u.c[0] = (l >> 24) & 255;
2051     u.c[1] = (l >> 16) & 255;
2052     u.c[2] = (l >> 8) & 255;
2053     u.c[3] = l & 255;
2054     return u.l;
2055 #else
2056 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2057     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2058 #else
2059     register I32 o;
2060     register I32 s;
2061
2062     u.l = l;
2063     l = 0;
2064     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2065         l |= (u.c[o & 0xf] & 255) << s;
2066     }
2067     return l;
2068 #endif
2069 #endif
2070 }
2071
2072 #endif /* BYTEORDER != 0x4321 */
2073 #endif /* MYSWAP */
2074
2075 /*
2076  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2077  * If these functions are defined,
2078  * the BYTEORDER is neither 0x1234 nor 0x4321.
2079  * However, this is not assumed.
2080  * -DWS
2081  */
2082
2083 #define HTOV(name,type)                                         \
2084         type                                                    \
2085         name (register type n)                                  \
2086         {                                                       \
2087             union {                                             \
2088                 type value;                                     \
2089                 char c[sizeof(type)];                           \
2090             } u;                                                \
2091             register I32 i;                                     \
2092             register I32 s;                                     \
2093             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
2094                 u.c[i] = (n >> s) & 0xFF;                       \
2095             }                                                   \
2096             return u.value;                                     \
2097         }
2098
2099 #define VTOH(name,type)                                         \
2100         type                                                    \
2101         name (register type n)                                  \
2102         {                                                       \
2103             union {                                             \
2104                 type value;                                     \
2105                 char c[sizeof(type)];                           \
2106             } u;                                                \
2107             register I32 i;                                     \
2108             register I32 s;                                     \
2109             u.value = n;                                        \
2110             n = 0;                                              \
2111             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
2112                 n += (u.c[i] & 0xFF) << s;                      \
2113             }                                                   \
2114             return n;                                           \
2115         }
2116
2117 #if defined(HAS_HTOVS) && !defined(htovs)
2118 HTOV(htovs,short)
2119 #endif
2120 #if defined(HAS_HTOVL) && !defined(htovl)
2121 HTOV(htovl,long)
2122 #endif
2123 #if defined(HAS_VTOHS) && !defined(vtohs)
2124 VTOH(vtohs,short)
2125 #endif
2126 #if defined(HAS_VTOHL) && !defined(vtohl)
2127 VTOH(vtohl,long)
2128 #endif
2129
2130     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2131 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC)
2132 PerlIO *
2133 Perl_my_popen(pTHX_ char *cmd, char *mode)
2134 {
2135     int p[2];
2136     register I32 This, that;
2137     register I32 pid;
2138     SV *sv;
2139     I32 doexec = strNE(cmd,"-");
2140     I32 did_pipes = 0;
2141     int pp[2];
2142
2143     PERL_FLUSHALL_FOR_CHILD;
2144 #ifdef OS2
2145     if (doexec) {
2146         return my_syspopen(cmd,mode);
2147     }
2148 #endif
2149     This = (*mode == 'w');
2150     that = !This;
2151     if (doexec && PL_tainting) {
2152         taint_env();
2153         taint_proper("Insecure %s%s", "EXEC");
2154     }
2155     if (PerlProc_pipe(p) < 0)
2156         return Nullfp;
2157     if (doexec && PerlProc_pipe(pp) >= 0)
2158         did_pipes = 1;
2159     while ((pid = (doexec?vfork():fork())) < 0) {
2160         if (errno != EAGAIN) {
2161             PerlLIO_close(p[This]);
2162             if (did_pipes) {
2163                 PerlLIO_close(pp[0]);
2164                 PerlLIO_close(pp[1]);
2165             }
2166             if (!doexec)
2167                 Perl_croak(aTHX_ "Can't fork");
2168             return Nullfp;
2169         }
2170         sleep(5);
2171     }
2172     if (pid == 0) {
2173         GV* tmpgv;
2174
2175 #undef THIS
2176 #undef THAT
2177 #define THIS that
2178 #define THAT This
2179         PerlLIO_close(p[THAT]);
2180         if (did_pipes) {
2181             PerlLIO_close(pp[0]);
2182 #if defined(HAS_FCNTL) && defined(F_SETFD)
2183             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2184 #endif
2185         }
2186         if (p[THIS] != (*mode == 'r')) {
2187             PerlLIO_dup2(p[THIS], *mode == 'r');
2188             PerlLIO_close(p[THIS]);
2189         }
2190 #ifndef OS2
2191         if (doexec) {
2192 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2193             int fd;
2194
2195 #ifndef NOFILE
2196 #define NOFILE 20
2197 #endif
2198             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2199                 if (fd != pp[1])
2200                     PerlLIO_close(fd);
2201 #endif
2202             do_exec3(cmd,pp[1],did_pipes);      /* may or may not use the shell */
2203             PerlProc__exit(1);
2204         }
2205 #endif  /* defined OS2 */
2206         /*SUPPRESS 560*/
2207         if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2208             sv_setiv(GvSV(tmpgv), (IV)getpid());
2209         PL_forkprocess = 0;
2210         hv_clear(PL_pidstatus); /* we have no children */
2211         return Nullfp;
2212 #undef THIS
2213 #undef THAT
2214     }
2215     do_execfree();      /* free any memory malloced by child on vfork */
2216     PerlLIO_close(p[that]);
2217     if (did_pipes)
2218         PerlLIO_close(pp[1]);
2219     if (p[that] < p[This]) {
2220         PerlLIO_dup2(p[This], p[that]);
2221         PerlLIO_close(p[This]);
2222         p[This] = p[that];
2223     }
2224     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2225     (void)SvUPGRADE(sv,SVt_IV);
2226     SvIVX(sv) = pid;
2227     PL_forkprocess = pid;
2228     if (did_pipes && pid > 0) {
2229         int errkid;
2230         int n = 0, n1;
2231
2232         while (n < sizeof(int)) {
2233             n1 = PerlLIO_read(pp[0],
2234                               (void*)(((char*)&errkid)+n),
2235                               (sizeof(int)) - n);
2236             if (n1 <= 0)
2237                 break;
2238             n += n1;
2239         }
2240         if (n) {                        /* Error */
2241             if (n != sizeof(int))
2242                 Perl_croak(aTHX_ "panic: kid popen errno read");
2243             PerlLIO_close(pp[0]);
2244             errno = errkid;             /* Propagate errno from kid */
2245             return Nullfp;
2246         }
2247     }
2248     if (did_pipes)
2249          PerlLIO_close(pp[0]);
2250     return PerlIO_fdopen(p[This], mode);
2251 }
2252 #else
2253 #if defined(atarist) || defined(DJGPP)
2254 FILE *popen();
2255 PerlIO *
2256 Perl_my_popen(pTHX_ char *cmd, char *mode)
2257 {
2258     /* Needs work for PerlIO ! */
2259     /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
2260     PERL_FLUSHALL_FOR_CHILD;
2261     return popen(PerlIO_exportFILE(cmd, 0), mode);
2262 }
2263 #endif
2264
2265 #endif /* !DOSISH */
2266
2267 #ifdef DUMP_FDS
2268 void
2269 Perl_dump_fds(pTHX_ char *s)
2270 {
2271     int fd;
2272     struct stat tmpstatbuf;
2273
2274     PerlIO_printf(PerlIO_stderr(),"%s", s);
2275     for (fd = 0; fd < 32; fd++) {
2276         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2277             PerlIO_printf(PerlIO_stderr()," %d",fd);
2278     }
2279     PerlIO_printf(PerlIO_stderr(),"\n");
2280 }
2281 #endif  /* DUMP_FDS */
2282
2283 #ifndef HAS_DUP2
2284 int
2285 dup2(int oldfd, int newfd)
2286 {
2287 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2288     if (oldfd == newfd)
2289         return oldfd;
2290     PerlLIO_close(newfd);
2291     return fcntl(oldfd, F_DUPFD, newfd);
2292 #else
2293 #define DUP2_MAX_FDS 256
2294     int fdtmp[DUP2_MAX_FDS];
2295     I32 fdx = 0;
2296     int fd;
2297
2298     if (oldfd == newfd)
2299         return oldfd;
2300     PerlLIO_close(newfd);
2301     /* good enough for low fd's... */
2302     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2303         if (fdx >= DUP2_MAX_FDS) {
2304             PerlLIO_close(fd);
2305             fd = -1;
2306             break;
2307         }
2308         fdtmp[fdx++] = fd;
2309     }
2310     while (fdx > 0)
2311         PerlLIO_close(fdtmp[--fdx]);
2312     return fd;
2313 #endif
2314 }
2315 #endif
2316
2317
2318 #ifdef HAS_SIGACTION
2319
2320 Sighandler_t
2321 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2322 {
2323     struct sigaction act, oact;
2324
2325     act.sa_handler = handler;
2326     sigemptyset(&act.sa_mask);
2327     act.sa_flags = 0;
2328 #ifdef SA_RESTART
2329     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2330 #endif
2331 #ifdef SA_NOCLDWAIT
2332     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2333         act.sa_flags |= SA_NOCLDWAIT;
2334 #endif
2335     if (sigaction(signo, &act, &oact) == -1)
2336         return SIG_ERR;
2337     else
2338         return oact.sa_handler;
2339 }
2340
2341 Sighandler_t
2342 Perl_rsignal_state(pTHX_ int signo)
2343 {
2344     struct sigaction oact;
2345
2346     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2347         return SIG_ERR;
2348     else
2349         return oact.sa_handler;
2350 }
2351
2352 int
2353 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2354 {
2355     struct sigaction act;
2356
2357     act.sa_handler = handler;
2358     sigemptyset(&act.sa_mask);
2359     act.sa_flags = 0;
2360 #ifdef SA_RESTART
2361     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2362 #endif
2363 #ifdef SA_NOCLDWAIT
2364     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2365         act.sa_flags |= SA_NOCLDWAIT;
2366 #endif
2367     return sigaction(signo, &act, save);
2368 }
2369
2370 int
2371 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2372 {
2373     return sigaction(signo, save, (struct sigaction *)NULL);
2374 }
2375
2376 #else /* !HAS_SIGACTION */
2377
2378 Sighandler_t
2379 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2380 {
2381     return PerlProc_signal(signo, handler);
2382 }
2383
2384 static int sig_trapped;
2385
2386 static
2387 Signal_t
2388 sig_trap(int signo)
2389 {
2390     sig_trapped++;
2391 }
2392
2393 Sighandler_t
2394 Perl_rsignal_state(pTHX_ int signo)
2395 {
2396     Sighandler_t oldsig;
2397
2398     sig_trapped = 0;
2399     oldsig = PerlProc_signal(signo, sig_trap);
2400     PerlProc_signal(signo, oldsig);
2401     if (sig_trapped)
2402         PerlProc_kill(getpid(), signo);
2403     return oldsig;
2404 }
2405
2406 int
2407 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2408 {
2409     *save = PerlProc_signal(signo, handler);
2410     return (*save == SIG_ERR) ? -1 : 0;
2411 }
2412
2413 int
2414 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2415 {
2416     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2417 }
2418
2419 #endif /* !HAS_SIGACTION */
2420
2421     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2422 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC)
2423 I32
2424 Perl_my_pclose(pTHX_ PerlIO *ptr)
2425 {
2426     Sigsave_t hstat, istat, qstat;
2427     int status;
2428     SV **svp;
2429     int pid;
2430     int pid2;
2431     bool close_failed;
2432     int saved_errno;
2433 #ifdef VMS
2434     int saved_vaxc_errno;
2435 #endif
2436 #ifdef WIN32
2437     int saved_win32_errno;
2438 #endif
2439
2440     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2441     pid = (int)SvIVX(*svp);
2442     SvREFCNT_dec(*svp);
2443     *svp = &PL_sv_undef;
2444 #ifdef OS2
2445     if (pid == -1) {                    /* Opened by popen. */
2446         return my_syspclose(ptr);
2447     }
2448 #endif
2449     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2450         saved_errno = errno;
2451 #ifdef VMS
2452         saved_vaxc_errno = vaxc$errno;
2453 #endif
2454 #ifdef WIN32
2455         saved_win32_errno = GetLastError();
2456 #endif
2457     }
2458 #ifdef UTS
2459     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2460 #endif
2461     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2462     rsignal_save(SIGINT, SIG_IGN, &istat);
2463     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2464     do {
2465         pid2 = wait4pid(pid, &status, 0);
2466     } while (pid2 == -1 && errno == EINTR);
2467     rsignal_restore(SIGHUP, &hstat);
2468     rsignal_restore(SIGINT, &istat);
2469     rsignal_restore(SIGQUIT, &qstat);
2470     if (close_failed) {
2471         SETERRNO(saved_errno, saved_vaxc_errno);
2472         return -1;
2473     }
2474     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2475 }
2476 #endif /* !DOSISH */
2477
2478 #if  !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
2479 I32
2480 Perl_wait4pid(pTHX_ int pid, int *statusp, int flags)
2481 {
2482     SV *sv;
2483     SV** svp;
2484     char spid[TYPE_CHARS(int)];
2485
2486     if (!pid)
2487         return -1;
2488     if (pid > 0) {
2489         sprintf(spid, "%d", pid);
2490         svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2491         if (svp && *svp != &PL_sv_undef) {
2492             *statusp = SvIVX(*svp);
2493             (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2494             return pid;
2495         }
2496     }
2497     else {
2498         HE *entry;
2499
2500         hv_iterinit(PL_pidstatus);
2501         if (entry = hv_iternext(PL_pidstatus)) {
2502             pid = atoi(hv_iterkey(entry,(I32*)statusp));
2503             sv = hv_iterval(PL_pidstatus,entry);
2504             *statusp = SvIVX(sv);
2505             sprintf(spid, "%d", pid);
2506             (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2507             return pid;
2508         }
2509     }
2510 #ifdef HAS_WAITPID
2511 #  ifdef HAS_WAITPID_RUNTIME
2512     if (!HAS_WAITPID_RUNTIME)
2513         goto hard_way;
2514 #  endif
2515     return PerlProc_waitpid(pid,statusp,flags);
2516 #endif
2517 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2518     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2519 #endif
2520 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2521   hard_way:
2522     {
2523         I32 result;
2524         if (flags)
2525             Perl_croak(aTHX_ "Can't do waitpid with flags");
2526         else {
2527             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2528                 pidgone(result,*statusp);
2529             if (result < 0)
2530                 *statusp = -1;
2531         }
2532         return result;
2533     }
2534 #endif
2535 }
2536 #endif /* !DOSISH || OS2 || WIN32 */
2537
2538 void
2539 /*SUPPRESS 590*/
2540 Perl_pidgone(pTHX_ int pid, int status)
2541 {
2542     register SV *sv;
2543     char spid[TYPE_CHARS(int)];
2544
2545     sprintf(spid, "%d", pid);
2546     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2547     (void)SvUPGRADE(sv,SVt_IV);
2548     SvIVX(sv) = status;
2549     return;
2550 }
2551
2552 #if defined(atarist) || defined(OS2) || defined(DJGPP)
2553 int pclose();
2554 #ifdef HAS_FORK
2555 int                                     /* Cannot prototype with I32
2556                                            in os2ish.h. */
2557 my_syspclose(PerlIO *ptr)
2558 #else
2559 I32
2560 Perl_my_pclose(pTHX_ PerlIO *ptr)
2561 #endif
2562 {
2563     /* Needs work for PerlIO ! */
2564     FILE *f = PerlIO_findFILE(ptr);
2565     I32 result = pclose(f);
2566     PerlIO_releaseFILE(ptr,f);
2567     return result;
2568 }
2569 #endif
2570
2571 void
2572 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2573 {
2574     register I32 todo;
2575     register const char *frombase = from;
2576
2577     if (len == 1) {
2578         register const char c = *from;
2579         while (count-- > 0)
2580             *to++ = c;
2581         return;
2582     }
2583     while (count-- > 0) {
2584         for (todo = len; todo > 0; todo--) {
2585             *to++ = *from++;
2586         }
2587         from = frombase;
2588     }
2589 }
2590
2591 U32
2592 Perl_cast_ulong(pTHX_ double f)
2593 {
2594     long along;
2595
2596 #if CASTFLAGS & 2
2597 #   define BIGDOUBLE 2147483648.0
2598     if (f >= BIGDOUBLE)
2599         return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
2600 #endif
2601     if (f >= 0.0)
2602         return (unsigned long)f;
2603     along = (long)f;
2604     return (unsigned long)along;
2605 }
2606 # undef BIGDOUBLE
2607
2608 /* Unfortunately, on some systems the cast_uv() function doesn't
2609    work with the system-supplied definition of ULONG_MAX.  The
2610    comparison  (f >= ULONG_MAX) always comes out true.  It must be a
2611    problem with the compiler constant folding.
2612
2613    In any case, this workaround should be fine on any two's complement
2614    system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
2615    ccflags.
2616                --Andy Dougherty      <doughera@lafcol.lafayette.edu>
2617 */
2618
2619 /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
2620    of LONG_(MIN/MAX).
2621                            -- Kenneth Albanowski <kjahds@kjahds.com>
2622 */
2623
2624 #ifndef MY_UV_MAX
2625 #  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
2626 #endif
2627
2628 I32
2629 Perl_cast_i32(pTHX_ double f)
2630 {
2631     if (f >= I32_MAX)
2632         return (I32) I32_MAX;
2633     if (f <= I32_MIN)
2634         return (I32) I32_MIN;
2635     return (I32) f;
2636 }
2637
2638 IV
2639 Perl_cast_iv(pTHX_ double f)
2640 {
2641     if (f >= IV_MAX) {
2642         UV uv;
2643
2644         if (f >= (double)UV_MAX)
2645             return (IV) UV_MAX;
2646         uv = (UV) f;
2647         return (IV)uv;
2648     }
2649     if (f <= IV_MIN)
2650         return (IV) IV_MIN;
2651     return (IV) f;
2652 }
2653
2654 UV
2655 Perl_cast_uv(pTHX_ double f)
2656 {
2657     if (f >= MY_UV_MAX)
2658         return (UV) MY_UV_MAX;
2659     if (f < 0) {
2660         IV iv;
2661
2662         if (f < IV_MIN)
2663             return (UV)IV_MIN;
2664         iv = (IV) f;
2665         return (UV) iv;
2666     }
2667     return (UV) f;
2668 }
2669
2670 #ifndef HAS_RENAME
2671 I32
2672 Perl_same_dirent(pTHX_ char *a, char *b)
2673 {
2674     char *fa = strrchr(a,'/');
2675     char *fb = strrchr(b,'/');
2676     struct stat tmpstatbuf1;
2677     struct stat tmpstatbuf2;
2678     SV *tmpsv = sv_newmortal();
2679
2680     if (fa)
2681         fa++;
2682     else
2683         fa = a;
2684     if (fb)
2685         fb++;
2686     else
2687         fb = b;
2688     if (strNE(a,b))
2689         return FALSE;
2690     if (fa == a)
2691         sv_setpv(tmpsv, ".");
2692     else
2693         sv_setpvn(tmpsv, a, fa - a);
2694     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2695         return FALSE;
2696     if (fb == b)
2697         sv_setpv(tmpsv, ".");
2698     else
2699         sv_setpvn(tmpsv, b, fb - b);
2700     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2701         return FALSE;
2702     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2703            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2704 }
2705 #endif /* !HAS_RENAME */
2706
2707 UV
2708 Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
2709 {
2710     register char *s = start;
2711     register UV retval = 0;
2712     bool overflowed = FALSE;
2713     while (len && *s >= '0' && *s <= '1') {
2714       register UV n = retval << 1;
2715       if (!overflowed && (n >> 1) != retval) {
2716           Perl_warn(aTHX_ "Integer overflow in binary number");
2717           overflowed = TRUE;
2718       }
2719       retval = n | (*s++ - '0');
2720       len--;
2721     }
2722     if (len && (*s >= '2' && *s <= '9')) {
2723       dTHR;
2724       if (ckWARN(WARN_UNSAFE))
2725           Perl_warner(aTHX_ WARN_UNSAFE, "Illegal binary digit '%c' ignored", *s);
2726     }
2727     *retlen = s - start;
2728     return retval;
2729 }
2730 UV
2731 Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
2732 {
2733     register char *s = start;
2734     register UV retval = 0;
2735     bool overflowed = FALSE;
2736
2737     while (len && *s >= '0' && *s <= '7') {
2738         register UV n = retval << 3;
2739         if (!overflowed && (n >> 3) != retval) {
2740             Perl_warn(aTHX_ "Integer overflow in octal number");
2741             overflowed = TRUE;
2742         }
2743         retval = n | (*s++ - '0');
2744         len--;
2745     }
2746     if (len && (*s == '8' || *s == '9')) {
2747         dTHR;
2748         if (ckWARN(WARN_OCTAL))
2749             Perl_warner(aTHX_ WARN_OCTAL, "Illegal octal digit '%c' ignored", *s);
2750     }
2751     *retlen = s - start;
2752     return retval;
2753 }
2754
2755 UV
2756 Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
2757 {
2758     register char *s = start;
2759     register UV retval = 0;
2760     bool overflowed = FALSE;
2761     char *tmp = s;
2762     register UV n;
2763
2764     while (len-- && *s) {
2765         tmp = strchr((char *) PL_hexdigit, *s++);
2766         if (!tmp) {
2767             if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0))
2768                 continue;
2769             else {
2770                 dTHR;
2771                 --s;
2772                 if (ckWARN(WARN_UNSAFE))
2773                     Perl_warner(aTHX_ WARN_UNSAFE,"Illegal hex digit '%c' ignored", *s);
2774                 break;
2775             }
2776         }
2777         n = retval << 4;
2778         if (!overflowed && (n >> 4) != retval) {
2779             Perl_warn(aTHX_ "Integer overflow in hex number");
2780             overflowed = TRUE;
2781         }
2782         retval = n | ((tmp - PL_hexdigit) & 15);
2783     }
2784     *retlen = s - start;
2785     return retval;
2786 }
2787
2788 char*
2789 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2790 {
2791     dTHR;
2792     char *xfound = Nullch;
2793     char *xfailed = Nullch;
2794     char tmpbuf[MAXPATHLEN];
2795     register char *s;
2796     I32 len;
2797     int retval;
2798 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2799 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2800 #  define MAX_EXT_LEN 4
2801 #endif
2802 #ifdef OS2
2803 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2804 #  define MAX_EXT_LEN 4
2805 #endif
2806 #ifdef VMS
2807 #  define SEARCH_EXTS ".pl", ".com", NULL
2808 #  define MAX_EXT_LEN 4
2809 #endif
2810     /* additional extensions to try in each dir if scriptname not found */
2811 #ifdef SEARCH_EXTS
2812     char *exts[] = { SEARCH_EXTS };
2813     char **ext = search_ext ? search_ext : exts;
2814     int extidx = 0, i = 0;
2815     char *curext = Nullch;
2816 #else
2817 #  define MAX_EXT_LEN 0
2818 #endif
2819
2820     /*
2821      * If dosearch is true and if scriptname does not contain path
2822      * delimiters, search the PATH for scriptname.
2823      *
2824      * If SEARCH_EXTS is also defined, will look for each
2825      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2826      * while searching the PATH.
2827      *
2828      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2829      * proceeds as follows:
2830      *   If DOSISH or VMSISH:
2831      *     + look for ./scriptname{,.foo,.bar}
2832      *     + search the PATH for scriptname{,.foo,.bar}
2833      *
2834      *   If !DOSISH:
2835      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2836      *       this will not look in '.' if it's not in the PATH)
2837      */
2838     tmpbuf[0] = '\0';
2839
2840 #ifdef VMS
2841 #  ifdef ALWAYS_DEFTYPES
2842     len = strlen(scriptname);
2843     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2844         int hasdir, idx = 0, deftypes = 1;
2845         bool seen_dot = 1;
2846
2847         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2848 #  else
2849     if (dosearch) {
2850         int hasdir, idx = 0, deftypes = 1;
2851         bool seen_dot = 1;
2852
2853         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2854 #  endif
2855         /* The first time through, just add SEARCH_EXTS to whatever we
2856          * already have, so we can check for default file types. */
2857         while (deftypes ||
2858                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2859         {
2860             if (deftypes) {
2861                 deftypes = 0;
2862                 *tmpbuf = '\0';
2863             }
2864             if ((strlen(tmpbuf) + strlen(scriptname)
2865                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2866                 continue;       /* don't search dir with too-long name */
2867             strcat(tmpbuf, scriptname);
2868 #else  /* !VMS */
2869
2870 #ifdef DOSISH
2871     if (strEQ(scriptname, "-"))
2872         dosearch = 0;
2873     if (dosearch) {             /* Look in '.' first. */
2874         char *cur = scriptname;
2875 #ifdef SEARCH_EXTS
2876         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2877             while (ext[i])
2878                 if (strEQ(ext[i++],curext)) {
2879                     extidx = -1;                /* already has an ext */
2880                     break;
2881                 }
2882         do {
2883 #endif
2884             DEBUG_p(PerlIO_printf(Perl_debug_log,
2885                                   "Looking for %s\n",cur));
2886             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2887                 && !S_ISDIR(PL_statbuf.st_mode)) {
2888                 dosearch = 0;
2889                 scriptname = cur;
2890 #ifdef SEARCH_EXTS
2891                 break;
2892 #endif
2893             }
2894 #ifdef SEARCH_EXTS
2895             if (cur == scriptname) {
2896                 len = strlen(scriptname);
2897                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2898                     break;
2899                 cur = strcpy(tmpbuf, scriptname);
2900             }
2901         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2902                  && strcpy(tmpbuf+len, ext[extidx++]));
2903 #endif
2904     }
2905 #endif
2906
2907     if (dosearch && !strchr(scriptname, '/')
2908 #ifdef DOSISH
2909                  && !strchr(scriptname, '\\')
2910 #endif
2911                  && (s = PerlEnv_getenv("PATH"))) {
2912         bool seen_dot = 0;
2913
2914         PL_bufend = s + strlen(s);
2915         while (s < PL_bufend) {
2916 #if defined(atarist) || defined(DOSISH)
2917             for (len = 0; *s
2918 #  ifdef atarist
2919                     && *s != ','
2920 #  endif
2921                     && *s != ';'; len++, s++) {
2922                 if (len < sizeof tmpbuf)
2923                     tmpbuf[len] = *s;
2924             }
2925             if (len < sizeof tmpbuf)
2926                 tmpbuf[len] = '\0';
2927 #else  /* ! (atarist || DOSISH) */
2928             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2929                         ':',
2930                         &len);
2931 #endif /* ! (atarist || DOSISH) */
2932             if (s < PL_bufend)
2933                 s++;
2934             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2935                 continue;       /* don't search dir with too-long name */
2936             if (len
2937 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2938                 && tmpbuf[len - 1] != '/'
2939                 && tmpbuf[len - 1] != '\\'
2940 #endif
2941                )
2942                 tmpbuf[len++] = '/';
2943             if (len == 2 && tmpbuf[0] == '.')
2944                 seen_dot = 1;
2945             (void)strcpy(tmpbuf + len, scriptname);
2946 #endif  /* !VMS */
2947
2948 #ifdef SEARCH_EXTS
2949             len = strlen(tmpbuf);
2950             if (extidx > 0)     /* reset after previous loop */
2951                 extidx = 0;
2952             do {
2953 #endif
2954                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2955                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2956                 if (S_ISDIR(PL_statbuf.st_mode)) {
2957                     retval = -1;
2958                 }
2959 #ifdef SEARCH_EXTS
2960             } while (  retval < 0               /* not there */
2961                     && extidx>=0 && ext[extidx] /* try an extension? */
2962                     && strcpy(tmpbuf+len, ext[extidx++])
2963                 );
2964 #endif
2965             if (retval < 0)
2966                 continue;
2967             if (S_ISREG(PL_statbuf.st_mode)
2968                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2969 #ifndef DOSISH
2970                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2971 #endif
2972                 )
2973             {
2974                 xfound = tmpbuf;              /* bingo! */
2975                 break;
2976             }
2977             if (!xfailed)
2978                 xfailed = savepv(tmpbuf);
2979         }
2980 #ifndef DOSISH
2981         if (!xfound && !seen_dot && !xfailed &&
2982             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2983              || S_ISDIR(PL_statbuf.st_mode)))
2984 #endif
2985             seen_dot = 1;                       /* Disable message. */
2986         if (!xfound) {
2987             if (flags & 1) {                    /* do or die? */
2988                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2989                       (xfailed ? "execute" : "find"),
2990                       (xfailed ? xfailed : scriptname),
2991                       (xfailed ? "" : " on PATH"),
2992                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2993             }
2994             scriptname = Nullch;
2995         }
2996         if (xfailed)
2997             Safefree(xfailed);
2998         scriptname = xfound;
2999     }
3000     return (scriptname ? savepv(scriptname) : Nullch);
3001 }
3002
3003
3004 #ifdef USE_THREADS
3005 #ifdef FAKE_THREADS
3006 /* Very simplistic scheduler for now */
3007 void
3008 schedule(void)
3009 {
3010     thr = thr->i.next_run;
3011 }
3012
3013 void
3014 Perl_cond_init(pTHX_ perl_cond *cp)
3015 {
3016     *cp = 0;
3017 }
3018
3019 void
3020 Perl_cond_signal(pTHX_ perl_cond *cp)
3021 {
3022     perl_os_thread t;
3023     perl_cond cond = *cp;
3024
3025     if (!cond)
3026         return;
3027     t = cond->thread;
3028     /* Insert t in the runnable queue just ahead of us */
3029     t->i.next_run = thr->i.next_run;
3030     thr->i.next_run->i.prev_run = t;
3031     t->i.prev_run = thr;
3032     thr->i.next_run = t;
3033     thr->i.wait_queue = 0;
3034     /* Remove from the wait queue */
3035     *cp = cond->next;
3036     Safefree(cond);
3037 }
3038
3039 void
3040 Perl_cond_broadcast(pTHX_ perl_cond *cp)
3041 {
3042     perl_os_thread t;
3043     perl_cond cond, cond_next;
3044
3045     for (cond = *cp; cond; cond = cond_next) {
3046         t = cond->thread;
3047         /* Insert t in the runnable queue just ahead of us */
3048         t->i.next_run = thr->i.next_run;
3049         thr->i.next_run->i.prev_run = t;
3050         t->i.prev_run = thr;
3051         thr->i.next_run = t;
3052         thr->i.wait_queue = 0;
3053         /* Remove from the wait queue */
3054         cond_next = cond->next;
3055         Safefree(cond);
3056     }
3057     *cp = 0;
3058 }
3059
3060 void
3061 Perl_cond_wait(pTHX_ perl_cond *cp)
3062 {
3063     perl_cond cond;
3064
3065     if (thr->i.next_run == thr)
3066         Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3067
3068     New(666, cond, 1, struct perl_wait_queue);
3069     cond->thread = thr;
3070     cond->next = *cp;
3071     *cp = cond;
3072     thr->i.wait_queue = cond;
3073     /* Remove ourselves from runnable queue */
3074     thr->i.next_run->i.prev_run = thr->i.prev_run;
3075     thr->i.prev_run->i.next_run = thr->i.next_run;
3076 }
3077 #endif /* FAKE_THREADS */
3078
3079 #ifdef PTHREAD_GETSPECIFIC_INT
3080 struct perl_thread *
3081 Perl_getTHR(pTHX)
3082 {
3083     pthread_addr_t t;
3084
3085     if (pthread_getspecific(PL_thr_key, &t))
3086         Perl_croak(aTHX_ "panic: pthread_getspecific");
3087     return (struct perl_thread *) t;
3088 }
3089 #endif
3090
3091 MAGIC *
3092 Perl_condpair_magic(pTHX_ SV *sv)
3093 {
3094     MAGIC *mg;
3095
3096     SvUPGRADE(sv, SVt_PVMG);
3097     mg = mg_find(sv, 'm');
3098     if (!mg) {
3099         condpair_t *cp;
3100
3101         New(53, cp, 1, condpair_t);
3102         MUTEX_INIT(&cp->mutex);
3103         COND_INIT(&cp->owner_cond);
3104         COND_INIT(&cp->cond);
3105         cp->owner = 0;
3106         MUTEX_LOCK(&PL_cred_mutex);             /* XXX need separate mutex? */
3107         mg = mg_find(sv, 'm');
3108         if (mg) {
3109             /* someone else beat us to initialising it */
3110             MUTEX_UNLOCK(&PL_cred_mutex);       /* XXX need separate mutex? */
3111             MUTEX_DESTROY(&cp->mutex);
3112             COND_DESTROY(&cp->owner_cond);
3113             COND_DESTROY(&cp->cond);
3114             Safefree(cp);
3115         }
3116         else {
3117             sv_magic(sv, Nullsv, 'm', 0, 0);
3118             mg = SvMAGIC(sv);
3119             mg->mg_ptr = (char *)cp;
3120             mg->mg_len = sizeof(cp);
3121             MUTEX_UNLOCK(&PL_cred_mutex);       /* XXX need separate mutex? */
3122             DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(),
3123                                            "%p: condpair_magic %p\n", thr, sv));)
3124         }
3125     }
3126     return mg;
3127 }
3128
3129 /*
3130  * Make a new perl thread structure using t as a prototype. Some of the
3131  * fields for the new thread are copied from the prototype thread, t,
3132  * so t should not be running in perl at the time this function is
3133  * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3134  * thread calling new_struct_thread) clearly satisfies this constraint.
3135  */
3136 struct perl_thread *
3137 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3138 {
3139 #ifndef PERL_IMPLICIT_CONTEXT
3140     struct perl_thread *thr;
3141 #endif
3142     SV *sv;
3143     SV **svp;
3144     I32 i;
3145
3146     sv = newSVpvn("", 0);
3147     SvGROW(sv, sizeof(struct perl_thread) + 1);
3148     SvCUR_set(sv, sizeof(struct perl_thread));
3149     thr = (Thread) SvPVX(sv);
3150 #ifdef DEBUGGING
3151     memset(thr, 0xab, sizeof(struct perl_thread));
3152     PL_markstack = 0;
3153     PL_scopestack = 0;
3154     PL_savestack = 0;
3155     PL_retstack = 0;
3156     PL_dirty = 0;
3157     PL_localizing = 0;
3158     Zero(&PL_hv_fetch_ent_mh, 1, HE);
3159 #else
3160     Zero(thr, 1, struct perl_thread);
3161 #endif
3162
3163     PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect);
3164
3165     thr->oursv = sv;
3166     init_stacks();
3167
3168     PL_curcop = &PL_compiling;
3169     thr->cvcache = newHV();
3170     thr->threadsv = newAV();
3171     thr->specific = newAV();
3172     thr->errsv = newSVpvn("", 0);
3173     thr->errhv = newHV();
3174     thr->flags = THRf_R_JOINABLE;
3175     MUTEX_INIT(&thr->mutex);
3176
3177     /* top_env needs to be non-zero. It points to an area
3178        in which longjmp() stuff is stored, as C callstack
3179        info there at least is thread specific this has to
3180        be per-thread. Otherwise a 'die' in a thread gives
3181        that thread the C stack of last thread to do an eval {}!
3182        See comments in scope.h
3183        Initialize top entry (as in perl.c for main thread)
3184      */
3185     PL_start_env.je_prev = NULL;
3186     PL_start_env.je_ret = -1;
3187     PL_start_env.je_mustcatch = TRUE;
3188     PL_top_env  = &PL_start_env;
3189
3190     PL_in_eval = EVAL_NULL;     /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */
3191     PL_restartop = 0;
3192
3193     PL_statname = NEWSV(66,0);
3194     PL_maxscream = -1;
3195     PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
3196     PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
3197     PL_regindent = 0;
3198     PL_reginterp_cnt = 0;
3199     PL_lastscream = Nullsv;
3200     PL_screamfirst = 0;
3201     PL_screamnext = 0;
3202     PL_reg_start_tmp = 0;
3203     PL_reg_start_tmpl = 0;
3204
3205     /* parent thread's data needs to be locked while we make copy */
3206     MUTEX_LOCK(&t->mutex);
3207
3208     PL_protect = t->Tprotect;
3209
3210     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
3211     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
3212     PL_curstash = t->Tcurstash;   /* always be set to main? */
3213
3214     PL_tainted = t->Ttainted;
3215     PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
3216     PL_nrs = newSVsv(t->Tnrs);
3217     PL_rs = SvREFCNT_inc(PL_nrs);
3218     PL_last_in_gv = Nullgv;
3219     PL_ofslen = t->Tofslen;
3220     PL_ofs = savepvn(t->Tofs, PL_ofslen);
3221     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3222     PL_chopset = t->Tchopset;
3223     PL_formtarget = newSVsv(t->Tformtarget);
3224     PL_bodytarget = newSVsv(t->Tbodytarget);
3225     PL_toptarget = newSVsv(t->Ttoptarget);
3226
3227     /* Initialise all per-thread SVs that the template thread used */
3228     svp = AvARRAY(t->threadsv);
3229     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3230         if (*svp && *svp != &PL_sv_undef) {
3231             SV *sv = newSVsv(*svp);
3232             av_store(thr->threadsv, i, sv);
3233             sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
3234             DEBUG_S(PerlIO_printf(PerlIO_stderr(),
3235                 "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
3236         }
3237     }
3238     thr->threadsvp = AvARRAY(thr->threadsv);
3239
3240     MUTEX_LOCK(&PL_threads_mutex);
3241     PL_nthreads++;
3242     thr->tid = ++PL_threadnum;
3243     thr->next = t->next;
3244     thr->prev = t;
3245     t->next = thr;
3246     thr->next->prev = thr;
3247     MUTEX_UNLOCK(&PL_threads_mutex);
3248
3249     /* done copying parent's state */
3250     MUTEX_UNLOCK(&t->mutex);
3251
3252 #ifdef HAVE_THREAD_INTERN
3253     Perl_init_thread_intern(thr);
3254 #endif /* HAVE_THREAD_INTERN */
3255     return thr;
3256 }
3257 #endif /* USE_THREADS */
3258
3259 #ifdef HUGE_VAL
3260 /*
3261  * This hack is to force load of "huge" support from libm.a
3262  * So it is in perl for (say) POSIX to use.
3263  * Needed for SunOS with Sun's 'acc' for example.
3264  */
3265 double
3266 Perl_huge(void)
3267 {
3268  return HUGE_VAL;
3269 }
3270 #endif
3271
3272 #ifdef PERL_GLOBAL_STRUCT
3273 struct perl_vars *
3274 Perl_GetVars(pTHX)
3275 {
3276  return &PL_Vars;
3277 }
3278 #endif
3279
3280 char **
3281 Perl_get_op_names(pTHX)
3282 {
3283  return PL_op_name;
3284 }
3285
3286 char **
3287 Perl_get_op_descs(pTHX)
3288 {
3289  return PL_op_desc;
3290 }
3291
3292 char *
3293 Perl_get_no_modify(pTHX)
3294 {
3295  return (char*)PL_no_modify;
3296 }
3297
3298 U32 *
3299 Perl_get_opargs(pTHX)
3300 {
3301  return PL_opargs;
3302 }
3303
3304 PPADDR_t*
3305 Perl_get_ppaddr(pTHX)
3306 {
3307  return &PL_ppaddr;
3308 }
3309
3310 #ifndef HAS_GETENV_LEN
3311 char *
3312 Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len)
3313 {
3314     char *env_trans = PerlEnv_getenv(env_elem);
3315     if (env_trans)
3316         *len = strlen(env_trans);
3317     return env_trans;
3318 }
3319 #endif
3320
3321
3322 MGVTBL*
3323 Perl_get_vtbl(pTHX_ int vtbl_id)
3324 {
3325     MGVTBL* result = Null(MGVTBL*);
3326
3327     switch(vtbl_id) {
3328     case want_vtbl_sv:
3329         result = &PL_vtbl_sv;
3330         break;
3331     case want_vtbl_env:
3332         result = &PL_vtbl_env;
3333         break;
3334     case want_vtbl_envelem:
3335         result = &PL_vtbl_envelem;
3336         break;
3337     case want_vtbl_sig:
3338         result = &PL_vtbl_sig;
3339         break;
3340     case want_vtbl_sigelem:
3341         result = &PL_vtbl_sigelem;
3342         break;
3343     case want_vtbl_pack:
3344         result = &PL_vtbl_pack;
3345         break;
3346     case want_vtbl_packelem:
3347         result = &PL_vtbl_packelem;
3348         break;
3349     case want_vtbl_dbline:
3350         result = &PL_vtbl_dbline;
3351         break;
3352     case want_vtbl_isa:
3353         result = &PL_vtbl_isa;
3354         break;
3355     case want_vtbl_isaelem:
3356         result = &PL_vtbl_isaelem;
3357         break;
3358     case want_vtbl_arylen:
3359         result = &PL_vtbl_arylen;
3360         break;
3361     case want_vtbl_glob:
3362         result = &PL_vtbl_glob;
3363         break;
3364     case want_vtbl_mglob:
3365         result = &PL_vtbl_mglob;
3366         break;
3367     case want_vtbl_nkeys:
3368         result = &PL_vtbl_nkeys;
3369         break;
3370     case want_vtbl_taint:
3371         result = &PL_vtbl_taint;
3372         break;
3373     case want_vtbl_substr:
3374         result = &PL_vtbl_substr;
3375         break;
3376     case want_vtbl_vec:
3377         result = &PL_vtbl_vec;
3378         break;
3379     case want_vtbl_pos:
3380         result = &PL_vtbl_pos;
3381         break;
3382     case want_vtbl_bm:
3383         result = &PL_vtbl_bm;
3384         break;
3385     case want_vtbl_fm:
3386         result = &PL_vtbl_fm;
3387         break;
3388     case want_vtbl_uvar:
3389         result = &PL_vtbl_uvar;
3390         break;
3391 #ifdef USE_THREADS
3392     case want_vtbl_mutex:
3393         result = &PL_vtbl_mutex;
3394         break;
3395 #endif
3396     case want_vtbl_defelem:
3397         result = &PL_vtbl_defelem;
3398         break;
3399     case want_vtbl_regexp:
3400         result = &PL_vtbl_regexp;
3401         break;
3402     case want_vtbl_regdata:
3403         result = &PL_vtbl_regdata;
3404         break;
3405     case want_vtbl_regdatum:
3406         result = &PL_vtbl_regdatum;
3407         break;
3408 #ifdef USE_LOCALE_COLLATE
3409     case want_vtbl_collxfrm:
3410         result = &PL_vtbl_collxfrm;
3411         break;
3412 #endif
3413     case want_vtbl_amagic:
3414         result = &PL_vtbl_amagic;
3415         break;
3416     case want_vtbl_amagicelem:
3417         result = &PL_vtbl_amagicelem;
3418         break;
3419     case want_vtbl_backref:
3420         result = &PL_vtbl_backref;
3421         break;
3422     }
3423     return result;
3424 }
3425
3426 I32
3427 Perl_my_fflush_all(pTHX)
3428 {
3429 #ifdef FFLUSH_NULL
3430     return PerlIO_flush(NULL);
3431 #else
3432     long open_max = -1;
3433 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3434 #  ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3435     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3436 #  else
3437 #  if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3438     open_max = sysconf(_SC_OPEN_MAX);
3439 #  else
3440 #   ifdef FOPEN_MAX
3441     open_max = FOPEN_MAX;
3442 #   else
3443 #    ifdef OPEN_MAX
3444     open_max = OPEN_MAX;
3445 #    else
3446 #     ifdef _NFILE
3447     open_max = _NFILE;
3448 #     endif
3449 #    endif
3450 #   endif
3451 #  endif
3452 #  endif
3453     if (open_max > 0) {
3454       long i;
3455       for (i = 0; i < open_max; i++)
3456             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3457                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3458                 STDIO_STREAM_ARRAY[i]._flag)
3459                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3460       return 0;
3461     }
3462 # endif
3463     SETERRNO(EBADF,RMS$_IFI);
3464     return EOF;
3465 #endif
3466 }
3467
3468 double
3469 Perl_my_atof(const char* s) {
3470 #ifdef USE_LOCALE_NUMERIC
3471     if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
3472         double x, y;
3473
3474         x = atof(s);
3475         SET_NUMERIC_STANDARD();
3476         y = atof(s);
3477         SET_NUMERIC_LOCAL();
3478         if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
3479             return y;
3480         return x;
3481     } else
3482         return atof(s);
3483 #else
3484     return atof(s);
3485 #endif
3486 }