util.c

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