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