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