util.c

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