util.c

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