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