util.c

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