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