util.c

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