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