util.c

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