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