util.c

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