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 occurence.
 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) && GvGP(PL_last_in_gv) &&
1113             IoLINES(GvIOp(PL_last_in_gv))) {
1114             bool line_mode = (RsSIMPLE(PL_rs) &&
1115                               SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
1116             Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
1117                            PL_last_in_gv == PL_argvgv ?
1118                            "" : GvNAME(PL_last_in_gv),
1119                            line_mode ? "line" : "chunk",
1120                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1121         }
1122 #ifdef USE_5005THREADS
1123         if (thr->tid)
1124             Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
1125 #endif
1126         sv_catpv(sv, PL_dirty ? dgd : ".\n");
1127     }
1128     return sv;
1129 }
1130
1131 OP *
1132 Perl_vdie(pTHX_ const char* pat, va_list *args)
1133 {
1134     char *message;
1135     int was_in_eval = PL_in_eval;
1136     HV *stash;
1137     GV *gv;
1138     CV *cv;
1139     SV *msv;
1140     STRLEN msglen;
1141
1142     DEBUG_S(PerlIO_printf(Perl_debug_log,
1143                           "%p: die: curstack = %p, mainstack = %p\n",
1144                           thr, PL_curstack, PL_mainstack));
1145
1146     if (pat) {
1147         msv = vmess(pat, args);
1148         if (PL_errors && SvCUR(PL_errors)) {
1149             sv_catsv(PL_errors, msv);
1150             message = SvPV(PL_errors, msglen);
1151             SvCUR_set(PL_errors, 0);
1152         }
1153         else
1154             message = SvPV(msv,msglen);
1155     }
1156     else {
1157         message = Nullch;
1158         msglen = 0;
1159     }
1160
1161     DEBUG_S(PerlIO_printf(Perl_debug_log,
1162                           "%p: die: message = %s\ndiehook = %p\n",
1163                           thr, message, PL_diehook));
1164     if (PL_diehook) {
1165         /* sv_2cv might call Perl_croak() */
1166         SV *olddiehook = PL_diehook;
1167         ENTER;
1168         SAVESPTR(PL_diehook);
1169         PL_diehook = Nullsv;
1170         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1171         LEAVE;
1172         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1173             dSP;
1174             SV *msg;
1175
1176             ENTER;
1177             save_re_context();
1178             if (message) {
1179                 msg = newSVpvn(message, msglen);
1180                 SvREADONLY_on(msg);
1181                 SAVEFREESV(msg);
1182             }
1183             else {
1184                 msg = ERRSV;
1185             }
1186
1187             PUSHSTACKi(PERLSI_DIEHOOK);
1188             PUSHMARK(SP);
1189             XPUSHs(msg);
1190             PUTBACK;
1191             call_sv((SV*)cv, G_DISCARD);
1192             POPSTACK;
1193             LEAVE;
1194         }
1195     }
1196
1197     PL_restartop = die_where(message, msglen);
1198     DEBUG_S(PerlIO_printf(Perl_debug_log,
1199           "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
1200           thr, PL_restartop, was_in_eval, PL_top_env));
1201     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
1202         JMPENV_JUMP(3);
1203     return PL_restartop;
1204 }
1205
1206 #if defined(PERL_IMPLICIT_CONTEXT)
1207 OP *
1208 Perl_die_nocontext(const char* pat, ...)
1209 {
1210     dTHX;
1211     OP *o;
1212     va_list args;
1213     va_start(args, pat);
1214     o = vdie(pat, &args);
1215     va_end(args);
1216     return o;
1217 }
1218 #endif /* PERL_IMPLICIT_CONTEXT */
1219
1220 OP *
1221 Perl_die(pTHX_ const char* pat, ...)
1222 {
1223     OP *o;
1224     va_list args;
1225     va_start(args, pat);
1226     o = vdie(pat, &args);
1227     va_end(args);
1228     return o;
1229 }
1230
1231 void
1232 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1233 {
1234     char *message;
1235     HV *stash;
1236     GV *gv;
1237     CV *cv;
1238     SV *msv;
1239     STRLEN msglen;
1240
1241     if (pat) {
1242         msv = vmess(pat, args);
1243         if (PL_errors && SvCUR(PL_errors)) {
1244             sv_catsv(PL_errors, msv);
1245             message = SvPV(PL_errors, msglen);
1246             SvCUR_set(PL_errors, 0);
1247         }
1248         else
1249             message = SvPV(msv,msglen);
1250     }
1251     else {
1252         message = Nullch;
1253         msglen = 0;
1254     }
1255
1256     DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1257                           PTR2UV(thr), message));
1258
1259     if (PL_diehook) {
1260         /* sv_2cv might call Perl_croak() */
1261         SV *olddiehook = PL_diehook;
1262         ENTER;
1263         SAVESPTR(PL_diehook);
1264         PL_diehook = Nullsv;
1265         cv = sv_2cv(olddiehook, &stash, &gv, 0);
1266         LEAVE;
1267         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1268             dSP;
1269             SV *msg;
1270
1271             ENTER;
1272             save_re_context();
1273             if (message) {
1274                 msg = newSVpvn(message, msglen);
1275                 SvREADONLY_on(msg);
1276                 SAVEFREESV(msg);
1277             }
1278             else {
1279                 msg = ERRSV;
1280             }
1281
1282             PUSHSTACKi(PERLSI_DIEHOOK);
1283             PUSHMARK(SP);
1284             XPUSHs(msg);
1285             PUTBACK;
1286             call_sv((SV*)cv, G_DISCARD);
1287             POPSTACK;
1288             LEAVE;
1289         }
1290     }
1291     if (PL_in_eval) {
1292         PL_restartop = die_where(message, msglen);
1293         JMPENV_JUMP(3);
1294     }
1295     else if (!message)
1296         message = SvPVx(ERRSV, msglen);
1297
1298     {
1299 #ifdef USE_SFIO
1300         /* SFIO can really mess with your errno */
1301         int e = errno;
1302 #endif
1303         PerlIO *serr = Perl_error_log;
1304
1305         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1306         (void)PerlIO_flush(serr);
1307 #ifdef USE_SFIO
1308         errno = e;
1309 #endif
1310     }
1311     my_failure_exit();
1312 }
1313
1314 #if defined(PERL_IMPLICIT_CONTEXT)
1315 void
1316 Perl_croak_nocontext(const char *pat, ...)
1317 {
1318     dTHX;
1319     va_list args;
1320     va_start(args, pat);
1321     vcroak(pat, &args);
1322     /* NOTREACHED */
1323     va_end(args);
1324 }
1325 #endif /* PERL_IMPLICIT_CONTEXT */
1326
1327 /*
1328 =head1 Warning and Dieing
1329
1330 =for apidoc croak
1331
1332 This is the XSUB-writer's interface to Perl's C<die> function.
1333 Normally use this function the same way you use the C C<printf>
1334 function.  See C<warn>.
1335
1336 If you want to throw an exception object, assign the object to
1337 C<$@> and then pass C<Nullch> to croak():
1338
1339    errsv = get_sv("@", TRUE);
1340    sv_setsv(errsv, exception_object);
1341    croak(Nullch);
1342
1343 =cut
1344 */
1345
1346 void
1347 Perl_croak(pTHX_ const char *pat, ...)
1348 {
1349     va_list args;
1350     va_start(args, pat);
1351     vcroak(pat, &args);
1352     /* NOTREACHED */
1353     va_end(args);
1354 }
1355
1356 void
1357 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1358 {
1359     char *message;
1360     HV *stash;
1361     GV *gv;
1362     CV *cv;
1363     SV *msv;
1364     STRLEN msglen;
1365     IO *io;
1366     MAGIC *mg;
1367
1368     msv = vmess(pat, args);
1369     message = SvPV(msv, msglen);
1370
1371     if (PL_warnhook) {
1372         /* sv_2cv might call Perl_warn() */
1373         SV *oldwarnhook = PL_warnhook;
1374         ENTER;
1375         SAVESPTR(PL_warnhook);
1376         PL_warnhook = Nullsv;
1377         cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1378         LEAVE;
1379         if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1380             dSP;
1381             SV *msg;
1382
1383             ENTER;
1384             save_re_context();
1385             msg = newSVpvn(message, msglen);
1386             SvREADONLY_on(msg);
1387             SAVEFREESV(msg);
1388
1389             PUSHSTACKi(PERLSI_WARNHOOK);
1390             PUSHMARK(SP);
1391             XPUSHs(msg);
1392             PUTBACK;
1393             call_sv((SV*)cv, G_DISCARD);
1394             POPSTACK;
1395             LEAVE;
1396             return;
1397         }
1398     }
1399
1400     /* if STDERR is tied, use it instead */
1401     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1402         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1403         dSP; ENTER;
1404         PUSHMARK(SP);
1405         XPUSHs(SvTIED_obj((SV*)io, mg));
1406         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1407         PUTBACK;
1408         call_method("PRINT", G_SCALAR);
1409         LEAVE;
1410         return;
1411     }
1412
1413     {
1414         PerlIO *serr = Perl_error_log;
1415
1416         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1417 #ifdef LEAKTEST
1418         DEBUG_L(*message == '!'
1419                 ? (xstat(message[1]=='!'
1420                          ? (message[2]=='!' ? 2 : 1)
1421                          : 0)
1422                    , 0)
1423                 : 0);
1424 #endif
1425         (void)PerlIO_flush(serr);
1426     }
1427 }
1428
1429 #if defined(PERL_IMPLICIT_CONTEXT)
1430 void
1431 Perl_warn_nocontext(const char *pat, ...)
1432 {
1433     dTHX;
1434     va_list args;
1435     va_start(args, pat);
1436     vwarn(pat, &args);
1437     va_end(args);
1438 }
1439 #endif /* PERL_IMPLICIT_CONTEXT */
1440
1441 /*
1442 =for apidoc warn
1443
1444 This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
1445 function the same way you use the C C<printf> function.  See
1446 C<croak>.
1447
1448 =cut
1449 */
1450
1451 void
1452 Perl_warn(pTHX_ const char *pat, ...)
1453 {
1454     va_list args;
1455     va_start(args, pat);
1456     vwarn(pat, &args);
1457     va_end(args);
1458 }
1459
1460 #if defined(PERL_IMPLICIT_CONTEXT)
1461 void
1462 Perl_warner_nocontext(U32 err, const char *pat, ...)
1463 {
1464     dTHX;
1465     va_list args;
1466     va_start(args, pat);
1467     vwarner(err, pat, &args);
1468     va_end(args);
1469 }
1470 #endif /* PERL_IMPLICIT_CONTEXT */
1471
1472 void
1473 Perl_warner(pTHX_ U32  err, const char* pat,...)
1474 {
1475     va_list args;
1476     va_start(args, pat);
1477     vwarner(err, pat, &args);
1478     va_end(args);
1479 }
1480
1481 void
1482 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1483 {
1484     char *message;
1485     HV *stash;
1486     GV *gv;
1487     CV *cv;
1488     SV *msv;
1489     STRLEN msglen;
1490
1491     msv = vmess(pat, args);
1492     message = SvPV(msv, msglen);
1493
1494     if (ckDEAD(err)) {
1495 #ifdef USE_5005THREADS
1496         DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
1497 #endif /* USE_5005THREADS */
1498         if (PL_diehook) {
1499             /* sv_2cv might call Perl_croak() */
1500             SV *olddiehook = PL_diehook;
1501             ENTER;
1502             SAVESPTR(PL_diehook);
1503             PL_diehook = Nullsv;
1504             cv = sv_2cv(olddiehook, &stash, &gv, 0);
1505             LEAVE;
1506             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1507                 dSP;
1508                 SV *msg;
1509
1510                 ENTER;
1511                 save_re_context();
1512                 msg = newSVpvn(message, msglen);
1513                 SvREADONLY_on(msg);
1514                 SAVEFREESV(msg);
1515
1516                 PUSHSTACKi(PERLSI_DIEHOOK);
1517                 PUSHMARK(sp);
1518                 XPUSHs(msg);
1519                 PUTBACK;
1520                 call_sv((SV*)cv, G_DISCARD);
1521                 POPSTACK;
1522                 LEAVE;
1523             }
1524         }
1525         if (PL_in_eval) {
1526             PL_restartop = die_where(message, msglen);
1527             JMPENV_JUMP(3);
1528         }
1529         {
1530             PerlIO *serr = Perl_error_log;
1531             PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1532             (void)PerlIO_flush(serr);
1533         }
1534         my_failure_exit();
1535
1536     }
1537     else {
1538         if (PL_warnhook) {
1539             /* sv_2cv might call Perl_warn() */
1540             SV *oldwarnhook = PL_warnhook;
1541             ENTER;
1542             SAVESPTR(PL_warnhook);
1543             PL_warnhook = Nullsv;
1544             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1545             LEAVE;
1546             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1547                 dSP;
1548                 SV *msg;
1549
1550                 ENTER;
1551                 save_re_context();
1552                 msg = newSVpvn(message, msglen);
1553                 SvREADONLY_on(msg);
1554                 SAVEFREESV(msg);
1555
1556                 PUSHSTACKi(PERLSI_WARNHOOK);
1557                 PUSHMARK(sp);
1558                 XPUSHs(msg);
1559                 PUTBACK;
1560                 call_sv((SV*)cv, G_DISCARD);
1561                 POPSTACK;
1562                 LEAVE;
1563                 return;
1564             }
1565         }
1566         {
1567             PerlIO *serr = Perl_error_log;
1568             PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1569 #ifdef LEAKTEST
1570             DEBUG_L(*message == '!'
1571                 ? (xstat(message[1]=='!'
1572                          ? (message[2]=='!' ? 2 : 1)
1573                          : 0)
1574                    , 0)
1575                 : 0);
1576 #endif
1577             (void)PerlIO_flush(serr);
1578         }
1579     }
1580 }
1581
1582 /* since we've already done strlen() for both nam and val
1583  * we can use that info to make things faster than
1584  * sprintf(s, "%s=%s", nam, val)
1585  */
1586 #define my_setenv_format(s, nam, nlen, val, vlen) \
1587    Copy(nam, s, nlen, char); \
1588    *(s+nlen) = '='; \
1589    Copy(val, s+(nlen+1), vlen, char); \
1590    *(s+(nlen+1+vlen)) = '\0'
1591
1592 #ifdef USE_ENVIRON_ARRAY
1593        /* VMS' my_setenv() is in vms.c */
1594 #if !defined(WIN32) && !defined(NETWARE)
1595 void
1596 Perl_my_setenv(pTHX_ char *nam, char *val)
1597 {
1598 #ifndef PERL_USE_SAFE_PUTENV
1599     /* most putenv()s leak, so we manipulate environ directly */
1600     register I32 i=setenv_getix(nam);           /* where does it go? */
1601     int nlen, vlen;
1602
1603     if (environ == PL_origenviron) {    /* need we copy environment? */
1604         I32 j;
1605         I32 max;
1606         char **tmpenv;
1607
1608         /*SUPPRESS 530*/
1609         for (max = i; environ[max]; max++) ;
1610         tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1611         for (j=0; j<max; j++) {         /* copy environment */
1612             int len = strlen(environ[j]);
1613             tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1614             Copy(environ[j], tmpenv[j], len+1, char);
1615         }
1616         tmpenv[max] = Nullch;
1617         environ = tmpenv;               /* tell exec where it is now */
1618     }
1619     if (!val) {
1620         safesysfree(environ[i]);
1621         while (environ[i]) {
1622             environ[i] = environ[i+1];
1623             i++;
1624         }
1625         return;
1626     }
1627     if (!environ[i]) {                  /* does not exist yet */
1628         environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1629         environ[i+1] = Nullch;  /* make sure it's null terminated */
1630     }
1631     else
1632         safesysfree(environ[i]);
1633     nlen = strlen(nam);
1634     vlen = strlen(val);
1635
1636     environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1637     /* all that work just for this */
1638     my_setenv_format(environ[i], nam, nlen, val, vlen);
1639
1640 #else   /* PERL_USE_SAFE_PUTENV */
1641 #   if defined(__CYGWIN__) || defined( EPOC)
1642     setenv(nam, val, 1);
1643 #   else
1644     char *new_env;
1645     int nlen = strlen(nam), vlen;
1646     if (!val) {
1647         val = "";
1648     }
1649     vlen = strlen(val);
1650     new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1651     /* all that work just for this */
1652     my_setenv_format(new_env, nam, nlen, val, vlen);
1653     (void)putenv(new_env);
1654 #   endif /* __CYGWIN__ */
1655 #endif  /* PERL_USE_SAFE_PUTENV */
1656 }
1657
1658 #else /* WIN32 || NETWARE */
1659
1660 void
1661 Perl_my_setenv(pTHX_ char *nam,char *val)
1662 {
1663     register char *envstr;
1664     int nlen = strlen(nam), vlen;
1665
1666     if (!val) {
1667         val = "";
1668     }
1669     vlen = strlen(val);
1670     New(904, envstr, nlen+vlen+2, char);
1671     my_setenv_format(envstr, nam, nlen, val, vlen);
1672     (void)PerlEnv_putenv(envstr);
1673     Safefree(envstr);
1674 }
1675
1676 #endif /* WIN32 || NETWARE */
1677
1678 I32
1679 Perl_setenv_getix(pTHX_ char *nam)
1680 {
1681     register I32 i, len = strlen(nam);
1682
1683     for (i = 0; environ[i]; i++) {
1684         if (
1685 #ifdef WIN32
1686             strnicmp(environ[i],nam,len) == 0
1687 #else
1688             strnEQ(environ[i],nam,len)
1689 #endif
1690             && environ[i][len] == '=')
1691             break;                      /* strnEQ must come first to avoid */
1692     }                                   /* potential SEGV's */
1693     return i;
1694 }
1695
1696 #endif /* !VMS && !EPOC*/
1697
1698 #ifdef UNLINK_ALL_VERSIONS
1699 I32
1700 Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1701 {
1702     I32 i;
1703
1704     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1705     return i ? 0 : -1;
1706 }
1707 #endif
1708
1709 /* this is a drop-in replacement for bcopy() */
1710 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1711 char *
1712 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1713 {
1714     char *retval = to;
1715
1716     if (from - to >= 0) {
1717         while (len--)
1718             *to++ = *from++;
1719     }
1720     else {
1721         to += len;
1722         from += len;
1723         while (len--)
1724             *(--to) = *(--from);
1725     }
1726     return retval;
1727 }
1728 #endif
1729
1730 /* this is a drop-in replacement for memset() */
1731 #ifndef HAS_MEMSET
1732 void *
1733 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1734 {
1735     char *retval = loc;
1736
1737     while (len--)
1738         *loc++ = ch;
1739     return retval;
1740 }
1741 #endif
1742
1743 /* this is a drop-in replacement for bzero() */
1744 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1745 char *
1746 Perl_my_bzero(register char *loc, register I32 len)
1747 {
1748     char *retval = loc;
1749
1750     while (len--)
1751         *loc++ = 0;
1752     return retval;
1753 }
1754 #endif
1755
1756 /* this is a drop-in replacement for memcmp() */
1757 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1758 I32
1759 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1760 {
1761     register U8 *a = (U8 *)s1;
1762     register U8 *b = (U8 *)s2;
1763     register I32 tmp;
1764
1765     while (len--) {
1766         if (tmp = *a++ - *b++)
1767             return tmp;
1768     }
1769     return 0;
1770 }
1771 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1772
1773 #ifndef HAS_VPRINTF
1774
1775 #ifdef USE_CHAR_VSPRINTF
1776 char *
1777 #else
1778 int
1779 #endif
1780 vsprintf(char *dest, const char *pat, char *args)
1781 {
1782     FILE fakebuf;
1783
1784     fakebuf._ptr = dest;
1785     fakebuf._cnt = 32767;
1786 #ifndef _IOSTRG
1787 #define _IOSTRG 0
1788 #endif
1789     fakebuf._flag = _IOWRT|_IOSTRG;
1790     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1791     (void)putc('\0', &fakebuf);
1792 #ifdef USE_CHAR_VSPRINTF
1793     return(dest);
1794 #else
1795     return 0;           /* perl doesn't use return value */
1796 #endif
1797 }
1798
1799 #endif /* HAS_VPRINTF */
1800
1801 #ifdef MYSWAP
1802 #if BYTEORDER != 0x4321
1803 short
1804 Perl_my_swap(pTHX_ short s)
1805 {
1806 #if (BYTEORDER & 1) == 0
1807     short result;
1808
1809     result = ((s & 255) << 8) + ((s >> 8) & 255);
1810     return result;
1811 #else
1812     return s;
1813 #endif
1814 }
1815
1816 long
1817 Perl_my_htonl(pTHX_ long l)
1818 {
1819     union {
1820         long result;
1821         char c[sizeof(long)];
1822     } u;
1823
1824 #if BYTEORDER == 0x1234
1825     u.c[0] = (l >> 24) & 255;
1826     u.c[1] = (l >> 16) & 255;
1827     u.c[2] = (l >> 8) & 255;
1828     u.c[3] = l & 255;
1829     return u.result;
1830 #else
1831 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1832     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1833 #else
1834     register I32 o;
1835     register I32 s;
1836
1837     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1838         u.c[o & 0xf] = (l >> s) & 255;
1839     }
1840     return u.result;
1841 #endif
1842 #endif
1843 }
1844
1845 long
1846 Perl_my_ntohl(pTHX_ long l)
1847 {
1848     union {
1849         long l;
1850         char c[sizeof(long)];
1851     } u;
1852
1853 #if BYTEORDER == 0x1234
1854     u.c[0] = (l >> 24) & 255;
1855     u.c[1] = (l >> 16) & 255;
1856     u.c[2] = (l >> 8) & 255;
1857     u.c[3] = l & 255;
1858     return u.l;
1859 #else
1860 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1861     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1862 #else
1863     register I32 o;
1864     register I32 s;
1865
1866     u.l = l;
1867     l = 0;
1868     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1869         l |= (u.c[o & 0xf] & 255) << s;
1870     }
1871     return l;
1872 #endif
1873 #endif
1874 }
1875
1876 #endif /* BYTEORDER != 0x4321 */
1877 #endif /* MYSWAP */
1878
1879 /*
1880  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1881  * If these functions are defined,
1882  * the BYTEORDER is neither 0x1234 nor 0x4321.
1883  * However, this is not assumed.
1884  * -DWS
1885  */
1886
1887 #define HTOV(name,type)                                         \
1888         type                                                    \
1889         name (register type n)                                  \
1890         {                                                       \
1891             union {                                             \
1892                 type value;                                     \
1893                 char c[sizeof(type)];                           \
1894             } u;                                                \
1895             register I32 i;                                     \
1896             register I32 s;                                     \
1897             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1898                 u.c[i] = (n >> s) & 0xFF;                       \
1899             }                                                   \
1900             return u.value;                                     \
1901         }
1902
1903 #define VTOH(name,type)                                         \
1904         type                                                    \
1905         name (register type n)                                  \
1906         {                                                       \
1907             union {                                             \
1908                 type value;                                     \
1909                 char c[sizeof(type)];                           \
1910             } u;                                                \
1911             register I32 i;                                     \
1912             register I32 s;                                     \
1913             u.value = n;                                        \
1914             n = 0;                                              \
1915             for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {  \
1916                 n += (u.c[i] & 0xFF) << s;                      \
1917             }                                                   \
1918             return n;                                           \
1919         }
1920
1921 #if defined(HAS_HTOVS) && !defined(htovs)
1922 HTOV(htovs,short)
1923 #endif
1924 #if defined(HAS_HTOVL) && !defined(htovl)
1925 HTOV(htovl,long)
1926 #endif
1927 #if defined(HAS_VTOHS) && !defined(vtohs)
1928 VTOH(vtohs,short)
1929 #endif
1930 #if defined(HAS_VTOHL) && !defined(vtohl)
1931 VTOH(vtohl,long)
1932 #endif
1933
1934 PerlIO *
1935 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1936 {
1937 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1938     int p[2];
1939     register I32 This, that;
1940     register Pid_t pid;
1941     SV *sv;
1942     I32 did_pipes = 0;
1943     int pp[2];
1944
1945     PERL_FLUSHALL_FOR_CHILD;
1946     This = (*mode == 'w');
1947     that = !This;
1948     if (PL_tainting) {
1949         taint_env();
1950         taint_proper("Insecure %s%s", "EXEC");
1951     }
1952     if (PerlProc_pipe(p) < 0)
1953         return Nullfp;
1954     /* Try for another pipe pair for error return */
1955     if (PerlProc_pipe(pp) >= 0)
1956         did_pipes = 1;
1957     while ((pid = PerlProc_fork()) < 0) {
1958         if (errno != EAGAIN) {
1959             PerlLIO_close(p[This]);
1960             if (did_pipes) {
1961                 PerlLIO_close(pp[0]);
1962                 PerlLIO_close(pp[1]);
1963             }
1964             return Nullfp;
1965         }
1966         sleep(5);
1967     }
1968     if (pid == 0) {
1969         /* Child */
1970 #undef THIS
1971 #undef THAT
1972 #define THIS that
1973 #define THAT This
1974         /* Close parent's end of _the_ pipe */
1975         PerlLIO_close(p[THAT]);
1976         /* Close parent's end of error status pipe (if any) */
1977         if (did_pipes) {
1978             PerlLIO_close(pp[0]);
1979 #if defined(HAS_FCNTL) && defined(F_SETFD)
1980             /* Close error pipe automatically if exec works */
1981             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1982 #endif
1983         }
1984         /* Now dup our end of _the_ pipe to right position */
1985         if (p[THIS] != (*mode == 'r')) {
1986             PerlLIO_dup2(p[THIS], *mode == 'r');
1987             PerlLIO_close(p[THIS]);
1988         }
1989 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1990         /* No automatic close - do it by hand */
1991 #  ifndef NOFILE
1992 #  define NOFILE 20
1993 #  endif
1994         {
1995             int fd;
1996
1997             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
1998                 if (fd != pp[1])
1999                     PerlLIO_close(fd);
2000             }
2001         }
2002 #endif
2003         do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2004         PerlProc__exit(1);
2005 #undef THIS
2006 #undef THAT
2007     }
2008     /* Parent */
2009     do_execfree();      /* free any memory malloced by child on fork */
2010     /* Close child's end of pipe */
2011     PerlLIO_close(p[that]);
2012     if (did_pipes)
2013         PerlLIO_close(pp[1]);
2014     /* Keep the lower of the two fd numbers */
2015     if (p[that] < p[This]) {
2016         PerlLIO_dup2(p[This], p[that]);
2017         PerlLIO_close(p[This]);
2018         p[This] = p[that];
2019     }
2020     LOCK_FDPID_MUTEX;
2021     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2022     UNLOCK_FDPID_MUTEX;
2023     (void)SvUPGRADE(sv,SVt_IV);
2024     SvIVX(sv) = pid;
2025     PL_forkprocess = pid;
2026     /* If we managed to get status pipe check for exec fail */
2027     if (did_pipes && pid > 0) {
2028         int errkid;
2029         int n = 0, n1;
2030
2031         while (n < sizeof(int)) {
2032             n1 = PerlLIO_read(pp[0],
2033                               (void*)(((char*)&errkid)+n),
2034                               (sizeof(int)) - n);
2035             if (n1 <= 0)
2036                 break;
2037             n += n1;
2038         }
2039         PerlLIO_close(pp[0]);
2040         did_pipes = 0;
2041         if (n) {                        /* Error */
2042             int pid2, status;
2043             PerlLIO_close(p[This]);
2044             if (n != sizeof(int))
2045                 Perl_croak(aTHX_ "panic: kid popen errno read");
2046             do {
2047                 pid2 = wait4pid(pid, &status, 0);
2048             } while (pid2 == -1 && errno == EINTR);
2049             errno = errkid;             /* Propagate errno from kid */
2050             return Nullfp;
2051         }
2052     }
2053     if (did_pipes)
2054          PerlLIO_close(pp[0]);
2055     return PerlIO_fdopen(p[This], mode);
2056 #else
2057     Perl_croak(aTHX_ "List form of piped open not implemented");
2058     return (PerlIO *) NULL;
2059 #endif
2060 }
2061
2062     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2063 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2064 PerlIO *
2065 Perl_my_popen(pTHX_ char *cmd, char *mode)
2066 {
2067     int p[2];
2068     register I32 This, that;
2069     register Pid_t pid;
2070     SV *sv;
2071     I32 doexec = strNE(cmd,"-");
2072     I32 did_pipes = 0;
2073     int pp[2];
2074
2075     PERL_FLUSHALL_FOR_CHILD;
2076 #ifdef OS2
2077     if (doexec) {
2078         return my_syspopen(aTHX_ cmd,mode);
2079     }
2080 #endif
2081     This = (*mode == 'w');
2082     that = !This;
2083     if (doexec && PL_tainting) {
2084         taint_env();
2085         taint_proper("Insecure %s%s", "EXEC");
2086     }
2087     if (PerlProc_pipe(p) < 0)
2088         return Nullfp;
2089     if (doexec && PerlProc_pipe(pp) >= 0)
2090         did_pipes = 1;
2091     while ((pid = PerlProc_fork()) < 0) {
2092         if (errno != EAGAIN) {
2093             PerlLIO_close(p[This]);
2094             if (did_pipes) {
2095                 PerlLIO_close(pp[0]);
2096                 PerlLIO_close(pp[1]);
2097             }
2098             if (!doexec)
2099                 Perl_croak(aTHX_ "Can't fork");
2100             return Nullfp;
2101         }
2102         sleep(5);
2103     }
2104     if (pid == 0) {
2105         GV* tmpgv;
2106
2107 #undef THIS
2108 #undef THAT
2109 #define THIS that
2110 #define THAT This
2111         PerlLIO_close(p[THAT]);
2112         if (did_pipes) {
2113             PerlLIO_close(pp[0]);
2114 #if defined(HAS_FCNTL) && defined(F_SETFD)
2115             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2116 #endif
2117         }
2118         if (p[THIS] != (*mode == 'r')) {
2119             PerlLIO_dup2(p[THIS], *mode == 'r');
2120             PerlLIO_close(p[THIS]);
2121         }
2122 #ifndef OS2
2123         if (doexec) {
2124 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2125             int fd;
2126
2127 #ifndef NOFILE
2128 #define NOFILE 20
2129 #endif
2130             {
2131                 int fd;
2132
2133                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2134                     if (fd != pp[1])
2135                         PerlLIO_close(fd);
2136             }
2137 #endif
2138             /* may or may not use the shell */
2139             do_exec3(cmd, pp[1], did_pipes);
2140             PerlProc__exit(1);
2141         }
2142 #endif  /* defined OS2 */
2143         /*SUPPRESS 560*/
2144         if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2145         SvREADONLY_off(GvSV(tmpgv));
2146             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2147         SvREADONLY_on(GvSV(tmpgv));
2148     }
2149         PL_forkprocess = 0;
2150         hv_clear(PL_pidstatus); /* we have no children */
2151         return Nullfp;
2152 #undef THIS
2153 #undef THAT
2154     }
2155     do_execfree();      /* free any memory malloced by child on fork */
2156     PerlLIO_close(p[that]);
2157     if (did_pipes)
2158         PerlLIO_close(pp[1]);
2159     if (p[that] < p[This]) {
2160         PerlLIO_dup2(p[This], p[that]);
2161         PerlLIO_close(p[This]);
2162         p[This] = p[that];
2163     }
2164     LOCK_FDPID_MUTEX;
2165     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2166     UNLOCK_FDPID_MUTEX;
2167     (void)SvUPGRADE(sv,SVt_IV);
2168     SvIVX(sv) = pid;
2169     PL_forkprocess = pid;
2170     if (did_pipes && pid > 0) {
2171         int errkid;
2172         int n = 0, n1;
2173
2174         while (n < sizeof(int)) {
2175             n1 = PerlLIO_read(pp[0],
2176                               (void*)(((char*)&errkid)+n),
2177                               (sizeof(int)) - n);
2178             if (n1 <= 0)
2179                 break;
2180             n += n1;
2181         }
2182         PerlLIO_close(pp[0]);
2183         did_pipes = 0;
2184         if (n) {                        /* Error */
2185             int pid2, status;
2186             PerlLIO_close(p[This]);
2187             if (n != sizeof(int))
2188                 Perl_croak(aTHX_ "panic: kid popen errno read");
2189             do {
2190                 pid2 = wait4pid(pid, &status, 0);
2191             } while (pid2 == -1 && errno == EINTR);
2192             errno = errkid;             /* Propagate errno from kid */
2193             return Nullfp;
2194         }
2195     }
2196     if (did_pipes)
2197          PerlLIO_close(pp[0]);
2198     return PerlIO_fdopen(p[This], mode);
2199 }
2200 #else
2201 #if defined(atarist) || defined(EPOC)
2202 FILE *popen();
2203 PerlIO *
2204 Perl_my_popen(pTHX_ char *cmd, char *mode)
2205 {
2206     PERL_FLUSHALL_FOR_CHILD;
2207     /* Call system's popen() to get a FILE *, then import it.
2208        used 0 for 2nd parameter to PerlIO_importFILE;
2209        apparently not used
2210     */
2211     return PerlIO_importFILE(popen(cmd, mode), 0);
2212 }
2213 #else
2214 #if defined(DJGPP)
2215 FILE *djgpp_popen();
2216 PerlIO *
2217 Perl_my_popen(pTHX_ char *cmd, char *mode)
2218 {
2219     PERL_FLUSHALL_FOR_CHILD;
2220     /* Call system's popen() to get a FILE *, then import it.
2221        used 0 for 2nd parameter to PerlIO_importFILE;
2222        apparently not used
2223     */
2224     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2225 }
2226 #endif
2227 #endif
2228
2229 #endif /* !DOSISH */
2230
2231 /* this is called in parent before the fork() */
2232 void
2233 Perl_atfork_lock(void)
2234 {
2235 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2236     /* locks must be held in locking order (if any) */
2237 #  ifdef MYMALLOC
2238     MUTEX_LOCK(&PL_malloc_mutex);
2239 #  endif
2240     OP_REFCNT_LOCK;
2241 #endif
2242 }
2243
2244 /* this is called in both parent and child after the fork() */
2245 void
2246 Perl_atfork_unlock(void)
2247 {
2248 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2249     /* locks must be released in same order as in atfork_lock() */
2250 #  ifdef MYMALLOC
2251     MUTEX_UNLOCK(&PL_malloc_mutex);
2252 #  endif
2253     OP_REFCNT_UNLOCK;
2254 #endif
2255 }
2256
2257 Pid_t
2258 Perl_my_fork(void)
2259 {
2260 #if defined(HAS_FORK)
2261     Pid_t pid;
2262 #if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
2263     atfork_lock();
2264     pid = fork();
2265     atfork_unlock();
2266 #else
2267     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2268      * handlers elsewhere in the code */
2269     pid = fork();
2270 #endif
2271     return pid;
2272 #else
2273     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2274     Perl_croak_nocontext("fork() not available");
2275     return 0;
2276 #endif /* HAS_FORK */
2277 }
2278
2279 #ifdef DUMP_FDS
2280 void
2281 Perl_dump_fds(pTHX_ char *s)
2282 {
2283     int fd;
2284     Stat_t tmpstatbuf;
2285
2286     PerlIO_printf(Perl_debug_log,"%s", s);
2287     for (fd = 0; fd < 32; fd++) {
2288         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2289             PerlIO_printf(Perl_debug_log," %d",fd);
2290     }
2291     PerlIO_printf(Perl_debug_log,"\n");
2292 }
2293 #endif  /* DUMP_FDS */
2294
2295 #ifndef HAS_DUP2
2296 int
2297 dup2(int oldfd, int newfd)
2298 {
2299 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2300     if (oldfd == newfd)
2301         return oldfd;
2302     PerlLIO_close(newfd);
2303     return fcntl(oldfd, F_DUPFD, newfd);
2304 #else
2305 #define DUP2_MAX_FDS 256
2306     int fdtmp[DUP2_MAX_FDS];
2307     I32 fdx = 0;
2308     int fd;
2309
2310     if (oldfd == newfd)
2311         return oldfd;
2312     PerlLIO_close(newfd);
2313     /* good enough for low fd's... */
2314     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2315         if (fdx >= DUP2_MAX_FDS) {
2316             PerlLIO_close(fd);
2317             fd = -1;
2318             break;
2319         }
2320         fdtmp[fdx++] = fd;
2321     }
2322     while (fdx > 0)
2323         PerlLIO_close(fdtmp[--fdx]);
2324     return fd;
2325 #endif
2326 }
2327 #endif
2328
2329 #ifndef PERL_MICRO
2330 #ifdef HAS_SIGACTION
2331
2332 Sighandler_t
2333 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2334 {
2335     struct sigaction act, oact;
2336
2337     act.sa_handler = handler;
2338     sigemptyset(&act.sa_mask);
2339     act.sa_flags = 0;
2340 #ifdef SA_RESTART
2341 #if defined(PERL_OLD_SIGNALS)
2342     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2343 #endif
2344 #endif
2345 #ifdef SA_NOCLDWAIT
2346     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2347         act.sa_flags |= SA_NOCLDWAIT;
2348 #endif
2349     if (sigaction(signo, &act, &oact) == -1)
2350         return SIG_ERR;
2351     else
2352         return oact.sa_handler;
2353 }
2354
2355 Sighandler_t
2356 Perl_rsignal_state(pTHX_ int signo)
2357 {
2358     struct sigaction oact;
2359
2360     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2361         return SIG_ERR;
2362     else
2363         return oact.sa_handler;
2364 }
2365
2366 int
2367 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2368 {
2369     struct sigaction act;
2370
2371     act.sa_handler = handler;
2372     sigemptyset(&act.sa_mask);
2373     act.sa_flags = 0;
2374 #ifdef SA_RESTART
2375 #if defined(PERL_OLD_SIGNALS)
2376     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2377 #endif
2378 #endif
2379 #ifdef SA_NOCLDWAIT
2380     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2381         act.sa_flags |= SA_NOCLDWAIT;
2382 #endif
2383     return sigaction(signo, &act, save);
2384 }
2385
2386 int
2387 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2388 {
2389     return sigaction(signo, save, (struct sigaction *)NULL);
2390 }
2391
2392 #else /* !HAS_SIGACTION */
2393
2394 Sighandler_t
2395 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2396 {
2397     return PerlProc_signal(signo, handler);
2398 }
2399
2400 static int sig_trapped; /* XXX signals are process-wide anyway, so we
2401                            ignore the implications of this for threading */
2402
2403 static
2404 Signal_t
2405 sig_trap(int signo)
2406 {
2407     sig_trapped++;
2408 }
2409
2410 Sighandler_t
2411 Perl_rsignal_state(pTHX_ int signo)
2412 {
2413     Sighandler_t oldsig;
2414
2415     sig_trapped = 0;
2416     oldsig = PerlProc_signal(signo, sig_trap);
2417     PerlProc_signal(signo, oldsig);
2418     if (sig_trapped)
2419         PerlProc_kill(PerlProc_getpid(), signo);
2420     return oldsig;
2421 }
2422
2423 int
2424 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2425 {
2426     *save = PerlProc_signal(signo, handler);
2427     return (*save == SIG_ERR) ? -1 : 0;
2428 }
2429
2430 int
2431 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2432 {
2433     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2434 }
2435
2436 #endif /* !HAS_SIGACTION */
2437 #endif /* !PERL_MICRO */
2438
2439     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2440 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2441 I32
2442 Perl_my_pclose(pTHX_ PerlIO *ptr)
2443 {
2444     Sigsave_t hstat, istat, qstat;
2445     int status;
2446     SV **svp;
2447     Pid_t pid;
2448     Pid_t pid2;
2449     bool close_failed;
2450     int saved_errno = 0;
2451 #ifdef VMS
2452     int saved_vaxc_errno;
2453 #endif
2454 #ifdef WIN32
2455     int saved_win32_errno;
2456 #endif
2457
2458     LOCK_FDPID_MUTEX;
2459     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2460     UNLOCK_FDPID_MUTEX;
2461     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2462     SvREFCNT_dec(*svp);
2463     *svp = &PL_sv_undef;
2464 #ifdef OS2
2465     if (pid == -1) {                    /* Opened by popen. */
2466         return my_syspclose(ptr);
2467     }
2468 #endif
2469     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2470         saved_errno = errno;
2471 #ifdef VMS
2472         saved_vaxc_errno = vaxc$errno;
2473 #endif
2474 #ifdef WIN32
2475         saved_win32_errno = GetLastError();
2476 #endif
2477     }
2478 #ifdef UTS
2479     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2480 #endif
2481 #ifndef PERL_MICRO
2482     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2483     rsignal_save(SIGINT, SIG_IGN, &istat);
2484     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2485 #endif
2486     do {
2487         pid2 = wait4pid(pid, &status, 0);
2488     } while (pid2 == -1 && errno == EINTR);
2489 #ifndef PERL_MICRO
2490     rsignal_restore(SIGHUP, &hstat);
2491     rsignal_restore(SIGINT, &istat);
2492     rsignal_restore(SIGQUIT, &qstat);
2493 #endif
2494     if (close_failed) {
2495         SETERRNO(saved_errno, saved_vaxc_errno);
2496         return -1;
2497     }
2498     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2499 }
2500 #endif /* !DOSISH */
2501
2502 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2503 I32
2504 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2505 {
2506     I32 result;
2507     if (!pid)
2508         return -1;
2509 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2510     {
2511     SV *sv;
2512     SV** svp;
2513     char spid[TYPE_CHARS(int)];
2514
2515     if (pid > 0) {
2516         sprintf(spid, "%"IVdf, (IV)pid);
2517         svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2518         if (svp && *svp != &PL_sv_undef) {
2519             *statusp = SvIVX(*svp);
2520             (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2521             return pid;
2522         }
2523     }
2524     else {
2525         HE *entry;
2526
2527         hv_iterinit(PL_pidstatus);
2528         if ((entry = hv_iternext(PL_pidstatus))) {
2529             SV *sv;
2530             char spid[TYPE_CHARS(int)];
2531
2532             pid = atoi(hv_iterkey(entry,(I32*)statusp));
2533             sv = hv_iterval(PL_pidstatus,entry);
2534             *statusp = SvIVX(sv);
2535             sprintf(spid, "%"IVdf, (IV)pid);
2536             (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2537             return pid;
2538         }
2539         }
2540     }
2541 #endif
2542 #ifdef HAS_WAITPID
2543 #  ifdef HAS_WAITPID_RUNTIME
2544     if (!HAS_WAITPID_RUNTIME)
2545         goto hard_way;
2546 #  endif
2547     result = PerlProc_waitpid(pid,statusp,flags);
2548     goto finish;
2549 #endif
2550 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2551     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2552     goto finish;
2553 #endif
2554 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2555   hard_way:
2556     {
2557         if (flags)
2558             Perl_croak(aTHX_ "Can't do waitpid with flags");
2559         else {
2560             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2561                 pidgone(result,*statusp);
2562             if (result < 0)
2563                 *statusp = -1;
2564         }
2565     }
2566 #endif
2567   finish:
2568     if (result < 0 && errno == EINTR) {
2569         PERL_ASYNC_CHECK();
2570     }
2571     return result;
2572 }
2573 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2574
2575 void
2576 /*SUPPRESS 590*/
2577 Perl_pidgone(pTHX_ Pid_t pid, int status)
2578 {
2579     register SV *sv;
2580     char spid[TYPE_CHARS(int)];
2581
2582     sprintf(spid, "%"IVdf, (IV)pid);
2583     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2584     (void)SvUPGRADE(sv,SVt_IV);
2585     SvIVX(sv) = status;
2586     return;
2587 }
2588
2589 #if defined(atarist) || defined(OS2) || defined(EPOC)
2590 int pclose();
2591 #ifdef HAS_FORK
2592 int                                     /* Cannot prototype with I32
2593                                            in os2ish.h. */
2594 my_syspclose(PerlIO *ptr)
2595 #else
2596 I32
2597 Perl_my_pclose(pTHX_ PerlIO *ptr)
2598 #endif
2599 {
2600     /* Needs work for PerlIO ! */
2601     FILE *f = PerlIO_findFILE(ptr);
2602     I32 result = pclose(f);
2603     PerlIO_releaseFILE(ptr,f);
2604     return result;
2605 }
2606 #endif
2607
2608 #if defined(DJGPP)
2609 int djgpp_pclose();
2610 I32
2611 Perl_my_pclose(pTHX_ PerlIO *ptr)
2612 {
2613     /* Needs work for PerlIO ! */
2614     FILE *f = PerlIO_findFILE(ptr);
2615     I32 result = djgpp_pclose(f);
2616     result = (result << 8) & 0xff00;
2617     PerlIO_releaseFILE(ptr,f);
2618     return result;
2619 }
2620 #endif
2621
2622 void
2623 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2624 {
2625     register I32 todo;
2626     register const char *frombase = from;
2627
2628     if (len == 1) {
2629         register const char c = *from;
2630         while (count-- > 0)
2631             *to++ = c;
2632         return;
2633     }
2634     while (count-- > 0) {
2635         for (todo = len; todo > 0; todo--) {
2636             *to++ = *from++;
2637         }
2638         from = frombase;
2639     }
2640 }
2641
2642 #ifndef HAS_RENAME
2643 I32
2644 Perl_same_dirent(pTHX_ char *a, char *b)
2645 {
2646     char *fa = strrchr(a,'/');
2647     char *fb = strrchr(b,'/');
2648     Stat_t tmpstatbuf1;
2649     Stat_t tmpstatbuf2;
2650     SV *tmpsv = sv_newmortal();
2651
2652     if (fa)
2653         fa++;
2654     else
2655         fa = a;
2656     if (fb)
2657         fb++;
2658     else
2659         fb = b;
2660     if (strNE(a,b))
2661         return FALSE;
2662     if (fa == a)
2663         sv_setpv(tmpsv, ".");
2664     else
2665         sv_setpvn(tmpsv, a, fa - a);
2666     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
2667         return FALSE;
2668     if (fb == b)
2669         sv_setpv(tmpsv, ".");
2670     else
2671         sv_setpvn(tmpsv, b, fb - b);
2672     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
2673         return FALSE;
2674     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2675            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2676 }
2677 #endif /* !HAS_RENAME */
2678
2679 char*
2680 Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
2681 {
2682     char *xfound = Nullch;
2683     char *xfailed = Nullch;
2684     char tmpbuf[MAXPATHLEN];
2685     register char *s;
2686     I32 len = 0;
2687     int retval;
2688 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2689 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2690 #  define MAX_EXT_LEN 4
2691 #endif
2692 #ifdef OS2
2693 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2694 #  define MAX_EXT_LEN 4
2695 #endif
2696 #ifdef VMS
2697 #  define SEARCH_EXTS ".pl", ".com", NULL
2698 #  define MAX_EXT_LEN 4
2699 #endif
2700     /* additional extensions to try in each dir if scriptname not found */
2701 #ifdef SEARCH_EXTS
2702     char *exts[] = { SEARCH_EXTS };
2703     char **ext = search_ext ? search_ext : exts;
2704     int extidx = 0, i = 0;
2705     char *curext = Nullch;
2706 #else
2707 #  define MAX_EXT_LEN 0
2708 #endif
2709
2710     /*
2711      * If dosearch is true and if scriptname does not contain path
2712      * delimiters, search the PATH for scriptname.
2713      *
2714      * If SEARCH_EXTS is also defined, will look for each
2715      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2716      * while searching the PATH.
2717      *
2718      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2719      * proceeds as follows:
2720      *   If DOSISH or VMSISH:
2721      *     + look for ./scriptname{,.foo,.bar}
2722      *     + search the PATH for scriptname{,.foo,.bar}
2723      *
2724      *   If !DOSISH:
2725      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2726      *       this will not look in '.' if it's not in the PATH)
2727      */
2728     tmpbuf[0] = '\0';
2729
2730 #ifdef VMS
2731 #  ifdef ALWAYS_DEFTYPES
2732     len = strlen(scriptname);
2733     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2734         int hasdir, idx = 0, deftypes = 1;
2735         bool seen_dot = 1;
2736
2737         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2738 #  else
2739     if (dosearch) {
2740         int hasdir, idx = 0, deftypes = 1;
2741         bool seen_dot = 1;
2742
2743         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2744 #  endif
2745         /* The first time through, just add SEARCH_EXTS to whatever we
2746          * already have, so we can check for default file types. */
2747         while (deftypes ||
2748                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2749         {
2750             if (deftypes) {
2751                 deftypes = 0;
2752                 *tmpbuf = '\0';
2753             }
2754             if ((strlen(tmpbuf) + strlen(scriptname)
2755                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2756                 continue;       /* don't search dir with too-long name */
2757             strcat(tmpbuf, scriptname);
2758 #else  /* !VMS */
2759
2760 #ifdef DOSISH
2761     if (strEQ(scriptname, "-"))
2762         dosearch = 0;
2763     if (dosearch) {             /* Look in '.' first. */
2764         char *cur = scriptname;
2765 #ifdef SEARCH_EXTS
2766         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2767             while (ext[i])
2768                 if (strEQ(ext[i++],curext)) {
2769                     extidx = -1;                /* already has an ext */
2770                     break;
2771                 }
2772         do {
2773 #endif
2774             DEBUG_p(PerlIO_printf(Perl_debug_log,
2775                                   "Looking for %s\n",cur));
2776             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2777                 && !S_ISDIR(PL_statbuf.st_mode)) {
2778                 dosearch = 0;
2779                 scriptname = cur;
2780 #ifdef SEARCH_EXTS
2781                 break;
2782 #endif
2783             }
2784 #ifdef SEARCH_EXTS
2785             if (cur == scriptname) {
2786                 len = strlen(scriptname);
2787                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2788                     break;
2789                 cur = strcpy(tmpbuf, scriptname);
2790             }
2791         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2792                  && strcpy(tmpbuf+len, ext[extidx++]));
2793 #endif
2794     }
2795 #endif
2796
2797 #ifdef MACOS_TRADITIONAL
2798     if (dosearch && !strchr(scriptname, ':') &&
2799         (s = PerlEnv_getenv("Commands")))
2800 #else
2801     if (dosearch && !strchr(scriptname, '/')
2802 #ifdef DOSISH
2803                  && !strchr(scriptname, '\\')
2804 #endif
2805                  && (s = PerlEnv_getenv("PATH")))
2806 #endif
2807     {
2808         bool seen_dot = 0;
2809
2810         PL_bufend = s + strlen(s);
2811         while (s < PL_bufend) {
2812 #ifdef MACOS_TRADITIONAL
2813             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2814                         ',',
2815                         &len);
2816 #else
2817 #if defined(atarist) || defined(DOSISH)
2818             for (len = 0; *s
2819 #  ifdef atarist
2820                     && *s != ','
2821 #  endif
2822                     && *s != ';'; len++, s++) {
2823                 if (len < sizeof tmpbuf)
2824                     tmpbuf[len] = *s;
2825             }
2826             if (len < sizeof tmpbuf)
2827                 tmpbuf[len] = '\0';
2828 #else  /* ! (atarist || DOSISH) */
2829             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2830                         ':',
2831                         &len);
2832 #endif /* ! (atarist || DOSISH) */
2833 #endif /* MACOS_TRADITIONAL */
2834             if (s < PL_bufend)
2835                 s++;
2836             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2837                 continue;       /* don't search dir with too-long name */
2838 #ifdef MACOS_TRADITIONAL
2839             if (len && tmpbuf[len - 1] != ':')
2840                 tmpbuf[len++] = ':';
2841 #else
2842             if (len
2843 #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2844                 && tmpbuf[len - 1] != '/'
2845                 && tmpbuf[len - 1] != '\\'
2846 #endif
2847                )
2848                 tmpbuf[len++] = '/';
2849             if (len == 2 && tmpbuf[0] == '.')
2850                 seen_dot = 1;
2851 #endif
2852             (void)strcpy(tmpbuf + len, scriptname);
2853 #endif  /* !VMS */
2854
2855 #ifdef SEARCH_EXTS
2856             len = strlen(tmpbuf);
2857             if (extidx > 0)     /* reset after previous loop */
2858                 extidx = 0;
2859             do {
2860 #endif
2861                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2862                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2863                 if (S_ISDIR(PL_statbuf.st_mode)) {
2864                     retval = -1;
2865                 }
2866 #ifdef SEARCH_EXTS
2867             } while (  retval < 0               /* not there */
2868                     && extidx>=0 && ext[extidx] /* try an extension? */
2869                     && strcpy(tmpbuf+len, ext[extidx++])
2870                 );
2871 #endif
2872             if (retval < 0)
2873                 continue;
2874             if (S_ISREG(PL_statbuf.st_mode)
2875                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2876 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2877                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2878 #endif
2879                 )
2880             {
2881                 xfound = tmpbuf;              /* bingo! */
2882                 break;
2883             }
2884             if (!xfailed)
2885                 xfailed = savepv(tmpbuf);
2886         }
2887 #ifndef DOSISH
2888         if (!xfound && !seen_dot && !xfailed &&
2889             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2890              || S_ISDIR(PL_statbuf.st_mode)))
2891 #endif
2892             seen_dot = 1;                       /* Disable message. */
2893         if (!xfound) {
2894             if (flags & 1) {                    /* do or die? */
2895                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2896                       (xfailed ? "execute" : "find"),
2897                       (xfailed ? xfailed : scriptname),
2898                       (xfailed ? "" : " on PATH"),
2899                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2900             }
2901             scriptname = Nullch;
2902         }
2903         if (xfailed)
2904             Safefree(xfailed);
2905         scriptname = xfound;
2906     }
2907     return (scriptname ? savepv(scriptname) : Nullch);
2908 }
2909
2910 #ifndef PERL_GET_CONTEXT_DEFINED
2911
2912 void *
2913 Perl_get_context(void)
2914 {
2915 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2916 #  ifdef OLD_PTHREADS_API
2917     pthread_addr_t t;
2918     if (pthread_getspecific(PL_thr_key, &t))
2919         Perl_croak_nocontext("panic: pthread_getspecific");
2920     return (void*)t;
2921 #  else
2922 #    ifdef I_MACH_CTHREADS
2923     return (void*)cthread_data(cthread_self());
2924 #    else
2925     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2926 #    endif
2927 #  endif
2928 #else
2929     return (void*)NULL;
2930 #endif
2931 }
2932
2933 void
2934 Perl_set_context(void *t)
2935 {
2936 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
2937 #  ifdef I_MACH_CTHREADS
2938     cthread_set_data(cthread_self(), t);
2939 #  else
2940     if (pthread_setspecific(PL_thr_key, t))
2941         Perl_croak_nocontext("panic: pthread_setspecific");
2942 #  endif
2943 #endif
2944 }
2945
2946 #endif /* !PERL_GET_CONTEXT_DEFINED */
2947
2948 #ifdef USE_5005THREADS
2949
2950 #ifdef FAKE_THREADS
2951 /* Very simplistic scheduler for now */
2952 void
2953 schedule(void)
2954 {
2955     thr = thr->i.next_run;
2956 }
2957
2958 void
2959 Perl_cond_init(pTHX_ perl_cond *cp)
2960 {
2961     *cp = 0;
2962 }
2963
2964 void
2965 Perl_cond_signal(pTHX_ perl_cond *cp)
2966 {
2967     perl_os_thread t;
2968     perl_cond cond = *cp;
2969
2970     if (!cond)
2971         return;
2972     t = cond->thread;
2973     /* Insert t in the runnable queue just ahead of us */
2974     t->i.next_run = thr->i.next_run;
2975     thr->i.next_run->i.prev_run = t;
2976     t->i.prev_run = thr;
2977     thr->i.next_run = t;
2978     thr->i.wait_queue = 0;
2979     /* Remove from the wait queue */
2980     *cp = cond->next;
2981     Safefree(cond);
2982 }
2983
2984 void
2985 Perl_cond_broadcast(pTHX_ perl_cond *cp)
2986 {
2987     perl_os_thread t;
2988     perl_cond cond, cond_next;
2989
2990     for (cond = *cp; cond; cond = cond_next) {
2991         t = cond->thread;
2992         /* Insert t in the runnable queue just ahead of us */
2993         t->i.next_run = thr->i.next_run;
2994         thr->i.next_run->i.prev_run = t;
2995         t->i.prev_run = thr;
2996         thr->i.next_run = t;
2997         thr->i.wait_queue = 0;
2998         /* Remove from the wait queue */
2999         cond_next = cond->next;
3000         Safefree(cond);
3001     }
3002     *cp = 0;
3003 }
3004
3005 void
3006 Perl_cond_wait(pTHX_ perl_cond *cp)
3007 {
3008     perl_cond cond;
3009
3010     if (thr->i.next_run == thr)
3011         Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
3012
3013     New(666, cond, 1, struct perl_wait_queue);
3014     cond->thread = thr;
3015     cond->next = *cp;
3016     *cp = cond;
3017     thr->i.wait_queue = cond;
3018     /* Remove ourselves from runnable queue */
3019     thr->i.next_run->i.prev_run = thr->i.prev_run;
3020     thr->i.prev_run->i.next_run = thr->i.next_run;
3021 }
3022 #endif /* FAKE_THREADS */
3023
3024 MAGIC *
3025 Perl_condpair_magic(pTHX_ SV *sv)
3026 {
3027     MAGIC *mg;
3028
3029     (void)SvUPGRADE(sv, SVt_PVMG);
3030     mg = mg_find(sv, PERL_MAGIC_mutex);
3031     if (!mg) {
3032         condpair_t *cp;
3033
3034         New(53, cp, 1, condpair_t);
3035         MUTEX_INIT(&cp->mutex);
3036         COND_INIT(&cp->owner_cond);
3037         COND_INIT(&cp->cond);
3038         cp->owner = 0;
3039         LOCK_CRED_MUTEX;                /* XXX need separate mutex? */
3040         mg = mg_find(sv, PERL_MAGIC_mutex);
3041         if (mg) {
3042             /* someone else beat us to initialising it */
3043             UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
3044             MUTEX_DESTROY(&cp->mutex);
3045             COND_DESTROY(&cp->owner_cond);
3046             COND_DESTROY(&cp->cond);
3047             Safefree(cp);
3048         }
3049         else {
3050             sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
3051             mg = SvMAGIC(sv);
3052             mg->mg_ptr = (char *)cp;
3053             mg->mg_len = sizeof(cp);
3054             UNLOCK_CRED_MUTEX;          /* XXX need separate mutex? */
3055             DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
3056                                            "%p: condpair_magic %p\n", thr, sv)));
3057         }
3058     }
3059     return mg;
3060 }
3061
3062 SV *
3063 Perl_sv_lock(pTHX_ SV *osv)
3064 {
3065     MAGIC *mg;
3066     SV *sv = osv;
3067
3068     LOCK_SV_LOCK_MUTEX;
3069     if (SvROK(sv)) {
3070         sv = SvRV(sv);
3071     }
3072
3073     mg = condpair_magic(sv);
3074     MUTEX_LOCK(MgMUTEXP(mg));
3075     if (MgOWNER(mg) == thr)
3076         MUTEX_UNLOCK(MgMUTEXP(mg));
3077     else {
3078         while (MgOWNER(mg))
3079             COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3080         MgOWNER(mg) = thr;
3081         DEBUG_S(PerlIO_printf(Perl_debug_log,
3082                               "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
3083                               PTR2UV(thr), PTR2UV(sv)));
3084         MUTEX_UNLOCK(MgMUTEXP(mg));
3085         SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3086     }
3087     UNLOCK_SV_LOCK_MUTEX;
3088     return sv;
3089 }
3090
3091 /*
3092  * Make a new perl thread structure using t as a prototype. Some of the
3093  * fields for the new thread are copied from the prototype thread, t,
3094  * so t should not be running in perl at the time this function is
3095  * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3096  * thread calling new_struct_thread) clearly satisfies this constraint.
3097  */
3098 struct perl_thread *
3099 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
3100 {
3101 #if !defined(PERL_IMPLICIT_CONTEXT)
3102     struct perl_thread *thr;
3103 #endif
3104     SV *sv;
3105     SV **svp;
3106     I32 i;
3107
3108     sv = newSVpvn("", 0);
3109     SvGROW(sv, sizeof(struct perl_thread) + 1);
3110     SvCUR_set(sv, sizeof(struct perl_thread));
3111     thr = (Thread) SvPVX(sv);
3112 #ifdef DEBUGGING
3113     memset(thr, 0xab, sizeof(struct perl_thread));
3114     PL_markstack = 0;
3115     PL_scopestack = 0;
3116     PL_savestack = 0;
3117     PL_retstack = 0;
3118     PL_dirty = 0;
3119     PL_localizing = 0;
3120     Zero(&PL_hv_fetch_ent_mh, 1, HE);
3121     PL_efloatbuf = (char*)NULL;
3122     PL_efloatsize = 0;
3123 #else
3124     Zero(thr, 1, struct perl_thread);
3125 #endif
3126
3127     thr->oursv = sv;
3128     init_stacks();
3129
3130     PL_curcop = &PL_compiling;
3131     thr->interp = t->interp;
3132     thr->cvcache = newHV();
3133     thr->threadsv = newAV();
3134     thr->specific = newAV();
3135     thr->errsv = newSVpvn("", 0);
3136     thr->flags = THRf_R_JOINABLE;
3137     thr->thr_done = 0;
3138     MUTEX_INIT(&thr->mutex);
3139
3140     JMPENV_BOOTSTRAP;
3141
3142     PL_in_eval = EVAL_NULL;     /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
3143     PL_restartop = 0;
3144
3145     PL_statname = NEWSV(66,0);
3146     PL_errors = newSVpvn("", 0);
3147     PL_maxscream = -1;
3148     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3149     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3150     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3151     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3152     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3153     PL_regindent = 0;
3154     PL_reginterp_cnt = 0;
3155     PL_lastscream = Nullsv;
3156     PL_screamfirst = 0;
3157     PL_screamnext = 0;
3158     PL_reg_start_tmp = 0;
3159     PL_reg_start_tmpl = 0;
3160     PL_reg_poscache = Nullch;
3161
3162     PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3163
3164     /* parent thread's data needs to be locked while we make copy */
3165     MUTEX_LOCK(&t->mutex);
3166
3167 #ifdef PERL_FLEXIBLE_EXCEPTIONS
3168     PL_protect = t->Tprotect;
3169 #endif
3170
3171     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
3172     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
3173     PL_curstash = t->Tcurstash;   /* always be set to main? */
3174
3175     PL_tainted = t->Ttainted;
3176     PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
3177     PL_rs = newSVsv(t->Trs);
3178     PL_last_in_gv = Nullgv;
3179     PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
3180     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3181     PL_chopset = t->Tchopset;
3182     PL_bodytarget = newSVsv(t->Tbodytarget);
3183     PL_toptarget = newSVsv(t->Ttoptarget);
3184     if (t->Tformtarget == t->Ttoptarget)
3185         PL_formtarget = PL_toptarget;
3186     else
3187         PL_formtarget = PL_bodytarget;
3188
3189     /* Initialise all per-thread SVs that the template thread used */
3190     svp = AvARRAY(t->threadsv);
3191     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
3192         if (*svp && *svp != &PL_sv_undef) {
3193             SV *sv = newSVsv(*svp);
3194             av_store(thr->threadsv, i, sv);
3195             sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
3196             DEBUG_S(PerlIO_printf(Perl_debug_log,
3197                 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3198                                   (IV)i, t, thr));
3199         }
3200     }
3201     thr->threadsvp = AvARRAY(thr->threadsv);
3202
3203     MUTEX_LOCK(&PL_threads_mutex);
3204     PL_nthreads++;
3205     thr->tid = ++PL_threadnum;
3206     thr->next = t->next;
3207     thr->prev = t;
3208     t->next = thr;
3209     thr->next->prev = thr;
3210     MUTEX_UNLOCK(&PL_threads_mutex);
3211
3212     /* done copying parent's state */
3213     MUTEX_UNLOCK(&t->mutex);
3214
3215 #ifdef HAVE_THREAD_INTERN
3216     Perl_init_thread_intern(thr);
3217 #endif /* HAVE_THREAD_INTERN */
3218     return thr;
3219 }
3220 #endif /* USE_5005THREADS */
3221
3222 #ifdef PERL_GLOBAL_STRUCT
3223 struct perl_vars *
3224 Perl_GetVars(pTHX)
3225 {
3226  return &PL_Vars;
3227 }
3228 #endif
3229
3230 char **
3231 Perl_get_op_names(pTHX)
3232 {
3233  return PL_op_name;
3234 }
3235
3236 char **
3237 Perl_get_op_descs(pTHX)
3238 {
3239  return PL_op_desc;
3240 }
3241
3242 char *
3243 Perl_get_no_modify(pTHX)
3244 {
3245  return (char*)PL_no_modify;
3246 }
3247
3248 U32 *
3249 Perl_get_opargs(pTHX)
3250 {
3251  return PL_opargs;
3252 }
3253
3254 PPADDR_t*
3255 Perl_get_ppaddr(pTHX)
3256 {
3257  return (PPADDR_t*)PL_ppaddr;
3258 }
3259
3260 #ifndef HAS_GETENV_LEN
3261 char *
3262 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3263 {
3264     char *env_trans = PerlEnv_getenv(env_elem);
3265     if (env_trans)
3266         *len = strlen(env_trans);
3267     return env_trans;
3268 }
3269 #endif
3270
3271
3272 MGVTBL*
3273 Perl_get_vtbl(pTHX_ int vtbl_id)
3274 {
3275     MGVTBL* result = Null(MGVTBL*);
3276
3277     switch(vtbl_id) {
3278     case want_vtbl_sv:
3279         result = &PL_vtbl_sv;
3280         break;
3281     case want_vtbl_env:
3282         result = &PL_vtbl_env;
3283         break;
3284     case want_vtbl_envelem:
3285         result = &PL_vtbl_envelem;
3286         break;
3287     case want_vtbl_sig:
3288         result = &PL_vtbl_sig;
3289         break;
3290     case want_vtbl_sigelem:
3291         result = &PL_vtbl_sigelem;
3292         break;
3293     case want_vtbl_pack:
3294         result = &PL_vtbl_pack;
3295         break;
3296     case want_vtbl_packelem:
3297         result = &PL_vtbl_packelem;
3298         break;
3299     case want_vtbl_dbline:
3300         result = &PL_vtbl_dbline;
3301         break;
3302     case want_vtbl_isa:
3303         result = &PL_vtbl_isa;
3304         break;
3305     case want_vtbl_isaelem:
3306         result = &PL_vtbl_isaelem;
3307         break;
3308     case want_vtbl_arylen:
3309         result = &PL_vtbl_arylen;
3310         break;
3311     case want_vtbl_glob:
3312         result = &PL_vtbl_glob;
3313         break;
3314     case want_vtbl_mglob:
3315         result = &PL_vtbl_mglob;
3316         break;
3317     case want_vtbl_nkeys:
3318         result = &PL_vtbl_nkeys;
3319         break;
3320     case want_vtbl_taint:
3321         result = &PL_vtbl_taint;
3322         break;
3323     case want_vtbl_substr:
3324         result = &PL_vtbl_substr;
3325         break;
3326     case want_vtbl_vec:
3327         result = &PL_vtbl_vec;
3328         break;
3329     case want_vtbl_pos:
3330         result = &PL_vtbl_pos;
3331         break;
3332     case want_vtbl_bm:
3333         result = &PL_vtbl_bm;
3334         break;
3335     case want_vtbl_fm:
3336         result = &PL_vtbl_fm;
3337         break;
3338     case want_vtbl_uvar:
3339         result = &PL_vtbl_uvar;
3340         break;
3341 #ifdef USE_5005THREADS
3342     case want_vtbl_mutex:
3343         result = &PL_vtbl_mutex;
3344         break;
3345 #endif
3346     case want_vtbl_defelem:
3347         result = &PL_vtbl_defelem;
3348         break;
3349     case want_vtbl_regexp:
3350         result = &PL_vtbl_regexp;
3351         break;
3352     case want_vtbl_regdata:
3353         result = &PL_vtbl_regdata;
3354         break;
3355     case want_vtbl_regdatum:
3356         result = &PL_vtbl_regdatum;
3357         break;
3358 #ifdef USE_LOCALE_COLLATE
3359     case want_vtbl_collxfrm:
3360         result = &PL_vtbl_collxfrm;
3361         break;
3362 #endif
3363     case want_vtbl_amagic:
3364         result = &PL_vtbl_amagic;
3365         break;
3366     case want_vtbl_amagicelem:
3367         result = &PL_vtbl_amagicelem;
3368         break;
3369     case want_vtbl_backref:
3370         result = &PL_vtbl_backref;
3371         break;
3372     }
3373     return result;
3374 }
3375
3376 I32
3377 Perl_my_fflush_all(pTHX)
3378 {
3379 #if defined(FFLUSH_NULL)
3380     return PerlIO_flush(NULL);
3381 #else
3382 # if defined(HAS__FWALK)
3383     /* undocumented, unprototyped, but very useful BSDism */
3384     extern void _fwalk(int (*)(FILE *));
3385     _fwalk(&fflush);
3386     return 0;
3387 # else
3388 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3389     long open_max = -1;
3390 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3391     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3392 #   else
3393 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3394     open_max = sysconf(_SC_OPEN_MAX);
3395 #     else
3396 #      ifdef FOPEN_MAX
3397     open_max = FOPEN_MAX;
3398 #      else
3399 #       ifdef OPEN_MAX
3400     open_max = OPEN_MAX;
3401 #       else
3402 #        ifdef _NFILE
3403     open_max = _NFILE;
3404 #        endif
3405 #       endif
3406 #      endif
3407 #     endif
3408 #    endif
3409     if (open_max > 0) {
3410       long i;
3411       for (i = 0; i < open_max; i++)
3412             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3413                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3414                 STDIO_STREAM_ARRAY[i]._flag)
3415                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3416       return 0;
3417     }
3418 #  endif
3419     SETERRNO(EBADF,RMS$_IFI);
3420     return EOF;
3421 # endif
3422 #endif
3423 }
3424
3425 void
3426 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3427 {
3428     char *vile;
3429     I32   warn_type;
3430     char *func =
3431         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3432         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3433         PL_op_desc[op];
3434     char *pars = OP_IS_FILETEST(op) ? "" : "()";
3435     char *type = OP_IS_SOCKET(op) ||
3436                  (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3437                      "socket" : "filehandle";
3438     char *name = NULL;
3439
3440     if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3441         vile = "closed";
3442         warn_type = WARN_CLOSED;
3443     }
3444     else {
3445         vile = "unopened";
3446         warn_type = WARN_UNOPENED;
3447     }
3448
3449     if (gv && isGV(gv)) {
3450         SV *sv = sv_newmortal();
3451         gv_efullname4(sv, gv, Nullch, FALSE);
3452         if (SvOK(sv))
3453             name = SvPVX(sv);
3454     }
3455
3456     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3457         if (name && *name)
3458             Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput",
3459                         name,
3460                         (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3461         else
3462             Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput",
3463                         (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3464     } else if (name && *name) {
3465         Perl_warner(aTHX_ packWARN(warn_type),
3466                     "%s%s on %s %s %s", func, pars, vile, type, name);
3467         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3468             Perl_warner(aTHX_ packWARN(warn_type),
3469                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3470                         func, pars, name);
3471     }
3472     else {
3473         Perl_warner(aTHX_ packWARN(warn_type),
3474                     "%s%s on %s %s", func, pars, vile, type);
3475         if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3476             Perl_warner(aTHX_ packWARN(warn_type),
3477                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3478                         func, pars);
3479     }
3480 }
3481
3482 #ifdef EBCDIC
3483 /* in ASCII order, not that it matters */
3484 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3485
3486 int
3487 Perl_ebcdic_control(pTHX_ int ch)
3488 {
3489         if (ch > 'a') {
3490                 char *ctlp;
3491
3492                if (islower(ch))
3493                       ch = toupper(ch);
3494
3495                if ((ctlp = strchr(controllablechars, ch)) == 0) {
3496                       Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3497                }
3498
3499                 if (ctlp == controllablechars)
3500                        return('\177'); /* DEL */
3501                 else
3502                        return((unsigned char)(ctlp - controllablechars - 1));
3503         } else { /* Want uncontrol */
3504                 if (ch == '\177' || ch == -1)
3505                         return('?');
3506                 else if (ch == '\157')
3507                         return('\177');
3508                 else if (ch == '\174')
3509                         return('\000');
3510                 else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3511                         return('\036');
3512                 else if (ch == '\155')
3513                         return('\037');
3514                 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3515                         return(controllablechars[ch+1]);
3516                 else
3517                         Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3518         }
3519 }
3520 #endif
3521
3522 /* To workaround core dumps from the uninitialised tm_zone we get the
3523  * system to give us a reasonable struct to copy.  This fix means that
3524  * strftime uses the tm_zone and tm_gmtoff values returned by
3525  * localtime(time()). That should give the desired result most of the
3526  * time. But probably not always!
3527  *
3528  * This does not address tzname aspects of NETaa14816.
3529  *
3530  */
3531
3532 #ifdef HAS_GNULIBC
3533 # ifndef STRUCT_TM_HASZONE
3534 #    define STRUCT_TM_HASZONE
3535 # endif
3536 #endif
3537
3538 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3539 # ifndef HAS_TM_TM_ZONE
3540 #    define HAS_TM_TM_ZONE
3541 # endif
3542 #endif
3543
3544 void
3545 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3546 {
3547 #ifdef HAS_TM_TM_ZONE
3548     Time_t now;
3549     (void)time(&now);
3550     Copy(localtime(&now), ptm, 1, struct tm);
3551 #endif
3552 }
3553
3554 /*
3555  * mini_mktime - normalise struct tm values without the localtime()
3556  * semantics (and overhead) of mktime().
3557  */
3558 void
3559 Perl_mini_mktime(pTHX_ struct tm *ptm)
3560 {
3561     int yearday;
3562     int secs;
3563     int month, mday, year, jday;
3564     int odd_cent, odd_year;
3565
3566 #define DAYS_PER_YEAR   365
3567 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3568 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3569 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3570 #define SECS_PER_HOUR   (60*60)
3571 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3572 /* parentheses deliberately absent on these two, otherwise they don't work */
3573 #define MONTH_TO_DAYS   153/5
3574 #define DAYS_TO_MONTH   5/153
3575 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3576 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3577 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3578 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3579
3580 /*
3581  * Year/day algorithm notes:
3582  *
3583  * With a suitable offset for numeric value of the month, one can find
3584  * an offset into the year by considering months to have 30.6 (153/5) days,
3585  * using integer arithmetic (i.e., with truncation).  To avoid too much
3586  * messing about with leap days, we consider January and February to be
3587  * the 13th and 14th month of the previous year.  After that transformation,
3588  * we need the month index we use to be high by 1 from 'normal human' usage,
3589  * so the month index values we use run from 4 through 15.
3590  *
3591  * Given that, and the rules for the Gregorian calendar (leap years are those
3592  * divisible by 4 unless also divisible by 100, when they must be divisible
3593  * by 400 instead), we can simply calculate the number of days since some
3594  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3595  * the days we derive from our month index, and adding in the day of the
3596  * month.  The value used here is not adjusted for the actual origin which
3597  * it normally would use (1 January A.D. 1), since we're not exposing it.
3598  * We're only building the value so we can turn around and get the
3599  * normalised values for the year, month, day-of-month, and day-of-year.
3600  *
3601  * For going backward, we need to bias the value we're using so that we find
3602  * the right year value.  (Basically, we don't want the contribution of
3603  * March 1st to the number to apply while deriving the year).  Having done
3604  * that, we 'count up' the contribution to the year number by accounting for
3605  * full quadracenturies (400-year periods) with their extra leap days, plus
3606  * the contribution from full centuries (to avoid counting in the lost leap
3607  * days), plus the contribution from full quad-years (to count in the normal
3608  * leap days), plus the leftover contribution from any non-leap years.
3609  * At this point, if we were working with an actual leap day, we'll have 0
3610  * days left over.  This is also true for March 1st, however.  So, we have
3611  * to special-case that result, and (earlier) keep track of the 'odd'
3612  * century and year contributions.  If we got 4 extra centuries in a qcent,
3613  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3614  * Otherwise, we add back in the earlier bias we removed (the 123 from
3615  * figuring in March 1st), find the month index (integer division by 30.6),
3616  * and the remainder is the day-of-month.  We then have to convert back to
3617  * 'real' months (including fixing January and February from being 14/15 in
3618  * the previous year to being in the proper year).  After that, to get
3619  * tm_yday, we work with the normalised year and get a new yearday value for
3620  * January 1st, which we subtract from the yearday value we had earlier,
3621  * representing the date we've re-built.  This is done from January 1
3622  * because tm_yday is 0-origin.
3623  *
3624  * Since POSIX time routines are only guaranteed to work for times since the
3625  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3626  * applies Gregorian calendar rules even to dates before the 16th century
3627  * doesn't bother me.  Besides, you'd need cultural context for a given
3628  * date to know whether it was Julian or Gregorian calendar, and that's
3629  * outside the scope for this routine.  Since we convert back based on the
3630  * same rules we used to build the yearday, you'll only get strange results
3631  * for input which needed normalising, or for the 'odd' century years which
3632  * were leap years in the Julian calander but not in the Gregorian one.
3633  * I can live with that.
3634  *
3635  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3636  * that's still outside the scope for POSIX time manipulation, so I don't
3637  * care.
3638  */
3639
3640     year = 1900 + ptm->tm_year;
3641     month = ptm->tm_mon;
3642     mday = ptm->tm_mday;
3643     /* allow given yday with no month & mday to dominate the result */
3644     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3645         month = 0;
3646         mday = 0;
3647         jday = 1 + ptm->tm_yday;
3648     }
3649     else {
3650         jday = 0;
3651     }
3652     if (month >= 2)
3653         month+=2;
3654     else
3655         month+=14, year--;
3656     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3657     yearday += month*MONTH_TO_DAYS + mday + jday;
3658     /*
3659      * Note that we don't know when leap-seconds were or will be,
3660      * so we have to trust the user if we get something which looks
3661      * like a sensible leap-second.  Wild values for seconds will
3662      * be rationalised, however.
3663      */
3664     if ((unsigned) ptm->tm_sec <= 60) {
3665         secs = 0;
3666     }
3667     else {
3668         secs = ptm->tm_sec;
3669         ptm->tm_sec = 0;
3670     }
3671     secs += 60 * ptm->tm_min;
3672     secs += SECS_PER_HOUR * ptm->tm_hour;
3673     if (secs < 0) {
3674         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3675             /* got negative remainder, but need positive time */
3676             /* back off an extra day to compensate */
3677             yearday += (secs/SECS_PER_DAY)-1;
3678             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3679         }
3680         else {
3681             yearday += (secs/SECS_PER_DAY);
3682             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3683         }
3684     }
3685     else if (secs >= SECS_PER_DAY) {
3686         yearday += (secs/SECS_PER_DAY);
3687         secs %= SECS_PER_DAY;
3688     }
3689     ptm->tm_hour = secs/SECS_PER_HOUR;
3690     secs %= SECS_PER_HOUR;
3691     ptm->tm_min = secs/60;
3692     secs %= 60;
3693     ptm->tm_sec += secs;
3694     /* done with time of day effects */
3695     /*
3696      * The algorithm for yearday has (so far) left it high by 428.
3697      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3698      * bias it by 123 while trying to figure out what year it
3699      * really represents.  Even with this tweak, the reverse
3700      * translation fails for years before A.D. 0001.
3701      * It would still fail for Feb 29, but we catch that one below.
3702      */
3703     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3704     yearday -= YEAR_ADJUST;
3705     year = (yearday / DAYS_PER_QCENT) * 400;
3706     yearday %= DAYS_PER_QCENT;
3707     odd_cent = yearday / DAYS_PER_CENT;
3708     year += odd_cent * 100;
3709     yearday %= DAYS_PER_CENT;
3710     year += (yearday / DAYS_PER_QYEAR) * 4;
3711     yearday %= DAYS_PER_QYEAR;
3712     odd_year = yearday / DAYS_PER_YEAR;
3713     year += odd_year;
3714     yearday %= DAYS_PER_YEAR;
3715     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3716         month = 1;
3717         yearday = 29;
3718     }
3719     else {
3720         yearday += YEAR_ADJUST; /* recover March 1st crock */
3721         month = yearday*DAYS_TO_MONTH;
3722         yearday -= month*MONTH_TO_DAYS;
3723         /* recover other leap-year adjustment */
3724         if (month > 13) {
3725             month-=14;
3726             year++;
3727         }
3728         else {
3729             month-=2;
3730         }
3731     }
3732     ptm->tm_year = year - 1900;
3733     if (yearday) {
3734       ptm->tm_mday = yearday;
3735       ptm->tm_mon = month;
3736     }
3737     else {
3738       ptm->tm_mday = 31;
3739       ptm->tm_mon = month - 1;
3740     }
3741     /* re-build yearday based on Jan 1 to get tm_yday */
3742     year--;
3743     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3744     yearday += 14*MONTH_TO_DAYS + 1;
3745     ptm->tm_yday = jday - yearday;
3746     /* fix tm_wday if not overridden by caller */
3747     if ((unsigned)ptm->tm_wday > 6)
3748         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3749 }
3750
3751 char *
3752 Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
3753 {
3754 #ifdef HAS_STRFTIME
3755   char *buf;
3756   int buflen;
3757   struct tm mytm;
3758   int len;
3759
3760   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3761   mytm.tm_sec = sec;
3762   mytm.tm_min = min;
3763   mytm.tm_hour = hour;
3764   mytm.tm_mday = mday;
3765   mytm.tm_mon = mon;
3766   mytm.tm_year = year;
3767   mytm.tm_wday = wday;
3768   mytm.tm_yday = yday;
3769   mytm.tm_isdst = isdst;
3770   mini_mktime(&mytm);
3771   buflen = 64;
3772   New(0, buf, buflen, char);
3773   len = strftime(buf, buflen, fmt, &mytm);
3774   /*
3775   ** The following is needed to handle to the situation where
3776   ** tmpbuf overflows.  Basically we want to allocate a buffer
3777   ** and try repeatedly.  The reason why it is so complicated
3778   ** is that getting a return value of 0 from strftime can indicate
3779   ** one of the following:
3780   ** 1. buffer overflowed,
3781   ** 2. illegal conversion specifier, or
3782   ** 3. the format string specifies nothing to be returned(not
3783   **      an error).  This could be because format is an empty string
3784   **    or it specifies %p that yields an empty string in some locale.
3785   ** If there is a better way to make it portable, go ahead by
3786   ** all means.
3787   */
3788   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3789     return buf;
3790   else {
3791     /* Possibly buf overflowed - try again with a bigger buf */
3792     int     fmtlen = strlen(fmt);
3793     int     bufsize = fmtlen + buflen;
3794
3795     New(0, buf, bufsize, char);
3796     while (buf) {
3797       buflen = strftime(buf, bufsize, fmt, &mytm);
3798       if (buflen > 0 && buflen < bufsize)
3799         break;
3800       /* heuristic to prevent out-of-memory errors */
3801       if (bufsize > 100*fmtlen) {
3802         Safefree(buf);
3803         buf = NULL;
3804         break;
3805       }
3806       bufsize *= 2;
3807       Renew(buf, bufsize, char);
3808     }
3809     return buf;
3810   }
3811 #else
3812   Perl_croak(aTHX_ "panic: no strftime");
3813 #endif
3814 }
3815
3816
3817 #define SV_CWD_RETURN_UNDEF \
3818 sv_setsv(sv, &PL_sv_undef); \
3819 return FALSE
3820
3821 #define SV_CWD_ISDOT(dp) \
3822     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3823         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3824
3825 /*
3826 =head1 Miscellaneous Functions
3827
3828 =for apidoc getcwd_sv
3829
3830 Fill the sv with current working directory
3831
3832 =cut
3833 */
3834
3835 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3836  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3837  * getcwd(3) if available
3838  * Comments from the orignal:
3839  *     This is a faster version of getcwd.  It's also more dangerous
3840  *     because you might chdir out of a directory that you can't chdir
3841  *     back into. */
3842
3843 int
3844 Perl_getcwd_sv(pTHX_ register SV *sv)
3845 {
3846 #ifndef PERL_MICRO
3847
3848 #ifndef INCOMPLETE_TAINTS
3849     SvTAINTED_on(sv);
3850 #endif
3851
3852 #ifdef HAS_GETCWD
3853     {
3854         char buf[MAXPATHLEN];
3855
3856         /* Some getcwd()s automatically allocate a buffer of the given
3857          * size from the heap if they are given a NULL buffer pointer.
3858          * The problem is that this behaviour is not portable. */
3859         if (getcwd(buf, sizeof(buf) - 1)) {
3860             STRLEN len = strlen(buf);
3861             sv_setpvn(sv, buf, len);
3862             return TRUE;
3863         }
3864         else {
3865             sv_setsv(sv, &PL_sv_undef);
3866             return FALSE;
3867         }
3868     }
3869
3870 #else
3871
3872     Stat_t statbuf;
3873     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3874     int namelen, pathlen=0;
3875     DIR *dir;
3876     Direntry_t *dp;
3877
3878     (void)SvUPGRADE(sv, SVt_PV);
3879
3880     if (PerlLIO_lstat(".", &statbuf) < 0) {
3881         SV_CWD_RETURN_UNDEF;
3882     }
3883
3884     orig_cdev = statbuf.st_dev;
3885     orig_cino = statbuf.st_ino;
3886     cdev = orig_cdev;
3887     cino = orig_cino;
3888
3889     for (;;) {
3890         odev = cdev;
3891         oino = cino;
3892
3893         if (PerlDir_chdir("..") < 0) {
3894             SV_CWD_RETURN_UNDEF;
3895         }
3896         if (PerlLIO_stat(".", &statbuf) < 0) {
3897             SV_CWD_RETURN_UNDEF;
3898         }
3899
3900         cdev = statbuf.st_dev;
3901         cino = statbuf.st_ino;
3902
3903         if (odev == cdev && oino == cino) {
3904             break;
3905         }
3906         if (!(dir = PerlDir_open("."))) {
3907             SV_CWD_RETURN_UNDEF;
3908         }
3909
3910         while ((dp = PerlDir_read(dir)) != NULL) {
3911 #ifdef DIRNAMLEN
3912             namelen = dp->d_namlen;
3913 #else
3914             namelen = strlen(dp->d_name);
3915 #endif
3916             /* skip . and .. */
3917             if (SV_CWD_ISDOT(dp)) {
3918                 continue;
3919             }
3920
3921             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3922                 SV_CWD_RETURN_UNDEF;
3923             }
3924
3925             tdev = statbuf.st_dev;
3926             tino = statbuf.st_ino;
3927             if (tino == oino && tdev == odev) {
3928                 break;
3929             }
3930         }
3931
3932         if (!dp) {
3933             SV_CWD_RETURN_UNDEF;
3934         }
3935
3936         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3937             SV_CWD_RETURN_UNDEF;
3938         }
3939
3940         SvGROW(sv, pathlen + namelen + 1);
3941
3942         if (pathlen) {
3943             /* shift down */
3944             Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3945         }
3946
3947         /* prepend current directory to the front */
3948         *SvPVX(sv) = '/';
3949         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3950         pathlen += (namelen + 1);
3951
3952 #ifdef VOID_CLOSEDIR
3953         PerlDir_close(dir);
3954 #else
3955         if (PerlDir_close(dir) < 0) {
3956             SV_CWD_RETURN_UNDEF;
3957         }
3958 #endif
3959     }
3960
3961     if (pathlen) {
3962         SvCUR_set(sv, pathlen);
3963         *SvEND(sv) = '\0';
3964         SvPOK_only(sv);
3965
3966         if (PerlDir_chdir(SvPVX(sv)) < 0) {
3967             SV_CWD_RETURN_UNDEF;
3968         }
3969     }
3970     if (PerlLIO_stat(".", &statbuf) < 0) {
3971         SV_CWD_RETURN_UNDEF;
3972     }
3973
3974     cdev = statbuf.st_dev;
3975     cino = statbuf.st_ino;
3976
3977     if (cdev != orig_cdev || cino != orig_cino) {
3978         Perl_croak(aTHX_ "Unstable directory path, "
3979                    "current directory changed unexpectedly");
3980     }
3981
3982     return TRUE;
3983 #endif
3984
3985 #else
3986     return FALSE;
3987 #endif
3988 }
3989
3990 /*
3991 =head1 SV Manipulation Functions
3992
3993 =for apidoc new_vstring
3994
3995 Returns a pointer to the next character after the parsed
3996 vstring, as well as updating the passed in sv.
3997
3998 Function must be called like
3999
4000         sv = NEWSV(92,5);
4001         s = new_vstring(s,sv);
4002
4003 The sv must already be large enough to store the vstring
4004 passed in.
4005
4006 =cut
4007 */
4008
4009 char *
4010 Perl_new_vstring(pTHX_ char *s, SV *sv)
4011 {
4012     char *pos = s;
4013     if (*pos == 'v') pos++;  /* get past 'v' */
4014     while (isDIGIT(*pos) || *pos == '_')
4015     pos++;
4016     if (!isALPHA(*pos)) {
4017         UV rev;
4018         U8 tmpbuf[UTF8_MAXLEN+1];
4019         U8 *tmpend;
4020
4021         if (*s == 'v') s++;  /* get past 'v' */
4022
4023         sv_setpvn(sv, "", 0);
4024
4025         for (;;) {
4026             rev = 0;
4027             {
4028                  /* this is atoi() that tolerates underscores */
4029                  char *end = pos;
4030                  UV mult = 1;
4031                  if ( s > pos && *(s-1) == '_') {
4032                       mult = 10;
4033                  }
4034                  while (--end >= s) {
4035                       UV orev;
4036                       orev = rev;
4037                       rev += (*end - '0') * mult;
4038                       mult *= 10;
4039                       if (orev > rev && ckWARN_d(WARN_OVERFLOW))
4040                            Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4041                                        "Integer overflow in decimal number");
4042                  }
4043             }
4044 #ifdef EBCDIC
4045             if (rev > 0x7FFFFFFF)
4046                  Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
4047 #endif
4048             /* Append native character for the rev point */
4049             tmpend = uvchr_to_utf8(tmpbuf, rev);
4050             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
4051             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
4052                  SvUTF8_on(sv);
4053             if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
4054                  s = ++pos;
4055             else {
4056                  s = pos;
4057                  break;
4058             }
4059             while (isDIGIT(*pos) )
4060                  pos++;
4061         }
4062         SvPOK_on(sv);
4063         SvREADONLY_on(sv);
4064     }
4065     return s;
4066 }
4067
4068 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4069 #   define EMULATE_SOCKETPAIR_UDP
4070 #endif
4071
4072 #ifdef EMULATE_SOCKETPAIR_UDP
4073 static int
4074 S_socketpair_udp (int fd[2]) {
4075     dTHX;
4076     /* Fake a datagram socketpair using UDP to localhost.  */
4077     int sockets[2] = {-1, -1};
4078     struct sockaddr_in addresses[2];
4079     int i;
4080     Sock_size_t size = sizeof (struct sockaddr_in);
4081     unsigned short port;
4082     int got;
4083
4084     memset (&addresses, 0, sizeof (addresses));
4085     i = 1;
4086     do {
4087         sockets[i] = PerlSock_socket (AF_INET, SOCK_DGRAM, PF_INET);
4088         if (sockets[i] == -1)
4089             goto tidy_up_and_fail;
4090
4091         addresses[i].sin_family = AF_INET;
4092         addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK);
4093         addresses[i].sin_port = 0;      /* kernel choses port.  */
4094         if (PerlSock_bind (sockets[i], (struct sockaddr *) &addresses[i],
4095                   sizeof (struct sockaddr_in))
4096             == -1)
4097             goto tidy_up_and_fail;
4098     } while (i--);
4099
4100     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4101        for each connect the other socket to it.  */
4102     i = 1;
4103     do {
4104         if (PerlSock_getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size)
4105             == -1)
4106             goto tidy_up_and_fail;
4107         if (size != sizeof (struct sockaddr_in))
4108             goto abort_tidy_up_and_fail;
4109         /* !1 is 0, !0 is 1 */
4110         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4111                     sizeof (struct sockaddr_in)) == -1)
4112             goto tidy_up_and_fail;
4113     } while (i--);
4114
4115     /* Now we have 2 sockets connected to each other. I don't trust some other
4116        process not to have already sent a packet to us (by random) so send
4117        a packet from each to the other.  */
4118     i = 1;
4119     do {
4120         /* I'm going to send my own port number.  As a short.
4121            (Who knows if someone somewhere has sin_port as a bitfield and needs
4122            this routine. (I'm assuming crays have socketpair)) */
4123         port = addresses[i].sin_port;
4124         got = PerlLIO_write (sockets[i], &port, sizeof(port));
4125         if (got != sizeof(port)) {
4126             if (got == -1)
4127                 goto tidy_up_and_fail;
4128             goto abort_tidy_up_and_fail;
4129         }
4130     } while (i--);
4131
4132     /* Packets sent. I don't trust them to have arrived though.
4133        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4134        connect to localhost will use a second kernel thread. In 2.6 the
4135        first thread running the connect() returns before the second completes,
4136        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4137        returns 0. Poor programs have tripped up. One poor program's authors'
4138        had a 50-1 reverse stock split. Not sure how connected these were.)
4139        So I don't trust someone not to have an unpredictable UDP stack.
4140     */
4141
4142     {
4143         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4144         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4145         fd_set rset;
4146
4147         FD_ZERO (&rset);
4148         FD_SET (sockets[0], &rset);
4149         FD_SET (sockets[1], &rset);
4150
4151         got = PerlSock_select (max + 1, &rset, NULL, NULL, &waitfor);
4152         if (got != 2 || !FD_ISSET (sockets[0], &rset)
4153             || !FD_ISSET (sockets[1], &rset)) {
4154              /* I hope this is portable and appropriate.  */
4155             if (got == -1)
4156                 goto tidy_up_and_fail;
4157             goto abort_tidy_up_and_fail;
4158         }
4159     }
4160
4161     /* And the paranoia department even now doesn't trust it to have arrive
4162        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4163     {
4164         struct sockaddr_in readfrom;
4165         unsigned short buffer[2];
4166
4167         i = 1;
4168         do {
4169 #ifdef MSG_DONTWAIT
4170             got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
4171                             MSG_DONTWAIT,
4172                             (struct sockaddr *) &readfrom, &size);
4173 #else
4174             got = PerlSock_recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
4175                             0,
4176                             (struct sockaddr *) &readfrom, &size);
4177 #endif
4178
4179             if (got == -1)
4180                     goto tidy_up_and_fail;
4181             if (got != sizeof(port)
4182                 || size != sizeof (struct sockaddr_in)
4183                 /* Check other socket sent us its port.  */
4184                 || buffer[0] != (unsigned short) addresses[!i].sin_port
4185                 /* Check kernel says we got the datagram from that socket.  */
4186                 || readfrom.sin_family != addresses[!i].sin_family
4187                 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4188                 || readfrom.sin_port != addresses[!i].sin_port)
4189                 goto abort_tidy_up_and_fail;
4190         } while (i--);
4191     }
4192     /* My caller (my_socketpair) has validated that this is non-NULL  */
4193     fd[0] = sockets[0];
4194     fd[1] = sockets[1];
4195     /* I hereby declare this connection open.  May God bless all who cross
4196        her.  */
4197     return 0;
4198
4199   abort_tidy_up_and_fail:
4200     errno = ECONNABORTED;
4201   tidy_up_and_fail:
4202     {
4203         int save_errno = errno;
4204         if (sockets[0] != -1)
4205             PerlLIO_close (sockets[0]);
4206         if (sockets[1] != -1)
4207             PerlLIO_close (sockets[1]);
4208         errno = save_errno;
4209         return -1;
4210     }
4211 }
4212 #endif /*  EMULATE_SOCKETPAIR_UDP */
4213
4214 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4215 int
4216 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4217     /* Stevens says that family must be AF_LOCAL, protocol 0.
4218        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4219     dTHX;
4220     int listener = -1;
4221     int connector = -1;
4222     int acceptor = -1;
4223     struct sockaddr_in listen_addr;
4224     struct sockaddr_in connect_addr;
4225     Sock_size_t size;
4226
4227     if (protocol
4228 #ifdef AF_UNIX
4229         || family != AF_UNIX
4230 #endif
4231         ) {
4232         errno = EAFNOSUPPORT;
4233         return -1;
4234     }
4235     if (!fd) {
4236         errno = EINVAL;
4237         return -1;
4238     }
4239
4240 #ifdef EMULATE_SOCKETPAIR_UDP
4241     if (type == SOCK_DGRAM)
4242         return S_socketpair_udp (fd);
4243 #endif
4244
4245     listener = PerlSock_socket (AF_INET, type, 0);
4246     if (listener == -1)
4247         return -1;
4248     memset (&listen_addr, 0, sizeof (listen_addr));
4249     listen_addr.sin_family = AF_INET;
4250     listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
4251     listen_addr.sin_port = 0;   /* kernel choses port.  */
4252     if (PerlSock_bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr))
4253         == -1)
4254         goto tidy_up_and_fail;
4255     if (PerlSock_listen(listener, 1) == -1)
4256         goto tidy_up_and_fail;
4257
4258     connector = PerlSock_socket (AF_INET, type, 0);
4259     if (connector == -1)
4260         goto tidy_up_and_fail;
4261     /* We want to find out the port number to connect to.  */
4262     size = sizeof (connect_addr);
4263     if (PerlSock_getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1)
4264         goto tidy_up_and_fail;
4265     if (size != sizeof (connect_addr))
4266         goto abort_tidy_up_and_fail;
4267     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4268                 sizeof (connect_addr)) == -1)
4269         goto tidy_up_and_fail;
4270
4271     size = sizeof (listen_addr);
4272     acceptor = PerlSock_accept (listener, (struct sockaddr *) &listen_addr, &size);
4273     if (acceptor == -1)
4274         goto tidy_up_and_fail;
4275     if (size != sizeof (listen_addr))
4276         goto abort_tidy_up_and_fail;
4277     PerlLIO_close (listener);
4278     /* Now check we are talking to ourself by matching port and host on the
4279        two sockets.  */
4280     if (PerlSock_getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1)
4281         goto tidy_up_and_fail;
4282     if (size != sizeof (connect_addr)
4283         || listen_addr.sin_family != connect_addr.sin_family
4284         || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4285         || listen_addr.sin_port != connect_addr.sin_port) {
4286         goto abort_tidy_up_and_fail;
4287     }
4288     fd[0] = connector;
4289     fd[1] = acceptor;
4290     return 0;
4291
4292   abort_tidy_up_and_fail:
4293   errno = ECONNABORTED; /* I hope this is portable and appropriate.  */
4294   tidy_up_and_fail:
4295     {
4296         int save_errno = errno;
4297         if (listener != -1)
4298             PerlLIO_close (listener);
4299         if (connector != -1)
4300             PerlLIO_close (connector);
4301         if (acceptor != -1)
4302             PerlLIO_close (acceptor);
4303         errno = save_errno;
4304         return -1;
4305     }
4306 }
4307 #else
4308 /* In any case have a stub so that there's code corresponding
4309  * to the my_socketpair in global.sym. */
4310 int
4311 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4312 #ifdef HAS_SOCKETPAIR
4313     return socketpair(family, type, protocol, fd);
4314 #else
4315     return -1;
4316 #endif
4317 }
4318 #endif
4319
4320 /*
4321
4322 =for apidoc sv_nosharing
4323
4324 Dummy routine which "shares" an SV when there is no sharing module present.
4325 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4326 some level of strict-ness.
4327
4328 =cut
4329 */
4330
4331 void
4332 Perl_sv_nosharing(pTHX_ SV *sv)
4333 {
4334 }
4335
4336 /*
4337 =for apidoc sv_nolocking
4338
4339 Dummy routine which "locks" an SV when there is no locking module present.
4340 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4341 some level of strict-ness.
4342
4343 =cut
4344 */
4345
4346 void
4347 Perl_sv_nolocking(pTHX_ SV *sv)
4348 {
4349 }
4350
4351
4352 /*
4353 =for apidoc sv_nounlocking
4354
4355 Dummy routine which "unlocks" an SV when there is no locking module present.
4356 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4357 some level of strict-ness.
4358
4359 =cut
4360 */
4361
4362 void
4363 Perl_sv_nounlocking(pTHX_ SV *sv)
4364 {
4365 }
4366