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