util.c

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