util.c

   1 /*    util.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  12  * not content."  --Gandalf
  13  */
  14
  15 #include "EXTERN.h"
  16 #define PERL_IN_UTIL_C
  17 #include "perl.h"
  18
  19 #ifndef PERL_MICRO
  20 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  21 #include <signal.h>
  22 #endif
  23
  24 #ifndef SIG_ERR
  25 # define SIG_ERR ((Sighandler_t) -1)
  26 #endif
  27 #endif
  28
  29 #ifdef I_SYS_WAIT
  30 #  include <sys/wait.h>
  31 #endif
  32
  33 #ifdef HAS_SELECT
  34 # ifdef I_SYS_SELECT
  35 #  include <sys/select.h>
  36 # endif
  37 #endif
  38
  39 #define FLUSH
  40
  41 #ifdef LEAKTEST
  42
  43 long xcount[MAXXCOUNT];
  44 long lastxcount[MAXXCOUNT];
  45 long xycount[MAXXCOUNT][MAXYCOUNT];
  46 long lastxycount[MAXXCOUNT][MAXYCOUNT];
  47
  48 #endif
  49
  50 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  51 #  define FD_CLOEXEC 1                  /* NeXT needs this */
  52 #endif
  53
  54 /* NOTE:  Do not call the next three routines directly.  Use the macros
  55  * in handy.h, so that we can easily redefine everything to do tracking of
  56  * allocated hunks back to the original New to track down any memory leaks.
  57  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  58  */
  59
  60 /* paranoid version of system's malloc() */
  61
  62 Malloc_t
  63 Perl_safesysmalloc(MEM_SIZE size)
  64 {
  65     dTHX;
  66     Malloc_t ptr;
  67 #ifdef HAS_64K_LIMIT
  68         if (size > 0xffff) {
  69             PerlIO_printf(Perl_error_log,
  70                           "Allocation too large: %lx\n", size) FLUSH;
  71             my_exit(1);
  72         }
  73 #endif /* HAS_64K_LIMIT */
  74 #ifdef DEBUGGING
  75     if ((long)size < 0)
  76         Perl_croak_nocontext("panic: malloc");
  77 #endif
  78     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
  79     PERL_ALLOC_CHECK(ptr);
  80     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
  81     if (ptr != Nullch)
  82         return ptr;
  83     else if (PL_nomemok)
  84         return Nullch;
  85     else {
  86         PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
  87         my_exit(1);
  88         return Nullch;
  89     }
  90     /*NOTREACHED*/
  91 }
  92
  93 /* paranoid version of system's realloc() */
  94
  95 Malloc_t
  96 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
  97 {
  98     dTHX;
  99     Malloc_t ptr;
 100 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 101     Malloc_t PerlMem_realloc();
 102 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 103
 104 #ifdef HAS_64K_LIMIT
 105     if (size > 0xffff) {
 106         PerlIO_printf(Perl_error_log,
 107                       "Reallocation too large: %lx\n", size) FLUSH;
 108         my_exit(1);
 109     }
 110 #endif /* HAS_64K_LIMIT */
 111     if (!size) {
 112         safesysfree(where);
 113         return NULL;
 114     }
 115
 116     if (!where)
 117         return safesysmalloc(size);
 118 #ifdef DEBUGGING
 119     if ((long)size < 0)
 120         Perl_croak_nocontext("panic: realloc");
 121 #endif
 122     ptr = (Malloc_t)PerlMem_realloc(where,size);
 123     PERL_ALLOC_CHECK(ptr);
 124
 125     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 126     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 127
 128     if (ptr != Nullch)
 129         return ptr;
 130     else if (PL_nomemok)
 131         return Nullch;
 132     else {
 133         PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
 134         my_exit(1);
 135         return Nullch;
 136     }
 137     /*NOTREACHED*/
 138 }
 139
 140 /* safe version of system's free() */
 141
 142 Free_t
 143 Perl_safesysfree(Malloc_t where)
 144 {
 145 #ifdef PERL_IMPLICIT_SYS
 146     dTHX;
 147 #endif
 148     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 149     if (where) {
 150         /*SUPPRESS 701*/
 151         PerlMem_free(where);
 152     }
 153 }
 154
 155 /* safe version of system's calloc() */
 156
 157 Malloc_t
 158 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 159 {
 160     dTHX;
 161     Malloc_t ptr;
 162
 163 #ifdef HAS_64K_LIMIT
 164     if (size * count > 0xffff) {
 165         PerlIO_printf(Perl_error_log,
 166                       "Allocation too large: %lx\n", size * count) FLUSH;
 167         my_exit(1);
 168     }
 169 #endif /* HAS_64K_LIMIT */
 170 #ifdef DEBUGGING
 171     if ((long)size < 0 || (long)count < 0)
 172         Perl_croak_nocontext("panic: calloc");
 173 #endif
 174     size *= count;
 175     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
 176     PERL_ALLOC_CHECK(ptr);
 177     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
 178     if (ptr != Nullch) {
 179         memset((void*)ptr, 0, size);
 180         return ptr;
 181     }
 182     else if (PL_nomemok)
 183         return Nullch;
 184     else {
 185         PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
 186         my_exit(1);
 187         return Nullch;
 188     }
 189     /*NOTREACHED*/
 190 }
 191
 192 #ifdef LEAKTEST
 193
 194 struct mem_test_strut {
 195     union {
 196         long type;
 197         char c[2];
 198     } u;
 199     long size;
 200 };
 201
 202 #    define ALIGN sizeof(struct mem_test_strut)
 203
 204 #    define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
 205 #    define typeof_chunk(ch) \
 206         (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
 207 #    define set_typeof_chunk(ch,t) \
 208         (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
 209 #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE                            \
 210                           ? MAXYCOUNT - 1                               \
 211                           : ( (size) > 40                               \
 212                               ? ((size) - 1)/8 + 5                      \
 213                               : ((size) - 1)/4))
 214
 215 Malloc_t
 216 Perl_safexmalloc(I32 x, MEM_SIZE size)
 217 {
 218     register char* where = (char*)safemalloc(size + ALIGN);
 219
 220     xcount[x] += size;
 221     xycount[x][SIZE_TO_Y(size)]++;
 222     set_typeof_chunk(where, x);
 223     sizeof_chunk(where) = size;
 224     return (Malloc_t)(where + ALIGN);
 225 }
 226
 227 Malloc_t
 228 Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
 229 {
 230     char *where = (char*)wh;
 231
 232     if (!wh)
 233         return safexmalloc(0,size);
 234
 235     {
 236         MEM_SIZE old = sizeof_chunk(where - ALIGN);
 237         int t = typeof_chunk(where - ALIGN);
 238         register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
 239
 240         xycount[t][SIZE_TO_Y(old)]--;
 241         xycount[t][SIZE_TO_Y(size)]++;
 242         xcount[t] += size - old;
 243         sizeof_chunk(new) = size;
 244         return (Malloc_t)(new + ALIGN);
 245     }
 246 }
 247
 248 void
 249 Perl_safexfree(Malloc_t wh)
 250 {
 251     I32 x;
 252     char *where = (char*)wh;
 253     MEM_SIZE size;
 254
 255     if (!where)
 256         return;
 257     where -= ALIGN;
 258     size = sizeof_chunk(where);
 259     x = where[0] + 100 * where[1];
 260     xcount[x] -= size;
 261     xycount[x][SIZE_TO_Y(size)]--;
 262     safefree(where);
 263 }
 264
 265 Malloc_t
 266 Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
 267 {
 268     register char * where = (char*)safexmalloc(x, size * count + ALIGN);
 269     xcount[x] += size;
 270     xycount[x][SIZE_TO_Y(size)]++;
 271     memset((void*)(where + ALIGN), 0, size * count);
 272     set_typeof_chunk(where, x);
 273     sizeof_chunk(where) = size;
 274     return (Malloc_t)(where + ALIGN);
 275 }
 276
 277 STATIC void
 278 S_xstat(pTHX_ int flag)
 279 {
 280     register I32 i, j, total = 0;
 281     I32 subtot[MAXYCOUNT];
 282
 283     for (j = 0; j < MAXYCOUNT; j++) {
 284         subtot[j] = 0;
 285     }
 286
 287     PerlIO_printf(Perl_debug_log, "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
 288     for (i = 0; i < MAXXCOUNT; i++) {
 289         total += xcount[i];
 290         for (j = 0; j < MAXYCOUNT; j++) {
 291             subtot[j] += xycount[i][j];
 292         }
 293         if (flag == 0
 294             ? xcount[i]                 /* Have something */
 295             : (flag == 2
 296                ? xcount[i] != lastxcount[i] /* Changed */
 297                : xcount[i] > lastxcount[i])) { /* Growed */
 298             PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
 299                           flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
 300             lastxcount[i] = xcount[i];
 301             for (j = 0; j < MAXYCOUNT; j++) {
 302                 if ( flag == 0
 303                      ? xycount[i][j]    /* Have something */
 304                      : (flag == 2
 305                         ? xycount[i][j] != lastxycount[i][j] /* Changed */
 306                         : xycount[i][j] > lastxycount[i][j])) { /* Growed */
 307                     PerlIO_printf(Perl_debug_log,"%3ld ",
 308                                   flag == 2
 309                                   ? xycount[i][j] - lastxycount[i][j]
 310                                   : xycount[i][j]);
 311                     lastxycount[i][j] = xycount[i][j];
 312                 } else {
 313                     PerlIO_printf(Perl_debug_log, "  . ", xycount[i][j]);
 314                 }
 315             }
 316             PerlIO_printf(Perl_debug_log, "\n");
 317         }
 318     }
 319     if (flag != 2) {
 320         PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
 321         for (j = 0; j < MAXYCOUNT; j++) {
 322             if (subtot[j]) {
 323                 PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
 324             } else {
 325                 PerlIO_printf(Perl_debug_log, "  . ");
 326             }
 327         }
 328         PerlIO_printf(Perl_debug_log, "\n");
 329     }
 330 }
 331
 332 #endif /* LEAKTEST */
 333
 334 /* These must be defined when not using Perl's malloc for binary
 335  * compatibility */
 336
 337 #ifndef MYMALLOC
 338
 339 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 340 {
 341     dTHXs;
 342     return (Malloc_t)PerlMem_malloc(nbytes);
 343 }
 344
 345 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 346 {
 347     dTHXs;
 348     return (Malloc_t)PerlMem_calloc(elements, size);
 349 }
 350
 351 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 352 {
 353     dTHXs;
 354     return (Malloc_t)PerlMem_realloc(where, nbytes);
 355 }
 356
 357 Free_t   Perl_mfree (Malloc_t where)
 358 {
 359     dTHXs;
 360     PerlMem_free(where);
 361 }
 362
 363 #endif
 364
 365 /* copy a string up to some (non-backslashed) delimiter, if any */
 366
 367 char *
 368 Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
 369 {
 370     register I32 tolen;
 371     for (tolen = 0; from < fromend; from++, tolen++) {
 372         if (*from == '\\') {
 373             if (from[1] == delim)
 374                 from++;
 375             else {
 376                 if (to < toend)
 377                     *to++ = *from;
 378                 tolen++;
 379                 from++;
 380             }
 381         }
 382         else if (*from == delim)
 383             break;
 384         if (to < toend)
 385             *to++ = *from;
 386     }
 387     if (to < toend)
 388         *to = '\0';
 389     *retlen = tolen;
 390     return from;
 391 }
 392
 393 /* return ptr to little string in big string, NULL if not found */
 394 /* This routine was donated by Corey Satten. */
 395
 396 char *
 397 Perl_instr(pTHX_ register const char *big, register const char *little)
 398 {
 399     register const char *s, *x;
 400     register I32 first;
 401
 402     if (!little)
 403         return (char*)big;
 404     first = *little++;
 405     if (!first)
 406         return (char*)big;
 407     while (*big) {
 408         if (*big++ != first)
 409             continue;
 410         for (x=big,s=little; *s; /**/ ) {
 411             if (!*x)
 412                 return Nullch;
 413             if (*s++ != *x++) {
 414                 s--;
 415                 break;
 416             }
 417         }
 418         if (!*s)
 419             return (char*)(big-1);
 420     }
 421     return Nullch;
 422 }
 423
 424 /* same as instr but allow embedded nulls */
 425
 426 char *
 427 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 428 {
 429     register const char *s, *x;
 430     register I32 first = *little;
 431     register const char *littleend = lend;
 432
 433     if (!first && little >= littleend)
 434         return (char*)big;
 435     if (bigend - big < littleend - little)
 436         return Nullch;
 437     bigend -= littleend - little++;
 438     while (big <= bigend) {
 439         if (*big++ != first)
 440             continue;
 441         for (x=big,s=little; s < littleend; /**/ ) {
 442             if (*s++ != *x++) {
 443                 s--;
 444                 break;
 445             }
 446         }
 447         if (s >= littleend)
 448             return (char*)(big-1);
 449     }
 450     return Nullch;
 451 }
 452
 453 /* reverse of the above--find last substring */
 454
 455 char *
 456 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
 457 {
 458     register const char *bigbeg;
 459     register const char *s, *x;
 460     register I32 first = *little;
 461     register const char *littleend = lend;
 462
 463     if (!first && little >= littleend)
 464         return (char*)bigend;
 465     bigbeg = big;
 466     big = bigend - (littleend - little++);
 467     while (big >= bigbeg) {
 468         if (*big-- != first)
 469             continue;
 470         for (x=big+2,s=little; s < littleend; /**/ ) {
 471             if (*s++ != *x++) {
 472                 s--;
 473                 break;
 474             }
 475         }
 476         if (s >= littleend)
 477             return (char*)(big+1);
 478     }
 479     return Nullch;
 480 }
 481
 482 #define FBM_TABLE_OFFSET 2      /* Number of bytes between EOS and table*/
 483
 484 /* As a space optimization, we do not compile tables for strings of length
 485    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 486    special-cased in fbm_instr().
 487
 488    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 489
 490 /*
 491 =head1 Miscellaneous Functions
 492
 493 =for apidoc fbm_compile
 494
 495 Analyses the string in order to make fast searches on it using fbm_instr()
 496 -- the Boyer-Moore algorithm.
 497
 498 =cut
 499 */
 500
 501 void
 502 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 503 {
 504     register U8 *s;
 505     register U8 *table;
 506     register U32 i;
 507     STRLEN len;
 508     I32 rarest = 0;
 509     U32 frequency = 256;
 510
 511     if (flags & FBMcf_TAIL)
 512         sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
 513     s = (U8*)SvPV_force(sv, len);
 514     (void)SvUPGRADE(sv, SVt_PVBM);
 515     if (len == 0)               /* TAIL might be on a zero-length string. */
 516         return;
 517     if (len > 2) {
 518         U8 mlen;
 519         unsigned char *sb;
 520
 521         if (len > 255)
 522             mlen = 255;
 523         else
 524             mlen = (U8)len;
 525         Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
 526         table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
 527         s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
 528         memset((void*)table, mlen, 256);
 529         table[-1] = (U8)flags;
 530         i = 0;
 531         sb = s - mlen + 1;                      /* first char (maybe) */
 532         while (s >= sb) {
 533             if (table[*s] == mlen)
 534                 table[*s] = (U8)i;
 535             s--, i++;
 536         }
 537     }
 538     sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0);     /* deep magic */
 539     SvVALID_on(sv);
 540
 541     s = (unsigned char*)(SvPVX(sv));            /* deeper magic */
 542     for (i = 0; i < len; i++) {
 543         if (PL_freq[s[i]] < frequency) {
 544             rarest = i;
 545             frequency = PL_freq[s[i]];
 546         }
 547     }
 548     BmRARE(sv) = s[rarest];
 549     BmPREVIOUS(sv) = (U16)rarest;
 550     BmUSEFUL(sv) = 100;                 /* Initial value */
 551     if (flags & FBMcf_TAIL)
 552         SvTAIL_on(sv);
 553     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
 554                           BmRARE(sv),BmPREVIOUS(sv)));
 555 }
 556
 557 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
 558 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 559    if multiline */
 560
 561 /*
 562 =for apidoc fbm_instr
 563
 564 Returns the location of the SV in the string delimited by C<str> and
 565 C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
 566 does not have to be fbm_compiled, but the search will not be as fast
 567 then.
 568
 569 =cut
 570 */
 571
 572 char *
 573 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
 574 {
 575     register unsigned char *s;
 576     STRLEN l;
 577     register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
 578     register STRLEN littlelen = l;
 579     register I32 multiline = flags & FBMrf_MULTILINE;
 580
 581     if ((STRLEN)(bigend - big) < littlelen) {
 582         if ( SvTAIL(littlestr)
 583              && ((STRLEN)(bigend - big) == littlelen - 1)
 584              && (littlelen == 1
 585                  || (*big == *little &&
 586                      memEQ((char *)big, (char *)little, littlelen - 1))))
 587             return (char*)big;
 588         return Nullch;
 589     }
 590
 591     if (littlelen <= 2) {               /* Special-cased */
 592
 593         if (littlelen == 1) {
 594             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
 595                 /* Know that bigend != big.  */
 596                 if (bigend[-1] == '\n')
 597                     return (char *)(bigend - 1);
 598                 return (char *) bigend;
 599             }
 600             s = big;
 601             while (s < bigend) {
 602                 if (*s == *little)
 603                     return (char *)s;
 604                 s++;
 605             }
 606             if (SvTAIL(littlestr))
 607                 return (char *) bigend;
 608             return Nullch;
 609         }
 610         if (!littlelen)
 611             return (char*)big;          /* Cannot be SvTAIL! */
 612
 613         /* littlelen is 2 */
 614         if (SvTAIL(littlestr) && !multiline) {
 615             if (bigend[-1] == '\n' && bigend[-2] == *little)
 616                 return (char*)bigend - 2;
 617             if (bigend[-1] == *little)
 618                 return (char*)bigend - 1;
 619             return Nullch;
 620         }
 621         {
 622             /* This should be better than FBM if c1 == c2, and almost
 623                as good otherwise: maybe better since we do less indirection.
 624                And we save a lot of memory by caching no table. */
 625             register unsigned char c1 = little[0];
 626             register unsigned char c2 = little[1];
 627
 628             s = big + 1;
 629             bigend--;
 630             if (c1 != c2) {
 631                 while (s <= bigend) {
 632                     if (s[0] == c2) {
 633                         if (s[-1] == c1)
 634                             return (char*)s - 1;
 635                         s += 2;
 636                         continue;
 637                     }
 638                   next_chars:
 639                     if (s[0] == c1) {
 640                         if (s == bigend)
 641                             goto check_1char_anchor;
 642                         if (s[1] == c2)
 643                             return (char*)s;
 644                         else {
 645                             s++;
 646                             goto next_chars;
 647                         }
 648                     }
 649                     else
 650                         s += 2;
 651                 }
 652                 goto check_1char_anchor;
 653             }
 654             /* Now c1 == c2 */
 655             while (s <= bigend) {
 656                 if (s[0] == c1) {
 657                     if (s[-1] == c1)
 658                         return (char*)s - 1;
 659                     if (s == bigend)
 660                         goto check_1char_anchor;
 661                     if (s[1] == c1)
 662                         return (char*)s;
 663                     s += 3;
 664                 }
 665                 else
 666                     s += 2;
 667             }
 668         }
 669       check_1char_anchor:               /* One char and anchor! */
 670         if (SvTAIL(littlestr) && (*bigend == *little))
 671             return (char *)bigend;      /* bigend is already decremented. */
 672         return Nullch;
 673     }
 674     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 675         s = bigend - littlelen;
 676         if (s >= big && bigend[-1] == '\n' && *s == *little
 677             /* Automatically of length > 2 */
 678             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 679         {
 680             return (char*)s;            /* how sweet it is */
 681         }
 682         if (s[1] == *little
 683             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 684         {
 685             return (char*)s + 1;        /* how sweet it is */
 686         }
 687         return Nullch;
 688     }
 689     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
 690         char *b = ninstr((char*)big,(char*)bigend,
 691                          (char*)little, (char*)little + littlelen);
 692
 693         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 694             /* Chop \n from littlestr: */
 695             s = bigend - littlelen + 1;
 696             if (*s == *little
 697                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 698             {
 699                 return (char*)s;
 700             }
 701             return Nullch;
 702         }
 703         return b;
 704     }
 705
 706     {   /* Do actual FBM.  */
 707         register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
 708         register unsigned char *oldlittle;
 709
 710         if (littlelen > (STRLEN)(bigend - big))
 711             return Nullch;
 712         --littlelen;                    /* Last char found by table lookup */
 713
 714         s = big + littlelen;
 715         little += littlelen;            /* last char */
 716         oldlittle = little;
 717         if (s < bigend) {
 718             register I32 tmp;
 719
 720           top2:
 721             /*SUPPRESS 560*/
 722             if ((tmp = table[*s])) {
 723                 if ((s += tmp) < bigend)
 724                     goto top2;
 725                 goto check_end;
 726             }
 727             else {              /* less expensive than calling strncmp() */
 728                 register unsigned char *olds = s;
 729
 730                 tmp = littlelen;
 731
 732                 while (tmp--) {
 733                     if (*--s == *--little)
 734                         continue;
 735                     s = olds + 1;       /* here we pay the price for failure */
 736                     little = oldlittle;
 737                     if (s < bigend)     /* fake up continue to outer loop */
 738                         goto top2;
 739                     goto check_end;
 740                 }
 741                 return (char *)s;
 742             }
 743         }
 744       check_end:
 745         if ( s == bigend && (table[-1] & FBMcf_TAIL)
 746              && memEQ((char *)(bigend - littlelen),
 747                       (char *)(oldlittle - littlelen), littlelen) )
 748             return (char*)bigend - littlelen;
 749         return Nullch;
 750     }
 751 }
 752
 753 /* start_shift, end_shift are positive quantities which give offsets
 754    of ends of some substring of bigstr.
 755    If `last' we want the last occurrence.
 756    old_posp is the way of communication between consequent calls if
 757    the next call needs to find the .
 758    The initial *old_posp should be -1.
 759
 760    Note that we take into account SvTAIL, so one can get extra
 761    optimizations if _ALL flag is set.
 762  */
 763
 764 /* If SvTAIL is actually due to \Z or \z, this gives false positives
 765    if PL_multiline.  In fact if !PL_multiline the authoritative answer
 766    is not supported yet. */
 767
 768 char *
 769 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 770 {
 771     register unsigned char *s, *x;
 772     register unsigned char *big;
 773     register I32 pos;
 774     register I32 previous;
 775     register I32 first;
 776     register unsigned char *little;
 777     register I32 stop_pos;
 778     register unsigned char *littleend;
 779     I32 found = 0;
 780
 781     if (*old_posp == -1
 782         ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
 783         : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
 784       cant_find:
 785         if ( BmRARE(littlestr) == '\n'
 786              && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
 787             little = (unsigned char *)(SvPVX(littlestr));
 788             littleend = little + SvCUR(littlestr);
 789             first = *little++;
 790             goto check_tail;
 791         }
 792         return Nullch;
 793     }
 794
 795     little = (unsigned char *)(SvPVX(littlestr));
 796     littleend = little + SvCUR(littlestr);
 797     first = *little++;
 798     /* The value of pos we can start at: */
 799     previous = BmPREVIOUS(littlestr);
 800     big = (unsigned char *)(SvPVX(bigstr));
 801     /* The value of pos we can stop at: */
 802     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
 803     if (previous + start_shift > stop_pos) {
 804 /*
 805   stop_pos does not include SvTAIL in the count, so this check is incorrect
 806   (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
 807 */
 808 #if 0
 809         if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
 810             goto check_tail;
 811 #endif
 812         return Nullch;
 813     }
 814     while (pos < previous + start_shift) {
 815         if (!(pos += PL_screamnext[pos]))
 816             goto cant_find;
 817     }
 818     big -= previous;
 819     do {
 820         if (pos >= stop_pos) break;
 821         if (big[pos] != first)
 822             continue;
 823         for (x=big+pos+1,s=little; s < littleend; /**/ ) {
 824             if (*s++ != *x++) {
 825                 s--;
 826                 break;
 827             }
 828         }
 829         if (s == littleend) {
 830             *old_posp = pos;
 831             if (!last) return (char *)(big+pos);
 832             found = 1;
 833         }
 834     } while ( pos += PL_screamnext[pos] );
 835     if (last && found)
 836         return (char *)(big+(*old_posp));
 837   check_tail:
 838     if (!SvTAIL(littlestr) || (end_shift > 0))
 839         return Nullch;
 840     /* Ignore the trailing "\n".  This code is not microoptimized */
 841     big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
 842     stop_pos = littleend - little;      /* Actual littlestr len */
 843     if (stop_pos == 0)
 844         return (char*)big;
 845     big -= stop_pos;
 846     if (*big == first
 847         && ((stop_pos == 1) ||
 848             memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
 849         return (char*)big;
 850     return Nullch;
 851 }
 852
 853 I32
 854 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
 855 {
 856     register U8 *a = (U8 *)s1;
 857     register U8 *b = (U8 *)s2;
 858     while (len--) {
 859         if (*a != *b && *a != PL_fold[*b])
 860             return 1;
 861         a++,b++;
 862     }
 863     return 0;
 864 }
 865
 866 I32
 867 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
 868 {
 869     register U8 *a = (U8 *)s1;
 870     register U8 *b = (U8 *)s2;
 871     while (len--) {
 872         if (*a != *b && *a != PL_fold_locale[*b])
 873             return 1;
 874         a++,b++;
 875     }
 876     return 0;
 877 }
 878
 879 /* copy a string to a safe spot */
 880
 881 /*
 882 =head1 Memory Management
 883
 884 =for apidoc savepv
 885
 886 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
 887 string which is a duplicate of C<pv>. The size of the string is
 888 determined by C<strlen()>. The memory allocated for the new string can
 889 be freed with the C<Safefree()> function.
 890
 891 =cut
 892 */
 893
 894 char *
 895 Perl_savepv(pTHX_ const char *pv)
 896 {
 897     register char *newaddr = Nullch;
 898     if (pv) {
 899         New(902,newaddr,strlen(pv)+1,char);
 900         (void)strcpy(newaddr,pv);
 901     }
 902     return newaddr;
 903 }
 904
 905 /* same thing but with a known length */
 906
 907 /*
 908 =for apidoc savepvn
 909
 910 Perl's version of what C<strndup()> would be if it existed. Returns a
 911 pointer to a newly allocated string which is a duplicate of the first
 912 C<len> bytes from C<pv>. The memory allocated for the new string can be
 913 freed with the C<Safefree()> function.
 914
 915 =cut
 916 */
 917
 918 char *
 919 Perl_savepvn(pTHX_ const char *pv, register I32 len)
 920 {
 921     register char *newaddr;
 922
 923     New(903,newaddr,len+1,char);
 924     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
 925     if (pv) {
 926         Copy(pv,newaddr,len,char);      /* might not be null terminated */
 927         newaddr[len] = '\0';            /* is now */
 928     }
 929     else {
 930         Zero(newaddr,len+1,char);
 931     }
 932     return newaddr;
 933 }
 934
 935 /*
 936 =for apidoc savesharedpv
 937
 938 A version of C<savepv()> which allocates the duplicate string in memory
 939 which is shared between threads.
 940
 941 =cut
 942 */
 943 char *
 944 Perl_savesharedpv(pTHX_ const char *pv)
 945 {
 946     register char *newaddr = Nullch;
 947     if (pv) {
 948         newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
 949         (void)strcpy(newaddr,pv);
 950     }
 951     return newaddr;
 952 }
 953
 954
 955
 956 /* the SV for Perl_form() and mess() is not kept in an arena */
 957
 958 STATIC SV *
 959 S_mess_alloc(pTHX)
 960 {
 961     SV *sv;
 962     XPVMG *any;
 963
 964     if (!PL_dirty)
 965         return sv_2mortal(newSVpvn("",0));
 966
 967     if (PL_mess_sv)
 968         return PL_mess_sv;
 969
 970     /* Create as PVMG now, to avoid any upgrading later */
 971     New(905, sv, 1, SV);
 972     Newz(905, any, 1, XPVMG);
 973     SvFLAGS(sv) = SVt_PVMG;
 974     SvANY(sv) = (void*)any;
 975     SvREFCNT(sv) = 1 << 30; /* practically infinite */
 976     PL_mess_sv = sv;
 977     return sv;
 978 }
 979
 980 #if defined(PERL_IMPLICIT_CONTEXT)
 981 char *
 982 Perl_form_nocontext(const char* pat, ...)
 983 {
 984     dTHX;
 985     char *retval;
 986     va_list args;
 987     va_start(args, pat);
 988     retval = vform(pat, &args);
 989     va_end(args);
 990     return retval;
 991 }
 992 #endif /* PERL_IMPLICIT_CONTEXT */
 993
 994 /*
 995 =head1 Miscellaneous Functions
 996 =for apidoc form
 997
 998 Takes a sprintf-style format pattern and conventional
 999 (non-SV) arguments and returns the formatted string.
1000
1001     (char *) Perl_form(pTHX_ const char* pat, ...)
1002
1003 can be used any place a string (char *) is required:
1004
1005     char * s = Perl_form("%d.%d",major,minor);
1006
1007 Uses a single private buffer so if you want to format several strings you
1008 must explicitly copy the earlier strings away (and free the copies when you
1009 are done).
1010
1011 =cut
1012 */
1013
1014 char *
1015 Perl_form(pTHX_ const char* pat, ...)
1016 {
1017     char *retval;
1018     va_list args;
1019     va_start(args, pat);
1020     retval = vform(pat, &args);
1021     va_end(args);
1022     return retval;
1023 }
1024
1025 char *
1026 Perl_vform(pTHX_ const char *pat, va_list *args)
1027 {
1028     SV *sv = mess_alloc();
1029     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1030     return SvPVX(sv);
1031 }
1032
1033 #if defined(PERL_IMPLICIT_CONTEXT)
1034 SV *
1035 Perl_mess_nocontext(const char *pat, ...)
1036 {
1037     dTHX;
1038     SV *retval;
1039     va_list args;
1040     va_start(args, pat);
1041     retval = vmess(pat, &args);
1042     va_end(args);
1043     return retval;
1044 }
1045 #endif /* PERL_IMPLICIT_CONTEXT */
1046
1047 SV *
1048 Perl_mess(pTHX_ const char *pat, ...)
1049 {
1050     SV *retval;
1051     va_list args;
1052     va_start(args, pat);
1053     retval = vmess(pat, &args);
1054     va_end(args);
1055     return retval;
1056 }
1057
1058 STATIC COP*
1059 S_closest_cop(pTHX_ COP *cop, OP *o)
1060 {
1061     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
1062
1063     if (!o || o == PL_op) return cop;
1064
1065     if (o->op_flags & OPf_KIDS) {
1066         OP *kid;
1067         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1068         {
1069             COP *new_cop;
1070
1071             /* If the OP_NEXTSTATE has been optimised away we can still use it
1072              * the get the file and line number. */
1073
1074             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1075                 cop = (COP *)kid;
1076
1077             /* Keep searching, and return when we've found something. */
1078
1079             new_cop = closest_cop(cop, kid);
1080             if (new_cop) return new_cop;
1081         }
1082     }
1083
1084     /* Nothing found. */
1085
1086     return 0;
1087 }
1088
1089 SV *
1090 Perl_vmess(pTHX_ const char *pat, va_list *args)
1091 {
1092     SV *sv = mess_alloc();
1093     static char dgd[] = " during global destruction.\n";
1094     COP *cop;
1095
1096     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1097     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1098
1099         /*
1100          * Try and find the file and line for PL_op.  This will usually be
1101          * PL_curcop, but it might be a cop that has been optimised away.  We
1102          * can try to find such a cop by searching through the optree starting
1103          * from the sibling of PL_curcop.
1104          */
1105
1106         cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1107         if (!cop) cop = PL_curcop;
1108
1109         if (CopLINE(cop))
1110             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1111             OutCopFILE(cop), (IV)CopLINE(cop));
1112         if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
1113             bool line_mode = (RsSIMPLE(PL_rs) &&
1114                               SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1115             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1116                            PL_last_in_gv == PL_argvgv ?
1117                            "" : GvNAME(PL_last_in_gv),
1118                            line_mode ? "line" : "chunk",
1119                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1120         }
1121 #ifdef USE_5005THREADS
1122         if (thr->tid)
1123             Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1124 #endif
1125         sv_catpv(sv, PL_dirty ? dgd : ".\n");
1126     }
1127     return sv;
1128 }
1129
1130 OP *
1131 Perl_vdie(pTHX_ const char* pat, va_list *args)
1132 {
1133     char *message;
1134     int was_in_eval = PL_in_eval;
1135     HV *stash;
1136     GV *gv;
1137     CV *cv;
1138     SV *msv;
1139     STRLEN msglen;
1140
1141     DEBUG_S(PerlIO_printf(Perl_debug_log,
1142                           "%p: die: curstack = %p, mainstack = %p\n",
1143                           thr, PL_curstack, PL_mainstack));
1144
1145     if (pat) {
1146         msv = vmess(pat, args);
1147         if (PL_errors && SvCUR(PL_errors)) {
1148             sv_catsv(PL_errors, msv);
1149             message = SvPV(PL_errors, msglen);
1150             SvCUR_set(PL_errors, 0);
1151         }
1152         else
1153             message = SvPV(msv,msglen);
1154     }
1155     else {
1156         message = Nullch;
1157         msglen = 0;
1158     }
1159
1160     DEBUG_S(PerlIO_printf(Perl_debug_log,
1161                           "%p: die: message = %s\ndiehook = %p\n",
1162                           thr, message, PL_diehook));
1163     if (PL_diehook) {
1164         /* sv_2cv might call Perl_croak() */
1165         SV *olddiehook = PL_diehook;
1166         ENTER;
1167         SAVESPTR(PL_diehook);
1168         PL_diehook = Nullsv;
1169         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1170         LEAVE;
1171         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1172             dSP;
1173             SV *msg;
1174
1175             ENTER;
1176             save_re_context();
1177             if (message) {
1178                 msg = newSVpvn(message, msglen);
1179                 SvREADONLY_on(msg);
1180                 SAVEFREESV(msg);
1181             }
1182             else {
1183                 msg = ERRSV;
1184             }
1185
1186             PUSHSTACKi(PERLSI_DIEHOOK);
1187             PUSHMARK(SP);
1188             XPUSHs(msg);
1189             PUTBACK;
1190             call_sv((SV*)cv, G_DISCARD);
1191             POPSTACK;
1192             LEAVE;
1193         }
1194     }
1195
1196     PL_restartop = die_where(message, msglen);
1197     DEBUG_S(PerlIO_printf(Perl_debug_log,
1198           "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1199           thr, PL_restartop, was_in_eval, PL_top_env));
1200     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1201         JMPENV_JUMP(3);
1202     return PL_restartop;
1203 }
1204
1205 #if defined(PERL_IMPLICIT_CONTEXT)
1206 OP *
1207 Perl_die_nocontext(const char* pat, ...)
1208 {
1209     dTHX;
1210     OP *o;
1211     va_list args;
1212     va_start(args, pat);
1213     o = vdie(pat, &args);
1214     va_end(args);
1215     return o;
1216 }
1217 #endif /* PERL_IMPLICIT_CONTEXT */
1218
1219 OP *
1220 Perl_die(pTHX_ const char* pat, ...)
1221 {
1222     OP *o;
1223     va_list args;
1224     va_start(args, pat);
1225     o = vdie(pat, &args);
1226     va_end(args);
1227     return o;
1228 }
1229
1230 void
1231 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1232 {
1233     char *message;
1234     HV *stash;
1235     GV *gv;
1236     CV *cv;
1237     SV *msv;
1238     STRLEN msglen;
1239
1240     if (pat) {
1241         msv = vmess(pat, args);
1242         if (PL_errors && SvCUR(PL_errors)) {
1243             sv_catsv(PL_errors, msv);
1244             message = SvPV(PL_errors, msglen);
1245             SvCUR_set(PL_errors, 0);
1246         }
1247         else
1248             message = SvPV(msv,msglen);
1249     }
1250     else {
1251         message = Nullch;
1252         msglen = 0;
1253     }
1254
1255     DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1256                           PTR2UV(thr), message));
1257
1258     if (PL_diehook) {
1259         /* sv_2cv might call Perl_croak() */
1260         SV *olddiehook = PL_diehook;
1261         ENTER;
1262         SAVESPTR(PL_diehook);
1263         PL_diehook = Nullsv;
1264         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1265         LEAVE;
1266         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1267             dSP;
1268             SV *msg;
1269
1270             ENTER;
1271             save_re_context();
1272             if (message) {
1273                 msg = newSVpvn(message, msglen);
1274                 SvREADONLY_on(msg);
1275                 SAVEFREESV(msg);
1276             }
1277             else {
1278                 msg = ERRSV;
1279             }
1280
1281             PUSHSTACKi(PERLSI_DIEHOOK);
1282             PUSHMARK(SP);
1283             XPUSHs(msg);
1284             PUTBACK;
1285             call_sv((SV*)cv, G_DISCARD);
1286             POPSTACK;
1287             LEAVE;
1288         }
1289     }
1290     if (PL_in_eval) {
1291         PL_restartop = die_where(message, msglen);
1292         JMPENV_JUMP(3);
1293     }
1294     else if (!message)
1295         message = SvPVx(ERRSV, msglen);
1296
1297     {
1298 #ifdef USE_SFIO
1299         /* SFIO can really mess with your errno */
1300         int e = errno;
1301 #endif
1302         PerlIO *serr = Perl_error_log;
1303
1304         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1305         (void)PerlIO_flush(serr);
1306 #ifdef USE_SFIO
1307         errno = e;
1308 #endif
1309     }
1310     my_failure_exit();
1311 }
1312
1313 #if defined(PERL_IMPLICIT_CONTEXT)
1314 void
1315 Perl_croak_nocontext(const char *pat, ...)
1316 {
1317     dTHX;
1318     va_list args;
1319     va_start(args, pat);
1320     vcroak(pat, &args);
1321     /* NOTREACHED */
1322     va_end(args);
1323 }
1324 #endif /* PERL_IMPLICIT_CONTEXT */
1325
1326 /*
1327 =head1 Warning and Dieing
1328
1329 =for apidoc croak
1330
1331 This is the XSUB-writer's interface to Perl's C<die> function.
1332 Normally use this function the same way you use the C C<printf>
1333 function.  See C<warn>.
1334
1335 If you want to throw an exception object, assign the object to
1336 C<$@> and then pass C<Nullch> to croak():
1337
1338    errsv = get_sv("@", TRUE);
1339    sv_setsv(errsv, exception_object);
1340    croak(Nullch);
1341
1342 =cut
1343 */
1344
1345 void
1346 Perl_croak(pTHX_ const char *pat, ...)
1347 {
1348     va_list args;
1349     va_start(args, pat);
1350     vcroak(pat, &args);
1351     /* NOTREACHED */
1352     va_end(args);
1353 }
1354
1355 void
1356 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1357 {
1358     char *message;
1359     HV *stash;
1360     GV *gv;
1361     CV *cv;
1362     SV *msv;
1363     STRLEN msglen;
1364     IO *io;
1365     MAGIC *mg;
1366
1367     msv = vmess(pat, args);
1368     message = SvPV(msv, msglen);
1369
1370     if (PL_warnhook) {
1371         /* sv_2cv might call Perl_warn() */
1372         SV *oldwarnhook = PL_warnhook;
1373         ENTER;
1374         SAVESPTR(PL_warnhook);
1375         PL_warnhook = Nullsv;
1376         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1377         LEAVE;
1378         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1379             dSP;
1380             SV *msg;
1381
1382             ENTER;
1383             save_re_context();
1384             msg = newSVpvn(message, msglen);
1385             SvREADONLY_on(msg);
1386             SAVEFREESV(msg);
1387
1388             PUSHSTACKi(PERLSI_WARNHOOK);
1389             PUSHMARK(SP);
1390             XPUSHs(msg);
1391             PUTBACK;
1392             call_sv((SV*)cv, G_DISCARD);
1393             POPSTACK;
1394             LEAVE;
1395             return;
1396         }
1397     }
1398
1399     /* if STDERR is tied, use it instead */
1400     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1401         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1402         dSP; ENTER;
1403         PUSHMARK(SP);
1404         XPUSHs(SvTIED_obj((SV*)io, mg));
1405         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1406         PUTBACK;
1407         call_method("PRINT", G_SCALAR);
1408         LEAVE;
1409         return;
1410     }
1411
1412     {
1413         PerlIO *serr = Perl_error_log;
1414
1415         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1416 #ifdef LEAKTEST
1417         DEBUG_L(*message == '!'
1418                 ? (xstat(message[1]=='!'
1419                          ? (message[2]=='!' ? 2 : 1)
1420                          : 0)
1421                    , 0)
1422                 : 0);
1423 #endif
1424         (void)PerlIO_flush(serr);
1425     }
1426 }
1427
1428 #if defined(PERL_IMPLICIT_CONTEXT)
1429 void
1430 Perl_warn_nocontext(const char *pat, ...)
1431 {
1432     dTHX;
1433     va_list args;
1434     va_start(args, pat);
1435     vwarn(pat, &args);
1436     va_end(args);
1437 }
1438 #endif /* PERL_IMPLICIT_CONTEXT */
1439
1440 /*
1441 =for apidoc warn
1442
1443 This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
1444 function the same way you use the C C<printf> function.  See
1445 C<croak>.
1446
1447 =cut
1448 */
1449
1450 void
1451 Perl_warn(pTHX_ const char *pat, ...)
1452 {
1453     va_list args;
1454     va_start(args, pat);
1455     vwarn(pat, &args);
1456     va_end(args);
1457 }
1458
1459 #if defined(PERL_IMPLICIT_CONTEXT)
1460 void
1461 Perl_warner_nocontext(U32 err, const char *pat, ...)
1462 {
1463     dTHX;
1464     va_list args;
1465     va_start(args, pat);
1466     vwarner(err, pat, &args);
1467     va_end(args);
1468 }
1469 #endif /* PERL_IMPLICIT_CONTEXT */
1470
1471 void
1472 Perl_warner(pTHX_ U32  err, const char* pat,...)
1473 {
1474     va_list args;
1475     va_start(args, pat);
1476     vwarner(err, pat, &args);
1477     va_end(args);
1478 }
1479
1480 void
1481 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1482 {
1483     char *message;
1484     HV *stash;
1485     GV *gv;
1486     CV *cv;
1487     SV *msv;
1488     STRLEN msglen;
1489
1490     msv = vmess(pat, args);
1491     message = SvPV(msv, msglen);
1492
1493     if (ckDEAD(err)) {
1494 #ifdef USE_5005THREADS
1495         DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1496 #endif /* USE_5005THREADS */
1497         if (PL_diehook) {
1498             /* sv_2cv might call Perl_croak() */
1499             SV *olddiehook = PL_diehook;
1500             ENTER;
1501             SAVESPTR(PL_diehook);
1502             PL_diehook = Nullsv;
1503             cv = sv_2cv(olddiehook, &stash, &gv, 0);
1504             LEAVE;
1505             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1506                 dSP;
1507                 SV *msg;
1508
1509                 ENTER;
1510                 save_re_context();
1511                 msg = newSVpvn(message, msglen);
1512                 SvREADONLY_on(msg);
1513                 SAVEFREESV(msg);
1514
1515                 PUSHSTACKi(PERLSI_DIEHOOK);
1516                 PUSHMARK(sp);
1517                 XPUSHs(msg);
1518                 PUTBACK;
1519                 call_sv((SV*)cv, G_DISCARD);
1520                 POPSTACK;
1521                 LEAVE;
1522             }
1523         }
1524         if (PL_in_eval) {
1525             PL_restartop = die_where(message, msglen);
1526             JMPENV_JUMP(3);
1527         }
1528         {
1529             PerlIO *serr = Perl_error_log;
1530             PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1531             (void)PerlIO_flush(serr);
1532         }
1533         my_failure_exit();
1534     }
1535     else {
1536         if (PL_warnhook) {
1537             /* sv_2cv might call Perl_warn() */
1538             SV *oldwarnhook = PL_warnhook;
1539             ENTER;
1540             SAVESPTR(PL_warnhook);
1541             PL_warnhook = Nullsv;
1542             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1543             LEAVE;
1544             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1545                 dSP;
1546                 SV *msg;
1547
1548                 ENTER;
1549                 save_re_context();
1550                 msg = newSVpvn(message, msglen);
1551                 SvREADONLY_on(msg);
1552                 SAVEFREESV(msg);
1553
1554                 PUSHSTACKi(PERLSI_WARNHOOK);
1555                 PUSHMARK(sp);
1556                 XPUSHs(msg);
1557                 PUTBACK;
1558                 call_sv((SV*)cv, G_DISCARD);
1559                 POPSTACK;
1560                 LEAVE;
1561                 return;
1562             }
1563         }
1564         {
1565             PerlIO *serr = Perl_error_log;
1566             PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1567 #ifdef LEAKTEST
1568             DEBUG_L(*message == '!'
1569                 ? (xstat(message[1]=='!'
1570                         ? (message[2]=='!' ? 2 : 1)
1571                         : 0)
1572                     , 0)
1573                 : 0);
1574 #endif
1575             (void)PerlIO_flush(serr);
1576         }
1577     }
1578 }
1579
1580 /* since we've already done strlen() for both nam and val
1581  * we can use that info to make things faster than
1582  * sprintf(s, "%s=%s", nam, val)
1583  */
1584 #define my_setenv_format(s, nam, nlen, val, vlen) \
1585    Copy(nam, s, nlen, char); \
1586    *(s+nlen) = '='; \
1587    Copy(val, s+(nlen+1), vlen, char); \
1588    *(s+(nlen+1+vlen)) = '\0'
1589
1590 #ifdef USE_ENVIRON_ARRAY
1591        /* VMS' my_setenv() is in vms.c */
1592 #if !defined(WIN32) && !defined(NETWARE)
1593 void
1594 Perl_my_setenv(pTHX_ char *nam, char *val)
1595 {
1596 #ifdef USE_ITHREADS
1597   /* only parent thread can modify process environment */
1598   if (PL_curinterp == aTHX)
1599 #endif
1600   {
1601 #ifndef PERL_USE_SAFE_PUTENV
1602     /* most putenv()s leak, so we manipulate environ directly */
1603     register I32 i=setenv_getix(nam);           /* where does it go? */
1604     int nlen, vlen;
1605
1606     if (environ == PL_origenviron) {    /* need we copy environment? */
1607         I32 j;
1608         I32 max;
1609         char **tmpenv;
1610
1611         /*SUPPRESS 530*/
1612         for (max = i; environ[max]; max++) ;
1613         tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1614         for (j=0; j<max; j++) {         /* copy environment */
1615             int len = strlen(environ[j]);
1616             tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1617             Copy(environ[j], tmpenv[j], len+1, char);
1618         }
1619         tmpenv[max] = Nullch;
1620         environ = tmpenv;               /* tell exec where it is now */
1621     }
1622     if (!val) {
1623         safesysfree(environ[i]);
1624         while (environ[i]) {
1625             environ[i] = environ[i+1];
1626             i++;
1627         }
1628         return;
1629     }
1630     if (!environ[i]) {                  /* does not exist yet */
1631         environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1632         environ[i+1] = Nullch;  /* make sure it's null terminated */
1633     }
1634     else
1635         safesysfree(environ[i]);
1636     nlen = strlen(nam);
1637     vlen = strlen(val);
1638
1639     environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1640     /* all that work just for this */
1641     my_setenv_format(environ[i], nam, nlen, val, vlen);
1642
1643 #else   /* PERL_USE_SAFE_PUTENV */
1644 #   if defined(__CYGWIN__) || defined( EPOC)
1645     setenv(nam, val, 1);
1646 #   else
1647     char *new_env;
1648     int nlen = strlen(nam), vlen;
1649     if (!val) {
1650         val = "";
1651     }
1652     vlen = strlen(val);
1653     new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1654     /* all that work just for this */
1655     my_setenv_format(new_env, nam, nlen, val, vlen);
1656     (void)putenv(new_env);
1657 #   endif /* __CYGWIN__ */
1658 #endif  /* PERL_USE_SAFE_PUTENV */
1659   }
1660 }
1661
1662 #else /* WIN32 || NETWARE */
1663
1664 void
1665 Perl_my_setenv(pTHX_ char *nam,char *val)
1666 {
1667     register char *envstr;
1668     int nlen = strlen(nam), vlen;
1669
1670     if (!val) {
1671         val = "";
1672     }
1673     vlen = strlen(val);
1674     New(904, envstr, nlen+vlen+2, char);
1675     my_setenv_format(envstr, nam, nlen, val, vlen);
1676     (void)PerlEnv_putenv(envstr);
1677     Safefree(envstr);
1678 }
1679
1680 #endif /* WIN32 || NETWARE */
1681
1682 I32
1683 Perl_setenv_getix(pTHX_ char *nam)
1684 {
1685     register I32 i, len = strlen(nam);
1686
1687     for (i = 0; environ[i]; i++) {
1688         if (
1689 #ifdef WIN32
1690             strnicmp(environ[i],nam,len) == 0
1691 #else
1692             strnEQ(environ[i],nam,len)
1693 #endif
1694             && environ[i][len] == '=')
1695             break;                      /* strnEQ must come first to avoid */
1696     }                                   /* potential SEGV's */
1697     return i;
1698 }
1699
1700 #endif /* !VMS && !EPOC*/
1701
1702 #ifdef UNLINK_ALL_VERSIONS
1703 I32
1704 Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1705 {
1706     I32 i;
1707
1708     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1709     return i ? 0 : -1;
1710 }
1711 #endif
1712
1713 /* this is a drop-in replacement for bcopy() */
1714 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1715 char *
1716 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1717 {
1718     char *retval = to;
1719
1720     if (from - to >= 0) {
1721         while (len--)
1722             *to++ = *from++;
1723     }
1724     else {
1725         to += len;
1726         from += len;
1727         while (len--)
1728             *(--to) = *(--from);
1729     }
1730     return retval;
1731 }
1732 #endif
1733
1734 /* this is a drop-in replacement for memset() */
1735 #ifndef HAS_MEMSET
1736 void *
1737 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1738 {
1739     char *retval = loc;
1740
1741     while (len--)
1742         *loc++ = ch;
1743     return retval;
1744 }
1745 #endif
1746
1747 /* this is a drop-in replacement for bzero() */
1748 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1749 char *
1750 Perl_my_bzero(register char *loc, register I32 len)
1751 {
1752     char *retval = loc;
1753
1754     while (len--)
1755         *loc++ = 0;
1756     return retval;
1757 }
1758 #endif
1759
1760 /* this is a drop-in replacement for memcmp() */
1761 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1762 I32
1763 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1764 {
1765     register U8 *a = (U8 *)s1;
1766     register U8 *b = (U8 *)s2;
1767     register I32 tmp;
1768
1769     while (len--) {
1770         if (tmp = *a++ - *b++)
1771             return tmp;
1772     }
1773     return 0;
1774 }
1775 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1776
1777 #ifndef HAS_VPRINTF
1778
1779 #ifdef USE_CHAR_VSPRINTF
1780 char *
1781 #else
1782 int
1783 #endif
1784 vsprintf(char *dest, const char *pat, char *args)
1785 {
1786     FILE fakebuf;
1787
1788     fakebuf._ptr = dest;
1789     fakebuf._cnt = 32767;
1790 #ifndef _IOSTRG
1791 #define _IOSTRG 0
1792 #endif
1793     fakebuf._flag = _IOWRT|_IOSTRG;
1794     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1795     (void)putc('\0', &fakebuf);
1796 #ifdef USE_CHAR_VSPRINTF
1797     return(dest);
1798 #else
1799     return 0;           /* perl doesn't use return value */
1800 #endif
1801 }
1802
1803 #endif /* HAS_VPRINTF */
1804
1805 #ifdef MYSWAP
1806 #if BYTEORDER != 0x4321
1807 short
1808 Perl_my_swap(pTHX_ short s)
1809 {
1810 #if (BYTEORDER & 1) == 0
1811     short result;
1812
1813     result = ((s & 255) << 8) + ((s >> 8) & 255);
1814     return result;
1815 #else
1816     return s;
1817 #endif
1818 }
1819
1820 long
1821 Perl_my_htonl(pTHX_ long l)
1822 {
1823     union {
1824         long result;
1825         char c[sizeof(long)];
1826     } u;
1827
1828 #if BYTEORDER == 0x1234
1829     u.c[0] = (l >> 24) & 255;
1830     u.c[1] = (l >> 16) & 255;
1831     u.c[2] = (l >> 8) & 255;
1832     u.c[3] = l & 255;
1833     return u.result;
1834 #else
1835 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1836     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1837 #else
1838     register I32 o;
1839     register I32 s;
1840
1841     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1842         u.c[o & 0xf] = (l >> s) & 255;
1843     }
1844     return u.result;
1845 #endif
1846 #endif
1847 }
1848
1849 long
1850 Perl_my_ntohl(pTHX_ long l)
1851 {
1852     union {
1853         long l;
1854         char c[sizeof(long)];
1855     } u;
1856
1857 #if BYTEORDER == 0x1234
1858     u.c[0] = (l >> 24) & 255;
1859     u.c[1] = (l >> 16) & 255;
1860     u.c[2] = (l >> 8) & 255;
1861     u.c[3] = l & 255;
1862     return u.l;
1863 #else
1864 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1865     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1866 #else
1867     register I32 o;
1868     register I32 s;
1869
1870     u.l = l;
1871     l = 0;
1872     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1873         l |= (u.c[o & 0xf] & 255) << s;
1874     }
1875     return l;
1876 #endif
1877 #endif
1878 }
1879
1880 #endif /* BYTEORDER != 0x4321 */
1881 #endif /* MYSWAP */
1882
1883 /*
1884  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1885  * If these functions are defined,
1886  * the BYTEORDER is neither 0x1234 nor 0x4321.
1887  * However, this is not assumed.
1888  * -DWS
1889  */
1890
1891 #define HTOV(name,type)                                         \
1892         type                                                    \
1893         name (register type n)                                  \
1894         {                                                       \
1895             union {                                             \
1896                 type value;                                     \
1897                 char c[sizeof(type)];                           \
1898             } u;                                                \
1899             register I32 i;                                     \
1900             register I32 s;                                     \
1901             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1902                 u.c[i] = (n >> s) & 0xFF;                       \
1903             }                                                   \
1904             return u.value;                                     \
1905         }
1906
1907 #define VTOH(name,type)                                         \
1908         type                                                    \
1909         name (register type n)                                  \
1910         {                                                       \
1911             union {                                             \
1912                 type value;                                     \
1913                 char c[sizeof(type)];                           \
1914             } u;                                                \
1915             register I32 i;                                     \
1916             register I32 s;                                     \
1917             u.value = n;                                        \
1918             n = 0;                                              \
1919             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1920                 n += (u.c[i] & 0xFF) << s;                      \
1921             }                                                   \
1922             return n;                                           \
1923         }
1924
1925 #if defined(HAS_HTOVS) && !defined(htovs)
1926 HTOV(htovs,short)
1927 #endif
1928 #if defined(HAS_HTOVL) && !defined(htovl)
1929 HTOV(htovl,long)
1930 #endif
1931 #if defined(HAS_VTOHS) && !defined(vtohs)
1932 VTOH(vtohs,short)
1933 #endif
1934 #if defined(HAS_VTOHL) && !defined(vtohl)
1935 VTOH(vtohl,long)
1936 #endif
1937
1938 PerlIO *
1939 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1940 {
1941 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1942     int p[2];
1943     register I32 This, that;
1944     register Pid_t pid;
1945     SV *sv;
1946     I32 did_pipes = 0;
1947     int pp[2];
1948
1949     PERL_FLUSHALL_FOR_CHILD;
1950     This = (*mode == 'w');
1951     that = !This;
1952     if (PL_tainting) {
1953         taint_env();
1954         taint_proper("Insecure %s%s", "EXEC");
1955     }
1956     if (PerlProc_pipe(p) < 0)
1957         return Nullfp;
1958     /* Try for another pipe pair for error return */
1959     if (PerlProc_pipe(pp) >= 0)
1960         did_pipes = 1;
1961     while ((pid = PerlProc_fork()) < 0) {
1962         if (errno != EAGAIN) {
1963             PerlLIO_close(p[This]);
1964             PerlLIO_close(p[that]);
1965             if (did_pipes) {
1966                 PerlLIO_close(pp[0]);
1967                 PerlLIO_close(pp[1]);
1968             }
1969             return Nullfp;
1970         }
1971         sleep(5);
1972     }
1973     if (pid == 0) {
1974         /* Child */
1975 #undef THIS
1976 #undef THAT
1977 #define THIS that
1978 #define THAT This
1979         /* Close parent's end of error status pipe (if any) */
1980         if (did_pipes) {
1981             PerlLIO_close(pp[0]);
1982 #if defined(HAS_FCNTL) && defined(F_SETFD)
1983             /* Close error pipe automatically if exec works */
1984             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1985 #endif
1986         }
1987         /* Now dup our end of _the_ pipe to right position */
1988         if (p[THIS] != (*mode == 'r')) {
1989             PerlLIO_dup2(p[THIS], *mode == 'r');
1990             PerlLIO_close(p[THIS]);
1991             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1992                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1993         }
1994         else
1995             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
1996 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1997         /* No automatic close - do it by hand */
1998 #  ifndef NOFILE
1999 #  define NOFILE 20
2000 #  endif
2001         {
2002             int fd;
2003
2004             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2005                 if (fd != pp[1])
2006                     PerlLIO_close(fd);
2007             }
2008         }
2009 #endif
2010         do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2011         PerlProc__exit(1);
2012 #undef THIS
2013 #undef THAT
2014     }
2015     /* Parent */
2016     do_execfree();      /* free any memory malloced by child on fork */
2017     if (did_pipes)
2018         PerlLIO_close(pp[1]);
2019     /* Keep the lower of the two fd numbers */
2020     if (p[that] < p[This]) {
2021         PerlLIO_dup2(p[This], p[that]);
2022         PerlLIO_close(p[This]);
2023         p[This] = p[that];
2024     }
2025     else
2026         PerlLIO_close(p[that]);         /* close child's end of pipe */
2027
2028     LOCK_FDPID_MUTEX;
2029     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2030     UNLOCK_FDPID_MUTEX;
2031     (void)SvUPGRADE(sv,SVt_IV);
2032     SvIVX(sv) = pid;
2033     PL_forkprocess = pid;
2034     /* If we managed to get status pipe check for exec fail */
2035     if (did_pipes && pid > 0) {
2036         int errkid;
2037         int n = 0, n1;
2038
2039         while (n < sizeof(int)) {
2040             n1 = PerlLIO_read(pp[0],
2041                               (void*)(((char*)&errkid)+n),
2042                               (sizeof(int)) - n);
2043             if (n1 <= 0)
2044                 break;
2045             n += n1;
2046         }
2047         PerlLIO_close(pp[0]);
2048         did_pipes = 0;
2049         if (n) {                        /* Error */
2050             int pid2, status;
2051             PerlLIO_close(p[This]);
2052             if (n != sizeof(int))
2053                 Perl_croak(aTHX_ "panic: kid popen errno read");
2054             do {
2055                 pid2 = wait4pid(pid, &status, 0);
2056             } while (pid2 == -1 && errno == EINTR);
2057             errno = errkid;             /* Propagate errno from kid */
2058             return Nullfp;
2059         }
2060     }
2061     if (did_pipes)
2062          PerlLIO_close(pp[0]);
2063     return PerlIO_fdopen(p[This], mode);
2064 #else
2065     Perl_croak(aTHX_ "List form of piped open not implemented");
2066     return (PerlIO *) NULL;
2067 #endif
2068 }
2069
2070     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2071 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2072 PerlIO *
2073 Perl_my_popen(pTHX_ char *cmd, char *mode)
2074 {
2075     int p[2];
2076     register I32 This, that;
2077     register Pid_t pid;
2078     SV *sv;
2079     I32 doexec = strNE(cmd,"-");
2080     I32 did_pipes = 0;
2081     int pp[2];
2082
2083     PERL_FLUSHALL_FOR_CHILD;
2084 #ifdef OS2
2085     if (doexec) {
2086         return my_syspopen(aTHX_ cmd,mode);
2087     }
2088 #endif
2089     This = (*mode == 'w');
2090     that = !This;
2091     if (doexec && PL_tainting) {
2092         taint_env();
2093         taint_proper("Insecure %s%s", "EXEC");
2094     }
2095     if (PerlProc_pipe(p) < 0)
2096         return Nullfp;
2097     if (doexec && PerlProc_pipe(pp) >= 0)
2098         did_pipes = 1;
2099     while ((pid = PerlProc_fork()) < 0) {
2100         if (errno != EAGAIN) {
2101             PerlLIO_close(p[This]);
2102             PerlLIO_close(p[that]);
2103             if (did_pipes) {
2104                 PerlLIO_close(pp[0]);
2105                 PerlLIO_close(pp[1]);
2106             }
2107             if (!doexec)
2108                 Perl_croak(aTHX_ "Can't fork");
2109             return Nullfp;
2110         }
2111         sleep(5);
2112     }
2113     if (pid == 0) {
2114         GV* tmpgv;
2115
2116 #undef THIS
2117 #undef THAT
2118 #define THIS that
2119 #define THAT This
2120         if (did_pipes) {
2121             PerlLIO_close(pp[0]);
2122 #if defined(HAS_FCNTL) && defined(F_SETFD)
2123             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2124 #endif
2125         }
2126         if (p[THIS] != (*mode == 'r')) {
2127             PerlLIO_dup2(p[THIS], *mode == 'r');
2128             PerlLIO_close(p[THIS]);
2129             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2130                 PerlLIO_close(p[THAT]);
2131         }
2132         else
2133             PerlLIO_close(p[THAT]);
2134 #ifndef OS2
2135         if (doexec) {
2136 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2137             int fd;
2138
2139 #ifndef NOFILE
2140 #define NOFILE 20
2141 #endif
2142             {
2143                 int fd;
2144
2145                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2146                     if (fd != pp[1])
2147                         PerlLIO_close(fd);
2148             }
2149 #endif
2150             /* may or may not use the shell */
2151             do_exec3(cmd, pp[1], did_pipes);
2152             PerlProc__exit(1);
2153         }
2154 #endif  /* defined OS2 */
2155         /*SUPPRESS 560*/
2156         if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2157             SvREADONLY_off(GvSV(tmpgv));
2158             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2159             SvREADONLY_on(GvSV(tmpgv));
2160         }
2161 #ifdef THREADS_HAVE_PIDS
2162         PL_ppid = (IV)getppid();
2163 #endif
2164         PL_forkprocess = 0;
2165         hv_clear(PL_pidstatus); /* we have no children */
2166         return Nullfp;
2167 #undef THIS
2168 #undef THAT
2169     }
2170     do_execfree();      /* free any memory malloced by child on vfork */
2171     if (did_pipes)
2172         PerlLIO_close(pp[1]);
2173     if (p[that] < p[This]) {
2174         PerlLIO_dup2(p[This], p[that]);
2175         PerlLIO_close(p[This]);
2176         p[This] = p[that];
2177     }
2178     else
2179         PerlLIO_close(p[that]);
2180
2181     LOCK_FDPID_MUTEX;
2182     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2183     UNLOCK_FDPID_MUTEX;
2184     (void)SvUPGRADE(sv,SVt_IV);
2185     SvIVX(sv) = pid;
2186     PL_forkprocess = pid;
2187     if (did_pipes && pid > 0) {
2188         int errkid;
2189         int n = 0, n1;
2190
2191         while (n < sizeof(int)) {
2192             n1 = PerlLIO_read(pp[0],
2193                               (void*)(((char*)&errkid)+n),
2194                               (sizeof(int)) - n);
2195             if (n1 <= 0)
2196                 break;
2197             n += n1;
2198         }
2199         PerlLIO_close(pp[0]);
2200         did_pipes = 0;
2201         if (n) {                        /* Error */
2202             int pid2, status;
2203             PerlLIO_close(p[This]);
2204             if (n != sizeof(int))
2205                 Perl_croak(aTHX_ "panic: kid popen errno read");
2206             do {
2207                 pid2 = wait4pid(pid, &status, 0);
2208             } while (pid2 == -1 && errno == EINTR);
2209             errno = errkid;             /* Propagate errno from kid */
2210             return Nullfp;
2211         }
2212     }
2213     if (did_pipes)
2214          PerlLIO_close(pp[0]);
2215     return PerlIO_fdopen(p[This], mode);
2216 }
2217 #else
2218 #if defined(atarist) || defined(EPOC)
2219 FILE *popen();
2220 PerlIO *
2221 Perl_my_popen(pTHX_ char *cmd, char *mode)
2222 {
2223     PERL_FLUSHALL_FOR_CHILD;
2224     /* Call system's popen() to get a FILE *, then import it.
2225        used 0 for 2nd parameter to PerlIO_importFILE;
2226        apparently not used
2227     */
2228     return PerlIO_importFILE(popen(cmd, mode), 0);
2229 }
2230 #else
2231 #if defined(DJGPP)
2232 FILE *djgpp_popen();
2233 PerlIO *
2234 Perl_my_popen(pTHX_ char *cmd, char *mode)
2235 {
2236     PERL_FLUSHALL_FOR_CHILD;
2237     /* Call system's popen() to get a FILE *, then import it.
2238        used 0 for 2nd parameter to PerlIO_importFILE;
2239        apparently not used
2240     */
2241     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2242 }
2243 #endif
2244 #endif
2245
2246 #endif /* !DOSISH */
2247
2248 /* this is called in parent before the fork() */
2249 void
2250 Perl_atfork_lock(void)
2251 {
2252 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2253     /* locks must be held in locking order (if any) */
2254 #  ifdef MYMALLOC
2255     MUTEX_LOCK(&PL_malloc_mutex);
2256 #  endif
2257     OP_REFCNT_LOCK;
2258 #endif
2259 }
2260
2261 /* this is called in both parent and child after the fork() */
2262 void
2263 Perl_atfork_unlock(void)
2264 {
2265 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2266     /* locks must be released in same order as in atfork_lock() */
2267 #  ifdef MYMALLOC
2268     MUTEX_UNLOCK(&PL_malloc_mutex);
2269 #  endif
2270     OP_REFCNT_UNLOCK;
2271 #endif
2272 }
2273
2274 Pid_t
2275 Perl_my_fork(void)
2276 {
2277 #if defined(HAS_FORK)
2278     Pid_t pid;
2279 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2280     atfork_lock();
2281     pid = fork();
2282     atfork_unlock();
2283 #else
2284     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2285      * handlers elsewhere in the code */
2286     pid = fork();
2287 #endif
2288     return pid;
2289 #else
2290     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2291     Perl_croak_nocontext("fork() not available");
2292     return 0;
2293 #endif /* HAS_FORK */
2294 }
2295
2296 #ifdef DUMP_FDS
2297 void
2298 Perl_dump_fds(pTHX_ char *s)
2299 {
2300     int fd;
2301     Stat_t tmpstatbuf;
2302
2303     PerlIO_printf(Perl_debug_log,"%s", s);
2304     for (fd = 0; fd < 32; fd++) {
2305         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2306             PerlIO_printf(Perl_debug_log," %d",fd);
2307     }
2308     PerlIO_printf(Perl_debug_log,"\n");
2309 }
2310 #endif  /* DUMP_FDS */
2311
2312 #ifndef HAS_DUP2
2313 int
2314 dup2(int oldfd, int newfd)
2315 {
2316 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2317     if (oldfd == newfd)
2318         return oldfd;
2319     PerlLIO_close(newfd);
2320     return fcntl(oldfd, F_DUPFD, newfd);
2321 #else
2322 #define DUP2_MAX_FDS 256
2323     int fdtmp[DUP2_MAX_FDS];
2324     I32 fdx = 0;
2325     int fd;
2326
2327     if (oldfd == newfd)
2328         return oldfd;
2329     PerlLIO_close(newfd);
2330     /* good enough for low fd's... */
2331     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2332         if (fdx >= DUP2_MAX_FDS) {
2333             PerlLIO_close(fd);
2334             fd = -1;
2335             break;
2336         }
2337         fdtmp[fdx++] = fd;
2338     }
2339     while (fdx > 0)
2340         PerlLIO_close(fdtmp[--fdx]);
2341     return fd;
2342 #endif
2343 }
2344 #endif
2345
2346 #ifndef PERL_MICRO
2347 #ifdef HAS_SIGACTION
2348
2349 Sighandler_t
2350 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2351 {
2352     struct sigaction act, oact;
2353
2354 #ifdef USE_ITHREADS
2355     /* only "parent" interpreter can diddle signals */
2356     if (PL_curinterp != aTHX)
2357         return SIG_ERR;
2358 #endif
2359
2360     act.sa_handler = handler;
2361     sigemptyset(&act.sa_mask);
2362     act.sa_flags = 0;
2363 #ifdef SA_RESTART
2364 #if defined(PERL_OLD_SIGNALS)
2365     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2366 #endif
2367 #endif
2368 #ifdef SA_NOCLDWAIT
2369     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2370         act.sa_flags |= SA_NOCLDWAIT;
2371 #endif
2372     if (sigaction(signo, &act, &oact) == -1)
2373         return SIG_ERR;
2374     else
2375         return oact.sa_handler;
2376 }
2377
2378 Sighandler_t
2379 Perl_rsignal_state(pTHX_ int signo)
2380 {
2381     struct sigaction oact;
2382
2383     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2384         return SIG_ERR;
2385     else
2386         return oact.sa_handler;
2387 }
2388
2389 int
2390 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2391 {
2392     struct sigaction act;
2393
2394 #ifdef USE_ITHREADS
2395     /* only "parent" interpreter can diddle signals */
2396     if (PL_curinterp != aTHX)
2397         return -1;
2398 #endif
2399
2400     act.sa_handler = handler;
2401     sigemptyset(&act.sa_mask);
2402     act.sa_flags = 0;
2403 #ifdef SA_RESTART
2404 #if defined(PERL_OLD_SIGNALS)
2405     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2406 #endif
2407 #endif
2408 #ifdef SA_NOCLDWAIT
2409     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2410         act.sa_flags |= SA_NOCLDWAIT;
2411 #endif
2412     return sigaction(signo, &act, save);
2413 }
2414
2415 int
2416 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2417 {
2418 #ifdef USE_ITHREADS
2419     /* only "parent" interpreter can diddle signals */
2420     if (PL_curinterp != aTHX)
2421         return -1;
2422 #endif
2423
2424     return sigaction(signo, save, (struct sigaction *)NULL);
2425 }
2426
2427 #else /* !HAS_SIGACTION */
2428
2429 Sighandler_t
2430 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2431 {
2432 #if defined(USE_ITHREADS) && !defined(WIN32)
2433     /* only "parent" interpreter can diddle signals */
2434     if (PL_curinterp != aTHX)
2435         return SIG_ERR;
2436 #endif
2437
2438     return PerlProc_signal(signo, handler);
2439 }
2440
2441 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2442                            ignore the implications of this for threading */
2443
2444 static
2445 Signal_t
2446 sig_trap(int signo)
2447 {
2448     sig_trapped++;
2449 }
2450
2451 Sighandler_t
2452 Perl_rsignal_state(pTHX_ int signo)
2453 {
2454     Sighandler_t oldsig;
2455
2456 #if defined(USE_ITHREADS) && !defined(WIN32)
2457     /* only "parent" interpreter can diddle signals */
2458     if (PL_curinterp != aTHX)
2459         return SIG_ERR;
2460 #endif
2461
2462     sig_trapped = 0;
2463     oldsig = PerlProc_signal(signo, sig_trap);
2464     PerlProc_signal(signo, oldsig);
2465     if (sig_trapped)
2466         PerlProc_kill(PerlProc_getpid(), signo);
2467     return oldsig;
2468 }
2469
2470 int
2471 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2472 {
2473 #if defined(USE_ITHREADS) && !defined(WIN32)
2474     /* only "parent" interpreter can diddle signals */
2475     if (PL_curinterp != aTHX)
2476         return -1;
2477 #endif
2478     *save = PerlProc_signal(signo, handler);
2479     return (*save == SIG_ERR) ? -1 : 0;
2480 }
2481
2482 int
2483 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2484 {
2485 #if defined(USE_ITHREADS) && !defined(WIN32)
2486     /* only "parent" interpreter can diddle signals */
2487     if (PL_curinterp != aTHX)
2488         return -1;
2489 #endif
2490     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2491 }
2492
2493 #endif /* !HAS_SIGACTION */
2494 #endif /* !PERL_MICRO */
2495
2496     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2497 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2498 I32
2499 Perl_my_pclose(pTHX_ PerlIO *ptr)
2500 {
2501     Sigsave_t hstat, istat, qstat;
2502     int status;
2503     SV **svp;
2504     Pid_t pid;
2505     Pid_t pid2;
2506     bool close_failed;
2507     int saved_errno = 0;
2508 #ifdef VMS
2509     int saved_vaxc_errno;
2510 #endif
2511 #ifdef WIN32
2512     int saved_win32_errno;
2513 #endif
2514
2515     LOCK_FDPID_MUTEX;
2516     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2517     UNLOCK_FDPID_MUTEX;
2518     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2519     SvREFCNT_dec(*svp);
2520     *svp = &PL_sv_undef;
2521 #ifdef OS2
2522     if (pid == -1) {                    /* Opened by popen. */
2523         return my_syspclose(ptr);
2524     }
2525 #endif
2526     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2527         saved_errno = errno;
2528 #ifdef VMS
2529         saved_vaxc_errno = vaxc$errno;
2530 #endif
2531 #ifdef WIN32
2532         saved_win32_errno = GetLastError();
2533 #endif
2534     }
2535 #ifdef UTS
2536     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2537 #endif
2538 #ifndef PERL_MICRO
2539     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2540     rsignal_save(SIGINT, SIG_IGN, &istat);
2541     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2542 #endif
2543     do {
2544         pid2 = wait4pid(pid, &status, 0);
2545     } while (pid2 == -1 && errno == EINTR);
2546 #ifndef PERL_MICRO
2547     rsignal_restore(SIGHUP, &hstat);
2548     rsignal_restore(SIGINT, &istat);
2549     rsignal_restore(SIGQUIT, &qstat);
2550 #endif
2551     if (close_failed) {
2552         SETERRNO(saved_errno, saved_vaxc_errno);
2553         return -1;
2554     }
2555     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2556 }
2557 #endif /* !DOSISH */
2558
2559 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2560 I32
2561 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2562 {
2563     I32 result;
2564     if (!pid)
2565         return -1;
2566 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2567     {
2568         SV *sv;
2569         SV** svp;
2570         char spid[TYPE_CHARS(int)];
2571
2572         if (pid > 0) {
2573             sprintf(spid, "%"IVdf, (IV)pid);
2574             svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2575             if (svp && *svp != &PL_sv_undef) {
2576                 *statusp = SvIVX(*svp);
2577                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2578                 return pid;
2579             }
2580         }
2581         else {
2582             HE *entry;
2583
2584             hv_iterinit(PL_pidstatus);
2585             if ((entry = hv_iternext(PL_pidstatus))) {
2586                 SV *sv;
2587                 char spid[TYPE_CHARS(int)];
2588
2589                 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2590                 sv = hv_iterval(PL_pidstatus,entry);
2591                 *statusp = SvIVX(sv);
2592                 sprintf(spid, "%"IVdf, (IV)pid);
2593                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2594                 return pid;
2595             }
2596         }
2597     }
2598 #endif
2599 #ifdef HAS_WAITPID
2600 #  ifdef HAS_WAITPID_RUNTIME
2601     if (!HAS_WAITPID_RUNTIME)
2602         goto hard_way;
2603 #  endif
2604     result = PerlProc_waitpid(pid,statusp,flags);
2605     goto finish;
2606 #endif
2607 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2608     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2609     goto finish;
2610 #endif
2611 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2612   hard_way:
2613     {
2614         if (flags)
2615             Perl_croak(aTHX_ "Can't do waitpid with flags");
2616         else {
2617             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2618                 pidgone(result,*statusp);
2619             if (result < 0)
2620                 *statusp = -1;
2621         }
2622     }
2623 #endif
2624   finish:
2625     if (result < 0 && errno == EINTR) {
2626         PERL_ASYNC_CHECK();
2627     }
2628     return result;
2629 }
2630 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2631
2632 void
2633 /*SUPPRESS 590*/
2634 Perl_pidgone(pTHX_ Pid_t pid, int status)
2635 {
2636     register SV *sv;
2637     char spid[TYPE_CHARS(int)];
2638
2639     sprintf(spid, "%"IVdf, (IV)pid);
2640     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2641     (void)SvUPGRADE(sv,SVt_IV);
2642     SvIVX(sv) = status;
2643     return;
2644 }
2645
2646 #if defined(atarist) || defined(OS2) || defined(EPOC)
2647 int pclose();
2648 #ifdef HAS_FORK
2649 int                                     /* Cannot prototype with I32
2650                                            in os2ish.h. */
2651 my_syspclose(PerlIO *ptr)
2652 #else
2653 I32
2654 Perl_my_pclose(pTHX_ PerlIO *ptr)
2655 #endif
2656 {
2657     /* Needs work for PerlIO ! */
2658     FILE *f = PerlIO_findFILE(ptr);
2659     I32 result = pclose(f);
2660     PerlIO_releaseFILE(ptr,f);
2661     return result;
2662 }
2663 #endif
2664
2665 #if defined(DJGPP)
2666 int djgpp_pclose();
2667 I32
2668 Perl_my_pclose(pTHX_ PerlIO *ptr)
2669 {
2670     /* Needs work for PerlIO ! */
2671     FILE *f = PerlIO_findFILE(ptr);
2672     I32 result = djgpp_pclose(f);
2673     result = (result << 8) & 0xff00;
2674     PerlIO_releaseFILE(ptr,f);
2675     return result;
2676 }
2677 #endif
2678
2679 void
2680 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2681 {
2682     register I32 todo;
2683     register const char *frombase = from;
2684
2685     if (len == 1) {
2686         register const char c = *from;
2687         while (count-- > 0)
2688             *to++ = c;
2689         return;
2690     }
2691     while (count-- > 0) {
2692         for (todo = len; todo > 0; todo--) {
2693             *to++ = *from++;
2694         }
2695         from = frombase;
2696     }
2697 }
2698
2699 #ifndef HAS_RENAME
2700 I32
2701 Perl_same_dirent(pTHX_ char *a, char *b)
2702 {
2703     char *fa = strrchr(a,'/');
2704     char *fb = strrchr(b,'/');
2705     Stat_t tmpstatbuf1;
2706     Stat_t tmpstatbuf2;
2707     SV *tmpsv = sv_newmortal();
2708
2709     if (fa)
2710         fa++;
2711     else
2712         fa = a;
2713     if (fb)
2714         fb++;
2715     else
2716         fb = b;
2717     if (strNE(a,b))
2718         return FALSE;
2719     if (fa == a)
2720         sv_setpv(tmpsv, ".");
2721     else
2722         sv_setpvn(tmpsv, a, fa - a);
2723     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2724         return FALSE;
2725     if (fb == b)
2726         sv_setpv(tmpsv, ".");
2727     else
2728         sv_setpvn(tmpsv, b, fb - b);
2729     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2730         return FALSE;
2731     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2732            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2733 }
2734 #endif /* !HAS_RENAME */
2735
2736 char*
2737 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2738 {
2739     char *xfound = Nullch;
2740     char *xfailed = Nullch;
2741     char tmpbuf[MAXPATHLEN];
2742     register char *s;
2743     I32 len = 0;
2744     int retval;
2745 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2746 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2747 #  define MAX_EXT_LEN 4
2748 #endif
2749 #ifdef OS2
2750 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2751 #  define MAX_EXT_LEN 4
2752 #endif
2753 #ifdef VMS
2754 #  define SEARCH_EXTS ".pl", ".com", NULL
2755 #  define MAX_EXT_LEN 4
2756 #endif
2757     /* additional extensions to try in each dir if scriptname not found */
2758 #ifdef SEARCH_EXTS
2759     char *exts[] = { SEARCH_EXTS };
2760     char **ext = search_ext ? search_ext : exts;
2761     int extidx = 0, i = 0;
2762     char *curext = Nullch;
2763 #else
2764 #  define MAX_EXT_LEN 0
2765 #endif
2766
2767     /*
2768      * If dosearch is true and if scriptname does not contain path
2769      * delimiters, search the PATH for scriptname.
2770      *
2771      * If SEARCH_EXTS is also defined, will look for each
2772      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2773      * while searching the PATH.
2774      *
2775      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2776      * proceeds as follows:
2777      *   If DOSISH or VMSISH:
2778      *     + look for ./scriptname{,.foo,.bar}
2779      *     + search the PATH for scriptname{,.foo,.bar}
2780      *
2781      *   If !DOSISH:
2782      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2783      *       this will not look in '.' if it's not in the PATH)
2784      */
2785     tmpbuf[0] = '\0';
2786
2787 #ifdef VMS
2788 #  ifdef ALWAYS_DEFTYPES
2789     len = strlen(scriptname);
2790     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2791         int hasdir, idx = 0, deftypes = 1;
2792         bool seen_dot = 1;
2793
2794         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2795 #  else
2796     if (dosearch) {
2797         int hasdir, idx = 0, deftypes = 1;
2798         bool seen_dot = 1;
2799
2800         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2801 #  endif
2802         /* The first time through, just add SEARCH_EXTS to whatever we
2803          * already have, so we can check for default file types. */
2804         while (deftypes ||
2805                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2806         {
2807             if (deftypes) {
2808                 deftypes = 0;
2809                 *tmpbuf = '\0';
2810             }
2811             if ((strlen(tmpbuf) + strlen(scriptname)
2812                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2813                 continue;       /* don't search dir with too-long name */
2814             strcat(tmpbuf, scriptname);
2815 #else  /* !VMS */
2816
2817 #ifdef DOSISH
2818     if (strEQ(scriptname, "-"))
2819         dosearch = 0;
2820     if (dosearch) {             /* Look in '.' first. */
2821         char *cur = scriptname;
2822 #ifdef SEARCH_EXTS
2823         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2824             while (ext[i])
2825                 if (strEQ(ext[i++],curext)) {
2826                     extidx = -1;                /* already has an ext */
2827                     break;
2828                 }
2829         do {
2830 #endif
2831             DEBUG_p(PerlIO_printf(Perl_debug_log,
2832                                   "Looking for %s\n",cur));
2833             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2834                 && !S_ISDIR(PL_statbuf.st_mode)) {
2835                 dosearch = 0;
2836                 scriptname = cur;
2837 #ifdef SEARCH_EXTS
2838                 break;
2839 #endif
2840             }
2841 #ifdef SEARCH_EXTS
2842             if (cur == scriptname) {
2843                 len = strlen(scriptname);
2844                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2845                     break;
2846                 cur = strcpy(tmpbuf, scriptname);
2847             }
2848         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2849                  && strcpy(tmpbuf+len, ext[extidx++]));
2850 #endif
2851     }
2852 #endif
2853
2854 #ifdef MACOS_TRADITIONAL
2855     if (dosearch && !strchr(scriptname, ':') &&
2856         (s = PerlEnv_getenv("Commands")))
2857 #else
2858     if (dosearch && !strchr(scriptname, '/')
2859 #ifdef DOSISH
2860                  && !strchr(scriptname, '\\')
2861 #endif
2862                  && (s = PerlEnv_getenv("PATH")))
2863 #endif
2864     {
2865         bool seen_dot = 0;
2866
2867         PL_bufend = s + strlen(s);
2868         while (s < PL_bufend) {
2869 #ifdef MACOS_TRADITIONAL
2870             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2871                         ',',
2872                         &len);
2873 #else
2874 #if defined(atarist) || defined(DOSISH)
2875             for (len = 0; *s
2876 #  ifdef atarist
2877                     && *s != ','
2878 #  endif
2879                     && *s != ';'; len++, s++) {
2880                 if (len < sizeof tmpbuf)
2881                     tmpbuf[len] = *s;
2882             }
2883             if (len < sizeof tmpbuf)
2884                 tmpbuf[len] = '\0';
2885 #else  /* ! (atarist || DOSISH) */
2886             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2887                         ':',
2888                         &len);
2889 #endif /* ! (atarist || DOSISH) */
2890 #endif /* MACOS_TRADITIONAL */
2891             if (s < PL_bufend)
2892                 s++;
2893             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2894                 continue;       /* don't search dir with too-long name */
2895 #ifdef MACOS_TRADITIONAL
2896             if (len && tmpbuf[len - 1] != ':')
2897                 tmpbuf[len++] = ':';
2898 #else
2899             if (len
2900 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2901                 && tmpbuf[len - 1] != '/'
2902                 && tmpbuf[len - 1] != '\\'
2903 #endif
2904                )
2905                 tmpbuf[len++] = '/';
2906             if (len == 2 && tmpbuf[0] == '.')
2907                 seen_dot = 1;
2908 #endif
2909             (void)strcpy(tmpbuf + len, scriptname);
2910 #endif  /* !VMS */
2911
2912 #ifdef SEARCH_EXTS
2913             len = strlen(tmpbuf);
2914             if (extidx > 0)     /* reset after previous loop */
2915                 extidx = 0;
2916             do {
2917 #endif
2918                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2919                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2920                 if (S_ISDIR(PL_statbuf.st_mode)) {
2921                     retval = -1;
2922                 }
2923 #ifdef SEARCH_EXTS
2924             } while (  retval < 0               /* not there */
2925                     && extidx>=0 && ext[extidx] /* try an extension? */
2926                     && strcpy(tmpbuf+len, ext[extidx++])
2927                 );
2928 #endif
2929             if (retval < 0)
2930                 continue;
2931             if (S_ISREG(PL_statbuf.st_mode)
2932                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2933 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2934                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2935 #endif
2936                 )
2937             {
2938                 xfound = tmpbuf;                /* bingo! */
2939                 break;
2940             }
2941             if (!xfailed)
2942                 xfailed = savepv(tmpbuf);
2943         }
2944 #ifndef DOSISH
2945         if (!xfound && !seen_dot && !xfailed &&
2946             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2947              || S_ISDIR(PL_statbuf.st_mode)))
2948 #endif
2949             seen_dot = 1;                       /* Disable message. */
2950         if (!xfound) {
2951             if (flags & 1) {                    /* do or die? */
2952                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2953                       (xfailed ? "execute" : "find"),
2954                       (xfailed ? xfailed : scriptname),
2955                       (xfailed ? "" : " on PATH"),
2956                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2957             }
2958             scriptname = Nullch;
2959         }
2960         if (xfailed)
2961             Safefree(xfailed);
2962         scriptname = xfound;
2963     }
2964     return (scriptname ? savepv(scriptname) : Nullch);
2965 }
2966
2967 #ifndef PERL_GET_CONTEXT_DEFINED
2968
2969 void *
2970 Perl_get_context(void)
2971 {
2972 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2973 #  ifdef OLD_PTHREADS_API
2974     pthread_addr_t t;
2975     if (pthread_getspecific(PL_thr_key, &t))
2976         Perl_croak_nocontext("panic: pthread_getspecific");
2977     return (void*)t;
2978 #  else
2979 #    ifdef I_MACH_CTHREADS
2980     return (void*)cthread_data(cthread_self());
2981 #    else
2982     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2983 #    endif
2984 #  endif
2985 #else
2986     return (void*)NULL;
2987 #endif
2988 }
2989
2990 void
2991 Perl_set_context(void *t)
2992 {
2993 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2994 #  ifdef I_MACH_CTHREADS
2995     cthread_set_data(cthread_self(), t);
2996 #  else
2997     if (pthread_setspecific(PL_thr_key, t))
2998         Perl_croak_nocontext("panic: pthread_setspecific");
2999 #  endif
3000 #endif
3001 }
3002
3003 #endif /* !PERL_GET_CONTEXT_DEFINED */
3004
3005 #ifdef USE_5005THREADS
3006
3007 #ifdef FAKE_THREADS
3008 /* Very simplistic scheduler for now */
3009 void
3010 schedule(void)
3011 {
3012     thr = thr->i.next_run;
3013 }
3014
3015 void
3016 Perl_cond_init(pTHX_ perl_cond *cp)
3017 {
3018     *cp = 0;
3019 }
3020
3021 void
3022 Perl_cond_signal(pTHX_ perl_cond *cp)
3023 {
3024     perl_os_thread t;
3025     perl_cond cond = *cp;
3026
3027     if (!cond)
3028         return;
3029     t = cond->thread;
3030     /* Insert t in the runnable queue just ahead of us */
3031     t->i.next_run = thr->i.next_run;
3032     thr->i.next_run->i.prev_run = t;
3033     t->i.prev_run = thr;
3034     thr->i.next_run = t;
3035     thr->i.wait_queue = 0;
3036     /* Remove from the wait queue */
3037     *cp = cond->next;
3038     Safefree(cond);
3039 }
3040
3041 void
3042 Perl_cond_broadcast(pTHX_ perl_cond *cp)
3043 {
3044     perl_os_thread t;
3045     perl_cond cond, cond_next;
3046
3047     for (cond = *cp; cond; cond = cond_next) {
3048         t = cond->thread;
3049         /* Insert t in the runnable queue just ahead of us */
3050         t->i.next_run = thr->i.next_run;
3051         thr->i.next_run->i.prev_run = t;
3052         t->i.prev_run = thr;
3053         thr->i.next_run = t;
3054         thr->i.wait_queue = 0;
3055         /* Remove from the wait queue */
3056         cond_next = cond->next;
3057         Safefree(cond);
3058     }
3059     *cp = 0;
3060 }
3061
3062 void
3063 Perl_cond_wait(pTHX_ perl_cond *cp)
3064 {
3065     perl_cond cond;
3066
3067     if (thr->i.next_run == thr)
3068         Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3069
3070     New(666, cond, 1, struct perl_wait_queue);
3071     cond->thread = thr;
3072     cond->next = *cp;
3073     *cp = cond;
3074     thr->i.wait_queue = cond;
3075     /* Remove ourselves from runnable queue */
3076     thr->i.next_run->i.prev_run = thr->i.prev_run;
3077     thr->i.prev_run->i.next_run = thr->i.next_run;
3078 }
3079 #endif /* FAKE_THREADS */
3080
3081 MAGIC *
3082 Perl_condpair_magic(pTHX_ SV *sv)
3083 {
3084     MAGIC *mg;
3085
3086     (void)SvUPGRADE(sv, SVt_PVMG);
3087     mg = mg_find(sv, PERL_MAGIC_mutex);
3088     if (!mg) {
3089         condpair_t *cp;
3090
3091         New(53, cp, 1, condpair_t);
3092         MUTEX_INIT(&cp->mutex);
3093         COND_INIT(&cp->owner_cond);
3094         COND_INIT(&cp->cond);
3095         cp->owner = 0;
3096         LOCK_CRED_MUTEX;                /* XXX need separate mutex? */
3097         mg = mg_find(sv, PERL_MAGIC_mutex);
3098         if (mg) {
3099             /* someone else beat us to initialising it */
3100             UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
3101             MUTEX_DESTROY(&cp->mutex);
3102             COND_DESTROY(&cp->owner_cond);
3103             COND_DESTROY(&cp->cond);
3104             Safefree(cp);
3105         }
3106         else {
3107             sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
3108             mg = SvMAGIC(sv);
3109             mg->mg_ptr = (char *)cp;
3110             mg->mg_len = sizeof(cp);
3111             UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
3112             DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3113                                            "%p: condpair_magic %p\n", thr, sv)));
3114         }
3115     }
3116     return mg;
3117 }
3118
3119 SV *
3120 Perl_sv_lock(pTHX_ SV *osv)
3121 {
3122     MAGIC *mg;
3123     SV *sv = osv;
3124
3125     LOCK_SV_LOCK_MUTEX;
3126     if (SvROK(sv)) {
3127         sv = SvRV(sv);
3128     }
3129
3130     mg = condpair_magic(sv);
3131     MUTEX_LOCK(MgMUTEXP(mg));
3132     if (MgOWNER(mg) == thr)
3133         MUTEX_UNLOCK(MgMUTEXP(mg));
3134     else {
3135         while (MgOWNER(mg))
3136             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3137         MgOWNER(mg) = thr;
3138         DEBUG_S(PerlIO_printf(Perl_debug_log,
3139                               "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3140                               PTR2UV(thr), PTR2UV(sv)));
3141         MUTEX_UNLOCK(MgMUTEXP(mg));
3142         SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3143     }
3144     UNLOCK_SV_LOCK_MUTEX;
3145     return sv;
3146 }
3147
3148 /*
3149  * Make a new perl thread structure using t as a prototype. Some of the
3150  * fields for the new thread are copied from the prototype thread, t,
3151  * so t should not be running in perl at the time this function is
3152  * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3153  * thread calling new_struct_thread) clearly satisfies this constraint.
3154  */
3155 struct perl_thread *
3156 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3157 {
3158 #if !defined(PERL_IMPLICIT_CONTEXT)
3159     struct perl_thread *thr;
3160 #endif
3161     SV *sv;
3162     SV **svp;
3163     I32 i;
3164
3165     sv = newSVpvn("", 0);
3166     SvGROW(sv, sizeof(struct perl_thread) + 1);
3167     SvCUR_set(sv, sizeof(struct perl_thread));
3168     thr = (Thread) SvPVX(sv);
3169 #ifdef DEBUGGING
3170     Poison(thr, 1, struct perl_thread);
3171     PL_markstack = 0;
3172     PL_scopestack = 0;
3173     PL_savestack = 0;
3174     PL_retstack = 0;
3175     PL_dirty = 0;
3176     PL_localizing = 0;
3177     Zero(&PL_hv_fetch_ent_mh, 1, HE);
3178     PL_efloatbuf = (char*)NULL;
3179     PL_efloatsize = 0;
3180 #else
3181     Zero(thr, 1, struct perl_thread);
3182 #endif
3183
3184     thr->oursv = sv;
3185     init_stacks();
3186
3187     PL_curcop = &PL_compiling;
3188     thr->interp = t->interp;
3189     thr->cvcache = newHV();
3190     thr->threadsv = newAV();
3191     thr->specific = newAV();
3192     thr->errsv = newSVpvn("", 0);
3193     thr->flags = THRf_R_JOINABLE;
3194     thr->thr_done = 0;
3195     MUTEX_INIT(&thr->mutex);
3196
3197     JMPENV_BOOTSTRAP;
3198
3199     PL_in_eval = EVAL_NULL;     /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3200     PL_restartop = 0;
3201
3202     PL_statname = NEWSV(66,0);
3203     PL_errors = newSVpvn("", 0);
3204     PL_maxscream = -1;
3205     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3206     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3207     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3208     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3209     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3210     PL_regindent = 0;
3211     PL_reginterp_cnt = 0;
3212     PL_lastscream = Nullsv;
3213     PL_screamfirst = 0;
3214     PL_screamnext = 0;
3215     PL_reg_start_tmp = 0;
3216     PL_reg_start_tmpl = 0;
3217     PL_reg_poscache = Nullch;
3218
3219     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3220
3221     /* parent thread's data needs to be locked while we make copy */
3222     MUTEX_LOCK(&t->mutex);
3223
3224 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3225     PL_protect = t->Tprotect;
3226 #endif
3227
3228     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
3229     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
3230     PL_curstash = t->Tcurstash;   /* always be set to main? */
3231
3232     PL_tainted = t->Ttainted;
3233     PL_curpm = t->Tcurpm;       /* XXX No PMOP ref count */
3234     PL_rs = newSVsv(t->Trs);
3235     PL_last_in_gv = Nullgv;
3236     PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3237     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3238     PL_chopset = t->Tchopset;
3239     PL_bodytarget = newSVsv(t->Tbodytarget);
3240     PL_toptarget = newSVsv(t->Ttoptarget);
3241     if (t->Tformtarget == t->Ttoptarget)
3242         PL_formtarget = PL_toptarget;
3243     else
3244         PL_formtarget = PL_bodytarget;
3245
3246     /* Initialise all per-thread SVs that the template thread used */
3247     svp = AvARRAY(t->threadsv);
3248     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3249         if (*svp && *svp != &PL_sv_undef) {
3250             SV *sv = newSVsv(*svp);
3251             av_store(thr->threadsv, i, sv);
3252             sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3253             DEBUG_S(PerlIO_printf(Perl_debug_log,
3254                 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3255                                   (IV)i, t, thr));
3256         }
3257     }
3258     thr->threadsvp = AvARRAY(thr->threadsv);
3259
3260     MUTEX_LOCK(&PL_threads_mutex);
3261     PL_nthreads++;
3262     thr->tid = ++PL_threadnum;
3263     thr->next = t->next;
3264     thr->prev = t;
3265     t->next = thr;
3266     thr->next->prev = thr;
3267     MUTEX_UNLOCK(&PL_threads_mutex);
3268
3269     /* done copying parent's state */
3270     MUTEX_UNLOCK(&t->mutex);
3271
3272 #ifdef HAVE_THREAD_INTERN
3273     Perl_init_thread_intern(thr);
3274 #endif /* HAVE_THREAD_INTERN */
3275     return thr;
3276 }
3277 #endif /* USE_5005THREADS */
3278
3279 #ifdef PERL_GLOBAL_STRUCT
3280 struct perl_vars *
3281 Perl_GetVars(pTHX)
3282 {
3283  return &PL_Vars;
3284 }
3285 #endif
3286
3287 char **
3288 Perl_get_op_names(pTHX)
3289 {
3290  return PL_op_name;
3291 }
3292
3293 char **
3294 Perl_get_op_descs(pTHX)
3295 {
3296  return PL_op_desc;
3297 }
3298
3299 char *
3300 Perl_get_no_modify(pTHX)
3301 {
3302  return (char*)PL_no_modify;
3303 }
3304
3305 U32 *
3306 Perl_get_opargs(pTHX)
3307 {
3308  return PL_opargs;
3309 }
3310
3311 PPADDR_t*
3312 Perl_get_ppaddr(pTHX)
3313 {
3314  return (PPADDR_t*)PL_ppaddr;
3315 }
3316
3317 #ifndef HAS_GETENV_LEN
3318 char *
3319 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3320 {
3321     char *env_trans = PerlEnv_getenv(env_elem);
3322     if (env_trans)
3323         *len = strlen(env_trans);
3324     return env_trans;
3325 }
3326 #endif
3327
3328
3329 MGVTBL*
3330 Perl_get_vtbl(pTHX_ int vtbl_id)
3331 {
3332     MGVTBL* result = Null(MGVTBL*);
3333
3334     switch(vtbl_id) {
3335     case want_vtbl_sv:
3336         result = &PL_vtbl_sv;
3337         break;
3338     case want_vtbl_env:
3339         result = &PL_vtbl_env;
3340         break;
3341     case want_vtbl_envelem:
3342         result = &PL_vtbl_envelem;
3343         break;
3344     case want_vtbl_sig:
3345         result = &PL_vtbl_sig;
3346         break;
3347     case want_vtbl_sigelem:
3348         result = &PL_vtbl_sigelem;
3349         break;
3350     case want_vtbl_pack:
3351         result = &PL_vtbl_pack;
3352         break;
3353     case want_vtbl_packelem:
3354         result = &PL_vtbl_packelem;
3355         break;
3356     case want_vtbl_dbline:
3357         result = &PL_vtbl_dbline;
3358         break;
3359     case want_vtbl_isa:
3360         result = &PL_vtbl_isa;
3361         break;
3362     case want_vtbl_isaelem:
3363         result = &PL_vtbl_isaelem;
3364         break;
3365     case want_vtbl_arylen:
3366         result = &PL_vtbl_arylen;
3367         break;
3368     case want_vtbl_glob:
3369         result = &PL_vtbl_glob;
3370         break;
3371     case want_vtbl_mglob:
3372         result = &PL_vtbl_mglob;
3373         break;
3374     case want_vtbl_nkeys:
3375         result = &PL_vtbl_nkeys;
3376         break;
3377     case want_vtbl_taint:
3378         result = &PL_vtbl_taint;
3379         break;
3380     case want_vtbl_substr:
3381         result = &PL_vtbl_substr;
3382         break;
3383     case want_vtbl_vec:
3384         result = &PL_vtbl_vec;
3385         break;
3386     case want_vtbl_pos:
3387         result = &PL_vtbl_pos;
3388         break;
3389     case want_vtbl_bm:
3390         result = &PL_vtbl_bm;
3391         break;
3392     case want_vtbl_fm:
3393         result = &PL_vtbl_fm;
3394         break;
3395     case want_vtbl_uvar:
3396         result = &PL_vtbl_uvar;
3397         break;
3398 #ifdef USE_5005THREADS
3399     case want_vtbl_mutex:
3400         result = &PL_vtbl_mutex;
3401         break;
3402 #endif
3403     case want_vtbl_defelem:
3404         result = &PL_vtbl_defelem;
3405         break;
3406     case want_vtbl_regexp:
3407         result = &PL_vtbl_regexp;
3408         break;
3409     case want_vtbl_regdata:
3410         result = &PL_vtbl_regdata;
3411         break;
3412     case want_vtbl_regdatum:
3413         result = &PL_vtbl_regdatum;
3414         break;
3415 #ifdef USE_LOCALE_COLLATE
3416     case want_vtbl_collxfrm:
3417         result = &PL_vtbl_collxfrm;
3418         break;
3419 #endif
3420     case want_vtbl_amagic:
3421         result = &PL_vtbl_amagic;
3422         break;
3423     case want_vtbl_amagicelem:
3424         result = &PL_vtbl_amagicelem;
3425         break;
3426     case want_vtbl_backref:
3427         result = &PL_vtbl_backref;
3428         break;
3429     }
3430     return result;
3431 }
3432
3433 I32
3434 Perl_my_fflush_all(pTHX)
3435 {
3436 #if defined(FFLUSH_NULL)
3437     return PerlIO_flush(NULL);
3438 #else
3439 # if defined(HAS__FWALK)
3440     extern int fflush(FILE *);
3441     /* undocumented, unprototyped, but very useful BSDism */
3442     extern void _fwalk(int (*)(FILE *));
3443     _fwalk(&fflush);
3444     return 0;
3445 # else
3446 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3447     long open_max = -1;
3448 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3449     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3450 #   else
3451 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3452     open_max = sysconf(_SC_OPEN_MAX);
3453 #     else
3454 #      ifdef FOPEN_MAX
3455     open_max = FOPEN_MAX;
3456 #      else
3457 #       ifdef OPEN_MAX
3458     open_max = OPEN_MAX;
3459 #       else
3460 #        ifdef _NFILE
3461     open_max = _NFILE;
3462 #        endif
3463 #       endif
3464 #      endif
3465 #     endif
3466 #    endif
3467     if (open_max > 0) {
3468       long i;
3469       for (i = 0; i < open_max; i++)
3470             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3471                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3472                 STDIO_STREAM_ARRAY[i]._flag)
3473                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3474       return 0;
3475     }
3476 #  endif
3477     SETERRNO(EBADF,RMS_IFI);
3478     return EOF;
3479 # endif
3480 #endif
3481 }
3482
3483 void
3484 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3485 {
3486     char *func =
3487         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3488         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3489         PL_op_desc[op];
3490     char *pars = OP_IS_FILETEST(op) ? "" : "()";
3491     char *type = OP_IS_SOCKET(op)
3492             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3493                 ?  "socket" : "filehandle";
3494     char *name = NULL;
3495
3496     if (gv && isGV(gv)) {
3497         name = GvENAME(gv);
3498     }
3499
3500     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3501         if (ckWARN(WARN_IO)) {
3502             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3503             if (name && *name)
3504                 Perl_warner(aTHX_ packWARN(WARN_IO),
3505                             "Filehandle %s opened only for %sput",
3506                             name, direction);
3507             else
3508                 Perl_warner(aTHX_ packWARN(WARN_IO),
3509                             "Filehandle opened only for %sput", direction);
3510         }
3511     }
3512     else {
3513         char *vile;
3514         I32   warn_type;
3515
3516         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3517             vile = "closed";
3518             warn_type = WARN_CLOSED;
3519         }
3520         else {
3521             vile = "unopened";
3522             warn_type = WARN_UNOPENED;
3523         }
3524
3525         if (ckWARN(warn_type)) {
3526             if (name && *name) {
3527                 Perl_warner(aTHX_ packWARN(warn_type),
3528                             "%s%s on %s %s %s", func, pars, vile, type, name);
3529                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3530                     Perl_warner(
3531                         aTHX_ packWARN(warn_type),
3532                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3533                         func, pars, name
3534                     );
3535             }
3536             else {
3537                 Perl_warner(aTHX_ packWARN(warn_type),
3538                             "%s%s on %s %s", func, pars, vile, type);
3539                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3540                     Perl_warner(
3541                         aTHX_ packWARN(warn_type),
3542                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3543                         func, pars
3544                     );
3545             }
3546         }
3547     }
3548 }
3549
3550 #ifdef EBCDIC
3551 /* in ASCII order, not that it matters */
3552 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3553
3554 int
3555 Perl_ebcdic_control(pTHX_ int ch)
3556 {
3557     if (ch > 'a') {
3558         char *ctlp;
3559
3560         if (islower(ch))
3561             ch = toupper(ch);
3562
3563         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3564             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3565         }
3566
3567         if (ctlp == controllablechars)
3568             return('\177'); /* DEL */
3569         else
3570             return((unsigned char)(ctlp - controllablechars - 1));
3571     } else { /* Want uncontrol */
3572         if (ch == '\177' || ch == -1)
3573             return('?');
3574         else if (ch == '\157')
3575             return('\177');
3576         else if (ch == '\174')
3577             return('\000');
3578         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3579             return('\036');
3580         else if (ch == '\155')
3581             return('\037');
3582         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3583             return(controllablechars[ch+1]);
3584         else
3585             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3586     }
3587 }
3588 #endif
3589
3590 /* To workaround core dumps from the uninitialised tm_zone we get the
3591  * system to give us a reasonable struct to copy.  This fix means that
3592  * strftime uses the tm_zone and tm_gmtoff values returned by
3593  * localtime(time()). That should give the desired result most of the
3594  * time. But probably not always!
3595  *
3596  * This does not address tzname aspects of NETaa14816.
3597  *
3598  */
3599
3600 #ifdef HAS_GNULIBC
3601 # ifndef STRUCT_TM_HASZONE
3602 #    define STRUCT_TM_HASZONE
3603 # endif
3604 #endif
3605
3606 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3607 # ifndef HAS_TM_TM_ZONE
3608 #    define HAS_TM_TM_ZONE
3609 # endif
3610 #endif
3611
3612 void
3613 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3614 {
3615 #ifdef HAS_TM_TM_ZONE
3616     Time_t now;
3617     (void)time(&now);
3618     Copy(localtime(&now), ptm, 1, struct tm);
3619 #endif
3620 }
3621
3622 /*
3623  * mini_mktime - normalise struct tm values without the localtime()
3624  * semantics (and overhead) of mktime().
3625  */
3626 void
3627 Perl_mini_mktime(pTHX_ struct tm *ptm)
3628 {
3629     int yearday;
3630     int secs;
3631     int month, mday, year, jday;
3632     int odd_cent, odd_year;
3633
3634 #define DAYS_PER_YEAR   365
3635 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3636 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3637 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3638 #define SECS_PER_HOUR   (60*60)
3639 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3640 /* parentheses deliberately absent on these two, otherwise they don't work */
3641 #define MONTH_TO_DAYS   153/5
3642 #define DAYS_TO_MONTH   5/153
3643 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3644 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3645 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3646 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3647
3648 /*
3649  * Year/day algorithm notes:
3650  *
3651  * With a suitable offset for numeric value of the month, one can find
3652  * an offset into the year by considering months to have 30.6 (153/5) days,
3653  * using integer arithmetic (i.e., with truncation).  To avoid too much
3654  * messing about with leap days, we consider January and February to be
3655  * the 13th and 14th month of the previous year.  After that transformation,
3656  * we need the month index we use to be high by 1 from 'normal human' usage,
3657  * so the month index values we use run from 4 through 15.
3658  *
3659  * Given that, and the rules for the Gregorian calendar (leap years are those
3660  * divisible by 4 unless also divisible by 100, when they must be divisible
3661  * by 400 instead), we can simply calculate the number of days since some
3662  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3663  * the days we derive from our month index, and adding in the day of the
3664  * month.  The value used here is not adjusted for the actual origin which
3665  * it normally would use (1 January A.D. 1), since we're not exposing it.
3666  * We're only building the value so we can turn around and get the
3667  * normalised values for the year, month, day-of-month, and day-of-year.
3668  *
3669  * For going backward, we need to bias the value we're using so that we find
3670  * the right year value.  (Basically, we don't want the contribution of
3671  * March 1st to the number to apply while deriving the year).  Having done
3672  * that, we 'count up' the contribution to the year number by accounting for
3673  * full quadracenturies (400-year periods) with their extra leap days, plus
3674  * the contribution from full centuries (to avoid counting in the lost leap
3675  * days), plus the contribution from full quad-years (to count in the normal
3676  * leap days), plus the leftover contribution from any non-leap years.
3677  * At this point, if we were working with an actual leap day, we'll have 0
3678  * days left over.  This is also true for March 1st, however.  So, we have
3679  * to special-case that result, and (earlier) keep track of the 'odd'
3680  * century and year contributions.  If we got 4 extra centuries in a qcent,
3681  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3682  * Otherwise, we add back in the earlier bias we removed (the 123 from
3683  * figuring in March 1st), find the month index (integer division by 30.6),
3684  * and the remainder is the day-of-month.  We then have to convert back to
3685  * 'real' months (including fixing January and February from being 14/15 in
3686  * the previous year to being in the proper year).  After that, to get
3687  * tm_yday, we work with the normalised year and get a new yearday value for
3688  * January 1st, which we subtract from the yearday value we had earlier,
3689  * representing the date we've re-built.  This is done from January 1
3690  * because tm_yday is 0-origin.
3691  *
3692  * Since POSIX time routines are only guaranteed to work for times since the
3693  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3694  * applies Gregorian calendar rules even to dates before the 16th century
3695  * doesn't bother me.  Besides, you'd need cultural context for a given
3696  * date to know whether it was Julian or Gregorian calendar, and that's
3697  * outside the scope for this routine.  Since we convert back based on the
3698  * same rules we used to build the yearday, you'll only get strange results
3699  * for input which needed normalising, or for the 'odd' century years which
3700  * were leap years in the Julian calander but not in the Gregorian one.
3701  * I can live with that.
3702  *
3703  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3704  * that's still outside the scope for POSIX time manipulation, so I don't
3705  * care.
3706  */
3707
3708     year = 1900 + ptm->tm_year;
3709     month = ptm->tm_mon;
3710     mday = ptm->tm_mday;
3711     /* allow given yday with no month & mday to dominate the result */
3712     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3713         month = 0;
3714         mday = 0;
3715         jday = 1 + ptm->tm_yday;
3716     }
3717     else {
3718         jday = 0;
3719     }
3720     if (month >= 2)
3721         month+=2;
3722     else
3723         month+=14, year--;
3724     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3725     yearday += month*MONTH_TO_DAYS + mday + jday;
3726     /*
3727      * Note that we don't know when leap-seconds were or will be,
3728      * so we have to trust the user if we get something which looks
3729      * like a sensible leap-second.  Wild values for seconds will
3730      * be rationalised, however.
3731      */
3732     if ((unsigned) ptm->tm_sec <= 60) {
3733         secs = 0;
3734     }
3735     else {
3736         secs = ptm->tm_sec;
3737         ptm->tm_sec = 0;
3738     }
3739     secs += 60 * ptm->tm_min;
3740     secs += SECS_PER_HOUR * ptm->tm_hour;
3741     if (secs < 0) {
3742         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3743             /* got negative remainder, but need positive time */
3744             /* back off an extra day to compensate */
3745             yearday += (secs/SECS_PER_DAY)-1;
3746             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3747         }
3748         else {
3749             yearday += (secs/SECS_PER_DAY);
3750             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3751         }
3752     }
3753     else if (secs >= SECS_PER_DAY) {
3754         yearday += (secs/SECS_PER_DAY);
3755         secs %= SECS_PER_DAY;
3756     }
3757     ptm->tm_hour = secs/SECS_PER_HOUR;
3758     secs %= SECS_PER_HOUR;
3759     ptm->tm_min = secs/60;
3760     secs %= 60;
3761     ptm->tm_sec += secs;
3762     /* done with time of day effects */
3763     /*
3764      * The algorithm for yearday has (so far) left it high by 428.
3765      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3766      * bias it by 123 while trying to figure out what year it
3767      * really represents.  Even with this tweak, the reverse
3768      * translation fails for years before A.D. 0001.
3769      * It would still fail for Feb 29, but we catch that one below.
3770      */
3771     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3772     yearday -= YEAR_ADJUST;
3773     year = (yearday / DAYS_PER_QCENT) * 400;
3774     yearday %= DAYS_PER_QCENT;
3775     odd_cent = yearday / DAYS_PER_CENT;
3776     year += odd_cent * 100;
3777     yearday %= DAYS_PER_CENT;
3778     year += (yearday / DAYS_PER_QYEAR) * 4;
3779     yearday %= DAYS_PER_QYEAR;
3780     odd_year = yearday / DAYS_PER_YEAR;
3781     year += odd_year;
3782     yearday %= DAYS_PER_YEAR;
3783     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3784         month = 1;
3785         yearday = 29;
3786     }
3787     else {
3788         yearday += YEAR_ADJUST; /* recover March 1st crock */
3789         month = yearday*DAYS_TO_MONTH;
3790         yearday -= month*MONTH_TO_DAYS;
3791         /* recover other leap-year adjustment */
3792         if (month > 13) {
3793             month-=14;
3794             year++;
3795         }
3796         else {
3797             month-=2;
3798         }
3799     }
3800     ptm->tm_year = year - 1900;
3801     if (yearday) {
3802       ptm->tm_mday = yearday;
3803       ptm->tm_mon = month;
3804     }
3805     else {
3806       ptm->tm_mday = 31;
3807       ptm->tm_mon = month - 1;
3808     }
3809     /* re-build yearday based on Jan 1 to get tm_yday */
3810     year--;
3811     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3812     yearday += 14*MONTH_TO_DAYS + 1;
3813     ptm->tm_yday = jday - yearday;
3814     /* fix tm_wday if not overridden by caller */
3815     if ((unsigned)ptm->tm_wday > 6)
3816         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3817 }
3818
3819 char *
3820 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3821 {
3822 #ifdef HAS_STRFTIME
3823   char *buf;
3824   int buflen;
3825   struct tm mytm;
3826   int len;
3827
3828   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3829   mytm.tm_sec = sec;
3830   mytm.tm_min = min;
3831   mytm.tm_hour = hour;
3832   mytm.tm_mday = mday;
3833   mytm.tm_mon = mon;
3834   mytm.tm_year = year;
3835   mytm.tm_wday = wday;
3836   mytm.tm_yday = yday;
3837   mytm.tm_isdst = isdst;
3838   mini_mktime(&mytm);
3839   buflen = 64;
3840   New(0, buf, buflen, char);
3841   len = strftime(buf, buflen, fmt, &mytm);
3842   /*
3843   ** The following is needed to handle to the situation where
3844   ** tmpbuf overflows.  Basically we want to allocate a buffer
3845   ** and try repeatedly.  The reason why it is so complicated
3846   ** is that getting a return value of 0 from strftime can indicate
3847   ** one of the following:
3848   ** 1. buffer overflowed,
3849   ** 2. illegal conversion specifier, or
3850   ** 3. the format string specifies nothing to be returned(not
3851   **      an error).  This could be because format is an empty string
3852   **    or it specifies %p that yields an empty string in some locale.
3853   ** If there is a better way to make it portable, go ahead by
3854   ** all means.
3855   */
3856   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3857     return buf;
3858   else {
3859     /* Possibly buf overflowed - try again with a bigger buf */
3860     int     fmtlen = strlen(fmt);
3861     int     bufsize = fmtlen + buflen;
3862
3863     New(0, buf, bufsize, char);
3864     while (buf) {
3865       buflen = strftime(buf, bufsize, fmt, &mytm);
3866       if (buflen > 0 && buflen < bufsize)
3867         break;
3868       /* heuristic to prevent out-of-memory errors */
3869       if (bufsize > 100*fmtlen) {
3870         Safefree(buf);
3871         buf = NULL;
3872         break;
3873       }
3874       bufsize *= 2;
3875       Renew(buf, bufsize, char);
3876     }
3877     return buf;
3878   }
3879 #else
3880   Perl_croak(aTHX_ "panic: no strftime");
3881 #endif
3882 }
3883
3884
3885 #define SV_CWD_RETURN_UNDEF \
3886 sv_setsv(sv, &PL_sv_undef); \
3887 return FALSE
3888
3889 #define SV_CWD_ISDOT(dp) \
3890     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3891         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3892
3893 /*
3894 =head1 Miscellaneous Functions
3895
3896 =for apidoc getcwd_sv
3897
3898 Fill the sv with current working directory
3899
3900 =cut
3901 */
3902
3903 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3904  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3905  * getcwd(3) if available
3906  * Comments from the orignal:
3907  *     This is a faster version of getcwd.  It's also more dangerous
3908  *     because you might chdir out of a directory that you can't chdir
3909  *     back into. */
3910
3911 int
3912 Perl_getcwd_sv(pTHX_ register SV *sv)
3913 {
3914 #ifndef PERL_MICRO
3915
3916 #ifndef INCOMPLETE_TAINTS
3917     SvTAINTED_on(sv);
3918 #endif
3919
3920 #ifdef HAS_GETCWD
3921     {
3922         char buf[MAXPATHLEN];
3923
3924         /* Some getcwd()s automatically allocate a buffer of the given
3925          * size from the heap if they are given a NULL buffer pointer.
3926          * The problem is that this behaviour is not portable. */
3927         if (getcwd(buf, sizeof(buf) - 1)) {
3928             STRLEN len = strlen(buf);
3929             sv_setpvn(sv, buf, len);
3930             return TRUE;
3931         }
3932         else {
3933             sv_setsv(sv, &PL_sv_undef);
3934             return FALSE;
3935         }
3936     }
3937
3938 #else
3939
3940     Stat_t statbuf;
3941     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3942     int namelen, pathlen=0;
3943     DIR *dir;
3944     Direntry_t *dp;
3945
3946     (void)SvUPGRADE(sv, SVt_PV);
3947
3948     if (PerlLIO_lstat(".", &statbuf) < 0) {
3949         SV_CWD_RETURN_UNDEF;
3950     }
3951
3952     orig_cdev = statbuf.st_dev;
3953     orig_cino = statbuf.st_ino;
3954     cdev = orig_cdev;
3955     cino = orig_cino;
3956
3957     for (;;) {
3958         odev = cdev;
3959         oino = cino;
3960
3961         if (PerlDir_chdir("..") < 0) {
3962             SV_CWD_RETURN_UNDEF;
3963         }
3964         if (PerlLIO_stat(".", &statbuf) < 0) {
3965             SV_CWD_RETURN_UNDEF;
3966         }
3967
3968         cdev = statbuf.st_dev;
3969         cino = statbuf.st_ino;
3970
3971         if (odev == cdev && oino == cino) {
3972             break;
3973         }
3974         if (!(dir = PerlDir_open("."))) {
3975             SV_CWD_RETURN_UNDEF;
3976         }
3977
3978         while ((dp = PerlDir_read(dir)) != NULL) {
3979 #ifdef DIRNAMLEN
3980             namelen = dp->d_namlen;
3981 #else
3982             namelen = strlen(dp->d_name);
3983 #endif
3984             /* skip . and .. */
3985             if (SV_CWD_ISDOT(dp)) {
3986                 continue;
3987             }
3988
3989             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3990                 SV_CWD_RETURN_UNDEF;
3991             }
3992
3993             tdev = statbuf.st_dev;
3994             tino = statbuf.st_ino;
3995             if (tino == oino && tdev == odev) {
3996                 break;
3997             }
3998         }
3999
4000         if (!dp) {
4001             SV_CWD_RETURN_UNDEF;
4002         }
4003
4004         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4005             SV_CWD_RETURN_UNDEF;
4006         }
4007
4008         SvGROW(sv, pathlen + namelen + 1);
4009
4010         if (pathlen) {
4011             /* shift down */
4012             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4013         }
4014
4015         /* prepend current directory to the front */
4016         *SvPVX(sv) = '/';
4017         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4018         pathlen += (namelen + 1);
4019
4020 #ifdef VOID_CLOSEDIR
4021         PerlDir_close(dir);
4022 #else
4023         if (PerlDir_close(dir) < 0) {
4024             SV_CWD_RETURN_UNDEF;
4025         }
4026 #endif
4027     }
4028
4029     if (pathlen) {
4030         SvCUR_set(sv, pathlen);
4031         *SvEND(sv) = '\0';
4032         SvPOK_only(sv);
4033
4034         if (PerlDir_chdir(SvPVX(sv)) < 0) {
4035             SV_CWD_RETURN_UNDEF;
4036         }
4037     }
4038     if (PerlLIO_stat(".", &statbuf) < 0) {
4039         SV_CWD_RETURN_UNDEF;
4040     }
4041
4042     cdev = statbuf.st_dev;
4043     cino = statbuf.st_ino;
4044
4045     if (cdev != orig_cdev || cino != orig_cino) {
4046         Perl_croak(aTHX_ "Unstable directory path, "
4047                    "current directory changed unexpectedly");
4048     }
4049
4050     return TRUE;
4051 #endif
4052
4053 #else
4054     return FALSE;
4055 #endif
4056 }
4057
4058 /*
4059 =head1 SV Manipulation Functions
4060
4061 =for apidoc new_vstring
4062
4063 Returns a pointer to the next character after the parsed
4064 vstring, as well as updating the passed in sv.
4065
4066 Function must be called like
4067
4068         sv = NEWSV(92,5);
4069         s = new_vstring(s,sv);
4070
4071 The sv must already be large enough to store the vstring
4072 passed in.
4073
4074 =cut
4075 */
4076
4077 char *
4078 Perl_new_vstring(pTHX_ char *s, SV *sv)
4079 {
4080     char *pos = s;
4081     if (*pos == 'v') pos++;  /* get past 'v' */
4082     while (isDIGIT(*pos) || *pos == '_')
4083     pos++;
4084     if (!isALPHA(*pos)) {
4085         UV rev;
4086         U8 tmpbuf[UTF8_MAXLEN+1];
4087         U8 *tmpend;
4088
4089         if (*s == 'v') s++;  /* get past 'v' */
4090
4091         sv_setpvn(sv, "", 0);
4092
4093         for (;;) {
4094             rev = 0;
4095             {
4096                  /* this is atoi() that tolerates underscores */
4097                  char *end = pos;
4098                  UV mult = 1;
4099                  if ( s > pos && *(s-1) == '_') {
4100                       mult = 10;
4101                  }
4102                  while (--end >= s) {
4103                       UV orev;
4104                       orev = rev;
4105                       rev += (*end - '0') * mult;
4106                       mult *= 10;
4107                       if (orev > rev && ckWARN_d(WARN_OVERFLOW))
4108                            Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4109                                        "Integer overflow in decimal number");
4110                  }
4111             }
4112 #ifdef EBCDIC
4113             if (rev > 0x7FFFFFFF)
4114                  Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
4115 #endif
4116             /* Append native character for the rev point */
4117             tmpend = uvchr_to_utf8(tmpbuf, rev);
4118             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
4119             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
4120                  SvUTF8_on(sv);
4121             if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
4122                  s = ++pos;
4123             else {
4124                  s = pos;
4125                  break;
4126             }
4127             while (isDIGIT(*pos) )
4128                  pos++;
4129         }
4130         SvPOK_on(sv);
4131         SvREADONLY_on(sv);
4132     }
4133     return s;
4134 }
4135
4136 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4137 #   define EMULATE_SOCKETPAIR_UDP
4138 #endif
4139
4140 #ifdef EMULATE_SOCKETPAIR_UDP
4141 static int
4142 S_socketpair_udp (int fd[2]) {
4143     dTHX;
4144     /* Fake a datagram socketpair using UDP to localhost.  */
4145     int sockets[2] = {-1, -1};
4146     struct sockaddr_in addresses[2];
4147     int i;
4148     Sock_size_t size = sizeof(struct sockaddr_in);
4149     unsigned short port;
4150     int got;
4151
4152     memset(&addresses, 0, sizeof(addresses));
4153     i = 1;
4154     do {
4155         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4156         if (sockets[i] == -1)
4157             goto tidy_up_and_fail;
4158
4159         addresses[i].sin_family = AF_INET;
4160         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4161         addresses[i].sin_port = 0;      /* kernel choses port.  */
4162         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4163                 sizeof(struct sockaddr_in)) == -1)
4164             goto tidy_up_and_fail;
4165     } while (i--);
4166
4167     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4168        for each connect the other socket to it.  */
4169     i = 1;
4170     do {
4171         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4172                 &size) == -1)
4173             goto tidy_up_and_fail;
4174         if (size != sizeof(struct sockaddr_in))
4175             goto abort_tidy_up_and_fail;
4176         /* !1 is 0, !0 is 1 */
4177         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4178                 sizeof(struct sockaddr_in)) == -1)
4179             goto tidy_up_and_fail;
4180     } while (i--);
4181
4182     /* Now we have 2 sockets connected to each other. I don't trust some other
4183        process not to have already sent a packet to us (by random) so send
4184        a packet from each to the other.  */
4185     i = 1;
4186     do {
4187         /* I'm going to send my own port number.  As a short.
4188            (Who knows if someone somewhere has sin_port as a bitfield and needs
4189            this routine. (I'm assuming crays have socketpair)) */
4190         port = addresses[i].sin_port;
4191         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4192         if (got != sizeof(port)) {
4193             if (got == -1)
4194                 goto tidy_up_and_fail;
4195             goto abort_tidy_up_and_fail;
4196         }
4197     } while (i--);
4198
4199     /* Packets sent. I don't trust them to have arrived though.
4200        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4201        connect to localhost will use a second kernel thread. In 2.6 the
4202        first thread running the connect() returns before the second completes,
4203        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4204        returns 0. Poor programs have tripped up. One poor program's authors'
4205        had a 50-1 reverse stock split. Not sure how connected these were.)
4206        So I don't trust someone not to have an unpredictable UDP stack.
4207     */
4208
4209     {
4210         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4211         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4212         fd_set rset;
4213
4214         FD_ZERO(&rset);
4215         FD_SET(sockets[0], &rset);
4216         FD_SET(sockets[1], &rset);
4217
4218         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4219         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4220                 || !FD_ISSET(sockets[1], &rset)) {
4221             /* I hope this is portable and appropriate.  */
4222             if (got == -1)
4223                 goto tidy_up_and_fail;
4224             goto abort_tidy_up_and_fail;
4225         }
4226     }
4227
4228     /* And the paranoia department even now doesn't trust it to have arrive
4229        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4230     {
4231         struct sockaddr_in readfrom;
4232         unsigned short buffer[2];
4233
4234         i = 1;
4235         do {
4236 #ifdef MSG_DONTWAIT
4237             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4238                     sizeof(buffer), MSG_DONTWAIT,
4239                     (struct sockaddr *) &readfrom, &size);
4240 #else
4241             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4242                     sizeof(buffer), 0,
4243                     (struct sockaddr *) &readfrom, &size);
4244 #endif
4245
4246             if (got == -1)
4247                 goto tidy_up_and_fail;
4248             if (got != sizeof(port)
4249                     || size != sizeof(struct sockaddr_in)
4250                     /* Check other socket sent us its port.  */
4251                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4252                     /* Check kernel says we got the datagram from that socket */
4253                     || readfrom.sin_family != addresses[!i].sin_family
4254                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4255                     || readfrom.sin_port != addresses[!i].sin_port)
4256                 goto abort_tidy_up_and_fail;
4257         } while (i--);
4258     }
4259     /* My caller (my_socketpair) has validated that this is non-NULL  */
4260     fd[0] = sockets[0];
4261     fd[1] = sockets[1];
4262     /* I hereby declare this connection open.  May God bless all who cross
4263        her.  */
4264     return 0;
4265
4266   abort_tidy_up_and_fail:
4267     errno = ECONNABORTED;
4268   tidy_up_and_fail:
4269     {
4270         int save_errno = errno;
4271         if (sockets[0] != -1)
4272             PerlLIO_close(sockets[0]);
4273         if (sockets[1] != -1)
4274             PerlLIO_close(sockets[1]);
4275         errno = save_errno;
4276         return -1;
4277     }
4278 }
4279 #endif /*  EMULATE_SOCKETPAIR_UDP */
4280
4281 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4282 int
4283 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4284     /* Stevens says that family must be AF_LOCAL, protocol 0.
4285        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4286     dTHX;
4287     int listener = -1;
4288     int connector = -1;
4289     int acceptor = -1;
4290     struct sockaddr_in listen_addr;
4291     struct sockaddr_in connect_addr;
4292     Sock_size_t size;
4293
4294     if (protocol
4295 #ifdef AF_UNIX
4296         || family != AF_UNIX
4297 #endif
4298     ) {
4299         errno = EAFNOSUPPORT;
4300         return -1;
4301     }
4302     if (!fd) {
4303         errno = EINVAL;
4304         return -1;
4305     }
4306
4307 #ifdef EMULATE_SOCKETPAIR_UDP
4308     if (type == SOCK_DGRAM)
4309         return S_socketpair_udp(fd);
4310 #endif
4311
4312     listener = PerlSock_socket(AF_INET, type, 0);
4313     if (listener == -1)
4314         return -1;
4315     memset(&listen_addr, 0, sizeof(listen_addr));
4316     listen_addr.sin_family = AF_INET;
4317     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4318     listen_addr.sin_port = 0;   /* kernel choses port.  */
4319     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4320             sizeof(listen_addr)) == -1)
4321         goto tidy_up_and_fail;
4322     if (PerlSock_listen(listener, 1) == -1)
4323         goto tidy_up_and_fail;
4324
4325     connector = PerlSock_socket(AF_INET, type, 0);
4326     if (connector == -1)
4327         goto tidy_up_and_fail;
4328     /* We want to find out the port number to connect to.  */
4329     size = sizeof(connect_addr);
4330     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4331             &size) == -1)
4332         goto tidy_up_and_fail;
4333     if (size != sizeof(connect_addr))
4334         goto abort_tidy_up_and_fail;
4335     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4336             sizeof(connect_addr)) == -1)
4337         goto tidy_up_and_fail;
4338
4339     size = sizeof(listen_addr);
4340     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4341             &size);
4342     if (acceptor == -1)
4343         goto tidy_up_and_fail;
4344     if (size != sizeof(listen_addr))
4345         goto abort_tidy_up_and_fail;
4346     PerlLIO_close(listener);
4347     /* Now check we are talking to ourself by matching port and host on the
4348        two sockets.  */
4349     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4350             &size) == -1)
4351         goto tidy_up_and_fail;
4352     if (size != sizeof(connect_addr)
4353             || listen_addr.sin_family != connect_addr.sin_family
4354             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4355             || listen_addr.sin_port != connect_addr.sin_port) {
4356         goto abort_tidy_up_and_fail;
4357     }
4358     fd[0] = connector;
4359     fd[1] = acceptor;
4360     return 0;
4361
4362   abort_tidy_up_and_fail:
4363   errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
4364   tidy_up_and_fail:
4365     {
4366         int save_errno = errno;
4367         if (listener != -1)
4368             PerlLIO_close(listener);
4369         if (connector != -1)
4370             PerlLIO_close(connector);
4371         if (acceptor != -1)
4372             PerlLIO_close(acceptor);
4373         errno = save_errno;
4374         return -1;
4375     }
4376 }
4377 #else
4378 /* In any case have a stub so that there's code corresponding
4379  * to the my_socketpair in global.sym. */
4380 int
4381 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4382 #ifdef HAS_SOCKETPAIR
4383     return socketpair(family, type, protocol, fd);
4384 #else
4385     return -1;
4386 #endif
4387 }
4388 #endif
4389
4390 /*
4391
4392 =for apidoc sv_nosharing
4393
4394 Dummy routine which "shares" an SV when there is no sharing module present.
4395 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4396 some level of strict-ness.
4397
4398 =cut
4399 */
4400
4401 void
4402 Perl_sv_nosharing(pTHX_ SV *sv)
4403 {
4404 }
4405
4406 /*
4407 =for apidoc sv_nolocking
4408
4409 Dummy routine which "locks" an SV when there is no locking module present.
4410 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4411 some level of strict-ness.
4412
4413 =cut
4414 */
4415
4416 void
4417 Perl_sv_nolocking(pTHX_ SV *sv)
4418 {
4419 }
4420
4421
4422 /*
4423 =for apidoc sv_nounlocking
4424
4425 Dummy routine which "unlocks" an SV when there is no locking module present.
4426 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4427 some level of strict-ness.
4428
4429 =cut
4430 */
4431
4432 void
4433 Perl_sv_nounlocking(pTHX_ SV *sv)
4434 {
4435 }
4436