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