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