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