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