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