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