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             if (environ) /* old glibc can crash with null environ */
1961                 (void)unsetenv(nam);
1962         } else {
1963             const int nlen = strlen(nam);
1964             const int vlen = strlen(val);
1965             char * const new_env =
1966                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1967             my_setenv_format(new_env, nam, nlen, val, vlen);
1968             (void)putenv(new_env);
1969         }
1970 #       else /* ! HAS_UNSETENV */
1971         char *new_env;
1972         const int nlen = strlen(nam);
1973         int vlen;
1974         if (!val) {
1975            val = "";
1976         }
1977         vlen = strlen(val);
1978         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1979         /* all that work just for this */
1980         my_setenv_format(new_env, nam, nlen, val, vlen);
1981         (void)putenv(new_env);
1982 #       endif /* HAS_UNSETENV */
1983 #   endif /* __CYGWIN__ */
1984 #ifndef PERL_USE_SAFE_PUTENV
1985     }
1986 #endif
1987   }
1988 }
1989
1990 #else /* WIN32 || NETWARE */
1991
1992 void
1993 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1994 {
1995     dVAR;
1996     char *envstr;
1997     const int nlen = strlen(nam);
1998     int vlen;
1999
2000     if (!val) {
2001        val = "";
2002     }
2003     vlen = strlen(val);
2004     Newx(envstr, nlen+vlen+2, char);
2005     my_setenv_format(envstr, nam, nlen, val, vlen);
2006     (void)PerlEnv_putenv(envstr);
2007     Safefree(envstr);
2008 }
2009
2010 #endif /* WIN32 || NETWARE */
2011
2012 #endif /* !VMS */
2013
2014 #ifdef UNLINK_ALL_VERSIONS
2015 I32
2016 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2017 {
2018     I32 retries = 0;
2019
2020     PERL_ARGS_ASSERT_UNLNK;
2021
2022     while (PerlLIO_unlink(f) >= 0)
2023         retries++;
2024     return retries ? 0 : -1;
2025 }
2026 #endif
2027
2028 /* this is a drop-in replacement for bcopy() */
2029 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2030 char *
2031 Perl_my_bcopy(const char *from, char *to, I32 len)
2032 {
2033     char * const retval = to;
2034
2035     PERL_ARGS_ASSERT_MY_BCOPY;
2036
2037     assert(len >= 0);
2038
2039     if (from - to >= 0) {
2040         while (len--)
2041             *to++ = *from++;
2042     }
2043     else {
2044         to += len;
2045         from += len;
2046         while (len--)
2047             *(--to) = *(--from);
2048     }
2049     return retval;
2050 }
2051 #endif
2052
2053 /* this is a drop-in replacement for memset() */
2054 #ifndef HAS_MEMSET
2055 void *
2056 Perl_my_memset(char *loc, I32 ch, I32 len)
2057 {
2058     char * const retval = loc;
2059
2060     PERL_ARGS_ASSERT_MY_MEMSET;
2061
2062     assert(len >= 0);
2063
2064     while (len--)
2065         *loc++ = ch;
2066     return retval;
2067 }
2068 #endif
2069
2070 /* this is a drop-in replacement for bzero() */
2071 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2072 char *
2073 Perl_my_bzero(char *loc, I32 len)
2074 {
2075     char * const retval = loc;
2076
2077     PERL_ARGS_ASSERT_MY_BZERO;
2078
2079     assert(len >= 0);
2080
2081     while (len--)
2082         *loc++ = 0;
2083     return retval;
2084 }
2085 #endif
2086
2087 /* this is a drop-in replacement for memcmp() */
2088 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2089 I32
2090 Perl_my_memcmp(const char *s1, const char *s2, I32 len)
2091 {
2092     const U8 *a = (const U8 *)s1;
2093     const U8 *b = (const U8 *)s2;
2094     I32 tmp;
2095
2096     PERL_ARGS_ASSERT_MY_MEMCMP;
2097
2098     assert(len >= 0);
2099
2100     while (len--) {
2101         if ((tmp = *a++ - *b++))
2102             return tmp;
2103     }
2104     return 0;
2105 }
2106 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2107
2108 #ifndef HAS_VPRINTF
2109 /* This vsprintf replacement should generally never get used, since
2110    vsprintf was available in both System V and BSD 2.11.  (There may
2111    be some cross-compilation or embedded set-ups where it is needed,
2112    however.)
2113
2114    If you encounter a problem in this function, it's probably a symptom
2115    that Configure failed to detect your system's vprintf() function.
2116    See the section on "item vsprintf" in the INSTALL file.
2117
2118    This version may compile on systems with BSD-ish <stdio.h>,
2119    but probably won't on others.
2120 */
2121
2122 #ifdef USE_CHAR_VSPRINTF
2123 char *
2124 #else
2125 int
2126 #endif
2127 vsprintf(char *dest, const char *pat, void *args)
2128 {
2129     FILE fakebuf;
2130
2131 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2132     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2133     FILE_cnt(&fakebuf) = 32767;
2134 #else
2135     /* These probably won't compile -- If you really need
2136        this, you'll have to figure out some other method. */
2137     fakebuf._ptr = dest;
2138     fakebuf._cnt = 32767;
2139 #endif
2140 #ifndef _IOSTRG
2141 #define _IOSTRG 0
2142 #endif
2143     fakebuf._flag = _IOWRT|_IOSTRG;
2144     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2145 #if defined(STDIO_PTR_LVALUE)
2146     *(FILE_ptr(&fakebuf)++) = '\0';
2147 #else
2148     /* PerlIO has probably #defined away fputc, but we want it here. */
2149 #  ifdef fputc
2150 #    undef fputc  /* XXX Should really restore it later */
2151 #  endif
2152     (void)fputc('\0', &fakebuf);
2153 #endif
2154 #ifdef USE_CHAR_VSPRINTF
2155     return(dest);
2156 #else
2157     return 0;           /* perl doesn't use return value */
2158 #endif
2159 }
2160
2161 #endif /* HAS_VPRINTF */
2162
2163 PerlIO *
2164 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2165 {
2166 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2167     dVAR;
2168     int p[2];
2169     I32 This, that;
2170     Pid_t pid;
2171     SV *sv;
2172     I32 did_pipes = 0;
2173     int pp[2];
2174
2175     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2176
2177     PERL_FLUSHALL_FOR_CHILD;
2178     This = (*mode == 'w');
2179     that = !This;
2180     if (TAINTING_get) {
2181         taint_env();
2182         taint_proper("Insecure %s%s", "EXEC");
2183     }
2184     if (PerlProc_pipe(p) < 0)
2185         return NULL;
2186     /* Try for another pipe pair for error return */
2187     if (PerlProc_pipe(pp) >= 0)
2188         did_pipes = 1;
2189     while ((pid = PerlProc_fork()) < 0) {
2190         if (errno != EAGAIN) {
2191             PerlLIO_close(p[This]);
2192             PerlLIO_close(p[that]);
2193             if (did_pipes) {
2194                 PerlLIO_close(pp[0]);
2195                 PerlLIO_close(pp[1]);
2196             }
2197             return NULL;
2198         }
2199         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2200         sleep(5);
2201     }
2202     if (pid == 0) {
2203         /* Child */
2204 #undef THIS
2205 #undef THAT
2206 #define THIS that
2207 #define THAT This
2208         /* Close parent's end of error status pipe (if any) */
2209         if (did_pipes) {
2210             PerlLIO_close(pp[0]);
2211 #if defined(HAS_FCNTL) && defined(F_SETFD)
2212             /* Close error pipe automatically if exec works */
2213             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2214 #endif
2215         }
2216         /* Now dup our end of _the_ pipe to right position */
2217         if (p[THIS] != (*mode == 'r')) {
2218             PerlLIO_dup2(p[THIS], *mode == 'r');
2219             PerlLIO_close(p[THIS]);
2220             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2221                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2222         }
2223         else
2224             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2225 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2226         /* No automatic close - do it by hand */
2227 #  ifndef NOFILE
2228 #  define NOFILE 20
2229 #  endif
2230         {
2231             int fd;
2232
2233             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2234                 if (fd != pp[1])
2235                     PerlLIO_close(fd);
2236             }
2237         }
2238 #endif
2239         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2240         PerlProc__exit(1);
2241 #undef THIS
2242 #undef THAT
2243     }
2244     /* Parent */
2245     do_execfree();      /* free any memory malloced by child on fork */
2246     if (did_pipes)
2247         PerlLIO_close(pp[1]);
2248     /* Keep the lower of the two fd numbers */
2249     if (p[that] < p[This]) {
2250         PerlLIO_dup2(p[This], p[that]);
2251         PerlLIO_close(p[This]);
2252         p[This] = p[that];
2253     }
2254     else
2255         PerlLIO_close(p[that]);         /* close child's end of pipe */
2256
2257     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2258     SvUPGRADE(sv,SVt_IV);
2259     SvIV_set(sv, pid);
2260     PL_forkprocess = pid;
2261     /* If we managed to get status pipe check for exec fail */
2262     if (did_pipes && pid > 0) {
2263         int errkid;
2264         unsigned n = 0;
2265         SSize_t n1;
2266
2267         while (n < sizeof(int)) {
2268             n1 = PerlLIO_read(pp[0],
2269                               (void*)(((char*)&errkid)+n),
2270                               (sizeof(int)) - n);
2271             if (n1 <= 0)
2272                 break;
2273             n += n1;
2274         }
2275         PerlLIO_close(pp[0]);
2276         did_pipes = 0;
2277         if (n) {                        /* Error */
2278             int pid2, status;
2279             PerlLIO_close(p[This]);
2280             if (n != sizeof(int))
2281                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2282             do {
2283                 pid2 = wait4pid(pid, &status, 0);
2284             } while (pid2 == -1 && errno == EINTR);
2285             errno = errkid;             /* Propagate errno from kid */
2286             return NULL;
2287         }
2288     }
2289     if (did_pipes)
2290          PerlLIO_close(pp[0]);
2291     return PerlIO_fdopen(p[This], mode);
2292 #else
2293 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2294     return my_syspopen4(aTHX_ NULL, mode, n, args);
2295 #  else
2296     Perl_croak(aTHX_ "List form of piped open not implemented");
2297     return (PerlIO *) NULL;
2298 #  endif
2299 #endif
2300 }
2301
2302     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2303 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2304 PerlIO *
2305 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2306 {
2307     dVAR;
2308     int p[2];
2309     I32 This, that;
2310     Pid_t pid;
2311     SV *sv;
2312     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2313     I32 did_pipes = 0;
2314     int pp[2];
2315
2316     PERL_ARGS_ASSERT_MY_POPEN;
2317
2318     PERL_FLUSHALL_FOR_CHILD;
2319 #ifdef OS2
2320     if (doexec) {
2321         return my_syspopen(aTHX_ cmd,mode);
2322     }
2323 #endif
2324     This = (*mode == 'w');
2325     that = !This;
2326     if (doexec && TAINTING_get) {
2327         taint_env();
2328         taint_proper("Insecure %s%s", "EXEC");
2329     }
2330     if (PerlProc_pipe(p) < 0)
2331         return NULL;
2332     if (doexec && PerlProc_pipe(pp) >= 0)
2333         did_pipes = 1;
2334     while ((pid = PerlProc_fork()) < 0) {
2335         if (errno != EAGAIN) {
2336             PerlLIO_close(p[This]);
2337             PerlLIO_close(p[that]);
2338             if (did_pipes) {
2339                 PerlLIO_close(pp[0]);
2340                 PerlLIO_close(pp[1]);
2341             }
2342             if (!doexec)
2343                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2344             return NULL;
2345         }
2346         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2347         sleep(5);
2348     }
2349     if (pid == 0) {
2350
2351 #undef THIS
2352 #undef THAT
2353 #define THIS that
2354 #define THAT This
2355         if (did_pipes) {
2356             PerlLIO_close(pp[0]);
2357 #if defined(HAS_FCNTL) && defined(F_SETFD)
2358             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2359 #endif
2360         }
2361         if (p[THIS] != (*mode == 'r')) {
2362             PerlLIO_dup2(p[THIS], *mode == 'r');
2363             PerlLIO_close(p[THIS]);
2364             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2365                 PerlLIO_close(p[THAT]);
2366         }
2367         else
2368             PerlLIO_close(p[THAT]);
2369 #ifndef OS2
2370         if (doexec) {
2371 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2372 #ifndef NOFILE
2373 #define NOFILE 20
2374 #endif
2375             {
2376                 int fd;
2377
2378                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2379                     if (fd != pp[1])
2380                         PerlLIO_close(fd);
2381             }
2382 #endif
2383             /* may or may not use the shell */
2384             do_exec3(cmd, pp[1], did_pipes);
2385             PerlProc__exit(1);
2386         }
2387 #endif  /* defined OS2 */
2388
2389 #ifdef PERLIO_USING_CRLF
2390    /* Since we circumvent IO layers when we manipulate low-level
2391       filedescriptors directly, need to manually switch to the
2392       default, binary, low-level mode; see PerlIOBuf_open(). */
2393    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2394 #endif
2395         PL_forkprocess = 0;
2396 #ifdef PERL_USES_PL_PIDSTATUS
2397         hv_clear(PL_pidstatus); /* we have no children */
2398 #endif
2399         return NULL;
2400 #undef THIS
2401 #undef THAT
2402     }
2403     do_execfree();      /* free any memory malloced by child on vfork */
2404     if (did_pipes)
2405         PerlLIO_close(pp[1]);
2406     if (p[that] < p[This]) {
2407         PerlLIO_dup2(p[This], p[that]);
2408         PerlLIO_close(p[This]);
2409         p[This] = p[that];
2410     }
2411     else
2412         PerlLIO_close(p[that]);
2413
2414     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2415     SvUPGRADE(sv,SVt_IV);
2416     SvIV_set(sv, pid);
2417     PL_forkprocess = pid;
2418     if (did_pipes && pid > 0) {
2419         int errkid;
2420         unsigned n = 0;
2421         SSize_t n1;
2422
2423         while (n < sizeof(int)) {
2424             n1 = PerlLIO_read(pp[0],
2425                               (void*)(((char*)&errkid)+n),
2426                               (sizeof(int)) - n);
2427             if (n1 <= 0)
2428                 break;
2429             n += n1;
2430         }
2431         PerlLIO_close(pp[0]);
2432         did_pipes = 0;
2433         if (n) {                        /* Error */
2434             int pid2, status;
2435             PerlLIO_close(p[This]);
2436             if (n != sizeof(int))
2437                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2438             do {
2439                 pid2 = wait4pid(pid, &status, 0);
2440             } while (pid2 == -1 && errno == EINTR);
2441             errno = errkid;             /* Propagate errno from kid */
2442             return NULL;
2443         }
2444     }
2445     if (did_pipes)
2446          PerlLIO_close(pp[0]);
2447     return PerlIO_fdopen(p[This], mode);
2448 }
2449 #else
2450 #if defined(DJGPP)
2451 FILE *djgpp_popen();
2452 PerlIO *
2453 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2454 {
2455     PERL_FLUSHALL_FOR_CHILD;
2456     /* Call system's popen() to get a FILE *, then import it.
2457        used 0 for 2nd parameter to PerlIO_importFILE;
2458        apparently not used
2459     */
2460     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2461 }
2462 #else
2463 #if defined(__LIBCATAMOUNT__)
2464 PerlIO *
2465 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2466 {
2467     return NULL;
2468 }
2469 #endif
2470 #endif
2471
2472 #endif /* !DOSISH */
2473
2474 /* this is called in parent before the fork() */
2475 void
2476 Perl_atfork_lock(void)
2477 {
2478    dVAR;
2479 #if defined(USE_ITHREADS)
2480     /* locks must be held in locking order (if any) */
2481 #  ifdef USE_PERLIO
2482     MUTEX_LOCK(&PL_perlio_mutex);
2483 #  endif
2484 #  ifdef MYMALLOC
2485     MUTEX_LOCK(&PL_malloc_mutex);
2486 #  endif
2487     OP_REFCNT_LOCK;
2488 #endif
2489 }
2490
2491 /* this is called in both parent and child after the fork() */
2492 void
2493 Perl_atfork_unlock(void)
2494 {
2495     dVAR;
2496 #if defined(USE_ITHREADS)
2497     /* locks must be released in same order as in atfork_lock() */
2498 #  ifdef USE_PERLIO
2499     MUTEX_UNLOCK(&PL_perlio_mutex);
2500 #  endif
2501 #  ifdef MYMALLOC
2502     MUTEX_UNLOCK(&PL_malloc_mutex);
2503 #  endif
2504     OP_REFCNT_UNLOCK;
2505 #endif
2506 }
2507
2508 Pid_t
2509 Perl_my_fork(void)
2510 {
2511 #if defined(HAS_FORK)
2512     Pid_t pid;
2513 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2514     atfork_lock();
2515     pid = fork();
2516     atfork_unlock();
2517 #else
2518     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2519      * handlers elsewhere in the code */
2520     pid = fork();
2521 #endif
2522     return pid;
2523 #else
2524     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2525     Perl_croak_nocontext("fork() not available");
2526     return 0;
2527 #endif /* HAS_FORK */
2528 }
2529
2530 #ifdef DUMP_FDS
2531 void
2532 Perl_dump_fds(pTHX_ const char *const s)
2533 {
2534     int fd;
2535     Stat_t tmpstatbuf;
2536
2537     PERL_ARGS_ASSERT_DUMP_FDS;
2538
2539     PerlIO_printf(Perl_debug_log,"%s", s);
2540     for (fd = 0; fd < 32; fd++) {
2541         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2542             PerlIO_printf(Perl_debug_log," %d",fd);
2543     }
2544     PerlIO_printf(Perl_debug_log,"\n");
2545     return;
2546 }
2547 #endif  /* DUMP_FDS */
2548
2549 #ifndef HAS_DUP2
2550 int
2551 dup2(int oldfd, int newfd)
2552 {
2553 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2554     if (oldfd == newfd)
2555         return oldfd;
2556     PerlLIO_close(newfd);
2557     return fcntl(oldfd, F_DUPFD, newfd);
2558 #else
2559 #define DUP2_MAX_FDS 256
2560     int fdtmp[DUP2_MAX_FDS];
2561     I32 fdx = 0;
2562     int fd;
2563
2564     if (oldfd == newfd)
2565         return oldfd;
2566     PerlLIO_close(newfd);
2567     /* good enough for low fd's... */
2568     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2569         if (fdx >= DUP2_MAX_FDS) {
2570             PerlLIO_close(fd);
2571             fd = -1;
2572             break;
2573         }
2574         fdtmp[fdx++] = fd;
2575     }
2576     while (fdx > 0)
2577         PerlLIO_close(fdtmp[--fdx]);
2578     return fd;
2579 #endif
2580 }
2581 #endif
2582
2583 #ifndef PERL_MICRO
2584 #ifdef HAS_SIGACTION
2585
2586 Sighandler_t
2587 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2588 {
2589     dVAR;
2590     struct sigaction act, oact;
2591
2592 #ifdef USE_ITHREADS
2593     /* only "parent" interpreter can diddle signals */
2594     if (PL_curinterp != aTHX)
2595         return (Sighandler_t) SIG_ERR;
2596 #endif
2597
2598     act.sa_handler = (void(*)(int))handler;
2599     sigemptyset(&act.sa_mask);
2600     act.sa_flags = 0;
2601 #ifdef SA_RESTART
2602     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2603         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2604 #endif
2605 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2606     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2607         act.sa_flags |= SA_NOCLDWAIT;
2608 #endif
2609     if (sigaction(signo, &act, &oact) == -1)
2610         return (Sighandler_t) SIG_ERR;
2611     else
2612         return (Sighandler_t) oact.sa_handler;
2613 }
2614
2615 Sighandler_t
2616 Perl_rsignal_state(pTHX_ int signo)
2617 {
2618     struct sigaction oact;
2619     PERL_UNUSED_CONTEXT;
2620
2621     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2622         return (Sighandler_t) SIG_ERR;
2623     else
2624         return (Sighandler_t) oact.sa_handler;
2625 }
2626
2627 int
2628 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2629 {
2630     dVAR;
2631     struct sigaction act;
2632
2633     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2634
2635 #ifdef USE_ITHREADS
2636     /* only "parent" interpreter can diddle signals */
2637     if (PL_curinterp != aTHX)
2638         return -1;
2639 #endif
2640
2641     act.sa_handler = (void(*)(int))handler;
2642     sigemptyset(&act.sa_mask);
2643     act.sa_flags = 0;
2644 #ifdef SA_RESTART
2645     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2646         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2647 #endif
2648 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2649     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2650         act.sa_flags |= SA_NOCLDWAIT;
2651 #endif
2652     return sigaction(signo, &act, save);
2653 }
2654
2655 int
2656 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2657 {
2658     dVAR;
2659 #ifdef USE_ITHREADS
2660     /* only "parent" interpreter can diddle signals */
2661     if (PL_curinterp != aTHX)
2662         return -1;
2663 #endif
2664
2665     return sigaction(signo, save, (struct sigaction *)NULL);
2666 }
2667
2668 #else /* !HAS_SIGACTION */
2669
2670 Sighandler_t
2671 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2672 {
2673 #if defined(USE_ITHREADS) && !defined(WIN32)
2674     /* only "parent" interpreter can diddle signals */
2675     if (PL_curinterp != aTHX)
2676         return (Sighandler_t) SIG_ERR;
2677 #endif
2678
2679     return PerlProc_signal(signo, handler);
2680 }
2681
2682 static Signal_t
2683 sig_trap(int signo)
2684 {
2685     dVAR;
2686     PL_sig_trapped++;
2687 }
2688
2689 Sighandler_t
2690 Perl_rsignal_state(pTHX_ int signo)
2691 {
2692     dVAR;
2693     Sighandler_t oldsig;
2694
2695 #if defined(USE_ITHREADS) && !defined(WIN32)
2696     /* only "parent" interpreter can diddle signals */
2697     if (PL_curinterp != aTHX)
2698         return (Sighandler_t) SIG_ERR;
2699 #endif
2700
2701     PL_sig_trapped = 0;
2702     oldsig = PerlProc_signal(signo, sig_trap);
2703     PerlProc_signal(signo, oldsig);
2704     if (PL_sig_trapped)
2705         PerlProc_kill(PerlProc_getpid(), signo);
2706     return oldsig;
2707 }
2708
2709 int
2710 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2711 {
2712 #if defined(USE_ITHREADS) && !defined(WIN32)
2713     /* only "parent" interpreter can diddle signals */
2714     if (PL_curinterp != aTHX)
2715         return -1;
2716 #endif
2717     *save = PerlProc_signal(signo, handler);
2718     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2719 }
2720
2721 int
2722 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2723 {
2724 #if defined(USE_ITHREADS) && !defined(WIN32)
2725     /* only "parent" interpreter can diddle signals */
2726     if (PL_curinterp != aTHX)
2727         return -1;
2728 #endif
2729     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2730 }
2731
2732 #endif /* !HAS_SIGACTION */
2733 #endif /* !PERL_MICRO */
2734
2735     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2736 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
2737 I32
2738 Perl_my_pclose(pTHX_ PerlIO *ptr)
2739 {
2740     dVAR;
2741     int status;
2742     SV **svp;
2743     Pid_t pid;
2744     Pid_t pid2 = 0;
2745     bool close_failed;
2746     dSAVEDERRNO;
2747     const int fd = PerlIO_fileno(ptr);
2748
2749 #ifdef USE_PERLIO
2750     /* Find out whether the refcount is low enough for us to wait for the
2751        child proc without blocking. */
2752     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
2753 #else
2754     const bool should_wait = 1;
2755 #endif
2756
2757     svp = av_fetch(PL_fdpid,fd,TRUE);
2758     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2759     SvREFCNT_dec(*svp);
2760     *svp = &PL_sv_undef;
2761 #ifdef OS2
2762     if (pid == -1) {                    /* Opened by popen. */
2763         return my_syspclose(ptr);
2764     }
2765 #endif
2766     close_failed = (PerlIO_close(ptr) == EOF);
2767     SAVE_ERRNO;
2768     if (should_wait) do {
2769         pid2 = wait4pid(pid, &status, 0);
2770     } while (pid2 == -1 && errno == EINTR);
2771     if (close_failed) {
2772         RESTORE_ERRNO;
2773         return -1;
2774     }
2775     return(
2776       should_wait
2777        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
2778        : 0
2779     );
2780 }
2781 #else
2782 #if defined(__LIBCATAMOUNT__)
2783 I32
2784 Perl_my_pclose(pTHX_ PerlIO *ptr)
2785 {
2786     return -1;
2787 }
2788 #endif
2789 #endif /* !DOSISH */
2790
2791 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2792 I32
2793 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2794 {
2795     dVAR;
2796     I32 result = 0;
2797     PERL_ARGS_ASSERT_WAIT4PID;
2798     if (!pid)
2799         return -1;
2800 #ifdef PERL_USES_PL_PIDSTATUS
2801     {
2802         if (pid > 0) {
2803             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2804                pid, rather than a string form.  */
2805             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2806             if (svp && *svp != &PL_sv_undef) {
2807                 *statusp = SvIVX(*svp);
2808                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2809                                 G_DISCARD);
2810                 return pid;
2811             }
2812         }
2813         else {
2814             HE *entry;
2815
2816             hv_iterinit(PL_pidstatus);
2817             if ((entry = hv_iternext(PL_pidstatus))) {
2818                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2819                 I32 len;
2820                 const char * const spid = hv_iterkey(entry,&len);
2821
2822                 assert (len == sizeof(Pid_t));
2823                 memcpy((char *)&pid, spid, len);
2824                 *statusp = SvIVX(sv);
2825                 /* The hash iterator is currently on this entry, so simply
2826                    calling hv_delete would trigger the lazy delete, which on
2827                    aggregate does more work, beacuse next call to hv_iterinit()
2828                    would spot the flag, and have to call the delete routine,
2829                    while in the meantime any new entries can't re-use that
2830                    memory.  */
2831                 hv_iterinit(PL_pidstatus);
2832                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2833                 return pid;
2834             }
2835         }
2836     }
2837 #endif
2838 #ifdef HAS_WAITPID
2839 #  ifdef HAS_WAITPID_RUNTIME
2840     if (!HAS_WAITPID_RUNTIME)
2841         goto hard_way;
2842 #  endif
2843     result = PerlProc_waitpid(pid,statusp,flags);
2844     goto finish;
2845 #endif
2846 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2847     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2848     goto finish;
2849 #endif
2850 #ifdef PERL_USES_PL_PIDSTATUS
2851 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2852   hard_way:
2853 #endif
2854     {
2855         if (flags)
2856             Perl_croak(aTHX_ "Can't do waitpid with flags");
2857         else {
2858             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2859                 pidgone(result,*statusp);
2860             if (result < 0)
2861                 *statusp = -1;
2862         }
2863     }
2864 #endif
2865 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2866   finish:
2867 #endif
2868     if (result < 0 && errno == EINTR) {
2869         PERL_ASYNC_CHECK();
2870         errno = EINTR; /* reset in case a signal handler changed $! */
2871     }
2872     return result;
2873 }
2874 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2875
2876 #ifdef PERL_USES_PL_PIDSTATUS
2877 void
2878 S_pidgone(pTHX_ Pid_t pid, int status)
2879 {
2880     SV *sv;
2881
2882     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2883     SvUPGRADE(sv,SVt_IV);
2884     SvIV_set(sv, status);
2885     return;
2886 }
2887 #endif
2888
2889 #if defined(OS2)
2890 int pclose();
2891 #ifdef HAS_FORK
2892 int                                     /* Cannot prototype with I32
2893                                            in os2ish.h. */
2894 my_syspclose(PerlIO *ptr)
2895 #else
2896 I32
2897 Perl_my_pclose(pTHX_ PerlIO *ptr)
2898 #endif
2899 {
2900     /* Needs work for PerlIO ! */
2901     FILE * const f = PerlIO_findFILE(ptr);
2902     const I32 result = pclose(f);
2903     PerlIO_releaseFILE(ptr,f);
2904     return result;
2905 }
2906 #endif
2907
2908 #if defined(DJGPP)
2909 int djgpp_pclose();
2910 I32
2911 Perl_my_pclose(pTHX_ PerlIO *ptr)
2912 {
2913     /* Needs work for PerlIO ! */
2914     FILE * const f = PerlIO_findFILE(ptr);
2915     I32 result = djgpp_pclose(f);
2916     result = (result << 8) & 0xff00;
2917     PerlIO_releaseFILE(ptr,f);
2918     return result;
2919 }
2920 #endif
2921
2922 #define PERL_REPEATCPY_LINEAR 4
2923 void
2924 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
2925 {
2926     PERL_ARGS_ASSERT_REPEATCPY;
2927
2928     assert(len >= 0);
2929
2930     if (count < 0)
2931         Perl_croak_memory_wrap();
2932
2933     if (len == 1)
2934         memset(to, *from, count);
2935     else if (count) {
2936         char *p = to;
2937         IV items, linear, half;
2938
2939         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
2940         for (items = 0; items < linear; ++items) {
2941             const char *q = from;
2942             IV todo;
2943             for (todo = len; todo > 0; todo--)
2944                 *p++ = *q++;
2945         }
2946
2947         half = count / 2;
2948         while (items <= half) {
2949             IV size = items * len;
2950             memcpy(p, to, size);
2951             p     += size;
2952             items *= 2;
2953         }
2954
2955         if (count > items)
2956             memcpy(p, to, (count - items) * len);
2957     }
2958 }
2959
2960 #ifndef HAS_RENAME
2961 I32
2962 Perl_same_dirent(pTHX_ const char *a, const char *b)
2963 {
2964     char *fa = strrchr(a,'/');
2965     char *fb = strrchr(b,'/');
2966     Stat_t tmpstatbuf1;
2967     Stat_t tmpstatbuf2;
2968     SV * const tmpsv = sv_newmortal();
2969
2970     PERL_ARGS_ASSERT_SAME_DIRENT;
2971
2972     if (fa)
2973         fa++;
2974     else
2975         fa = a;
2976     if (fb)
2977         fb++;
2978     else
2979         fb = b;
2980     if (strNE(a,b))
2981         return FALSE;
2982     if (fa == a)
2983         sv_setpvs(tmpsv, ".");
2984     else
2985         sv_setpvn(tmpsv, a, fa - a);
2986     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
2987         return FALSE;
2988     if (fb == b)
2989         sv_setpvs(tmpsv, ".");
2990     else
2991         sv_setpvn(tmpsv, b, fb - b);
2992     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
2993         return FALSE;
2994     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2995            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2996 }
2997 #endif /* !HAS_RENAME */
2998
2999 char*
3000 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3001                  const char *const *const search_ext, I32 flags)
3002 {
3003     dVAR;
3004     const char *xfound = NULL;
3005     char *xfailed = NULL;
3006     char tmpbuf[MAXPATHLEN];
3007     char *s;
3008     I32 len = 0;
3009     int retval;
3010     char *bufend;
3011 #if defined(DOSISH) && !defined(OS2)
3012 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3013 #  define MAX_EXT_LEN 4
3014 #endif
3015 #ifdef OS2
3016 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3017 #  define MAX_EXT_LEN 4
3018 #endif
3019 #ifdef VMS
3020 #  define SEARCH_EXTS ".pl", ".com", NULL
3021 #  define MAX_EXT_LEN 4
3022 #endif
3023     /* additional extensions to try in each dir if scriptname not found */
3024 #ifdef SEARCH_EXTS
3025     static const char *const exts[] = { SEARCH_EXTS };
3026     const char *const *const ext = search_ext ? search_ext : exts;
3027     int extidx = 0, i = 0;
3028     const char *curext = NULL;
3029 #else
3030     PERL_UNUSED_ARG(search_ext);
3031 #  define MAX_EXT_LEN 0
3032 #endif
3033
3034     PERL_ARGS_ASSERT_FIND_SCRIPT;
3035
3036     /*
3037      * If dosearch is true and if scriptname does not contain path
3038      * delimiters, search the PATH for scriptname.
3039      *
3040      * If SEARCH_EXTS is also defined, will look for each
3041      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3042      * while searching the PATH.
3043      *
3044      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3045      * proceeds as follows:
3046      *   If DOSISH or VMSISH:
3047      *     + look for ./scriptname{,.foo,.bar}
3048      *     + search the PATH for scriptname{,.foo,.bar}
3049      *
3050      *   If !DOSISH:
3051      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3052      *       this will not look in '.' if it's not in the PATH)
3053      */
3054     tmpbuf[0] = '\0';
3055
3056 #ifdef VMS
3057 #  ifdef ALWAYS_DEFTYPES
3058     len = strlen(scriptname);
3059     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3060         int idx = 0, deftypes = 1;
3061         bool seen_dot = 1;
3062
3063         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3064 #  else
3065     if (dosearch) {
3066         int idx = 0, deftypes = 1;
3067         bool seen_dot = 1;
3068
3069         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3070 #  endif
3071         /* The first time through, just add SEARCH_EXTS to whatever we
3072          * already have, so we can check for default file types. */
3073         while (deftypes ||
3074                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3075         {
3076             if (deftypes) {
3077                 deftypes = 0;
3078                 *tmpbuf = '\0';
3079             }
3080             if ((strlen(tmpbuf) + strlen(scriptname)
3081                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3082                 continue;       /* don't search dir with too-long name */
3083             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3084 #else  /* !VMS */
3085
3086 #ifdef DOSISH
3087     if (strEQ(scriptname, "-"))
3088         dosearch = 0;
3089     if (dosearch) {             /* Look in '.' first. */
3090         const char *cur = scriptname;
3091 #ifdef SEARCH_EXTS
3092         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3093             while (ext[i])
3094                 if (strEQ(ext[i++],curext)) {
3095                     extidx = -1;                /* already has an ext */
3096                     break;
3097                 }
3098         do {
3099 #endif
3100             DEBUG_p(PerlIO_printf(Perl_debug_log,
3101                                   "Looking for %s\n",cur));
3102             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3103                 && !S_ISDIR(PL_statbuf.st_mode)) {
3104                 dosearch = 0;
3105                 scriptname = cur;
3106 #ifdef SEARCH_EXTS
3107                 break;
3108 #endif
3109             }
3110 #ifdef SEARCH_EXTS
3111             if (cur == scriptname) {
3112                 len = strlen(scriptname);
3113                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3114                     break;
3115                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3116                 cur = tmpbuf;
3117             }
3118         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3119                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3120 #endif
3121     }
3122 #endif
3123
3124     if (dosearch && !strchr(scriptname, '/')
3125 #ifdef DOSISH
3126                  && !strchr(scriptname, '\\')
3127 #endif
3128                  && (s = PerlEnv_getenv("PATH")))
3129     {
3130         bool seen_dot = 0;
3131
3132         bufend = s + strlen(s);
3133         while (s < bufend) {
3134 #  ifdef DOSISH
3135             for (len = 0; *s
3136                     && *s != ';'; len++, s++) {
3137                 if (len < sizeof tmpbuf)
3138                     tmpbuf[len] = *s;
3139             }
3140             if (len < sizeof tmpbuf)
3141                 tmpbuf[len] = '\0';
3142 #  else
3143             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3144                         ':',
3145                         &len);
3146 #  endif
3147             if (s < bufend)
3148                 s++;
3149             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3150                 continue;       /* don't search dir with too-long name */
3151             if (len
3152 #  ifdef DOSISH
3153                 && tmpbuf[len - 1] != '/'
3154                 && tmpbuf[len - 1] != '\\'
3155 #  endif
3156                )
3157                 tmpbuf[len++] = '/';
3158             if (len == 2 && tmpbuf[0] == '.')
3159                 seen_dot = 1;
3160             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3161 #endif  /* !VMS */
3162
3163 #ifdef SEARCH_EXTS
3164             len = strlen(tmpbuf);
3165             if (extidx > 0)     /* reset after previous loop */
3166                 extidx = 0;
3167             do {
3168 #endif
3169                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3170                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3171                 if (S_ISDIR(PL_statbuf.st_mode)) {
3172                     retval = -1;
3173                 }
3174 #ifdef SEARCH_EXTS
3175             } while (  retval < 0               /* not there */
3176                     && extidx>=0 && ext[extidx] /* try an extension? */
3177                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3178                 );
3179 #endif
3180             if (retval < 0)
3181                 continue;
3182             if (S_ISREG(PL_statbuf.st_mode)
3183                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3184 #if !defined(DOSISH)
3185                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3186 #endif
3187                 )
3188             {
3189                 xfound = tmpbuf;                /* bingo! */
3190                 break;
3191             }
3192             if (!xfailed)
3193                 xfailed = savepv(tmpbuf);
3194         }
3195 #ifndef DOSISH
3196         if (!xfound && !seen_dot && !xfailed &&
3197             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3198              || S_ISDIR(PL_statbuf.st_mode)))
3199 #endif
3200             seen_dot = 1;                       /* Disable message. */
3201         if (!xfound) {
3202             if (flags & 1) {                    /* do or die? */
3203                 /* diag_listed_as: Can't execute %s */
3204                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3205                       (xfailed ? "execute" : "find"),
3206                       (xfailed ? xfailed : scriptname),
3207                       (xfailed ? "" : " on PATH"),
3208                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3209             }
3210             scriptname = NULL;
3211         }
3212         Safefree(xfailed);
3213         scriptname = xfound;
3214     }
3215     return (scriptname ? savepv(scriptname) : NULL);
3216 }
3217
3218 #ifndef PERL_GET_CONTEXT_DEFINED
3219
3220 void *
3221 Perl_get_context(void)
3222 {
3223     dVAR;
3224 #if defined(USE_ITHREADS)
3225 #  ifdef OLD_PTHREADS_API
3226     pthread_addr_t t;
3227     int error = pthread_getspecific(PL_thr_key, &t)
3228     if (error)
3229         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3230     return (void*)t;
3231 #  else
3232 #    ifdef I_MACH_CTHREADS
3233     return (void*)cthread_data(cthread_self());
3234 #    else
3235     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3236 #    endif
3237 #  endif
3238 #else
3239     return (void*)NULL;
3240 #endif
3241 }
3242
3243 void
3244 Perl_set_context(void *t)
3245 {
3246     dVAR;
3247     PERL_ARGS_ASSERT_SET_CONTEXT;
3248 #if defined(USE_ITHREADS)
3249 #  ifdef I_MACH_CTHREADS
3250     cthread_set_data(cthread_self(), t);
3251 #  else
3252     {
3253         const int error = pthread_setspecific(PL_thr_key, t);
3254         if (error)
3255             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3256     }
3257 #  endif
3258 #else
3259     PERL_UNUSED_ARG(t);
3260 #endif
3261 }
3262
3263 #endif /* !PERL_GET_CONTEXT_DEFINED */
3264
3265 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3266 struct perl_vars *
3267 Perl_GetVars(pTHX)
3268 {
3269  return &PL_Vars;
3270 }
3271 #endif
3272
3273 char **
3274 Perl_get_op_names(pTHX)
3275 {
3276     PERL_UNUSED_CONTEXT;
3277     return (char **)PL_op_name;
3278 }
3279
3280 char **
3281 Perl_get_op_descs(pTHX)
3282 {
3283     PERL_UNUSED_CONTEXT;
3284     return (char **)PL_op_desc;
3285 }
3286
3287 const char *
3288 Perl_get_no_modify(pTHX)
3289 {
3290     PERL_UNUSED_CONTEXT;
3291     return PL_no_modify;
3292 }
3293
3294 U32 *
3295 Perl_get_opargs(pTHX)
3296 {
3297     PERL_UNUSED_CONTEXT;
3298     return (U32 *)PL_opargs;
3299 }
3300
3301 PPADDR_t*
3302 Perl_get_ppaddr(pTHX)
3303 {
3304     dVAR;
3305     PERL_UNUSED_CONTEXT;
3306     return (PPADDR_t*)PL_ppaddr;
3307 }
3308
3309 #ifndef HAS_GETENV_LEN
3310 char *
3311 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3312 {
3313     char * const env_trans = PerlEnv_getenv(env_elem);
3314     PERL_UNUSED_CONTEXT;
3315     PERL_ARGS_ASSERT_GETENV_LEN;
3316     if (env_trans)
3317         *len = strlen(env_trans);
3318     return env_trans;
3319 }
3320 #endif
3321
3322
3323 MGVTBL*
3324 Perl_get_vtbl(pTHX_ int vtbl_id)
3325 {
3326     PERL_UNUSED_CONTEXT;
3327
3328     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3329         ? NULL : PL_magic_vtables + vtbl_id;
3330 }
3331
3332 I32
3333 Perl_my_fflush_all(pTHX)
3334 {
3335 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3336     return PerlIO_flush(NULL);
3337 #else
3338 # if defined(HAS__FWALK)
3339     extern int fflush(FILE *);
3340     /* undocumented, unprototyped, but very useful BSDism */
3341     extern void _fwalk(int (*)(FILE *));
3342     _fwalk(&fflush);
3343     return 0;
3344 # else
3345 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3346     long open_max = -1;
3347 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3348     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3349 #   else
3350 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3351     open_max = sysconf(_SC_OPEN_MAX);
3352 #     else
3353 #      ifdef FOPEN_MAX
3354     open_max = FOPEN_MAX;
3355 #      else
3356 #       ifdef OPEN_MAX
3357     open_max = OPEN_MAX;
3358 #       else
3359 #        ifdef _NFILE
3360     open_max = _NFILE;
3361 #        endif
3362 #       endif
3363 #      endif
3364 #     endif
3365 #    endif
3366     if (open_max > 0) {
3367       long i;
3368       for (i = 0; i < open_max; i++)
3369             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3370                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3371                 STDIO_STREAM_ARRAY[i]._flag)
3372                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3373       return 0;
3374     }
3375 #  endif
3376     SETERRNO(EBADF,RMS_IFI);
3377     return EOF;
3378 # endif
3379 #endif
3380 }
3381
3382 void
3383 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3384 {
3385     if (ckWARN(WARN_IO)) {
3386         HEK * const name
3387            = gv && (isGV_with_GP(gv))
3388                 ? GvENAME_HEK((gv))
3389                 : NULL;
3390         const char * const direction = have == '>' ? "out" : "in";
3391
3392         if (name && HEK_LEN(name))
3393             Perl_warner(aTHX_ packWARN(WARN_IO),
3394                         "Filehandle %"HEKf" opened only for %sput",
3395                         name, direction);
3396         else
3397             Perl_warner(aTHX_ packWARN(WARN_IO),
3398                         "Filehandle opened only for %sput", direction);
3399     }
3400 }
3401
3402 void
3403 Perl_report_evil_fh(pTHX_ const GV *gv)
3404 {
3405     const IO *io = gv ? GvIO(gv) : NULL;
3406     const PERL_BITFIELD16 op = PL_op->op_type;
3407     const char *vile;
3408     I32 warn_type;
3409
3410     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3411         vile = "closed";
3412         warn_type = WARN_CLOSED;
3413     }
3414     else {
3415         vile = "unopened";
3416         warn_type = WARN_UNOPENED;
3417     }
3418
3419     if (ckWARN(warn_type)) {
3420         SV * const name
3421             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3422                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3423         const char * const pars =
3424             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3425         const char * const func =
3426             (const char *)
3427             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3428              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3429              PL_op_desc[op]);
3430         const char * const type =
3431             (const char *)
3432             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3433              ? "socket" : "filehandle");
3434         const bool have_name = name && SvCUR(name);
3435         Perl_warner(aTHX_ packWARN(warn_type),
3436                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3437                     have_name ? " " : "",
3438                     SVfARG(have_name ? name : &PL_sv_no));
3439         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3440                 Perl_warner(
3441                             aTHX_ packWARN(warn_type),
3442                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3443                         func, pars, have_name ? " " : "",
3444                         SVfARG(have_name ? name : &PL_sv_no)
3445                             );
3446     }
3447 }
3448
3449 /* To workaround core dumps from the uninitialised tm_zone we get the
3450  * system to give us a reasonable struct to copy.  This fix means that
3451  * strftime uses the tm_zone and tm_gmtoff values returned by
3452  * localtime(time()). That should give the desired result most of the
3453  * time. But probably not always!
3454  *
3455  * This does not address tzname aspects of NETaa14816.
3456  *
3457  */
3458
3459 #ifdef HAS_GNULIBC
3460 # ifndef STRUCT_TM_HASZONE
3461 #    define STRUCT_TM_HASZONE
3462 # endif
3463 #endif
3464
3465 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3466 # ifndef HAS_TM_TM_ZONE
3467 #    define HAS_TM_TM_ZONE
3468 # endif
3469 #endif
3470
3471 void
3472 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3473 {
3474 #ifdef HAS_TM_TM_ZONE
3475     Time_t now;
3476     const struct tm* my_tm;
3477     PERL_ARGS_ASSERT_INIT_TM;
3478     (void)time(&now);
3479     my_tm = localtime(&now);
3480     if (my_tm)
3481         Copy(my_tm, ptm, 1, struct tm);
3482 #else
3483     PERL_ARGS_ASSERT_INIT_TM;
3484     PERL_UNUSED_ARG(ptm);
3485 #endif
3486 }
3487
3488 /*
3489  * mini_mktime - normalise struct tm values without the localtime()
3490  * semantics (and overhead) of mktime().
3491  */
3492 void
3493 Perl_mini_mktime(pTHX_ struct tm *ptm)
3494 {
3495     int yearday;
3496     int secs;
3497     int month, mday, year, jday;
3498     int odd_cent, odd_year;
3499     PERL_UNUSED_CONTEXT;
3500
3501     PERL_ARGS_ASSERT_MINI_MKTIME;
3502
3503 #define DAYS_PER_YEAR   365
3504 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3505 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3506 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3507 #define SECS_PER_HOUR   (60*60)
3508 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3509 /* parentheses deliberately absent on these two, otherwise they don't work */
3510 #define MONTH_TO_DAYS   153/5
3511 #define DAYS_TO_MONTH   5/153
3512 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3513 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3514 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3515 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3516
3517 /*
3518  * Year/day algorithm notes:
3519  *
3520  * With a suitable offset for numeric value of the month, one can find
3521  * an offset into the year by considering months to have 30.6 (153/5) days,
3522  * using integer arithmetic (i.e., with truncation).  To avoid too much
3523  * messing about with leap days, we consider January and February to be
3524  * the 13th and 14th month of the previous year.  After that transformation,
3525  * we need the month index we use to be high by 1 from 'normal human' usage,
3526  * so the month index values we use run from 4 through 15.
3527  *
3528  * Given that, and the rules for the Gregorian calendar (leap years are those
3529  * divisible by 4 unless also divisible by 100, when they must be divisible
3530  * by 400 instead), we can simply calculate the number of days since some
3531  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3532  * the days we derive from our month index, and adding in the day of the
3533  * month.  The value used here is not adjusted for the actual origin which
3534  * it normally would use (1 January A.D. 1), since we're not exposing it.
3535  * We're only building the value so we can turn around and get the
3536  * normalised values for the year, month, day-of-month, and day-of-year.
3537  *
3538  * For going backward, we need to bias the value we're using so that we find
3539  * the right year value.  (Basically, we don't want the contribution of
3540  * March 1st to the number to apply while deriving the year).  Having done
3541  * that, we 'count up' the contribution to the year number by accounting for
3542  * full quadracenturies (400-year periods) with their extra leap days, plus
3543  * the contribution from full centuries (to avoid counting in the lost leap
3544  * days), plus the contribution from full quad-years (to count in the normal
3545  * leap days), plus the leftover contribution from any non-leap years.
3546  * At this point, if we were working with an actual leap day, we'll have 0
3547  * days left over.  This is also true for March 1st, however.  So, we have
3548  * to special-case that result, and (earlier) keep track of the 'odd'
3549  * century and year contributions.  If we got 4 extra centuries in a qcent,
3550  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3551  * Otherwise, we add back in the earlier bias we removed (the 123 from
3552  * figuring in March 1st), find the month index (integer division by 30.6),
3553  * and the remainder is the day-of-month.  We then have to convert back to
3554  * 'real' months (including fixing January and February from being 14/15 in
3555  * the previous year to being in the proper year).  After that, to get
3556  * tm_yday, we work with the normalised year and get a new yearday value for
3557  * January 1st, which we subtract from the yearday value we had earlier,
3558  * representing the date we've re-built.  This is done from January 1
3559  * because tm_yday is 0-origin.
3560  *
3561  * Since POSIX time routines are only guaranteed to work for times since the
3562  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3563  * applies Gregorian calendar rules even to dates before the 16th century
3564  * doesn't bother me.  Besides, you'd need cultural context for a given
3565  * date to know whether it was Julian or Gregorian calendar, and that's
3566  * outside the scope for this routine.  Since we convert back based on the
3567  * same rules we used to build the yearday, you'll only get strange results
3568  * for input which needed normalising, or for the 'odd' century years which
3569  * were leap years in the Julian calendar but not in the Gregorian one.
3570  * I can live with that.
3571  *
3572  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3573  * that's still outside the scope for POSIX time manipulation, so I don't
3574  * care.
3575  */
3576
3577     year = 1900 + ptm->tm_year;
3578     month = ptm->tm_mon;
3579     mday = ptm->tm_mday;
3580     jday = 0;
3581     if (month >= 2)
3582         month+=2;
3583     else
3584         month+=14, year--;
3585     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3586     yearday += month*MONTH_TO_DAYS + mday + jday;
3587     /*
3588      * Note that we don't know when leap-seconds were or will be,
3589      * so we have to trust the user if we get something which looks
3590      * like a sensible leap-second.  Wild values for seconds will
3591      * be rationalised, however.
3592      */
3593     if ((unsigned) ptm->tm_sec <= 60) {
3594         secs = 0;
3595     }
3596     else {
3597         secs = ptm->tm_sec;
3598         ptm->tm_sec = 0;
3599     }
3600     secs += 60 * ptm->tm_min;
3601     secs += SECS_PER_HOUR * ptm->tm_hour;
3602     if (secs < 0) {
3603         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3604             /* got negative remainder, but need positive time */
3605             /* back off an extra day to compensate */
3606             yearday += (secs/SECS_PER_DAY)-1;
3607             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3608         }
3609         else {
3610             yearday += (secs/SECS_PER_DAY);
3611             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3612         }
3613     }
3614     else if (secs >= SECS_PER_DAY) {
3615         yearday += (secs/SECS_PER_DAY);
3616         secs %= SECS_PER_DAY;
3617     }
3618     ptm->tm_hour = secs/SECS_PER_HOUR;
3619     secs %= SECS_PER_HOUR;
3620     ptm->tm_min = secs/60;
3621     secs %= 60;
3622     ptm->tm_sec += secs;
3623     /* done with time of day effects */
3624     /*
3625      * The algorithm for yearday has (so far) left it high by 428.
3626      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3627      * bias it by 123 while trying to figure out what year it
3628      * really represents.  Even with this tweak, the reverse
3629      * translation fails for years before A.D. 0001.
3630      * It would still fail for Feb 29, but we catch that one below.
3631      */
3632     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3633     yearday -= YEAR_ADJUST;
3634     year = (yearday / DAYS_PER_QCENT) * 400;
3635     yearday %= DAYS_PER_QCENT;
3636     odd_cent = yearday / DAYS_PER_CENT;
3637     year += odd_cent * 100;
3638     yearday %= DAYS_PER_CENT;
3639     year += (yearday / DAYS_PER_QYEAR) * 4;
3640     yearday %= DAYS_PER_QYEAR;
3641     odd_year = yearday / DAYS_PER_YEAR;
3642     year += odd_year;
3643     yearday %= DAYS_PER_YEAR;
3644     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3645         month = 1;
3646         yearday = 29;
3647     }
3648     else {
3649         yearday += YEAR_ADJUST; /* recover March 1st crock */
3650         month = yearday*DAYS_TO_MONTH;
3651         yearday -= month*MONTH_TO_DAYS;
3652         /* recover other leap-year adjustment */
3653         if (month > 13) {
3654             month-=14;
3655             year++;
3656         }
3657         else {
3658             month-=2;
3659         }
3660     }
3661     ptm->tm_year = year - 1900;
3662     if (yearday) {
3663       ptm->tm_mday = yearday;
3664       ptm->tm_mon = month;
3665     }
3666     else {
3667       ptm->tm_mday = 31;
3668       ptm->tm_mon = month - 1;
3669     }
3670     /* re-build yearday based on Jan 1 to get tm_yday */
3671     year--;
3672     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3673     yearday += 14*MONTH_TO_DAYS + 1;
3674     ptm->tm_yday = jday - yearday;
3675     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3676 }
3677
3678 char *
3679 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)
3680 {
3681 #ifdef HAS_STRFTIME
3682   char *buf;
3683   int buflen;
3684   struct tm mytm;
3685   int len;
3686
3687   PERL_ARGS_ASSERT_MY_STRFTIME;
3688
3689   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3690   mytm.tm_sec = sec;
3691   mytm.tm_min = min;
3692   mytm.tm_hour = hour;
3693   mytm.tm_mday = mday;
3694   mytm.tm_mon = mon;
3695   mytm.tm_year = year;
3696   mytm.tm_wday = wday;
3697   mytm.tm_yday = yday;
3698   mytm.tm_isdst = isdst;
3699   mini_mktime(&mytm);
3700   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3701 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3702   STMT_START {
3703     struct tm mytm2;
3704     mytm2 = mytm;
3705     mktime(&mytm2);
3706 #ifdef HAS_TM_TM_GMTOFF
3707     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3708 #endif
3709 #ifdef HAS_TM_TM_ZONE
3710     mytm.tm_zone = mytm2.tm_zone;
3711 #endif
3712   } STMT_END;
3713 #endif
3714   buflen = 64;
3715   Newx(buf, buflen, char);
3716   len = strftime(buf, buflen, fmt, &mytm);
3717   /*
3718   ** The following is needed to handle to the situation where
3719   ** tmpbuf overflows.  Basically we want to allocate a buffer
3720   ** and try repeatedly.  The reason why it is so complicated
3721   ** is that getting a return value of 0 from strftime can indicate
3722   ** one of the following:
3723   ** 1. buffer overflowed,
3724   ** 2. illegal conversion specifier, or
3725   ** 3. the format string specifies nothing to be returned(not
3726   **      an error).  This could be because format is an empty string
3727   **    or it specifies %p that yields an empty string in some locale.
3728   ** If there is a better way to make it portable, go ahead by
3729   ** all means.
3730   */
3731   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3732     return buf;
3733   else {
3734     /* Possibly buf overflowed - try again with a bigger buf */
3735     const int fmtlen = strlen(fmt);
3736     int bufsize = fmtlen + buflen;
3737
3738     Renew(buf, bufsize, char);
3739     while (buf) {
3740       buflen = strftime(buf, bufsize, fmt, &mytm);
3741       if (buflen > 0 && buflen < bufsize)
3742         break;
3743       /* heuristic to prevent out-of-memory errors */
3744       if (bufsize > 100*fmtlen) {
3745         Safefree(buf);
3746         buf = NULL;
3747         break;
3748       }
3749       bufsize *= 2;
3750       Renew(buf, bufsize, char);
3751     }
3752     return buf;
3753   }
3754 #else
3755   Perl_croak(aTHX_ "panic: no strftime");
3756   return NULL;
3757 #endif
3758 }
3759
3760
3761 #define SV_CWD_RETURN_UNDEF \
3762 sv_setsv(sv, &PL_sv_undef); \
3763 return FALSE
3764
3765 #define SV_CWD_ISDOT(dp) \
3766     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3767         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3768
3769 /*
3770 =head1 Miscellaneous Functions
3771
3772 =for apidoc getcwd_sv
3773
3774 Fill the sv with current working directory
3775
3776 =cut
3777 */
3778
3779 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3780  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3781  * getcwd(3) if available
3782  * Comments from the orignal:
3783  *     This is a faster version of getcwd.  It's also more dangerous
3784  *     because you might chdir out of a directory that you can't chdir
3785  *     back into. */
3786
3787 int
3788 Perl_getcwd_sv(pTHX_ SV *sv)
3789 {
3790 #ifndef PERL_MICRO
3791     dVAR;
3792 #ifndef INCOMPLETE_TAINTS
3793     SvTAINTED_on(sv);
3794 #endif
3795
3796     PERL_ARGS_ASSERT_GETCWD_SV;
3797
3798 #ifdef HAS_GETCWD
3799     {
3800         char buf[MAXPATHLEN];
3801
3802         /* Some getcwd()s automatically allocate a buffer of the given
3803          * size from the heap if they are given a NULL buffer pointer.
3804          * The problem is that this behaviour is not portable. */
3805         if (getcwd(buf, sizeof(buf) - 1)) {
3806             sv_setpv(sv, buf);
3807             return TRUE;
3808         }
3809         else {
3810             sv_setsv(sv, &PL_sv_undef);
3811             return FALSE;
3812         }
3813     }
3814
3815 #else
3816
3817     Stat_t statbuf;
3818     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3819     int pathlen=0;
3820     Direntry_t *dp;
3821
3822     SvUPGRADE(sv, SVt_PV);
3823
3824     if (PerlLIO_lstat(".", &statbuf) < 0) {
3825         SV_CWD_RETURN_UNDEF;
3826     }
3827
3828     orig_cdev = statbuf.st_dev;
3829     orig_cino = statbuf.st_ino;
3830     cdev = orig_cdev;
3831     cino = orig_cino;
3832
3833     for (;;) {
3834         DIR *dir;
3835         int namelen;
3836         odev = cdev;
3837         oino = cino;
3838
3839         if (PerlDir_chdir("..") < 0) {
3840             SV_CWD_RETURN_UNDEF;
3841         }
3842         if (PerlLIO_stat(".", &statbuf) < 0) {
3843             SV_CWD_RETURN_UNDEF;
3844         }
3845
3846         cdev = statbuf.st_dev;
3847         cino = statbuf.st_ino;
3848
3849         if (odev == cdev && oino == cino) {
3850             break;
3851         }
3852         if (!(dir = PerlDir_open("."))) {
3853             SV_CWD_RETURN_UNDEF;
3854         }
3855
3856         while ((dp = PerlDir_read(dir)) != NULL) {
3857 #ifdef DIRNAMLEN
3858             namelen = dp->d_namlen;
3859 #else
3860             namelen = strlen(dp->d_name);
3861 #endif
3862             /* skip . and .. */
3863             if (SV_CWD_ISDOT(dp)) {
3864                 continue;
3865             }
3866
3867             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3868                 SV_CWD_RETURN_UNDEF;
3869             }
3870
3871             tdev = statbuf.st_dev;
3872             tino = statbuf.st_ino;
3873             if (tino == oino && tdev == odev) {
3874                 break;
3875             }
3876         }
3877
3878         if (!dp) {
3879             SV_CWD_RETURN_UNDEF;
3880         }
3881
3882         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3883             SV_CWD_RETURN_UNDEF;
3884         }
3885
3886         SvGROW(sv, pathlen + namelen + 1);
3887
3888         if (pathlen) {
3889             /* shift down */
3890             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3891         }
3892
3893         /* prepend current directory to the front */
3894         *SvPVX(sv) = '/';
3895         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3896         pathlen += (namelen + 1);
3897
3898 #ifdef VOID_CLOSEDIR
3899         PerlDir_close(dir);
3900 #else
3901         if (PerlDir_close(dir) < 0) {
3902             SV_CWD_RETURN_UNDEF;
3903         }
3904 #endif
3905     }
3906
3907     if (pathlen) {
3908         SvCUR_set(sv, pathlen);
3909         *SvEND(sv) = '\0';
3910         SvPOK_only(sv);
3911
3912         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3913             SV_CWD_RETURN_UNDEF;
3914         }
3915     }
3916     if (PerlLIO_stat(".", &statbuf) < 0) {
3917         SV_CWD_RETURN_UNDEF;
3918     }
3919
3920     cdev = statbuf.st_dev;
3921     cino = statbuf.st_ino;
3922
3923     if (cdev != orig_cdev || cino != orig_cino) {
3924         Perl_croak(aTHX_ "Unstable directory path, "
3925                    "current directory changed unexpectedly");
3926     }
3927
3928     return TRUE;
3929 #endif
3930
3931 #else
3932     return FALSE;
3933 #endif
3934 }
3935
3936 #define VERSION_MAX 0x7FFFFFFF
3937
3938 /*
3939 =for apidoc prescan_version
3940
3941 Validate that a given string can be parsed as a version object, but doesn't
3942 actually perform the parsing.  Can use either strict or lax validation rules.
3943 Can optionally set a number of hint variables to save the parsing code
3944 some time when tokenizing.
3945
3946 =cut
3947 */
3948 const char *
3949 Perl_prescan_version(pTHX_ const char *s, bool strict,
3950                      const char **errstr,
3951                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
3952     bool qv = (sqv ? *sqv : FALSE);
3953     int width = 3;
3954     int saw_decimal = 0;
3955     bool alpha = FALSE;
3956     const char *d = s;
3957
3958     PERL_ARGS_ASSERT_PRESCAN_VERSION;
3959
3960     if (qv && isDIGIT(*d))
3961         goto dotted_decimal_version;
3962
3963     if (*d == 'v') { /* explicit v-string */
3964         d++;
3965         if (isDIGIT(*d)) {
3966             qv = TRUE;
3967         }
3968         else { /* degenerate v-string */
3969             /* requires v1.2.3 */
3970             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3971         }
3972
3973 dotted_decimal_version:
3974         if (strict && d[0] == '0' && isDIGIT(d[1])) {
3975             /* no leading zeros allowed */
3976             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
3977         }
3978
3979         while (isDIGIT(*d))     /* integer part */
3980             d++;
3981
3982         if (*d == '.')
3983         {
3984             saw_decimal++;
3985             d++;                /* decimal point */
3986         }
3987         else
3988         {
3989             if (strict) {
3990                 /* require v1.2.3 */
3991                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
3992             }
3993             else {
3994                 goto version_prescan_finish;
3995             }
3996         }
3997
3998         {
3999             int i = 0;
4000             int j = 0;
4001             while (isDIGIT(*d)) {       /* just keep reading */
4002                 i++;
4003                 while (isDIGIT(*d)) {
4004                     d++; j++;
4005                     /* maximum 3 digits between decimal */
4006                     if (strict && j > 3) {
4007                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4008                     }
4009                 }
4010                 if (*d == '_') {
4011                     if (strict) {
4012                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4013                     }
4014                     if ( alpha ) {
4015                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4016                     }
4017                     d++;
4018                     alpha = TRUE;
4019                 }
4020                 else if (*d == '.') {
4021                     if (alpha) {
4022                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4023                     }
4024                     saw_decimal++;
4025                     d++;
4026                 }
4027                 else if (!isDIGIT(*d)) {
4028                     break;
4029                 }
4030                 j = 0;
4031             }
4032
4033             if (strict && i < 2) {
4034                 /* requires v1.2.3 */
4035                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4036             }
4037         }
4038     }                                   /* end if dotted-decimal */
4039     else
4040     {                                   /* decimal versions */
4041         int j = 0;                      /* may need this later */
4042         /* special strict case for leading '.' or '0' */
4043         if (strict) {
4044             if (*d == '.') {
4045                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4046             }
4047             if (*d == '0' && isDIGIT(d[1])) {
4048                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4049             }
4050         }
4051
4052         /* and we never support negative versions */
4053         if ( *d == '-') {
4054             BADVERSION(s,errstr,"Invalid version format (negative version number)");
4055         }
4056
4057         /* consume all of the integer part */
4058         while (isDIGIT(*d))
4059             d++;
4060
4061         /* look for a fractional part */
4062         if (*d == '.') {
4063             /* we found it, so consume it */
4064             saw_decimal++;
4065             d++;
4066         }
4067         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4068             if ( d == s ) {
4069                 /* found nothing */
4070                 BADVERSION(s,errstr,"Invalid version format (version required)");
4071             }
4072             /* found just an integer */
4073             goto version_prescan_finish;
4074         }
4075         else if ( d == s ) {
4076             /* didn't find either integer or period */
4077             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4078         }
4079         else if (*d == '_') {
4080             /* underscore can't come after integer part */
4081             if (strict) {
4082                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4083             }
4084             else if (isDIGIT(d[1])) {
4085                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4086             }
4087             else {
4088                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4089             }
4090         }
4091         else {
4092             /* anything else after integer part is just invalid data */
4093             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4094         }
4095
4096         /* scan the fractional part after the decimal point*/
4097
4098         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4099                 /* strict or lax-but-not-the-end */
4100                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4101         }
4102
4103         while (isDIGIT(*d)) {
4104             d++; j++;
4105             if (*d == '.' && isDIGIT(d[-1])) {
4106                 if (alpha) {
4107                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4108                 }
4109                 if (strict) {
4110                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4111                 }
4112                 d = (char *)s;          /* start all over again */
4113                 qv = TRUE;
4114                 goto dotted_decimal_version;
4115             }
4116             if (*d == '_') {
4117                 if (strict) {
4118                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4119                 }
4120                 if ( alpha ) {
4121                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4122                 }
4123                 if ( ! isDIGIT(d[1]) ) {
4124                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4125                 }
4126                 width = j;
4127                 d++;
4128                 alpha = TRUE;
4129             }
4130         }
4131     }
4132
4133 version_prescan_finish:
4134     while (isSPACE(*d))
4135         d++;
4136
4137     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4138         /* trailing non-numeric data */
4139         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4140     }
4141
4142     if (sqv)
4143         *sqv = qv;
4144     if (swidth)
4145         *swidth = width;
4146     if (ssaw_decimal)
4147         *ssaw_decimal = saw_decimal;
4148     if (salpha)
4149         *salpha = alpha;
4150     return d;
4151 }
4152
4153 /*
4154 =for apidoc scan_version
4155
4156 Returns a pointer to the next character after the parsed
4157 version string, as well as upgrading the passed in SV to
4158 an RV.
4159
4160 Function must be called with an already existing SV like
4161
4162     sv = newSV(0);
4163     s = scan_version(s, SV *sv, bool qv);
4164
4165 Performs some preprocessing to the string to ensure that
4166 it has the correct characteristics of a version.  Flags the
4167 object if it contains an underscore (which denotes this
4168 is an alpha version).  The boolean qv denotes that the version
4169 should be interpreted as if it had multiple decimals, even if
4170 it doesn't.
4171
4172 =cut
4173 */
4174
4175 const char *
4176 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4177 {
4178     const char *start = s;
4179     const char *pos;
4180     const char *last;
4181     const char *errstr = NULL;
4182     int saw_decimal = 0;
4183     int width = 3;
4184     bool alpha = FALSE;
4185     bool vinf = FALSE;
4186     AV * av;
4187     SV * hv;
4188
4189     PERL_ARGS_ASSERT_SCAN_VERSION;
4190
4191     while (isSPACE(*s)) /* leading whitespace is OK */
4192         s++;
4193
4194     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4195     if (errstr) {
4196         /* "undef" is a special case and not an error */
4197         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4198             Safefree(start);
4199             Perl_croak(aTHX_ "%s", errstr);
4200         }
4201     }
4202
4203     start = s;
4204     if (*s == 'v')
4205         s++;
4206     pos = s;
4207
4208     /* Now that we are through the prescan, start creating the object */
4209     av = newAV();
4210     hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4211     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4212
4213 #ifndef NODEFAULT_SHAREKEYS
4214     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4215 #endif
4216
4217     if ( qv )
4218         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4219     if ( alpha )
4220         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4221     if ( !qv && width < 3 )
4222         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4223
4224     while (isDIGIT(*pos))
4225         pos++;
4226     if (!isALPHA(*pos)) {
4227         I32 rev;
4228
4229         for (;;) {
4230             rev = 0;
4231             {
4232                 /* this is atoi() that delimits on underscores */
4233                 const char *end = pos;
4234                 I32 mult = 1;
4235                 I32 orev;
4236
4237                 /* the following if() will only be true after the decimal
4238                  * point of a version originally created with a bare
4239                  * floating point number, i.e. not quoted in any way
4240                  */
4241                 if ( !qv && s > start && saw_decimal == 1 ) {
4242                     mult *= 100;
4243                     while ( s < end ) {
4244                         orev = rev;
4245                         rev += (*s - '0') * mult;
4246                         mult /= 10;
4247                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4248                             || (PERL_ABS(rev) > VERSION_MAX )) {
4249                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4250                                            "Integer overflow in version %d",VERSION_MAX);
4251                             s = end - 1;
4252                             rev = VERSION_MAX;
4253                             vinf = 1;
4254                         }
4255                         s++;
4256                         if ( *s == '_' )
4257                             s++;
4258                     }
4259                 }
4260                 else {
4261                     while (--end >= s) {
4262                         orev = rev;
4263                         rev += (*end - '0') * mult;
4264                         mult *= 10;
4265                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4266                             || (PERL_ABS(rev) > VERSION_MAX )) {
4267                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4268                                            "Integer overflow in version");
4269                             end = s - 1;
4270                             rev = VERSION_MAX;
4271                             vinf = 1;
4272                         }
4273                     }
4274                 }
4275             }
4276
4277             /* Append revision */
4278             av_push(av, newSViv(rev));
4279             if ( vinf ) {
4280                 s = last;
4281                 break;
4282             }
4283             else if ( *pos == '.' )
4284                 s = ++pos;
4285             else if ( *pos == '_' && isDIGIT(pos[1]) )
4286                 s = ++pos;
4287             else if ( *pos == ',' && isDIGIT(pos[1]) )
4288                 s = ++pos;
4289             else if ( isDIGIT(*pos) )
4290                 s = pos;
4291             else {
4292                 s = pos;
4293                 break;
4294             }
4295             if ( qv ) {
4296                 while ( isDIGIT(*pos) )
4297                     pos++;
4298             }
4299             else {
4300                 int digits = 0;
4301                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4302                     if ( *pos != '_' )
4303                         digits++;
4304                     pos++;
4305                 }
4306             }
4307         }
4308     }
4309     if ( qv ) { /* quoted versions always get at least three terms*/
4310         I32 len = av_len(av);
4311         /* This for loop appears to trigger a compiler bug on OS X, as it
4312            loops infinitely. Yes, len is negative. No, it makes no sense.
4313            Compiler in question is:
4314            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4315            for ( len = 2 - len; len > 0; len-- )
4316            av_push(MUTABLE_AV(sv), newSViv(0));
4317         */
4318         len = 2 - len;
4319         while (len-- > 0)
4320             av_push(av, newSViv(0));
4321     }
4322
4323     /* need to save off the current version string for later */
4324     if ( vinf ) {
4325         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4326         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4327         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4328     }
4329     else if ( s > start ) {
4330         SV * orig = newSVpvn(start,s-start);
4331         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4332             /* need to insert a v to be consistent */
4333             sv_insert(orig, 0, 0, "v", 1);
4334         }
4335         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4336     }
4337     else {
4338         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4339         av_push(av, newSViv(0));
4340     }
4341
4342     /* And finally, store the AV in the hash */
4343     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4344
4345     /* fix RT#19517 - special case 'undef' as string */
4346     if ( *s == 'u' && strEQ(s,"undef") ) {
4347         s += 5;
4348     }
4349
4350     return s;
4351 }
4352
4353 /*
4354 =for apidoc new_version
4355
4356 Returns a new version object based on the passed in SV:
4357
4358     SV *sv = new_version(SV *ver);
4359
4360 Does not alter the passed in ver SV.  See "upg_version" if you
4361 want to upgrade the SV.
4362
4363 =cut
4364 */
4365
4366 SV *
4367 Perl_new_version(pTHX_ SV *ver)
4368 {
4369     dVAR;
4370     SV * const rv = newSV(0);
4371     PERL_ARGS_ASSERT_NEW_VERSION;
4372     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4373          /* can just copy directly */
4374     {
4375         I32 key;
4376         AV * const av = newAV();
4377         AV *sav;
4378         /* This will get reblessed later if a derived class*/
4379         SV * const hv = newSVrv(rv, "version");
4380         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4381 #ifndef NODEFAULT_SHAREKEYS
4382         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4383 #endif
4384
4385         if ( SvROK(ver) )
4386             ver = SvRV(ver);
4387
4388         /* Begin copying all of the elements */
4389         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4390             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4391
4392         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4393             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4394
4395         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4396         {
4397             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4398             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4399         }
4400
4401         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4402         {
4403             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4404             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4405         }
4406
4407         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4408         /* This will get reblessed later if a derived class*/
4409         for ( key = 0; key <= av_len(sav); key++ )
4410         {
4411             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4412             av_push(av, newSViv(rev));
4413         }
4414
4415         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4416         return rv;
4417     }
4418 #ifdef SvVOK
4419     {
4420         const MAGIC* const mg = SvVSTRING_mg(ver);
4421         if ( mg ) { /* already a v-string */
4422             const STRLEN len = mg->mg_len;
4423             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4424             sv_setpvn(rv,version,len);
4425             /* this is for consistency with the pure Perl class */
4426             if ( isDIGIT(*version) )
4427                 sv_insert(rv, 0, 0, "v", 1);
4428             Safefree(version);
4429         }
4430         else {
4431 #endif
4432         sv_setsv(rv,ver); /* make a duplicate */
4433 #ifdef SvVOK
4434         }
4435     }
4436 #endif
4437     return upg_version(rv, FALSE);
4438 }
4439
4440 /*
4441 =for apidoc upg_version
4442
4443 In-place upgrade of the supplied SV to a version object.
4444
4445     SV *sv = upg_version(SV *sv, bool qv);
4446
4447 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4448 to force this SV to be interpreted as an "extended" version.
4449
4450 =cut
4451 */
4452
4453 SV *
4454 Perl_upg_version(pTHX_ SV *ver, bool qv)
4455 {
4456     const char *version, *s;
4457 #ifdef SvVOK
4458     const MAGIC *mg;
4459 #endif
4460
4461     PERL_ARGS_ASSERT_UPG_VERSION;
4462
4463     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4464     {
4465         STRLEN len;
4466
4467         /* may get too much accuracy */
4468         char tbuf[64];
4469         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4470         char *buf;
4471 #ifdef USE_LOCALE_NUMERIC
4472         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
4473         setlocale(LC_NUMERIC, "C");
4474 #endif
4475         if (sv) {
4476             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4477             buf = SvPV(sv, len);
4478         }
4479         else {
4480             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4481             buf = tbuf;
4482         }
4483 #ifdef USE_LOCALE_NUMERIC
4484         setlocale(LC_NUMERIC, loc);
4485         Safefree(loc);
4486 #endif
4487         while (buf[len-1] == '0' && len > 0) len--;
4488         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4489         version = savepvn(buf, len);
4490         SvREFCNT_dec(sv);
4491     }
4492 #ifdef SvVOK
4493     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4494         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4495         qv = TRUE;
4496     }
4497 #endif
4498     else /* must be a string or something like a string */
4499     {
4500         STRLEN len;
4501         version = savepv(SvPV(ver,len));
4502 #ifndef SvVOK
4503 #  if PERL_VERSION > 5
4504         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4505         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4506             /* may be a v-string */
4507             char *testv = (char *)version;
4508             STRLEN tlen = len;
4509             for (tlen=0; tlen < len; tlen++, testv++) {
4510                 /* if one of the characters is non-text assume v-string */
4511                 if (testv[0] < ' ') {
4512                     SV * const nsv = sv_newmortal();
4513                     const char *nver;
4514                     const char *pos;
4515                     int saw_decimal = 0;
4516                     sv_setpvf(nsv,"v%vd",ver);
4517                     pos = nver = savepv(SvPV_nolen(nsv));
4518
4519                     /* scan the resulting formatted string */
4520                     pos++; /* skip the leading 'v' */
4521                     while ( *pos == '.' || isDIGIT(*pos) ) {
4522                         if ( *pos == '.' )
4523                             saw_decimal++ ;
4524                         pos++;
4525                     }
4526
4527                     /* is definitely a v-string */
4528                     if ( saw_decimal >= 2 ) {
4529                         Safefree(version);
4530                         version = nver;
4531                     }
4532                     break;
4533                 }
4534             }
4535         }
4536 #  endif
4537 #endif
4538     }
4539
4540     s = scan_version(version, ver, qv);
4541     if ( *s != '\0' )
4542         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4543                        "Version string '%s' contains invalid data; "
4544                        "ignoring: '%s'", version, s);
4545     Safefree(version);
4546     return ver;
4547 }
4548
4549 /*
4550 =for apidoc vverify
4551
4552 Validates that the SV contains valid internal structure for a version object.
4553 It may be passed either the version object (RV) or the hash itself (HV).  If
4554 the structure is valid, it returns the HV.  If the structure is invalid,
4555 it returns NULL.
4556
4557     SV *hv = vverify(sv);
4558
4559 Note that it only confirms the bare minimum structure (so as not to get
4560 confused by derived classes which may contain additional hash entries):
4561
4562 =over 4
4563
4564 =item * The SV is an HV or a reference to an HV
4565
4566 =item * The hash contains a "version" key
4567
4568 =item * The "version" key has a reference to an AV as its value
4569
4570 =back
4571
4572 =cut
4573 */
4574
4575 SV *
4576 Perl_vverify(pTHX_ SV *vs)
4577 {
4578     SV *sv;
4579
4580     PERL_ARGS_ASSERT_VVERIFY;
4581
4582     if ( SvROK(vs) )
4583         vs = SvRV(vs);
4584
4585     /* see if the appropriate elements exist */
4586     if ( SvTYPE(vs) == SVt_PVHV
4587          && hv_exists(MUTABLE_HV(vs), "version", 7)
4588          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4589          && SvTYPE(sv) == SVt_PVAV )
4590         return vs;
4591     else
4592         return NULL;
4593 }
4594
4595 /*
4596 =for apidoc vnumify
4597
4598 Accepts a version object and returns the normalized floating
4599 point representation.  Call like:
4600
4601     sv = vnumify(rv);
4602
4603 NOTE: you can pass either the object directly or the SV
4604 contained within the RV.
4605
4606 The SV returned has a refcount of 1.
4607
4608 =cut
4609 */
4610
4611 SV *
4612 Perl_vnumify(pTHX_ SV *vs)
4613 {
4614     I32 i, len, digit;
4615     int width;
4616     bool alpha = FALSE;
4617     SV *sv;
4618     AV *av;
4619
4620     PERL_ARGS_ASSERT_VNUMIFY;
4621
4622     /* extract the HV from the object */
4623     vs = vverify(vs);
4624     if ( ! vs )
4625         Perl_croak(aTHX_ "Invalid version object");
4626
4627     /* see if various flags exist */
4628     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4629         alpha = TRUE;
4630     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4631         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4632     else
4633         width = 3;
4634
4635
4636     /* attempt to retrieve the version array */
4637     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4638         return newSVpvs("0");
4639     }
4640
4641     len = av_len(av);
4642     if ( len == -1 )
4643     {
4644         return newSVpvs("0");
4645     }
4646
4647     digit = SvIV(*av_fetch(av, 0, 0));
4648     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4649     for ( i = 1 ; i < len ; i++ )
4650     {
4651         digit = SvIV(*av_fetch(av, i, 0));
4652         if ( width < 3 ) {
4653             const int denom = (width == 2 ? 10 : 100);
4654             const div_t term = div((int)PERL_ABS(digit),denom);
4655             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4656         }
4657         else {
4658             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4659         }
4660     }
4661
4662     if ( len > 0 )
4663     {
4664         digit = SvIV(*av_fetch(av, len, 0));
4665         if ( alpha && width == 3 ) /* alpha version */
4666             sv_catpvs(sv,"_");
4667         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4668     }
4669     else /* len == 0 */
4670     {
4671         sv_catpvs(sv, "000");
4672     }
4673     return sv;
4674 }
4675
4676 /*
4677 =for apidoc vnormal
4678
4679 Accepts a version object and returns the normalized string
4680 representation.  Call like:
4681
4682     sv = vnormal(rv);
4683
4684 NOTE: you can pass either the object directly or the SV
4685 contained within the RV.
4686
4687 The SV returned has a refcount of 1.
4688
4689 =cut
4690 */
4691
4692 SV *
4693 Perl_vnormal(pTHX_ SV *vs)
4694 {
4695     I32 i, len, digit;
4696     bool alpha = FALSE;
4697     SV *sv;
4698     AV *av;
4699
4700     PERL_ARGS_ASSERT_VNORMAL;
4701
4702     /* extract the HV from the object */
4703     vs = vverify(vs);
4704     if ( ! vs )
4705         Perl_croak(aTHX_ "Invalid version object");
4706
4707     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4708         alpha = TRUE;
4709     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4710
4711     len = av_len(av);
4712     if ( len == -1 )
4713     {
4714         return newSVpvs("");
4715     }
4716     digit = SvIV(*av_fetch(av, 0, 0));
4717     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4718     for ( i = 1 ; i < len ; i++ ) {
4719         digit = SvIV(*av_fetch(av, i, 0));
4720         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4721     }
4722
4723     if ( len > 0 )
4724     {
4725         /* handle last digit specially */
4726         digit = SvIV(*av_fetch(av, len, 0));
4727         if ( alpha )
4728             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4729         else
4730             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4731     }
4732
4733     if ( len <= 2 ) { /* short version, must be at least three */
4734         for ( len = 2 - len; len != 0; len-- )
4735             sv_catpvs(sv,".0");
4736     }
4737     return sv;
4738 }
4739
4740 /*
4741 =for apidoc vstringify
4742
4743 In order to maintain maximum compatibility with earlier versions
4744 of Perl, this function will return either the floating point
4745 notation or the multiple dotted notation, depending on whether
4746 the original version contained 1 or more dots, respectively.
4747
4748 The SV returned has a refcount of 1.
4749
4750 =cut
4751 */
4752
4753 SV *
4754 Perl_vstringify(pTHX_ SV *vs)
4755 {
4756     PERL_ARGS_ASSERT_VSTRINGIFY;
4757
4758     /* extract the HV from the object */
4759     vs = vverify(vs);
4760     if ( ! vs )
4761         Perl_croak(aTHX_ "Invalid version object");
4762
4763     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4764         SV *pv;
4765         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4766         if ( SvPOK(pv) )
4767             return newSVsv(pv);
4768         else
4769             return &PL_sv_undef;
4770     }
4771     else {
4772         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4773             return vnormal(vs);
4774         else
4775             return vnumify(vs);
4776     }
4777 }
4778
4779 /*
4780 =for apidoc vcmp
4781
4782 Version object aware cmp.  Both operands must already have been
4783 converted into version objects.
4784
4785 =cut
4786 */
4787
4788 int
4789 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4790 {
4791     I32 i,l,m,r,retval;
4792     bool lalpha = FALSE;
4793     bool ralpha = FALSE;
4794     I32 left = 0;
4795     I32 right = 0;
4796     AV *lav, *rav;
4797
4798     PERL_ARGS_ASSERT_VCMP;
4799
4800     /* extract the HVs from the objects */
4801     lhv = vverify(lhv);
4802     rhv = vverify(rhv);
4803     if ( ! ( lhv && rhv ) )
4804         Perl_croak(aTHX_ "Invalid version object");
4805
4806     /* get the left hand term */
4807     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4808     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4809         lalpha = TRUE;
4810
4811     /* and the right hand term */
4812     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4813     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4814         ralpha = TRUE;
4815
4816     l = av_len(lav);
4817     r = av_len(rav);
4818     m = l < r ? l : r;
4819     retval = 0;
4820     i = 0;
4821     while ( i <= m && retval == 0 )
4822     {
4823         left  = SvIV(*av_fetch(lav,i,0));
4824         right = SvIV(*av_fetch(rav,i,0));
4825         if ( left < right  )
4826             retval = -1;
4827         if ( left > right )
4828             retval = +1;
4829         i++;
4830     }
4831
4832     /* tiebreaker for alpha with identical terms */
4833     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4834     {
4835         if ( lalpha && !ralpha )
4836         {
4837             retval = -1;
4838         }
4839         else if ( ralpha && !lalpha)
4840         {
4841             retval = +1;
4842         }
4843     }
4844
4845     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4846     {
4847         if ( l < r )
4848         {
4849             while ( i <= r && retval == 0 )
4850             {
4851                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4852                     retval = -1; /* not a match after all */
4853                 i++;
4854             }
4855         }
4856         else
4857         {
4858             while ( i <= l && retval == 0 )
4859             {
4860                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4861                     retval = +1; /* not a match after all */
4862                 i++;
4863             }
4864         }
4865     }
4866     return retval;
4867 }
4868
4869 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4870 #   define EMULATE_SOCKETPAIR_UDP
4871 #endif
4872
4873 #ifdef EMULATE_SOCKETPAIR_UDP
4874 static int
4875 S_socketpair_udp (int fd[2]) {
4876     dTHX;
4877     /* Fake a datagram socketpair using UDP to localhost.  */
4878     int sockets[2] = {-1, -1};
4879     struct sockaddr_in addresses[2];
4880     int i;
4881     Sock_size_t size = sizeof(struct sockaddr_in);
4882     unsigned short port;
4883     int got;
4884
4885     memset(&addresses, 0, sizeof(addresses));
4886     i = 1;
4887     do {
4888         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4889         if (sockets[i] == -1)
4890             goto tidy_up_and_fail;
4891
4892         addresses[i].sin_family = AF_INET;
4893         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4894         addresses[i].sin_port = 0;      /* kernel choses port.  */
4895         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4896                 sizeof(struct sockaddr_in)) == -1)
4897             goto tidy_up_and_fail;
4898     } while (i--);
4899
4900     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4901        for each connect the other socket to it.  */
4902     i = 1;
4903     do {
4904         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4905                 &size) == -1)
4906             goto tidy_up_and_fail;
4907         if (size != sizeof(struct sockaddr_in))
4908             goto abort_tidy_up_and_fail;
4909         /* !1 is 0, !0 is 1 */
4910         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4911                 sizeof(struct sockaddr_in)) == -1)
4912             goto tidy_up_and_fail;
4913     } while (i--);
4914
4915     /* Now we have 2 sockets connected to each other. I don't trust some other
4916        process not to have already sent a packet to us (by random) so send
4917        a packet from each to the other.  */
4918     i = 1;
4919     do {
4920         /* I'm going to send my own port number.  As a short.
4921            (Who knows if someone somewhere has sin_port as a bitfield and needs
4922            this routine. (I'm assuming crays have socketpair)) */
4923         port = addresses[i].sin_port;
4924         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4925         if (got != sizeof(port)) {
4926             if (got == -1)
4927                 goto tidy_up_and_fail;
4928             goto abort_tidy_up_and_fail;
4929         }
4930     } while (i--);
4931
4932     /* Packets sent. I don't trust them to have arrived though.
4933        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4934        connect to localhost will use a second kernel thread. In 2.6 the
4935        first thread running the connect() returns before the second completes,
4936        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4937        returns 0. Poor programs have tripped up. One poor program's authors'
4938        had a 50-1 reverse stock split. Not sure how connected these were.)
4939        So I don't trust someone not to have an unpredictable UDP stack.
4940     */
4941
4942     {
4943         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4944         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4945         fd_set rset;
4946
4947         FD_ZERO(&rset);
4948         FD_SET((unsigned int)sockets[0], &rset);
4949         FD_SET((unsigned int)sockets[1], &rset);
4950
4951         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4952         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4953                 || !FD_ISSET(sockets[1], &rset)) {
4954             /* I hope this is portable and appropriate.  */
4955             if (got == -1)
4956                 goto tidy_up_and_fail;
4957             goto abort_tidy_up_and_fail;
4958         }
4959     }
4960
4961     /* And the paranoia department even now doesn't trust it to have arrive
4962        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4963     {
4964         struct sockaddr_in readfrom;
4965         unsigned short buffer[2];
4966
4967         i = 1;
4968         do {
4969 #ifdef MSG_DONTWAIT
4970             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4971                     sizeof(buffer), MSG_DONTWAIT,
4972                     (struct sockaddr *) &readfrom, &size);
4973 #else
4974             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4975                     sizeof(buffer), 0,
4976                     (struct sockaddr *) &readfrom, &size);
4977 #endif
4978
4979             if (got == -1)
4980                 goto tidy_up_and_fail;
4981             if (got != sizeof(port)
4982                     || size != sizeof(struct sockaddr_in)
4983                     /* Check other socket sent us its port.  */
4984                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4985                     /* Check kernel says we got the datagram from that socket */
4986                     || readfrom.sin_family != addresses[!i].sin_family
4987                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4988                     || readfrom.sin_port != addresses[!i].sin_port)
4989                 goto abort_tidy_up_and_fail;
4990         } while (i--);
4991     }
4992     /* My caller (my_socketpair) has validated that this is non-NULL  */
4993     fd[0] = sockets[0];
4994     fd[1] = sockets[1];
4995     /* I hereby declare this connection open.  May God bless all who cross
4996        her.  */
4997     return 0;
4998
4999   abort_tidy_up_and_fail:
5000     errno = ECONNABORTED;
5001   tidy_up_and_fail:
5002     {
5003         dSAVE_ERRNO;
5004         if (sockets[0] != -1)
5005             PerlLIO_close(sockets[0]);
5006         if (sockets[1] != -1)
5007             PerlLIO_close(sockets[1]);
5008         RESTORE_ERRNO;
5009         return -1;
5010     }
5011 }
5012 #endif /*  EMULATE_SOCKETPAIR_UDP */
5013
5014 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5015 int
5016 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5017     /* Stevens says that family must be AF_LOCAL, protocol 0.
5018        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5019     dTHXa(NULL);
5020     int listener = -1;
5021     int connector = -1;
5022     int acceptor = -1;
5023     struct sockaddr_in listen_addr;
5024     struct sockaddr_in connect_addr;
5025     Sock_size_t size;
5026
5027     if (protocol
5028 #ifdef AF_UNIX
5029         || family != AF_UNIX
5030 #endif
5031     ) {
5032         errno = EAFNOSUPPORT;
5033         return -1;
5034     }
5035     if (!fd) {
5036         errno = EINVAL;
5037         return -1;
5038     }
5039
5040 #ifdef EMULATE_SOCKETPAIR_UDP
5041     if (type == SOCK_DGRAM)
5042         return S_socketpair_udp(fd);
5043 #endif
5044
5045     aTHXa(PERL_GET_THX);
5046     listener = PerlSock_socket(AF_INET, type, 0);
5047     if (listener == -1)
5048         return -1;
5049     memset(&listen_addr, 0, sizeof(listen_addr));
5050     listen_addr.sin_family = AF_INET;
5051     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5052     listen_addr.sin_port = 0;   /* kernel choses port.  */
5053     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5054             sizeof(listen_addr)) == -1)
5055         goto tidy_up_and_fail;
5056     if (PerlSock_listen(listener, 1) == -1)
5057         goto tidy_up_and_fail;
5058
5059     connector = PerlSock_socket(AF_INET, type, 0);
5060     if (connector == -1)
5061         goto tidy_up_and_fail;
5062     /* We want to find out the port number to connect to.  */
5063     size = sizeof(connect_addr);
5064     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5065             &size) == -1)
5066         goto tidy_up_and_fail;
5067     if (size != sizeof(connect_addr))
5068         goto abort_tidy_up_and_fail;
5069     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5070             sizeof(connect_addr)) == -1)
5071         goto tidy_up_and_fail;
5072
5073     size = sizeof(listen_addr);
5074     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5075             &size);
5076     if (acceptor == -1)
5077         goto tidy_up_and_fail;
5078     if (size != sizeof(listen_addr))
5079         goto abort_tidy_up_and_fail;
5080     PerlLIO_close(listener);
5081     /* Now check we are talking to ourself by matching port and host on the
5082        two sockets.  */
5083     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5084             &size) == -1)
5085         goto tidy_up_and_fail;
5086     if (size != sizeof(connect_addr)
5087             || listen_addr.sin_family != connect_addr.sin_family
5088             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5089             || listen_addr.sin_port != connect_addr.sin_port) {
5090         goto abort_tidy_up_and_fail;
5091     }
5092     fd[0] = connector;
5093     fd[1] = acceptor;
5094     return 0;
5095
5096   abort_tidy_up_and_fail:
5097 #ifdef ECONNABORTED
5098   errno = ECONNABORTED; /* This would be the standard thing to do. */
5099 #else
5100 #  ifdef ECONNREFUSED
5101   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5102 #  else
5103   errno = ETIMEDOUT;    /* Desperation time. */
5104 #  endif
5105 #endif
5106   tidy_up_and_fail:
5107     {
5108         dSAVE_ERRNO;
5109         if (listener != -1)
5110             PerlLIO_close(listener);
5111         if (connector != -1)
5112             PerlLIO_close(connector);
5113         if (acceptor != -1)
5114             PerlLIO_close(acceptor);
5115         RESTORE_ERRNO;
5116         return -1;
5117     }
5118 }
5119 #else
5120 /* In any case have a stub so that there's code corresponding
5121  * to the my_socketpair in embed.fnc. */
5122 int
5123 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5124 #ifdef HAS_SOCKETPAIR
5125     return socketpair(family, type, protocol, fd);
5126 #else
5127     return -1;
5128 #endif
5129 }
5130 #endif
5131
5132 /*
5133
5134 =for apidoc sv_nosharing
5135
5136 Dummy routine which "shares" an SV when there is no sharing module present.
5137 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5138 Exists to avoid test for a NULL function pointer and because it could
5139 potentially warn under some level of strict-ness.
5140
5141 =cut
5142 */
5143
5144 void
5145 Perl_sv_nosharing(pTHX_ SV *sv)
5146 {
5147     PERL_UNUSED_CONTEXT;
5148     PERL_UNUSED_ARG(sv);
5149 }
5150
5151 /*
5152
5153 =for apidoc sv_destroyable
5154
5155 Dummy routine which reports that object can be destroyed when there is no
5156 sharing module present.  It ignores its single SV argument, and returns
5157 'true'.  Exists to avoid test for a NULL function pointer and because it
5158 could potentially warn under some level of strict-ness.
5159
5160 =cut
5161 */
5162
5163 bool
5164 Perl_sv_destroyable(pTHX_ SV *sv)
5165 {
5166     PERL_UNUSED_CONTEXT;
5167     PERL_UNUSED_ARG(sv);
5168     return TRUE;
5169 }
5170
5171 U32
5172 Perl_parse_unicode_opts(pTHX_ const char **popt)
5173 {
5174   const char *p = *popt;
5175   U32 opt = 0;
5176
5177   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5178
5179   if (*p) {
5180        if (isDIGIT(*p)) {
5181             opt = (U32) atoi(p);
5182             while (isDIGIT(*p))
5183                 p++;
5184             if (*p && *p != '\n' && *p != '\r') {
5185              if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5186              else
5187                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5188             }
5189        }
5190        else {
5191             for (; *p; p++) {
5192                  switch (*p) {
5193                  case PERL_UNICODE_STDIN:
5194                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5195                  case PERL_UNICODE_STDOUT:
5196                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5197                  case PERL_UNICODE_STDERR:
5198                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5199                  case PERL_UNICODE_STD:
5200                       opt |= PERL_UNICODE_STD_FLAG;     break;
5201                  case PERL_UNICODE_IN:
5202                       opt |= PERL_UNICODE_IN_FLAG;      break;
5203                  case PERL_UNICODE_OUT:
5204                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5205                  case PERL_UNICODE_INOUT:
5206                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5207                  case PERL_UNICODE_LOCALE:
5208                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5209                  case PERL_UNICODE_ARGV:
5210                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5211                  case PERL_UNICODE_UTF8CACHEASSERT:
5212                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5213                  default:
5214                       if (*p != '\n' && *p != '\r') {
5215                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5216                         else
5217                           Perl_croak(aTHX_
5218                                      "Unknown Unicode option letter '%c'", *p);
5219                       }
5220                  }
5221             }
5222        }
5223   }
5224   else
5225        opt = PERL_UNICODE_DEFAULT_FLAGS;
5226
5227   the_end_of_the_opts_parser:
5228
5229   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5230        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5231                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5232
5233   *popt = p;
5234
5235   return opt;
5236 }
5237
5238 #ifdef VMS
5239 #  include <starlet.h>
5240 #endif
5241
5242 U32
5243 Perl_seed(pTHX)
5244 {
5245     dVAR;
5246     /*
5247      * This is really just a quick hack which grabs various garbage
5248      * values.  It really should be a real hash algorithm which
5249      * spreads the effect of every input bit onto every output bit,
5250      * if someone who knows about such things would bother to write it.
5251      * Might be a good idea to add that function to CORE as well.
5252      * No numbers below come from careful analysis or anything here,
5253      * except they are primes and SEED_C1 > 1E6 to get a full-width
5254      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5255      * probably be bigger too.
5256      */
5257 #if RANDBITS > 16
5258 #  define SEED_C1       1000003
5259 #define   SEED_C4       73819
5260 #else
5261 #  define SEED_C1       25747
5262 #define   SEED_C4       20639
5263 #endif
5264 #define   SEED_C2       3
5265 #define   SEED_C3       269
5266 #define   SEED_C5       26107
5267
5268 #ifndef PERL_NO_DEV_RANDOM
5269     int fd;
5270 #endif
5271     U32 u;
5272 #ifdef VMS
5273     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5274      * in 100-ns units, typically incremented ever 10 ms.        */
5275     unsigned int when[2];
5276 #else
5277 #  ifdef HAS_GETTIMEOFDAY
5278     struct timeval when;
5279 #  else
5280     Time_t when;
5281 #  endif
5282 #endif
5283
5284 /* This test is an escape hatch, this symbol isn't set by Configure. */
5285 #ifndef PERL_NO_DEV_RANDOM
5286 #ifndef PERL_RANDOM_DEVICE
5287    /* /dev/random isn't used by default because reads from it will block
5288     * if there isn't enough entropy available.  You can compile with
5289     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5290     * is enough real entropy to fill the seed. */
5291 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5292 #endif
5293     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5294     if (fd != -1) {
5295         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5296             u = 0;
5297         PerlLIO_close(fd);
5298         if (u)
5299             return u;
5300     }
5301 #endif
5302
5303 #ifdef VMS
5304     _ckvmssts(sys$gettim(when));
5305     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5306 #else
5307 #  ifdef HAS_GETTIMEOFDAY
5308     PerlProc_gettimeofday(&when,NULL);
5309     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5310 #  else
5311     (void)time(&when);
5312     u = (U32)SEED_C1 * when;
5313 #  endif
5314 #endif
5315     u += SEED_C3 * (U32)PerlProc_getpid();
5316     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5317 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5318     u += SEED_C5 * (U32)PTR2UV(&when);
5319 #endif
5320     return u;
5321 }
5322
5323 void
5324 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
5325 {
5326     dVAR;
5327     const char *env_pv;
5328     unsigned long i;
5329
5330     PERL_ARGS_ASSERT_GET_HASH_SEED;
5331
5332     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
5333
5334     if ( env_pv )
5335 #ifndef USE_HASH_SEED_EXPLICIT
5336     {
5337         /* ignore leading spaces */
5338         while (isSPACE(*env_pv))
5339             env_pv++;
5340 #ifdef USE_PERL_PERTURB_KEYS
5341         /* if they set it to "0" we disable key traversal randomization completely */
5342         if (strEQ(env_pv,"0")) {
5343             PL_hash_rand_bits_enabled= 0;
5344         } else {
5345             /* otherwise switch to deterministic mode */
5346             PL_hash_rand_bits_enabled= 2;
5347         }
5348 #endif
5349         /* ignore a leading 0x... if it is there */
5350         if (env_pv[0] == '0' && env_pv[1] == 'x')
5351             env_pv += 2;
5352
5353         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
5354             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
5355             if ( isXDIGIT(*env_pv)) {
5356                 seed_buffer[i] |= READ_XDIGIT(env_pv);
5357             }
5358         }
5359         while (isSPACE(*env_pv))
5360             env_pv++;
5361
5362         if (*env_pv && !isXDIGIT(*env_pv)) {
5363             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
5364         }
5365         /* should we check for unparsed crap? */
5366         /* should we warn about unused hex? */
5367         /* should we warn about insufficient hex? */
5368     }
5369     else
5370 #endif
5371     {
5372         (void)seedDrand01((Rand_seed_t)seed());
5373
5374         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
5375             seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
5376         }
5377     }
5378 #ifdef USE_PERL_PERTURB_KEYS
5379     {   /* initialize PL_hash_rand_bits from the hash seed.
5380          * This value is highly volatile, it is updated every
5381          * hash insert, and is used as part of hash bucket chain
5382          * randomization and hash iterator randomization. */
5383         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
5384         for( i = 0; i < sizeof(UV) ; i++ ) {
5385             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
5386             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
5387         }
5388     }
5389     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
5390     if (env_pv) {
5391         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
5392             PL_hash_rand_bits_enabled= 0;
5393         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
5394             PL_hash_rand_bits_enabled= 1;
5395         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
5396             PL_hash_rand_bits_enabled= 2;
5397         } else {
5398             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
5399         }
5400     }
5401 #endif
5402 }
5403
5404 #ifdef PERL_GLOBAL_STRUCT
5405
5406 #define PERL_GLOBAL_STRUCT_INIT
5407 #include "opcode.h" /* the ppaddr and check */
5408
5409 struct perl_vars *
5410 Perl_init_global_struct(pTHX)
5411 {
5412     struct perl_vars *plvarsp = NULL;
5413 # ifdef PERL_GLOBAL_STRUCT
5414     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5415     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5416 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5417     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5418     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5419     if (!plvarsp)
5420         exit(1);
5421 #  else
5422     plvarsp = PL_VarsPtr;
5423 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5424 #  undef PERLVAR
5425 #  undef PERLVARA
5426 #  undef PERLVARI
5427 #  undef PERLVARIC
5428 #  define PERLVAR(prefix,var,type) /**/
5429 #  define PERLVARA(prefix,var,n,type) /**/
5430 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5431 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5432 #  include "perlvars.h"
5433 #  undef PERLVAR
5434 #  undef PERLVARA
5435 #  undef PERLVARI
5436 #  undef PERLVARIC
5437 #  ifdef PERL_GLOBAL_STRUCT
5438     plvarsp->Gppaddr =
5439         (Perl_ppaddr_t*)
5440         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5441     if (!plvarsp->Gppaddr)
5442         exit(1);
5443     plvarsp->Gcheck  =
5444         (Perl_check_t*)
5445         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5446     if (!plvarsp->Gcheck)
5447         exit(1);
5448     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5449     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5450 #  endif
5451 #  ifdef PERL_SET_VARS
5452     PERL_SET_VARS(plvarsp);
5453 #  endif
5454 # undef PERL_GLOBAL_STRUCT_INIT
5455 # endif
5456     return plvarsp;
5457 }
5458
5459 #endif /* PERL_GLOBAL_STRUCT */
5460
5461 #ifdef PERL_GLOBAL_STRUCT
5462
5463 void
5464 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5465 {
5466     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5467 # ifdef PERL_GLOBAL_STRUCT
5468 #  ifdef PERL_UNSET_VARS
5469     PERL_UNSET_VARS(plvarsp);
5470 #  endif
5471     free(plvarsp->Gppaddr);
5472     free(plvarsp->Gcheck);
5473 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5474     free(plvarsp);
5475 #  endif
5476 # endif
5477 }
5478
5479 #endif /* PERL_GLOBAL_STRUCT */
5480
5481 #ifdef PERL_MEM_LOG
5482
5483 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5484  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5485  * given, and you supply your own implementation.
5486  *
5487  * The default implementation reads a single env var, PERL_MEM_LOG,
5488  * expecting one or more of the following:
5489  *
5490  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5491  *    'm' - memlog      was PERL_MEM_LOG=1
5492  *    's' - svlog       was PERL_SV_LOG=1
5493  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5494  *
5495  * This makes the logger controllable enough that it can reasonably be
5496  * added to the system perl.
5497  */
5498
5499 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5500  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5501  */
5502 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5503
5504 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5505  * writes to.  In the default logger, this is settable at runtime.
5506  */
5507 #ifndef PERL_MEM_LOG_FD
5508 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5509 #endif
5510
5511 #ifndef PERL_MEM_LOG_NOIMPL
5512
5513 # ifdef DEBUG_LEAKING_SCALARS
5514 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5515 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5516 # else
5517 #   define SV_LOG_SERIAL_FMT
5518 #   define _SV_LOG_SERIAL_ARG(sv)
5519 # endif
5520
5521 static void
5522 S_mem_log_common(enum mem_log_type mlt, const UV n,
5523                  const UV typesize, const char *type_name, const SV *sv,
5524                  Malloc_t oldalloc, Malloc_t newalloc,
5525                  const char *filename, const int linenumber,
5526                  const char *funcname)
5527 {
5528     const char *pmlenv;
5529
5530     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5531
5532     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5533     if (!pmlenv)
5534         return;
5535     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5536     {
5537         /* We can't use SVs or PerlIO for obvious reasons,
5538          * so we'll use stdio and low-level IO instead. */
5539         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5540
5541 #   ifdef HAS_GETTIMEOFDAY
5542 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5543 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5544         struct timeval tv;
5545         gettimeofday(&tv, 0);
5546 #   else
5547 #     define MEM_LOG_TIME_FMT   "%10d: "
5548 #     define MEM_LOG_TIME_ARG   (int)when
5549         Time_t when;
5550         (void)time(&when);
5551 #   endif
5552         /* If there are other OS specific ways of hires time than
5553          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5554          * probably that they would be used to fill in the struct
5555          * timeval. */
5556         {
5557             STRLEN len;
5558             int fd = atoi(pmlenv);
5559             if (!fd)
5560                 fd = PERL_MEM_LOG_FD;
5561
5562             if (strchr(pmlenv, 't')) {
5563                 len = my_snprintf(buf, sizeof(buf),
5564                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5565                 PerlLIO_write(fd, buf, len);
5566             }
5567             switch (mlt) {
5568             case MLT_ALLOC:
5569                 len = my_snprintf(buf, sizeof(buf),
5570                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5571                         " %s = %"IVdf": %"UVxf"\n",
5572                         filename, linenumber, funcname, n, typesize,
5573                         type_name, n * typesize, PTR2UV(newalloc));
5574                 break;
5575             case MLT_REALLOC:
5576                 len = my_snprintf(buf, sizeof(buf),
5577                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5578                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5579                         filename, linenumber, funcname, n, typesize,
5580                         type_name, n * typesize, PTR2UV(oldalloc),
5581                         PTR2UV(newalloc));
5582                 break;
5583             case MLT_FREE:
5584                 len = my_snprintf(buf, sizeof(buf),
5585                         "free: %s:%d:%s: %"UVxf"\n",
5586                         filename, linenumber, funcname,
5587                         PTR2UV(oldalloc));
5588                 break;
5589             case MLT_NEW_SV:
5590             case MLT_DEL_SV:
5591                 len = my_snprintf(buf, sizeof(buf),
5592                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5593                         mlt == MLT_NEW_SV ? "new" : "del",
5594                         filename, linenumber, funcname,
5595                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5596                 break;
5597             default:
5598                 len = 0;
5599             }
5600             PerlLIO_write(fd, buf, len);
5601         }
5602     }
5603 }
5604 #endif /* !PERL_MEM_LOG_NOIMPL */
5605
5606 #ifndef PERL_MEM_LOG_NOIMPL
5607 # define \
5608     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5609     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5610 #else
5611 /* this is suboptimal, but bug compatible.  User is providing their
5612    own implementation, but is getting these functions anyway, and they
5613    do nothing. But _NOIMPL users should be able to cope or fix */
5614 # define \
5615     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5616     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5617 #endif
5618
5619 Malloc_t
5620 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5621                    Malloc_t newalloc,
5622                    const char *filename, const int linenumber,
5623                    const char *funcname)
5624 {
5625     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5626                       NULL, NULL, newalloc,
5627                       filename, linenumber, funcname);
5628     return newalloc;
5629 }
5630
5631 Malloc_t
5632 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5633                      Malloc_t oldalloc, Malloc_t newalloc,
5634                      const char *filename, const int linenumber,
5635                      const char *funcname)
5636 {
5637     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5638                       NULL, oldalloc, newalloc,
5639                       filename, linenumber, funcname);
5640     return newalloc;
5641 }
5642
5643 Malloc_t
5644 Perl_mem_log_free(Malloc_t oldalloc,
5645                   const char *filename, const int linenumber,
5646                   const char *funcname)
5647 {
5648     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5649                       filename, linenumber, funcname);
5650     return oldalloc;
5651 }
5652
5653 void
5654 Perl_mem_log_new_sv(const SV *sv,
5655                     const char *filename, const int linenumber,
5656                     const char *funcname)
5657 {
5658     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5659                       filename, linenumber, funcname);
5660 }
5661
5662 void
5663 Perl_mem_log_del_sv(const SV *sv,
5664                     const char *filename, const int linenumber,
5665                     const char *funcname)
5666 {
5667     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5668                       filename, linenumber, funcname);
5669 }
5670
5671 #endif /* PERL_MEM_LOG */
5672
5673 /*
5674 =for apidoc my_sprintf
5675
5676 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5677 the length of the string written to the buffer. Only rare pre-ANSI systems
5678 need the wrapper function - usually this is a direct call to C<sprintf>.
5679
5680 =cut
5681 */
5682 #ifndef SPRINTF_RETURNS_STRLEN
5683 int
5684 Perl_my_sprintf(char *buffer, const char* pat, ...)
5685 {
5686     va_list args;
5687     PERL_ARGS_ASSERT_MY_SPRINTF;
5688     va_start(args, pat);
5689     vsprintf(buffer, pat, args);
5690     va_end(args);
5691     return strlen(buffer);
5692 }
5693 #endif
5694
5695 /*
5696 =for apidoc my_snprintf
5697
5698 The C library C<snprintf> functionality, if available and
5699 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5700 C<vsnprintf> is not available, will unfortunately use the unsafe
5701 C<vsprintf> which can overrun the buffer (there is an overrun check,
5702 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5703 getting C<vsnprintf>.
5704
5705 =cut
5706 */
5707 int
5708 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5709 {
5710     int retval;
5711     va_list ap;
5712     PERL_ARGS_ASSERT_MY_SNPRINTF;
5713     va_start(ap, format);
5714 #ifdef HAS_VSNPRINTF
5715     retval = vsnprintf(buffer, len, format, ap);
5716 #else
5717     retval = vsprintf(buffer, format, ap);
5718 #endif
5719     va_end(ap);
5720     /* vsprintf() shows failure with < 0 */
5721     if (retval < 0
5722 #ifdef HAS_VSNPRINTF
5723     /* vsnprintf() shows failure with >= len */
5724         ||
5725         (len > 0 && (Size_t)retval >= len)
5726 #endif
5727     )
5728         Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5729     return retval;
5730 }
5731
5732 /*
5733 =for apidoc my_vsnprintf
5734
5735 The C library C<vsnprintf> if available and standards-compliant.
5736 However, if if the C<vsnprintf> is not available, will unfortunately
5737 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5738 overrun check, but that may be too late).  Consider using
5739 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5740
5741 =cut
5742 */
5743 int
5744 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5745 {
5746     int retval;
5747 #ifdef NEED_VA_COPY
5748     va_list apc;
5749
5750     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5751
5752     Perl_va_copy(ap, apc);
5753 # ifdef HAS_VSNPRINTF
5754     retval = vsnprintf(buffer, len, format, apc);
5755 # else
5756     retval = vsprintf(buffer, format, apc);
5757 # endif
5758 #else
5759 # ifdef HAS_VSNPRINTF
5760     retval = vsnprintf(buffer, len, format, ap);
5761 # else
5762     retval = vsprintf(buffer, format, ap);
5763 # endif
5764 #endif /* #ifdef NEED_VA_COPY */
5765     /* vsprintf() shows failure with < 0 */
5766     if (retval < 0
5767 #ifdef HAS_VSNPRINTF
5768     /* vsnprintf() shows failure with >= len */
5769         ||
5770         (len > 0 && (Size_t)retval >= len)
5771 #endif
5772     )
5773         Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5774     return retval;
5775 }
5776
5777 void
5778 Perl_my_clearenv(pTHX)
5779 {
5780     dVAR;
5781 #if ! defined(PERL_MICRO)
5782 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5783     PerlEnv_clearenv();
5784 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5785 #    if defined(USE_ENVIRON_ARRAY)
5786 #      if defined(USE_ITHREADS)
5787     /* only the parent thread can clobber the process environment */
5788     if (PL_curinterp == aTHX)
5789 #      endif /* USE_ITHREADS */
5790     {
5791 #      if ! defined(PERL_USE_SAFE_PUTENV)
5792     if ( !PL_use_safe_putenv) {
5793       I32 i;
5794       if (environ == PL_origenviron)
5795         environ = (char**)safesysmalloc(sizeof(char*));
5796       else
5797         for (i = 0; environ[i]; i++)
5798           (void)safesysfree(environ[i]);
5799     }
5800     environ[0] = NULL;
5801 #      else /* PERL_USE_SAFE_PUTENV */
5802 #        if defined(HAS_CLEARENV)
5803     (void)clearenv();
5804 #        elif defined(HAS_UNSETENV)
5805     int bsiz = 80; /* Most envvar names will be shorter than this. */
5806     char *buf = (char*)safesysmalloc(bsiz);
5807     while (*environ != NULL) {
5808       char *e = strchr(*environ, '=');
5809       int l = e ? e - *environ : (int)strlen(*environ);
5810       if (bsiz < l + 1) {
5811         (void)safesysfree(buf);
5812         bsiz = l + 1; /* + 1 for the \0. */
5813         buf = (char*)safesysmalloc(bsiz);
5814       }
5815       memcpy(buf, *environ, l);
5816       buf[l] = '\0';
5817       (void)unsetenv(buf);
5818     }
5819     (void)safesysfree(buf);
5820 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5821     /* Just null environ and accept the leakage. */
5822     *environ = NULL;
5823 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5824 #      endif /* ! PERL_USE_SAFE_PUTENV */
5825     }
5826 #    endif /* USE_ENVIRON_ARRAY */
5827 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5828 #endif /* PERL_MICRO */
5829 }
5830
5831 #ifdef PERL_IMPLICIT_CONTEXT
5832
5833 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5834 the global PL_my_cxt_index is incremented, and that value is assigned to
5835 that module's static my_cxt_index (who's address is passed as an arg).
5836 Then, for each interpreter this function is called for, it makes sure a
5837 void* slot is available to hang the static data off, by allocating or
5838 extending the interpreter's PL_my_cxt_list array */
5839
5840 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5841 void *
5842 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5843 {
5844     dVAR;
5845     void *p;
5846     PERL_ARGS_ASSERT_MY_CXT_INIT;
5847     if (*index == -1) {
5848         /* this module hasn't been allocated an index yet */
5849 #if defined(USE_ITHREADS)
5850         MUTEX_LOCK(&PL_my_ctx_mutex);
5851 #endif
5852         *index = PL_my_cxt_index++;
5853 #if defined(USE_ITHREADS)
5854         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5855 #endif
5856     }
5857
5858     /* make sure the array is big enough */
5859     if (PL_my_cxt_size <= *index) {
5860         if (PL_my_cxt_size) {
5861             while (PL_my_cxt_size <= *index)
5862                 PL_my_cxt_size *= 2;
5863             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5864         }
5865         else {
5866             PL_my_cxt_size = 16;
5867             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5868         }
5869     }
5870     /* newSV() allocates one more than needed */
5871     p = (void*)SvPVX(newSV(size-1));
5872     PL_my_cxt_list[*index] = p;
5873     Zero(p, size, char);
5874     return p;
5875 }
5876
5877 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5878
5879 int
5880 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5881 {
5882     dVAR;
5883     int index;
5884
5885     PERL_ARGS_ASSERT_MY_CXT_INDEX;
5886
5887     for (index = 0; index < PL_my_cxt_index; index++) {
5888         const char *key = PL_my_cxt_keys[index];
5889         /* try direct pointer compare first - there are chances to success,
5890          * and it's much faster.
5891          */
5892         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5893             return index;
5894     }
5895     return -1;
5896 }
5897
5898 void *
5899 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5900 {
5901     dVAR;
5902     void *p;
5903     int index;
5904
5905     PERL_ARGS_ASSERT_MY_CXT_INIT;
5906
5907     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5908     if (index == -1) {
5909         /* this module hasn't been allocated an index yet */
5910 #if defined(USE_ITHREADS)
5911         MUTEX_LOCK(&PL_my_ctx_mutex);
5912 #endif
5913         index = PL_my_cxt_index++;
5914 #if defined(USE_ITHREADS)
5915         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5916 #endif
5917     }
5918
5919     /* make sure the array is big enough */
5920     if (PL_my_cxt_size <= index) {
5921         int old_size = PL_my_cxt_size;
5922         int i;
5923         if (PL_my_cxt_size) {
5924             while (PL_my_cxt_size <= index)
5925                 PL_my_cxt_size *= 2;
5926             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5927             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5928         }
5929         else {
5930             PL_my_cxt_size = 16;
5931             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5932             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5933         }
5934         for (i = old_size; i < PL_my_cxt_size; i++) {
5935             PL_my_cxt_keys[i] = 0;
5936             PL_my_cxt_list[i] = 0;
5937         }
5938     }
5939     PL_my_cxt_keys[index] = my_cxt_key;
5940     /* newSV() allocates one more than needed */
5941     p = (void*)SvPVX(newSV(size-1));
5942     PL_my_cxt_list[index] = p;
5943     Zero(p, size, char);
5944     return p;
5945 }
5946 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5947 #endif /* PERL_IMPLICIT_CONTEXT */
5948
5949 void
5950 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5951                           STRLEN xs_len)
5952 {
5953     SV *sv;
5954     const char *vn = NULL;
5955     SV *const module = PL_stack_base[ax];
5956
5957     PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5958
5959     if (items >= 2)      /* version supplied as bootstrap arg */
5960         sv = PL_stack_base[ax + 1];
5961     else {
5962         /* XXX GV_ADDWARN */
5963         vn = "XS_VERSION";
5964         sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5965         if (!sv || !SvOK(sv)) {
5966             vn = "VERSION";
5967             sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
5968         }
5969     }
5970     if (sv) {
5971         SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5972         SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5973             ? sv : sv_2mortal(new_version(sv));
5974         xssv = upg_version(xssv, 0);
5975         if ( vcmp(pmsv,xssv) ) {
5976             SV *string = vstringify(xssv);
5977             SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5978                                     " does not match ", module, string);
5979
5980             SvREFCNT_dec(string);
5981             string = vstringify(pmsv);
5982
5983             if (vn) {
5984                 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
5985                                string);
5986             } else {
5987                 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
5988             }
5989             SvREFCNT_dec(string);
5990
5991             Perl_sv_2mortal(aTHX_ xpt);
5992             Perl_croak_sv(aTHX_ xpt);
5993         }
5994     }
5995 }
5996
5997 void
5998 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
5999                              STRLEN api_len)
6000 {
6001     SV *xpt = NULL;
6002     SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6003     SV *runver;
6004
6005     PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6006
6007     /* This might croak  */
6008     compver = upg_version(compver, 0);
6009     /* This should never croak */
6010     runver = new_version(PL_apiversion);
6011     if (vcmp(compver, runver)) {
6012         SV *compver_string = vstringify(compver);
6013         SV *runver_string = vstringify(runver);
6014         xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6015                             " of %"SVf" does not match %"SVf,
6016                             compver_string, module, runver_string);
6017         Perl_sv_2mortal(aTHX_ xpt);
6018
6019         SvREFCNT_dec(compver_string);
6020         SvREFCNT_dec(runver_string);
6021     }
6022     SvREFCNT_dec(runver);
6023     if (xpt)
6024         Perl_croak_sv(aTHX_ xpt);
6025 }
6026
6027 #ifndef HAS_STRLCAT
6028 Size_t
6029 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6030 {
6031     Size_t used, length, copy;
6032
6033     used = strlen(dst);
6034     length = strlen(src);
6035     if (size > 0 && used < size - 1) {
6036         copy = (length >= size - used) ? size - used - 1 : length;
6037         memcpy(dst + used, src, copy);
6038         dst[used + copy] = '\0';
6039     }
6040     return used + length;
6041 }
6042 #endif
6043
6044 #ifndef HAS_STRLCPY
6045 Size_t
6046 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6047 {
6048     Size_t length, copy;
6049
6050     length = strlen(src);
6051     if (size > 0) {
6052         copy = (length >= size) ? size - 1 : length;
6053         memcpy(dst, src, copy);
6054         dst[copy] = '\0';
6055     }
6056     return length;
6057 }
6058 #endif
6059
6060 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6061 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6062 long _ftol( double ); /* Defined by VC6 C libs. */
6063 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6064 #endif
6065
6066 PERL_STATIC_INLINE bool
6067 S_gv_has_usable_name(pTHX_ GV *gv)
6068 {
6069     GV **gvp;
6070     return GvSTASH(gv)
6071         && HvENAME(GvSTASH(gv))
6072         && (gvp = (GV **)hv_fetch(
6073                         GvSTASH(gv), GvNAME(gv),
6074                         GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6075            ))
6076         && *gvp == gv;
6077 }
6078
6079 void
6080 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6081 {
6082     dVAR;
6083     SV * const dbsv = GvSVn(PL_DBsub);
6084     const bool save_taint = TAINT_get;
6085
6086     /* When we are called from pp_goto (svp is null),
6087      * we do not care about using dbsv to call CV;
6088      * it's for informational purposes only.
6089      */
6090
6091     PERL_ARGS_ASSERT_GET_DB_SUB;
6092
6093     TAINT_set(FALSE);
6094     save_item(dbsv);
6095     if (!PERLDB_SUB_NN) {
6096         GV *gv = CvGV(cv);
6097
6098         if (!svp) {
6099             gv_efullname3(dbsv, gv, NULL);
6100         }
6101         else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6102              || strEQ(GvNAME(gv), "END")
6103              || ( /* Could be imported, and old sub redefined. */
6104                  (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6105                  &&
6106                  !( (SvTYPE(*svp) == SVt_PVGV)
6107                     && (GvCV((const GV *)*svp) == cv)
6108                     /* Use GV from the stack as a fallback. */
6109                     && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
6110                   )
6111                 )
6112         ) {
6113             /* GV is potentially non-unique, or contain different CV. */
6114             SV * const tmp = newRV(MUTABLE_SV(cv));
6115             sv_setsv(dbsv, tmp);
6116             SvREFCNT_dec(tmp);
6117         }
6118         else {
6119             sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6120             sv_catpvs(dbsv, "::");
6121             sv_catpvn_flags(
6122               dbsv, GvNAME(gv), GvNAMELEN(gv),
6123               GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6124             );
6125         }
6126     }
6127     else {
6128         const int type = SvTYPE(dbsv);
6129         if (type < SVt_PVIV && type != SVt_IV)
6130             sv_upgrade(dbsv, SVt_PVIV);
6131         (void)SvIOK_on(dbsv);
6132         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6133     }
6134     TAINT_IF(save_taint);
6135 #ifdef NO_TAINT_SUPPORT
6136     PERL_UNUSED_VAR(save_taint);
6137 #endif
6138 }
6139
6140 int
6141 Perl_my_dirfd(pTHX_ DIR * dir) {
6142
6143     /* Most dirfd implementations have problems when passed NULL. */
6144     if(!dir)
6145         return -1;
6146 #ifdef HAS_DIRFD
6147     return dirfd(dir);
6148 #elif defined(HAS_DIR_DD_FD)
6149     return dir->dd_fd;
6150 #else
6151     Perl_die(aTHX_ PL_no_func, "dirfd");
6152     assert(0); /* NOT REACHED */
6153     return 0;
6154 #endif
6155 }
6156
6157 REGEXP *
6158 Perl_get_re_arg(pTHX_ SV *sv) {
6159
6160     if (sv) {
6161         if (SvMAGICAL(sv))
6162             mg_get(sv);
6163         if (SvROK(sv))
6164             sv = MUTABLE_SV(SvRV(sv));
6165         if (SvTYPE(sv) == SVt_REGEXP)
6166             return (REGEXP*) sv;
6167     }
6168
6169     return NULL;
6170 }
6171
6172 /*
6173  * Local variables:
6174  * c-indentation-style: bsd
6175  * c-basic-offset: 4
6176  * indent-tabs-mode: nil
6177  * End:
6178  *
6179  * ex: set ts=8 sts=4 sw=4 et:
6180  */