util.c

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