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 #if defined(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 #include <math.h>
  41 #include <stdlib.h>
  42
  43 #ifdef __Lynx__
  44 /* Missing protos on LynxOS */
  45 int putenv(char *);
  46 #endif
  47
  48 #ifdef __amigaos__
  49 # include "amigaos4/amigaio.h"
  50 #endif
  51
  52 #ifdef HAS_SELECT
  53 # ifdef I_SYS_SELECT
  54 #  include <sys/select.h>
  55 # endif
  56 #endif
  57
  58 #ifdef USE_C_BACKTRACE
  59 #  ifdef I_BFD
  60 #    define USE_BFD
  61 #    ifdef PERL_DARWIN
  62 #      undef USE_BFD /* BFD is useless in OS X. */
  63 #    endif
  64 #    ifdef USE_BFD
  65 #      include <bfd.h>
  66 #    endif
  67 #  endif
  68 #  ifdef I_DLFCN
  69 #    include <dlfcn.h>
  70 #  endif
  71 #  ifdef I_EXECINFO
  72 #    include <execinfo.h>
  73 #  endif
  74 #endif
  75
  76 #ifdef PERL_DEBUG_READONLY_COW
  77 # include <sys/mman.h>
  78 #endif
  79
  80 #define FLUSH
  81
  82 /* NOTE:  Do not call the next three routines directly.  Use the macros
  83  * in handy.h, so that we can easily redefine everything to do tracking of
  84  * allocated hunks back to the original New to track down any memory leaks.
  85  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  86  */
  87
  88 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
  89 #  define ALWAYS_NEED_THX
  90 #endif
  91
  92 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
  93 static void
  94 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
  95 {
  96     if (header->readonly
  97      && mprotect(header, header->size, PROT_READ|PROT_WRITE))
  98         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
  99                          header, header->size, errno);
 100 }
 101
 102 static void
 103 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
 104 {
 105     if (header->readonly
 106      && mprotect(header, header->size, PROT_READ))
 107         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
 108                          header, header->size, errno);
 109 }
 110 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
 111 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
 112 #else
 113 # define maybe_protect_rw(foo) NOOP
 114 # define maybe_protect_ro(foo) NOOP
 115 #endif
 116
 117 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
 118  /* Use memory_debug_header */
 119 # define USE_MDH
 120 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
 121    || defined(PERL_DEBUG_READONLY_COW)
 122 #  define MDH_HAS_SIZE
 123 # endif
 124 #endif
 125
 126 /* paranoid version of system's malloc() */
 127
 128 Malloc_t
 129 Perl_safesysmalloc(MEM_SIZE size)
 130 {
 131 #ifdef ALWAYS_NEED_THX
 132     dTHX;
 133 #endif
 134     Malloc_t ptr;
 135
 136 #ifdef USE_MDH
 137     if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
 138         goto out_of_memory;
 139     size += PERL_MEMORY_DEBUG_HEADER_SIZE;
 140 #endif
 141 #ifdef DEBUGGING
 142     if ((SSize_t)size < 0)
 143         Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
 144 #endif
 145     if (!size) size = 1;        /* malloc(0) is NASTY on our system */
 146 #ifdef PERL_DEBUG_READONLY_COW
 147     if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 148                     MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 149         perror("mmap failed");
 150         abort();
 151     }
 152 #else
 153     ptr = (Malloc_t)PerlMem_malloc(size?size:1);
 154 #endif
 155     PERL_ALLOC_CHECK(ptr);
 156     if (ptr != NULL) {
 157 #ifdef USE_MDH
 158         struct perl_memory_debug_header *const header
 159             = (struct perl_memory_debug_header *)ptr;
 160 #endif
 161
 162 #ifdef PERL_POISON
 163         PoisonNew(((char *)ptr), size, char);
 164 #endif
 165
 166 #ifdef PERL_TRACK_MEMPOOL
 167         header->interpreter = aTHX;
 168         /* Link us into the list.  */
 169         header->prev = &PL_memory_debug_header;
 170         header->next = PL_memory_debug_header.next;
 171         PL_memory_debug_header.next = header;
 172         maybe_protect_rw(header->next);
 173         header->next->prev = header;
 174         maybe_protect_ro(header->next);
 175 #  ifdef PERL_DEBUG_READONLY_COW
 176         header->readonly = 0;
 177 #  endif
 178 #endif
 179 #ifdef MDH_HAS_SIZE
 180         header->size = size;
 181 #endif
 182         ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
 183         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 184
 185     }
 186     else {
 187 #ifdef USE_MDH
 188       out_of_memory:
 189 #endif
 190         {
 191 #ifndef ALWAYS_NEED_THX
 192             dTHX;
 193 #endif
 194             if (PL_nomemok)
 195                 ptr =  NULL;
 196             else
 197                 croak_no_mem();
 198         }
 199     }
 200     return ptr;
 201 }
 202
 203 /* paranoid version of system's realloc() */
 204
 205 Malloc_t
 206 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 207 {
 208 #ifdef ALWAYS_NEED_THX
 209     dTHX;
 210 #endif
 211     Malloc_t ptr;
 212 #ifdef PERL_DEBUG_READONLY_COW
 213     const MEM_SIZE oldsize = where
 214         ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
 215         : 0;
 216 #endif
 217 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 218     Malloc_t PerlMem_realloc();
 219 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 220
 221     if (!size) {
 222         safesysfree(where);
 223         ptr = NULL;
 224     }
 225     else if (!where) {
 226         ptr = safesysmalloc(size);
 227     }
 228     else {
 229 #ifdef USE_MDH
 230         where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
 231         if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
 232             goto out_of_memory;
 233         size += PERL_MEMORY_DEBUG_HEADER_SIZE;
 234         {
 235             struct perl_memory_debug_header *const header
 236                 = (struct perl_memory_debug_header *)where;
 237
 238 # ifdef PERL_TRACK_MEMPOOL
 239             if (header->interpreter != aTHX) {
 240                 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
 241                                      header->interpreter, aTHX);
 242             }
 243             assert(header->next->prev == header);
 244             assert(header->prev->next == header);
 245 #  ifdef PERL_POISON
 246             if (header->size > size) {
 247                 const MEM_SIZE freed_up = header->size - size;
 248                 char *start_of_freed = ((char *)where) + size;
 249                 PoisonFree(start_of_freed, freed_up, char);
 250             }
 251 #  endif
 252 # endif
 253 # ifdef MDH_HAS_SIZE
 254             header->size = size;
 255 # endif
 256         }
 257 #endif
 258 #ifdef DEBUGGING
 259         if ((SSize_t)size < 0)
 260             Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
 261 #endif
 262 #ifdef PERL_DEBUG_READONLY_COW
 263         if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 264                         MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 265             perror("mmap failed");
 266             abort();
 267         }
 268         Copy(where,ptr,oldsize < size ? oldsize : size,char);
 269         if (munmap(where, oldsize)) {
 270             perror("munmap failed");
 271             abort();
 272         }
 273 #else
 274         ptr = (Malloc_t)PerlMem_realloc(where,size);
 275 #endif
 276         PERL_ALLOC_CHECK(ptr);
 277
 278     /* MUST do this fixup first, before doing ANYTHING else, as anything else
 279        might allocate memory/free/move memory, and until we do the fixup, it
 280        may well be chasing (and writing to) free memory.  */
 281         if (ptr != NULL) {
 282 #ifdef PERL_TRACK_MEMPOOL
 283             struct perl_memory_debug_header *const header
 284                 = (struct perl_memory_debug_header *)ptr;
 285
 286 #  ifdef PERL_POISON
 287             if (header->size < size) {
 288                 const MEM_SIZE fresh = size - header->size;
 289                 char *start_of_fresh = ((char *)ptr) + size;
 290                 PoisonNew(start_of_fresh, fresh, char);
 291             }
 292 #  endif
 293
 294             maybe_protect_rw(header->next);
 295             header->next->prev = header;
 296             maybe_protect_ro(header->next);
 297             maybe_protect_rw(header->prev);
 298             header->prev->next = header;
 299             maybe_protect_ro(header->prev);
 300 #endif
 301             ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
 302         }
 303
 304     /* In particular, must do that fixup above before logging anything via
 305      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 306
 307         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 308         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 309
 310         if (ptr == NULL) {
 311 #ifdef USE_MDH
 312           out_of_memory:
 313 #endif
 314             {
 315 #ifndef ALWAYS_NEED_THX
 316                 dTHX;
 317 #endif
 318                 if (PL_nomemok)
 319                     ptr = NULL;
 320                 else
 321                     croak_no_mem();
 322             }
 323         }
 324     }
 325     return ptr;
 326 }
 327
 328 /* safe version of system's free() */
 329
 330 Free_t
 331 Perl_safesysfree(Malloc_t where)
 332 {
 333 #ifdef ALWAYS_NEED_THX
 334     dTHX;
 335 #endif
 336     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 337     if (where) {
 338 #ifdef USE_MDH
 339         Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
 340         {
 341             struct perl_memory_debug_header *const header
 342                 = (struct perl_memory_debug_header *)where_intrn;
 343
 344 # ifdef MDH_HAS_SIZE
 345             const MEM_SIZE size = header->size;
 346 # endif
 347 # ifdef PERL_TRACK_MEMPOOL
 348             if (header->interpreter != aTHX) {
 349                 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
 350                                      header->interpreter, aTHX);
 351             }
 352             if (!header->prev) {
 353                 Perl_croak_nocontext("panic: duplicate free");
 354             }
 355             if (!(header->next))
 356                 Perl_croak_nocontext("panic: bad free, header->next==NULL");
 357             if (header->next->prev != header || header->prev->next != header) {
 358                 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
 359                                      "header=%p, ->prev->next=%p",
 360                                      header->next->prev, header,
 361                                      header->prev->next);
 362             }
 363             /* Unlink us from the chain.  */
 364             maybe_protect_rw(header->next);
 365             header->next->prev = header->prev;
 366             maybe_protect_ro(header->next);
 367             maybe_protect_rw(header->prev);
 368             header->prev->next = header->next;
 369             maybe_protect_ro(header->prev);
 370             maybe_protect_rw(header);
 371 #  ifdef PERL_POISON
 372             PoisonNew(where_intrn, size, char);
 373 #  endif
 374             /* Trigger the duplicate free warning.  */
 375             header->next = NULL;
 376 # endif
 377 # ifdef PERL_DEBUG_READONLY_COW
 378             if (munmap(where_intrn, size)) {
 379                 perror("munmap failed");
 380                 abort();
 381             }
 382 # endif
 383         }
 384 #else
 385         Malloc_t where_intrn = where;
 386 #endif /* USE_MDH */
 387 #ifndef PERL_DEBUG_READONLY_COW
 388         PerlMem_free(where_intrn);
 389 #endif
 390     }
 391 }
 392
 393 /* safe version of system's calloc() */
 394
 395 Malloc_t
 396 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 397 {
 398 #ifdef ALWAYS_NEED_THX
 399     dTHX;
 400 #endif
 401     Malloc_t ptr;
 402 #if defined(USE_MDH) || defined(DEBUGGING)
 403     MEM_SIZE total_size = 0;
 404 #endif
 405
 406     /* Even though calloc() for zero bytes is strange, be robust. */
 407     if (size && (count <= MEM_SIZE_MAX / size)) {
 408 #if defined(USE_MDH) || defined(DEBUGGING)
 409         total_size = size * count;
 410 #endif
 411     }
 412     else
 413         croak_memory_wrap();
 414 #ifdef USE_MDH
 415     if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 416         total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
 417     else
 418         croak_memory_wrap();
 419 #endif
 420 #ifdef DEBUGGING
 421     if ((SSize_t)size < 0 || (SSize_t)count < 0)
 422         Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
 423                              (UV)size, (UV)count);
 424 #endif
 425 #ifdef PERL_DEBUG_READONLY_COW
 426     if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
 427                     MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 428         perror("mmap failed");
 429         abort();
 430     }
 431 #elif defined(PERL_TRACK_MEMPOOL)
 432     /* Have to use malloc() because we've added some space for our tracking
 433        header.  */
 434     /* malloc(0) is non-portable. */
 435     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
 436 #else
 437     /* Use calloc() because it might save a memset() if the memory is fresh
 438        and clean from the OS.  */
 439     if (count && size)
 440         ptr = (Malloc_t)PerlMem_calloc(count, size);
 441     else /* calloc(0) is non-portable. */
 442         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 443 #endif
 444     PERL_ALLOC_CHECK(ptr);
 445     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));
 446     if (ptr != NULL) {
 447 #ifdef USE_MDH
 448         {
 449             struct perl_memory_debug_header *const header
 450                 = (struct perl_memory_debug_header *)ptr;
 451
 452 #  ifndef PERL_DEBUG_READONLY_COW
 453             memset((void*)ptr, 0, total_size);
 454 #  endif
 455 #  ifdef PERL_TRACK_MEMPOOL
 456             header->interpreter = aTHX;
 457             /* Link us into the list.  */
 458             header->prev = &PL_memory_debug_header;
 459             header->next = PL_memory_debug_header.next;
 460             PL_memory_debug_header.next = header;
 461             maybe_protect_rw(header->next);
 462             header->next->prev = header;
 463             maybe_protect_ro(header->next);
 464 #    ifdef PERL_DEBUG_READONLY_COW
 465             header->readonly = 0;
 466 #    endif
 467 #  endif
 468 #  ifdef MDH_HAS_SIZE
 469             header->size = total_size;
 470 #  endif
 471             ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
 472         }
 473 #endif
 474         return ptr;
 475     }
 476     else {
 477 #ifndef ALWAYS_NEED_THX
 478         dTHX;
 479 #endif
 480         if (PL_nomemok)
 481             return NULL;
 482         croak_no_mem();
 483     }
 484 }
 485
 486 /* These must be defined when not using Perl's malloc for binary
 487  * compatibility */
 488
 489 #ifndef MYMALLOC
 490
 491 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 492 {
 493 #ifdef PERL_IMPLICIT_SYS
 494     dTHX;
 495 #endif
 496     return (Malloc_t)PerlMem_malloc(nbytes);
 497 }
 498
 499 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 500 {
 501 #ifdef PERL_IMPLICIT_SYS
 502     dTHX;
 503 #endif
 504     return (Malloc_t)PerlMem_calloc(elements, size);
 505 }
 506
 507 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 508 {
 509 #ifdef PERL_IMPLICIT_SYS
 510     dTHX;
 511 #endif
 512     return (Malloc_t)PerlMem_realloc(where, nbytes);
 513 }
 514
 515 Free_t   Perl_mfree (Malloc_t where)
 516 {
 517 #ifdef PERL_IMPLICIT_SYS
 518     dTHX;
 519 #endif
 520     PerlMem_free(where);
 521 }
 522
 523 #endif
 524
 525 /* copy a string up to some (non-backslashed) delimiter, if any */
 526
 527 char *
 528 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
 529 {
 530     I32 tolen;
 531
 532     PERL_ARGS_ASSERT_DELIMCPY;
 533
 534     for (tolen = 0; from < fromend; from++, tolen++) {
 535         if (*from == '\\') {
 536             if (from[1] != delim) {
 537                 if (to < toend)
 538                     *to++ = *from;
 539                 tolen++;
 540             }
 541             from++;
 542         }
 543         else if (*from == delim)
 544             break;
 545         if (to < toend)
 546             *to++ = *from;
 547     }
 548     if (to < toend)
 549         *to = '\0';
 550     *retlen = tolen;
 551     return (char *)from;
 552 }
 553
 554 /*
 555 =head1 Miscellaneous Functions
 556
 557 =for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
 558
 559 Find the first (leftmost) occurrence of a sequence of bytes within another
 560 sequence.  This is the Perl version of C<strstr()>, extended to handle
 561 arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
 562 is what the initial C<n> in the function name stands for; some systems have an
 563 equivalent, C<memmem()>, but with a somewhat different API).
 564
 565 Another way of thinking about this function is finding a needle in a haystack.
 566 C<big> points to the first byte in the haystack.  C<big_end> points to one byte
 567 beyond the final byte in the haystack.  C<little> points to the first byte in
 568 the needle.  C<little_end> points to one byte beyond the final byte in the
 569 needle.  All the parameters must be non-C<NULL>.
 570
 571 The function returns C<NULL> if there is no occurrence of C<little> within
 572 C<big>.  If C<little> is the empty string, C<big> is returned.
 573
 574 Because this function operates at the byte level, and because of the inherent
 575 characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
 576 needle and the haystack are strings with the same UTF-8ness, but not if the
 577 UTF-8ness differs.
 578
 579 =cut
 580
 581 */
 582
 583 char *
 584 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 585 {
 586     PERL_ARGS_ASSERT_NINSTR;
 587
 588 #ifdef HAS_MEMMEM
 589     return ninstr(big, bigend, little, lend);
 590 #else
 591
 592     if (little >= lend)
 593         return (char*)big;
 594     {
 595         const char first = *little;
 596         const char *s, *x;
 597         bigend -= lend - little++;
 598     OUTER:
 599         while (big <= bigend) {
 600             if (*big++ == first) {
 601                 for (x=big,s=little; s < lend; x++,s++) {
 602                     if (*s != *x)
 603                         goto OUTER;
 604                 }
 605                 return (char*)(big-1);
 606             }
 607         }
 608     }
 609     return NULL;
 610
 611 #endif
 612
 613 }
 614
 615 /*
 616 =head1 Miscellaneous Functions
 617
 618 =for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
 619
 620 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
 621 sequence of bytes within another sequence, returning C<NULL> if there is no
 622 such occurrence.
 623
 624 =cut
 625
 626 */
 627
 628 char *
 629 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
 630 {
 631     const char *bigbeg;
 632     const I32 first = *little;
 633     const char * const littleend = lend;
 634
 635     PERL_ARGS_ASSERT_RNINSTR;
 636
 637     if (little >= littleend)
 638         return (char*)bigend;
 639     bigbeg = big;
 640     big = bigend - (littleend - little++);
 641     while (big >= bigbeg) {
 642         const char *s, *x;
 643         if (*big-- != first)
 644             continue;
 645         for (x=big+2,s=little; s < littleend; /**/ ) {
 646             if (*s != *x)
 647                 break;
 648             else {
 649                 x++;
 650                 s++;
 651             }
 652         }
 653         if (s >= littleend)
 654             return (char*)(big+1);
 655     }
 656     return NULL;
 657 }
 658
 659 /* As a space optimization, we do not compile tables for strings of length
 660    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 661    special-cased in fbm_instr().
 662
 663    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 664
 665 /*
 666 =head1 Miscellaneous Functions
 667
 668 =for apidoc fbm_compile
 669
 670 Analyses the string in order to make fast searches on it using C<fbm_instr()>
 671 -- the Boyer-Moore algorithm.
 672
 673 =cut
 674 */
 675
 676 void
 677 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 678 {
 679     const U8 *s;
 680     STRLEN i;
 681     STRLEN len;
 682     U32 frequency = 256;
 683     MAGIC *mg;
 684     PERL_DEB( STRLEN rarest = 0 );
 685
 686     PERL_ARGS_ASSERT_FBM_COMPILE;
 687
 688     if (isGV_with_GP(sv) || SvROK(sv))
 689         return;
 690
 691     if (SvVALID(sv))
 692         return;
 693
 694     if (flags & FBMcf_TAIL) {
 695         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 696         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
 697         if (mg && mg->mg_len >= 0)
 698             mg->mg_len++;
 699     }
 700     if (!SvPOK(sv) || SvNIOKp(sv))
 701         s = (U8*)SvPV_force_mutable(sv, len);
 702     else s = (U8 *)SvPV_mutable(sv, len);
 703     if (len == 0)               /* TAIL might be on a zero-length string. */
 704         return;
 705     SvUPGRADE(sv, SVt_PVMG);
 706     SvIOK_off(sv);
 707     SvNOK_off(sv);
 708     SvVALID_on(sv);
 709
 710     /* "deep magic", the comment used to add. The use of MAGIC itself isn't
 711        really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
 712        to call SvVALID_off() if the scalar was assigned to.
 713
 714        The comment itself (and "deeper magic" below) date back to
 715        378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
 716        str->str_pok |= 2;
 717        where the magic (presumably) was that the scalar had a BM table hidden
 718        inside itself.
 719
 720        As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
 721        the table instead of the previous (somewhat hacky) approach of co-opting
 722        the string buffer and storing it after the string.  */
 723
 724     assert(!mg_find(sv, PERL_MAGIC_bm));
 725     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
 726     assert(mg);
 727
 728     if (len > 2) {
 729         /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
 730            the BM table.  */
 731         const U8 mlen = (len>255) ? 255 : (U8)len;
 732         const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
 733         U8 *table;
 734
 735         Newx(table, 256, U8);
 736         memset((void*)table, mlen, 256);
 737         mg->mg_ptr = (char *)table;
 738         mg->mg_len = 256;
 739
 740         s += len - 1; /* last char */
 741         i = 0;
 742         while (s >= sb) {
 743             if (table[*s] == mlen)
 744                 table[*s] = (U8)i;
 745             s--, i++;
 746         }
 747     }
 748
 749     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
 750     for (i = 0; i < len; i++) {
 751         if (PL_freq[s[i]] < frequency) {
 752             PERL_DEB( rarest = i );
 753             frequency = PL_freq[s[i]];
 754         }
 755     }
 756     BmUSEFUL(sv) = 100;                 /* Initial value */
 757     if (flags & FBMcf_TAIL)
 758         SvTAIL_on(sv);
 759     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
 760                           s[rarest], (UV)rarest));
 761 }
 762
 763
 764 /*
 765 =for apidoc fbm_instr
 766
 767 Returns the location of the SV in the string delimited by C<big> and
 768 C<bigend> (C<bigend>) is the char following the last char).
 769 It returns C<NULL> if the string can't be found.  The C<sv>
 770 does not have to be C<fbm_compiled>, but the search will not be as fast
 771 then.
 772
 773 =cut
 774
 775 If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
 776 during FBM compilation due to FBMcf_TAIL in flags. It indicates that
 777 the littlestr must be anchored to the end of bigstr (or to any \n if
 778 FBMrf_MULTILINE).
 779
 780 E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
 781 while /abc$/ compiles to "abc\n" with SvTAIL() true.
 782
 783 A littlestr of "abc", !SvTAIL matches as /abc/;
 784 a littlestr of "ab\n", SvTAIL matches as:
 785    without FBMrf_MULTILINE: /ab\n?\z/
 786    with    FBMrf_MULTILINE: /ab\n/ || /ab\z/;
 787
 788 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
 789   "If SvTAIL is actually due to \Z or \z, this gives false positives
 790   if multiline".
 791 */
 792
 793
 794 char *
 795 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
 796 {
 797     unsigned char *s;
 798     STRLEN l;
 799     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
 800     STRLEN littlelen = l;
 801     const I32 multiline = flags & FBMrf_MULTILINE;
 802
 803     PERL_ARGS_ASSERT_FBM_INSTR;
 804
 805     if ((STRLEN)(bigend - big) < littlelen) {
 806         if ( SvTAIL(littlestr)
 807              && ((STRLEN)(bigend - big) == littlelen - 1)
 808              && (littlelen == 1
 809                  || (*big == *little &&
 810                      memEQ((char *)big, (char *)little, littlelen - 1))))
 811             return (char*)big;
 812         return NULL;
 813     }
 814
 815     switch (littlelen) { /* Special cases for 0, 1 and 2  */
 816     case 0:
 817         return (char*)big;              /* Cannot be SvTAIL! */
 818
 819     case 1:
 820             if (SvTAIL(littlestr) && !multiline) /* Anchor only! */
 821                 /* [-1] is safe because we know that bigend != big.  */
 822                 return (char *) (bigend - (bigend[-1] == '\n'));
 823
 824             s = (unsigned char *)memchr((void*)big, *little, bigend-big);
 825             if (s)
 826                 return (char *)s;
 827             if (SvTAIL(littlestr))
 828                 return (char *) bigend;
 829             return NULL;
 830
 831     case 2:
 832         if (SvTAIL(littlestr) && !multiline) {
 833             /* a littlestr with SvTAIL must be of the form "X\n" (where X
 834              * is a single char). It is anchored, and can only match
 835              * "....X\n"  or  "....X" */
 836             if (bigend[-2] == *little && bigend[-1] == '\n')
 837                 return (char*)bigend - 2;
 838             if (bigend[-1] == *little)
 839                 return (char*)bigend - 1;
 840             return NULL;
 841         }
 842
 843         {
 844             /* memchr() is likely to be very fast, possibly using whatever
 845              * hardware support is available, such as checking a whole
 846              * cache line in one instruction.
 847              * So for a 2 char pattern, calling memchr() is likely to be
 848              * faster than running FBM, or rolling our own. The previous
 849              * version of this code was roll-your-own which typically
 850              * only needed to read every 2nd char, which was good back in
 851              * the day, but no longer.
 852              */
 853             unsigned char c1 = little[0];
 854             unsigned char c2 = little[1];
 855
 856             /* *** for all this case, bigend points to the last char,
 857              * not the trailing \0: this makes the conditions slightly
 858              * simpler */
 859             bigend--;
 860             s = big;
 861             if (c1 != c2) {
 862                 while (s < bigend) {
 863                     /* do a quick test for c1 before calling memchr();
 864                      * this avoids the expensive fn call overhead when
 865                      * there are lots of c1's */
 866                     if (LIKELY(*s != c1)) {
 867                         s++;
 868                         s = (unsigned char *)memchr((void*)s, c1, bigend - s);
 869                         if (!s)
 870                             break;
 871                     }
 872                     if (s[1] == c2)
 873                         return (char*)s;
 874
 875                     /* failed; try searching for c2 this time; that way
 876                      * we don't go pathologically slow when the string
 877                      * consists mostly of c1's or vice versa.
 878                      */
 879                     s += 2;
 880                     if (s > bigend)
 881                         break;
 882                     s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
 883                     if (!s)
 884                         break;
 885                     if (s[-1] == c1)
 886                         return (char*)s - 1;
 887                 }
 888             }
 889             else {
 890                 /* c1, c2 the same */
 891                 while (s < bigend) {
 892                     if (s[0] == c1) {
 893                       got_1char:
 894                         if (s[1] == c1)
 895                             return (char*)s;
 896                         s += 2;
 897                     }
 898                     else {
 899                         s++;
 900                         s = (unsigned char *)memchr((void*)s, c1, bigend - s);
 901                         if (!s || s >= bigend)
 902                             break;
 903                         goto got_1char;
 904                     }
 905                 }
 906             }
 907
 908             /* failed to find 2 chars; try anchored match at end without
 909              * the \n */
 910             if (SvTAIL(littlestr) && bigend[0] == little[0])
 911                 return (char *)bigend;
 912             return NULL;
 913         }
 914
 915     default:
 916         break; /* Only lengths 0 1 and 2 have special-case code.  */
 917     }
 918
 919     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
 920         s = bigend - littlelen;
 921         if (s >= big && bigend[-1] == '\n' && *s == *little
 922             /* Automatically of length > 2 */
 923             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 924         {
 925             return (char*)s;            /* how sweet it is */
 926         }
 927         if (s[1] == *little
 928             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 929         {
 930             return (char*)s + 1;        /* how sweet it is */
 931         }
 932         return NULL;
 933     }
 934
 935     if (!SvVALID(littlestr)) {
 936         /* not compiled; use Perl_ninstr() instead */
 937         char * const b = ninstr((char*)big,(char*)bigend,
 938                          (char*)little, (char*)little + littlelen);
 939
 940         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
 941             /* Chop \n from littlestr: */
 942             s = bigend - littlelen + 1;
 943             if (*s == *little
 944                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 945             {
 946                 return (char*)s;
 947             }
 948             return NULL;
 949         }
 950         return b;
 951     }
 952
 953     /* Do actual FBM.  */
 954     if (littlelen > (STRLEN)(bigend - big))
 955         return NULL;
 956
 957     {
 958         const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
 959         const unsigned char *oldlittle;
 960
 961         assert(mg);
 962
 963         --littlelen;                    /* Last char found by table lookup */
 964
 965         s = big + littlelen;
 966         little += littlelen;            /* last char */
 967         oldlittle = little;
 968         if (s < bigend) {
 969             const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
 970             const unsigned char lastc = *little;
 971             I32 tmp;
 972
 973           top2:
 974             if ((tmp = table[*s])) {
 975                 /* *s != lastc; earliest position it could match now is
 976                  * tmp slots further on */
 977                 if ((s += tmp) >= bigend)
 978                     goto check_end;
 979                 if (LIKELY(*s != lastc)) {
 980                     s++;
 981                     s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
 982                     if (!s) {
 983                         s = bigend;
 984                         goto check_end;
 985                     }
 986                     goto top2;
 987                 }
 988             }
 989
 990
 991             /* hand-rolled strncmp(): less expensive than calling the
 992              * real function (maybe???) */
 993             {
 994                 unsigned char * const olds = s;
 995
 996                 tmp = littlelen;
 997
 998                 while (tmp--) {
 999                     if (*--s == *--little)
1000                         continue;
1001                     s = olds + 1;       /* here we pay the price for failure */
1002                     little = oldlittle;
1003                     if (s < bigend)     /* fake up continue to outer loop */
1004                         goto top2;
1005                     goto check_end;
1006                 }
1007                 return (char *)s;
1008             }
1009         }
1010       check_end:
1011         if ( s == bigend
1012              && SvTAIL(littlestr)
1013              && memEQ((char *)(bigend - littlelen),
1014                       (char *)(oldlittle - littlelen), littlelen) )
1015             return (char*)bigend - littlelen;
1016         return NULL;
1017     }
1018 }
1019
1020
1021 /*
1022 =for apidoc foldEQ
1023
1024 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1025 same
1026 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
1027 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
1028 range bytes match only themselves.
1029
1030 =cut
1031 */
1032
1033
1034 I32
1035 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1036 {
1037     const U8 *a = (const U8 *)s1;
1038     const U8 *b = (const U8 *)s2;
1039
1040     PERL_ARGS_ASSERT_FOLDEQ;
1041
1042     assert(len >= 0);
1043
1044     while (len--) {
1045         if (*a != *b && *a != PL_fold[*b])
1046             return 0;
1047         a++,b++;
1048     }
1049     return 1;
1050 }
1051 I32
1052 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1053 {
1054     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
1055      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1056      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
1057      * does it check that the strings each have at least 'len' characters */
1058
1059     const U8 *a = (const U8 *)s1;
1060     const U8 *b = (const U8 *)s2;
1061
1062     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1063
1064     assert(len >= 0);
1065
1066     while (len--) {
1067         if (*a != *b && *a != PL_fold_latin1[*b]) {
1068             return 0;
1069         }
1070         a++, b++;
1071     }
1072     return 1;
1073 }
1074
1075 /*
1076 =for apidoc foldEQ_locale
1077
1078 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1079 same case-insensitively in the current locale; false otherwise.
1080
1081 =cut
1082 */
1083
1084 I32
1085 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1086 {
1087     dVAR;
1088     const U8 *a = (const U8 *)s1;
1089     const U8 *b = (const U8 *)s2;
1090
1091     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1092
1093     assert(len >= 0);
1094
1095     while (len--) {
1096         if (*a != *b && *a != PL_fold_locale[*b])
1097             return 0;
1098         a++,b++;
1099     }
1100     return 1;
1101 }
1102
1103 /* copy a string to a safe spot */
1104
1105 /*
1106 =head1 Memory Management
1107
1108 =for apidoc savepv
1109
1110 Perl's version of C<strdup()>.  Returns a pointer to a newly allocated
1111 string which is a duplicate of C<pv>.  The size of the string is
1112 determined by C<strlen()>, which means it may not contain embedded C<NUL>
1113 characters and must have a trailing C<NUL>.  The memory allocated for the new
1114 string can be freed with the C<Safefree()> function.
1115
1116 On some platforms, Windows for example, all allocated memory owned by a thread
1117 is deallocated when that thread ends.  So if you need that not to happen, you
1118 need to use the shared memory functions, such as C<L</savesharedpv>>.
1119
1120 =cut
1121 */
1122
1123 char *
1124 Perl_savepv(pTHX_ const char *pv)
1125 {
1126     PERL_UNUSED_CONTEXT;
1127     if (!pv)
1128         return NULL;
1129     else {
1130         char *newaddr;
1131         const STRLEN pvlen = strlen(pv)+1;
1132         Newx(newaddr, pvlen, char);
1133         return (char*)memcpy(newaddr, pv, pvlen);
1134     }
1135 }
1136
1137 /* same thing but with a known length */
1138
1139 /*
1140 =for apidoc savepvn
1141
1142 Perl's version of what C<strndup()> would be if it existed.  Returns a
1143 pointer to a newly allocated string which is a duplicate of the first
1144 C<len> bytes from C<pv>, plus a trailing
1145 C<NUL> byte.  The memory allocated for
1146 the new string can be freed with the C<Safefree()> function.
1147
1148 On some platforms, Windows for example, all allocated memory owned by a thread
1149 is deallocated when that thread ends.  So if you need that not to happen, you
1150 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1151
1152 =cut
1153 */
1154
1155 char *
1156 Perl_savepvn(pTHX_ const char *pv, I32 len)
1157 {
1158     char *newaddr;
1159     PERL_UNUSED_CONTEXT;
1160
1161     assert(len >= 0);
1162
1163     Newx(newaddr,len+1,char);
1164     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1165     if (pv) {
1166         /* might not be null terminated */
1167         newaddr[len] = '\0';
1168         return (char *) CopyD(pv,newaddr,len,char);
1169     }
1170     else {
1171         return (char *) ZeroD(newaddr,len+1,char);
1172     }
1173 }
1174
1175 /*
1176 =for apidoc savesharedpv
1177
1178 A version of C<savepv()> which allocates the duplicate string in memory
1179 which is shared between threads.
1180
1181 =cut
1182 */
1183 char *
1184 Perl_savesharedpv(pTHX_ const char *pv)
1185 {
1186     char *newaddr;
1187     STRLEN pvlen;
1188
1189     PERL_UNUSED_CONTEXT;
1190
1191     if (!pv)
1192         return NULL;
1193
1194     pvlen = strlen(pv)+1;
1195     newaddr = (char*)PerlMemShared_malloc(pvlen);
1196     if (!newaddr) {
1197         croak_no_mem();
1198     }
1199     return (char*)memcpy(newaddr, pv, pvlen);
1200 }
1201
1202 /*
1203 =for apidoc savesharedpvn
1204
1205 A version of C<savepvn()> which allocates the duplicate string in memory
1206 which is shared between threads.  (With the specific difference that a C<NULL>
1207 pointer is not acceptable)
1208
1209 =cut
1210 */
1211 char *
1212 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1213 {
1214     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1215
1216     PERL_UNUSED_CONTEXT;
1217     /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1218
1219     if (!newaddr) {
1220         croak_no_mem();
1221     }
1222     newaddr[len] = '\0';
1223     return (char*)memcpy(newaddr, pv, len);
1224 }
1225
1226 /*
1227 =for apidoc savesvpv
1228
1229 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1230 the passed in SV using C<SvPV()>
1231
1232 On some platforms, Windows for example, all allocated memory owned by a thread
1233 is deallocated when that thread ends.  So if you need that not to happen, you
1234 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1235
1236 =cut
1237 */
1238
1239 char *
1240 Perl_savesvpv(pTHX_ SV *sv)
1241 {
1242     STRLEN len;
1243     const char * const pv = SvPV_const(sv, len);
1244     char *newaddr;
1245
1246     PERL_ARGS_ASSERT_SAVESVPV;
1247
1248     ++len;
1249     Newx(newaddr,len,char);
1250     return (char *) CopyD(pv,newaddr,len,char);
1251 }
1252
1253 /*
1254 =for apidoc savesharedsvpv
1255
1256 A version of C<savesharedpv()> which allocates the duplicate string in
1257 memory which is shared between threads.
1258
1259 =cut
1260 */
1261
1262 char *
1263 Perl_savesharedsvpv(pTHX_ SV *sv)
1264 {
1265     STRLEN len;
1266     const char * const pv = SvPV_const(sv, len);
1267
1268     PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1269
1270     return savesharedpvn(pv, len);
1271 }
1272
1273 /* the SV for Perl_form() and mess() is not kept in an arena */
1274
1275 STATIC SV *
1276 S_mess_alloc(pTHX)
1277 {
1278     SV *sv;
1279     XPVMG *any;
1280
1281     if (PL_phase != PERL_PHASE_DESTRUCT)
1282         return newSVpvs_flags("", SVs_TEMP);
1283
1284     if (PL_mess_sv)
1285         return PL_mess_sv;
1286
1287     /* Create as PVMG now, to avoid any upgrading later */
1288     Newx(sv, 1, SV);
1289     Newxz(any, 1, XPVMG);
1290     SvFLAGS(sv) = SVt_PVMG;
1291     SvANY(sv) = (void*)any;
1292     SvPV_set(sv, NULL);
1293     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1294     PL_mess_sv = sv;
1295     return sv;
1296 }
1297
1298 #if defined(PERL_IMPLICIT_CONTEXT)
1299 char *
1300 Perl_form_nocontext(const char* pat, ...)
1301 {
1302     dTHX;
1303     char *retval;
1304     va_list args;
1305     PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1306     va_start(args, pat);
1307     retval = vform(pat, &args);
1308     va_end(args);
1309     return retval;
1310 }
1311 #endif /* PERL_IMPLICIT_CONTEXT */
1312
1313 /*
1314 =head1 Miscellaneous Functions
1315 =for apidoc form
1316
1317 Takes a sprintf-style format pattern and conventional
1318 (non-SV) arguments and returns the formatted string.
1319
1320     (char *) Perl_form(pTHX_ const char* pat, ...)
1321
1322 can be used any place a string (char *) is required:
1323
1324     char * s = Perl_form("%d.%d",major,minor);
1325
1326 Uses a single private buffer so if you want to format several strings you
1327 must explicitly copy the earlier strings away (and free the copies when you
1328 are done).
1329
1330 =cut
1331 */
1332
1333 char *
1334 Perl_form(pTHX_ const char* pat, ...)
1335 {
1336     char *retval;
1337     va_list args;
1338     PERL_ARGS_ASSERT_FORM;
1339     va_start(args, pat);
1340     retval = vform(pat, &args);
1341     va_end(args);
1342     return retval;
1343 }
1344
1345 char *
1346 Perl_vform(pTHX_ const char *pat, va_list *args)
1347 {
1348     SV * const sv = mess_alloc();
1349     PERL_ARGS_ASSERT_VFORM;
1350     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1351     return SvPVX(sv);
1352 }
1353
1354 /*
1355 =for apidoc Am|SV *|mess|const char *pat|...
1356
1357 Take a sprintf-style format pattern and argument list.  These are used to
1358 generate a string message.  If the message does not end with a newline,
1359 then it will be extended with some indication of the current location
1360 in the code, as described for L</mess_sv>.
1361
1362 Normally, the resulting message is returned in a new mortal SV.
1363 During global destruction a single SV may be shared between uses of
1364 this function.
1365
1366 =cut
1367 */
1368
1369 #if defined(PERL_IMPLICIT_CONTEXT)
1370 SV *
1371 Perl_mess_nocontext(const char *pat, ...)
1372 {
1373     dTHX;
1374     SV *retval;
1375     va_list args;
1376     PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1377     va_start(args, pat);
1378     retval = vmess(pat, &args);
1379     va_end(args);
1380     return retval;
1381 }
1382 #endif /* PERL_IMPLICIT_CONTEXT */
1383
1384 SV *
1385 Perl_mess(pTHX_ const char *pat, ...)
1386 {
1387     SV *retval;
1388     va_list args;
1389     PERL_ARGS_ASSERT_MESS;
1390     va_start(args, pat);
1391     retval = vmess(pat, &args);
1392     va_end(args);
1393     return retval;
1394 }
1395
1396 const COP*
1397 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1398                        bool opnext)
1399 {
1400     /* Look for curop starting from o.  cop is the last COP we've seen. */
1401     /* opnext means that curop is actually the ->op_next of the op we are
1402        seeking. */
1403
1404     PERL_ARGS_ASSERT_CLOSEST_COP;
1405
1406     if (!o || !curop || (
1407         opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1408     ))
1409         return cop;
1410
1411     if (o->op_flags & OPf_KIDS) {
1412         const OP *kid;
1413         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1414             const COP *new_cop;
1415
1416             /* If the OP_NEXTSTATE has been optimised away we can still use it
1417              * the get the file and line number. */
1418
1419             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1420                 cop = (const COP *)kid;
1421
1422             /* Keep searching, and return when we've found something. */
1423
1424             new_cop = closest_cop(cop, kid, curop, opnext);
1425             if (new_cop)
1426                 return new_cop;
1427         }
1428     }
1429
1430     /* Nothing found. */
1431
1432     return NULL;
1433 }
1434
1435 /*
1436 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1437
1438 Expands a message, intended for the user, to include an indication of
1439 the current location in the code, if the message does not already appear
1440 to be complete.
1441
1442 C<basemsg> is the initial message or object.  If it is a reference, it
1443 will be used as-is and will be the result of this function.  Otherwise it
1444 is used as a string, and if it already ends with a newline, it is taken
1445 to be complete, and the result of this function will be the same string.
1446 If the message does not end with a newline, then a segment such as C<at
1447 foo.pl line 37> will be appended, and possibly other clauses indicating
1448 the current state of execution.  The resulting message will end with a
1449 dot and a newline.
1450
1451 Normally, the resulting message is returned in a new mortal SV.
1452 During global destruction a single SV may be shared between uses of this
1453 function.  If C<consume> is true, then the function is permitted (but not
1454 required) to modify and return C<basemsg> instead of allocating a new SV.
1455
1456 =cut
1457 */
1458
1459 SV *
1460 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1461 {
1462     SV *sv;
1463
1464 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1465     {
1466         char *ws;
1467         UV wi;
1468         /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1469         if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1470             && grok_atoUV(ws, &wi, NULL)
1471             && wi <= PERL_INT_MAX
1472         ) {
1473             Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1474         }
1475     }
1476 #endif
1477
1478     PERL_ARGS_ASSERT_MESS_SV;
1479
1480     if (SvROK(basemsg)) {
1481         if (consume) {
1482             sv = basemsg;
1483         }
1484         else {
1485             sv = mess_alloc();
1486             sv_setsv(sv, basemsg);
1487         }
1488         return sv;
1489     }
1490
1491     if (SvPOK(basemsg) && consume) {
1492         sv = basemsg;
1493     }
1494     else {
1495         sv = mess_alloc();
1496         sv_copypv(sv, basemsg);
1497     }
1498
1499     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1500         /*
1501          * Try and find the file and line for PL_op.  This will usually be
1502          * PL_curcop, but it might be a cop that has been optimised away.  We
1503          * can try to find such a cop by searching through the optree starting
1504          * from the sibling of PL_curcop.
1505          */
1506
1507         const COP *cop =
1508             closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1509         if (!cop)
1510             cop = PL_curcop;
1511
1512         if (CopLINE(cop))
1513             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1514             OutCopFILE(cop), (IV)CopLINE(cop));
1515         /* Seems that GvIO() can be untrustworthy during global destruction. */
1516         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1517                 && IoLINES(GvIOp(PL_last_in_gv)))
1518         {
1519             STRLEN l;
1520             const bool line_mode = (RsSIMPLE(PL_rs) &&
1521                                    *SvPV_const(PL_rs,l) == '\n' && l == 1);
1522             Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1523                            SVfARG(PL_last_in_gv == PL_argvgv
1524                                  ? &PL_sv_no
1525                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1526                            line_mode ? "line" : "chunk",
1527                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1528         }
1529         if (PL_phase == PERL_PHASE_DESTRUCT)
1530             sv_catpvs(sv, " during global destruction");
1531         sv_catpvs(sv, ".\n");
1532     }
1533     return sv;
1534 }
1535
1536 /*
1537 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1538
1539 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1540 argument list, respectively.  These are used to generate a string message.  If
1541 the
1542 message does not end with a newline, then it will be extended with
1543 some indication of the current location in the code, as described for
1544 L</mess_sv>.
1545
1546 Normally, the resulting message is returned in a new mortal SV.
1547 During global destruction a single SV may be shared between uses of
1548 this function.
1549
1550 =cut
1551 */
1552
1553 SV *
1554 Perl_vmess(pTHX_ const char *pat, va_list *args)
1555 {
1556     SV * const sv = mess_alloc();
1557
1558     PERL_ARGS_ASSERT_VMESS;
1559
1560     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1561     return mess_sv(sv, 1);
1562 }
1563
1564 void
1565 Perl_write_to_stderr(pTHX_ SV* msv)
1566 {
1567     IO *io;
1568     MAGIC *mg;
1569
1570     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1571
1572     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1573         && (io = GvIO(PL_stderrgv))
1574         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1575         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1576                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1577     else {
1578         PerlIO * const serr = Perl_error_log;
1579
1580         do_print(msv, serr);
1581         (void)PerlIO_flush(serr);
1582     }
1583 }
1584
1585 /*
1586 =head1 Warning and Dieing
1587 */
1588
1589 /* Common code used in dieing and warning */
1590
1591 STATIC SV *
1592 S_with_queued_errors(pTHX_ SV *ex)
1593 {
1594     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1595     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1596         sv_catsv(PL_errors, ex);
1597         ex = sv_mortalcopy(PL_errors);
1598         SvCUR_set(PL_errors, 0);
1599     }
1600     return ex;
1601 }
1602
1603 STATIC bool
1604 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1605 {
1606     HV *stash;
1607     GV *gv;
1608     CV *cv;
1609     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1610     /* sv_2cv might call Perl_croak() or Perl_warner() */
1611     SV * const oldhook = *hook;
1612
1613     if (!oldhook)
1614         return FALSE;
1615
1616     ENTER;
1617     SAVESPTR(*hook);
1618     *hook = NULL;
1619     cv = sv_2cv(oldhook, &stash, &gv, 0);
1620     LEAVE;
1621     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1622         dSP;
1623         SV *exarg;
1624
1625         ENTER;
1626         save_re_context();
1627         if (warn) {
1628             SAVESPTR(*hook);
1629             *hook = NULL;
1630         }
1631         exarg = newSVsv(ex);
1632         SvREADONLY_on(exarg);
1633         SAVEFREESV(exarg);
1634
1635         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1636         PUSHMARK(SP);
1637         XPUSHs(exarg);
1638         PUTBACK;
1639         call_sv(MUTABLE_SV(cv), G_DISCARD);
1640         POPSTACK;
1641         LEAVE;
1642         return TRUE;
1643     }
1644     return FALSE;
1645 }
1646
1647 /*
1648 =for apidoc Am|OP *|die_sv|SV *baseex
1649
1650 Behaves the same as L</croak_sv>, except for the return type.
1651 It should be used only where the C<OP *> return type is required.
1652 The function never actually returns.
1653
1654 =cut
1655 */
1656
1657 #ifdef _MSC_VER
1658 #  pragma warning( push )
1659 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1660     __declspec(noreturn) has non-void return type */
1661 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1662 __declspec(noreturn) has a return statement */
1663 #endif
1664 OP *
1665 Perl_die_sv(pTHX_ SV *baseex)
1666 {
1667     PERL_ARGS_ASSERT_DIE_SV;
1668     croak_sv(baseex);
1669     /* NOTREACHED */
1670     NORETURN_FUNCTION_END;
1671 }
1672 #ifdef _MSC_VER
1673 #  pragma warning( pop )
1674 #endif
1675
1676 /*
1677 =for apidoc Am|OP *|die|const char *pat|...
1678
1679 Behaves the same as L</croak>, except for the return type.
1680 It should be used only where the C<OP *> return type is required.
1681 The function never actually returns.
1682
1683 =cut
1684 */
1685
1686 #if defined(PERL_IMPLICIT_CONTEXT)
1687 #ifdef _MSC_VER
1688 #  pragma warning( push )
1689 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1690     __declspec(noreturn) has non-void return type */
1691 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1692 __declspec(noreturn) has a return statement */
1693 #endif
1694 OP *
1695 Perl_die_nocontext(const char* pat, ...)
1696 {
1697     dTHX;
1698     va_list args;
1699     va_start(args, pat);
1700     vcroak(pat, &args);
1701     NOT_REACHED; /* NOTREACHED */
1702     va_end(args);
1703     NORETURN_FUNCTION_END;
1704 }
1705 #ifdef _MSC_VER
1706 #  pragma warning( pop )
1707 #endif
1708 #endif /* PERL_IMPLICIT_CONTEXT */
1709
1710 #ifdef _MSC_VER
1711 #  pragma warning( push )
1712 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1713     __declspec(noreturn) has non-void return type */
1714 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1715 __declspec(noreturn) has a return statement */
1716 #endif
1717 OP *
1718 Perl_die(pTHX_ const char* pat, ...)
1719 {
1720     va_list args;
1721     va_start(args, pat);
1722     vcroak(pat, &args);
1723     NOT_REACHED; /* NOTREACHED */
1724     va_end(args);
1725     NORETURN_FUNCTION_END;
1726 }
1727 #ifdef _MSC_VER
1728 #  pragma warning( pop )
1729 #endif
1730
1731 /*
1732 =for apidoc Am|void|croak_sv|SV *baseex
1733
1734 This is an XS interface to Perl's C<die> function.
1735
1736 C<baseex> is the error message or object.  If it is a reference, it
1737 will be used as-is.  Otherwise it is used as a string, and if it does
1738 not end with a newline then it will be extended with some indication of
1739 the current location in the code, as described for L</mess_sv>.
1740
1741 The error message or object will be used as an exception, by default
1742 returning control to the nearest enclosing C<eval>, but subject to
1743 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1744 function never returns normally.
1745
1746 To die with a simple string message, the L</croak> function may be
1747 more convenient.
1748
1749 =cut
1750 */
1751
1752 void
1753 Perl_croak_sv(pTHX_ SV *baseex)
1754 {
1755     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1756     PERL_ARGS_ASSERT_CROAK_SV;
1757     invoke_exception_hook(ex, FALSE);
1758     die_unwind(ex);
1759 }
1760
1761 /*
1762 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1763
1764 This is an XS interface to Perl's C<die> function.
1765
1766 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1767 argument list.  These are used to generate a string message.  If the
1768 message does not end with a newline, then it will be extended with
1769 some indication of the current location in the code, as described for
1770 L</mess_sv>.
1771
1772 The error message will be used as an exception, by default
1773 returning control to the nearest enclosing C<eval>, but subject to
1774 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1775 function never returns normally.
1776
1777 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1778 (C<$@>) will be used as an error message or object instead of building an
1779 error message from arguments.  If you want to throw a non-string object,
1780 or build an error message in an SV yourself, it is preferable to use
1781 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1782
1783 =cut
1784 */
1785
1786 void
1787 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1788 {
1789     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1790     invoke_exception_hook(ex, FALSE);
1791     die_unwind(ex);
1792 }
1793
1794 /*
1795 =for apidoc Am|void|croak|const char *pat|...
1796
1797 This is an XS interface to Perl's C<die> function.
1798
1799 Take a sprintf-style format pattern and argument list.  These are used to
1800 generate a string message.  If the message does not end with a newline,
1801 then it will be extended with some indication of the current location
1802 in the code, as described for L</mess_sv>.
1803
1804 The error message will be used as an exception, by default
1805 returning control to the nearest enclosing C<eval>, but subject to
1806 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1807 function never returns normally.
1808
1809 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1810 (C<$@>) will be used as an error message or object instead of building an
1811 error message from arguments.  If you want to throw a non-string object,
1812 or build an error message in an SV yourself, it is preferable to use
1813 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1814
1815 =cut
1816 */
1817
1818 #if defined(PERL_IMPLICIT_CONTEXT)
1819 void
1820 Perl_croak_nocontext(const char *pat, ...)
1821 {
1822     dTHX;
1823     va_list args;
1824     va_start(args, pat);
1825     vcroak(pat, &args);
1826     NOT_REACHED; /* NOTREACHED */
1827     va_end(args);
1828 }
1829 #endif /* PERL_IMPLICIT_CONTEXT */
1830
1831 void
1832 Perl_croak(pTHX_ const char *pat, ...)
1833 {
1834     va_list args;
1835     va_start(args, pat);
1836     vcroak(pat, &args);
1837     NOT_REACHED; /* NOTREACHED */
1838     va_end(args);
1839 }
1840
1841 /*
1842 =for apidoc Am|void|croak_no_modify
1843
1844 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1845 terser object code than using C<Perl_croak>.  Less code used on exception code
1846 paths reduces CPU cache pressure.
1847
1848 =cut
1849 */
1850
1851 void
1852 Perl_croak_no_modify(void)
1853 {
1854     Perl_croak_nocontext( "%s", PL_no_modify);
1855 }
1856
1857 /* does not return, used in util.c perlio.c and win32.c
1858    This is typically called when malloc returns NULL.
1859 */
1860 void
1861 Perl_croak_no_mem(void)
1862 {
1863     dTHX;
1864
1865     int fd = PerlIO_fileno(Perl_error_log);
1866     if (fd < 0)
1867         SETERRNO(EBADF,RMS_IFI);
1868     else {
1869         /* Can't use PerlIO to write as it allocates memory */
1870         PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
1871     }
1872     my_exit(1);
1873 }
1874
1875 /* does not return, used only in POPSTACK */
1876 void
1877 Perl_croak_popstack(void)
1878 {
1879     dTHX;
1880     PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1881     my_exit(1);
1882 }
1883
1884 /*
1885 =for apidoc Am|void|warn_sv|SV *baseex
1886
1887 This is an XS interface to Perl's C<warn> function.
1888
1889 C<baseex> is the error message or object.  If it is a reference, it
1890 will be used as-is.  Otherwise it is used as a string, and if it does
1891 not end with a newline then it will be extended with some indication of
1892 the current location in the code, as described for L</mess_sv>.
1893
1894 The error message or object will by default be written to standard error,
1895 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1896
1897 To warn with a simple string message, the L</warn> function may be
1898 more convenient.
1899
1900 =cut
1901 */
1902
1903 void
1904 Perl_warn_sv(pTHX_ SV *baseex)
1905 {
1906     SV *ex = mess_sv(baseex, 0);
1907     PERL_ARGS_ASSERT_WARN_SV;
1908     if (!invoke_exception_hook(ex, TRUE))
1909         write_to_stderr(ex);
1910 }
1911
1912 /*
1913 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1914
1915 This is an XS interface to Perl's C<warn> function.
1916
1917 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1918 argument list.  These are used to generate a string message.  If the
1919 message does not end with a newline, then it will be extended with
1920 some indication of the current location in the code, as described for
1921 L</mess_sv>.
1922
1923 The error message or object will by default be written to standard error,
1924 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1925
1926 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1927
1928 =cut
1929 */
1930
1931 void
1932 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1933 {
1934     SV *ex = vmess(pat, args);
1935     PERL_ARGS_ASSERT_VWARN;
1936     if (!invoke_exception_hook(ex, TRUE))
1937         write_to_stderr(ex);
1938 }
1939
1940 /*
1941 =for apidoc Am|void|warn|const char *pat|...
1942
1943 This is an XS interface to Perl's C<warn> function.
1944
1945 Take a sprintf-style format pattern and argument list.  These are used to
1946 generate a string message.  If the message does not end with a newline,
1947 then it will be extended with some indication of the current location
1948 in the code, as described for L</mess_sv>.
1949
1950 The error message or object will by default be written to standard error,
1951 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1952
1953 Unlike with L</croak>, C<pat> is not permitted to be null.
1954
1955 =cut
1956 */
1957
1958 #if defined(PERL_IMPLICIT_CONTEXT)
1959 void
1960 Perl_warn_nocontext(const char *pat, ...)
1961 {
1962     dTHX;
1963     va_list args;
1964     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1965     va_start(args, pat);
1966     vwarn(pat, &args);
1967     va_end(args);
1968 }
1969 #endif /* PERL_IMPLICIT_CONTEXT */
1970
1971 void
1972 Perl_warn(pTHX_ const char *pat, ...)
1973 {
1974     va_list args;
1975     PERL_ARGS_ASSERT_WARN;
1976     va_start(args, pat);
1977     vwarn(pat, &args);
1978     va_end(args);
1979 }
1980
1981 #if defined(PERL_IMPLICIT_CONTEXT)
1982 void
1983 Perl_warner_nocontext(U32 err, const char *pat, ...)
1984 {
1985     dTHX;
1986     va_list args;
1987     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1988     va_start(args, pat);
1989     vwarner(err, pat, &args);
1990     va_end(args);
1991 }
1992 #endif /* PERL_IMPLICIT_CONTEXT */
1993
1994 void
1995 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1996 {
1997     PERL_ARGS_ASSERT_CK_WARNER_D;
1998
1999     if (Perl_ckwarn_d(aTHX_ err)) {
2000         va_list args;
2001         va_start(args, pat);
2002         vwarner(err, pat, &args);
2003         va_end(args);
2004     }
2005 }
2006
2007 void
2008 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2009 {
2010     PERL_ARGS_ASSERT_CK_WARNER;
2011
2012     if (Perl_ckwarn(aTHX_ err)) {
2013         va_list args;
2014         va_start(args, pat);
2015         vwarner(err, pat, &args);
2016         va_end(args);
2017     }
2018 }
2019
2020 void
2021 Perl_warner(pTHX_ U32  err, const char* pat,...)
2022 {
2023     va_list args;
2024     PERL_ARGS_ASSERT_WARNER;
2025     va_start(args, pat);
2026     vwarner(err, pat, &args);
2027     va_end(args);
2028 }
2029
2030 void
2031 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
2032 {
2033     dVAR;
2034     PERL_ARGS_ASSERT_VWARNER;
2035     if (
2036         (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2037         !(PL_in_eval & EVAL_KEEPERR)
2038     ) {
2039         SV * const msv = vmess(pat, args);
2040
2041         if (PL_parser && PL_parser->error_count) {
2042             qerror(msv);
2043         }
2044         else {
2045             invoke_exception_hook(msv, FALSE);
2046             die_unwind(msv);
2047         }
2048     }
2049     else {
2050         Perl_vwarn(aTHX_ pat, args);
2051     }
2052 }
2053
2054 /* implements the ckWARN? macros */
2055
2056 bool
2057 Perl_ckwarn(pTHX_ U32 w)
2058 {
2059     /* If lexical warnings have not been set, use $^W.  */
2060     if (isLEXWARN_off)
2061         return PL_dowarn & G_WARN_ON;
2062
2063     return ckwarn_common(w);
2064 }
2065
2066 /* implements the ckWARN?_d macro */
2067
2068 bool
2069 Perl_ckwarn_d(pTHX_ U32 w)
2070 {
2071     /* If lexical warnings have not been set then default classes warn.  */
2072     if (isLEXWARN_off)
2073         return TRUE;
2074
2075     return ckwarn_common(w);
2076 }
2077
2078 static bool
2079 S_ckwarn_common(pTHX_ U32 w)
2080 {
2081     if (PL_curcop->cop_warnings == pWARN_ALL)
2082         return TRUE;
2083
2084     if (PL_curcop->cop_warnings == pWARN_NONE)
2085         return FALSE;
2086
2087     /* Check the assumption that at least the first slot is non-zero.  */
2088     assert(unpackWARN1(w));
2089
2090     /* Check the assumption that it is valid to stop as soon as a zero slot is
2091        seen.  */
2092     if (!unpackWARN2(w)) {
2093         assert(!unpackWARN3(w));
2094         assert(!unpackWARN4(w));
2095     } else if (!unpackWARN3(w)) {
2096         assert(!unpackWARN4(w));
2097     }
2098
2099     /* Right, dealt with all the special cases, which are implemented as non-
2100        pointers, so there is a pointer to a real warnings mask.  */
2101     do {
2102         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2103             return TRUE;
2104     } while (w >>= WARNshift);
2105
2106     return FALSE;
2107 }
2108
2109 /* Set buffer=NULL to get a new one.  */
2110 STRLEN *
2111 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2112                            STRLEN size) {
2113     const MEM_SIZE len_wanted =
2114         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2115     PERL_UNUSED_CONTEXT;
2116     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2117
2118     buffer = (STRLEN*)
2119         (specialWARN(buffer) ?
2120          PerlMemShared_malloc(len_wanted) :
2121          PerlMemShared_realloc(buffer, len_wanted));
2122     buffer[0] = size;
2123     Copy(bits, (buffer + 1), size, char);
2124     if (size < WARNsize)
2125         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2126     return buffer;
2127 }
2128
2129 /* since we've already done strlen() for both nam and val
2130  * we can use that info to make things faster than
2131  * sprintf(s, "%s=%s", nam, val)
2132  */
2133 #define my_setenv_format(s, nam, nlen, val, vlen) \
2134    Copy(nam, s, nlen, char); \
2135    *(s+nlen) = '='; \
2136    Copy(val, s+(nlen+1), vlen, char); \
2137    *(s+(nlen+1+vlen)) = '\0'
2138
2139 #ifdef USE_ENVIRON_ARRAY
2140        /* VMS' my_setenv() is in vms.c */
2141 #if !defined(WIN32) && !defined(NETWARE)
2142 void
2143 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2144 {
2145   dVAR;
2146 #ifdef __amigaos4__
2147   amigaos4_obtain_environ(__FUNCTION__);
2148 #endif
2149 #ifdef USE_ITHREADS
2150   /* only parent thread can modify process environment */
2151   if (PL_curinterp == aTHX)
2152 #endif
2153   {
2154 #ifndef PERL_USE_SAFE_PUTENV
2155     if (!PL_use_safe_putenv) {
2156         /* most putenv()s leak, so we manipulate environ directly */
2157         I32 i;
2158         const I32 len = strlen(nam);
2159         int nlen, vlen;
2160
2161         /* where does it go? */
2162         for (i = 0; environ[i]; i++) {
2163             if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2164                 break;
2165         }
2166
2167         if (environ == PL_origenviron) {   /* need we copy environment? */
2168             I32 j;
2169             I32 max;
2170             char **tmpenv;
2171
2172             max = i;
2173             while (environ[max])
2174                 max++;
2175             tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2176             for (j=0; j<max; j++) {         /* copy environment */
2177                 const int len = strlen(environ[j]);
2178                 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2179                 Copy(environ[j], tmpenv[j], len+1, char);
2180             }
2181             tmpenv[max] = NULL;
2182             environ = tmpenv;               /* tell exec where it is now */
2183         }
2184         if (!val) {
2185             safesysfree(environ[i]);
2186             while (environ[i]) {
2187                 environ[i] = environ[i+1];
2188                 i++;
2189             }
2190 #ifdef __amigaos4__
2191             goto my_setenv_out;
2192 #else
2193             return;
2194 #endif
2195         }
2196         if (!environ[i]) {                 /* does not exist yet */
2197             environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2198             environ[i+1] = NULL;    /* make sure it's null terminated */
2199         }
2200         else
2201             safesysfree(environ[i]);
2202         nlen = strlen(nam);
2203         vlen = strlen(val);
2204
2205         environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2206         /* all that work just for this */
2207         my_setenv_format(environ[i], nam, nlen, val, vlen);
2208     } else {
2209 # endif
2210     /* This next branch should only be called #if defined(HAS_SETENV), but
2211        Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
2212        were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2213     */
2214 #   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2215 #       if defined(HAS_UNSETENV)
2216         if (val == NULL) {
2217             (void)unsetenv(nam);
2218         } else {
2219             (void)setenv(nam, val, 1);
2220         }
2221 #       else /* ! HAS_UNSETENV */
2222         (void)setenv(nam, val, 1);
2223 #       endif /* HAS_UNSETENV */
2224 #   else
2225 #       if defined(HAS_UNSETENV)
2226         if (val == NULL) {
2227             if (environ) /* old glibc can crash with null environ */
2228                 (void)unsetenv(nam);
2229         } else {
2230             const int nlen = strlen(nam);
2231             const int vlen = strlen(val);
2232             char * const new_env =
2233                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2234             my_setenv_format(new_env, nam, nlen, val, vlen);
2235             (void)putenv(new_env);
2236         }
2237 #       else /* ! HAS_UNSETENV */
2238         char *new_env;
2239         const int nlen = strlen(nam);
2240         int vlen;
2241         if (!val) {
2242            val = "";
2243         }
2244         vlen = strlen(val);
2245         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2246         /* all that work just for this */
2247         my_setenv_format(new_env, nam, nlen, val, vlen);
2248         (void)putenv(new_env);
2249 #       endif /* HAS_UNSETENV */
2250 #   endif /* __CYGWIN__ */
2251 #ifndef PERL_USE_SAFE_PUTENV
2252     }
2253 #endif
2254   }
2255 #ifdef __amigaos4__
2256 my_setenv_out:
2257   amigaos4_release_environ(__FUNCTION__);
2258 #endif
2259 }
2260
2261 #else /* WIN32 || NETWARE */
2262
2263 void
2264 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2265 {
2266     dVAR;
2267     char *envstr;
2268     const int nlen = strlen(nam);
2269     int vlen;
2270
2271     if (!val) {
2272        val = "";
2273     }
2274     vlen = strlen(val);
2275     Newx(envstr, nlen+vlen+2, char);
2276     my_setenv_format(envstr, nam, nlen, val, vlen);
2277     (void)PerlEnv_putenv(envstr);
2278     Safefree(envstr);
2279 }
2280
2281 #endif /* WIN32 || NETWARE */
2282
2283 #endif /* !VMS */
2284
2285 #ifdef UNLINK_ALL_VERSIONS
2286 I32
2287 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2288 {
2289     I32 retries = 0;
2290
2291     PERL_ARGS_ASSERT_UNLNK;
2292
2293     while (PerlLIO_unlink(f) >= 0)
2294         retries++;
2295     return retries ? 0 : -1;
2296 }
2297 #endif
2298
2299 /* this is a drop-in replacement for bcopy(), except for the return
2300  * value, which we need to be able to emulate memcpy()  */
2301 #if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
2302 void *
2303 Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
2304 {
2305 #if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
2306     bcopy(vfrom, vto, len);
2307 #else
2308     const unsigned char *from = (const unsigned char *)vfrom;
2309     unsigned char *to = (unsigned char *)vto;
2310
2311     PERL_ARGS_ASSERT_MY_BCOPY;
2312
2313     if (from - to >= 0) {
2314         while (len--)
2315             *to++ = *from++;
2316     }
2317     else {
2318         to += len;
2319         from += len;
2320         while (len--)
2321             *(--to) = *(--from);
2322     }
2323 #endif
2324
2325     return vto;
2326 }
2327 #endif
2328
2329 /* this is a drop-in replacement for memset() */
2330 #ifndef HAS_MEMSET
2331 void *
2332 Perl_my_memset(void *vloc, int ch, size_t len)
2333 {
2334     unsigned char *loc = (unsigned char *)vloc;
2335
2336     PERL_ARGS_ASSERT_MY_MEMSET;
2337
2338     while (len--)
2339         *loc++ = ch;
2340     return vloc;
2341 }
2342 #endif
2343
2344 /* this is a drop-in replacement for bzero() */
2345 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2346 void *
2347 Perl_my_bzero(void *vloc, size_t len)
2348 {
2349     unsigned char *loc = (unsigned char *)vloc;
2350
2351     PERL_ARGS_ASSERT_MY_BZERO;
2352
2353     while (len--)
2354         *loc++ = 0;
2355     return vloc;
2356 }
2357 #endif
2358
2359 /* this is a drop-in replacement for memcmp() */
2360 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2361 int
2362 Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
2363 {
2364     const U8 *a = (const U8 *)vs1;
2365     const U8 *b = (const U8 *)vs2;
2366     int tmp;
2367
2368     PERL_ARGS_ASSERT_MY_MEMCMP;
2369
2370     while (len--) {
2371         if ((tmp = *a++ - *b++))
2372             return tmp;
2373     }
2374     return 0;
2375 }
2376 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2377
2378 #ifndef HAS_VPRINTF
2379 /* This vsprintf replacement should generally never get used, since
2380    vsprintf was available in both System V and BSD 2.11.  (There may
2381    be some cross-compilation or embedded set-ups where it is needed,
2382    however.)
2383
2384    If you encounter a problem in this function, it's probably a symptom
2385    that Configure failed to detect your system's vprintf() function.
2386    See the section on "item vsprintf" in the INSTALL file.
2387
2388    This version may compile on systems with BSD-ish <stdio.h>,
2389    but probably won't on others.
2390 */
2391
2392 #ifdef USE_CHAR_VSPRINTF
2393 char *
2394 #else
2395 int
2396 #endif
2397 vsprintf(char *dest, const char *pat, void *args)
2398 {
2399     FILE fakebuf;
2400
2401 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2402     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2403     FILE_cnt(&fakebuf) = 32767;
2404 #else
2405     /* These probably won't compile -- If you really need
2406        this, you'll have to figure out some other method. */
2407     fakebuf._ptr = dest;
2408     fakebuf._cnt = 32767;
2409 #endif
2410 #ifndef _IOSTRG
2411 #define _IOSTRG 0
2412 #endif
2413     fakebuf._flag = _IOWRT|_IOSTRG;
2414     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2415 #if defined(STDIO_PTR_LVALUE)
2416     *(FILE_ptr(&fakebuf)++) = '\0';
2417 #else
2418     /* PerlIO has probably #defined away fputc, but we want it here. */
2419 #  ifdef fputc
2420 #    undef fputc  /* XXX Should really restore it later */
2421 #  endif
2422     (void)fputc('\0', &fakebuf);
2423 #endif
2424 #ifdef USE_CHAR_VSPRINTF
2425     return(dest);
2426 #else
2427     return 0;           /* perl doesn't use return value */
2428 #endif
2429 }
2430
2431 #endif /* HAS_VPRINTF */
2432
2433 PerlIO *
2434 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2435 {
2436 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2437     int p[2];
2438     I32 This, that;
2439     Pid_t pid;
2440     SV *sv;
2441     I32 did_pipes = 0;
2442     int pp[2];
2443
2444     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2445
2446     PERL_FLUSHALL_FOR_CHILD;
2447     This = (*mode == 'w');
2448     that = !This;
2449     if (TAINTING_get) {
2450         taint_env();
2451         taint_proper("Insecure %s%s", "EXEC");
2452     }
2453     if (PerlProc_pipe(p) < 0)
2454         return NULL;
2455     /* Try for another pipe pair for error return */
2456     if (PerlProc_pipe(pp) >= 0)
2457         did_pipes = 1;
2458     while ((pid = PerlProc_fork()) < 0) {
2459         if (errno != EAGAIN) {
2460             PerlLIO_close(p[This]);
2461             PerlLIO_close(p[that]);
2462             if (did_pipes) {
2463                 PerlLIO_close(pp[0]);
2464                 PerlLIO_close(pp[1]);
2465             }
2466             return NULL;
2467         }
2468         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2469         sleep(5);
2470     }
2471     if (pid == 0) {
2472         /* Child */
2473 #undef THIS
2474 #undef THAT
2475 #define THIS that
2476 #define THAT This
2477         /* Close parent's end of error status pipe (if any) */
2478         if (did_pipes) {
2479             PerlLIO_close(pp[0]);
2480 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2481             /* Close error pipe automatically if exec works */
2482             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2483                 return NULL;
2484 #endif
2485         }
2486         /* Now dup our end of _the_ pipe to right position */
2487         if (p[THIS] != (*mode == 'r')) {
2488             PerlLIO_dup2(p[THIS], *mode == 'r');
2489             PerlLIO_close(p[THIS]);
2490             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2491                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2492         }
2493         else
2494             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2495 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2496         /* No automatic close - do it by hand */
2497 #  ifndef NOFILE
2498 #  define NOFILE 20
2499 #  endif
2500         {
2501             int fd;
2502
2503             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2504                 if (fd != pp[1])
2505                     PerlLIO_close(fd);
2506             }
2507         }
2508 #endif
2509         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2510         PerlProc__exit(1);
2511 #undef THIS
2512 #undef THAT
2513     }
2514     /* Parent */
2515     do_execfree();      /* free any memory malloced by child on fork */
2516     if (did_pipes)
2517         PerlLIO_close(pp[1]);
2518     /* Keep the lower of the two fd numbers */
2519     if (p[that] < p[This]) {
2520         PerlLIO_dup2(p[This], p[that]);
2521         PerlLIO_close(p[This]);
2522         p[This] = p[that];
2523     }
2524     else
2525         PerlLIO_close(p[that]);         /* close child's end of pipe */
2526
2527     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2528     SvUPGRADE(sv,SVt_IV);
2529     SvIV_set(sv, pid);
2530     PL_forkprocess = pid;
2531     /* If we managed to get status pipe check for exec fail */
2532     if (did_pipes && pid > 0) {
2533         int errkid;
2534         unsigned n = 0;
2535         SSize_t n1;
2536
2537         while (n < sizeof(int)) {
2538             n1 = PerlLIO_read(pp[0],
2539                               (void*)(((char*)&errkid)+n),
2540                               (sizeof(int)) - n);
2541             if (n1 <= 0)
2542                 break;
2543             n += n1;
2544         }
2545         PerlLIO_close(pp[0]);
2546         did_pipes = 0;
2547         if (n) {                        /* Error */
2548             int pid2, status;
2549             PerlLIO_close(p[This]);
2550             if (n != sizeof(int))
2551                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2552             do {
2553                 pid2 = wait4pid(pid, &status, 0);
2554             } while (pid2 == -1 && errno == EINTR);
2555             errno = errkid;             /* Propagate errno from kid */
2556             return NULL;
2557         }
2558     }
2559     if (did_pipes)
2560          PerlLIO_close(pp[0]);
2561     return PerlIO_fdopen(p[This], mode);
2562 #else
2563 #  if defined(OS2)      /* Same, without fork()ing and all extra overhead... */
2564     return my_syspopen4(aTHX_ NULL, mode, n, args);
2565 #  elif defined(WIN32)
2566     return win32_popenlist(mode, n, args);
2567 #  else
2568     Perl_croak(aTHX_ "List form of piped open not implemented");
2569     return (PerlIO *) NULL;
2570 #  endif
2571 #endif
2572 }
2573
2574     /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2575 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2576 PerlIO *
2577 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2578 {
2579     int p[2];
2580     I32 This, that;
2581     Pid_t pid;
2582     SV *sv;
2583     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2584     I32 did_pipes = 0;
2585     int pp[2];
2586
2587     PERL_ARGS_ASSERT_MY_POPEN;
2588
2589     PERL_FLUSHALL_FOR_CHILD;
2590 #ifdef OS2
2591     if (doexec) {
2592         return my_syspopen(aTHX_ cmd,mode);
2593     }
2594 #endif
2595     This = (*mode == 'w');
2596     that = !This;
2597     if (doexec && TAINTING_get) {
2598         taint_env();
2599         taint_proper("Insecure %s%s", "EXEC");
2600     }
2601     if (PerlProc_pipe(p) < 0)
2602         return NULL;
2603     if (doexec && PerlProc_pipe(pp) >= 0)
2604         did_pipes = 1;
2605     while ((pid = PerlProc_fork()) < 0) {
2606         if (errno != EAGAIN) {
2607             PerlLIO_close(p[This]);
2608             PerlLIO_close(p[that]);
2609             if (did_pipes) {
2610                 PerlLIO_close(pp[0]);
2611                 PerlLIO_close(pp[1]);
2612             }
2613             if (!doexec)
2614                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2615             return NULL;
2616         }
2617         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2618         sleep(5);
2619     }
2620     if (pid == 0) {
2621
2622 #undef THIS
2623 #undef THAT
2624 #define THIS that
2625 #define THAT This
2626         if (did_pipes) {
2627             PerlLIO_close(pp[0]);
2628 #if defined(HAS_FCNTL) && defined(F_SETFD)
2629             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2630                 return NULL;
2631 #endif
2632         }
2633         if (p[THIS] != (*mode == 'r')) {
2634             PerlLIO_dup2(p[THIS], *mode == 'r');
2635             PerlLIO_close(p[THIS]);
2636             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2637                 PerlLIO_close(p[THAT]);
2638         }
2639         else
2640             PerlLIO_close(p[THAT]);
2641 #ifndef OS2
2642         if (doexec) {
2643 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2644 #ifndef NOFILE
2645 #define NOFILE 20
2646 #endif
2647             {
2648                 int fd;
2649
2650                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2651                     if (fd != pp[1])
2652                         PerlLIO_close(fd);
2653             }
2654 #endif
2655             /* may or may not use the shell */
2656             do_exec3(cmd, pp[1], did_pipes);
2657             PerlProc__exit(1);
2658         }
2659 #endif  /* defined OS2 */
2660
2661 #ifdef PERLIO_USING_CRLF
2662    /* Since we circumvent IO layers when we manipulate low-level
2663       filedescriptors directly, need to manually switch to the
2664       default, binary, low-level mode; see PerlIOBuf_open(). */
2665    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2666 #endif
2667         PL_forkprocess = 0;
2668 #ifdef PERL_USES_PL_PIDSTATUS
2669         hv_clear(PL_pidstatus); /* we have no children */
2670 #endif
2671         return NULL;
2672 #undef THIS
2673 #undef THAT
2674     }
2675     do_execfree();      /* free any memory malloced by child on vfork */
2676     if (did_pipes)
2677         PerlLIO_close(pp[1]);
2678     if (p[that] < p[This]) {
2679         PerlLIO_dup2(p[This], p[that]);
2680         PerlLIO_close(p[This]);
2681         p[This] = p[that];
2682     }
2683     else
2684         PerlLIO_close(p[that]);
2685
2686     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2687     SvUPGRADE(sv,SVt_IV);
2688     SvIV_set(sv, pid);
2689     PL_forkprocess = pid;
2690     if (did_pipes && pid > 0) {
2691         int errkid;
2692         unsigned n = 0;
2693         SSize_t n1;
2694
2695         while (n < sizeof(int)) {
2696             n1 = PerlLIO_read(pp[0],
2697                               (void*)(((char*)&errkid)+n),
2698                               (sizeof(int)) - n);
2699             if (n1 <= 0)
2700                 break;
2701             n += n1;
2702         }
2703         PerlLIO_close(pp[0]);
2704         did_pipes = 0;
2705         if (n) {                        /* Error */
2706             int pid2, status;
2707             PerlLIO_close(p[This]);
2708             if (n != sizeof(int))
2709                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2710             do {
2711                 pid2 = wait4pid(pid, &status, 0);
2712             } while (pid2 == -1 && errno == EINTR);
2713             errno = errkid;             /* Propagate errno from kid */
2714             return NULL;
2715         }
2716     }
2717     if (did_pipes)
2718          PerlLIO_close(pp[0]);
2719     return PerlIO_fdopen(p[This], mode);
2720 }
2721 #else
2722 #if defined(DJGPP)
2723 FILE *djgpp_popen();
2724 PerlIO *
2725 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2726 {
2727     PERL_FLUSHALL_FOR_CHILD;
2728     /* Call system's popen() to get a FILE *, then import it.
2729        used 0 for 2nd parameter to PerlIO_importFILE;
2730        apparently not used
2731     */
2732     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2733 }
2734 #else
2735 #if defined(__LIBCATAMOUNT__)
2736 PerlIO *
2737 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2738 {
2739     return NULL;
2740 }
2741 #endif
2742 #endif
2743
2744 #endif /* !DOSISH */
2745
2746 /* this is called in parent before the fork() */
2747 void
2748 Perl_atfork_lock(void)
2749 #if defined(USE_ITHREADS)
2750 #  ifdef USE_PERLIO
2751   PERL_TSA_ACQUIRE(PL_perlio_mutex)
2752 #  endif
2753 #  ifdef MYMALLOC
2754   PERL_TSA_ACQUIRE(PL_malloc_mutex)
2755 #  endif
2756   PERL_TSA_ACQUIRE(PL_op_mutex)
2757 #endif
2758 {
2759 #if defined(USE_ITHREADS)
2760     dVAR;
2761     /* locks must be held in locking order (if any) */
2762 #  ifdef USE_PERLIO
2763     MUTEX_LOCK(&PL_perlio_mutex);
2764 #  endif
2765 #  ifdef MYMALLOC
2766     MUTEX_LOCK(&PL_malloc_mutex);
2767 #  endif
2768     OP_REFCNT_LOCK;
2769 #endif
2770 }
2771
2772 /* this is called in both parent and child after the fork() */
2773 void
2774 Perl_atfork_unlock(void)
2775 #if defined(USE_ITHREADS)
2776 #  ifdef USE_PERLIO
2777   PERL_TSA_RELEASE(PL_perlio_mutex)
2778 #  endif
2779 #  ifdef MYMALLOC
2780   PERL_TSA_RELEASE(PL_malloc_mutex)
2781 #  endif
2782   PERL_TSA_RELEASE(PL_op_mutex)
2783 #endif
2784 {
2785 #if defined(USE_ITHREADS)
2786     dVAR;
2787     /* locks must be released in same order as in atfork_lock() */
2788 #  ifdef USE_PERLIO
2789     MUTEX_UNLOCK(&PL_perlio_mutex);
2790 #  endif
2791 #  ifdef MYMALLOC
2792     MUTEX_UNLOCK(&PL_malloc_mutex);
2793 #  endif
2794     OP_REFCNT_UNLOCK;
2795 #endif
2796 }
2797
2798 Pid_t
2799 Perl_my_fork(void)
2800 {
2801 #if defined(HAS_FORK)
2802     Pid_t pid;
2803 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2804     atfork_lock();
2805     pid = fork();
2806     atfork_unlock();
2807 #else
2808     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2809      * handlers elsewhere in the code */
2810     pid = fork();
2811 #endif
2812     return pid;
2813 #elif defined(__amigaos4__)
2814     return amigaos_fork();
2815 #else
2816     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2817     Perl_croak_nocontext("fork() not available");
2818     return 0;
2819 #endif /* HAS_FORK */
2820 }
2821
2822 #ifndef HAS_DUP2
2823 int
2824 dup2(int oldfd, int newfd)
2825 {
2826 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2827     if (oldfd == newfd)
2828         return oldfd;
2829     PerlLIO_close(newfd);
2830     return fcntl(oldfd, F_DUPFD, newfd);
2831 #else
2832 #define DUP2_MAX_FDS 256
2833     int fdtmp[DUP2_MAX_FDS];
2834     I32 fdx = 0;
2835     int fd;
2836
2837     if (oldfd == newfd)
2838         return oldfd;
2839     PerlLIO_close(newfd);
2840     /* good enough for low fd's... */
2841     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2842         if (fdx >= DUP2_MAX_FDS) {
2843             PerlLIO_close(fd);
2844             fd = -1;
2845             break;
2846         }
2847         fdtmp[fdx++] = fd;
2848     }
2849     while (fdx > 0)
2850         PerlLIO_close(fdtmp[--fdx]);
2851     return fd;
2852 #endif
2853 }
2854 #endif
2855
2856 #ifndef PERL_MICRO
2857 #ifdef HAS_SIGACTION
2858
2859 Sighandler_t
2860 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2861 {
2862     struct sigaction act, oact;
2863
2864 #ifdef USE_ITHREADS
2865     dVAR;
2866     /* only "parent" interpreter can diddle signals */
2867     if (PL_curinterp != aTHX)
2868         return (Sighandler_t) SIG_ERR;
2869 #endif
2870
2871     act.sa_handler = (void(*)(int))handler;
2872     sigemptyset(&act.sa_mask);
2873     act.sa_flags = 0;
2874 #ifdef SA_RESTART
2875     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2876         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2877 #endif
2878 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2879     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2880         act.sa_flags |= SA_NOCLDWAIT;
2881 #endif
2882     if (sigaction(signo, &act, &oact) == -1)
2883         return (Sighandler_t) SIG_ERR;
2884     else
2885         return (Sighandler_t) oact.sa_handler;
2886 }
2887
2888 Sighandler_t
2889 Perl_rsignal_state(pTHX_ int signo)
2890 {
2891     struct sigaction oact;
2892     PERL_UNUSED_CONTEXT;
2893
2894     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2895         return (Sighandler_t) SIG_ERR;
2896     else
2897         return (Sighandler_t) oact.sa_handler;
2898 }
2899
2900 int
2901 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2902 {
2903 #ifdef USE_ITHREADS
2904     dVAR;
2905 #endif
2906     struct sigaction act;
2907
2908     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2909
2910 #ifdef USE_ITHREADS
2911     /* only "parent" interpreter can diddle signals */
2912     if (PL_curinterp != aTHX)
2913         return -1;
2914 #endif
2915
2916     act.sa_handler = (void(*)(int))handler;
2917     sigemptyset(&act.sa_mask);
2918     act.sa_flags = 0;
2919 #ifdef SA_RESTART
2920     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2921         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2922 #endif
2923 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2924     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2925         act.sa_flags |= SA_NOCLDWAIT;
2926 #endif
2927     return sigaction(signo, &act, save);
2928 }
2929
2930 int
2931 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2932 {
2933 #ifdef USE_ITHREADS
2934     dVAR;
2935 #endif
2936     PERL_UNUSED_CONTEXT;
2937 #ifdef USE_ITHREADS
2938     /* only "parent" interpreter can diddle signals */
2939     if (PL_curinterp != aTHX)
2940         return -1;
2941 #endif
2942
2943     return sigaction(signo, save, (struct sigaction *)NULL);
2944 }
2945
2946 #else /* !HAS_SIGACTION */
2947
2948 Sighandler_t
2949 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2950 {
2951 #if defined(USE_ITHREADS) && !defined(WIN32)
2952     /* only "parent" interpreter can diddle signals */
2953     if (PL_curinterp != aTHX)
2954         return (Sighandler_t) SIG_ERR;
2955 #endif
2956
2957     return PerlProc_signal(signo, handler);
2958 }
2959
2960 static Signal_t
2961 sig_trap(int signo)
2962 {
2963     dVAR;
2964     PL_sig_trapped++;
2965 }
2966
2967 Sighandler_t
2968 Perl_rsignal_state(pTHX_ int signo)
2969 {
2970     dVAR;
2971     Sighandler_t oldsig;
2972
2973 #if defined(USE_ITHREADS) && !defined(WIN32)
2974     /* only "parent" interpreter can diddle signals */
2975     if (PL_curinterp != aTHX)
2976         return (Sighandler_t) SIG_ERR;
2977 #endif
2978
2979     PL_sig_trapped = 0;
2980     oldsig = PerlProc_signal(signo, sig_trap);
2981     PerlProc_signal(signo, oldsig);
2982     if (PL_sig_trapped)
2983         PerlProc_kill(PerlProc_getpid(), signo);
2984     return oldsig;
2985 }
2986
2987 int
2988 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2989 {
2990 #if defined(USE_ITHREADS) && !defined(WIN32)
2991     /* only "parent" interpreter can diddle signals */
2992     if (PL_curinterp != aTHX)
2993         return -1;
2994 #endif
2995     *save = PerlProc_signal(signo, handler);
2996     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2997 }
2998
2999 int
3000 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3001 {
3002 #if defined(USE_ITHREADS) && !defined(WIN32)
3003     /* only "parent" interpreter can diddle signals */
3004     if (PL_curinterp != aTHX)
3005         return -1;
3006 #endif
3007     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3008 }
3009
3010 #endif /* !HAS_SIGACTION */
3011 #endif /* !PERL_MICRO */
3012
3013     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3014 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3015 I32
3016 Perl_my_pclose(pTHX_ PerlIO *ptr)
3017 {
3018     int status;
3019     SV **svp;
3020     Pid_t pid;
3021     Pid_t pid2 = 0;
3022     bool close_failed;
3023     dSAVEDERRNO;
3024     const int fd = PerlIO_fileno(ptr);
3025     bool should_wait;
3026
3027     svp = av_fetch(PL_fdpid,fd,TRUE);
3028     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3029     SvREFCNT_dec(*svp);
3030     *svp = NULL;
3031
3032 #if defined(USE_PERLIO)
3033     /* Find out whether the refcount is low enough for us to wait for the
3034        child proc without blocking. */
3035     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3036 #else
3037     should_wait = pid > 0;
3038 #endif
3039
3040 #ifdef OS2
3041     if (pid == -1) {                    /* Opened by popen. */
3042         return my_syspclose(ptr);
3043     }
3044 #endif
3045     close_failed = (PerlIO_close(ptr) == EOF);
3046     SAVE_ERRNO;
3047     if (should_wait) do {
3048         pid2 = wait4pid(pid, &status, 0);
3049     } while (pid2 == -1 && errno == EINTR);
3050     if (close_failed) {
3051         RESTORE_ERRNO;
3052         return -1;
3053     }
3054     return(
3055       should_wait
3056        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3057        : 0
3058     );
3059 }
3060 #else
3061 #if defined(__LIBCATAMOUNT__)
3062 I32
3063 Perl_my_pclose(pTHX_ PerlIO *ptr)
3064 {
3065     return -1;
3066 }
3067 #endif
3068 #endif /* !DOSISH */
3069
3070 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3071 I32
3072 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3073 {
3074     I32 result = 0;
3075     PERL_ARGS_ASSERT_WAIT4PID;
3076 #ifdef PERL_USES_PL_PIDSTATUS
3077     if (!pid) {
3078         /* PERL_USES_PL_PIDSTATUS is only defined when neither
3079            waitpid() nor wait4() is available, or on OS/2, which
3080            doesn't appear to support waiting for a progress group
3081            member, so we can only treat a 0 pid as an unknown child.
3082         */
3083         errno = ECHILD;
3084         return -1;
3085     }
3086     {
3087         if (pid > 0) {
3088             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3089                pid, rather than a string form.  */
3090             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3091             if (svp && *svp != &PL_sv_undef) {
3092                 *statusp = SvIVX(*svp);
3093                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3094                                 G_DISCARD);
3095                 return pid;
3096             }
3097         }
3098         else {
3099             HE *entry;
3100
3101             hv_iterinit(PL_pidstatus);
3102             if ((entry = hv_iternext(PL_pidstatus))) {
3103                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3104                 I32 len;
3105                 const char * const spid = hv_iterkey(entry,&len);
3106
3107                 assert (len == sizeof(Pid_t));
3108                 memcpy((char *)&pid, spid, len);
3109                 *statusp = SvIVX(sv);
3110                 /* The hash iterator is currently on this entry, so simply
3111                    calling hv_delete would trigger the lazy delete, which on
3112                    aggregate does more work, because next call to hv_iterinit()
3113                    would spot the flag, and have to call the delete routine,
3114                    while in the meantime any new entries can't re-use that
3115                    memory.  */
3116                 hv_iterinit(PL_pidstatus);
3117                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3118                 return pid;
3119             }
3120         }
3121     }
3122 #endif
3123 #ifdef HAS_WAITPID
3124 #  ifdef HAS_WAITPID_RUNTIME
3125     if (!HAS_WAITPID_RUNTIME)
3126         goto hard_way;
3127 #  endif
3128     result = PerlProc_waitpid(pid,statusp,flags);
3129     goto finish;
3130 #endif
3131 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3132     result = wait4(pid,statusp,flags,NULL);
3133     goto finish;
3134 #endif
3135 #ifdef PERL_USES_PL_PIDSTATUS
3136 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3137   hard_way:
3138 #endif
3139     {
3140         if (flags)
3141             Perl_croak(aTHX_ "Can't do waitpid with flags");
3142         else {
3143             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3144                 pidgone(result,*statusp);
3145             if (result < 0)
3146                 *statusp = -1;
3147         }
3148     }
3149 #endif
3150 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3151   finish:
3152 #endif
3153     if (result < 0 && errno == EINTR) {
3154         PERL_ASYNC_CHECK();
3155         errno = EINTR; /* reset in case a signal handler changed $! */
3156     }
3157     return result;
3158 }
3159 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3160
3161 #ifdef PERL_USES_PL_PIDSTATUS
3162 void
3163 S_pidgone(pTHX_ Pid_t pid, int status)
3164 {
3165     SV *sv;
3166
3167     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3168     SvUPGRADE(sv,SVt_IV);
3169     SvIV_set(sv, status);
3170     return;
3171 }
3172 #endif
3173
3174 #if defined(OS2)
3175 int pclose();
3176 #ifdef HAS_FORK
3177 int                                     /* Cannot prototype with I32
3178                                            in os2ish.h. */
3179 my_syspclose(PerlIO *ptr)
3180 #else
3181 I32
3182 Perl_my_pclose(pTHX_ PerlIO *ptr)
3183 #endif
3184 {
3185     /* Needs work for PerlIO ! */
3186     FILE * const f = PerlIO_findFILE(ptr);
3187     const I32 result = pclose(f);
3188     PerlIO_releaseFILE(ptr,f);
3189     return result;
3190 }
3191 #endif
3192
3193 #if defined(DJGPP)
3194 int djgpp_pclose();
3195 I32
3196 Perl_my_pclose(pTHX_ PerlIO *ptr)
3197 {
3198     /* Needs work for PerlIO ! */
3199     FILE * const f = PerlIO_findFILE(ptr);
3200     I32 result = djgpp_pclose(f);
3201     result = (result << 8) & 0xff00;
3202     PerlIO_releaseFILE(ptr,f);
3203     return result;
3204 }
3205 #endif
3206
3207 #define PERL_REPEATCPY_LINEAR 4
3208 void
3209 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3210 {
3211     PERL_ARGS_ASSERT_REPEATCPY;
3212
3213     assert(len >= 0);
3214
3215     if (count < 0)
3216         croak_memory_wrap();
3217
3218     if (len == 1)
3219         memset(to, *from, count);
3220     else if (count) {
3221         char *p = to;
3222         IV items, linear, half;
3223
3224         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3225         for (items = 0; items < linear; ++items) {
3226             const char *q = from;
3227             IV todo;
3228             for (todo = len; todo > 0; todo--)
3229                 *p++ = *q++;
3230         }
3231
3232         half = count / 2;
3233         while (items <= half) {
3234             IV size = items * len;
3235             memcpy(p, to, size);
3236             p     += size;
3237             items *= 2;
3238         }
3239
3240         if (count > items)
3241             memcpy(p, to, (count - items) * len);
3242     }
3243 }
3244
3245 #ifndef HAS_RENAME
3246 I32
3247 Perl_same_dirent(pTHX_ const char *a, const char *b)
3248 {
3249     char *fa = strrchr(a,'/');
3250     char *fb = strrchr(b,'/');
3251     Stat_t tmpstatbuf1;
3252     Stat_t tmpstatbuf2;
3253     SV * const tmpsv = sv_newmortal();
3254
3255     PERL_ARGS_ASSERT_SAME_DIRENT;
3256
3257     if (fa)
3258         fa++;
3259     else
3260         fa = a;
3261     if (fb)
3262         fb++;
3263     else
3264         fb = b;
3265     if (strNE(a,b))
3266         return FALSE;
3267     if (fa == a)
3268         sv_setpvs(tmpsv, ".");
3269     else
3270         sv_setpvn(tmpsv, a, fa - a);
3271     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3272         return FALSE;
3273     if (fb == b)
3274         sv_setpvs(tmpsv, ".");
3275     else
3276         sv_setpvn(tmpsv, b, fb - b);
3277     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3278         return FALSE;
3279     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3280            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3281 }
3282 #endif /* !HAS_RENAME */
3283
3284 char*
3285 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3286                  const char *const *const search_ext, I32 flags)
3287 {
3288     const char *xfound = NULL;
3289     char *xfailed = NULL;
3290     char tmpbuf[MAXPATHLEN];
3291     char *s;
3292     I32 len = 0;
3293     int retval;
3294     char *bufend;
3295 #if defined(DOSISH) && !defined(OS2)
3296 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3297 #  define MAX_EXT_LEN 4
3298 #endif
3299 #ifdef OS2
3300 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3301 #  define MAX_EXT_LEN 4
3302 #endif
3303 #ifdef VMS
3304 #  define SEARCH_EXTS ".pl", ".com", NULL
3305 #  define MAX_EXT_LEN 4
3306 #endif
3307     /* additional extensions to try in each dir if scriptname not found */
3308 #ifdef SEARCH_EXTS
3309     static const char *const exts[] = { SEARCH_EXTS };
3310     const char *const *const ext = search_ext ? search_ext : exts;
3311     int extidx = 0, i = 0;
3312     const char *curext = NULL;
3313 #else
3314     PERL_UNUSED_ARG(search_ext);
3315 #  define MAX_EXT_LEN 0
3316 #endif
3317
3318     PERL_ARGS_ASSERT_FIND_SCRIPT;
3319
3320     /*
3321      * If dosearch is true and if scriptname does not contain path
3322      * delimiters, search the PATH for scriptname.
3323      *
3324      * If SEARCH_EXTS is also defined, will look for each
3325      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3326      * while searching the PATH.
3327      *
3328      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3329      * proceeds as follows:
3330      *   If DOSISH or VMSISH:
3331      *     + look for ./scriptname{,.foo,.bar}
3332      *     + search the PATH for scriptname{,.foo,.bar}
3333      *
3334      *   If !DOSISH:
3335      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3336      *       this will not look in '.' if it's not in the PATH)
3337      */
3338     tmpbuf[0] = '\0';
3339
3340 #ifdef VMS
3341 #  ifdef ALWAYS_DEFTYPES
3342     len = strlen(scriptname);
3343     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3344         int idx = 0, deftypes = 1;
3345         bool seen_dot = 1;
3346
3347         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3348 #  else
3349     if (dosearch) {
3350         int idx = 0, deftypes = 1;
3351         bool seen_dot = 1;
3352
3353         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3354 #  endif
3355         /* The first time through, just add SEARCH_EXTS to whatever we
3356          * already have, so we can check for default file types. */
3357         while (deftypes ||
3358                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3359         {
3360             Stat_t statbuf;
3361             if (deftypes) {
3362                 deftypes = 0;
3363                 *tmpbuf = '\0';
3364             }
3365             if ((strlen(tmpbuf) + strlen(scriptname)
3366                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3367                 continue;       /* don't search dir with too-long name */
3368             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3369 #else  /* !VMS */
3370
3371 #ifdef DOSISH
3372     if (strEQ(scriptname, "-"))
3373         dosearch = 0;
3374     if (dosearch) {             /* Look in '.' first. */
3375         const char *cur = scriptname;
3376 #ifdef SEARCH_EXTS
3377         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3378             while (ext[i])
3379                 if (strEQ(ext[i++],curext)) {
3380                     extidx = -1;                /* already has an ext */
3381                     break;
3382                 }
3383         do {
3384 #endif
3385             DEBUG_p(PerlIO_printf(Perl_debug_log,
3386                                   "Looking for %s\n",cur));
3387             {
3388                 Stat_t statbuf;
3389                 if (PerlLIO_stat(cur,&statbuf) >= 0
3390                     && !S_ISDIR(statbuf.st_mode)) {
3391                     dosearch = 0;
3392                     scriptname = cur;
3393 #ifdef SEARCH_EXTS
3394                     break;
3395 #endif
3396                 }
3397             }
3398 #ifdef SEARCH_EXTS
3399             if (cur == scriptname) {
3400                 len = strlen(scriptname);
3401                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3402                     break;
3403                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3404                 cur = tmpbuf;
3405             }
3406         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3407                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3408 #endif
3409     }
3410 #endif
3411
3412     if (dosearch && !strchr(scriptname, '/')
3413 #ifdef DOSISH
3414                  && !strchr(scriptname, '\\')
3415 #endif
3416                  && (s = PerlEnv_getenv("PATH")))
3417     {
3418         bool seen_dot = 0;
3419
3420         bufend = s + strlen(s);
3421         while (s < bufend) {
3422             Stat_t statbuf;
3423 #  ifdef DOSISH
3424             for (len = 0; *s
3425                     && *s != ';'; len++, s++) {
3426                 if (len < sizeof tmpbuf)
3427                     tmpbuf[len] = *s;
3428             }
3429             if (len < sizeof tmpbuf)
3430                 tmpbuf[len] = '\0';
3431 #  else
3432             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3433                         ':',
3434                         &len);
3435 #  endif
3436             if (s < bufend)
3437                 s++;
3438             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3439                 continue;       /* don't search dir with too-long name */
3440             if (len
3441 #  ifdef DOSISH
3442                 && tmpbuf[len - 1] != '/'
3443                 && tmpbuf[len - 1] != '\\'
3444 #  endif
3445                )
3446                 tmpbuf[len++] = '/';
3447             if (len == 2 && tmpbuf[0] == '.')
3448                 seen_dot = 1;
3449             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3450 #endif  /* !VMS */
3451
3452 #ifdef SEARCH_EXTS
3453             len = strlen(tmpbuf);
3454             if (extidx > 0)     /* reset after previous loop */
3455                 extidx = 0;
3456             do {
3457 #endif
3458                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3459                 retval = PerlLIO_stat(tmpbuf,&statbuf);
3460                 if (S_ISDIR(statbuf.st_mode)) {
3461                     retval = -1;
3462                 }
3463 #ifdef SEARCH_EXTS
3464             } while (  retval < 0               /* not there */
3465                     && extidx>=0 && ext[extidx] /* try an extension? */
3466                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3467                 );
3468 #endif
3469             if (retval < 0)
3470                 continue;
3471             if (S_ISREG(statbuf.st_mode)
3472                 && cando(S_IRUSR,TRUE,&statbuf)
3473 #if !defined(DOSISH)
3474                 && cando(S_IXUSR,TRUE,&statbuf)
3475 #endif
3476                 )
3477             {
3478                 xfound = tmpbuf;                /* bingo! */
3479                 break;
3480             }
3481             if (!xfailed)
3482                 xfailed = savepv(tmpbuf);
3483         }
3484 #ifndef DOSISH
3485         {
3486             Stat_t statbuf;
3487             if (!xfound && !seen_dot && !xfailed &&
3488                 (PerlLIO_stat(scriptname,&statbuf) < 0
3489                  || S_ISDIR(statbuf.st_mode)))
3490 #endif
3491                 seen_dot = 1;                   /* Disable message. */
3492 #ifndef DOSISH
3493         }
3494 #endif
3495         if (!xfound) {
3496             if (flags & 1) {                    /* do or die? */
3497                 /* diag_listed_as: Can't execute %s */
3498                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3499                       (xfailed ? "execute" : "find"),
3500                       (xfailed ? xfailed : scriptname),
3501                       (xfailed ? "" : " on PATH"),
3502                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3503             }
3504             scriptname = NULL;
3505         }
3506         Safefree(xfailed);
3507         scriptname = xfound;
3508     }
3509     return (scriptname ? savepv(scriptname) : NULL);
3510 }
3511
3512 #ifndef PERL_GET_CONTEXT_DEFINED
3513
3514 void *
3515 Perl_get_context(void)
3516 {
3517 #if defined(USE_ITHREADS)
3518     dVAR;
3519 #  ifdef OLD_PTHREADS_API
3520     pthread_addr_t t;
3521     int error = pthread_getspecific(PL_thr_key, &t)
3522     if (error)
3523         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3524     return (void*)t;
3525 #  else
3526 #    ifdef I_MACH_CTHREADS
3527     return (void*)cthread_data(cthread_self());
3528 #    else
3529     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3530 #    endif
3531 #  endif
3532 #else
3533     return (void*)NULL;
3534 #endif
3535 }
3536
3537 void
3538 Perl_set_context(void *t)
3539 {
3540 #if defined(USE_ITHREADS)
3541     dVAR;
3542 #endif
3543     PERL_ARGS_ASSERT_SET_CONTEXT;
3544 #if defined(USE_ITHREADS)
3545 #  ifdef I_MACH_CTHREADS
3546     cthread_set_data(cthread_self(), t);
3547 #  else
3548     {
3549         const int error = pthread_setspecific(PL_thr_key, t);
3550         if (error)
3551             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3552     }
3553 #  endif
3554 #else
3555     PERL_UNUSED_ARG(t);
3556 #endif
3557 }
3558
3559 #endif /* !PERL_GET_CONTEXT_DEFINED */
3560
3561 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3562 struct perl_vars *
3563 Perl_GetVars(pTHX)
3564 {
3565     PERL_UNUSED_CONTEXT;
3566     return &PL_Vars;
3567 }
3568 #endif
3569
3570 char **
3571 Perl_get_op_names(pTHX)
3572 {
3573     PERL_UNUSED_CONTEXT;
3574     return (char **)PL_op_name;
3575 }
3576
3577 char **
3578 Perl_get_op_descs(pTHX)
3579 {
3580     PERL_UNUSED_CONTEXT;
3581     return (char **)PL_op_desc;
3582 }
3583
3584 const char *
3585 Perl_get_no_modify(pTHX)
3586 {
3587     PERL_UNUSED_CONTEXT;
3588     return PL_no_modify;
3589 }
3590
3591 U32 *
3592 Perl_get_opargs(pTHX)
3593 {
3594     PERL_UNUSED_CONTEXT;
3595     return (U32 *)PL_opargs;
3596 }
3597
3598 PPADDR_t*
3599 Perl_get_ppaddr(pTHX)
3600 {
3601     dVAR;
3602     PERL_UNUSED_CONTEXT;
3603     return (PPADDR_t*)PL_ppaddr;
3604 }
3605
3606 #ifndef HAS_GETENV_LEN
3607 char *
3608 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3609 {
3610     char * const env_trans = PerlEnv_getenv(env_elem);
3611     PERL_UNUSED_CONTEXT;
3612     PERL_ARGS_ASSERT_GETENV_LEN;
3613     if (env_trans)
3614         *len = strlen(env_trans);
3615     return env_trans;
3616 }
3617 #endif
3618
3619
3620 MGVTBL*
3621 Perl_get_vtbl(pTHX_ int vtbl_id)
3622 {
3623     PERL_UNUSED_CONTEXT;
3624
3625     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3626         ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3627 }
3628
3629 I32
3630 Perl_my_fflush_all(pTHX)
3631 {
3632 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3633     return PerlIO_flush(NULL);
3634 #else
3635 # if defined(HAS__FWALK)
3636     extern int fflush(FILE *);
3637     /* undocumented, unprototyped, but very useful BSDism */
3638     extern void _fwalk(int (*)(FILE *));
3639     _fwalk(&fflush);
3640     return 0;
3641 # else
3642 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3643     long open_max = -1;
3644 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3645     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3646 #   else
3647 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3648     open_max = sysconf(_SC_OPEN_MAX);
3649 #     else
3650 #      ifdef FOPEN_MAX
3651     open_max = FOPEN_MAX;
3652 #      else
3653 #       ifdef OPEN_MAX
3654     open_max = OPEN_MAX;
3655 #       else
3656 #        ifdef _NFILE
3657     open_max = _NFILE;
3658 #        endif
3659 #       endif
3660 #      endif
3661 #     endif
3662 #    endif
3663     if (open_max > 0) {
3664       long i;
3665       for (i = 0; i < open_max; i++)
3666             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3667                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3668                 STDIO_STREAM_ARRAY[i]._flag)
3669                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3670       return 0;
3671     }
3672 #  endif
3673     SETERRNO(EBADF,RMS_IFI);
3674     return EOF;
3675 # endif
3676 #endif
3677 }
3678
3679 void
3680 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3681 {
3682     if (ckWARN(WARN_IO)) {
3683         HEK * const name
3684            = gv && (isGV_with_GP(gv))
3685                 ? GvENAME_HEK((gv))
3686                 : NULL;
3687         const char * const direction = have == '>' ? "out" : "in";
3688
3689         if (name && HEK_LEN(name))
3690             Perl_warner(aTHX_ packWARN(WARN_IO),
3691                         "Filehandle %"HEKf" opened only for %sput",
3692                         HEKfARG(name), direction);
3693         else
3694             Perl_warner(aTHX_ packWARN(WARN_IO),
3695                         "Filehandle opened only for %sput", direction);
3696     }
3697 }
3698
3699 void
3700 Perl_report_evil_fh(pTHX_ const GV *gv)
3701 {
3702     const IO *io = gv ? GvIO(gv) : NULL;
3703     const PERL_BITFIELD16 op = PL_op->op_type;
3704     const char *vile;
3705     I32 warn_type;
3706
3707     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3708         vile = "closed";
3709         warn_type = WARN_CLOSED;
3710     }
3711     else {
3712         vile = "unopened";
3713         warn_type = WARN_UNOPENED;
3714     }
3715
3716     if (ckWARN(warn_type)) {
3717         SV * const name
3718             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3719                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3720         const char * const pars =
3721             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3722         const char * const func =
3723             (const char *)
3724             (op == OP_READLINE || op == OP_RCATLINE
3725                                  ? "readline"  :        /* "<HANDLE>" not nice */
3726              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3727              PL_op_desc[op]);
3728         const char * const type =
3729             (const char *)
3730             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3731              ? "socket" : "filehandle");
3732         const bool have_name = name && SvCUR(name);
3733         Perl_warner(aTHX_ packWARN(warn_type),
3734                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3735                     have_name ? " " : "",
3736                     SVfARG(have_name ? name : &PL_sv_no));
3737         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3738                 Perl_warner(
3739                             aTHX_ packWARN(warn_type),
3740                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3741                         func, pars, have_name ? " " : "",
3742                         SVfARG(have_name ? name : &PL_sv_no)
3743                             );
3744     }
3745 }
3746
3747 /* To workaround core dumps from the uninitialised tm_zone we get the
3748  * system to give us a reasonable struct to copy.  This fix means that
3749  * strftime uses the tm_zone and tm_gmtoff values returned by
3750  * localtime(time()). That should give the desired result most of the
3751  * time. But probably not always!
3752  *
3753  * This does not address tzname aspects of NETaa14816.
3754  *
3755  */
3756
3757 #ifdef __GLIBC__
3758 # ifndef STRUCT_TM_HASZONE
3759 #    define STRUCT_TM_HASZONE
3760 # endif
3761 #endif
3762
3763 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3764 # ifndef HAS_TM_TM_ZONE
3765 #    define HAS_TM_TM_ZONE
3766 # endif
3767 #endif
3768
3769 void
3770 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3771 {
3772 #ifdef HAS_TM_TM_ZONE
3773     Time_t now;
3774     const struct tm* my_tm;
3775     PERL_UNUSED_CONTEXT;
3776     PERL_ARGS_ASSERT_INIT_TM;
3777     (void)time(&now);
3778     my_tm = localtime(&now);
3779     if (my_tm)
3780         Copy(my_tm, ptm, 1, struct tm);
3781 #else
3782     PERL_UNUSED_CONTEXT;
3783     PERL_ARGS_ASSERT_INIT_TM;
3784     PERL_UNUSED_ARG(ptm);
3785 #endif
3786 }
3787
3788 /*
3789  * mini_mktime - normalise struct tm values without the localtime()
3790  * semantics (and overhead) of mktime().
3791  */
3792 void
3793 Perl_mini_mktime(struct tm *ptm)
3794 {
3795     int yearday;
3796     int secs;
3797     int month, mday, year, jday;
3798     int odd_cent, odd_year;
3799
3800     PERL_ARGS_ASSERT_MINI_MKTIME;
3801
3802 #define DAYS_PER_YEAR   365
3803 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3804 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3805 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3806 #define SECS_PER_HOUR   (60*60)
3807 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3808 /* parentheses deliberately absent on these two, otherwise they don't work */
3809 #define MONTH_TO_DAYS   153/5
3810 #define DAYS_TO_MONTH   5/153
3811 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3812 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3813 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3814 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3815
3816 /*
3817  * Year/day algorithm notes:
3818  *
3819  * With a suitable offset for numeric value of the month, one can find
3820  * an offset into the year by considering months to have 30.6 (153/5) days,
3821  * using integer arithmetic (i.e., with truncation).  To avoid too much
3822  * messing about with leap days, we consider January and February to be
3823  * the 13th and 14th month of the previous year.  After that transformation,
3824  * we need the month index we use to be high by 1 from 'normal human' usage,
3825  * so the month index values we use run from 4 through 15.
3826  *
3827  * Given that, and the rules for the Gregorian calendar (leap years are those
3828  * divisible by 4 unless also divisible by 100, when they must be divisible
3829  * by 400 instead), we can simply calculate the number of days since some
3830  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3831  * the days we derive from our month index, and adding in the day of the
3832  * month.  The value used here is not adjusted for the actual origin which
3833  * it normally would use (1 January A.D. 1), since we're not exposing it.
3834  * We're only building the value so we can turn around and get the
3835  * normalised values for the year, month, day-of-month, and day-of-year.
3836  *
3837  * For going backward, we need to bias the value we're using so that we find
3838  * the right year value.  (Basically, we don't want the contribution of
3839  * March 1st to the number to apply while deriving the year).  Having done
3840  * that, we 'count up' the contribution to the year number by accounting for
3841  * full quadracenturies (400-year periods) with their extra leap days, plus
3842  * the contribution from full centuries (to avoid counting in the lost leap
3843  * days), plus the contribution from full quad-years (to count in the normal
3844  * leap days), plus the leftover contribution from any non-leap years.
3845  * At this point, if we were working with an actual leap day, we'll have 0
3846  * days left over.  This is also true for March 1st, however.  So, we have
3847  * to special-case that result, and (earlier) keep track of the 'odd'
3848  * century and year contributions.  If we got 4 extra centuries in a qcent,
3849  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3850  * Otherwise, we add back in the earlier bias we removed (the 123 from
3851  * figuring in March 1st), find the month index (integer division by 30.6),
3852  * and the remainder is the day-of-month.  We then have to convert back to
3853  * 'real' months (including fixing January and February from being 14/15 in
3854  * the previous year to being in the proper year).  After that, to get
3855  * tm_yday, we work with the normalised year and get a new yearday value for
3856  * January 1st, which we subtract from the yearday value we had earlier,
3857  * representing the date we've re-built.  This is done from January 1
3858  * because tm_yday is 0-origin.
3859  *
3860  * Since POSIX time routines are only guaranteed to work for times since the
3861  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3862  * applies Gregorian calendar rules even to dates before the 16th century
3863  * doesn't bother me.  Besides, you'd need cultural context for a given
3864  * date to know whether it was Julian or Gregorian calendar, and that's
3865  * outside the scope for this routine.  Since we convert back based on the
3866  * same rules we used to build the yearday, you'll only get strange results
3867  * for input which needed normalising, or for the 'odd' century years which
3868  * were leap years in the Julian calendar but not in the Gregorian one.
3869  * I can live with that.
3870  *
3871  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3872  * that's still outside the scope for POSIX time manipulation, so I don't
3873  * care.
3874  */
3875
3876     year = 1900 + ptm->tm_year;
3877     month = ptm->tm_mon;
3878     mday = ptm->tm_mday;
3879     jday = 0;
3880     if (month >= 2)
3881         month+=2;
3882     else
3883         month+=14, year--;
3884     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3885     yearday += month*MONTH_TO_DAYS + mday + jday;
3886     /*
3887      * Note that we don't know when leap-seconds were or will be,
3888      * so we have to trust the user if we get something which looks
3889      * like a sensible leap-second.  Wild values for seconds will
3890      * be rationalised, however.
3891      */
3892     if ((unsigned) ptm->tm_sec <= 60) {
3893         secs = 0;
3894     }
3895     else {
3896         secs = ptm->tm_sec;
3897         ptm->tm_sec = 0;
3898     }
3899     secs += 60 * ptm->tm_min;
3900     secs += SECS_PER_HOUR * ptm->tm_hour;
3901     if (secs < 0) {
3902         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3903             /* got negative remainder, but need positive time */
3904             /* back off an extra day to compensate */
3905             yearday += (secs/SECS_PER_DAY)-1;
3906             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3907         }
3908         else {
3909             yearday += (secs/SECS_PER_DAY);
3910             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3911         }
3912     }
3913     else if (secs >= SECS_PER_DAY) {
3914         yearday += (secs/SECS_PER_DAY);
3915         secs %= SECS_PER_DAY;
3916     }
3917     ptm->tm_hour = secs/SECS_PER_HOUR;
3918     secs %= SECS_PER_HOUR;
3919     ptm->tm_min = secs/60;
3920     secs %= 60;
3921     ptm->tm_sec += secs;
3922     /* done with time of day effects */
3923     /*
3924      * The algorithm for yearday has (so far) left it high by 428.
3925      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3926      * bias it by 123 while trying to figure out what year it
3927      * really represents.  Even with this tweak, the reverse
3928      * translation fails for years before A.D. 0001.
3929      * It would still fail for Feb 29, but we catch that one below.
3930      */
3931     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3932     yearday -= YEAR_ADJUST;
3933     year = (yearday / DAYS_PER_QCENT) * 400;
3934     yearday %= DAYS_PER_QCENT;
3935     odd_cent = yearday / DAYS_PER_CENT;
3936     year += odd_cent * 100;
3937     yearday %= DAYS_PER_CENT;
3938     year += (yearday / DAYS_PER_QYEAR) * 4;
3939     yearday %= DAYS_PER_QYEAR;
3940     odd_year = yearday / DAYS_PER_YEAR;
3941     year += odd_year;
3942     yearday %= DAYS_PER_YEAR;
3943     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3944         month = 1;
3945         yearday = 29;
3946     }
3947     else {
3948         yearday += YEAR_ADJUST; /* recover March 1st crock */
3949         month = yearday*DAYS_TO_MONTH;
3950         yearday -= month*MONTH_TO_DAYS;
3951         /* recover other leap-year adjustment */
3952         if (month > 13) {
3953             month-=14;
3954             year++;
3955         }
3956         else {
3957             month-=2;
3958         }
3959     }
3960     ptm->tm_year = year - 1900;
3961     if (yearday) {
3962       ptm->tm_mday = yearday;
3963       ptm->tm_mon = month;
3964     }
3965     else {
3966       ptm->tm_mday = 31;
3967       ptm->tm_mon = month - 1;
3968     }
3969     /* re-build yearday based on Jan 1 to get tm_yday */
3970     year--;
3971     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3972     yearday += 14*MONTH_TO_DAYS + 1;
3973     ptm->tm_yday = jday - yearday;
3974     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3975 }
3976
3977 char *
3978 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)
3979 {
3980 #ifdef HAS_STRFTIME
3981
3982   /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
3983
3984   char *buf;
3985   int buflen;
3986   struct tm mytm;
3987   int len;
3988
3989   PERL_ARGS_ASSERT_MY_STRFTIME;
3990
3991   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3992   mytm.tm_sec = sec;
3993   mytm.tm_min = min;
3994   mytm.tm_hour = hour;
3995   mytm.tm_mday = mday;
3996   mytm.tm_mon = mon;
3997   mytm.tm_year = year;
3998   mytm.tm_wday = wday;
3999   mytm.tm_yday = yday;
4000   mytm.tm_isdst = isdst;
4001   mini_mktime(&mytm);
4002   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4003 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4004   STMT_START {
4005     struct tm mytm2;
4006     mytm2 = mytm;
4007     mktime(&mytm2);
4008 #ifdef HAS_TM_TM_GMTOFF
4009     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4010 #endif
4011 #ifdef HAS_TM_TM_ZONE
4012     mytm.tm_zone = mytm2.tm_zone;
4013 #endif
4014   } STMT_END;
4015 #endif
4016   buflen = 64;
4017   Newx(buf, buflen, char);
4018
4019   GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4020   len = strftime(buf, buflen, fmt, &mytm);
4021   GCC_DIAG_RESTORE;
4022
4023   /*
4024   ** The following is needed to handle to the situation where
4025   ** tmpbuf overflows.  Basically we want to allocate a buffer
4026   ** and try repeatedly.  The reason why it is so complicated
4027   ** is that getting a return value of 0 from strftime can indicate
4028   ** one of the following:
4029   ** 1. buffer overflowed,
4030   ** 2. illegal conversion specifier, or
4031   ** 3. the format string specifies nothing to be returned(not
4032   **      an error).  This could be because format is an empty string
4033   **    or it specifies %p that yields an empty string in some locale.
4034   ** If there is a better way to make it portable, go ahead by
4035   ** all means.
4036   */
4037   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4038     return buf;
4039   else {
4040     /* Possibly buf overflowed - try again with a bigger buf */
4041     const int fmtlen = strlen(fmt);
4042     int bufsize = fmtlen + buflen;
4043
4044     Renew(buf, bufsize, char);
4045     while (buf) {
4046
4047       GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4048       buflen = strftime(buf, bufsize, fmt, &mytm);
4049       GCC_DIAG_RESTORE;
4050
4051       if (buflen > 0 && buflen < bufsize)
4052         break;
4053       /* heuristic to prevent out-of-memory errors */
4054       if (bufsize > 100*fmtlen) {
4055         Safefree(buf);
4056         buf = NULL;
4057         break;
4058       }
4059       bufsize *= 2;
4060       Renew(buf, bufsize, char);
4061     }
4062     return buf;
4063   }
4064 #else
4065   Perl_croak(aTHX_ "panic: no strftime");
4066   return NULL;
4067 #endif
4068 }
4069
4070
4071 #define SV_CWD_RETURN_UNDEF \
4072 sv_setsv(sv, &PL_sv_undef); \
4073 return FALSE
4074
4075 #define SV_CWD_ISDOT(dp) \
4076     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4077         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4078
4079 /*
4080 =head1 Miscellaneous Functions
4081
4082 =for apidoc getcwd_sv
4083
4084 Fill C<sv> with current working directory
4085
4086 =cut
4087 */
4088
4089 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4090  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4091  * getcwd(3) if available
4092  * Comments from the original:
4093  *     This is a faster version of getcwd.  It's also more dangerous
4094  *     because you might chdir out of a directory that you can't chdir
4095  *     back into. */
4096
4097 int
4098 Perl_getcwd_sv(pTHX_ SV *sv)
4099 {
4100 #ifndef PERL_MICRO
4101     SvTAINTED_on(sv);
4102
4103     PERL_ARGS_ASSERT_GETCWD_SV;
4104
4105 #ifdef HAS_GETCWD
4106     {
4107         char buf[MAXPATHLEN];
4108
4109         /* Some getcwd()s automatically allocate a buffer of the given
4110          * size from the heap if they are given a NULL buffer pointer.
4111          * The problem is that this behaviour is not portable. */
4112         if (getcwd(buf, sizeof(buf) - 1)) {
4113             sv_setpv(sv, buf);
4114             return TRUE;
4115         }
4116         else {
4117             sv_setsv(sv, &PL_sv_undef);
4118             return FALSE;
4119         }
4120     }
4121
4122 #else
4123
4124     Stat_t statbuf;
4125     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4126     int pathlen=0;
4127     Direntry_t *dp;
4128
4129     SvUPGRADE(sv, SVt_PV);
4130
4131     if (PerlLIO_lstat(".", &statbuf) < 0) {
4132         SV_CWD_RETURN_UNDEF;
4133     }
4134
4135     orig_cdev = statbuf.st_dev;
4136     orig_cino = statbuf.st_ino;
4137     cdev = orig_cdev;
4138     cino = orig_cino;
4139
4140     for (;;) {
4141         DIR *dir;
4142         int namelen;
4143         odev = cdev;
4144         oino = cino;
4145
4146         if (PerlDir_chdir("..") < 0) {
4147             SV_CWD_RETURN_UNDEF;
4148         }
4149         if (PerlLIO_stat(".", &statbuf) < 0) {
4150             SV_CWD_RETURN_UNDEF;
4151         }
4152
4153         cdev = statbuf.st_dev;
4154         cino = statbuf.st_ino;
4155
4156         if (odev == cdev && oino == cino) {
4157             break;
4158         }
4159         if (!(dir = PerlDir_open("."))) {
4160             SV_CWD_RETURN_UNDEF;
4161         }
4162
4163         while ((dp = PerlDir_read(dir)) != NULL) {
4164 #ifdef DIRNAMLEN
4165             namelen = dp->d_namlen;
4166 #else
4167             namelen = strlen(dp->d_name);
4168 #endif
4169             /* skip . and .. */
4170             if (SV_CWD_ISDOT(dp)) {
4171                 continue;
4172             }
4173
4174             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4175                 SV_CWD_RETURN_UNDEF;
4176             }
4177
4178             tdev = statbuf.st_dev;
4179             tino = statbuf.st_ino;
4180             if (tino == oino && tdev == odev) {
4181                 break;
4182             }
4183         }
4184
4185         if (!dp) {
4186             SV_CWD_RETURN_UNDEF;
4187         }
4188
4189         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4190             SV_CWD_RETURN_UNDEF;
4191         }
4192
4193         SvGROW(sv, pathlen + namelen + 1);
4194
4195         if (pathlen) {
4196             /* shift down */
4197             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4198         }
4199
4200         /* prepend current directory to the front */
4201         *SvPVX(sv) = '/';
4202         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4203         pathlen += (namelen + 1);
4204
4205 #ifdef VOID_CLOSEDIR
4206         PerlDir_close(dir);
4207 #else
4208         if (PerlDir_close(dir) < 0) {
4209             SV_CWD_RETURN_UNDEF;
4210         }
4211 #endif
4212     }
4213
4214     if (pathlen) {
4215         SvCUR_set(sv, pathlen);
4216         *SvEND(sv) = '\0';
4217         SvPOK_only(sv);
4218
4219         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4220             SV_CWD_RETURN_UNDEF;
4221         }
4222     }
4223     if (PerlLIO_stat(".", &statbuf) < 0) {
4224         SV_CWD_RETURN_UNDEF;
4225     }
4226
4227     cdev = statbuf.st_dev;
4228     cino = statbuf.st_ino;
4229
4230     if (cdev != orig_cdev || cino != orig_cino) {
4231         Perl_croak(aTHX_ "Unstable directory path, "
4232                    "current directory changed unexpectedly");
4233     }
4234
4235     return TRUE;
4236 #endif
4237
4238 #else
4239     return FALSE;
4240 #endif
4241 }
4242
4243 #include "vutil.c"
4244
4245 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4246 #   define EMULATE_SOCKETPAIR_UDP
4247 #endif
4248
4249 #ifdef EMULATE_SOCKETPAIR_UDP
4250 static int
4251 S_socketpair_udp (int fd[2]) {
4252     dTHX;
4253     /* Fake a datagram socketpair using UDP to localhost.  */
4254     int sockets[2] = {-1, -1};
4255     struct sockaddr_in addresses[2];
4256     int i;
4257     Sock_size_t size = sizeof(struct sockaddr_in);
4258     unsigned short port;
4259     int got;
4260
4261     memset(&addresses, 0, sizeof(addresses));
4262     i = 1;
4263     do {
4264         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4265         if (sockets[i] == -1)
4266             goto tidy_up_and_fail;
4267
4268         addresses[i].sin_family = AF_INET;
4269         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4270         addresses[i].sin_port = 0;      /* kernel choses port.  */
4271         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4272                 sizeof(struct sockaddr_in)) == -1)
4273             goto tidy_up_and_fail;
4274     } while (i--);
4275
4276     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4277        for each connect the other socket to it.  */
4278     i = 1;
4279     do {
4280         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4281                 &size) == -1)
4282             goto tidy_up_and_fail;
4283         if (size != sizeof(struct sockaddr_in))
4284             goto abort_tidy_up_and_fail;
4285         /* !1 is 0, !0 is 1 */
4286         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4287                 sizeof(struct sockaddr_in)) == -1)
4288             goto tidy_up_and_fail;
4289     } while (i--);
4290
4291     /* Now we have 2 sockets connected to each other. I don't trust some other
4292        process not to have already sent a packet to us (by random) so send
4293        a packet from each to the other.  */
4294     i = 1;
4295     do {
4296         /* I'm going to send my own port number.  As a short.
4297            (Who knows if someone somewhere has sin_port as a bitfield and needs
4298            this routine. (I'm assuming crays have socketpair)) */
4299         port = addresses[i].sin_port;
4300         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4301         if (got != sizeof(port)) {
4302             if (got == -1)
4303                 goto tidy_up_and_fail;
4304             goto abort_tidy_up_and_fail;
4305         }
4306     } while (i--);
4307
4308     /* Packets sent. I don't trust them to have arrived though.
4309        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4310        connect to localhost will use a second kernel thread. In 2.6 the
4311        first thread running the connect() returns before the second completes,
4312        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4313        returns 0. Poor programs have tripped up. One poor program's authors'
4314        had a 50-1 reverse stock split. Not sure how connected these were.)
4315        So I don't trust someone not to have an unpredictable UDP stack.
4316     */
4317
4318     {
4319         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4320         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4321         fd_set rset;
4322
4323         FD_ZERO(&rset);
4324         FD_SET((unsigned int)sockets[0], &rset);
4325         FD_SET((unsigned int)sockets[1], &rset);
4326
4327         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4328         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4329                 || !FD_ISSET(sockets[1], &rset)) {
4330             /* I hope this is portable and appropriate.  */
4331             if (got == -1)
4332                 goto tidy_up_and_fail;
4333             goto abort_tidy_up_and_fail;
4334         }
4335     }
4336
4337     /* And the paranoia department even now doesn't trust it to have arrive
4338        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4339     {
4340         struct sockaddr_in readfrom;
4341         unsigned short buffer[2];
4342
4343         i = 1;
4344         do {
4345 #ifdef MSG_DONTWAIT
4346             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4347                     sizeof(buffer), MSG_DONTWAIT,
4348                     (struct sockaddr *) &readfrom, &size);
4349 #else
4350             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4351                     sizeof(buffer), 0,
4352                     (struct sockaddr *) &readfrom, &size);
4353 #endif
4354
4355             if (got == -1)
4356                 goto tidy_up_and_fail;
4357             if (got != sizeof(port)
4358                     || size != sizeof(struct sockaddr_in)
4359                     /* Check other socket sent us its port.  */
4360                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4361                     /* Check kernel says we got the datagram from that socket */
4362                     || readfrom.sin_family != addresses[!i].sin_family
4363                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4364                     || readfrom.sin_port != addresses[!i].sin_port)
4365                 goto abort_tidy_up_and_fail;
4366         } while (i--);
4367     }
4368     /* My caller (my_socketpair) has validated that this is non-NULL  */
4369     fd[0] = sockets[0];
4370     fd[1] = sockets[1];
4371     /* I hereby declare this connection open.  May God bless all who cross
4372        her.  */
4373     return 0;
4374
4375   abort_tidy_up_and_fail:
4376     errno = ECONNABORTED;
4377   tidy_up_and_fail:
4378     {
4379         dSAVE_ERRNO;
4380         if (sockets[0] != -1)
4381             PerlLIO_close(sockets[0]);
4382         if (sockets[1] != -1)
4383             PerlLIO_close(sockets[1]);
4384         RESTORE_ERRNO;
4385         return -1;
4386     }
4387 }
4388 #endif /*  EMULATE_SOCKETPAIR_UDP */
4389
4390 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4391 int
4392 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4393     /* Stevens says that family must be AF_LOCAL, protocol 0.
4394        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4395     dTHXa(NULL);
4396     int listener = -1;
4397     int connector = -1;
4398     int acceptor = -1;
4399     struct sockaddr_in listen_addr;
4400     struct sockaddr_in connect_addr;
4401     Sock_size_t size;
4402
4403     if (protocol
4404 #ifdef AF_UNIX
4405         || family != AF_UNIX
4406 #endif
4407     ) {
4408         errno = EAFNOSUPPORT;
4409         return -1;
4410     }
4411     if (!fd) {
4412         errno = EINVAL;
4413         return -1;
4414     }
4415
4416 #ifdef EMULATE_SOCKETPAIR_UDP
4417     if (type == SOCK_DGRAM)
4418         return S_socketpair_udp(fd);
4419 #endif
4420
4421     aTHXa(PERL_GET_THX);
4422     listener = PerlSock_socket(AF_INET, type, 0);
4423     if (listener == -1)
4424         return -1;
4425     memset(&listen_addr, 0, sizeof(listen_addr));
4426     listen_addr.sin_family = AF_INET;
4427     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4428     listen_addr.sin_port = 0;   /* kernel choses port.  */
4429     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4430             sizeof(listen_addr)) == -1)
4431         goto tidy_up_and_fail;
4432     if (PerlSock_listen(listener, 1) == -1)
4433         goto tidy_up_and_fail;
4434
4435     connector = PerlSock_socket(AF_INET, type, 0);
4436     if (connector == -1)
4437         goto tidy_up_and_fail;
4438     /* We want to find out the port number to connect to.  */
4439     size = sizeof(connect_addr);
4440     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4441             &size) == -1)
4442         goto tidy_up_and_fail;
4443     if (size != sizeof(connect_addr))
4444         goto abort_tidy_up_and_fail;
4445     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4446             sizeof(connect_addr)) == -1)
4447         goto tidy_up_and_fail;
4448
4449     size = sizeof(listen_addr);
4450     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4451             &size);
4452     if (acceptor == -1)
4453         goto tidy_up_and_fail;
4454     if (size != sizeof(listen_addr))
4455         goto abort_tidy_up_and_fail;
4456     PerlLIO_close(listener);
4457     /* Now check we are talking to ourself by matching port and host on the
4458        two sockets.  */
4459     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4460             &size) == -1)
4461         goto tidy_up_and_fail;
4462     if (size != sizeof(connect_addr)
4463             || listen_addr.sin_family != connect_addr.sin_family
4464             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4465             || listen_addr.sin_port != connect_addr.sin_port) {
4466         goto abort_tidy_up_and_fail;
4467     }
4468     fd[0] = connector;
4469     fd[1] = acceptor;
4470     return 0;
4471
4472   abort_tidy_up_and_fail:
4473 #ifdef ECONNABORTED
4474   errno = ECONNABORTED; /* This would be the standard thing to do. */
4475 #else
4476 #  ifdef ECONNREFUSED
4477   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4478 #  else
4479   errno = ETIMEDOUT;    /* Desperation time. */
4480 #  endif
4481 #endif
4482   tidy_up_and_fail:
4483     {
4484         dSAVE_ERRNO;
4485         if (listener != -1)
4486             PerlLIO_close(listener);
4487         if (connector != -1)
4488             PerlLIO_close(connector);
4489         if (acceptor != -1)
4490             PerlLIO_close(acceptor);
4491         RESTORE_ERRNO;
4492         return -1;
4493     }
4494 }
4495 #else
4496 /* In any case have a stub so that there's code corresponding
4497  * to the my_socketpair in embed.fnc. */
4498 int
4499 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4500 #ifdef HAS_SOCKETPAIR
4501     return socketpair(family, type, protocol, fd);
4502 #else
4503     return -1;
4504 #endif
4505 }
4506 #endif
4507
4508 /*
4509
4510 =for apidoc sv_nosharing
4511
4512 Dummy routine which "shares" an SV when there is no sharing module present.
4513 Or "locks" it.  Or "unlocks" it.  In other
4514 words, ignores its single SV argument.
4515 Exists to avoid test for a C<NULL> function pointer and because it could
4516 potentially warn under some level of strict-ness.
4517
4518 =cut
4519 */
4520
4521 void
4522 Perl_sv_nosharing(pTHX_ SV *sv)
4523 {
4524     PERL_UNUSED_CONTEXT;
4525     PERL_UNUSED_ARG(sv);
4526 }
4527
4528 /*
4529
4530 =for apidoc sv_destroyable
4531
4532 Dummy routine which reports that object can be destroyed when there is no
4533 sharing module present.  It ignores its single SV argument, and returns
4534 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4535 could potentially warn under some level of strict-ness.
4536
4537 =cut
4538 */
4539
4540 bool
4541 Perl_sv_destroyable(pTHX_ SV *sv)
4542 {
4543     PERL_UNUSED_CONTEXT;
4544     PERL_UNUSED_ARG(sv);
4545     return TRUE;
4546 }
4547
4548 U32
4549 Perl_parse_unicode_opts(pTHX_ const char **popt)
4550 {
4551   const char *p = *popt;
4552   U32 opt = 0;
4553
4554   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4555
4556   if (*p) {
4557        if (isDIGIT(*p)) {
4558             const char* endptr;
4559             UV uv;
4560             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4561                 opt = (U32)uv;
4562                 p = endptr;
4563                 if (p && *p && *p != '\n' && *p != '\r') {
4564                     if (isSPACE(*p))
4565                         goto the_end_of_the_opts_parser;
4566                     else
4567                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4568                 }
4569             }
4570             else {
4571                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4572             }
4573         }
4574         else {
4575             for (; *p; p++) {
4576                  switch (*p) {
4577                  case PERL_UNICODE_STDIN:
4578                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4579                  case PERL_UNICODE_STDOUT:
4580                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4581                  case PERL_UNICODE_STDERR:
4582                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4583                  case PERL_UNICODE_STD:
4584                       opt |= PERL_UNICODE_STD_FLAG;     break;
4585                  case PERL_UNICODE_IN:
4586                       opt |= PERL_UNICODE_IN_FLAG;      break;
4587                  case PERL_UNICODE_OUT:
4588                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4589                  case PERL_UNICODE_INOUT:
4590                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4591                  case PERL_UNICODE_LOCALE:
4592                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4593                  case PERL_UNICODE_ARGV:
4594                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4595                  case PERL_UNICODE_UTF8CACHEASSERT:
4596                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4597                  default:
4598                       if (*p != '\n' && *p != '\r') {
4599                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4600                         else
4601                           Perl_croak(aTHX_
4602                                      "Unknown Unicode option letter '%c'", *p);
4603                       }
4604                  }
4605             }
4606        }
4607   }
4608   else
4609        opt = PERL_UNICODE_DEFAULT_FLAGS;
4610
4611   the_end_of_the_opts_parser:
4612
4613   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4614        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4615                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4616
4617   *popt = p;
4618
4619   return opt;
4620 }
4621
4622 #ifdef VMS
4623 #  include <starlet.h>
4624 #endif
4625
4626 U32
4627 Perl_seed(pTHX)
4628 {
4629     /*
4630      * This is really just a quick hack which grabs various garbage
4631      * values.  It really should be a real hash algorithm which
4632      * spreads the effect of every input bit onto every output bit,
4633      * if someone who knows about such things would bother to write it.
4634      * Might be a good idea to add that function to CORE as well.
4635      * No numbers below come from careful analysis or anything here,
4636      * except they are primes and SEED_C1 > 1E6 to get a full-width
4637      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4638      * probably be bigger too.
4639      */
4640 #if RANDBITS > 16
4641 #  define SEED_C1       1000003
4642 #define   SEED_C4       73819
4643 #else
4644 #  define SEED_C1       25747
4645 #define   SEED_C4       20639
4646 #endif
4647 #define   SEED_C2       3
4648 #define   SEED_C3       269
4649 #define   SEED_C5       26107
4650
4651 #ifndef PERL_NO_DEV_RANDOM
4652     int fd;
4653 #endif
4654     U32 u;
4655 #ifdef HAS_GETTIMEOFDAY
4656     struct timeval when;
4657 #else
4658     Time_t when;
4659 #endif
4660
4661 /* This test is an escape hatch, this symbol isn't set by Configure. */
4662 #ifndef PERL_NO_DEV_RANDOM
4663 #ifndef PERL_RANDOM_DEVICE
4664    /* /dev/random isn't used by default because reads from it will block
4665     * if there isn't enough entropy available.  You can compile with
4666     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4667     * is enough real entropy to fill the seed. */
4668 #  ifdef __amigaos4__
4669 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4670 #  else
4671 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4672 #  endif
4673 #endif
4674     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4675     if (fd != -1) {
4676         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4677             u = 0;
4678         PerlLIO_close(fd);
4679         if (u)
4680             return u;
4681     }
4682 #endif
4683
4684 #ifdef HAS_GETTIMEOFDAY
4685     PerlProc_gettimeofday(&when,NULL);
4686     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4687 #else
4688     (void)time(&when);
4689     u = (U32)SEED_C1 * when;
4690 #endif
4691     u += SEED_C3 * (U32)PerlProc_getpid();
4692     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4693 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4694     u += SEED_C5 * (U32)PTR2UV(&when);
4695 #endif
4696     return u;
4697 }
4698
4699 void
4700 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4701 {
4702     const char *env_pv;
4703     unsigned long i;
4704
4705     PERL_ARGS_ASSERT_GET_HASH_SEED;
4706
4707     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4708
4709     if ( env_pv )
4710 #ifndef USE_HASH_SEED_EXPLICIT
4711     {
4712         /* ignore leading spaces */
4713         while (isSPACE(*env_pv))
4714             env_pv++;
4715 #ifdef USE_PERL_PERTURB_KEYS
4716         /* if they set it to "0" we disable key traversal randomization completely */
4717         if (strEQ(env_pv,"0")) {
4718             PL_hash_rand_bits_enabled= 0;
4719         } else {
4720             /* otherwise switch to deterministic mode */
4721             PL_hash_rand_bits_enabled= 2;
4722         }
4723 #endif
4724         /* ignore a leading 0x... if it is there */
4725         if (env_pv[0] == '0' && env_pv[1] == 'x')
4726             env_pv += 2;
4727
4728         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4729             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4730             if ( isXDIGIT(*env_pv)) {
4731                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4732             }
4733         }
4734         while (isSPACE(*env_pv))
4735             env_pv++;
4736
4737         if (*env_pv && !isXDIGIT(*env_pv)) {
4738             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4739         }
4740         /* should we check for unparsed crap? */
4741         /* should we warn about unused hex? */
4742         /* should we warn about insufficient hex? */
4743     }
4744     else
4745 #endif
4746     {
4747         (void)seedDrand01((Rand_seed_t)seed());
4748
4749         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4750             seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4751         }
4752     }
4753 #ifdef USE_PERL_PERTURB_KEYS
4754     {   /* initialize PL_hash_rand_bits from the hash seed.
4755          * This value is highly volatile, it is updated every
4756          * hash insert, and is used as part of hash bucket chain
4757          * randomization and hash iterator randomization. */
4758         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4759         for( i = 0; i < sizeof(UV) ; i++ ) {
4760             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4761             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4762         }
4763     }
4764     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4765     if (env_pv) {
4766         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4767             PL_hash_rand_bits_enabled= 0;
4768         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4769             PL_hash_rand_bits_enabled= 1;
4770         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4771             PL_hash_rand_bits_enabled= 2;
4772         } else {
4773             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4774         }
4775     }
4776 #endif
4777 }
4778
4779 #ifdef PERL_GLOBAL_STRUCT
4780
4781 #define PERL_GLOBAL_STRUCT_INIT
4782 #include "opcode.h" /* the ppaddr and check */
4783
4784 struct perl_vars *
4785 Perl_init_global_struct(pTHX)
4786 {
4787     struct perl_vars *plvarsp = NULL;
4788 # ifdef PERL_GLOBAL_STRUCT
4789     const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4790     const IV ncheck  = C_ARRAY_LENGTH(Gcheck);
4791     PERL_UNUSED_CONTEXT;
4792 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4793     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4794     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4795     if (!plvarsp)
4796         exit(1);
4797 #  else
4798     plvarsp = PL_VarsPtr;
4799 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4800 #  undef PERLVAR
4801 #  undef PERLVARA
4802 #  undef PERLVARI
4803 #  undef PERLVARIC
4804 #  define PERLVAR(prefix,var,type) /**/
4805 #  define PERLVARA(prefix,var,n,type) /**/
4806 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4807 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4808 #  include "perlvars.h"
4809 #  undef PERLVAR
4810 #  undef PERLVARA
4811 #  undef PERLVARI
4812 #  undef PERLVARIC
4813 #  ifdef PERL_GLOBAL_STRUCT
4814     plvarsp->Gppaddr =
4815         (Perl_ppaddr_t*)
4816         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4817     if (!plvarsp->Gppaddr)
4818         exit(1);
4819     plvarsp->Gcheck  =
4820         (Perl_check_t*)
4821         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4822     if (!plvarsp->Gcheck)
4823         exit(1);
4824     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4825     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
4826 #  endif
4827 #  ifdef PERL_SET_VARS
4828     PERL_SET_VARS(plvarsp);
4829 #  endif
4830 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4831     plvarsp->Gsv_placeholder.sv_flags = 0;
4832     memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4833 #  endif
4834 # undef PERL_GLOBAL_STRUCT_INIT
4835 # endif
4836     return plvarsp;
4837 }
4838
4839 #endif /* PERL_GLOBAL_STRUCT */
4840
4841 #ifdef PERL_GLOBAL_STRUCT
4842
4843 void
4844 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4845 {
4846     int veto = plvarsp->Gveto_cleanup;
4847
4848     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4849     PERL_UNUSED_CONTEXT;
4850 # ifdef PERL_GLOBAL_STRUCT
4851 #  ifdef PERL_UNSET_VARS
4852     PERL_UNSET_VARS(plvarsp);
4853 #  endif
4854     if (veto)
4855         return;
4856     free(plvarsp->Gppaddr);
4857     free(plvarsp->Gcheck);
4858 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4859     free(plvarsp);
4860 #  endif
4861 # endif
4862 }
4863
4864 #endif /* PERL_GLOBAL_STRUCT */
4865
4866 #ifdef PERL_MEM_LOG
4867
4868 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4869  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4870  * given, and you supply your own implementation.
4871  *
4872  * The default implementation reads a single env var, PERL_MEM_LOG,
4873  * expecting one or more of the following:
4874  *
4875  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4876  *    'm' - memlog      was PERL_MEM_LOG=1
4877  *    's' - svlog       was PERL_SV_LOG=1
4878  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4879  *
4880  * This makes the logger controllable enough that it can reasonably be
4881  * added to the system perl.
4882  */
4883
4884 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4885  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4886  */
4887 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4888
4889 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4890  * writes to.  In the default logger, this is settable at runtime.
4891  */
4892 #ifndef PERL_MEM_LOG_FD
4893 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4894 #endif
4895
4896 #ifndef PERL_MEM_LOG_NOIMPL
4897
4898 # ifdef DEBUG_LEAKING_SCALARS
4899 #   define SV_LOG_SERIAL_FMT        " [%lu]"
4900 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
4901 # else
4902 #   define SV_LOG_SERIAL_FMT
4903 #   define _SV_LOG_SERIAL_ARG(sv)
4904 # endif
4905
4906 static void
4907 S_mem_log_common(enum mem_log_type mlt, const UV n,
4908                  const UV typesize, const char *type_name, const SV *sv,
4909                  Malloc_t oldalloc, Malloc_t newalloc,
4910                  const char *filename, const int linenumber,
4911                  const char *funcname)
4912 {
4913     const char *pmlenv;
4914
4915     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4916
4917     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4918     if (!pmlenv)
4919         return;
4920     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4921     {
4922         /* We can't use SVs or PerlIO for obvious reasons,
4923          * so we'll use stdio and low-level IO instead. */
4924         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4925
4926 #   ifdef HAS_GETTIMEOFDAY
4927 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
4928 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
4929         struct timeval tv;
4930         gettimeofday(&tv, 0);
4931 #   else
4932 #     define MEM_LOG_TIME_FMT   "%10d: "
4933 #     define MEM_LOG_TIME_ARG   (int)when
4934         Time_t when;
4935         (void)time(&when);
4936 #   endif
4937         /* If there are other OS specific ways of hires time than
4938          * gettimeofday() (see dist/Time-HiRes), the easiest way is
4939          * probably that they would be used to fill in the struct
4940          * timeval. */
4941         {
4942             STRLEN len;
4943             const char* endptr;
4944             int fd;
4945             UV uv;
4946             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4947                 && uv && uv <= PERL_INT_MAX
4948             ) {
4949                 fd = (int)uv;
4950             } else {
4951                 fd = PERL_MEM_LOG_FD;
4952             }
4953
4954             if (strchr(pmlenv, 't')) {
4955                 len = my_snprintf(buf, sizeof(buf),
4956                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4957                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4958             }
4959             switch (mlt) {
4960             case MLT_ALLOC:
4961                 len = my_snprintf(buf, sizeof(buf),
4962                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
4963                         " %s = %"IVdf": %"UVxf"\n",
4964                         filename, linenumber, funcname, n, typesize,
4965                         type_name, n * typesize, PTR2UV(newalloc));
4966                 break;
4967             case MLT_REALLOC:
4968                 len = my_snprintf(buf, sizeof(buf),
4969                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
4970                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
4971                         filename, linenumber, funcname, n, typesize,
4972                         type_name, n * typesize, PTR2UV(oldalloc),
4973                         PTR2UV(newalloc));
4974                 break;
4975             case MLT_FREE:
4976                 len = my_snprintf(buf, sizeof(buf),
4977                         "free: %s:%d:%s: %"UVxf"\n",
4978                         filename, linenumber, funcname,
4979                         PTR2UV(oldalloc));
4980                 break;
4981             case MLT_NEW_SV:
4982             case MLT_DEL_SV:
4983                 len = my_snprintf(buf, sizeof(buf),
4984                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
4985                         mlt == MLT_NEW_SV ? "new" : "del",
4986                         filename, linenumber, funcname,
4987                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4988                 break;
4989             default:
4990                 len = 0;
4991             }
4992             PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4993         }
4994     }
4995 }
4996 #endif /* !PERL_MEM_LOG_NOIMPL */
4997
4998 #ifndef PERL_MEM_LOG_NOIMPL
4999 # define \
5000     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5001     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5002 #else
5003 /* this is suboptimal, but bug compatible.  User is providing their
5004    own implementation, but is getting these functions anyway, and they
5005    do nothing. But _NOIMPL users should be able to cope or fix */
5006 # define \
5007     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5008     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5009 #endif
5010
5011 Malloc_t
5012 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5013                    Malloc_t newalloc,
5014                    const char *filename, const int linenumber,
5015                    const char *funcname)
5016 {
5017     PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5018
5019     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5020                       NULL, NULL, newalloc,
5021                       filename, linenumber, funcname);
5022     return newalloc;
5023 }
5024
5025 Malloc_t
5026 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5027                      Malloc_t oldalloc, Malloc_t newalloc,
5028                      const char *filename, const int linenumber,
5029                      const char *funcname)
5030 {
5031     PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5032
5033     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5034                       NULL, oldalloc, newalloc,
5035                       filename, linenumber, funcname);
5036     return newalloc;
5037 }
5038
5039 Malloc_t
5040 Perl_mem_log_free(Malloc_t oldalloc,
5041                   const char *filename, const int linenumber,
5042                   const char *funcname)
5043 {
5044     PERL_ARGS_ASSERT_MEM_LOG_FREE;
5045
5046     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5047                       filename, linenumber, funcname);
5048     return oldalloc;
5049 }
5050
5051 void
5052 Perl_mem_log_new_sv(const SV *sv,
5053                     const char *filename, const int linenumber,
5054                     const char *funcname)
5055 {
5056     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5057                       filename, linenumber, funcname);
5058 }
5059
5060 void
5061 Perl_mem_log_del_sv(const SV *sv,
5062                     const char *filename, const int linenumber,
5063                     const char *funcname)
5064 {
5065     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5066                       filename, linenumber, funcname);
5067 }
5068
5069 #endif /* PERL_MEM_LOG */
5070
5071 /*
5072 =for apidoc my_sprintf
5073
5074 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5075 the length of the string written to the buffer.  Only rare pre-ANSI systems
5076 need the wrapper function - usually this is a direct call to C<sprintf>.
5077
5078 =cut
5079 */
5080 #ifndef SPRINTF_RETURNS_STRLEN
5081 int
5082 Perl_my_sprintf(char *buffer, const char* pat, ...)
5083 {
5084     va_list args;
5085     PERL_ARGS_ASSERT_MY_SPRINTF;
5086     va_start(args, pat);
5087     vsprintf(buffer, pat, args);
5088     va_end(args);
5089     return strlen(buffer);
5090 }
5091 #endif
5092
5093 /*
5094 =for apidoc quadmath_format_single
5095
5096 C<quadmath_snprintf()> is very strict about its C<format> string and will
5097 fail, returning -1, if the format is invalid.  It accepts exactly
5098 one format spec.
5099
5100 C<quadmath_format_single()> checks that the intended single spec looks
5101 sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
5102 and has C<Q> before it.  This is not a full "printf syntax check",
5103 just the basics.
5104
5105 Returns the format if it is valid, NULL if not.
5106
5107 C<quadmath_format_single()> can and will actually patch in the missing
5108 C<Q>, if necessary.  In this case it will return the modified copy of
5109 the format, B<which the caller will need to free.>
5110
5111 See also L</quadmath_format_needed>.
5112
5113 =cut
5114 */
5115 #ifdef USE_QUADMATH
5116 const char*
5117 Perl_quadmath_format_single(const char* format)
5118 {
5119     STRLEN len;
5120
5121     PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
5122
5123     if (format[0] != '%' || strchr(format + 1, '%'))
5124         return NULL;
5125     len = strlen(format);
5126     /* minimum length three: %Qg */
5127     if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
5128         return NULL;
5129     if (format[len - 2] != 'Q') {
5130         char* fixed;
5131         Newx(fixed, len + 1, char);
5132         memcpy(fixed, format, len - 1);
5133         fixed[len - 1] = 'Q';
5134         fixed[len    ] = format[len - 1];
5135         fixed[len + 1] = 0;
5136         return (const char*)fixed;
5137     }
5138     return format;
5139 }
5140 #endif
5141
5142 /*
5143 =for apidoc quadmath_format_needed
5144
5145 C<quadmath_format_needed()> returns true if the C<format> string seems to
5146 contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
5147 or returns false otherwise.
5148
5149 The format specifier detection is not complete printf-syntax detection,
5150 but it should catch most common cases.
5151
5152 If true is returned, those arguments B<should> in theory be processed
5153 with C<quadmath_snprintf()>, but in case there is more than one such
5154 format specifier (see L</quadmath_format_single>), and if there is
5155 anything else beyond that one (even just a single byte), they
5156 B<cannot> be processed because C<quadmath_snprintf()> is very strict,
5157 accepting only one format spec, and nothing else.
5158 In this case, the code should probably fail.
5159
5160 =cut
5161 */
5162 #ifdef USE_QUADMATH
5163 bool
5164 Perl_quadmath_format_needed(const char* format)
5165 {
5166   const char *p = format;
5167   const char *q;
5168
5169   PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
5170
5171   while ((q = strchr(p, '%'))) {
5172     q++;
5173     if (*q == '+') /* plus */
5174       q++;
5175     if (*q == '#') /* alt */
5176       q++;
5177     if (*q == '*') /* width */
5178       q++;
5179     else {
5180       if (isDIGIT(*q)) {
5181         while (isDIGIT(*q)) q++;
5182       }
5183     }
5184     if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
5185       q++;
5186       if (*q == '*')
5187         q++;
5188       else
5189         while (isDIGIT(*q)) q++;
5190     }
5191     if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
5192       return TRUE;
5193     p = q + 1;
5194   }
5195   return FALSE;
5196 }
5197 #endif
5198
5199 /*
5200 =for apidoc my_snprintf
5201
5202 The C library C<snprintf> functionality, if available and
5203 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5204 C<vsnprintf> is not available, will unfortunately use the unsafe
5205 C<vsprintf> which can overrun the buffer (there is an overrun check,
5206 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5207 getting C<vsnprintf>.
5208
5209 =cut
5210 */
5211 int
5212 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5213 {
5214     int retval = -1;
5215     va_list ap;
5216     PERL_ARGS_ASSERT_MY_SNPRINTF;
5217 #ifndef HAS_VSNPRINTF
5218     PERL_UNUSED_VAR(len);
5219 #endif
5220     va_start(ap, format);
5221 #ifdef USE_QUADMATH
5222     {
5223         const char* qfmt = quadmath_format_single(format);
5224         bool quadmath_valid = FALSE;
5225         if (qfmt) {
5226             /* If the format looked promising, use it as quadmath. */
5227             retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
5228             if (retval == -1)
5229                 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
5230             quadmath_valid = TRUE;
5231             if (qfmt != format)
5232                 Safefree(qfmt);
5233             qfmt = NULL;
5234         }
5235         assert(qfmt == NULL);
5236         /* quadmath_format_single() will return false for example for
5237          * "foo = %g", or simply "%g".  We could handle the %g by
5238          * using quadmath for the NV args.  More complex cases of
5239          * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
5240          * quadmath-valid but has stuff in front).
5241          *
5242          * Handling the "Q-less" cases right would require walking
5243          * through the va_list and rewriting the format, calling
5244          * quadmath for the NVs, building a new va_list, and then
5245          * letting vsnprintf/vsprintf to take care of the other
5246          * arguments.  This may be doable.
5247          *
5248          * We do not attempt that now.  But for paranoia, we here try
5249          * to detect some common (but not all) cases where the
5250          * "Q-less" %[efgaEFGA] formats are present, and die if
5251          * detected.  This doesn't fix the problem, but it stops the
5252          * vsnprintf/vsprintf pulling doubles off the va_list when
5253          * __float128 NVs should be pulled off instead.
5254          *
5255          * If quadmath_format_needed() returns false, we are reasonably
5256          * certain that we can call vnsprintf() or vsprintf() safely. */
5257         if (!quadmath_valid && quadmath_format_needed(format))
5258           Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
5259
5260     }
5261 #endif
5262     if (retval == -1)
5263 #ifdef HAS_VSNPRINTF
5264         retval = vsnprintf(buffer, len, format, ap);
5265 #else
5266         retval = vsprintf(buffer, format, ap);
5267 #endif
5268     va_end(ap);
5269     /* vsprintf() shows failure with < 0 */
5270     if (retval < 0
5271 #ifdef HAS_VSNPRINTF
5272     /* vsnprintf() shows failure with >= len */
5273         ||
5274         (len > 0 && (Size_t)retval >= len)
5275 #endif
5276     )
5277         Perl_croak_nocontext("panic: my_snprintf buffer overflow");
5278     return retval;
5279 }
5280
5281 /*
5282 =for apidoc my_vsnprintf
5283
5284 The C library C<vsnprintf> if available and standards-compliant.
5285 However, if if the C<vsnprintf> is not available, will unfortunately
5286 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5287 overrun check, but that may be too late).  Consider using
5288 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5289
5290 =cut
5291 */
5292 int
5293 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5294 {
5295 #ifdef USE_QUADMATH
5296     PERL_UNUSED_ARG(buffer);
5297     PERL_UNUSED_ARG(len);
5298     PERL_UNUSED_ARG(format);
5299     PERL_UNUSED_ARG(ap);
5300     Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
5301     return 0;
5302 #else
5303     int retval;
5304 #ifdef NEED_VA_COPY
5305     va_list apc;
5306
5307     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5308     Perl_va_copy(ap, apc);
5309 # ifdef HAS_VSNPRINTF
5310     retval = vsnprintf(buffer, len, format, apc);
5311 # else
5312     PERL_UNUSED_ARG(len);
5313     retval = vsprintf(buffer, format, apc);
5314 # endif
5315     va_end(apc);
5316 #else
5317 # ifdef HAS_VSNPRINTF
5318     retval = vsnprintf(buffer, len, format, ap);
5319 # else
5320     PERL_UNUSED_ARG(len);
5321     retval = vsprintf(buffer, format, ap);
5322 # endif
5323 #endif /* #ifdef NEED_VA_COPY */
5324     /* vsprintf() shows failure with < 0 */
5325     if (retval < 0
5326 #ifdef HAS_VSNPRINTF
5327     /* vsnprintf() shows failure with >= len */
5328         ||
5329         (len > 0 && (Size_t)retval >= len)
5330 #endif
5331     )
5332         Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
5333     return retval;
5334 #endif
5335 }
5336
5337 void
5338 Perl_my_clearenv(pTHX)
5339 {
5340     dVAR;
5341 #if ! defined(PERL_MICRO)
5342 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5343     PerlEnv_clearenv();
5344 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5345 #    if defined(USE_ENVIRON_ARRAY)
5346 #      if defined(USE_ITHREADS)
5347     /* only the parent thread can clobber the process environment */
5348     if (PL_curinterp == aTHX)
5349 #      endif /* USE_ITHREADS */
5350     {
5351 #      if ! defined(PERL_USE_SAFE_PUTENV)
5352     if ( !PL_use_safe_putenv) {
5353       I32 i;
5354       if (environ == PL_origenviron)
5355         environ = (char**)safesysmalloc(sizeof(char*));
5356       else
5357         for (i = 0; environ[i]; i++)
5358           (void)safesysfree(environ[i]);
5359     }
5360     environ[0] = NULL;
5361 #      else /* PERL_USE_SAFE_PUTENV */
5362 #        if defined(HAS_CLEARENV)
5363     (void)clearenv();
5364 #        elif defined(HAS_UNSETENV)
5365     int bsiz = 80; /* Most envvar names will be shorter than this. */
5366     char *buf = (char*)safesysmalloc(bsiz);
5367     while (*environ != NULL) {
5368       char *e = strchr(*environ, '=');
5369       int l = e ? e - *environ : (int)strlen(*environ);
5370       if (bsiz < l + 1) {
5371         (void)safesysfree(buf);
5372         bsiz = l + 1; /* + 1 for the \0. */
5373         buf = (char*)safesysmalloc(bsiz);
5374       }
5375       memcpy(buf, *environ, l);
5376       buf[l] = '\0';
5377       (void)unsetenv(buf);
5378     }
5379     (void)safesysfree(buf);
5380 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5381     /* Just null environ and accept the leakage. */
5382     *environ = NULL;
5383 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5384 #      endif /* ! PERL_USE_SAFE_PUTENV */
5385     }
5386 #    endif /* USE_ENVIRON_ARRAY */
5387 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5388 #endif /* PERL_MICRO */
5389 }
5390
5391 #ifdef PERL_IMPLICIT_CONTEXT
5392
5393 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5394 the global PL_my_cxt_index is incremented, and that value is assigned to
5395 that module's static my_cxt_index (who's address is passed as an arg).
5396 Then, for each interpreter this function is called for, it makes sure a
5397 void* slot is available to hang the static data off, by allocating or
5398 extending the interpreter's PL_my_cxt_list array */
5399
5400 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5401 void *
5402 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5403 {
5404     dVAR;
5405     void *p;
5406     PERL_ARGS_ASSERT_MY_CXT_INIT;
5407     if (*index == -1) {
5408         /* this module hasn't been allocated an index yet */
5409 #if defined(USE_ITHREADS)
5410         MUTEX_LOCK(&PL_my_ctx_mutex);
5411 #endif
5412         *index = PL_my_cxt_index++;
5413 #if defined(USE_ITHREADS)
5414         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5415 #endif
5416     }
5417
5418     /* make sure the array is big enough */
5419     if (PL_my_cxt_size <= *index) {
5420         if (PL_my_cxt_size) {
5421             while (PL_my_cxt_size <= *index)
5422                 PL_my_cxt_size *= 2;
5423             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5424         }
5425         else {
5426             PL_my_cxt_size = 16;
5427             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5428         }
5429     }
5430     /* newSV() allocates one more than needed */
5431     p = (void*)SvPVX(newSV(size-1));
5432     PL_my_cxt_list[*index] = p;
5433     Zero(p, size, char);
5434     return p;
5435 }
5436
5437 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5438
5439 int
5440 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5441 {
5442     dVAR;
5443     int index;
5444
5445     PERL_ARGS_ASSERT_MY_CXT_INDEX;
5446
5447     for (index = 0; index < PL_my_cxt_index; index++) {
5448         const char *key = PL_my_cxt_keys[index];
5449         /* try direct pointer compare first - there are chances to success,
5450          * and it's much faster.
5451          */
5452         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5453             return index;
5454     }
5455     return -1;
5456 }
5457
5458 void *
5459 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5460 {
5461     dVAR;
5462     void *p;
5463     int index;
5464
5465     PERL_ARGS_ASSERT_MY_CXT_INIT;
5466
5467     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5468     if (index == -1) {
5469         /* this module hasn't been allocated an index yet */
5470 #if defined(USE_ITHREADS)
5471         MUTEX_LOCK(&PL_my_ctx_mutex);
5472 #endif
5473         index = PL_my_cxt_index++;
5474 #if defined(USE_ITHREADS)
5475         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5476 #endif
5477     }
5478
5479     /* make sure the array is big enough */
5480     if (PL_my_cxt_size <= index) {
5481         int old_size = PL_my_cxt_size;
5482         int i;
5483         if (PL_my_cxt_size) {
5484             while (PL_my_cxt_size <= index)
5485                 PL_my_cxt_size *= 2;
5486             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5487             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5488         }
5489         else {
5490             PL_my_cxt_size = 16;
5491             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5492             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5493         }
5494         for (i = old_size; i < PL_my_cxt_size; i++) {
5495             PL_my_cxt_keys[i] = 0;
5496             PL_my_cxt_list[i] = 0;
5497         }
5498     }
5499     PL_my_cxt_keys[index] = my_cxt_key;
5500     /* newSV() allocates one more than needed */
5501     p = (void*)SvPVX(newSV(size-1));
5502     PL_my_cxt_list[index] = p;
5503     Zero(p, size, char);
5504     return p;
5505 }
5506 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5507 #endif /* PERL_IMPLICIT_CONTEXT */
5508
5509
5510 /* Perl_xs_handshake():
5511    implement the various XS_*_BOOTCHECK macros, which are added to .c
5512    files by ExtUtils::ParseXS, to check that the perl the module was built
5513    with is binary compatible with the running perl.
5514
5515    usage:
5516        Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
5517             [U32 items, U32 ax], [char * api_version], [char * xs_version])
5518
5519    The meaning of the varargs is determined the U32 key arg (which is not
5520    a format string). The fields of key are assembled by using HS_KEY().
5521
5522    Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
5523    "PerlInterpreter *" and represents the callers context; otherwise it is
5524    of type "CV *", and is the boot xsub's CV.
5525
5526    v_my_perl will catch where a threaded future perl526.dll calling IO.dll
5527    for example, and IO.dll was linked with threaded perl524.dll, and both
5528    perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
5529    successfully can load IO.dll into the process but simultaneously it
5530    loaded an interpreter of a different version into the process, and XS
5531    code will naturally pass SV*s created by perl524.dll for perl526.dll to
5532    use through perl526.dll's my_perl->Istack_base.
5533
5534    v_my_perl cannot be the first arg, since then 'key' will be out of
5535    place in a threaded vs non-threaded mixup; and analyzing the key
5536    number's bitfields won't reveal the problem, since it will be a valid
5537    key (unthreaded perl) on interp side, but croak will report the XS mod's
5538    key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
5539    it's a threaded perl and an unthreaded XS module, threaded perl will
5540    look at an uninit C stack or an uninit register to get 'key'
5541    (remember that it assumes that the 1st arg is the interp cxt).
5542
5543    'file' is the source filename of the caller.
5544 */
5545
5546 I32
5547 Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
5548 {
5549     va_list args;
5550     U32 items, ax;
5551     void * got;
5552     void * need;
5553 #ifdef PERL_IMPLICIT_CONTEXT
5554     dTHX;
5555     tTHX xs_interp;
5556 #else
5557     CV* cv;
5558     SV *** xs_spp;
5559 #endif
5560     PERL_ARGS_ASSERT_XS_HANDSHAKE;
5561     va_start(args, file);
5562
5563     got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
5564     need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
5565     if (UNLIKELY(got != need))
5566         goto bad_handshake;
5567 /* try to catch where a 2nd threaded perl interp DLL is loaded into a process
5568    by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
5569    2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
5570    dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
5571    passed to the XS DLL */
5572 #ifdef PERL_IMPLICIT_CONTEXT
5573     xs_interp = (tTHX)v_my_perl;
5574     got = xs_interp;
5575     need = my_perl;
5576 #else
5577 /* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
5578    loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
5579    but the DynaLoder/Perl that started the process and loaded the XS DLL is
5580    unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
5581    through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
5582    location in the unthreaded perl binary) stored in CV * to figure out if this
5583    Perl_xs_handshake was called by the same pp_entersub */
5584     cv = (CV*)v_my_perl;
5585     xs_spp = (SV***)CvHSCXT(cv);
5586     got = xs_spp;
5587     need = &PL_stack_sp;
5588 #endif
5589     if(UNLIKELY(got != need)) {
5590         bad_handshake:/* recycle branch and string from above */
5591         if(got != (void *)HSf_NOCHK)
5592             noperl_die("%s: loadable library and perl binaries are mismatched"
5593                        " (got handshake key %p, needed %p)\n",
5594                 file, got, need);
5595     }
5596
5597     if(key & HSf_SETXSUBFN) {     /* this might be called from a module bootstrap */
5598         SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
5599         PL_xsubfilename = file;   /* so the old name must be restored for
5600                                      additional XSUBs to register themselves */
5601         /* XSUBs can't be perl lang/perl5db.pl debugged
5602         if (PERLDB_LINE_OR_SAVESRC)
5603             (void)gv_fetchfile(file); */
5604     }
5605
5606     if(key & HSf_POPMARK) {
5607         ax = POPMARK;
5608         {   SV **mark = PL_stack_base + ax++;
5609             {   dSP;
5610                 items = (I32)(SP - MARK);
5611             }
5612         }
5613     } else {
5614         items = va_arg(args, U32);
5615         ax = va_arg(args, U32);
5616     }
5617     {
5618         U32 apiverlen;
5619         assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
5620         if((apiverlen = HS_GETAPIVERLEN(key))) {
5621             char * api_p = va_arg(args, char*);
5622             if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
5623                 || memNE(api_p, "v" PERL_API_VERSION_STRING,
5624                          sizeof("v" PERL_API_VERSION_STRING)-1))
5625                 Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s",
5626                                     api_p, SVfARG(PL_stack_base[ax + 0]),
5627                                     "v" PERL_API_VERSION_STRING);
5628         }
5629     }
5630     {
5631         U32 xsverlen;
5632         assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
5633         if((xsverlen = HS_GETXSVERLEN(key)))
5634             S_xs_version_bootcheck(aTHX_
5635                 items, ax, va_arg(args, char*), xsverlen);
5636     }
5637     va_end(args);
5638     return ax;
5639 }
5640
5641
5642 STATIC void
5643 S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
5644                           STRLEN xs_len)
5645 {
5646     SV *sv;
5647     const char *vn = NULL;
5648     SV *const module = PL_stack_base[ax];
5649
5650     PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
5651
5652     if (items >= 2)      /* version supplied as bootstrap arg */
5653         sv = PL_stack_base[ax + 1];
5654     else {
5655         /* XXX GV_ADDWARN */
5656         vn = "XS_VERSION";
5657         sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
5658         if (!sv || !SvOK(sv)) {
5659             vn = "VERSION";
5660             sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
5661         }
5662     }
5663     if (sv) {
5664         SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
5665         SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
5666             ? sv : sv_2mortal(new_version(sv));
5667         xssv = upg_version(xssv, 0);
5668         if ( vcmp(pmsv,xssv) ) {
5669             SV *string = vstringify(xssv);
5670             SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
5671                                     " does not match ", SVfARG(module), SVfARG(string));
5672
5673             SvREFCNT_dec(string);
5674             string = vstringify(pmsv);
5675
5676             if (vn) {
5677                 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn,
5678                                SVfARG(string));
5679             } else {
5680                 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
5681             }
5682             SvREFCNT_dec(string);
5683
5684             Perl_sv_2mortal(aTHX_ xpt);
5685             Perl_croak_sv(aTHX_ xpt);
5686         }
5687     }
5688 }
5689
5690 /*
5691 =for apidoc my_strlcat
5692
5693 The C library C<strlcat> if available, or a Perl implementation of it.
5694 This operates on C C<NUL>-terminated strings.
5695
5696 C<my_strlcat()> appends string C<src> to the end of C<dst>.  It will append at
5697 most S<C<size - strlen(dst) - 1>> characters.  It will then C<NUL>-terminate,
5698 unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
5699 practice this should not happen as it means that either C<size> is incorrect or
5700 that C<dst> is not a proper C<NUL>-terminated string).
5701
5702 Note that C<size> is the full size of the destination buffer and
5703 the result is guaranteed to be C<NUL>-terminated if there is room.  Note that
5704 room for the C<NUL> should be included in C<size>.
5705
5706 =cut
5707
5708 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
5709 */
5710 #ifndef HAS_STRLCAT
5711 Size_t
5712 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5713 {
5714     Size_t used, length, copy;
5715
5716     used = strlen(dst);
5717     length = strlen(src);
5718     if (size > 0 && used < size - 1) {
5719         copy = (length >= size - used) ? size - used - 1 : length;
5720         memcpy(dst + used, src, copy);
5721         dst[used + copy] = '\0';
5722     }
5723     return used + length;
5724 }
5725 #endif
5726
5727
5728 /*
5729 =for apidoc my_strlcpy
5730
5731 The C library C<strlcpy> if available, or a Perl implementation of it.
5732 This operates on C C<NUL>-terminated strings.
5733
5734 C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
5735 to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
5736
5737 =cut
5738
5739 Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
5740 */
5741 #ifndef HAS_STRLCPY
5742 Size_t
5743 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5744 {
5745     Size_t length, copy;
5746
5747     length = strlen(src);
5748     if (size > 0) {
5749         copy = (length >= size) ? size - 1 : length;
5750         memcpy(dst, src, copy);
5751         dst[copy] = '\0';
5752     }
5753     return length;
5754 }
5755 #endif
5756
5757 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5758 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5759 long _ftol( double ); /* Defined by VC6 C libs. */
5760 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5761 #endif
5762
5763 PERL_STATIC_INLINE bool
5764 S_gv_has_usable_name(pTHX_ GV *gv)
5765 {
5766     GV **gvp;
5767     return GvSTASH(gv)
5768         && HvENAME(GvSTASH(gv))
5769         && (gvp = (GV **)hv_fetchhek(
5770                         GvSTASH(gv), GvNAME_HEK(gv), 0
5771            ))
5772         && *gvp == gv;
5773 }
5774
5775 void
5776 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5777 {
5778     SV * const dbsv = GvSVn(PL_DBsub);
5779     const bool save_taint = TAINT_get;
5780
5781     /* When we are called from pp_goto (svp is null),
5782      * we do not care about using dbsv to call CV;
5783      * it's for informational purposes only.
5784      */
5785
5786     PERL_ARGS_ASSERT_GET_DB_SUB;
5787
5788     TAINT_set(FALSE);
5789     save_item(dbsv);
5790     if (!PERLDB_SUB_NN) {
5791         GV *gv = CvGV(cv);
5792
5793         if (!svp && !CvLEXICAL(cv)) {
5794             gv_efullname3(dbsv, gv, NULL);
5795         }
5796         else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
5797              || strEQ(GvNAME(gv), "END")
5798              || ( /* Could be imported, and old sub redefined. */
5799                  (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
5800                  &&
5801                  !( (SvTYPE(*svp) == SVt_PVGV)
5802                     && (GvCV((const GV *)*svp) == cv)
5803                     /* Use GV from the stack as a fallback. */
5804                     && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
5805                   )
5806                 )
5807         ) {
5808             /* GV is potentially non-unique, or contain different CV. */
5809             SV * const tmp = newRV(MUTABLE_SV(cv));
5810             sv_setsv(dbsv, tmp);
5811             SvREFCNT_dec(tmp);
5812         }
5813         else {
5814             sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
5815             sv_catpvs(dbsv, "::");
5816             sv_cathek(dbsv, GvNAME_HEK(gv));
5817         }
5818     }
5819     else {
5820         const int type = SvTYPE(dbsv);
5821         if (type < SVt_PVIV && type != SVt_IV)
5822             sv_upgrade(dbsv, SVt_PVIV);
5823         (void)SvIOK_on(dbsv);
5824         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
5825     }
5826     SvSETMAGIC(dbsv);
5827     TAINT_IF(save_taint);
5828 #ifdef NO_TAINT_SUPPORT
5829     PERL_UNUSED_VAR(save_taint);
5830 #endif
5831 }
5832
5833 int
5834 Perl_my_dirfd(DIR * dir) {
5835
5836     /* Most dirfd implementations have problems when passed NULL. */
5837     if(!dir)
5838         return -1;
5839 #ifdef HAS_DIRFD
5840     return dirfd(dir);
5841 #elif defined(HAS_DIR_DD_FD)
5842     return dir->dd_fd;
5843 #else
5844     Perl_croak_nocontext(PL_no_func, "dirfd");
5845     NOT_REACHED; /* NOTREACHED */
5846     return 0;
5847 #endif
5848 }
5849
5850 REGEXP *
5851 Perl_get_re_arg(pTHX_ SV *sv) {
5852
5853     if (sv) {
5854         if (SvMAGICAL(sv))
5855             mg_get(sv);
5856         if (SvROK(sv))
5857             sv = MUTABLE_SV(SvRV(sv));
5858         if (SvTYPE(sv) == SVt_REGEXP)
5859             return (REGEXP*) sv;
5860     }
5861
5862     return NULL;
5863 }
5864
5865 /*
5866  * This code is derived from drand48() implementation from FreeBSD,
5867  * found in lib/libc/gen/_rand48.c.
5868  *
5869  * The U64 implementation is original, based on the POSIX
5870  * specification for drand48().
5871  */
5872
5873 /*
5874 * Copyright (c) 1993 Martin Birgmeier
5875 * All rights reserved.
5876 *
5877 * You may redistribute unmodified or modified versions of this source
5878 * code provided that the above copyright notice and this and the
5879 * following conditions are retained.
5880 *
5881 * This software is provided ``as is'', and comes with no warranties
5882 * of any kind. I shall in no event be liable for anything that happens
5883 * to anyone/anything when using this software.
5884 */
5885
5886 #define FREEBSD_DRAND48_SEED_0   (0x330e)
5887
5888 #ifdef PERL_DRAND48_QUAD
5889
5890 #define DRAND48_MULT U64_CONST(0x5deece66d)
5891 #define DRAND48_ADD  0xb
5892 #define DRAND48_MASK U64_CONST(0xffffffffffff)
5893
5894 #else
5895
5896 #define FREEBSD_DRAND48_SEED_1   (0xabcd)
5897 #define FREEBSD_DRAND48_SEED_2   (0x1234)
5898 #define FREEBSD_DRAND48_MULT_0   (0xe66d)
5899 #define FREEBSD_DRAND48_MULT_1   (0xdeec)
5900 #define FREEBSD_DRAND48_MULT_2   (0x0005)
5901 #define FREEBSD_DRAND48_ADD      (0x000b)
5902
5903 const unsigned short _rand48_mult[3] = {
5904                 FREEBSD_DRAND48_MULT_0,
5905                 FREEBSD_DRAND48_MULT_1,
5906                 FREEBSD_DRAND48_MULT_2
5907 };
5908 const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
5909
5910 #endif
5911
5912 void
5913 Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
5914 {
5915     PERL_ARGS_ASSERT_DRAND48_INIT_R;
5916
5917 #ifdef PERL_DRAND48_QUAD
5918     *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
5919 #else
5920     random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
5921     random_state->seed[1] = (U16) seed;
5922     random_state->seed[2] = (U16) (seed >> 16);
5923 #endif
5924 }
5925
5926 double
5927 Perl_drand48_r(perl_drand48_t *random_state)
5928 {
5929     PERL_ARGS_ASSERT_DRAND48_R;
5930
5931 #ifdef PERL_DRAND48_QUAD
5932     *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
5933         & DRAND48_MASK;
5934
5935     return ldexp((double)*random_state, -48);
5936 #else
5937     {
5938     U32 accu;
5939     U16 temp[2];
5940
5941     accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
5942          + (U32) _rand48_add;
5943     temp[0] = (U16) accu;        /* lower 16 bits */
5944     accu >>= sizeof(U16) * 8;
5945     accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
5946           + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
5947     temp[1] = (U16) accu;        /* middle 16 bits */
5948     accu >>= sizeof(U16) * 8;
5949     accu += _rand48_mult[0] * random_state->seed[2]
5950           + _rand48_mult[1] * random_state->seed[1]
5951           + _rand48_mult[2] * random_state->seed[0];
5952     random_state->seed[0] = temp[0];
5953     random_state->seed[1] = temp[1];
5954     random_state->seed[2] = (U16) accu;
5955
5956     return ldexp((double) random_state->seed[0], -48) +
5957            ldexp((double) random_state->seed[1], -32) +
5958            ldexp((double) random_state->seed[2], -16);
5959     }
5960 #endif
5961 }
5962
5963 #ifdef USE_C_BACKTRACE
5964
5965 /* Possibly move all this USE_C_BACKTRACE code into a new file. */
5966
5967 #ifdef USE_BFD
5968
5969 typedef struct {
5970     /* abfd is the BFD handle. */
5971     bfd* abfd;
5972     /* bfd_syms is the BFD symbol table. */
5973     asymbol** bfd_syms;
5974     /* bfd_text is handle to the the ".text" section of the object file. */
5975     asection* bfd_text;
5976     /* Since opening the executable and scanning its symbols is quite
5977      * heavy operation, we remember the filename we used the last time,
5978      * and do the opening and scanning only if the filename changes.
5979      * This removes most (but not all) open+scan cycles. */
5980     const char* fname_prev;
5981 } bfd_context;
5982
5983 /* Given a dl_info, update the BFD context if necessary. */
5984 static void bfd_update(bfd_context* ctx, Dl_info* dl_info)
5985 {
5986     /* BFD open and scan only if the filename changed. */
5987     if (ctx->fname_prev == NULL ||
5988         strNE(dl_info->dli_fname, ctx->fname_prev)) {
5989         if (ctx->abfd) {
5990             bfd_close(ctx->abfd);
5991         }
5992         ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
5993         if (ctx->abfd) {
5994             if (bfd_check_format(ctx->abfd, bfd_object)) {
5995                 IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd);
5996                 if (symbol_size > 0) {
5997                     Safefree(ctx->bfd_syms);
5998                     Newx(ctx->bfd_syms, symbol_size, asymbol*);
5999                     ctx->bfd_text =
6000                         bfd_get_section_by_name(ctx->abfd, ".text");
6001                 }
6002                 else
6003                     ctx->abfd = NULL;
6004             }
6005             else
6006                 ctx->abfd = NULL;
6007         }
6008         ctx->fname_prev = dl_info->dli_fname;
6009     }
6010 }
6011
6012 /* Given a raw frame, try to symbolize it and store
6013  * symbol information (source file, line number) away. */
6014 static void bfd_symbolize(bfd_context* ctx,
6015                           void* raw_frame,
6016                           char** symbol_name,
6017                           STRLEN* symbol_name_size,
6018                           char** source_name,
6019                           STRLEN* source_name_size,
6020                           STRLEN* source_line)
6021 {
6022     *symbol_name = NULL;
6023     *symbol_name_size = 0;
6024     if (ctx->abfd) {
6025         IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma);
6026         if (offset > 0 &&
6027             bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) {
6028             const char *file;
6029             const char *func;
6030             unsigned int line = 0;
6031             if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text,
6032                                       ctx->bfd_syms, offset,
6033                                       &file, &func, &line) &&
6034                 file && func && line > 0) {
6035                 /* Size and copy the source file, use only
6036                  * the basename of the source file.
6037                  *
6038                  * NOTE: the basenames are fine for the
6039                  * Perl source files, but may not always
6040                  * be the best idea for XS files. */
6041                 const char *p, *b = NULL;
6042                 /* Look for the last slash. */
6043                 for (p = file; *p; p++) {
6044                     if (*p == '/')
6045                         b = p + 1;
6046                 }
6047                 if (b == NULL || *b == 0) {
6048                     b = file;
6049                 }
6050                 *source_name_size = p - b + 1;
6051                 Newx(*source_name, *source_name_size + 1, char);
6052                 Copy(b, *source_name, *source_name_size + 1, char);
6053
6054                 *symbol_name_size = strlen(func);
6055                 Newx(*symbol_name, *symbol_name_size + 1, char);
6056                 Copy(func, *symbol_name, *symbol_name_size + 1, char);
6057
6058                 *source_line = line;
6059             }
6060         }
6061     }
6062 }
6063
6064 #endif /* #ifdef USE_BFD */
6065
6066 #ifdef PERL_DARWIN
6067
6068 /* OS X has no public API for for 'symbolicating' (Apple official term)
6069  * stack addresses to {function_name, source_file, line_number}.
6070  * Good news: there is command line utility atos(1) which does that.
6071  * Bad news 1: it's a command line utility.
6072  * Bad news 2: one needs to have the Developer Tools installed.
6073  * Bad news 3: in newer releases it needs to be run as 'xcrun atos'.
6074  *
6075  * To recap: we need to open a pipe for reading for a utility which
6076  * might not exist, or exists in different locations, and then parse
6077  * the output.  And since this is all for a low-level API, we cannot
6078  * use high-level stuff.  Thanks, Apple. */
6079
6080 typedef struct {
6081     /* tool is set to the absolute pathname of the tool to use:
6082      * xcrun or atos. */
6083     const char* tool;
6084     /* format is set to a printf format string used for building
6085      * the external command to run. */
6086     const char* format;
6087     /* unavail is set if e.g. xcrun cannot be found, or something
6088      * else happens that makes getting the backtrace dubious.  Note,
6089      * however, that the context isn't persistent, the next call to
6090      * get_c_backtrace() will start from scratch. */
6091     bool unavail;
6092     /* fname is the current object file name. */
6093     const char* fname;
6094     /* object_base_addr is the base address of the shared object. */
6095     void* object_base_addr;
6096 } atos_context;
6097
6098 /* Given |dl_info|, updates the context.  If the context has been
6099  * marked unavailable, return immediately.  If not but the tool has
6100  * not been set, set it to either "xcrun atos" or "atos" (also set the
6101  * format to use for creating commands for piping), or if neither is
6102  * unavailable (one needs the Developer Tools installed), mark the context
6103  * an unavailable.  Finally, update the filename (object name),
6104  * and its base address. */
6105
6106 static void atos_update(atos_context* ctx,
6107                         Dl_info* dl_info)
6108 {
6109     if (ctx->unavail)
6110         return;
6111     if (ctx->tool == NULL) {
6112         const char* tools[] = {
6113             "/usr/bin/xcrun",
6114             "/usr/bin/atos"
6115         };
6116         const char* formats[] = {
6117             "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1",
6118             "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1"
6119         };
6120         struct stat st;
6121         UV i;
6122         for (i = 0; i < C_ARRAY_LENGTH(tools); i++) {
6123             if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) {
6124                 ctx->tool = tools[i];
6125                 ctx->format = formats[i];
6126                 break;
6127             }
6128         }
6129         if (ctx->tool == NULL) {
6130             ctx->unavail = TRUE;
6131             return;
6132         }
6133     }
6134     if (ctx->fname == NULL ||
6135         strNE(dl_info->dli_fname, ctx->fname)) {
6136         ctx->fname = dl_info->dli_fname;
6137         ctx->object_base_addr = dl_info->dli_fbase;
6138     }
6139 }
6140
6141 /* Given an output buffer end |p| and its |start|, matches
6142  * for the atos output, extracting the source code location
6143  * and returning non-NULL if possible, returning NULL otherwise. */
6144 static const char* atos_parse(const char* p,
6145                               const char* start,
6146                               STRLEN* source_name_size,
6147                               STRLEN* source_line) {
6148     /* atos() output is something like:
6149      * perl_parse (in miniperl) (perl.c:2314)\n\n".
6150      * We cannot use Perl regular expressions, because we need to
6151      * stay low-level.  Therefore here we have a rolled-out version
6152      * of a state machine which matches _backwards_from_the_end_ and
6153      * if there's a success, returns the starts of the filename,
6154      * also setting the filename size and the source line number.
6155      * The matched regular expression is roughly "\(.*:\d+\)\s*$" */
6156     const char* source_number_start;
6157     const char* source_name_end;
6158     const char* source_line_end;
6159     const char* close_paren;
6160     UV uv;
6161
6162     /* Skip trailing whitespace. */
6163     while (p > start && isspace(*p)) p--;
6164     /* Now we should be at the close paren. */
6165     if (p == start || *p != ')')
6166         return NULL;
6167     close_paren = p;
6168     p--;
6169     /* Now we should be in the line number. */
6170     if (p == start || !isdigit(*p))
6171         return NULL;
6172     /* Skip over the digits. */
6173     while (p > start && isdigit(*p))
6174         p--;
6175     /* Now we should be at the colon. */
6176     if (p == start || *p != ':')
6177         return NULL;
6178     source_number_start = p + 1;
6179     source_name_end = p; /* Just beyond the end. */
6180     p--;
6181     /* Look for the open paren. */
6182     while (p > start && *p != '(')
6183         p--;
6184     if (p == start)
6185         return NULL;
6186     p++;
6187     *source_name_size = source_name_end - p;
6188     if (grok_atoUV(source_number_start, &uv,  &source_line_end)
6189         && source_line_end == close_paren
6190         && uv <= PERL_INT_MAX
6191     ) {
6192         *source_line = (STRLEN)uv;
6193         return p;
6194     }
6195     return NULL;
6196 }
6197
6198 /* Given a raw frame, read a pipe from the symbolicator (that's the
6199  * technical term) atos, reads the result, and parses the source code
6200  * location.  We must stay low-level, so we use snprintf(), pipe(),
6201  * and fread(), and then also parse the output ourselves. */
6202 static void atos_symbolize(atos_context* ctx,
6203                            void* raw_frame,
6204                            char** source_name,
6205                            STRLEN* source_name_size,
6206                            STRLEN* source_line)
6207 {
6208     char cmd[1024];
6209     const char* p;
6210     Size_t cnt;
6211
6212     if (ctx->unavail)
6213         return;
6214     /* Simple security measure: if there's any funny business with
6215      * the object name (used as "-o '%s'" ), leave since at least
6216      * partially the user controls it. */
6217     for (p = ctx->fname; *p; p++) {
6218         if (*p == '\'' || iscntrl(*p)) {
6219             ctx->unavail = TRUE;
6220             return;
6221         }
6222     }
6223     cnt = snprintf(cmd, sizeof(cmd), ctx->format,
6224                    ctx->fname, ctx->object_base_addr, raw_frame);
6225     if (cnt < sizeof(cmd)) {
6226         /* Undo nostdio.h #defines that disable stdio.
6227          * This is somewhat naughty, but is used elsewhere
6228          * in the core, and affects only OS X. */
6229 #undef FILE
6230 #undef popen
6231 #undef fread
6232 #undef pclose
6233         FILE* fp = popen(cmd, "r");
6234         /* At the moment we open a new pipe for each stack frame.
6235          * This is naturally somewhat slow, but hopefully generating
6236          * stack traces is never going to in a performance critical path.
6237          *
6238          * We could play tricks with atos by batching the stack
6239          * addresses to be resolved: atos can either take multiple
6240          * addresses from the command line, or read addresses from
6241          * a file (though the mess of creating temporary files would
6242          * probably negate much of any possible speedup).
6243          *
6244          * Normally there are only two objects present in the backtrace:
6245          * perl itself, and the libdyld.dylib.  (Note that the object
6246          * filenames contain the full pathname, so perl may not always
6247          * be in the same place.)  Whenever the object in the
6248          * backtrace changes, the base address also changes.
6249          *
6250          * The problem with batching the addresses, though, would be
6251          * matching the results with the addresses: the parsing of
6252          * the results is already painful enough with a single address. */
6253         if (fp) {
6254             char out[1024];
6255             UV cnt = fread(out, 1, sizeof(out), fp);
6256             if (cnt < sizeof(out)) {
6257                 const char* p = atos_parse(out + cnt - 1, out,
6258                                            source_name_size,
6259                                            source_line);
6260                 if (p) {
6261                     Newx(*source_name,
6262                          *source_name_size, char);
6263                     Copy(p, *source_name,
6264                          *source_name_size,  char);
6265                 }
6266             }
6267             pclose(fp);
6268         }
6269     }
6270 }
6271
6272 #endif /* #ifdef PERL_DARWIN */
6273
6274 /*
6275 =for apidoc get_c_backtrace
6276
6277 Collects the backtrace (aka "stacktrace") into a single linear
6278 malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
6279
6280 Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
6281 returning at most C<depth> frames.
6282
6283 =cut
6284 */
6285
6286 Perl_c_backtrace*
6287 Perl_get_c_backtrace(pTHX_ int depth, int skip)
6288 {
6289     /* Note that here we must stay as low-level as possible: Newx(),
6290      * Copy(), Safefree(); since we may be called from anywhere,
6291      * so we should avoid higher level constructs like SVs or AVs.
6292      *
6293      * Since we are using safesysmalloc() via Newx(), don't try
6294      * getting backtrace() there, unless you like deep recursion. */
6295
6296     /* Currently only implemented with backtrace() and dladdr(),
6297      * for other platforms NULL is returned. */
6298
6299 #if defined(HAS_BACKTRACE) && defined(HAS_DLADDR)
6300     /* backtrace() is available via <execinfo.h> in glibc and in most
6301      * modern BSDs; dladdr() is available via <dlfcn.h>. */
6302
6303     /* We try fetching this many frames total, but then discard
6304      * the |skip| first ones.  For the remaining ones we will try
6305      * retrieving more information with dladdr(). */
6306     int try_depth = skip +  depth;
6307
6308     /* The addresses (program counters) returned by backtrace(). */
6309     void** raw_frames;
6310
6311     /* Retrieved with dladdr() from the addresses returned by backtrace(). */
6312     Dl_info* dl_infos;
6313
6314     /* Sizes _including_ the terminating \0 of the object name
6315      * and symbol name strings. */
6316     STRLEN* object_name_sizes;
6317     STRLEN* symbol_name_sizes;
6318
6319 #ifdef USE_BFD
6320     /* The symbol names comes either from dli_sname,
6321      * or if using BFD, they can come from BFD. */
6322     char** symbol_names;
6323 #endif
6324
6325     /* The source code location information.  Dug out with e.g. BFD. */
6326     char** source_names;
6327     STRLEN* source_name_sizes;
6328     STRLEN* source_lines;
6329
6330     Perl_c_backtrace* bt = NULL;  /* This is what will be returned. */
6331     int got_depth; /* How many frames were returned from backtrace(). */
6332     UV frame_count = 0; /* How many frames we return. */
6333     UV total_bytes = 0; /* The size of the whole returned backtrace. */
6334
6335 #ifdef USE_BFD
6336     bfd_context bfd_ctx;
6337 #endif
6338 #ifdef PERL_DARWIN
6339     atos_context atos_ctx;
6340 #endif
6341
6342     /* Here are probably possibilities for optimizing.  We could for
6343      * example have a struct that contains most of these and then
6344      * allocate |try_depth| of them, saving a bunch of malloc calls.
6345      * Note, however, that |frames| could not be part of that struct
6346      * because backtrace() will want an array of just them.  Also be
6347      * careful about the name strings. */
6348     Newx(raw_frames, try_depth, void*);
6349     Newx(dl_infos, try_depth, Dl_info);
6350     Newx(object_name_sizes, try_depth, STRLEN);
6351     Newx(symbol_name_sizes, try_depth, STRLEN);
6352     Newx(source_names, try_depth, char*);
6353     Newx(source_name_sizes, try_depth, STRLEN);
6354     Newx(source_lines, try_depth, STRLEN);
6355 #ifdef USE_BFD
6356     Newx(symbol_names, try_depth, char*);
6357 #endif
6358
6359     /* Get the raw frames. */
6360     got_depth = (int)backtrace(raw_frames, try_depth);
6361
6362     /* We use dladdr() instead of backtrace_symbols() because we want
6363      * the full details instead of opaque strings.  This is useful for
6364      * two reasons: () the details are needed for further symbolic
6365      * digging, for example in OS X (2) by having the details we fully
6366      * control the output, which in turn is useful when more platforms
6367      * are added: we can keep out output "portable". */
6368
6369     /* We want a single linear allocation, which can then be freed
6370      * with a single swoop.  We will do the usual trick of first
6371      * walking over the structure and seeing how much we need to
6372      * allocate, then allocating, and then walking over the structure
6373      * the second time and populating it. */
6374
6375     /* First we must compute the total size of the buffer. */
6376     total_bytes = sizeof(Perl_c_backtrace_header);
6377     if (got_depth > skip) {
6378         int i;
6379 #ifdef USE_BFD
6380         bfd_init(); /* Is this safe to call multiple times? */
6381         Zero(&bfd_ctx, 1, bfd_context);
6382 #endif
6383 #ifdef PERL_DARWIN
6384         Zero(&atos_ctx, 1, atos_context);
6385 #endif
6386         for (i = skip; i < try_depth; i++) {
6387             Dl_info* dl_info = &dl_infos[i];
6388
6389             object_name_sizes[i] = 0;
6390             source_names[i] = NULL;
6391             source_name_sizes[i] = 0;
6392             source_lines[i] = 0;
6393
6394             /* Yes, zero from dladdr() is failure. */
6395             if (dladdr(raw_frames[i], dl_info)) {
6396                 total_bytes += sizeof(Perl_c_backtrace_frame);
6397
6398                 object_name_sizes[i] =
6399                     dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
6400                 symbol_name_sizes[i] =
6401                     dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0;
6402 #ifdef USE_BFD
6403                 bfd_update(&bfd_ctx, dl_info);
6404                 bfd_symbolize(&bfd_ctx, raw_frames[i],
6405                               &symbol_names[i],
6406                               &symbol_name_sizes[i],
6407                               &source_names[i],
6408                               &source_name_sizes[i],
6409                               &source_lines[i]);
6410 #endif
6411 #if PERL_DARWIN
6412                 atos_update(&atos_ctx, dl_info);
6413                 atos_symbolize(&atos_ctx,
6414                                raw_frames[i],
6415                                &source_names[i],
6416                                &source_name_sizes[i],
6417                                &source_lines[i]);
6418 #endif
6419
6420                 /* Plus ones for the terminating \0. */
6421                 total_bytes += object_name_sizes[i] + 1;
6422                 total_bytes += symbol_name_sizes[i] + 1;
6423                 total_bytes += source_name_sizes[i] + 1;
6424
6425                 frame_count++;
6426             } else {
6427                 break;
6428             }
6429         }
6430 #ifdef USE_BFD
6431         Safefree(bfd_ctx.bfd_syms);
6432 #endif
6433     }
6434
6435     /* Now we can allocate and populate the result buffer. */
6436     Newxc(bt, total_bytes, char, Perl_c_backtrace);
6437     Zero(bt, total_bytes, char);
6438     bt->header.frame_count = frame_count;
6439     bt->header.total_bytes = total_bytes;
6440     if (frame_count > 0) {
6441         Perl_c_backtrace_frame* frame = bt->frame_info;
6442         char* name_base = (char *)(frame + frame_count);
6443         char* name_curr = name_base; /* Outputting the name strings here. */
6444         UV i;
6445         for (i = skip; i < skip + frame_count; i++) {
6446             Dl_info* dl_info = &dl_infos[i];
6447
6448             frame->addr = raw_frames[i];
6449             frame->object_base_addr = dl_info->dli_fbase;
6450             frame->symbol_addr = dl_info->dli_saddr;
6451
6452             /* Copies a string, including the \0, and advances the name_curr.
6453              * Also copies the start and the size to the frame. */
6454 #define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \
6455             if (size && src) \
6456                 Copy(src, name_curr, size, char); \
6457             frame->doffset = name_curr - (char*)bt; \
6458             frame->dsize = size; \
6459             name_curr += size; \
6460             *name_curr++ = 0;
6461
6462             PERL_C_BACKTRACE_STRCPY(frame, object_name_offset,
6463                                     dl_info->dli_fname,
6464                                     object_name_size, object_name_sizes[i]);
6465
6466 #ifdef USE_BFD
6467             PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6468                                     symbol_names[i],
6469                                     symbol_name_size, symbol_name_sizes[i]);
6470             Safefree(symbol_names[i]);
6471 #else
6472             PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset,
6473                                     dl_info->dli_sname,
6474                                     symbol_name_size, symbol_name_sizes[i]);
6475 #endif
6476
6477             PERL_C_BACKTRACE_STRCPY(frame, source_name_offset,
6478                                     source_names[i],
6479                                     source_name_size, source_name_sizes[i]);
6480             Safefree(source_names[i]);
6481
6482 #undef PERL_C_BACKTRACE_STRCPY
6483
6484             frame->source_line_number = source_lines[i];
6485
6486             frame++;
6487         }
6488         assert(total_bytes ==
6489                (UV)(sizeof(Perl_c_backtrace_header) +
6490                     frame_count * sizeof(Perl_c_backtrace_frame) +
6491                     name_curr - name_base));
6492     }
6493 #ifdef USE_BFD
6494     Safefree(symbol_names);
6495     if (bfd_ctx.abfd) {
6496         bfd_close(bfd_ctx.abfd);
6497     }
6498 #endif
6499     Safefree(source_lines);
6500     Safefree(source_name_sizes);
6501     Safefree(source_names);
6502     Safefree(symbol_name_sizes);
6503     Safefree(object_name_sizes);
6504     /* Assuming the strings returned by dladdr() are pointers
6505      * to read-only static memory (the object file), so that
6506      * they do not need freeing (and cannot be). */
6507     Safefree(dl_infos);
6508     Safefree(raw_frames);
6509     return bt;
6510 #else
6511     PERL_UNUSED_ARGV(depth);
6512     PERL_UNUSED_ARGV(skip);
6513     return NULL;
6514 #endif
6515 }
6516
6517 /*
6518 =for apidoc free_c_backtrace
6519
6520 Deallocates a backtrace received from get_c_bracktrace.
6521
6522 =cut
6523 */
6524
6525 /*
6526 =for apidoc get_c_backtrace_dump
6527
6528 Returns a SV containing a dump of C<depth> frames of the call stack, skipping
6529 the C<skip> innermost ones.  C<depth> of 20 is usually enough.
6530
6531 The appended output looks like:
6532
6533 ...
6534 1   10e004812:0082   Perl_croak   util.c:1716    /usr/bin/perl
6535 2   10df8d6d2:1d72   perl_parse   perl.c:3975    /usr/bin/perl
6536 ...
6537
6538 The fields are tab-separated.  The first column is the depth (zero
6539 being the innermost non-skipped frame).  In the hex:offset, the hex is
6540 where the program counter was in C<S_parse_body>, and the :offset (might
6541 be missing) tells how much inside the C<S_parse_body> the program counter was.
6542
6543 The C<util.c:1716> is the source code file and line number.
6544
6545 The F</usr/bin/perl> is obvious (hopefully).
6546
6547 Unknowns are C<"-">.  Unknowns can happen unfortunately quite easily:
6548 if the platform doesn't support retrieving the information;
6549 if the binary is missing the debug information;
6550 if the optimizer has transformed the code by for example inlining.
6551
6552 =cut
6553 */
6554
6555 SV*
6556 Perl_get_c_backtrace_dump(pTHX_ int depth, int skip)
6557 {
6558     Perl_c_backtrace* bt;
6559
6560     bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */);
6561     if (bt) {
6562         Perl_c_backtrace_frame* frame;
6563         SV* dsv = newSVpvs("");
6564         UV i;
6565         for (i = 0, frame = bt->frame_info;
6566              i < bt->header.frame_count; i++, frame++) {
6567             Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i);
6568             Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-");
6569             /* Symbol (function) names might disappear without debug info.
6570              *
6571              * The source code location might disappear in case of the
6572              * optimizer inlining or otherwise rearranging the code. */
6573             if (frame->symbol_addr) {
6574                 Perl_sv_catpvf(aTHX_ dsv, ":%04x",
6575                                (int)
6576                                ((char*)frame->addr - (char*)frame->symbol_addr));
6577             }
6578             Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6579                            frame->symbol_name_size &&
6580                            frame->symbol_name_offset ?
6581                            (char*)bt + frame->symbol_name_offset : "-");
6582             if (frame->source_name_size &&
6583                 frame->source_name_offset &&
6584                 frame->source_line_number) {
6585                 Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
6586                                (char*)bt + frame->source_name_offset,
6587                                (UV)frame->source_line_number);
6588             } else {
6589                 Perl_sv_catpvf(aTHX_ dsv, "\t-");
6590             }
6591             Perl_sv_catpvf(aTHX_ dsv, "\t%s",
6592                            frame->object_name_size &&
6593                            frame->object_name_offset ?
6594                            (char*)bt + frame->object_name_offset : "-");
6595             /* The frame->object_base_addr is not output,
6596              * but it is used for symbolizing/symbolicating. */
6597             sv_catpvs(dsv, "\n");
6598         }
6599
6600         Perl_free_c_backtrace(aTHX_ bt);
6601
6602         return dsv;
6603     }
6604
6605     return NULL;
6606 }
6607
6608 /*
6609 =for apidoc dump_c_backtrace
6610
6611 Dumps the C backtrace to the given C<fp>.
6612
6613 Returns true if a backtrace could be retrieved, false if not.
6614
6615 =cut
6616 */
6617
6618 bool
6619 Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
6620 {
6621     SV* sv;
6622
6623     PERL_ARGS_ASSERT_DUMP_C_BACKTRACE;
6624
6625     sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip);
6626     if (sv) {
6627         sv_2mortal(sv);
6628         PerlIO_printf(fp, "%s", SvPV_nolen(sv));
6629         return TRUE;
6630     }
6631     return FALSE;
6632 }
6633
6634 #endif /* #ifdef USE_C_BACKTRACE */
6635
6636 #ifdef PERL_TSA_ACTIVE
6637
6638 /* pthread_mutex_t and perl_mutex are typedef equivalent
6639  * so casting the pointers is fine. */
6640
6641 int perl_tsa_mutex_lock(perl_mutex* mutex)
6642 {
6643     return pthread_mutex_lock((pthread_mutex_t *) mutex);
6644 }
6645
6646 int perl_tsa_mutex_unlock(perl_mutex* mutex)
6647 {
6648     return pthread_mutex_unlock((pthread_mutex_t *) mutex);
6649 }
6650
6651 int perl_tsa_mutex_destroy(perl_mutex* mutex)
6652 {
6653     return pthread_mutex_destroy((pthread_mutex_t *) mutex);
6654 }
6655
6656 #endif
6657
6658
6659 #ifdef USE_DTRACE
6660
6661 /* log a sub call or return */
6662
6663 void
6664 Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call)
6665 {
6666     const char *func;
6667     const char *file;
6668     const char *stash;
6669     const COP  *start;
6670     line_t      line;
6671
6672     PERL_ARGS_ASSERT_DTRACE_PROBE_CALL;
6673
6674     if (CvNAMED(cv)) {
6675         HEK *hek = CvNAME_HEK(cv);
6676         func = HEK_KEY(hek);
6677     }
6678     else {
6679         GV  *gv = CvGV(cv);
6680         func = GvENAME(gv);
6681     }
6682     start = (const COP *)CvSTART(cv);
6683     file  = CopFILE(start);
6684     line  = CopLINE(start);
6685     stash = CopSTASHPV(start);
6686
6687     if (is_call) {
6688         PERL_SUB_ENTRY(func, file, line, stash);
6689     }
6690     else {
6691         PERL_SUB_RETURN(func, file, line, stash);
6692     }
6693 }
6694
6695
6696 /* log a require file loading/loaded  */
6697
6698 void
6699 Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading)
6700 {
6701     PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
6702
6703     if (is_loading) {
6704         PERL_LOADING_FILE(name);
6705     }
6706     else {
6707         PERL_LOADED_FILE(name);
6708     }
6709 }
6710
6711
6712 /* log an op execution */
6713
6714 void
6715 Perl_dtrace_probe_op(pTHX_ const OP *op)
6716 {
6717     PERL_ARGS_ASSERT_DTRACE_PROBE_OP;
6718
6719     PERL_OP_ENTRY(OP_NAME(op));
6720 }
6721
6722
6723 /* log a compile/run phase change */
6724
6725 void
6726 Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase)
6727 {
6728     const char *ph_old = PL_phase_names[PL_phase];
6729     const char *ph_new = PL_phase_names[phase];
6730
6731     PERL_PHASE_CHANGE(ph_new, ph_old);
6732 }
6733
6734 #endif
6735
6736 /*
6737  * ex: set ts=8 sts=4 sw=4 et:
6738  */