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