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 *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 *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     const register U8 *s;
 369     register U8 *table;
 370     register U32 i;
 371     STRLEN len;
 372     I32 rarest = 0;
 373     U32 frequency = 256;
 374
 375     if (flags & FBMcf_TAIL) {
 376         MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 377         sv_catpvn(sv, "\n", 1);         /* Taken into account in fbm_instr() */
 378         if (mg && mg->mg_len >= 0)
 379             mg->mg_len++;
 380     }
 381     s = (U8*)SvPV_force_mutable(sv, len);
 382     SvUPGRADE(sv, SVt_PVBM);
 383     if (len == 0)               /* TAIL might be on a zero-length string. */
 384         return;
 385     if (len > 2) {
 386         const unsigned char *sb;
 387         const U8 mlen = (len>255) ? 255 : (U8)len;
 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 *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 *table = little + littlelen + FBM_TABLE_OFFSET;
 573         const register 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     const register unsigned char *big;
 636     register I32 pos;
 637     register I32 previous;
 638     register I32 first;
 639     const register unsigned char *little;
 640     register I32 stop_pos;
 641     const register 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         const register 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         New(902,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     New(903,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 *pv = SvPV_const(sv, len);
 843     register char *newaddr;
 844
 845     ++len;
 846     New(903,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     New(905, sv, 1, SV);
 867     Newz(905, 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 *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 *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 *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 *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 = S_vdie_croak_common(aTHX_ 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             save_re_context();
1282             msg = newSVpvn(message, msglen);
1283             SvFLAGS(msg) |= utf8;
1284             SvREADONLY_on(msg);
1285             SAVEFREESV(msg);
1286
1287             PUSHSTACKi(PERLSI_WARNHOOK);
1288             PUSHMARK(SP);
1289             XPUSHs(msg);
1290             PUTBACK;
1291             call_sv((SV*)cv, G_DISCARD);
1292             POPSTACK;
1293             LEAVE;
1294             return;
1295         }
1296     }
1297
1298     write_to_stderr(message, msglen);
1299 }
1300
1301 #if defined(PERL_IMPLICIT_CONTEXT)
1302 void
1303 Perl_warn_nocontext(const char *pat, ...)
1304 {
1305     dTHX;
1306     va_list args;
1307     va_start(args, pat);
1308     vwarn(pat, &args);
1309     va_end(args);
1310 }
1311 #endif /* PERL_IMPLICIT_CONTEXT */
1312
1313 /*
1314 =for apidoc warn
1315
1316 This is the XSUB-writer's interface to Perl's C<warn> function.  Call this
1317 function the same way you call the C C<printf> function.  See C<croak>.
1318
1319 =cut
1320 */
1321
1322 void
1323 Perl_warn(pTHX_ const char *pat, ...)
1324 {
1325     va_list args;
1326     va_start(args, pat);
1327     vwarn(pat, &args);
1328     va_end(args);
1329 }
1330
1331 #if defined(PERL_IMPLICIT_CONTEXT)
1332 void
1333 Perl_warner_nocontext(U32 err, const char *pat, ...)
1334 {
1335     dTHX;
1336     va_list args;
1337     va_start(args, pat);
1338     vwarner(err, pat, &args);
1339     va_end(args);
1340 }
1341 #endif /* PERL_IMPLICIT_CONTEXT */
1342
1343 void
1344 Perl_warner(pTHX_ U32  err, const char* pat,...)
1345 {
1346     va_list args;
1347     va_start(args, pat);
1348     vwarner(err, pat, &args);
1349     va_end(args);
1350 }
1351
1352 void
1353 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1354 {
1355     dVAR;
1356     if (ckDEAD(err)) {
1357         SV * const msv = vmess(pat, args);
1358         STRLEN msglen;
1359         const char *message = SvPV_const(msv, msglen);
1360         const I32 utf8 = SvUTF8(msv);
1361
1362         if (PL_diehook) {
1363             assert(message);
1364             S_vdie_common(aTHX_ message, msglen, utf8);
1365         }
1366         if (PL_in_eval) {
1367             PL_restartop = die_where(message, msglen);
1368             SvFLAGS(ERRSV) |= utf8;
1369             JMPENV_JUMP(3);
1370         }
1371         write_to_stderr(message, msglen);
1372         my_failure_exit();
1373     }
1374     else {
1375         Perl_vwarn(aTHX_ pat, args);
1376     }
1377 }
1378
1379 /* since we've already done strlen() for both nam and val
1380  * we can use that info to make things faster than
1381  * sprintf(s, "%s=%s", nam, val)
1382  */
1383 #define my_setenv_format(s, nam, nlen, val, vlen) \
1384    Copy(nam, s, nlen, char); \
1385    *(s+nlen) = '='; \
1386    Copy(val, s+(nlen+1), vlen, char); \
1387    *(s+(nlen+1+vlen)) = '\0'
1388
1389 #ifdef USE_ENVIRON_ARRAY
1390        /* VMS' my_setenv() is in vms.c */
1391 #if !defined(WIN32) && !defined(NETWARE)
1392 void
1393 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1394 {
1395   dVAR;
1396 #ifdef USE_ITHREADS
1397   /* only parent thread can modify process environment */
1398   if (PL_curinterp == aTHX)
1399 #endif
1400   {
1401 #ifndef PERL_USE_SAFE_PUTENV
1402     if (!PL_use_safe_putenv) {
1403     /* most putenv()s leak, so we manipulate environ directly */
1404     register I32 i=setenv_getix(nam);           /* where does it go? */
1405     int nlen, vlen;
1406
1407     if (environ == PL_origenviron) {    /* need we copy environment? */
1408         I32 j;
1409         I32 max;
1410         char **tmpenv;
1411
1412         for (max = i; environ[max]; max++) ;
1413         tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1414         for (j=0; j<max; j++) {         /* copy environment */
1415             const int len = strlen(environ[j]);
1416             tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1417             Copy(environ[j], tmpenv[j], len+1, char);
1418         }
1419         tmpenv[max] = Nullch;
1420         environ = tmpenv;               /* tell exec where it is now */
1421     }
1422     if (!val) {
1423         safesysfree(environ[i]);
1424         while (environ[i]) {
1425             environ[i] = environ[i+1];
1426             i++;
1427         }
1428         return;
1429     }
1430     if (!environ[i]) {                  /* does not exist yet */
1431         environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1432         environ[i+1] = Nullch;  /* make sure it's null terminated */
1433     }
1434     else
1435         safesysfree(environ[i]);
1436     nlen = strlen(nam);
1437     vlen = strlen(val);
1438
1439     environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1440     /* all that work just for this */
1441     my_setenv_format(environ[i], nam, nlen, val, vlen);
1442     } else {
1443 # endif
1444 #   if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
1445     setenv(nam, val, 1);
1446 #   else
1447     char *new_env;
1448     const int nlen = strlen(nam);
1449     int vlen;
1450     if (!val) {
1451         val = "";
1452     }
1453     vlen = strlen(val);
1454     new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1455     /* all that work just for this */
1456     my_setenv_format(new_env, nam, nlen, val, vlen);
1457     (void)putenv(new_env);
1458 #   endif /* __CYGWIN__ */
1459 #ifndef PERL_USE_SAFE_PUTENV
1460     }
1461 #endif
1462   }
1463 }
1464
1465 #else /* WIN32 || NETWARE */
1466
1467 void
1468 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1469 {
1470     dVAR;
1471     register char *envstr;
1472     const int nlen = strlen(nam);
1473     int vlen;
1474
1475     if (!val) {
1476         val = "";
1477     }
1478     vlen = strlen(val);
1479     New(904, envstr, nlen+vlen+2, char);
1480     my_setenv_format(envstr, nam, nlen, val, vlen);
1481     (void)PerlEnv_putenv(envstr);
1482     Safefree(envstr);
1483 }
1484
1485 #endif /* WIN32 || NETWARE */
1486
1487 #ifndef PERL_MICRO
1488 I32
1489 Perl_setenv_getix(pTHX_ const char *nam)
1490 {
1491     register I32 i;
1492     const register I32 len = strlen(nam);
1493
1494     for (i = 0; environ[i]; i++) {
1495         if (
1496 #ifdef WIN32
1497             strnicmp(environ[i],nam,len) == 0
1498 #else
1499             strnEQ(environ[i],nam,len)
1500 #endif
1501             && environ[i][len] == '=')
1502             break;                      /* strnEQ must come first to avoid */
1503     }                                   /* potential SEGV's */
1504     return i;
1505 }
1506 #endif /* !PERL_MICRO */
1507
1508 #endif /* !VMS && !EPOC*/
1509
1510 #ifdef UNLINK_ALL_VERSIONS
1511 I32
1512 Perl_unlnk(pTHX_ char *f)       /* unlink all versions of a file */
1513 {
1514     I32 i;
1515
1516     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
1517     return i ? 0 : -1;
1518 }
1519 #endif
1520
1521 /* this is a drop-in replacement for bcopy() */
1522 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1523 char *
1524 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1525 {
1526     char *retval = to;
1527
1528     if (from - to >= 0) {
1529         while (len--)
1530             *to++ = *from++;
1531     }
1532     else {
1533         to += len;
1534         from += len;
1535         while (len--)
1536             *(--to) = *(--from);
1537     }
1538     return retval;
1539 }
1540 #endif
1541
1542 /* this is a drop-in replacement for memset() */
1543 #ifndef HAS_MEMSET
1544 void *
1545 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1546 {
1547     char *retval = loc;
1548
1549     while (len--)
1550         *loc++ = ch;
1551     return retval;
1552 }
1553 #endif
1554
1555 /* this is a drop-in replacement for bzero() */
1556 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1557 char *
1558 Perl_my_bzero(register char *loc, register I32 len)
1559 {
1560     char *retval = loc;
1561
1562     while (len--)
1563         *loc++ = 0;
1564     return retval;
1565 }
1566 #endif
1567
1568 /* this is a drop-in replacement for memcmp() */
1569 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1570 I32
1571 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1572 {
1573     register const U8 *a = (const U8 *)s1;
1574     register const U8 *b = (const U8 *)s2;
1575     register I32 tmp;
1576
1577     while (len--) {
1578         if ((tmp = *a++ - *b++))
1579             return tmp;
1580     }
1581     return 0;
1582 }
1583 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1584
1585 #ifndef HAS_VPRINTF
1586
1587 #ifdef USE_CHAR_VSPRINTF
1588 char *
1589 #else
1590 int
1591 #endif
1592 vsprintf(char *dest, const char *pat, char *args)
1593 {
1594     FILE fakebuf;
1595
1596     fakebuf._ptr = dest;
1597     fakebuf._cnt = 32767;
1598 #ifndef _IOSTRG
1599 #define _IOSTRG 0
1600 #endif
1601     fakebuf._flag = _IOWRT|_IOSTRG;
1602     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1603     (void)putc('\0', &fakebuf);
1604 #ifdef USE_CHAR_VSPRINTF
1605     return(dest);
1606 #else
1607     return 0;           /* perl doesn't use return value */
1608 #endif
1609 }
1610
1611 #endif /* HAS_VPRINTF */
1612
1613 #ifdef MYSWAP
1614 #if BYTEORDER != 0x4321
1615 short
1616 Perl_my_swap(pTHX_ short s)
1617 {
1618 #if (BYTEORDER & 1) == 0
1619     short result;
1620
1621     result = ((s & 255) << 8) + ((s >> 8) & 255);
1622     return result;
1623 #else
1624     return s;
1625 #endif
1626 }
1627
1628 long
1629 Perl_my_htonl(pTHX_ long l)
1630 {
1631     union {
1632         long result;
1633         char c[sizeof(long)];
1634     } u;
1635
1636 #if BYTEORDER == 0x1234
1637     u.c[0] = (l >> 24) & 255;
1638     u.c[1] = (l >> 16) & 255;
1639     u.c[2] = (l >> 8) & 255;
1640     u.c[3] = l & 255;
1641     return u.result;
1642 #else
1643 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1644     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1645 #else
1646     register I32 o;
1647     register I32 s;
1648
1649     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1650         u.c[o & 0xf] = (l >> s) & 255;
1651     }
1652     return u.result;
1653 #endif
1654 #endif
1655 }
1656
1657 long
1658 Perl_my_ntohl(pTHX_ long l)
1659 {
1660     union {
1661         long l;
1662         char c[sizeof(long)];
1663     } u;
1664
1665 #if BYTEORDER == 0x1234
1666     u.c[0] = (l >> 24) & 255;
1667     u.c[1] = (l >> 16) & 255;
1668     u.c[2] = (l >> 8) & 255;
1669     u.c[3] = l & 255;
1670     return u.l;
1671 #else
1672 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1673     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1674 #else
1675     register I32 o;
1676     register I32 s;
1677
1678     u.l = l;
1679     l = 0;
1680     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1681         l |= (u.c[o & 0xf] & 255) << s;
1682     }
1683     return l;
1684 #endif
1685 #endif
1686 }
1687
1688 #endif /* BYTEORDER != 0x4321 */
1689 #endif /* MYSWAP */
1690
1691 /*
1692  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1693  * If these functions are defined,
1694  * the BYTEORDER is neither 0x1234 nor 0x4321.
1695  * However, this is not assumed.
1696  * -DWS
1697  */
1698
1699 #define HTOLE(name,type)                                        \
1700         type                                                    \
1701         name (register type n)                                  \
1702         {                                                       \
1703             union {                                             \
1704                 type value;                                     \
1705                 char c[sizeof(type)];                           \
1706             } u;                                                \
1707             register I32 i;                                     \
1708             register I32 s = 0;                                 \
1709             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
1710                 u.c[i] = (n >> s) & 0xFF;                       \
1711             }                                                   \
1712             return u.value;                                     \
1713         }
1714
1715 #define LETOH(name,type)                                        \
1716         type                                                    \
1717         name (register type n)                                  \
1718         {                                                       \
1719             union {                                             \
1720                 type value;                                     \
1721                 char c[sizeof(type)];                           \
1722             } u;                                                \
1723             register I32 i;                                     \
1724             register I32 s = 0;                                 \
1725             u.value = n;                                        \
1726             n = 0;                                              \
1727             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
1728                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
1729             }                                                   \
1730             return n;                                           \
1731         }
1732
1733 /*
1734  * Big-endian byte order functions.
1735  */
1736
1737 #define HTOBE(name,type)                                        \
1738         type                                                    \
1739         name (register type n)                                  \
1740         {                                                       \
1741             union {                                             \
1742                 type value;                                     \
1743                 char c[sizeof(type)];                           \
1744             } u;                                                \
1745             register I32 i;                                     \
1746             register I32 s = 8*(sizeof(u.c)-1);                 \
1747             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
1748                 u.c[i] = (n >> s) & 0xFF;                       \
1749             }                                                   \
1750             return u.value;                                     \
1751         }
1752
1753 #define BETOH(name,type)                                        \
1754         type                                                    \
1755         name (register type n)                                  \
1756         {                                                       \
1757             union {                                             \
1758                 type value;                                     \
1759                 char c[sizeof(type)];                           \
1760             } u;                                                \
1761             register I32 i;                                     \
1762             register I32 s = 8*(sizeof(u.c)-1);                 \
1763             u.value = n;                                        \
1764             n = 0;                                              \
1765             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
1766                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
1767             }                                                   \
1768             return n;                                           \
1769         }
1770
1771 /*
1772  * If we just can't do it...
1773  */
1774
1775 #define NOT_AVAIL(name,type)                                    \
1776         type                                                    \
1777         name (register type n)                                  \
1778         {                                                       \
1779             Perl_croak_nocontext(#name "() not available");     \
1780             return n; /* not reached */                         \
1781         }
1782
1783
1784 #if defined(HAS_HTOVS) && !defined(htovs)
1785 HTOLE(htovs,short)
1786 #endif
1787 #if defined(HAS_HTOVL) && !defined(htovl)
1788 HTOLE(htovl,long)
1789 #endif
1790 #if defined(HAS_VTOHS) && !defined(vtohs)
1791 LETOH(vtohs,short)
1792 #endif
1793 #if defined(HAS_VTOHL) && !defined(vtohl)
1794 LETOH(vtohl,long)
1795 #endif
1796
1797 #ifdef PERL_NEED_MY_HTOLE16
1798 # if U16SIZE == 2
1799 HTOLE(Perl_my_htole16,U16)
1800 # else
1801 NOT_AVAIL(Perl_my_htole16,U16)
1802 # endif
1803 #endif
1804 #ifdef PERL_NEED_MY_LETOH16
1805 # if U16SIZE == 2
1806 LETOH(Perl_my_letoh16,U16)
1807 # else
1808 NOT_AVAIL(Perl_my_letoh16,U16)
1809 # endif
1810 #endif
1811 #ifdef PERL_NEED_MY_HTOBE16
1812 # if U16SIZE == 2
1813 HTOBE(Perl_my_htobe16,U16)
1814 # else
1815 NOT_AVAIL(Perl_my_htobe16,U16)
1816 # endif
1817 #endif
1818 #ifdef PERL_NEED_MY_BETOH16
1819 # if U16SIZE == 2
1820 BETOH(Perl_my_betoh16,U16)
1821 # else
1822 NOT_AVAIL(Perl_my_betoh16,U16)
1823 # endif
1824 #endif
1825
1826 #ifdef PERL_NEED_MY_HTOLE32
1827 # if U32SIZE == 4
1828 HTOLE(Perl_my_htole32,U32)
1829 # else
1830 NOT_AVAIL(Perl_my_htole32,U32)
1831 # endif
1832 #endif
1833 #ifdef PERL_NEED_MY_LETOH32
1834 # if U32SIZE == 4
1835 LETOH(Perl_my_letoh32,U32)
1836 # else
1837 NOT_AVAIL(Perl_my_letoh32,U32)
1838 # endif
1839 #endif
1840 #ifdef PERL_NEED_MY_HTOBE32
1841 # if U32SIZE == 4
1842 HTOBE(Perl_my_htobe32,U32)
1843 # else
1844 NOT_AVAIL(Perl_my_htobe32,U32)
1845 # endif
1846 #endif
1847 #ifdef PERL_NEED_MY_BETOH32
1848 # if U32SIZE == 4
1849 BETOH(Perl_my_betoh32,U32)
1850 # else
1851 NOT_AVAIL(Perl_my_betoh32,U32)
1852 # endif
1853 #endif
1854
1855 #ifdef PERL_NEED_MY_HTOLE64
1856 # if U64SIZE == 8
1857 HTOLE(Perl_my_htole64,U64)
1858 # else
1859 NOT_AVAIL(Perl_my_htole64,U64)
1860 # endif
1861 #endif
1862 #ifdef PERL_NEED_MY_LETOH64
1863 # if U64SIZE == 8
1864 LETOH(Perl_my_letoh64,U64)
1865 # else
1866 NOT_AVAIL(Perl_my_letoh64,U64)
1867 # endif
1868 #endif
1869 #ifdef PERL_NEED_MY_HTOBE64
1870 # if U64SIZE == 8
1871 HTOBE(Perl_my_htobe64,U64)
1872 # else
1873 NOT_AVAIL(Perl_my_htobe64,U64)
1874 # endif
1875 #endif
1876 #ifdef PERL_NEED_MY_BETOH64
1877 # if U64SIZE == 8
1878 BETOH(Perl_my_betoh64,U64)
1879 # else
1880 NOT_AVAIL(Perl_my_betoh64,U64)
1881 # endif
1882 #endif
1883
1884 #ifdef PERL_NEED_MY_HTOLES
1885 HTOLE(Perl_my_htoles,short)
1886 #endif
1887 #ifdef PERL_NEED_MY_LETOHS
1888 LETOH(Perl_my_letohs,short)
1889 #endif
1890 #ifdef PERL_NEED_MY_HTOBES
1891 HTOBE(Perl_my_htobes,short)
1892 #endif
1893 #ifdef PERL_NEED_MY_BETOHS
1894 BETOH(Perl_my_betohs,short)
1895 #endif
1896
1897 #ifdef PERL_NEED_MY_HTOLEI
1898 HTOLE(Perl_my_htolei,int)
1899 #endif
1900 #ifdef PERL_NEED_MY_LETOHI
1901 LETOH(Perl_my_letohi,int)
1902 #endif
1903 #ifdef PERL_NEED_MY_HTOBEI
1904 HTOBE(Perl_my_htobei,int)
1905 #endif
1906 #ifdef PERL_NEED_MY_BETOHI
1907 BETOH(Perl_my_betohi,int)
1908 #endif
1909
1910 #ifdef PERL_NEED_MY_HTOLEL
1911 HTOLE(Perl_my_htolel,long)
1912 #endif
1913 #ifdef PERL_NEED_MY_LETOHL
1914 LETOH(Perl_my_letohl,long)
1915 #endif
1916 #ifdef PERL_NEED_MY_HTOBEL
1917 HTOBE(Perl_my_htobel,long)
1918 #endif
1919 #ifdef PERL_NEED_MY_BETOHL
1920 BETOH(Perl_my_betohl,long)
1921 #endif
1922
1923 void
1924 Perl_my_swabn(void *ptr, int n)
1925 {
1926     register char *s = (char *)ptr;
1927     register char *e = s + (n-1);
1928     register char tc;
1929
1930     for (n /= 2; n > 0; s++, e--, n--) {
1931       tc = *s;
1932       *s = *e;
1933       *e = tc;
1934     }
1935 }
1936
1937 PerlIO *
1938 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1939 {
1940 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1941     int p[2];
1942     register I32 This, that;
1943     register Pid_t pid;
1944     SV *sv;
1945     I32 did_pipes = 0;
1946     int pp[2];
1947
1948     PERL_FLUSHALL_FOR_CHILD;
1949     This = (*mode == 'w');
1950     that = !This;
1951     if (PL_tainting) {
1952         taint_env();
1953         taint_proper("Insecure %s%s", "EXEC");
1954     }
1955     if (PerlProc_pipe(p) < 0)
1956         return Nullfp;
1957     /* Try for another pipe pair for error return */
1958     if (PerlProc_pipe(pp) >= 0)
1959         did_pipes = 1;
1960     while ((pid = PerlProc_fork()) < 0) {
1961         if (errno != EAGAIN) {
1962             PerlLIO_close(p[This]);
1963             PerlLIO_close(p[that]);
1964             if (did_pipes) {
1965                 PerlLIO_close(pp[0]);
1966                 PerlLIO_close(pp[1]);
1967             }
1968             return Nullfp;
1969         }
1970         sleep(5);
1971     }
1972     if (pid == 0) {
1973         /* Child */
1974 #undef THIS
1975 #undef THAT
1976 #define THIS that
1977 #define THAT This
1978         /* Close parent's end of error status pipe (if any) */
1979         if (did_pipes) {
1980             PerlLIO_close(pp[0]);
1981 #if defined(HAS_FCNTL) && defined(F_SETFD)
1982             /* Close error pipe automatically if exec works */
1983             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1984 #endif
1985         }
1986         /* Now dup our end of _the_ pipe to right position */
1987         if (p[THIS] != (*mode == 'r')) {
1988             PerlLIO_dup2(p[THIS], *mode == 'r');
1989             PerlLIO_close(p[THIS]);
1990             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
1991                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1992         }
1993         else
1994             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
1995 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
1996         /* No automatic close - do it by hand */
1997 #  ifndef NOFILE
1998 #  define NOFILE 20
1999 #  endif
2000         {
2001             int fd;
2002
2003             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2004                 if (fd != pp[1])
2005                     PerlLIO_close(fd);
2006             }
2007         }
2008 #endif
2009         do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2010         PerlProc__exit(1);
2011 #undef THIS
2012 #undef THAT
2013     }
2014     /* Parent */
2015     do_execfree();      /* free any memory malloced by child on fork */
2016     if (did_pipes)
2017         PerlLIO_close(pp[1]);
2018     /* Keep the lower of the two fd numbers */
2019     if (p[that] < p[This]) {
2020         PerlLIO_dup2(p[This], p[that]);
2021         PerlLIO_close(p[This]);
2022         p[This] = p[that];
2023     }
2024     else
2025         PerlLIO_close(p[that]);         /* close child's end of pipe */
2026
2027     LOCK_FDPID_MUTEX;
2028     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2029     UNLOCK_FDPID_MUTEX;
2030     SvUPGRADE(sv,SVt_IV);
2031     SvIV_set(sv, pid);
2032     PL_forkprocess = pid;
2033     /* If we managed to get status pipe check for exec fail */
2034     if (did_pipes && pid > 0) {
2035         int errkid;
2036         int n = 0, n1;
2037
2038         while (n < sizeof(int)) {
2039             n1 = PerlLIO_read(pp[0],
2040                               (void*)(((char*)&errkid)+n),
2041                               (sizeof(int)) - n);
2042             if (n1 <= 0)
2043                 break;
2044             n += n1;
2045         }
2046         PerlLIO_close(pp[0]);
2047         did_pipes = 0;
2048         if (n) {                        /* Error */
2049             int pid2, status;
2050             PerlLIO_close(p[This]);
2051             if (n != sizeof(int))
2052                 Perl_croak(aTHX_ "panic: kid popen errno read");
2053             do {
2054                 pid2 = wait4pid(pid, &status, 0);
2055             } while (pid2 == -1 && errno == EINTR);
2056             errno = errkid;             /* Propagate errno from kid */
2057             return Nullfp;
2058         }
2059     }
2060     if (did_pipes)
2061          PerlLIO_close(pp[0]);
2062     return PerlIO_fdopen(p[This], mode);
2063 #else
2064     Perl_croak(aTHX_ "List form of piped open not implemented");
2065     return (PerlIO *) NULL;
2066 #endif
2067 }
2068
2069     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2070 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2071 PerlIO *
2072 Perl_my_popen(pTHX_ char *cmd, char *mode)
2073 {
2074     int p[2];
2075     register I32 This, that;
2076     register Pid_t pid;
2077     SV *sv;
2078     I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2079     I32 did_pipes = 0;
2080     int pp[2];
2081
2082     PERL_FLUSHALL_FOR_CHILD;
2083 #ifdef OS2
2084     if (doexec) {
2085         return my_syspopen(aTHX_ cmd,mode);
2086     }
2087 #endif
2088     This = (*mode == 'w');
2089     that = !This;
2090     if (doexec && PL_tainting) {
2091         taint_env();
2092         taint_proper("Insecure %s%s", "EXEC");
2093     }
2094     if (PerlProc_pipe(p) < 0)
2095         return Nullfp;
2096     if (doexec && PerlProc_pipe(pp) >= 0)
2097         did_pipes = 1;
2098     while ((pid = PerlProc_fork()) < 0) {
2099         if (errno != EAGAIN) {
2100             PerlLIO_close(p[This]);
2101             PerlLIO_close(p[that]);
2102             if (did_pipes) {
2103                 PerlLIO_close(pp[0]);
2104                 PerlLIO_close(pp[1]);
2105             }
2106             if (!doexec)
2107                 Perl_croak(aTHX_ "Can't fork");
2108             return Nullfp;
2109         }
2110         sleep(5);
2111     }
2112     if (pid == 0) {
2113         GV* tmpgv;
2114
2115 #undef THIS
2116 #undef THAT
2117 #define THIS that
2118 #define THAT This
2119         if (did_pipes) {
2120             PerlLIO_close(pp[0]);
2121 #if defined(HAS_FCNTL) && defined(F_SETFD)
2122             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2123 #endif
2124         }
2125         if (p[THIS] != (*mode == 'r')) {
2126             PerlLIO_dup2(p[THIS], *mode == 'r');
2127             PerlLIO_close(p[THIS]);
2128             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2129                 PerlLIO_close(p[THAT]);
2130         }
2131         else
2132             PerlLIO_close(p[THAT]);
2133 #ifndef OS2
2134         if (doexec) {
2135 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2136 #ifndef NOFILE
2137 #define NOFILE 20
2138 #endif
2139             {
2140                 int fd;
2141
2142                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2143                     if (fd != pp[1])
2144                         PerlLIO_close(fd);
2145             }
2146 #endif
2147             /* may or may not use the shell */
2148             do_exec3(cmd, pp[1], did_pipes);
2149             PerlProc__exit(1);
2150         }
2151 #endif  /* defined OS2 */
2152         if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
2153             SvREADONLY_off(GvSV(tmpgv));
2154             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2155             SvREADONLY_on(GvSV(tmpgv));
2156         }
2157 #ifdef THREADS_HAVE_PIDS
2158         PL_ppid = (IV)getppid();
2159 #endif
2160         PL_forkprocess = 0;
2161         hv_clear(PL_pidstatus); /* we have no children */
2162         return Nullfp;
2163 #undef THIS
2164 #undef THAT
2165     }
2166     do_execfree();      /* free any memory malloced by child on vfork */
2167     if (did_pipes)
2168         PerlLIO_close(pp[1]);
2169     if (p[that] < p[This]) {
2170         PerlLIO_dup2(p[This], p[that]);
2171         PerlLIO_close(p[This]);
2172         p[This] = p[that];
2173     }
2174     else
2175         PerlLIO_close(p[that]);
2176
2177     LOCK_FDPID_MUTEX;
2178     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2179     UNLOCK_FDPID_MUTEX;
2180     SvUPGRADE(sv,SVt_IV);
2181     SvIV_set(sv, pid);
2182     PL_forkprocess = pid;
2183     if (did_pipes && pid > 0) {
2184         int errkid;
2185         int n = 0, n1;
2186
2187         while (n < sizeof(int)) {
2188             n1 = PerlLIO_read(pp[0],
2189                               (void*)(((char*)&errkid)+n),
2190                               (sizeof(int)) - n);
2191             if (n1 <= 0)
2192                 break;
2193             n += n1;
2194         }
2195         PerlLIO_close(pp[0]);
2196         did_pipes = 0;
2197         if (n) {                        /* Error */
2198             int pid2, status;
2199             PerlLIO_close(p[This]);
2200             if (n != sizeof(int))
2201                 Perl_croak(aTHX_ "panic: kid popen errno read");
2202             do {
2203                 pid2 = wait4pid(pid, &status, 0);
2204             } while (pid2 == -1 && errno == EINTR);
2205             errno = errkid;             /* Propagate errno from kid */
2206             return Nullfp;
2207         }
2208     }
2209     if (did_pipes)
2210          PerlLIO_close(pp[0]);
2211     return PerlIO_fdopen(p[This], mode);
2212 }
2213 #else
2214 #if defined(atarist) || defined(EPOC)
2215 FILE *popen();
2216 PerlIO *
2217 Perl_my_popen(pTHX_ char *cmd, char *mode)
2218 {
2219     PERL_FLUSHALL_FOR_CHILD;
2220     /* Call system's popen() to get a FILE *, then import it.
2221        used 0 for 2nd parameter to PerlIO_importFILE;
2222        apparently not used
2223     */
2224     return PerlIO_importFILE(popen(cmd, mode), 0);
2225 }
2226 #else
2227 #if defined(DJGPP)
2228 FILE *djgpp_popen();
2229 PerlIO *
2230 Perl_my_popen(pTHX_ char *cmd, char *mode)
2231 {
2232     PERL_FLUSHALL_FOR_CHILD;
2233     /* Call system's popen() to get a FILE *, then import it.
2234        used 0 for 2nd parameter to PerlIO_importFILE;
2235        apparently not used
2236     */
2237     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2238 }
2239 #endif
2240 #endif
2241
2242 #endif /* !DOSISH */
2243
2244 /* this is called in parent before the fork() */
2245 void
2246 Perl_atfork_lock(void)
2247 {
2248    dVAR;
2249 #if defined(USE_ITHREADS)
2250     /* locks must be held in locking order (if any) */
2251 #  ifdef MYMALLOC
2252     MUTEX_LOCK(&PL_malloc_mutex);
2253 #  endif
2254     OP_REFCNT_LOCK;
2255 #endif
2256 }
2257
2258 /* this is called in both parent and child after the fork() */
2259 void
2260 Perl_atfork_unlock(void)
2261 {
2262     dVAR;
2263 #if defined(USE_ITHREADS)
2264     /* locks must be released in same order as in atfork_lock() */
2265 #  ifdef MYMALLOC
2266     MUTEX_UNLOCK(&PL_malloc_mutex);
2267 #  endif
2268     OP_REFCNT_UNLOCK;
2269 #endif
2270 }
2271
2272 Pid_t
2273 Perl_my_fork(void)
2274 {
2275 #if defined(HAS_FORK)
2276     Pid_t pid;
2277 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2278     atfork_lock();
2279     pid = fork();
2280     atfork_unlock();
2281 #else
2282     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2283      * handlers elsewhere in the code */
2284     pid = fork();
2285 #endif
2286     return pid;
2287 #else
2288     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2289     Perl_croak_nocontext("fork() not available");
2290     return 0;
2291 #endif /* HAS_FORK */
2292 }
2293
2294 #ifdef DUMP_FDS
2295 void
2296 Perl_dump_fds(pTHX_ char *s)
2297 {
2298     int fd;
2299     Stat_t tmpstatbuf;
2300
2301     PerlIO_printf(Perl_debug_log,"%s", s);
2302     for (fd = 0; fd < 32; fd++) {
2303         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2304             PerlIO_printf(Perl_debug_log," %d",fd);
2305     }
2306     PerlIO_printf(Perl_debug_log,"\n");
2307     return;
2308 }
2309 #endif  /* DUMP_FDS */
2310
2311 #ifndef HAS_DUP2
2312 int
2313 dup2(int oldfd, int newfd)
2314 {
2315 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2316     if (oldfd == newfd)
2317         return oldfd;
2318     PerlLIO_close(newfd);
2319     return fcntl(oldfd, F_DUPFD, newfd);
2320 #else
2321 #define DUP2_MAX_FDS 256
2322     int fdtmp[DUP2_MAX_FDS];
2323     I32 fdx = 0;
2324     int fd;
2325
2326     if (oldfd == newfd)
2327         return oldfd;
2328     PerlLIO_close(newfd);
2329     /* good enough for low fd's... */
2330     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2331         if (fdx >= DUP2_MAX_FDS) {
2332             PerlLIO_close(fd);
2333             fd = -1;
2334             break;
2335         }
2336         fdtmp[fdx++] = fd;
2337     }
2338     while (fdx > 0)
2339         PerlLIO_close(fdtmp[--fdx]);
2340     return fd;
2341 #endif
2342 }
2343 #endif
2344
2345 #ifndef PERL_MICRO
2346 #ifdef HAS_SIGACTION
2347
2348 #ifdef MACOS_TRADITIONAL
2349 /* We don't want restart behavior on MacOS */
2350 #undef SA_RESTART
2351 #endif
2352
2353 Sighandler_t
2354 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2355 {
2356     dVAR;
2357     struct sigaction act, oact;
2358
2359 #ifdef USE_ITHREADS
2360     /* only "parent" interpreter can diddle signals */
2361     if (PL_curinterp != aTHX)
2362         return SIG_ERR;
2363 #endif
2364
2365     act.sa_handler = handler;
2366     sigemptyset(&act.sa_mask);
2367     act.sa_flags = 0;
2368 #ifdef SA_RESTART
2369     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2370         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2371 #endif
2372 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2373     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2374         act.sa_flags |= SA_NOCLDWAIT;
2375 #endif
2376     if (sigaction(signo, &act, &oact) == -1)
2377         return SIG_ERR;
2378     else
2379         return oact.sa_handler;
2380 }
2381
2382 Sighandler_t
2383 Perl_rsignal_state(pTHX_ int signo)
2384 {
2385     struct sigaction oact;
2386
2387     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2388         return SIG_ERR;
2389     else
2390         return oact.sa_handler;
2391 }
2392
2393 int
2394 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2395 {
2396     dVAR;
2397     struct sigaction act;
2398
2399 #ifdef USE_ITHREADS
2400     /* only "parent" interpreter can diddle signals */
2401     if (PL_curinterp != aTHX)
2402         return -1;
2403 #endif
2404
2405     act.sa_handler = handler;
2406     sigemptyset(&act.sa_mask);
2407     act.sa_flags = 0;
2408 #ifdef SA_RESTART
2409     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2410         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2411 #endif
2412 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2413     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2414         act.sa_flags |= SA_NOCLDWAIT;
2415 #endif
2416     return sigaction(signo, &act, save);
2417 }
2418
2419 int
2420 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2421 {
2422     dVAR;
2423 #ifdef USE_ITHREADS
2424     /* only "parent" interpreter can diddle signals */
2425     if (PL_curinterp != aTHX)
2426         return -1;
2427 #endif
2428
2429     return sigaction(signo, save, (struct sigaction *)NULL);
2430 }
2431
2432 #else /* !HAS_SIGACTION */
2433
2434 Sighandler_t
2435 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2436 {
2437 #if defined(USE_ITHREADS) && !defined(WIN32)
2438     /* only "parent" interpreter can diddle signals */
2439     if (PL_curinterp != aTHX)
2440         return SIG_ERR;
2441 #endif
2442
2443     return PerlProc_signal(signo, handler);
2444 }
2445
2446 static
2447 Signal_t
2448 sig_trap(int signo)
2449 {
2450     dVAR;
2451     PL_sig_trapped++;
2452 }
2453
2454 Sighandler_t
2455 Perl_rsignal_state(pTHX_ int signo)
2456 {
2457     dVAR;
2458     Sighandler_t oldsig;
2459
2460 #if defined(USE_ITHREADS) && !defined(WIN32)
2461     /* only "parent" interpreter can diddle signals */
2462     if (PL_curinterp != aTHX)
2463         return SIG_ERR;
2464 #endif
2465
2466     PL_sig_trapped = 0;
2467     oldsig = PerlProc_signal(signo, sig_trap);
2468     PerlProc_signal(signo, oldsig);
2469     if (PL_sig_trapped)
2470         PerlProc_kill(PerlProc_getpid(), signo);
2471     return oldsig;
2472 }
2473
2474 int
2475 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2476 {
2477 #if defined(USE_ITHREADS) && !defined(WIN32)
2478     /* only "parent" interpreter can diddle signals */
2479     if (PL_curinterp != aTHX)
2480         return -1;
2481 #endif
2482     *save = PerlProc_signal(signo, handler);
2483     return (*save == SIG_ERR) ? -1 : 0;
2484 }
2485
2486 int
2487 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2488 {
2489 #if defined(USE_ITHREADS) && !defined(WIN32)
2490     /* only "parent" interpreter can diddle signals */
2491     if (PL_curinterp != aTHX)
2492         return -1;
2493 #endif
2494     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
2495 }
2496
2497 #endif /* !HAS_SIGACTION */
2498 #endif /* !PERL_MICRO */
2499
2500     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2501 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
2502 I32
2503 Perl_my_pclose(pTHX_ PerlIO *ptr)
2504 {
2505     Sigsave_t hstat, istat, qstat;
2506     int status;
2507     SV **svp;
2508     Pid_t pid;
2509     Pid_t pid2;
2510     bool close_failed;
2511     int saved_errno = 0;
2512 #ifdef WIN32
2513     int saved_win32_errno;
2514 #endif
2515
2516     LOCK_FDPID_MUTEX;
2517     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2518     UNLOCK_FDPID_MUTEX;
2519     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2520     SvREFCNT_dec(*svp);
2521     *svp = &PL_sv_undef;
2522 #ifdef OS2
2523     if (pid == -1) {                    /* Opened by popen. */
2524         return my_syspclose(ptr);
2525     }
2526 #endif
2527     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2528         saved_errno = errno;
2529 #ifdef WIN32
2530         saved_win32_errno = GetLastError();
2531 #endif
2532     }
2533 #ifdef UTS
2534     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2535 #endif
2536 #ifndef PERL_MICRO
2537     rsignal_save(SIGHUP, SIG_IGN, &hstat);
2538     rsignal_save(SIGINT, SIG_IGN, &istat);
2539     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
2540 #endif
2541     do {
2542         pid2 = wait4pid(pid, &status, 0);
2543     } while (pid2 == -1 && errno == EINTR);
2544 #ifndef PERL_MICRO
2545     rsignal_restore(SIGHUP, &hstat);
2546     rsignal_restore(SIGINT, &istat);
2547     rsignal_restore(SIGQUIT, &qstat);
2548 #endif
2549     if (close_failed) {
2550         SETERRNO(saved_errno, 0);
2551         return -1;
2552     }
2553     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2554 }
2555 #endif /* !DOSISH */
2556
2557 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
2558 I32
2559 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2560 {
2561     I32 result = 0;
2562     if (!pid)
2563         return -1;
2564 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2565     {
2566         char spid[TYPE_CHARS(IV)];
2567
2568         if (pid > 0) {
2569             SV** svp;
2570             sprintf(spid, "%"IVdf, (IV)pid);
2571             svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2572             if (svp && *svp != &PL_sv_undef) {
2573                 *statusp = SvIVX(*svp);
2574                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2575                 return pid;
2576             }
2577         }
2578         else {
2579             HE *entry;
2580
2581             hv_iterinit(PL_pidstatus);
2582             if ((entry = hv_iternext(PL_pidstatus))) {
2583                 SV *sv = hv_iterval(PL_pidstatus,entry);
2584
2585                 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2586                 *statusp = SvIVX(sv);
2587                 sprintf(spid, "%"IVdf, (IV)pid);
2588                 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2589                 return pid;
2590             }
2591         }
2592     }
2593 #endif
2594 #ifdef HAS_WAITPID
2595 #  ifdef HAS_WAITPID_RUNTIME
2596     if (!HAS_WAITPID_RUNTIME)
2597         goto hard_way;
2598 #  endif
2599     result = PerlProc_waitpid(pid,statusp,flags);
2600     goto finish;
2601 #endif
2602 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2603     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
2604     goto finish;
2605 #endif
2606 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2607 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2608   hard_way:
2609 #endif
2610     {
2611         if (flags)
2612             Perl_croak(aTHX_ "Can't do waitpid with flags");
2613         else {
2614             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2615                 pidgone(result,*statusp);
2616             if (result < 0)
2617                 *statusp = -1;
2618         }
2619     }
2620 #endif
2621 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2622   finish:
2623 #endif
2624     if (result < 0 && errno == EINTR) {
2625         PERL_ASYNC_CHECK();
2626     }
2627     return result;
2628 }
2629 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2630
2631 void
2632 Perl_pidgone(pTHX_ Pid_t pid, int status)
2633 {
2634     register SV *sv;
2635     char spid[TYPE_CHARS(IV)];
2636
2637     sprintf(spid, "%"IVdf, (IV)pid);
2638     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
2639     SvUPGRADE(sv,SVt_IV);
2640     SvIV_set(sv, status);
2641     return;
2642 }
2643
2644 #if defined(atarist) || defined(OS2) || defined(EPOC)
2645 int pclose();
2646 #ifdef HAS_FORK
2647 int                                     /* Cannot prototype with I32
2648                                            in os2ish.h. */
2649 my_syspclose(PerlIO *ptr)
2650 #else
2651 I32
2652 Perl_my_pclose(pTHX_ PerlIO *ptr)
2653 #endif
2654 {
2655     /* Needs work for PerlIO ! */
2656     FILE *f = PerlIO_findFILE(ptr);
2657     I32 result = pclose(f);
2658     PerlIO_releaseFILE(ptr,f);
2659     return result;
2660 }
2661 #endif
2662
2663 #if defined(DJGPP)
2664 int djgpp_pclose();
2665 I32
2666 Perl_my_pclose(pTHX_ PerlIO *ptr)
2667 {
2668     /* Needs work for PerlIO ! */
2669     FILE *f = PerlIO_findFILE(ptr);
2670     I32 result = djgpp_pclose(f);
2671     result = (result << 8) & 0xff00;
2672     PerlIO_releaseFILE(ptr,f);
2673     return result;
2674 }
2675 #endif
2676
2677 void
2678 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
2679 {
2680     register I32 todo;
2681     register const char *frombase = from;
2682
2683     if (len == 1) {
2684         register const char c = *from;
2685         while (count-- > 0)
2686             *to++ = c;
2687         return;
2688     }
2689     while (count-- > 0) {
2690         for (todo = len; todo > 0; todo--) {
2691             *to++ = *from++;
2692         }
2693         from = frombase;
2694     }
2695 }
2696
2697 #ifndef HAS_RENAME
2698 I32
2699 Perl_same_dirent(pTHX_ const char *a, const char *b)
2700 {
2701     char *fa = strrchr(a,'/');
2702     char *fb = strrchr(b,'/');
2703     Stat_t tmpstatbuf1;
2704     Stat_t tmpstatbuf2;
2705     SV *tmpsv = sv_newmortal();
2706
2707     if (fa)
2708         fa++;
2709     else
2710         fa = a;
2711     if (fb)
2712         fb++;
2713     else
2714         fb = b;
2715     if (strNE(a,b))
2716         return FALSE;
2717     if (fa == a)
2718         sv_setpvn(tmpsv, ".", 1);
2719     else
2720         sv_setpvn(tmpsv, a, fa - a);
2721     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2722         return FALSE;
2723     if (fb == b)
2724         sv_setpvn(tmpsv, ".", 1);
2725     else
2726         sv_setpvn(tmpsv, b, fb - b);
2727     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2728         return FALSE;
2729     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2730            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2731 }
2732 #endif /* !HAS_RENAME */
2733
2734 char*
2735 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags)
2736 {
2737     const char *xfound = Nullch;
2738     char *xfailed = Nullch;
2739     char tmpbuf[MAXPATHLEN];
2740     register char *s;
2741     I32 len = 0;
2742     int retval;
2743 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2744 #  define SEARCH_EXTS ".bat", ".cmd", NULL
2745 #  define MAX_EXT_LEN 4
2746 #endif
2747 #ifdef OS2
2748 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2749 #  define MAX_EXT_LEN 4
2750 #endif
2751 #ifdef VMS
2752 #  define SEARCH_EXTS ".pl", ".com", NULL
2753 #  define MAX_EXT_LEN 4
2754 #endif
2755     /* additional extensions to try in each dir if scriptname not found */
2756 #ifdef SEARCH_EXTS
2757     const char *exts[] = { SEARCH_EXTS };
2758     const char **ext = search_ext ? search_ext : exts;
2759     int extidx = 0, i = 0;
2760     const char *curext = Nullch;
2761 #else
2762     PERL_UNUSED_ARG(search_ext);
2763 #  define MAX_EXT_LEN 0
2764 #endif
2765
2766     /*
2767      * If dosearch is true and if scriptname does not contain path
2768      * delimiters, search the PATH for scriptname.
2769      *
2770      * If SEARCH_EXTS is also defined, will look for each
2771      * scriptname{SEARCH_EXTS} whenever scriptname is not found
2772      * while searching the PATH.
2773      *
2774      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2775      * proceeds as follows:
2776      *   If DOSISH or VMSISH:
2777      *     + look for ./scriptname{,.foo,.bar}
2778      *     + search the PATH for scriptname{,.foo,.bar}
2779      *
2780      *   If !DOSISH:
2781      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
2782      *       this will not look in '.' if it's not in the PATH)
2783      */
2784     tmpbuf[0] = '\0';
2785
2786 #ifdef VMS
2787 #  ifdef ALWAYS_DEFTYPES
2788     len = strlen(scriptname);
2789     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2790         int hasdir, idx = 0, deftypes = 1;
2791         bool seen_dot = 1;
2792
2793         hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2794 #  else
2795     if (dosearch) {
2796         int hasdir, idx = 0, deftypes = 1;
2797         bool seen_dot = 1;
2798
2799         hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2800 #  endif
2801         /* The first time through, just add SEARCH_EXTS to whatever we
2802          * already have, so we can check for default file types. */
2803         while (deftypes ||
2804                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
2805         {
2806             if (deftypes) {
2807                 deftypes = 0;
2808                 *tmpbuf = '\0';
2809             }
2810             if ((strlen(tmpbuf) + strlen(scriptname)
2811                  + MAX_EXT_LEN) >= sizeof tmpbuf)
2812                 continue;       /* don't search dir with too-long name */
2813             strcat(tmpbuf, scriptname);
2814 #else  /* !VMS */
2815
2816 #ifdef DOSISH
2817     if (strEQ(scriptname, "-"))
2818         dosearch = 0;
2819     if (dosearch) {             /* Look in '.' first. */
2820         const char *cur = scriptname;
2821 #ifdef SEARCH_EXTS
2822         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2823             while (ext[i])
2824                 if (strEQ(ext[i++],curext)) {
2825                     extidx = -1;                /* already has an ext */
2826                     break;
2827                 }
2828         do {
2829 #endif
2830             DEBUG_p(PerlIO_printf(Perl_debug_log,
2831                                   "Looking for %s\n",cur));
2832             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2833                 && !S_ISDIR(PL_statbuf.st_mode)) {
2834                 dosearch = 0;
2835                 scriptname = cur;
2836 #ifdef SEARCH_EXTS
2837                 break;
2838 #endif
2839             }
2840 #ifdef SEARCH_EXTS
2841             if (cur == scriptname) {
2842                 len = strlen(scriptname);
2843                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
2844                     break;
2845                 /* FIXME? Convert to memcpy  */
2846                 cur = strcpy(tmpbuf, scriptname);
2847             }
2848         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
2849                  && strcpy(tmpbuf+len, ext[extidx++]));
2850 #endif
2851     }
2852 #endif
2853
2854 #ifdef MACOS_TRADITIONAL
2855     if (dosearch && !strchr(scriptname, ':') &&
2856         (s = PerlEnv_getenv("Commands")))
2857 #else
2858     if (dosearch && !strchr(scriptname, '/')
2859 #ifdef DOSISH
2860                  && !strchr(scriptname, '\\')
2861 #endif
2862                  && (s = PerlEnv_getenv("PATH")))
2863 #endif
2864     {
2865         bool seen_dot = 0;
2866
2867         PL_bufend = s + strlen(s);
2868         while (s < PL_bufend) {
2869 #ifdef MACOS_TRADITIONAL
2870             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2871                         ',',
2872                         &len);
2873 #else
2874 #if defined(atarist) || defined(DOSISH)
2875             for (len = 0; *s
2876 #  ifdef atarist
2877                     && *s != ','
2878 #  endif
2879                     && *s != ';'; len++, s++) {
2880                 if (len < sizeof tmpbuf)
2881                     tmpbuf[len] = *s;
2882             }
2883             if (len < sizeof tmpbuf)
2884                 tmpbuf[len] = '\0';
2885 #else  /* ! (atarist || DOSISH) */
2886             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2887                         ':',
2888                         &len);
2889 #endif /* ! (atarist || DOSISH) */
2890 #endif /* MACOS_TRADITIONAL */
2891             if (s < PL_bufend)
2892                 s++;
2893             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
2894                 continue;       /* don't search dir with too-long name */
2895 #ifdef MACOS_TRADITIONAL
2896             if (len && tmpbuf[len - 1] != ':')
2897                 tmpbuf[len++] = ':';
2898 #else
2899             if (len
2900 #  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
2901                 && tmpbuf[len - 1] != '/'
2902                 && tmpbuf[len - 1] != '\\'
2903 #  endif
2904                )
2905                 tmpbuf[len++] = '/';
2906             if (len == 2 && tmpbuf[0] == '.')
2907                 seen_dot = 1;
2908 #endif
2909             /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
2910              */
2911             (void)strcpy(tmpbuf + len, scriptname);
2912 #endif  /* !VMS */
2913
2914 #ifdef SEARCH_EXTS
2915             len = strlen(tmpbuf);
2916             if (extidx > 0)     /* reset after previous loop */
2917                 extidx = 0;
2918             do {
2919 #endif
2920                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
2921                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
2922                 if (S_ISDIR(PL_statbuf.st_mode)) {
2923                     retval = -1;
2924                 }
2925 #ifdef SEARCH_EXTS
2926             } while (  retval < 0               /* not there */
2927                     && extidx>=0 && ext[extidx] /* try an extension? */
2928                     && strcpy(tmpbuf+len, ext[extidx++])
2929                 );
2930 #endif
2931             if (retval < 0)
2932                 continue;
2933             if (S_ISREG(PL_statbuf.st_mode)
2934                 && cando(S_IRUSR,TRUE,&PL_statbuf)
2935 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
2936                 && cando(S_IXUSR,TRUE,&PL_statbuf)
2937 #endif
2938                 )
2939             {
2940                 xfound = tmpbuf;                /* bingo! */
2941                 break;
2942             }
2943             if (!xfailed)
2944                 xfailed = savepv(tmpbuf);
2945         }
2946 #ifndef DOSISH
2947         if (!xfound && !seen_dot && !xfailed &&
2948             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
2949              || S_ISDIR(PL_statbuf.st_mode)))
2950 #endif
2951             seen_dot = 1;                       /* Disable message. */
2952         if (!xfound) {
2953             if (flags & 1) {                    /* do or die? */
2954                 Perl_croak(aTHX_ "Can't %s %s%s%s",
2955                       (xfailed ? "execute" : "find"),
2956                       (xfailed ? xfailed : scriptname),
2957                       (xfailed ? "" : " on PATH"),
2958                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2959             }
2960             scriptname = Nullch;
2961         }
2962         if (xfailed)
2963             Safefree(xfailed);
2964         scriptname = xfound;
2965     }
2966     return (scriptname ? savepv(scriptname) : Nullch);
2967 }
2968
2969 #ifndef PERL_GET_CONTEXT_DEFINED
2970
2971 void *
2972 Perl_get_context(void)
2973 {
2974     dVAR;
2975 #if defined(USE_ITHREADS)
2976 #  ifdef OLD_PTHREADS_API
2977     pthread_addr_t t;
2978     if (pthread_getspecific(PL_thr_key, &t))
2979         Perl_croak_nocontext("panic: pthread_getspecific");
2980     return (void*)t;
2981 #  else
2982 #    ifdef I_MACH_CTHREADS
2983     return (void*)cthread_data(cthread_self());
2984 #    else
2985     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2986 #    endif
2987 #  endif
2988 #else
2989     return (void*)NULL;
2990 #endif
2991 }
2992
2993 void
2994 Perl_set_context(void *t)
2995 {
2996     dVAR;
2997 #if defined(USE_ITHREADS)
2998 #  ifdef I_MACH_CTHREADS
2999     cthread_set_data(cthread_self(), t);
3000 #  else
3001     if (pthread_setspecific(PL_thr_key, t))
3002         Perl_croak_nocontext("panic: pthread_setspecific");
3003 #  endif
3004 #else
3005     PERL_UNUSED_ARG(t);
3006 #endif
3007 }
3008
3009 #endif /* !PERL_GET_CONTEXT_DEFINED */
3010
3011 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3012 struct perl_vars *
3013 Perl_GetVars(pTHX)
3014 {
3015  return &PL_Vars;
3016 }
3017 #endif
3018
3019 char **
3020 Perl_get_op_names(pTHX)
3021 {
3022  return (char **)PL_op_name;
3023 }
3024
3025 char **
3026 Perl_get_op_descs(pTHX)
3027 {
3028  return (char **)PL_op_desc;
3029 }
3030
3031 const char *
3032 Perl_get_no_modify(pTHX)
3033 {
3034  return PL_no_modify;
3035 }
3036
3037 U32 *
3038 Perl_get_opargs(pTHX)
3039 {
3040  return (U32 *)PL_opargs;
3041 }
3042
3043 PPADDR_t*
3044 Perl_get_ppaddr(pTHX)
3045 {
3046  dVAR;
3047  return (PPADDR_t*)PL_ppaddr;
3048 }
3049
3050 #ifndef HAS_GETENV_LEN
3051 char *
3052 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3053 {
3054     char * const env_trans = PerlEnv_getenv(env_elem);
3055     if (env_trans)
3056         *len = strlen(env_trans);
3057     return env_trans;
3058 }
3059 #endif
3060
3061
3062 MGVTBL*
3063 Perl_get_vtbl(pTHX_ int vtbl_id)
3064 {
3065     const MGVTBL* result = Null(MGVTBL*);
3066
3067     switch(vtbl_id) {
3068     case want_vtbl_sv:
3069         result = &PL_vtbl_sv;
3070         break;
3071     case want_vtbl_env:
3072         result = &PL_vtbl_env;
3073         break;
3074     case want_vtbl_envelem:
3075         result = &PL_vtbl_envelem;
3076         break;
3077     case want_vtbl_sig:
3078         result = &PL_vtbl_sig;
3079         break;
3080     case want_vtbl_sigelem:
3081         result = &PL_vtbl_sigelem;
3082         break;
3083     case want_vtbl_pack:
3084         result = &PL_vtbl_pack;
3085         break;
3086     case want_vtbl_packelem:
3087         result = &PL_vtbl_packelem;
3088         break;
3089     case want_vtbl_dbline:
3090         result = &PL_vtbl_dbline;
3091         break;
3092     case want_vtbl_isa:
3093         result = &PL_vtbl_isa;
3094         break;
3095     case want_vtbl_isaelem:
3096         result = &PL_vtbl_isaelem;
3097         break;
3098     case want_vtbl_arylen:
3099         result = &PL_vtbl_arylen;
3100         break;
3101     case want_vtbl_glob:
3102         result = &PL_vtbl_glob;
3103         break;
3104     case want_vtbl_mglob:
3105         result = &PL_vtbl_mglob;
3106         break;
3107     case want_vtbl_nkeys:
3108         result = &PL_vtbl_nkeys;
3109         break;
3110     case want_vtbl_taint:
3111         result = &PL_vtbl_taint;
3112         break;
3113     case want_vtbl_substr:
3114         result = &PL_vtbl_substr;
3115         break;
3116     case want_vtbl_vec:
3117         result = &PL_vtbl_vec;
3118         break;
3119     case want_vtbl_pos:
3120         result = &PL_vtbl_pos;
3121         break;
3122     case want_vtbl_bm:
3123         result = &PL_vtbl_bm;
3124         break;
3125     case want_vtbl_fm:
3126         result = &PL_vtbl_fm;
3127         break;
3128     case want_vtbl_uvar:
3129         result = &PL_vtbl_uvar;
3130         break;
3131     case want_vtbl_defelem:
3132         result = &PL_vtbl_defelem;
3133         break;
3134     case want_vtbl_regexp:
3135         result = &PL_vtbl_regexp;
3136         break;
3137     case want_vtbl_regdata:
3138         result = &PL_vtbl_regdata;
3139         break;
3140     case want_vtbl_regdatum:
3141         result = &PL_vtbl_regdatum;
3142         break;
3143 #ifdef USE_LOCALE_COLLATE
3144     case want_vtbl_collxfrm:
3145         result = &PL_vtbl_collxfrm;
3146         break;
3147 #endif
3148     case want_vtbl_amagic:
3149         result = &PL_vtbl_amagic;
3150         break;
3151     case want_vtbl_amagicelem:
3152         result = &PL_vtbl_amagicelem;
3153         break;
3154     case want_vtbl_backref:
3155         result = &PL_vtbl_backref;
3156         break;
3157     case want_vtbl_utf8:
3158         result = &PL_vtbl_utf8;
3159         break;
3160     }
3161     return (MGVTBL*)result;
3162 }
3163
3164 I32
3165 Perl_my_fflush_all(pTHX)
3166 {
3167 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3168     return PerlIO_flush(NULL);
3169 #else
3170 # if defined(HAS__FWALK)
3171     extern int fflush(FILE *);
3172     /* undocumented, unprototyped, but very useful BSDism */
3173     extern void _fwalk(int (*)(FILE *));
3174     _fwalk(&fflush);
3175     return 0;
3176 # else
3177 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3178     long open_max = -1;
3179 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3180     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3181 #   else
3182 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3183     open_max = sysconf(_SC_OPEN_MAX);
3184 #     else
3185 #      ifdef FOPEN_MAX
3186     open_max = FOPEN_MAX;
3187 #      else
3188 #       ifdef OPEN_MAX
3189     open_max = OPEN_MAX;
3190 #       else
3191 #        ifdef _NFILE
3192     open_max = _NFILE;
3193 #        endif
3194 #       endif
3195 #      endif
3196 #     endif
3197 #    endif
3198     if (open_max > 0) {
3199       long i;
3200       for (i = 0; i < open_max; i++)
3201             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3202                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3203                 STDIO_STREAM_ARRAY[i]._flag)
3204                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3205       return 0;
3206     }
3207 #  endif
3208     SETERRNO(EBADF,RMS_IFI);
3209     return EOF;
3210 # endif
3211 #endif
3212 }
3213
3214 void
3215 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3216 {
3217     const char *func =
3218         op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3219         op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3220         PL_op_desc[op];
3221     const char *pars = OP_IS_FILETEST(op) ? "" : "()";
3222     const char *type = OP_IS_SOCKET(op)
3223             || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3224                 ?  "socket" : "filehandle";
3225     const char *name = NULL;
3226
3227     if (gv && isGV(gv)) {
3228         name = GvENAME(gv);
3229     }
3230
3231     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3232         if (ckWARN(WARN_IO)) {
3233             const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3234             if (name && *name)
3235                 Perl_warner(aTHX_ packWARN(WARN_IO),
3236                             "Filehandle %s opened only for %sput",
3237                             name, direction);
3238             else
3239                 Perl_warner(aTHX_ packWARN(WARN_IO),
3240                             "Filehandle opened only for %sput", direction);
3241         }
3242     }
3243     else {
3244         const char *vile;
3245         I32   warn_type;
3246
3247         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3248             vile = "closed";
3249             warn_type = WARN_CLOSED;
3250         }
3251         else {
3252             vile = "unopened";
3253             warn_type = WARN_UNOPENED;
3254         }
3255
3256         if (ckWARN(warn_type)) {
3257             if (name && *name) {
3258                 Perl_warner(aTHX_ packWARN(warn_type),
3259                             "%s%s on %s %s %s", func, pars, vile, type, name);
3260                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3261                     Perl_warner(
3262                         aTHX_ packWARN(warn_type),
3263                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3264                         func, pars, name
3265                     );
3266             }
3267             else {
3268                 Perl_warner(aTHX_ packWARN(warn_type),
3269                             "%s%s on %s %s", func, pars, vile, type);
3270                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3271                     Perl_warner(
3272                         aTHX_ packWARN(warn_type),
3273                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3274                         func, pars
3275                     );
3276             }
3277         }
3278     }
3279 }
3280
3281 #ifdef EBCDIC
3282 /* in ASCII order, not that it matters */
3283 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3284
3285 int
3286 Perl_ebcdic_control(pTHX_ int ch)
3287 {
3288     if (ch > 'a') {
3289         const char *ctlp;
3290
3291         if (islower(ch))
3292             ch = toupper(ch);
3293
3294         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3295             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3296         }
3297
3298         if (ctlp == controllablechars)
3299             return('\177'); /* DEL */
3300         else
3301             return((unsigned char)(ctlp - controllablechars - 1));
3302     } else { /* Want uncontrol */
3303         if (ch == '\177' || ch == -1)
3304             return('?');
3305         else if (ch == '\157')
3306             return('\177');
3307         else if (ch == '\174')
3308             return('\000');
3309         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3310             return('\036');
3311         else if (ch == '\155')
3312             return('\037');
3313         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3314             return(controllablechars[ch+1]);
3315         else
3316             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3317     }
3318 }
3319 #endif
3320
3321 /* To workaround core dumps from the uninitialised tm_zone we get the
3322  * system to give us a reasonable struct to copy.  This fix means that
3323  * strftime uses the tm_zone and tm_gmtoff values returned by
3324  * localtime(time()). That should give the desired result most of the
3325  * time. But probably not always!
3326  *
3327  * This does not address tzname aspects of NETaa14816.
3328  *
3329  */
3330
3331 #ifdef HAS_GNULIBC
3332 # ifndef STRUCT_TM_HASZONE
3333 #    define STRUCT_TM_HASZONE
3334 # endif
3335 #endif
3336
3337 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3338 # ifndef HAS_TM_TM_ZONE
3339 #    define HAS_TM_TM_ZONE
3340 # endif
3341 #endif
3342
3343 void
3344 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3345 {
3346 #ifdef HAS_TM_TM_ZONE
3347     Time_t now;
3348     const struct tm* my_tm;
3349     (void)time(&now);
3350     my_tm = localtime(&now);
3351     if (my_tm)
3352         Copy(my_tm, ptm, 1, struct tm);
3353 #else
3354     PERL_UNUSED_ARG(ptm);
3355 #endif
3356 }
3357
3358 /*
3359  * mini_mktime - normalise struct tm values without the localtime()
3360  * semantics (and overhead) of mktime().
3361  */
3362 void
3363 Perl_mini_mktime(pTHX_ struct tm *ptm)
3364 {
3365     int yearday;
3366     int secs;
3367     int month, mday, year, jday;
3368     int odd_cent, odd_year;
3369
3370 #define DAYS_PER_YEAR   365
3371 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3372 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3373 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3374 #define SECS_PER_HOUR   (60*60)
3375 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3376 /* parentheses deliberately absent on these two, otherwise they don't work */
3377 #define MONTH_TO_DAYS   153/5
3378 #define DAYS_TO_MONTH   5/153
3379 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3380 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3381 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3382 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3383
3384 /*
3385  * Year/day algorithm notes:
3386  *
3387  * With a suitable offset for numeric value of the month, one can find
3388  * an offset into the year by considering months to have 30.6 (153/5) days,
3389  * using integer arithmetic (i.e., with truncation).  To avoid too much
3390  * messing about with leap days, we consider January and February to be
3391  * the 13th and 14th month of the previous year.  After that transformation,
3392  * we need the month index we use to be high by 1 from 'normal human' usage,
3393  * so the month index values we use run from 4 through 15.
3394  *
3395  * Given that, and the rules for the Gregorian calendar (leap years are those
3396  * divisible by 4 unless also divisible by 100, when they must be divisible
3397  * by 400 instead), we can simply calculate the number of days since some
3398  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3399  * the days we derive from our month index, and adding in the day of the
3400  * month.  The value used here is not adjusted for the actual origin which
3401  * it normally would use (1 January A.D. 1), since we're not exposing it.
3402  * We're only building the value so we can turn around and get the
3403  * normalised values for the year, month, day-of-month, and day-of-year.
3404  *
3405  * For going backward, we need to bias the value we're using so that we find
3406  * the right year value.  (Basically, we don't want the contribution of
3407  * March 1st to the number to apply while deriving the year).  Having done
3408  * that, we 'count up' the contribution to the year number by accounting for
3409  * full quadracenturies (400-year periods) with their extra leap days, plus
3410  * the contribution from full centuries (to avoid counting in the lost leap
3411  * days), plus the contribution from full quad-years (to count in the normal
3412  * leap days), plus the leftover contribution from any non-leap years.
3413  * At this point, if we were working with an actual leap day, we'll have 0
3414  * days left over.  This is also true for March 1st, however.  So, we have
3415  * to special-case that result, and (earlier) keep track of the 'odd'
3416  * century and year contributions.  If we got 4 extra centuries in a qcent,
3417  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3418  * Otherwise, we add back in the earlier bias we removed (the 123 from
3419  * figuring in March 1st), find the month index (integer division by 30.6),
3420  * and the remainder is the day-of-month.  We then have to convert back to
3421  * 'real' months (including fixing January and February from being 14/15 in
3422  * the previous year to being in the proper year).  After that, to get
3423  * tm_yday, we work with the normalised year and get a new yearday value for
3424  * January 1st, which we subtract from the yearday value we had earlier,
3425  * representing the date we've re-built.  This is done from January 1
3426  * because tm_yday is 0-origin.
3427  *
3428  * Since POSIX time routines are only guaranteed to work for times since the
3429  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3430  * applies Gregorian calendar rules even to dates before the 16th century
3431  * doesn't bother me.  Besides, you'd need cultural context for a given
3432  * date to know whether it was Julian or Gregorian calendar, and that's
3433  * outside the scope for this routine.  Since we convert back based on the
3434  * same rules we used to build the yearday, you'll only get strange results
3435  * for input which needed normalising, or for the 'odd' century years which
3436  * were leap years in the Julian calander but not in the Gregorian one.
3437  * I can live with that.
3438  *
3439  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3440  * that's still outside the scope for POSIX time manipulation, so I don't
3441  * care.
3442  */
3443
3444     year = 1900 + ptm->tm_year;
3445     month = ptm->tm_mon;
3446     mday = ptm->tm_mday;
3447     /* allow given yday with no month & mday to dominate the result */
3448     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3449         month = 0;
3450         mday = 0;
3451         jday = 1 + ptm->tm_yday;
3452     }
3453     else {
3454         jday = 0;
3455     }
3456     if (month >= 2)
3457         month+=2;
3458     else
3459         month+=14, year--;
3460     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3461     yearday += month*MONTH_TO_DAYS + mday + jday;
3462     /*
3463      * Note that we don't know when leap-seconds were or will be,
3464      * so we have to trust the user if we get something which looks
3465      * like a sensible leap-second.  Wild values for seconds will
3466      * be rationalised, however.
3467      */
3468     if ((unsigned) ptm->tm_sec <= 60) {
3469         secs = 0;
3470     }
3471     else {
3472         secs = ptm->tm_sec;
3473         ptm->tm_sec = 0;
3474     }
3475     secs += 60 * ptm->tm_min;
3476     secs += SECS_PER_HOUR * ptm->tm_hour;
3477     if (secs < 0) {
3478         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3479             /* got negative remainder, but need positive time */
3480             /* back off an extra day to compensate */
3481             yearday += (secs/SECS_PER_DAY)-1;
3482             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3483         }
3484         else {
3485             yearday += (secs/SECS_PER_DAY);
3486             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3487         }
3488     }
3489     else if (secs >= SECS_PER_DAY) {
3490         yearday += (secs/SECS_PER_DAY);
3491         secs %= SECS_PER_DAY;
3492     }
3493     ptm->tm_hour = secs/SECS_PER_HOUR;
3494     secs %= SECS_PER_HOUR;
3495     ptm->tm_min = secs/60;
3496     secs %= 60;
3497     ptm->tm_sec += secs;
3498     /* done with time of day effects */
3499     /*
3500      * The algorithm for yearday has (so far) left it high by 428.
3501      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3502      * bias it by 123 while trying to figure out what year it
3503      * really represents.  Even with this tweak, the reverse
3504      * translation fails for years before A.D. 0001.
3505      * It would still fail for Feb 29, but we catch that one below.
3506      */
3507     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3508     yearday -= YEAR_ADJUST;
3509     year = (yearday / DAYS_PER_QCENT) * 400;
3510     yearday %= DAYS_PER_QCENT;
3511     odd_cent = yearday / DAYS_PER_CENT;
3512     year += odd_cent * 100;
3513     yearday %= DAYS_PER_CENT;
3514     year += (yearday / DAYS_PER_QYEAR) * 4;
3515     yearday %= DAYS_PER_QYEAR;
3516     odd_year = yearday / DAYS_PER_YEAR;
3517     year += odd_year;
3518     yearday %= DAYS_PER_YEAR;
3519     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3520         month = 1;
3521         yearday = 29;
3522     }
3523     else {
3524         yearday += YEAR_ADJUST; /* recover March 1st crock */
3525         month = yearday*DAYS_TO_MONTH;
3526         yearday -= month*MONTH_TO_DAYS;
3527         /* recover other leap-year adjustment */
3528         if (month > 13) {
3529             month-=14;
3530             year++;
3531         }
3532         else {
3533             month-=2;
3534         }
3535     }
3536     ptm->tm_year = year - 1900;
3537     if (yearday) {
3538       ptm->tm_mday = yearday;
3539       ptm->tm_mon = month;
3540     }
3541     else {
3542       ptm->tm_mday = 31;
3543       ptm->tm_mon = month - 1;
3544     }
3545     /* re-build yearday based on Jan 1 to get tm_yday */
3546     year--;
3547     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3548     yearday += 14*MONTH_TO_DAYS + 1;
3549     ptm->tm_yday = jday - yearday;
3550     /* fix tm_wday if not overridden by caller */
3551     if ((unsigned)ptm->tm_wday > 6)
3552         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3553 }
3554
3555 char *
3556 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)
3557 {
3558 #ifdef HAS_STRFTIME
3559   char *buf;
3560   int buflen;
3561   struct tm mytm;
3562   int len;
3563
3564   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3565   mytm.tm_sec = sec;
3566   mytm.tm_min = min;
3567   mytm.tm_hour = hour;
3568   mytm.tm_mday = mday;
3569   mytm.tm_mon = mon;
3570   mytm.tm_year = year;
3571   mytm.tm_wday = wday;
3572   mytm.tm_yday = yday;
3573   mytm.tm_isdst = isdst;
3574   mini_mktime(&mytm);
3575   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3576 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3577   STMT_START {
3578     struct tm mytm2;
3579     mytm2 = mytm;
3580     mktime(&mytm2);
3581 #ifdef HAS_TM_TM_GMTOFF
3582     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3583 #endif
3584 #ifdef HAS_TM_TM_ZONE
3585     mytm.tm_zone = mytm2.tm_zone;
3586 #endif
3587   } STMT_END;
3588 #endif
3589   buflen = 64;
3590   New(0, buf, buflen, char);
3591   len = strftime(buf, buflen, fmt, &mytm);
3592   /*
3593   ** The following is needed to handle to the situation where
3594   ** tmpbuf overflows.  Basically we want to allocate a buffer
3595   ** and try repeatedly.  The reason why it is so complicated
3596   ** is that getting a return value of 0 from strftime can indicate
3597   ** one of the following:
3598   ** 1. buffer overflowed,
3599   ** 2. illegal conversion specifier, or
3600   ** 3. the format string specifies nothing to be returned(not
3601   **      an error).  This could be because format is an empty string
3602   **    or it specifies %p that yields an empty string in some locale.
3603   ** If there is a better way to make it portable, go ahead by
3604   ** all means.
3605   */
3606   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3607     return buf;
3608   else {
3609     /* Possibly buf overflowed - try again with a bigger buf */
3610     const int fmtlen = strlen(fmt);
3611     const int bufsize = fmtlen + buflen;
3612
3613     New(0, buf, bufsize, char);
3614     while (buf) {
3615       buflen = strftime(buf, bufsize, fmt, &mytm);
3616       if (buflen > 0 && buflen < bufsize)
3617         break;
3618       /* heuristic to prevent out-of-memory errors */
3619       if (bufsize > 100*fmtlen) {
3620         Safefree(buf);
3621         buf = NULL;
3622         break;
3623       }
3624       Renew(buf, bufsize*2, char);
3625     }
3626     return buf;
3627   }
3628 #else
3629   Perl_croak(aTHX_ "panic: no strftime");
3630   return NULL;
3631 #endif
3632 }
3633
3634
3635 #define SV_CWD_RETURN_UNDEF \
3636 sv_setsv(sv, &PL_sv_undef); \
3637 return FALSE
3638
3639 #define SV_CWD_ISDOT(dp) \
3640     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3641         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3642
3643 /*
3644 =head1 Miscellaneous Functions
3645
3646 =for apidoc getcwd_sv
3647
3648 Fill the sv with current working directory
3649
3650 =cut
3651 */
3652
3653 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3654  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3655  * getcwd(3) if available
3656  * Comments from the orignal:
3657  *     This is a faster version of getcwd.  It's also more dangerous
3658  *     because you might chdir out of a directory that you can't chdir
3659  *     back into. */
3660
3661 int
3662 Perl_getcwd_sv(pTHX_ register SV *sv)
3663 {
3664 #ifndef PERL_MICRO
3665
3666 #ifndef INCOMPLETE_TAINTS
3667     SvTAINTED_on(sv);
3668 #endif
3669
3670 #ifdef HAS_GETCWD
3671     {
3672         char buf[MAXPATHLEN];
3673
3674         /* Some getcwd()s automatically allocate a buffer of the given
3675          * size from the heap if they are given a NULL buffer pointer.
3676          * The problem is that this behaviour is not portable. */
3677         if (getcwd(buf, sizeof(buf) - 1)) {
3678             sv_setpvn(sv, buf, strlen(buf));
3679             return TRUE;
3680         }
3681         else {
3682             sv_setsv(sv, &PL_sv_undef);
3683             return FALSE;
3684         }
3685     }
3686
3687 #else
3688
3689     Stat_t statbuf;
3690     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3691     int pathlen=0;
3692     Direntry_t *dp;
3693
3694     SvUPGRADE(sv, SVt_PV);
3695
3696     if (PerlLIO_lstat(".", &statbuf) < 0) {
3697         SV_CWD_RETURN_UNDEF;
3698     }
3699
3700     orig_cdev = statbuf.st_dev;
3701     orig_cino = statbuf.st_ino;
3702     cdev = orig_cdev;
3703     cino = orig_cino;
3704
3705     for (;;) {
3706         DIR *dir;
3707         odev = cdev;
3708         oino = cino;
3709
3710         if (PerlDir_chdir("..") < 0) {
3711             SV_CWD_RETURN_UNDEF;
3712         }
3713         if (PerlLIO_stat(".", &statbuf) < 0) {
3714             SV_CWD_RETURN_UNDEF;
3715         }
3716
3717         cdev = statbuf.st_dev;
3718         cino = statbuf.st_ino;
3719
3720         if (odev == cdev && oino == cino) {
3721             break;
3722         }
3723         if (!(dir = PerlDir_open("."))) {
3724             SV_CWD_RETURN_UNDEF;
3725         }
3726
3727         while ((dp = PerlDir_read(dir)) != NULL) {
3728 #ifdef DIRNAMLEN
3729             const int namelen = dp->d_namlen;
3730 #else
3731             const int namelen = strlen(dp->d_name);
3732 #endif
3733             /* skip . and .. */
3734             if (SV_CWD_ISDOT(dp)) {
3735                 continue;
3736             }
3737
3738             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3739                 SV_CWD_RETURN_UNDEF;
3740             }
3741
3742             tdev = statbuf.st_dev;
3743             tino = statbuf.st_ino;
3744             if (tino == oino && tdev == odev) {
3745                 break;
3746             }
3747         }
3748
3749         if (!dp) {
3750             SV_CWD_RETURN_UNDEF;
3751         }
3752
3753         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3754             SV_CWD_RETURN_UNDEF;
3755         }
3756
3757         SvGROW(sv, pathlen + namelen + 1);
3758
3759         if (pathlen) {
3760             /* shift down */
3761             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3762         }
3763
3764         /* prepend current directory to the front */
3765         *SvPVX(sv) = '/';
3766         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3767         pathlen += (namelen + 1);
3768
3769 #ifdef VOID_CLOSEDIR
3770         PerlDir_close(dir);
3771 #else
3772         if (PerlDir_close(dir) < 0) {
3773             SV_CWD_RETURN_UNDEF;
3774         }
3775 #endif
3776     }
3777
3778     if (pathlen) {
3779         SvCUR_set(sv, pathlen);
3780         *SvEND(sv) = '\0';
3781         SvPOK_only(sv);
3782
3783         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3784             SV_CWD_RETURN_UNDEF;
3785         }
3786     }
3787     if (PerlLIO_stat(".", &statbuf) < 0) {
3788         SV_CWD_RETURN_UNDEF;
3789     }
3790
3791     cdev = statbuf.st_dev;
3792     cino = statbuf.st_ino;
3793
3794     if (cdev != orig_cdev || cino != orig_cino) {
3795         Perl_croak(aTHX_ "Unstable directory path, "
3796                    "current directory changed unexpectedly");
3797     }
3798
3799     return TRUE;
3800 #endif
3801
3802 #else
3803     return FALSE;
3804 #endif
3805 }
3806
3807 /*
3808 =for apidoc scan_version
3809
3810 Returns a pointer to the next character after the parsed
3811 version string, as well as upgrading the passed in SV to
3812 an RV.
3813
3814 Function must be called with an already existing SV like
3815
3816     sv = newSV(0);
3817     s = scan_version(s,SV *sv, bool qv);
3818
3819 Performs some preprocessing to the string to ensure that
3820 it has the correct characteristics of a version.  Flags the
3821 object if it contains an underscore (which denotes this
3822 is a alpha version).  The boolean qv denotes that the version
3823 should be interpreted as if it had multiple decimals, even if
3824 it doesn't.
3825
3826 =cut
3827 */
3828
3829 const char *
3830 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
3831 {
3832     const char *start = s;
3833     const char *pos;
3834     const char *last;
3835     int saw_period = 0;
3836     int saw_under = 0;
3837     int width = 3;
3838     AV *av = newAV();
3839     SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3840     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3841 #ifndef NODEFAULT_SHAREKEYS
3842     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
3843 #endif
3844
3845     if (*s == 'v') {
3846         s++;  /* get past 'v' */
3847         qv = 1; /* force quoted version processing */
3848     }
3849
3850     last = pos = s;
3851
3852     /* pre-scan the input string to check for decimals/underbars */
3853     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3854     {
3855         if ( *pos == '.' )
3856         {
3857             if ( saw_under )
3858                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
3859             saw_period++ ;
3860             last = pos;
3861         }
3862         else if ( *pos == '_' )
3863         {
3864             if ( saw_under )
3865                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
3866             saw_under = 1;
3867             width = pos - last - 1; /* natural width of sub-version */
3868         }
3869         pos++;
3870     }
3871
3872     if ( saw_period > 1 ) {
3873         qv = 1; /* force quoted version processing */
3874     }
3875
3876     pos = s;
3877
3878     if ( qv )
3879         hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
3880     if ( saw_under ) {
3881         hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
3882     }
3883     if ( !qv && width < 3 )
3884         hv_store((HV *)hv, "width", 5, newSViv(width), 0);
3885
3886     while (isDIGIT(*pos))
3887         pos++;
3888     if (!isALPHA(*pos)) {
3889         I32 rev;
3890
3891         for (;;) {
3892             rev = 0;
3893             {
3894                 /* this is atoi() that delimits on underscores */
3895                 const char *end = pos;
3896                 I32 mult = 1;
3897                 I32 orev;
3898
3899                 /* the following if() will only be true after the decimal
3900                  * point of a version originally created with a bare
3901                  * floating point number, i.e. not quoted in any way
3902                  */
3903                 if ( !qv && s > start+1 && saw_period == 1 ) {
3904                     mult *= 100;
3905                     while ( s < end ) {
3906                         orev = rev;
3907                         rev += (*s - '0') * mult;
3908                         mult /= 10;
3909                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3910                             Perl_croak(aTHX_ "Integer overflow in version");
3911                         s++;
3912                         if ( *s == '_' )
3913                             s++;
3914                     }
3915                 }
3916                 else {
3917                     while (--end >= s) {
3918                         orev = rev;
3919                         rev += (*end - '0') * mult;
3920                         mult *= 10;
3921                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
3922                             Perl_croak(aTHX_ "Integer overflow in version");
3923                     }
3924                 }
3925             }
3926
3927             /* Append revision */
3928             av_push(av, newSViv(rev));
3929             if ( *pos == '.' && isDIGIT(pos[1]) )
3930                 s = ++pos;
3931             else if ( *pos == '_' && isDIGIT(pos[1]) )
3932                 s = ++pos;
3933             else if ( isDIGIT(*pos) )
3934                 s = pos;
3935             else {
3936                 s = pos;
3937                 break;
3938             }
3939             if ( qv ) {
3940                 while ( isDIGIT(*pos) )
3941                     pos++;
3942             }
3943             else {
3944                 int digits = 0;
3945                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
3946                     if ( *pos != '_' )
3947                         digits++;
3948                     pos++;
3949                 }
3950             }
3951         }
3952     }
3953     if ( qv ) { /* quoted versions always get at least three terms*/
3954         I32 len = av_len(av);
3955         /* This for loop appears to trigger a compiler bug on OS X, as it
3956            loops infinitely. Yes, len is negative. No, it makes no sense.
3957            Compiler in question is:
3958            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3959            for ( len = 2 - len; len > 0; len-- )
3960            av_push((AV *)sv, newSViv(0));
3961         */
3962         len = 2 - len;
3963         while (len-- > 0)
3964             av_push(av, newSViv(0));
3965     }
3966
3967     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
3968         av_push(av, newSViv(0));
3969
3970     /* And finally, store the AV in the hash */
3971     hv_store((HV *)hv, "version", 7, (SV *)av, 0);
3972     return s;
3973 }
3974
3975 /*
3976 =for apidoc new_version
3977
3978 Returns a new version object based on the passed in SV:
3979
3980     SV *sv = new_version(SV *ver);
3981
3982 Does not alter the passed in ver SV.  See "upg_version" if you
3983 want to upgrade the SV.
3984
3985 =cut
3986 */
3987
3988 SV *
3989 Perl_new_version(pTHX_ SV *ver)
3990 {
3991     SV *rv = newSV(0);
3992     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3993     {
3994         I32 key;
3995         AV * const av = newAV();
3996         AV *sav;
3997         /* This will get reblessed later if a derived class*/
3998         SV*  const hv = newSVrv(rv, "version");
3999         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4000 #ifndef NODEFAULT_SHAREKEYS
4001         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4002 #endif
4003
4004         if ( SvROK(ver) )
4005             ver = SvRV(ver);
4006
4007         /* Begin copying all of the elements */
4008         if ( hv_exists((HV *)ver, "qv", 2) )
4009             hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4010
4011         if ( hv_exists((HV *)ver, "alpha", 5) )
4012             hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4013
4014         if ( hv_exists((HV*)ver, "width", 5 ) )
4015         {
4016             const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
4017             hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4018         }
4019
4020         sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE);
4021         /* This will get reblessed later if a derived class*/
4022         for ( key = 0; key <= av_len(sav); key++ )
4023         {
4024             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4025             av_push(av, newSViv(rev));
4026         }
4027
4028         hv_store((HV *)hv, "version", 7, (SV *)av, 0);
4029         return rv;
4030     }
4031 #ifdef SvVOK
4032     if ( SvVOK(ver) ) { /* already a v-string */
4033         char *version;
4034         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4035         const STRLEN len = mg->mg_len;
4036         version = savepvn( (const char*)mg->mg_ptr, len);
4037         sv_setpvn(rv,version,len);
4038         Safefree(version);
4039     }
4040     else {
4041 #endif
4042     sv_setsv(rv,ver); /* make a duplicate */
4043 #ifdef SvVOK
4044     }
4045 #endif
4046     upg_version(rv);
4047     return rv;
4048 }
4049
4050 /*
4051 =for apidoc upg_version
4052
4053 In-place upgrade of the supplied SV to a version object.
4054
4055     SV *sv = upg_version(SV *sv);
4056
4057 Returns a pointer to the upgraded SV.
4058
4059 =cut
4060 */
4061
4062 SV *
4063 Perl_upg_version(pTHX_ SV *ver)
4064 {
4065     char *version;
4066     bool qv = 0;
4067
4068     if ( SvNOK(ver) ) /* may get too much accuracy */
4069     {
4070         char tbuf[64];
4071         sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4072         version = savepv(tbuf);
4073     }
4074 #ifdef SvVOK
4075     else if ( SvVOK(ver) ) { /* already a v-string */
4076         MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4077         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4078         qv = 1;
4079     }
4080 #endif
4081     else /* must be a string or something like a string */
4082     {
4083         version = savepv(SvPV_nolen(ver));
4084     }
4085     (void)scan_version(version, ver, qv);
4086     Safefree(version);
4087     return ver;
4088 }
4089
4090
4091 /*
4092 =for apidoc vnumify
4093
4094 Accepts a version object and returns the normalized floating
4095 point representation.  Call like:
4096
4097     sv = vnumify(rv);
4098
4099 NOTE: you can pass either the object directly or the SV
4100 contained within the RV.
4101
4102 =cut
4103 */
4104
4105 SV *
4106 Perl_vnumify(pTHX_ SV *vs)
4107 {
4108     I32 i, len, digit;
4109     int width;
4110     bool alpha = FALSE;
4111     SV * const sv = newSV(0);
4112     AV *av;
4113     if ( SvROK(vs) )
4114         vs = SvRV(vs);
4115
4116     /* see if various flags exist */
4117     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4118         alpha = TRUE;
4119     if ( hv_exists((HV*)vs, "width", 5 ) )
4120         width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE));
4121     else
4122         width = 3;
4123
4124
4125     /* attempt to retrieve the version array */
4126     if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) {
4127         sv_catpvn(sv,"0",1);
4128         return sv;
4129     }
4130
4131     len = av_len(av);
4132     if ( len == -1 )
4133     {
4134         sv_catpvn(sv,"0",1);
4135         return sv;
4136     }
4137
4138     digit = SvIV(*av_fetch(av, 0, 0));
4139     Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
4140     for ( i = 1 ; i < len ; i++ )
4141     {
4142         digit = SvIV(*av_fetch(av, i, 0));
4143         if ( width < 3 ) {
4144             const int denom = (int)pow(10,(3-width));
4145             const div_t term = div((int)PERL_ABS(digit),denom);
4146             Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
4147         }
4148         else {
4149             Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
4150         }
4151     }
4152
4153     if ( len > 0 )
4154     {
4155         digit = SvIV(*av_fetch(av, len, 0));
4156         if ( alpha && width == 3 ) /* alpha version */
4157             Perl_sv_catpv(aTHX_ sv,"_");
4158         /* Don't display additional trailing zeros */
4159         if ( digit > 0 )
4160             Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit);
4161     }
4162     else /* len == 1 */
4163     {
4164          sv_catpvn(sv,"000",3);
4165     }
4166     return sv;
4167 }
4168
4169 /*
4170 =for apidoc vnormal
4171
4172 Accepts a version object and returns the normalized string
4173 representation.  Call like:
4174
4175     sv = vnormal(rv);
4176
4177 NOTE: you can pass either the object directly or the SV
4178 contained within the RV.
4179
4180 =cut
4181 */
4182
4183 SV *
4184 Perl_vnormal(pTHX_ SV *vs)
4185 {
4186     I32 i, len, digit;
4187     bool alpha = FALSE;
4188     SV *sv = newSV(0);
4189     AV *av;
4190     if ( SvROK(vs) )
4191         vs = SvRV(vs);
4192
4193     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4194         alpha = TRUE;
4195     av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE);
4196
4197     len = av_len(av);
4198     if ( len == -1 ) {
4199         sv_catpvn(sv,"",0);
4200         return sv;
4201     }
4202     digit = SvIV(*av_fetch(av, 0, 0));
4203     Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit);
4204     for ( i = 1 ; i <= len-1 ; i++ ) {
4205         digit = SvIV(*av_fetch(av, i, 0));
4206         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4207     }
4208
4209     if ( len > 0 ) {
4210         /* handle last digit specially */
4211         digit = SvIV(*av_fetch(av, len, 0));
4212         if ( alpha )
4213             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4214         else
4215             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4216     }
4217
4218     if ( len <= 2 ) { /* short version, must be at least three */
4219         for ( len = 2 - len; len != 0; len-- )
4220             sv_catpvn(sv,".0",2);
4221     }
4222
4223     return sv;
4224 }
4225
4226 /*
4227 =for apidoc vstringify
4228
4229 In order to maintain maximum compatibility with earlier versions
4230 of Perl, this function will return either the floating point
4231 notation or the multiple dotted notation, depending on whether
4232 the original version contained 1 or more dots, respectively
4233
4234 =cut
4235 */
4236
4237 SV *
4238 Perl_vstringify(pTHX_ SV *vs)
4239 {
4240     I32 qv = 0;
4241     if ( SvROK(vs) )
4242         vs = SvRV(vs);
4243
4244     if ( hv_exists((HV *)vs, "qv", 2) )
4245         qv = 1;
4246
4247     if ( qv )
4248         return vnormal(vs);
4249     else
4250         return vnumify(vs);
4251 }
4252
4253 /*
4254 =for apidoc vcmp
4255
4256 Version object aware cmp.  Both operands must already have been
4257 converted into version objects.
4258
4259 =cut
4260 */
4261
4262 int
4263 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4264 {
4265     I32 i,l,m,r,retval;
4266     bool lalpha = FALSE;
4267     bool ralpha = FALSE;
4268     I32 left = 0;
4269     I32 right = 0;
4270     AV *lav, *rav;
4271     if ( SvROK(lhv) )
4272         lhv = SvRV(lhv);
4273     if ( SvROK(rhv) )
4274         rhv = SvRV(rhv);
4275
4276     /* get the left hand term */
4277     lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE);
4278     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4279         lalpha = TRUE;
4280
4281     /* and the right hand term */
4282     rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE);
4283     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4284         ralpha = TRUE;
4285
4286     l = av_len(lav);
4287     r = av_len(rav);
4288     m = l < r ? l : r;
4289     retval = 0;
4290     i = 0;
4291     while ( i <= m && retval == 0 )
4292     {
4293         left  = SvIV(*av_fetch(lav,i,0));
4294         right = SvIV(*av_fetch(rav,i,0));
4295         if ( left < right  )
4296             retval = -1;
4297         if ( left > right )
4298             retval = +1;
4299         i++;
4300     }
4301
4302     /* tiebreaker for alpha with identical terms */
4303     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4304     {
4305         if ( lalpha && !ralpha )
4306         {
4307             retval = -1;
4308         }
4309         else if ( ralpha && !lalpha)
4310         {
4311             retval = +1;
4312         }
4313     }
4314
4315     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4316     {
4317         if ( l < r )
4318         {
4319             while ( i <= r && retval == 0 )
4320             {
4321                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4322                     retval = -1; /* not a match after all */
4323                 i++;
4324             }
4325         }
4326         else
4327         {
4328             while ( i <= l && retval == 0 )
4329             {
4330                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4331                     retval = +1; /* not a match after all */
4332                 i++;
4333             }
4334         }
4335     }
4336     return retval;
4337 }
4338
4339 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4340 #   define EMULATE_SOCKETPAIR_UDP
4341 #endif
4342
4343 #ifdef EMULATE_SOCKETPAIR_UDP
4344 static int
4345 S_socketpair_udp (int fd[2]) {
4346     dTHX;
4347     /* Fake a datagram socketpair using UDP to localhost.  */
4348     int sockets[2] = {-1, -1};
4349     struct sockaddr_in addresses[2];
4350     int i;
4351     Sock_size_t size = sizeof(struct sockaddr_in);
4352     unsigned short port;
4353     int got;
4354
4355     memset(&addresses, 0, sizeof(addresses));
4356     i = 1;
4357     do {
4358         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4359         if (sockets[i] == -1)
4360             goto tidy_up_and_fail;
4361
4362         addresses[i].sin_family = AF_INET;
4363         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4364         addresses[i].sin_port = 0;      /* kernel choses port.  */
4365         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4366                 sizeof(struct sockaddr_in)) == -1)
4367             goto tidy_up_and_fail;
4368     } while (i--);
4369
4370     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4371        for each connect the other socket to it.  */
4372     i = 1;
4373     do {
4374         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4375                 &size) == -1)
4376             goto tidy_up_and_fail;
4377         if (size != sizeof(struct sockaddr_in))
4378             goto abort_tidy_up_and_fail;
4379         /* !1 is 0, !0 is 1 */
4380         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4381                 sizeof(struct sockaddr_in)) == -1)
4382             goto tidy_up_and_fail;
4383     } while (i--);
4384
4385     /* Now we have 2 sockets connected to each other. I don't trust some other
4386        process not to have already sent a packet to us (by random) so send
4387        a packet from each to the other.  */
4388     i = 1;
4389     do {
4390         /* I'm going to send my own port number.  As a short.
4391            (Who knows if someone somewhere has sin_port as a bitfield and needs
4392            this routine. (I'm assuming crays have socketpair)) */
4393         port = addresses[i].sin_port;
4394         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4395         if (got != sizeof(port)) {
4396             if (got == -1)
4397                 goto tidy_up_and_fail;
4398             goto abort_tidy_up_and_fail;
4399         }
4400     } while (i--);
4401
4402     /* Packets sent. I don't trust them to have arrived though.
4403        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4404        connect to localhost will use a second kernel thread. In 2.6 the
4405        first thread running the connect() returns before the second completes,
4406        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4407        returns 0. Poor programs have tripped up. One poor program's authors'
4408        had a 50-1 reverse stock split. Not sure how connected these were.)
4409        So I don't trust someone not to have an unpredictable UDP stack.
4410     */
4411
4412     {
4413         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4414         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4415         fd_set rset;
4416
4417         FD_ZERO(&rset);
4418         FD_SET(sockets[0], &rset);
4419         FD_SET(sockets[1], &rset);
4420
4421         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4422         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4423                 || !FD_ISSET(sockets[1], &rset)) {
4424             /* I hope this is portable and appropriate.  */
4425             if (got == -1)
4426                 goto tidy_up_and_fail;
4427             goto abort_tidy_up_and_fail;
4428         }
4429     }
4430
4431     /* And the paranoia department even now doesn't trust it to have arrive
4432        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4433     {
4434         struct sockaddr_in readfrom;
4435         unsigned short buffer[2];
4436
4437         i = 1;
4438         do {
4439 #ifdef MSG_DONTWAIT
4440             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4441                     sizeof(buffer), MSG_DONTWAIT,
4442                     (struct sockaddr *) &readfrom, &size);
4443 #else
4444             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4445                     sizeof(buffer), 0,
4446                     (struct sockaddr *) &readfrom, &size);
4447 #endif
4448
4449             if (got == -1)
4450                 goto tidy_up_and_fail;
4451             if (got != sizeof(port)
4452                     || size != sizeof(struct sockaddr_in)
4453                     /* Check other socket sent us its port.  */
4454                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4455                     /* Check kernel says we got the datagram from that socket */
4456                     || readfrom.sin_family != addresses[!i].sin_family
4457                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4458                     || readfrom.sin_port != addresses[!i].sin_port)
4459                 goto abort_tidy_up_and_fail;
4460         } while (i--);
4461     }
4462     /* My caller (my_socketpair) has validated that this is non-NULL  */
4463     fd[0] = sockets[0];
4464     fd[1] = sockets[1];
4465     /* I hereby declare this connection open.  May God bless all who cross
4466        her.  */
4467     return 0;
4468
4469   abort_tidy_up_and_fail:
4470     errno = ECONNABORTED;
4471   tidy_up_and_fail:
4472     {
4473         const int save_errno = errno;
4474         if (sockets[0] != -1)
4475             PerlLIO_close(sockets[0]);
4476         if (sockets[1] != -1)
4477             PerlLIO_close(sockets[1]);
4478         errno = save_errno;
4479         return -1;
4480     }
4481 }
4482 #endif /*  EMULATE_SOCKETPAIR_UDP */
4483
4484 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4485 int
4486 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4487     /* Stevens says that family must be AF_LOCAL, protocol 0.
4488        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4489     dTHX;
4490     int listener = -1;
4491     int connector = -1;
4492     int acceptor = -1;
4493     struct sockaddr_in listen_addr;
4494     struct sockaddr_in connect_addr;
4495     Sock_size_t size;
4496
4497     if (protocol
4498 #ifdef AF_UNIX
4499         || family != AF_UNIX
4500 #endif
4501     ) {
4502         errno = EAFNOSUPPORT;
4503         return -1;
4504     }
4505     if (!fd) {
4506         errno = EINVAL;
4507         return -1;
4508     }
4509
4510 #ifdef EMULATE_SOCKETPAIR_UDP
4511     if (type == SOCK_DGRAM)
4512         return S_socketpair_udp(fd);
4513 #endif
4514
4515     listener = PerlSock_socket(AF_INET, type, 0);
4516     if (listener == -1)
4517         return -1;
4518     memset(&listen_addr, 0, sizeof(listen_addr));
4519     listen_addr.sin_family = AF_INET;
4520     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4521     listen_addr.sin_port = 0;   /* kernel choses port.  */
4522     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4523             sizeof(listen_addr)) == -1)
4524         goto tidy_up_and_fail;
4525     if (PerlSock_listen(listener, 1) == -1)
4526         goto tidy_up_and_fail;
4527
4528     connector = PerlSock_socket(AF_INET, type, 0);
4529     if (connector == -1)
4530         goto tidy_up_and_fail;
4531     /* We want to find out the port number to connect to.  */
4532     size = sizeof(connect_addr);
4533     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4534             &size) == -1)
4535         goto tidy_up_and_fail;
4536     if (size != sizeof(connect_addr))
4537         goto abort_tidy_up_and_fail;
4538     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4539             sizeof(connect_addr)) == -1)
4540         goto tidy_up_and_fail;
4541
4542     size = sizeof(listen_addr);
4543     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4544             &size);
4545     if (acceptor == -1)
4546         goto tidy_up_and_fail;
4547     if (size != sizeof(listen_addr))
4548         goto abort_tidy_up_and_fail;
4549     PerlLIO_close(listener);
4550     /* Now check we are talking to ourself by matching port and host on the
4551        two sockets.  */
4552     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4553             &size) == -1)
4554         goto tidy_up_and_fail;
4555     if (size != sizeof(connect_addr)
4556             || listen_addr.sin_family != connect_addr.sin_family
4557             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4558             || listen_addr.sin_port != connect_addr.sin_port) {
4559         goto abort_tidy_up_and_fail;
4560     }
4561     fd[0] = connector;
4562     fd[1] = acceptor;
4563     return 0;
4564
4565   abort_tidy_up_and_fail:
4566 #ifdef ECONNABORTED
4567   errno = ECONNABORTED; /* This would be the standard thing to do. */
4568 #else
4569 #  ifdef ECONNREFUSED
4570   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4571 #  else
4572   errno = ETIMEDOUT;    /* Desperation time. */
4573 #  endif
4574 #endif
4575   tidy_up_and_fail:
4576     {
4577         int save_errno = errno;
4578         if (listener != -1)
4579             PerlLIO_close(listener);
4580         if (connector != -1)
4581             PerlLIO_close(connector);
4582         if (acceptor != -1)
4583             PerlLIO_close(acceptor);
4584         errno = save_errno;
4585         return -1;
4586     }
4587 }
4588 #else
4589 /* In any case have a stub so that there's code corresponding
4590  * to the my_socketpair in global.sym. */
4591 int
4592 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4593 #ifdef HAS_SOCKETPAIR
4594     return socketpair(family, type, protocol, fd);
4595 #else
4596     return -1;
4597 #endif
4598 }
4599 #endif
4600
4601 /*
4602
4603 =for apidoc sv_nosharing
4604
4605 Dummy routine which "shares" an SV when there is no sharing module present.
4606 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4607 some level of strict-ness.
4608
4609 =cut
4610 */
4611
4612 void
4613 Perl_sv_nosharing(pTHX_ SV *sv)
4614 {
4615     PERL_UNUSED_ARG(sv);
4616 }
4617
4618 /*
4619 =for apidoc sv_nolocking
4620
4621 Dummy routine which "locks" an SV when there is no locking module present.
4622 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4623 some level of strict-ness.
4624
4625 =cut
4626 */
4627
4628 void
4629 Perl_sv_nolocking(pTHX_ SV *sv)
4630 {
4631     PERL_UNUSED_ARG(sv);
4632 }
4633
4634
4635 /*
4636 =for apidoc sv_nounlocking
4637
4638 Dummy routine which "unlocks" an SV when there is no locking module present.
4639 Exists to avoid test for a NULL function pointer and because it could potentially warn under
4640 some level of strict-ness.
4641
4642 =cut
4643 */
4644
4645 void
4646 Perl_sv_nounlocking(pTHX_ SV *sv)
4647 {
4648     PERL_UNUSED_ARG(sv);
4649 }
4650
4651 U32
4652 Perl_parse_unicode_opts(pTHX_ const char **popt)
4653 {
4654   const char *p = *popt;
4655   U32 opt = 0;
4656
4657   if (*p) {
4658        if (isDIGIT(*p)) {
4659             opt = (U32) atoi(p);
4660             while (isDIGIT(*p)) p++;
4661             if (*p && *p != '\n' && *p != '\r')
4662                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4663        }
4664        else {
4665             for (; *p; p++) {
4666                  switch (*p) {
4667                  case PERL_UNICODE_STDIN:
4668                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4669                  case PERL_UNICODE_STDOUT:
4670                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4671                  case PERL_UNICODE_STDERR:
4672                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4673                  case PERL_UNICODE_STD:
4674                       opt |= PERL_UNICODE_STD_FLAG;     break;
4675                  case PERL_UNICODE_IN:
4676                       opt |= PERL_UNICODE_IN_FLAG;      break;
4677                  case PERL_UNICODE_OUT:
4678                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4679                  case PERL_UNICODE_INOUT:
4680                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4681                  case PERL_UNICODE_LOCALE:
4682                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4683                  case PERL_UNICODE_ARGV:
4684                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4685                  default:
4686                       if (*p != '\n' && *p != '\r')
4687                           Perl_croak(aTHX_
4688                                      "Unknown Unicode option letter '%c'", *p);
4689                  }
4690             }
4691        }
4692   }
4693   else
4694        opt = PERL_UNICODE_DEFAULT_FLAGS;
4695
4696   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4697        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4698                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4699
4700   *popt = p;
4701
4702   return opt;
4703 }
4704
4705 U32
4706 Perl_seed(pTHX)
4707 {
4708     /*
4709      * This is really just a quick hack which grabs various garbage
4710      * values.  It really should be a real hash algorithm which
4711      * spreads the effect of every input bit onto every output bit,
4712      * if someone who knows about such things would bother to write it.
4713      * Might be a good idea to add that function to CORE as well.
4714      * No numbers below come from careful analysis or anything here,
4715      * except they are primes and SEED_C1 > 1E6 to get a full-width
4716      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4717      * probably be bigger too.
4718      */
4719 #if RANDBITS > 16
4720 #  define SEED_C1       1000003
4721 #define   SEED_C4       73819
4722 #else
4723 #  define SEED_C1       25747
4724 #define   SEED_C4       20639
4725 #endif
4726 #define   SEED_C2       3
4727 #define   SEED_C3       269
4728 #define   SEED_C5       26107
4729
4730 #ifndef PERL_NO_DEV_RANDOM
4731     int fd;
4732 #endif
4733     U32 u;
4734 #ifdef VMS
4735 #  include <starlet.h>
4736     /* when[] = (low 32 bits, high 32 bits) of time since epoch
4737      * in 100-ns units, typically incremented ever 10 ms.        */
4738     unsigned int when[2];
4739 #else
4740 #  ifdef HAS_GETTIMEOFDAY
4741     struct timeval when;
4742 #  else
4743     Time_t when;
4744 #  endif
4745 #endif
4746
4747 /* This test is an escape hatch, this symbol isn't set by Configure. */
4748 #ifndef PERL_NO_DEV_RANDOM
4749 #ifndef PERL_RANDOM_DEVICE
4750    /* /dev/random isn't used by default because reads from it will block
4751     * if there isn't enough entropy available.  You can compile with
4752     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4753     * is enough real entropy to fill the seed. */
4754 #  define PERL_RANDOM_DEVICE "/dev/urandom"
4755 #endif
4756     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4757     if (fd != -1) {
4758         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4759             u = 0;
4760         PerlLIO_close(fd);
4761         if (u)
4762             return u;
4763     }
4764 #endif
4765
4766 #ifdef VMS
4767     _ckvmssts(sys$gettim(when));
4768     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4769 #else
4770 #  ifdef HAS_GETTIMEOFDAY
4771     PerlProc_gettimeofday(&when,NULL);
4772     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4773 #  else
4774     (void)time(&when);
4775     u = (U32)SEED_C1 * when;
4776 #  endif
4777 #endif
4778     u += SEED_C3 * (U32)PerlProc_getpid();
4779     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4780 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4781     u += SEED_C5 * (U32)PTR2UV(&when);
4782 #endif
4783     return u;
4784 }
4785
4786 UV
4787 Perl_get_hash_seed(pTHX)
4788 {
4789      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
4790      UV myseed = 0;
4791
4792      if (s)
4793           while (isSPACE(*s)) s++;
4794      if (s && isDIGIT(*s))
4795           myseed = (UV)Atoul(s);
4796      else
4797 #ifdef USE_HASH_SEED_EXPLICIT
4798      if (s)
4799 #endif
4800      {
4801           /* Compute a random seed */
4802           (void)seedDrand01((Rand_seed_t)seed());
4803           myseed = (UV)(Drand01() * (NV)UV_MAX);
4804 #if RANDBITS < (UVSIZE * 8)
4805           /* Since there are not enough randbits to to reach all
4806            * the bits of a UV, the low bits might need extra
4807            * help.  Sum in another random number that will
4808            * fill in the low bits. */
4809           myseed +=
4810                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4811 #endif /* RANDBITS < (UVSIZE * 8) */
4812           if (myseed == 0) { /* Superparanoia. */
4813               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4814               if (myseed == 0)
4815                   Perl_croak(aTHX_ "Your random numbers are not that random");
4816           }
4817      }
4818      PL_rehash_seed_set = TRUE;
4819
4820      return myseed;
4821 }
4822
4823 #ifdef USE_ITHREADS
4824 bool
4825 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
4826 {
4827     const char * const stashpv = CopSTASHPV(c);
4828     const char * const name = HvNAME_get(hv);
4829
4830     if (stashpv == name)
4831         return TRUE;
4832     if (stashpv && name)
4833         if (strEQ(stashpv, name))
4834             return TRUE;
4835     return FALSE;
4836 }
4837 #endif
4838
4839
4840 #ifdef PERL_GLOBAL_STRUCT
4841
4842 struct perl_vars *
4843 Perl_init_global_struct(pTHX)
4844 {
4845     struct perl_vars *plvarsp = NULL;
4846 #ifdef PERL_GLOBAL_STRUCT
4847 #  define PERL_GLOBAL_STRUCT_INIT
4848 #  include "opcode.h" /* the ppaddr and check */
4849     IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
4850     IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
4851 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4852     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4853     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4854     if (!plvarsp)
4855         exit(1);
4856 #  else
4857     plvarsp = PL_VarsPtr;
4858 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4859 #  undef PERLVAR
4860 #  undef PERLVARA
4861 #  undef PERLVARI
4862 #  undef PERLVARIC
4863 #  undef PERLVARISC
4864 #  define PERLVAR(var,type) /**/
4865 #  define PERLVARA(var,n,type) /**/
4866 #  define PERLVARI(var,type,init) plvarsp->var = init;
4867 #  define PERLVARIC(var,type,init) plvarsp->var = init;
4868 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
4869 #  include "perlvars.h"
4870 #  undef PERLVAR
4871 #  undef PERLVARA
4872 #  undef PERLVARI
4873 #  undef PERLVARIC
4874 #  undef PERLVARISC
4875 #  ifdef PERL_GLOBAL_STRUCT
4876     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4877     if (!plvarsp->Gppaddr)
4878         exit(1);
4879     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4880     if (!plvarsp->Gcheck)
4881         exit(1);
4882     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4883     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
4884 #  endif
4885 #  ifdef PERL_SET_VARS
4886     PERL_SET_VARS(plvarsp);
4887 #  endif
4888 #  undef PERL_GLOBAL_STRUCT_INIT
4889 #endif
4890     return plvarsp;
4891 }
4892
4893 #endif /* PERL_GLOBAL_STRUCT */
4894
4895 #ifdef PERL_GLOBAL_STRUCT
4896
4897 void
4898 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4899 {
4900 #ifdef PERL_GLOBAL_STRUCT
4901 #  ifdef PERL_UNSET_VARS
4902     PERL_UNSET_VARS(plvarsp);
4903 #  endif
4904     free(plvarsp->Gppaddr);
4905     free(plvarsp->Gcheck);
4906 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
4907     free(plvarsp);
4908 #    endif
4909 #endif
4910 }
4911
4912 #endif /* PERL_GLOBAL_STRUCT */
4913
4914 /*
4915  * Local variables:
4916  * c-indentation-style: bsd
4917  * c-basic-offset: 4
4918  * indent-tabs-mode: t
4919  * End:
4920  *
4921  * ex: set ts=8 sts=4 sw=4 noet:
4922  */