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