util.c

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