util.c

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