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