util.c

   1 /*    util.c
   2  *
   3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
   4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
  13  *  not content.'                                    --Gandalf to Pippin
  14  *
  15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
  16  */
  17
  18 /* This file contains assorted utility routines.
  19  * Which is a polite way of saying any stuff that people couldn't think of
  20  * a better place for. Amongst other things, it includes the warning and
  21  * dieing stuff, plus wrappers for malloc code.
  22  */
  23
  24 #include "EXTERN.h"
  25 #define PERL_IN_UTIL_C
  26 #include "perl.h"
  27 #include "reentr.h"
  28
  29 #if defined(USE_PERLIO)
  30 #include "perliol.h" /* For PerlIOUnix_refcnt */
  31 #endif
  32
  33 #ifndef PERL_MICRO
  34 #include <signal.h>
  35 #ifndef SIG_ERR
  36 # define SIG_ERR ((Sighandler_t) -1)
  37 #endif
  38 #endif
  39
  40 #include <math.h>
  41 #include <stdlib.h>
  42
  43 #ifdef __Lynx__
  44 /* Missing protos on LynxOS */
  45 int putenv(char *);
  46 #endif
  47
  48 #ifdef __amigaos__
  49 # include "amigaos4/amigaio.h"
  50 #endif
  51
  52 #ifdef HAS_SELECT
  53 # ifdef I_SYS_SELECT
  54 #  include <sys/select.h>
  55 # endif
  56 #endif
  57
  58 #ifdef USE_C_BACKTRACE
  59 #  ifdef I_BFD
  60 #    define USE_BFD
  61 #    ifdef PERL_DARWIN
  62 #      undef USE_BFD /* BFD is useless in OS X. */
  63 #    endif
  64 #    ifdef USE_BFD
  65 #      include <bfd.h>
  66 #    endif
  67 #  endif
  68 #  ifdef I_DLFCN
  69 #    include <dlfcn.h>
  70 #  endif
  71 #  ifdef I_EXECINFO
  72 #    include <execinfo.h>
  73 #  endif
  74 #endif
  75
  76 #ifdef PERL_DEBUG_READONLY_COW
  77 # include <sys/mman.h>
  78 #endif
  79
  80 #define FLUSH
  81
  82 /* NOTE:  Do not call the next three routines directly.  Use the macros
  83  * in handy.h, so that we can easily redefine everything to do tracking of
  84  * allocated hunks back to the original New to track down any memory leaks.
  85  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  86  */
  87
  88 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
  89 #  define ALWAYS_NEED_THX
  90 #endif
  91
  92 #if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
  93 static void
  94 S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
  95 {
  96     if (header->readonly
  97      && mprotect(header, header->size, PROT_READ|PROT_WRITE))
  98         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
  99                          header, header->size, errno);
 100 }
 101
 102 static void
 103 S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
 104 {
 105     if (header->readonly
 106      && mprotect(header, header->size, PROT_READ))
 107         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
 108                          header, header->size, errno);
 109 }
 110 # define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
 111 # define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
 112 #else
 113 # define maybe_protect_rw(foo) NOOP
 114 # define maybe_protect_ro(foo) NOOP
 115 #endif
 116
 117 #if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
 118  /* Use memory_debug_header */
 119 # define USE_MDH
 120 # if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
 121    || defined(PERL_DEBUG_READONLY_COW)
 122 #  define MDH_HAS_SIZE
 123 # endif
 124 #endif
 125
 126 /* paranoid version of system's malloc() */
 127
 128 Malloc_t
 129 Perl_safesysmalloc(MEM_SIZE size)
 130 {
 131 #ifdef ALWAYS_NEED_THX
 132     dTHX;
 133 #endif
 134     Malloc_t ptr;
 135
 136 #ifdef USE_MDH
 137     if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
 138         goto out_of_memory;
 139     size += PERL_MEMORY_DEBUG_HEADER_SIZE;
 140 #endif
 141 #ifdef DEBUGGING
 142     if ((SSize_t)size < 0)
 143         Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
 144 #endif
 145     if (!size) size = 1;        /* malloc(0) is NASTY on our system */
 146 #ifdef PERL_DEBUG_READONLY_COW
 147     if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 148                     MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 149         perror("mmap failed");
 150         abort();
 151     }
 152 #else
 153     ptr = (Malloc_t)PerlMem_malloc(size?size:1);
 154 #endif
 155     PERL_ALLOC_CHECK(ptr);
 156     if (ptr != NULL) {
 157 #ifdef USE_MDH
 158         struct perl_memory_debug_header *const header
 159             = (struct perl_memory_debug_header *)ptr;
 160 #endif
 161
 162 #ifdef PERL_POISON
 163         PoisonNew(((char *)ptr), size, char);
 164 #endif
 165
 166 #ifdef PERL_TRACK_MEMPOOL
 167         header->interpreter = aTHX;
 168         /* Link us into the list.  */
 169         header->prev = &PL_memory_debug_header;
 170         header->next = PL_memory_debug_header.next;
 171         PL_memory_debug_header.next = header;
 172         maybe_protect_rw(header->next);
 173         header->next->prev = header;
 174         maybe_protect_ro(header->next);
 175 #  ifdef PERL_DEBUG_READONLY_COW
 176         header->readonly = 0;
 177 #  endif
 178 #endif
 179 #ifdef MDH_HAS_SIZE
 180         header->size = size;
 181 #endif
 182         ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
 183         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 184
 185     }
 186     else {
 187 #ifdef USE_MDH
 188       out_of_memory:
 189 #endif
 190         {
 191 #ifndef ALWAYS_NEED_THX
 192             dTHX;
 193 #endif
 194             if (PL_nomemok)
 195                 ptr =  NULL;
 196             else
 197                 croak_no_mem();
 198         }
 199     }
 200     return ptr;
 201 }
 202
 203 /* paranoid version of system's realloc() */
 204
 205 Malloc_t
 206 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 207 {
 208 #ifdef ALWAYS_NEED_THX
 209     dTHX;
 210 #endif
 211     Malloc_t ptr;
 212 #ifdef PERL_DEBUG_READONLY_COW
 213     const MEM_SIZE oldsize = where
 214         ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
 215         : 0;
 216 #endif
 217 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
 218     Malloc_t PerlMem_realloc();
 219 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
 220
 221     if (!size) {
 222         safesysfree(where);
 223         ptr = NULL;
 224     }
 225     else if (!where) {
 226         ptr = safesysmalloc(size);
 227     }
 228     else {
 229 #ifdef USE_MDH
 230         where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
 231         if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
 232             goto out_of_memory;
 233         size += PERL_MEMORY_DEBUG_HEADER_SIZE;
 234         {
 235             struct perl_memory_debug_header *const header
 236                 = (struct perl_memory_debug_header *)where;
 237
 238 # ifdef PERL_TRACK_MEMPOOL
 239             if (header->interpreter != aTHX) {
 240                 Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
 241                                      header->interpreter, aTHX);
 242             }
 243             assert(header->next->prev == header);
 244             assert(header->prev->next == header);
 245 #  ifdef PERL_POISON
 246             if (header->size > size) {
 247                 const MEM_SIZE freed_up = header->size - size;
 248                 char *start_of_freed = ((char *)where) + size;
 249                 PoisonFree(start_of_freed, freed_up, char);
 250             }
 251 #  endif
 252 # endif
 253 # ifdef MDH_HAS_SIZE
 254             header->size = size;
 255 # endif
 256         }
 257 #endif
 258 #ifdef DEBUGGING
 259         if ((SSize_t)size < 0)
 260             Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
 261 #endif
 262 #ifdef PERL_DEBUG_READONLY_COW
 263         if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
 264                         MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 265             perror("mmap failed");
 266             abort();
 267         }
 268         Copy(where,ptr,oldsize < size ? oldsize : size,char);
 269         if (munmap(where, oldsize)) {
 270             perror("munmap failed");
 271             abort();
 272         }
 273 #else
 274         ptr = (Malloc_t)PerlMem_realloc(where,size);
 275 #endif
 276         PERL_ALLOC_CHECK(ptr);
 277
 278     /* MUST do this fixup first, before doing ANYTHING else, as anything else
 279        might allocate memory/free/move memory, and until we do the fixup, it
 280        may well be chasing (and writing to) free memory.  */
 281         if (ptr != NULL) {
 282 #ifdef PERL_TRACK_MEMPOOL
 283             struct perl_memory_debug_header *const header
 284                 = (struct perl_memory_debug_header *)ptr;
 285
 286 #  ifdef PERL_POISON
 287             if (header->size < size) {
 288                 const MEM_SIZE fresh = size - header->size;
 289                 char *start_of_fresh = ((char *)ptr) + size;
 290                 PoisonNew(start_of_fresh, fresh, char);
 291             }
 292 #  endif
 293
 294             maybe_protect_rw(header->next);
 295             header->next->prev = header;
 296             maybe_protect_ro(header->next);
 297             maybe_protect_rw(header->prev);
 298             header->prev->next = header;
 299             maybe_protect_ro(header->prev);
 300 #endif
 301             ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
 302         }
 303
 304     /* In particular, must do that fixup above before logging anything via
 305      *printf(), as it can reallocate memory, which can cause SEGVs.  */
 306
 307         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
 308         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
 309
 310         if (ptr == NULL) {
 311 #ifdef USE_MDH
 312           out_of_memory:
 313 #endif
 314             {
 315 #ifndef ALWAYS_NEED_THX
 316                 dTHX;
 317 #endif
 318                 if (PL_nomemok)
 319                     ptr = NULL;
 320                 else
 321                     croak_no_mem();
 322             }
 323         }
 324     }
 325     return ptr;
 326 }
 327
 328 /* safe version of system's free() */
 329
 330 Free_t
 331 Perl_safesysfree(Malloc_t where)
 332 {
 333 #ifdef ALWAYS_NEED_THX
 334     dTHX;
 335 #endif
 336     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
 337     if (where) {
 338 #ifdef USE_MDH
 339         Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
 340         {
 341             struct perl_memory_debug_header *const header
 342                 = (struct perl_memory_debug_header *)where_intrn;
 343
 344 # ifdef MDH_HAS_SIZE
 345             const MEM_SIZE size = header->size;
 346 # endif
 347 # ifdef PERL_TRACK_MEMPOOL
 348             if (header->interpreter != aTHX) {
 349                 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
 350                                      header->interpreter, aTHX);
 351             }
 352             if (!header->prev) {
 353                 Perl_croak_nocontext("panic: duplicate free");
 354             }
 355             if (!(header->next))
 356                 Perl_croak_nocontext("panic: bad free, header->next==NULL");
 357             if (header->next->prev != header || header->prev->next != header) {
 358                 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
 359                                      "header=%p, ->prev->next=%p",
 360                                      header->next->prev, header,
 361                                      header->prev->next);
 362             }
 363             /* Unlink us from the chain.  */
 364             maybe_protect_rw(header->next);
 365             header->next->prev = header->prev;
 366             maybe_protect_ro(header->next);
 367             maybe_protect_rw(header->prev);
 368             header->prev->next = header->next;
 369             maybe_protect_ro(header->prev);
 370             maybe_protect_rw(header);
 371 #  ifdef PERL_POISON
 372             PoisonNew(where_intrn, size, char);
 373 #  endif
 374             /* Trigger the duplicate free warning.  */
 375             header->next = NULL;
 376 # endif
 377 # ifdef PERL_DEBUG_READONLY_COW
 378             if (munmap(where_intrn, size)) {
 379                 perror("munmap failed");
 380                 abort();
 381             }
 382 # endif
 383         }
 384 #else
 385         Malloc_t where_intrn = where;
 386 #endif /* USE_MDH */
 387 #ifndef PERL_DEBUG_READONLY_COW
 388         PerlMem_free(where_intrn);
 389 #endif
 390     }
 391 }
 392
 393 /* safe version of system's calloc() */
 394
 395 Malloc_t
 396 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 397 {
 398 #ifdef ALWAYS_NEED_THX
 399     dTHX;
 400 #endif
 401     Malloc_t ptr;
 402 #if defined(USE_MDH) || defined(DEBUGGING)
 403     MEM_SIZE total_size = 0;
 404 #endif
 405
 406     /* Even though calloc() for zero bytes is strange, be robust. */
 407     if (size && (count <= MEM_SIZE_MAX / size)) {
 408 #if defined(USE_MDH) || defined(DEBUGGING)
 409         total_size = size * count;
 410 #endif
 411     }
 412     else
 413         croak_memory_wrap();
 414 #ifdef USE_MDH
 415     if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
 416         total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
 417     else
 418         croak_memory_wrap();
 419 #endif
 420 #ifdef DEBUGGING
 421     if ((SSize_t)size < 0 || (SSize_t)count < 0)
 422         Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
 423                              (UV)size, (UV)count);
 424 #endif
 425 #ifdef PERL_DEBUG_READONLY_COW
 426     if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
 427                     MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
 428         perror("mmap failed");
 429         abort();
 430     }
 431 #elif defined(PERL_TRACK_MEMPOOL)
 432     /* Have to use malloc() because we've added some space for our tracking
 433        header.  */
 434     /* malloc(0) is non-portable. */
 435     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
 436 #else
 437     /* Use calloc() because it might save a memset() if the memory is fresh
 438        and clean from the OS.  */
 439     if (count && size)
 440         ptr = (Malloc_t)PerlMem_calloc(count, size);
 441     else /* calloc(0) is non-portable. */
 442         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
 443 #endif
 444     PERL_ALLOC_CHECK(ptr);
 445     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
 446     if (ptr != NULL) {
 447 #ifdef USE_MDH
 448         {
 449             struct perl_memory_debug_header *const header
 450                 = (struct perl_memory_debug_header *)ptr;
 451
 452 #  ifndef PERL_DEBUG_READONLY_COW
 453             memset((void*)ptr, 0, total_size);
 454 #  endif
 455 #  ifdef PERL_TRACK_MEMPOOL
 456             header->interpreter = aTHX;
 457             /* Link us into the list.  */
 458             header->prev = &PL_memory_debug_header;
 459             header->next = PL_memory_debug_header.next;
 460             PL_memory_debug_header.next = header;
 461             maybe_protect_rw(header->next);
 462             header->next->prev = header;
 463             maybe_protect_ro(header->next);
 464 #    ifdef PERL_DEBUG_READONLY_COW
 465             header->readonly = 0;
 466 #    endif
 467 #  endif
 468 #  ifdef MDH_HAS_SIZE
 469             header->size = total_size;
 470 #  endif
 471             ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
 472         }
 473 #endif
 474         return ptr;
 475     }
 476     else {
 477 #ifndef ALWAYS_NEED_THX
 478         dTHX;
 479 #endif
 480         if (PL_nomemok)
 481             return NULL;
 482         croak_no_mem();
 483     }
 484 }
 485
 486 /* These must be defined when not using Perl's malloc for binary
 487  * compatibility */
 488
 489 #ifndef MYMALLOC
 490
 491 Malloc_t Perl_malloc (MEM_SIZE nbytes)
 492 {
 493 #ifdef PERL_IMPLICIT_SYS
 494     dTHX;
 495 #endif
 496     return (Malloc_t)PerlMem_malloc(nbytes);
 497 }
 498
 499 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
 500 {
 501 #ifdef PERL_IMPLICIT_SYS
 502     dTHX;
 503 #endif
 504     return (Malloc_t)PerlMem_calloc(elements, size);
 505 }
 506
 507 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
 508 {
 509 #ifdef PERL_IMPLICIT_SYS
 510     dTHX;
 511 #endif
 512     return (Malloc_t)PerlMem_realloc(where, nbytes);
 513 }
 514
 515 Free_t   Perl_mfree (Malloc_t where)
 516 {
 517 #ifdef PERL_IMPLICIT_SYS
 518     dTHX;
 519 #endif
 520     PerlMem_free(where);
 521 }
 522
 523 #endif
 524
 525 /* copy a string up to some (non-backslashed) delimiter, if any.
 526  * With allow_escape, converts \<delimiter> to <delimiter>, while leaves
 527  * \<non-delimiter> as-is.
 528  * Returns the position in the src string of the closing delimiter, if
 529  * any, or returns fromend otherwise.
 530  * This is the internal implementation for Perl_delimcpy and
 531  * Perl_delimcpy_no_escape.
 532  */
 533
 534 static char *
 535 S_delimcpy_intern(char *to, const char *toend, const char *from,
 536            const char *fromend, int delim, I32 *retlen,
 537            const bool allow_escape)
 538 {
 539     I32 tolen;
 540
 541     PERL_ARGS_ASSERT_DELIMCPY;
 542
 543     for (tolen = 0; from < fromend; from++, tolen++) {
 544         if (allow_escape && *from == '\\' && from + 1 < fromend) {
 545             if (from[1] != delim) {
 546                 if (to < toend)
 547                     *to++ = *from;
 548                 tolen++;
 549             }
 550             from++;
 551         }
 552         else if (*from == delim)
 553             break;
 554         if (to < toend)
 555             *to++ = *from;
 556     }
 557     if (to < toend)
 558         *to = '\0';
 559     *retlen = tolen;
 560     return (char *)from;
 561 }
 562
 563 char *
 564 Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
 565 {
 566     PERL_ARGS_ASSERT_DELIMCPY;
 567
 568     return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
 569 }
 570
 571 char *
 572 Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
 573                         const char *fromend, int delim, I32 *retlen)
 574 {
 575     PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
 576
 577     return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
 578 }
 579
 580 /*
 581 =head1 Miscellaneous Functions
 582
 583 =for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
 584
 585 Find the first (leftmost) occurrence of a sequence of bytes within another
 586 sequence.  This is the Perl version of C<strstr()>, extended to handle
 587 arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
 588 is what the initial C<n> in the function name stands for; some systems have an
 589 equivalent, C<memmem()>, but with a somewhat different API).
 590
 591 Another way of thinking about this function is finding a needle in a haystack.
 592 C<big> points to the first byte in the haystack.  C<big_end> points to one byte
 593 beyond the final byte in the haystack.  C<little> points to the first byte in
 594 the needle.  C<little_end> points to one byte beyond the final byte in the
 595 needle.  All the parameters must be non-C<NULL>.
 596
 597 The function returns C<NULL> if there is no occurrence of C<little> within
 598 C<big>.  If C<little> is the empty string, C<big> is returned.
 599
 600 Because this function operates at the byte level, and because of the inherent
 601 characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
 602 needle and the haystack are strings with the same UTF-8ness, but not if the
 603 UTF-8ness differs.
 604
 605 =cut
 606
 607 */
 608
 609 char *
 610 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
 611 {
 612     PERL_ARGS_ASSERT_NINSTR;
 613
 614 #ifdef HAS_MEMMEM
 615     return ninstr(big, bigend, little, lend);
 616 #else
 617
 618     if (little >= lend)
 619         return (char*)big;
 620     {
 621         const char first = *little;
 622         bigend -= lend - little++;
 623     OUTER:
 624         while (big <= bigend) {
 625             if (*big++ == first) {
 626                 const char *s, *x;
 627                 for (x=big,s=little; s < lend; x++,s++) {
 628                     if (*s != *x)
 629                         goto OUTER;
 630                 }
 631                 return (char*)(big-1);
 632             }
 633         }
 634     }
 635     return NULL;
 636
 637 #endif
 638
 639 }
 640
 641 /*
 642 =head1 Miscellaneous Functions
 643
 644 =for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
 645
 646 Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
 647 sequence of bytes within another sequence, returning C<NULL> if there is no
 648 such occurrence.
 649
 650 =cut
 651
 652 */
 653
 654 char *
 655 Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
 656 {
 657     const char *bigbeg;
 658     const I32 first = *little;
 659     const char * const littleend = lend;
 660
 661     PERL_ARGS_ASSERT_RNINSTR;
 662
 663     if (little >= littleend)
 664         return (char*)bigend;
 665     bigbeg = big;
 666     big = bigend - (littleend - little++);
 667     while (big >= bigbeg) {
 668         const char *s, *x;
 669         if (*big-- != first)
 670             continue;
 671         for (x=big+2,s=little; s < littleend; /**/ ) {
 672             if (*s != *x)
 673                 break;
 674             else {
 675                 x++;
 676                 s++;
 677             }
 678         }
 679         if (s >= littleend)
 680             return (char*)(big+1);
 681     }
 682     return NULL;
 683 }
 684
 685 /* As a space optimization, we do not compile tables for strings of length
 686    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
 687    special-cased in fbm_instr().
 688
 689    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
 690
 691 /*
 692 =head1 Miscellaneous Functions
 693
 694 =for apidoc fbm_compile
 695
 696 Analyses the string in order to make fast searches on it using C<fbm_instr()>
 697 -- the Boyer-Moore algorithm.
 698
 699 =cut
 700 */
 701
 702 void
 703 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 704 {
 705     const U8 *s;
 706     STRLEN i;
 707     STRLEN len;
 708     U32 frequency = 256;
 709     MAGIC *mg;
 710     PERL_DEB( STRLEN rarest = 0 );
 711
 712     PERL_ARGS_ASSERT_FBM_COMPILE;
 713
 714     if (isGV_with_GP(sv) || SvROK(sv))
 715         return;
 716
 717     if (SvVALID(sv))
 718         return;
 719
 720     if (flags & FBMcf_TAIL) {
 721         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 722         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
 723         if (mg && mg->mg_len >= 0)
 724             mg->mg_len++;
 725     }
 726     if (!SvPOK(sv) || SvNIOKp(sv))
 727         s = (U8*)SvPV_force_mutable(sv, len);
 728     else s = (U8 *)SvPV_mutable(sv, len);
 729     if (len == 0)               /* TAIL might be on a zero-length string. */
 730         return;
 731     SvUPGRADE(sv, SVt_PVMG);
 732     SvIOK_off(sv);
 733     SvNOK_off(sv);
 734
 735     /* add PERL_MAGIC_bm magic holding the FBM lookup table */
 736
 737     assert(!mg_find(sv, PERL_MAGIC_bm));
 738     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
 739     assert(mg);
 740
 741     if (len > 2) {
 742         /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
 743            the BM table.  */
 744         const U8 mlen = (len>255) ? 255 : (U8)len;
 745         const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
 746         U8 *table;
 747
 748         Newx(table, 256, U8);
 749         memset((void*)table, mlen, 256);
 750         mg->mg_ptr = (char *)table;
 751         mg->mg_len = 256;
 752
 753         s += len - 1; /* last char */
 754         i = 0;
 755         while (s >= sb) {
 756             if (table[*s] == mlen)
 757                 table[*s] = (U8)i;
 758             s--, i++;
 759         }
 760     }
 761
 762     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
 763     for (i = 0; i < len; i++) {
 764         if (PL_freq[s[i]] < frequency) {
 765             PERL_DEB( rarest = i );
 766             frequency = PL_freq[s[i]];
 767         }
 768     }
 769     BmUSEFUL(sv) = 100;                 /* Initial value */
 770     ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
 771     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n",
 772                           s[rarest], (UV)rarest));
 773 }
 774
 775
 776 /*
 777 =for apidoc fbm_instr
 778
 779 Returns the location of the SV in the string delimited by C<big> and
 780 C<bigend> (C<bigend>) is the char following the last char).
 781 It returns C<NULL> if the string can't be found.  The C<sv>
 782 does not have to be C<fbm_compiled>, but the search will not be as fast
 783 then.
 784
 785 =cut
 786
 787 If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
 788 during FBM compilation due to FBMcf_TAIL in flags. It indicates that
 789 the littlestr must be anchored to the end of bigstr (or to any \n if
 790 FBMrf_MULTILINE).
 791
 792 E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
 793 while /abc$/ compiles to "abc\n" with SvTAIL() true.
 794
 795 A littlestr of "abc", !SvTAIL matches as /abc/;
 796 a littlestr of "ab\n", SvTAIL matches as:
 797    without FBMrf_MULTILINE: /ab\n?\z/
 798    with    FBMrf_MULTILINE: /ab\n/ || /ab\z/;
 799
 800 (According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
 801   "If SvTAIL is actually due to \Z or \z, this gives false positives
 802   if multiline".
 803 */
 804
 805
 806 char *
 807 Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
 808 {
 809     unsigned char *s;
 810     STRLEN l;
 811     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
 812     STRLEN littlelen = l;
 813     const I32 multiline = flags & FBMrf_MULTILINE;
 814     bool valid = SvVALID(littlestr);
 815     bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
 816
 817     PERL_ARGS_ASSERT_FBM_INSTR;
 818
 819     if ((STRLEN)(bigend - big) < littlelen) {
 820         if (     tail
 821              && ((STRLEN)(bigend - big) == littlelen - 1)
 822              && (littlelen == 1
 823                  || (*big == *little &&
 824                      memEQ((char *)big, (char *)little, littlelen - 1))))
 825             return (char*)big;
 826         return NULL;
 827     }
 828
 829     switch (littlelen) { /* Special cases for 0, 1 and 2  */
 830     case 0:
 831         return (char*)big;              /* Cannot be SvTAIL! */
 832
 833     case 1:
 834             if (tail && !multiline) /* Anchor only! */
 835                 /* [-1] is safe because we know that bigend != big.  */
 836                 return (char *) (bigend - (bigend[-1] == '\n'));
 837
 838             s = (unsigned char *)memchr((void*)big, *little, bigend-big);
 839             if (s)
 840                 return (char *)s;
 841             if (tail)
 842                 return (char *) bigend;
 843             return NULL;
 844
 845     case 2:
 846         if (tail && !multiline) {
 847             /* a littlestr with SvTAIL must be of the form "X\n" (where X
 848              * is a single char). It is anchored, and can only match
 849              * "....X\n"  or  "....X" */
 850             if (bigend[-2] == *little && bigend[-1] == '\n')
 851                 return (char*)bigend - 2;
 852             if (bigend[-1] == *little)
 853                 return (char*)bigend - 1;
 854             return NULL;
 855         }
 856
 857         {
 858             /* memchr() is likely to be very fast, possibly using whatever
 859              * hardware support is available, such as checking a whole
 860              * cache line in one instruction.
 861              * So for a 2 char pattern, calling memchr() is likely to be
 862              * faster than running FBM, or rolling our own. The previous
 863              * version of this code was roll-your-own which typically
 864              * only needed to read every 2nd char, which was good back in
 865              * the day, but no longer.
 866              */
 867             unsigned char c1 = little[0];
 868             unsigned char c2 = little[1];
 869
 870             /* *** for all this case, bigend points to the last char,
 871              * not the trailing \0: this makes the conditions slightly
 872              * simpler */
 873             bigend--;
 874             s = big;
 875             if (c1 != c2) {
 876                 while (s < bigend) {
 877                     /* do a quick test for c1 before calling memchr();
 878                      * this avoids the expensive fn call overhead when
 879                      * there are lots of c1's */
 880                     if (LIKELY(*s != c1)) {
 881                         s++;
 882                         s = (unsigned char *)memchr((void*)s, c1, bigend - s);
 883                         if (!s)
 884                             break;
 885                     }
 886                     if (s[1] == c2)
 887                         return (char*)s;
 888
 889                     /* failed; try searching for c2 this time; that way
 890                      * we don't go pathologically slow when the string
 891                      * consists mostly of c1's or vice versa.
 892                      */
 893                     s += 2;
 894                     if (s > bigend)
 895                         break;
 896                     s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
 897                     if (!s)
 898                         break;
 899                     if (s[-1] == c1)
 900                         return (char*)s - 1;
 901                 }
 902             }
 903             else {
 904                 /* c1, c2 the same */
 905                 while (s < bigend) {
 906                     if (s[0] == c1) {
 907                       got_1char:
 908                         if (s[1] == c1)
 909                             return (char*)s;
 910                         s += 2;
 911                     }
 912                     else {
 913                         s++;
 914                         s = (unsigned char *)memchr((void*)s, c1, bigend - s);
 915                         if (!s || s >= bigend)
 916                             break;
 917                         goto got_1char;
 918                     }
 919                 }
 920             }
 921
 922             /* failed to find 2 chars; try anchored match at end without
 923              * the \n */
 924             if (tail && bigend[0] == little[0])
 925                 return (char *)bigend;
 926             return NULL;
 927         }
 928
 929     default:
 930         break; /* Only lengths 0 1 and 2 have special-case code.  */
 931     }
 932
 933     if (tail && !multiline) {   /* tail anchored? */
 934         s = bigend - littlelen;
 935         if (s >= big && bigend[-1] == '\n' && *s == *little
 936             /* Automatically of length > 2 */
 937             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
 938         {
 939             return (char*)s;            /* how sweet it is */
 940         }
 941         if (s[1] == *little
 942             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
 943         {
 944             return (char*)s + 1;        /* how sweet it is */
 945         }
 946         return NULL;
 947     }
 948
 949     if (!valid) {
 950         /* not compiled; use Perl_ninstr() instead */
 951         char * const b = ninstr((char*)big,(char*)bigend,
 952                          (char*)little, (char*)little + littlelen);
 953
 954         assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
 955         return b;
 956     }
 957
 958     /* Do actual FBM.  */
 959     if (littlelen > (STRLEN)(bigend - big))
 960         return NULL;
 961
 962     {
 963         const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
 964         const unsigned char *oldlittle;
 965
 966         assert(mg);
 967
 968         --littlelen;                    /* Last char found by table lookup */
 969
 970         s = big + littlelen;
 971         little += littlelen;            /* last char */
 972         oldlittle = little;
 973         if (s < bigend) {
 974             const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
 975             const unsigned char lastc = *little;
 976             I32 tmp;
 977
 978           top2:
 979             if ((tmp = table[*s])) {
 980                 /* *s != lastc; earliest position it could match now is
 981                  * tmp slots further on */
 982                 if ((s += tmp) >= bigend)
 983                     goto check_end;
 984                 if (LIKELY(*s != lastc)) {
 985                     s++;
 986                     s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
 987                     if (!s) {
 988                         s = bigend;
 989                         goto check_end;
 990                     }
 991                     goto top2;
 992                 }
 993             }
 994
 995
 996             /* hand-rolled strncmp(): less expensive than calling the
 997              * real function (maybe???) */
 998             {
 999                 unsigned char * const olds = s;
1000
1001                 tmp = littlelen;
1002
1003                 while (tmp--) {
1004                     if (*--s == *--little)
1005                         continue;
1006                     s = olds + 1;       /* here we pay the price for failure */
1007                     little = oldlittle;
1008                     if (s < bigend)     /* fake up continue to outer loop */
1009                         goto top2;
1010                     goto check_end;
1011                 }
1012                 return (char *)s;
1013             }
1014         }
1015       check_end:
1016         if ( s == bigend
1017              && tail
1018              && memEQ((char *)(bigend - littlelen),
1019                       (char *)(oldlittle - littlelen), littlelen) )
1020             return (char*)bigend - littlelen;
1021         return NULL;
1022     }
1023 }
1024
1025
1026 /*
1027 =for apidoc foldEQ
1028
1029 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1030 same
1031 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
1032 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
1033 range bytes match only themselves.
1034
1035 =cut
1036 */
1037
1038
1039 I32
1040 Perl_foldEQ(const char *s1, const char *s2, I32 len)
1041 {
1042     const U8 *a = (const U8 *)s1;
1043     const U8 *b = (const U8 *)s2;
1044
1045     PERL_ARGS_ASSERT_FOLDEQ;
1046
1047     assert(len >= 0);
1048
1049     while (len--) {
1050         if (*a != *b && *a != PL_fold[*b])
1051             return 0;
1052         a++,b++;
1053     }
1054     return 1;
1055 }
1056 I32
1057 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
1058 {
1059     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
1060      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
1061      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
1062      * does it check that the strings each have at least 'len' characters */
1063
1064     const U8 *a = (const U8 *)s1;
1065     const U8 *b = (const U8 *)s2;
1066
1067     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
1068
1069     assert(len >= 0);
1070
1071     while (len--) {
1072         if (*a != *b && *a != PL_fold_latin1[*b]) {
1073             return 0;
1074         }
1075         a++, b++;
1076     }
1077     return 1;
1078 }
1079
1080 /*
1081 =for apidoc foldEQ_locale
1082
1083 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
1084 same case-insensitively in the current locale; false otherwise.
1085
1086 =cut
1087 */
1088
1089 I32
1090 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
1091 {
1092     dVAR;
1093     const U8 *a = (const U8 *)s1;
1094     const U8 *b = (const U8 *)s2;
1095
1096     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
1097
1098     assert(len >= 0);
1099
1100     while (len--) {
1101         if (*a != *b && *a != PL_fold_locale[*b])
1102             return 0;
1103         a++,b++;
1104     }
1105     return 1;
1106 }
1107
1108 /* copy a string to a safe spot */
1109
1110 /*
1111 =head1 Memory Management
1112
1113 =for apidoc savepv
1114
1115 Perl's version of C<strdup()>.  Returns a pointer to a newly allocated
1116 string which is a duplicate of C<pv>.  The size of the string is
1117 determined by C<strlen()>, which means it may not contain embedded C<NUL>
1118 characters and must have a trailing C<NUL>.  The memory allocated for the new
1119 string can be freed with the C<Safefree()> function.
1120
1121 On some platforms, Windows for example, all allocated memory owned by a thread
1122 is deallocated when that thread ends.  So if you need that not to happen, you
1123 need to use the shared memory functions, such as C<L</savesharedpv>>.
1124
1125 =cut
1126 */
1127
1128 char *
1129 Perl_savepv(pTHX_ const char *pv)
1130 {
1131     PERL_UNUSED_CONTEXT;
1132     if (!pv)
1133         return NULL;
1134     else {
1135         char *newaddr;
1136         const STRLEN pvlen = strlen(pv)+1;
1137         Newx(newaddr, pvlen, char);
1138         return (char*)memcpy(newaddr, pv, pvlen);
1139     }
1140 }
1141
1142 /* same thing but with a known length */
1143
1144 /*
1145 =for apidoc savepvn
1146
1147 Perl's version of what C<strndup()> would be if it existed.  Returns a
1148 pointer to a newly allocated string which is a duplicate of the first
1149 C<len> bytes from C<pv>, plus a trailing
1150 C<NUL> byte.  The memory allocated for
1151 the new string can be freed with the C<Safefree()> function.
1152
1153 On some platforms, Windows for example, all allocated memory owned by a thread
1154 is deallocated when that thread ends.  So if you need that not to happen, you
1155 need to use the shared memory functions, such as C<L</savesharedpvn>>.
1156
1157 =cut
1158 */
1159
1160 char *
1161 Perl_savepvn(pTHX_ const char *pv, I32 len)
1162 {
1163     char *newaddr;
1164     PERL_UNUSED_CONTEXT;
1165
1166     assert(len >= 0);
1167
1168     Newx(newaddr,len+1,char);
1169     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
1170     if (pv) {
1171         /* might not be null terminated */
1172         newaddr[len] = '\0';
1173         return (char *) CopyD(pv,newaddr,len,char);
1174     }
1175     else {
1176         return (char *) ZeroD(newaddr,len+1,char);
1177     }
1178 }
1179
1180 /*
1181 =for apidoc savesharedpv
1182
1183 A version of C<savepv()> which allocates the duplicate string in memory
1184 which is shared between threads.
1185
1186 =cut
1187 */
1188 char *
1189 Perl_savesharedpv(pTHX_ const char *pv)
1190 {
1191     char *newaddr;
1192     STRLEN pvlen;
1193
1194     PERL_UNUSED_CONTEXT;
1195
1196     if (!pv)
1197         return NULL;
1198
1199     pvlen = strlen(pv)+1;
1200     newaddr = (char*)PerlMemShared_malloc(pvlen);
1201     if (!newaddr) {
1202         croak_no_mem();
1203     }
1204     return (char*)memcpy(newaddr, pv, pvlen);
1205 }
1206
1207 /*
1208 =for apidoc savesharedpvn
1209
1210 A version of C<savepvn()> which allocates the duplicate string in memory
1211 which is shared between threads.  (With the specific difference that a C<NULL>
1212 pointer is not acceptable)
1213
1214 =cut
1215 */
1216 char *
1217 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1218 {
1219     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1220
1221     PERL_UNUSED_CONTEXT;
1222     /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1223
1224     if (!newaddr) {
1225         croak_no_mem();
1226     }
1227     newaddr[len] = '\0';
1228     return (char*)memcpy(newaddr, pv, len);
1229 }
1230
1231 /*
1232 =for apidoc savesvpv
1233
1234 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1235 the passed in SV using C<SvPV()>
1236
1237 On some platforms, Windows for example, all allocated memory owned by a thread
1238 is deallocated when that thread ends.  So if you need that not to happen, you
1239 need to use the shared memory functions, such as C<L</savesharedsvpv>>.
1240
1241 =cut
1242 */
1243
1244 char *
1245 Perl_savesvpv(pTHX_ SV *sv)
1246 {
1247     STRLEN len;
1248     const char * const pv = SvPV_const(sv, len);
1249     char *newaddr;
1250
1251     PERL_ARGS_ASSERT_SAVESVPV;
1252
1253     ++len;
1254     Newx(newaddr,len,char);
1255     return (char *) CopyD(pv,newaddr,len,char);
1256 }
1257
1258 /*
1259 =for apidoc savesharedsvpv
1260
1261 A version of C<savesharedpv()> which allocates the duplicate string in
1262 memory which is shared between threads.
1263
1264 =cut
1265 */
1266
1267 char *
1268 Perl_savesharedsvpv(pTHX_ SV *sv)
1269 {
1270     STRLEN len;
1271     const char * const pv = SvPV_const(sv, len);
1272
1273     PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1274
1275     return savesharedpvn(pv, len);
1276 }
1277
1278 /* the SV for Perl_form() and mess() is not kept in an arena */
1279
1280 STATIC SV *
1281 S_mess_alloc(pTHX)
1282 {
1283     SV *sv;
1284     XPVMG *any;
1285
1286     if (PL_phase != PERL_PHASE_DESTRUCT)
1287         return newSVpvs_flags("", SVs_TEMP);
1288
1289     if (PL_mess_sv)
1290         return PL_mess_sv;
1291
1292     /* Create as PVMG now, to avoid any upgrading later */
1293     Newx(sv, 1, SV);
1294     Newxz(any, 1, XPVMG);
1295     SvFLAGS(sv) = SVt_PVMG;
1296     SvANY(sv) = (void*)any;
1297     SvPV_set(sv, NULL);
1298     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1299     PL_mess_sv = sv;
1300     return sv;
1301 }
1302
1303 #if defined(PERL_IMPLICIT_CONTEXT)
1304 char *
1305 Perl_form_nocontext(const char* pat, ...)
1306 {
1307     dTHX;
1308     char *retval;
1309     va_list args;
1310     PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1311     va_start(args, pat);
1312     retval = vform(pat, &args);
1313     va_end(args);
1314     return retval;
1315 }
1316 #endif /* PERL_IMPLICIT_CONTEXT */
1317
1318 /*
1319 =head1 Miscellaneous Functions
1320 =for apidoc form
1321
1322 Takes a sprintf-style format pattern and conventional
1323 (non-SV) arguments and returns the formatted string.
1324
1325     (char *) Perl_form(pTHX_ const char* pat, ...)
1326
1327 can be used any place a string (char *) is required:
1328
1329     char * s = Perl_form("%d.%d",major,minor);
1330
1331 Uses a single private buffer so if you want to format several strings you
1332 must explicitly copy the earlier strings away (and free the copies when you
1333 are done).
1334
1335 =cut
1336 */
1337
1338 char *
1339 Perl_form(pTHX_ const char* pat, ...)
1340 {
1341     char *retval;
1342     va_list args;
1343     PERL_ARGS_ASSERT_FORM;
1344     va_start(args, pat);
1345     retval = vform(pat, &args);
1346     va_end(args);
1347     return retval;
1348 }
1349
1350 char *
1351 Perl_vform(pTHX_ const char *pat, va_list *args)
1352 {
1353     SV * const sv = mess_alloc();
1354     PERL_ARGS_ASSERT_VFORM;
1355     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1356     return SvPVX(sv);
1357 }
1358
1359 /*
1360 =for apidoc Am|SV *|mess|const char *pat|...
1361
1362 Take a sprintf-style format pattern and argument list.  These are used to
1363 generate a string message.  If the message does not end with a newline,
1364 then it will be extended with some indication of the current location
1365 in the code, as described for L</mess_sv>.
1366
1367 Normally, the resulting message is returned in a new mortal SV.
1368 During global destruction a single SV may be shared between uses of
1369 this function.
1370
1371 =cut
1372 */
1373
1374 #if defined(PERL_IMPLICIT_CONTEXT)
1375 SV *
1376 Perl_mess_nocontext(const char *pat, ...)
1377 {
1378     dTHX;
1379     SV *retval;
1380     va_list args;
1381     PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1382     va_start(args, pat);
1383     retval = vmess(pat, &args);
1384     va_end(args);
1385     return retval;
1386 }
1387 #endif /* PERL_IMPLICIT_CONTEXT */
1388
1389 SV *
1390 Perl_mess(pTHX_ const char *pat, ...)
1391 {
1392     SV *retval;
1393     va_list args;
1394     PERL_ARGS_ASSERT_MESS;
1395     va_start(args, pat);
1396     retval = vmess(pat, &args);
1397     va_end(args);
1398     return retval;
1399 }
1400
1401 const COP*
1402 Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
1403                        bool opnext)
1404 {
1405     /* Look for curop starting from o.  cop is the last COP we've seen. */
1406     /* opnext means that curop is actually the ->op_next of the op we are
1407        seeking. */
1408
1409     PERL_ARGS_ASSERT_CLOSEST_COP;
1410
1411     if (!o || !curop || (
1412         opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
1413     ))
1414         return cop;
1415
1416     if (o->op_flags & OPf_KIDS) {
1417         const OP *kid;
1418         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
1419             const COP *new_cop;
1420
1421             /* If the OP_NEXTSTATE has been optimised away we can still use it
1422              * the get the file and line number. */
1423
1424             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1425                 cop = (const COP *)kid;
1426
1427             /* Keep searching, and return when we've found something. */
1428
1429             new_cop = closest_cop(cop, kid, curop, opnext);
1430             if (new_cop)
1431                 return new_cop;
1432         }
1433     }
1434
1435     /* Nothing found. */
1436
1437     return NULL;
1438 }
1439
1440 /*
1441 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1442
1443 Expands a message, intended for the user, to include an indication of
1444 the current location in the code, if the message does not already appear
1445 to be complete.
1446
1447 C<basemsg> is the initial message or object.  If it is a reference, it
1448 will be used as-is and will be the result of this function.  Otherwise it
1449 is used as a string, and if it already ends with a newline, it is taken
1450 to be complete, and the result of this function will be the same string.
1451 If the message does not end with a newline, then a segment such as C<at
1452 foo.pl line 37> will be appended, and possibly other clauses indicating
1453 the current state of execution.  The resulting message will end with a
1454 dot and a newline.
1455
1456 Normally, the resulting message is returned in a new mortal SV.
1457 During global destruction a single SV may be shared between uses of this
1458 function.  If C<consume> is true, then the function is permitted (but not
1459 required) to modify and return C<basemsg> instead of allocating a new SV.
1460
1461 =cut
1462 */
1463
1464 SV *
1465 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1466 {
1467     SV *sv;
1468
1469 #if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
1470     {
1471         char *ws;
1472         UV wi;
1473         /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
1474         if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
1475             && grok_atoUV(ws, &wi, NULL)
1476             && wi <= PERL_INT_MAX
1477         ) {
1478             Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
1479         }
1480     }
1481 #endif
1482
1483     PERL_ARGS_ASSERT_MESS_SV;
1484
1485     if (SvROK(basemsg)) {
1486         if (consume) {
1487             sv = basemsg;
1488         }
1489         else {
1490             sv = mess_alloc();
1491             sv_setsv(sv, basemsg);
1492         }
1493         return sv;
1494     }
1495
1496     if (SvPOK(basemsg) && consume) {
1497         sv = basemsg;
1498     }
1499     else {
1500         sv = mess_alloc();
1501         sv_copypv(sv, basemsg);
1502     }
1503
1504     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1505         /*
1506          * Try and find the file and line for PL_op.  This will usually be
1507          * PL_curcop, but it might be a cop that has been optimised away.  We
1508          * can try to find such a cop by searching through the optree starting
1509          * from the sibling of PL_curcop.
1510          */
1511
1512         if (PL_curcop) {
1513             const COP *cop =
1514                 closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
1515             if (!cop)
1516                 cop = PL_curcop;
1517
1518             if (CopLINE(cop))
1519                 Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
1520                                 OutCopFILE(cop), (IV)CopLINE(cop));
1521         }
1522
1523         /* Seems that GvIO() can be untrustworthy during global destruction. */
1524         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1525                 && IoLINES(GvIOp(PL_last_in_gv)))
1526         {
1527             STRLEN l;
1528             const bool line_mode = (RsSIMPLE(PL_rs) &&
1529                                    *SvPV_const(PL_rs,l) == '\n' && l == 1);
1530             Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
1531                            SVfARG(PL_last_in_gv == PL_argvgv
1532                                  ? &PL_sv_no
1533                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1534                            line_mode ? "line" : "chunk",
1535                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1536         }
1537         if (PL_phase == PERL_PHASE_DESTRUCT)
1538             sv_catpvs(sv, " during global destruction");
1539         sv_catpvs(sv, ".\n");
1540     }
1541     return sv;
1542 }
1543
1544 /*
1545 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1546
1547 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1548 argument list, respectively.  These are used to generate a string message.  If
1549 the
1550 message does not end with a newline, then it will be extended with
1551 some indication of the current location in the code, as described for
1552 L</mess_sv>.
1553
1554 Normally, the resulting message is returned in a new mortal SV.
1555 During global destruction a single SV may be shared between uses of
1556 this function.
1557
1558 =cut
1559 */
1560
1561 SV *
1562 Perl_vmess(pTHX_ const char *pat, va_list *args)
1563 {
1564     SV * const sv = mess_alloc();
1565
1566     PERL_ARGS_ASSERT_VMESS;
1567
1568     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1569     return mess_sv(sv, 1);
1570 }
1571
1572 void
1573 Perl_write_to_stderr(pTHX_ SV* msv)
1574 {
1575     IO *io;
1576     MAGIC *mg;
1577
1578     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1579
1580     if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1581         && (io = GvIO(PL_stderrgv))
1582         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
1583         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
1584                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1585     else {
1586         PerlIO * const serr = Perl_error_log;
1587
1588         do_print(msv, serr);
1589         (void)PerlIO_flush(serr);
1590     }
1591 }
1592
1593 /*
1594 =head1 Warning and Dieing
1595 */
1596
1597 /* Common code used in dieing and warning */
1598
1599 STATIC SV *
1600 S_with_queued_errors(pTHX_ SV *ex)
1601 {
1602     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1603     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1604         sv_catsv(PL_errors, ex);
1605         ex = sv_mortalcopy(PL_errors);
1606         SvCUR_set(PL_errors, 0);
1607     }
1608     return ex;
1609 }
1610
1611 STATIC bool
1612 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1613 {
1614     HV *stash;
1615     GV *gv;
1616     CV *cv;
1617     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1618     /* sv_2cv might call Perl_croak() or Perl_warner() */
1619     SV * const oldhook = *hook;
1620
1621     if (!oldhook)
1622         return FALSE;
1623
1624     ENTER;
1625     SAVESPTR(*hook);
1626     *hook = NULL;
1627     cv = sv_2cv(oldhook, &stash, &gv, 0);
1628     LEAVE;
1629     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1630         dSP;
1631         SV *exarg;
1632
1633         ENTER;
1634         save_re_context();
1635         if (warn) {
1636             SAVESPTR(*hook);
1637             *hook = NULL;
1638         }
1639         exarg = newSVsv(ex);
1640         SvREADONLY_on(exarg);
1641         SAVEFREESV(exarg);
1642
1643         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1644         PUSHMARK(SP);
1645         XPUSHs(exarg);
1646         PUTBACK;
1647         call_sv(MUTABLE_SV(cv), G_DISCARD);
1648         POPSTACK;
1649         LEAVE;
1650         return TRUE;
1651     }
1652     return FALSE;
1653 }
1654
1655 /*
1656 =for apidoc Am|OP *|die_sv|SV *baseex
1657
1658 Behaves the same as L</croak_sv>, except for the return type.
1659 It should be used only where the C<OP *> return type is required.
1660 The function never actually returns.
1661
1662 =cut
1663 */
1664
1665 #ifdef _MSC_VER
1666 #  pragma warning( push )
1667 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1668     __declspec(noreturn) has non-void return type */
1669 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1670 __declspec(noreturn) has a return statement */
1671 #endif
1672 OP *
1673 Perl_die_sv(pTHX_ SV *baseex)
1674 {
1675     PERL_ARGS_ASSERT_DIE_SV;
1676     croak_sv(baseex);
1677     /* NOTREACHED */
1678     NORETURN_FUNCTION_END;
1679 }
1680 #ifdef _MSC_VER
1681 #  pragma warning( pop )
1682 #endif
1683
1684 /*
1685 =for apidoc Am|OP *|die|const char *pat|...
1686
1687 Behaves the same as L</croak>, except for the return type.
1688 It should be used only where the C<OP *> return type is required.
1689 The function never actually returns.
1690
1691 =cut
1692 */
1693
1694 #if defined(PERL_IMPLICIT_CONTEXT)
1695 #ifdef _MSC_VER
1696 #  pragma warning( push )
1697 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1698     __declspec(noreturn) has non-void return type */
1699 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1700 __declspec(noreturn) has a return statement */
1701 #endif
1702 OP *
1703 Perl_die_nocontext(const char* pat, ...)
1704 {
1705     dTHX;
1706     va_list args;
1707     va_start(args, pat);
1708     vcroak(pat, &args);
1709     NOT_REACHED; /* NOTREACHED */
1710     va_end(args);
1711     NORETURN_FUNCTION_END;
1712 }
1713 #ifdef _MSC_VER
1714 #  pragma warning( pop )
1715 #endif
1716 #endif /* PERL_IMPLICIT_CONTEXT */
1717
1718 #ifdef _MSC_VER
1719 #  pragma warning( push )
1720 #  pragma warning( disable : 4646 ) /* warning C4646: function declared with
1721     __declspec(noreturn) has non-void return type */
1722 #  pragma warning( disable : 4645 ) /* warning C4645: function declared with
1723 __declspec(noreturn) has a return statement */
1724 #endif
1725 OP *
1726 Perl_die(pTHX_ const char* pat, ...)
1727 {
1728     va_list args;
1729     va_start(args, pat);
1730     vcroak(pat, &args);
1731     NOT_REACHED; /* NOTREACHED */
1732     va_end(args);
1733     NORETURN_FUNCTION_END;
1734 }
1735 #ifdef _MSC_VER
1736 #  pragma warning( pop )
1737 #endif
1738
1739 /*
1740 =for apidoc Am|void|croak_sv|SV *baseex
1741
1742 This is an XS interface to Perl's C<die> function.
1743
1744 C<baseex> is the error message or object.  If it is a reference, it
1745 will be used as-is.  Otherwise it is used as a string, and if it does
1746 not end with a newline then it will be extended with some indication of
1747 the current location in the code, as described for L</mess_sv>.
1748
1749 The error message or object will be used as an exception, by default
1750 returning control to the nearest enclosing C<eval>, but subject to
1751 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1752 function never returns normally.
1753
1754 To die with a simple string message, the L</croak> function may be
1755 more convenient.
1756
1757 =cut
1758 */
1759
1760 void
1761 Perl_croak_sv(pTHX_ SV *baseex)
1762 {
1763     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1764     PERL_ARGS_ASSERT_CROAK_SV;
1765     invoke_exception_hook(ex, FALSE);
1766     die_unwind(ex);
1767 }
1768
1769 /*
1770 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1771
1772 This is an XS interface to Perl's C<die> function.
1773
1774 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1775 argument list.  These are used to generate a string message.  If the
1776 message does not end with a newline, then it will be extended with
1777 some indication of the current location in the code, as described for
1778 L</mess_sv>.
1779
1780 The error message will be used as an exception, by default
1781 returning control to the nearest enclosing C<eval>, but subject to
1782 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1783 function never returns normally.
1784
1785 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1786 (C<$@>) will be used as an error message or object instead of building an
1787 error message from arguments.  If you want to throw a non-string object,
1788 or build an error message in an SV yourself, it is preferable to use
1789 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1790
1791 =cut
1792 */
1793
1794 void
1795 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1796 {
1797     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1798     invoke_exception_hook(ex, FALSE);
1799     die_unwind(ex);
1800 }
1801
1802 /*
1803 =for apidoc Am|void|croak|const char *pat|...
1804
1805 This is an XS interface to Perl's C<die> function.
1806
1807 Take a sprintf-style format pattern and argument list.  These are used to
1808 generate a string message.  If the message does not end with a newline,
1809 then it will be extended with some indication of the current location
1810 in the code, as described for L</mess_sv>.
1811
1812 The error message will be used as an exception, by default
1813 returning control to the nearest enclosing C<eval>, but subject to
1814 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1815 function never returns normally.
1816
1817 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1818 (C<$@>) will be used as an error message or object instead of building an
1819 error message from arguments.  If you want to throw a non-string object,
1820 or build an error message in an SV yourself, it is preferable to use
1821 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1822
1823 =cut
1824 */
1825
1826 #if defined(PERL_IMPLICIT_CONTEXT)
1827 void
1828 Perl_croak_nocontext(const char *pat, ...)
1829 {
1830     dTHX;
1831     va_list args;
1832     va_start(args, pat);
1833     vcroak(pat, &args);
1834     NOT_REACHED; /* NOTREACHED */
1835     va_end(args);
1836 }
1837 #endif /* PERL_IMPLICIT_CONTEXT */
1838
1839 void
1840 Perl_croak(pTHX_ const char *pat, ...)
1841 {
1842     va_list args;
1843     va_start(args, pat);
1844     vcroak(pat, &args);
1845     NOT_REACHED; /* NOTREACHED */
1846     va_end(args);
1847 }
1848
1849 /*
1850 =for apidoc Am|void|croak_no_modify
1851
1852 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1853 terser object code than using C<Perl_croak>.  Less code used on exception code
1854 paths reduces CPU cache pressure.
1855
1856 =cut
1857 */
1858
1859 void
1860 Perl_croak_no_modify(void)
1861 {
1862     Perl_croak_nocontext( "%s", PL_no_modify);
1863 }
1864
1865 /* does not return, used in util.c perlio.c and win32.c
1866    This is typically called when malloc returns NULL.
1867 */
1868 void
1869 Perl_croak_no_mem(void)
1870 {
1871     dTHX;
1872
1873     int fd = PerlIO_fileno(Perl_error_log);
1874     if (fd < 0)
1875         SETERRNO(EBADF,RMS_IFI);
1876     else {
1877         /* Can't use PerlIO to write as it allocates memory */
1878         PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1));
1879     }
1880     my_exit(1);
1881 }
1882
1883 /* does not return, used only in POPSTACK */
1884 void
1885 Perl_croak_popstack(void)
1886 {
1887     dTHX;
1888     PerlIO_printf(Perl_error_log, "panic: POPSTACK\n");
1889     my_exit(1);
1890 }
1891
1892 /*
1893 =for apidoc Am|void|warn_sv|SV *baseex
1894
1895 This is an XS interface to Perl's C<warn> function.
1896
1897 C<baseex> is the error message or object.  If it is a reference, it
1898 will be used as-is.  Otherwise it is used as a string, and if it does
1899 not end with a newline then it will be extended with some indication of
1900 the current location in the code, as described for L</mess_sv>.
1901
1902 The error message or object will by default be written to standard error,
1903 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1904
1905 To warn with a simple string message, the L</warn> function may be
1906 more convenient.
1907
1908 =cut
1909 */
1910
1911 void
1912 Perl_warn_sv(pTHX_ SV *baseex)
1913 {
1914     SV *ex = mess_sv(baseex, 0);
1915     PERL_ARGS_ASSERT_WARN_SV;
1916     if (!invoke_exception_hook(ex, TRUE))
1917         write_to_stderr(ex);
1918 }
1919
1920 /*
1921 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1922
1923 This is an XS interface to Perl's C<warn> function.
1924
1925 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1926 argument list.  These are used to generate a string message.  If the
1927 message does not end with a newline, then it will be extended with
1928 some indication of the current location in the code, as described for
1929 L</mess_sv>.
1930
1931 The error message or object will by default be written to standard error,
1932 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1933
1934 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1935
1936 =cut
1937 */
1938
1939 void
1940 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1941 {
1942     SV *ex = vmess(pat, args);
1943     PERL_ARGS_ASSERT_VWARN;
1944     if (!invoke_exception_hook(ex, TRUE))
1945         write_to_stderr(ex);
1946 }
1947
1948 /*
1949 =for apidoc Am|void|warn|const char *pat|...
1950
1951 This is an XS interface to Perl's C<warn> function.
1952
1953 Take a sprintf-style format pattern and argument list.  These are used to
1954 generate a string message.  If the message does not end with a newline,
1955 then it will be extended with some indication of the current location
1956 in the code, as described for L</mess_sv>.
1957
1958 The error message or object will by default be written to standard error,
1959 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1960
1961 Unlike with L</croak>, C<pat> is not permitted to be null.
1962
1963 =cut
1964 */
1965
1966 #if defined(PERL_IMPLICIT_CONTEXT)
1967 void
1968 Perl_warn_nocontext(const char *pat, ...)
1969 {
1970     dTHX;
1971     va_list args;
1972     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1973     va_start(args, pat);
1974     vwarn(pat, &args);
1975     va_end(args);
1976 }
1977 #endif /* PERL_IMPLICIT_CONTEXT */
1978
1979 void
1980 Perl_warn(pTHX_ const char *pat, ...)
1981 {
1982     va_list args;
1983     PERL_ARGS_ASSERT_WARN;
1984     va_start(args, pat);
1985     vwarn(pat, &args);
1986     va_end(args);
1987 }
1988
1989 #if defined(PERL_IMPLICIT_CONTEXT)
1990 void
1991 Perl_warner_nocontext(U32 err, const char *pat, ...)
1992 {
1993     dTHX;
1994     va_list args;
1995     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1996     va_start(args, pat);
1997     vwarner(err, pat, &args);
1998     va_end(args);
1999 }
2000 #endif /* PERL_IMPLICIT_CONTEXT */
2001
2002 void
2003 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
2004 {
2005     PERL_ARGS_ASSERT_CK_WARNER_D;
2006
2007     if (Perl_ckwarn_d(aTHX_ err)) {
2008         va_list args;
2009         va_start(args, pat);
2010         vwarner(err, pat, &args);
2011         va_end(args);
2012     }
2013 }
2014
2015 void
2016 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
2017 {
2018     PERL_ARGS_ASSERT_CK_WARNER;
2019
2020     if (Perl_ckwarn(aTHX_ err)) {
2021         va_list args;
2022         va_start(args, pat);
2023         vwarner(err, pat, &args);
2024         va_end(args);
2025     }
2026 }
2027
2028 void
2029 Perl_warner(pTHX_ U32  err, const char* pat,...)
2030 {
2031     va_list args;
2032     PERL_ARGS_ASSERT_WARNER;
2033     va_start(args, pat);
2034     vwarner(err, pat, &args);
2035     va_end(args);
2036 }
2037
2038 void
2039 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
2040 {
2041     dVAR;
2042     PERL_ARGS_ASSERT_VWARNER;
2043     if (
2044         (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
2045         !(PL_in_eval & EVAL_KEEPERR)
2046     ) {
2047         SV * const msv = vmess(pat, args);
2048
2049         if (PL_parser && PL_parser->error_count) {
2050             qerror(msv);
2051         }
2052         else {
2053             invoke_exception_hook(msv, FALSE);
2054             die_unwind(msv);
2055         }
2056     }
2057     else {
2058         Perl_vwarn(aTHX_ pat, args);
2059     }
2060 }
2061
2062 /* implements the ckWARN? macros */
2063
2064 bool
2065 Perl_ckwarn(pTHX_ U32 w)
2066 {
2067     /* If lexical warnings have not been set, use $^W.  */
2068     if (isLEXWARN_off)
2069         return PL_dowarn & G_WARN_ON;
2070
2071     return ckwarn_common(w);
2072 }
2073
2074 /* implements the ckWARN?_d macro */
2075
2076 bool
2077 Perl_ckwarn_d(pTHX_ U32 w)
2078 {
2079     /* If lexical warnings have not been set then default classes warn.  */
2080     if (isLEXWARN_off)
2081         return TRUE;
2082
2083     return ckwarn_common(w);
2084 }
2085
2086 static bool
2087 S_ckwarn_common(pTHX_ U32 w)
2088 {
2089     if (PL_curcop->cop_warnings == pWARN_ALL)
2090         return TRUE;
2091
2092     if (PL_curcop->cop_warnings == pWARN_NONE)
2093         return FALSE;
2094
2095     /* Check the assumption that at least the first slot is non-zero.  */
2096     assert(unpackWARN1(w));
2097
2098     /* Check the assumption that it is valid to stop as soon as a zero slot is
2099        seen.  */
2100     if (!unpackWARN2(w)) {
2101         assert(!unpackWARN3(w));
2102         assert(!unpackWARN4(w));
2103     } else if (!unpackWARN3(w)) {
2104         assert(!unpackWARN4(w));
2105     }
2106
2107     /* Right, dealt with all the special cases, which are implemented as non-
2108        pointers, so there is a pointer to a real warnings mask.  */
2109     do {
2110         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
2111             return TRUE;
2112     } while (w >>= WARNshift);
2113
2114     return FALSE;
2115 }
2116
2117 /* Set buffer=NULL to get a new one.  */
2118 STRLEN *
2119 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
2120                            STRLEN size) {
2121     const MEM_SIZE len_wanted =
2122         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
2123     PERL_UNUSED_CONTEXT;
2124     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
2125
2126     buffer = (STRLEN*)
2127         (specialWARN(buffer) ?
2128          PerlMemShared_malloc(len_wanted) :
2129          PerlMemShared_realloc(buffer, len_wanted));
2130     buffer[0] = size;
2131     Copy(bits, (buffer + 1), size, char);
2132     if (size < WARNsize)
2133         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
2134     return buffer;
2135 }
2136
2137 /* since we've already done strlen() for both nam and val
2138  * we can use that info to make things faster than
2139  * sprintf(s, "%s=%s", nam, val)
2140  */
2141 #define my_setenv_format(s, nam, nlen, val, vlen) \
2142    Copy(nam, s, nlen, char); \
2143    *(s+nlen) = '='; \
2144    Copy(val, s+(nlen+1), vlen, char); \
2145    *(s+(nlen+1+vlen)) = '\0'
2146
2147 #ifdef USE_ENVIRON_ARRAY
2148        /* VMS' my_setenv() is in vms.c */
2149 #if !defined(WIN32) && !defined(NETWARE)
2150 void
2151 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2152 {
2153   dVAR;
2154 #ifdef __amigaos4__
2155   amigaos4_obtain_environ(__FUNCTION__);
2156 #endif
2157 #ifdef USE_ITHREADS
2158   /* only parent thread can modify process environment */
2159   if (PL_curinterp == aTHX)
2160 #endif
2161   {
2162 #ifndef PERL_USE_SAFE_PUTENV
2163     if (!PL_use_safe_putenv) {
2164         /* most putenv()s leak, so we manipulate environ directly */
2165         I32 i;
2166         const I32 len = strlen(nam);
2167         int nlen, vlen;
2168
2169         /* where does it go? */
2170         for (i = 0; environ[i]; i++) {
2171             if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
2172                 break;
2173         }
2174
2175         if (environ == PL_origenviron) {   /* need we copy environment? */
2176             I32 j;
2177             I32 max;
2178             char **tmpenv;
2179
2180             max = i;
2181             while (environ[max])
2182                 max++;
2183             tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
2184             for (j=0; j<max; j++) {         /* copy environment */
2185                 const int len = strlen(environ[j]);
2186                 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
2187                 Copy(environ[j], tmpenv[j], len+1, char);
2188             }
2189             tmpenv[max] = NULL;
2190             environ = tmpenv;               /* tell exec where it is now */
2191         }
2192         if (!val) {
2193             safesysfree(environ[i]);
2194             while (environ[i]) {
2195                 environ[i] = environ[i+1];
2196                 i++;
2197             }
2198 #ifdef __amigaos4__
2199             goto my_setenv_out;
2200 #else
2201             return;
2202 #endif
2203         }
2204         if (!environ[i]) {                 /* does not exist yet */
2205             environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
2206             environ[i+1] = NULL;    /* make sure it's null terminated */
2207         }
2208         else
2209             safesysfree(environ[i]);
2210         nlen = strlen(nam);
2211         vlen = strlen(val);
2212
2213         environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
2214         /* all that work just for this */
2215         my_setenv_format(environ[i], nam, nlen, val, vlen);
2216     } else {
2217 # endif
2218     /* This next branch should only be called #if defined(HAS_SETENV), but
2219        Configure doesn't test for that yet.  For Solaris, setenv() and unsetenv()
2220        were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
2221     */
2222 #   if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
2223 #       if defined(HAS_UNSETENV)
2224         if (val == NULL) {
2225             (void)unsetenv(nam);
2226         } else {
2227             (void)setenv(nam, val, 1);
2228         }
2229 #       else /* ! HAS_UNSETENV */
2230         (void)setenv(nam, val, 1);
2231 #       endif /* HAS_UNSETENV */
2232 #   else
2233 #       if defined(HAS_UNSETENV)
2234         if (val == NULL) {
2235             if (environ) /* old glibc can crash with null environ */
2236                 (void)unsetenv(nam);
2237         } else {
2238             const int nlen = strlen(nam);
2239             const int vlen = strlen(val);
2240             char * const new_env =
2241                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2242             my_setenv_format(new_env, nam, nlen, val, vlen);
2243             (void)putenv(new_env);
2244         }
2245 #       else /* ! HAS_UNSETENV */
2246         char *new_env;
2247         const int nlen = strlen(nam);
2248         int vlen;
2249         if (!val) {
2250            val = "";
2251         }
2252         vlen = strlen(val);
2253         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
2254         /* all that work just for this */
2255         my_setenv_format(new_env, nam, nlen, val, vlen);
2256         (void)putenv(new_env);
2257 #       endif /* HAS_UNSETENV */
2258 #   endif /* __CYGWIN__ */
2259 #ifndef PERL_USE_SAFE_PUTENV
2260     }
2261 #endif
2262   }
2263 #ifdef __amigaos4__
2264 my_setenv_out:
2265   amigaos4_release_environ(__FUNCTION__);
2266 #endif
2267 }
2268
2269 #else /* WIN32 || NETWARE */
2270
2271 void
2272 Perl_my_setenv(pTHX_ const char *nam, const char *val)
2273 {
2274     dVAR;
2275     char *envstr;
2276     const int nlen = strlen(nam);
2277     int vlen;
2278
2279     if (!val) {
2280        val = "";
2281     }
2282     vlen = strlen(val);
2283     Newx(envstr, nlen+vlen+2, char);
2284     my_setenv_format(envstr, nam, nlen, val, vlen);
2285     (void)PerlEnv_putenv(envstr);
2286     Safefree(envstr);
2287 }
2288
2289 #endif /* WIN32 || NETWARE */
2290
2291 #endif /* !VMS */
2292
2293 #ifdef UNLINK_ALL_VERSIONS
2294 I32
2295 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2296 {
2297     I32 retries = 0;
2298
2299     PERL_ARGS_ASSERT_UNLNK;
2300
2301     while (PerlLIO_unlink(f) >= 0)
2302         retries++;
2303     return retries ? 0 : -1;
2304 }
2305 #endif
2306
2307 /* this is a drop-in replacement for bcopy(), except for the return
2308  * value, which we need to be able to emulate memcpy()  */
2309 #if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
2310 void *
2311 Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
2312 {
2313 #if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
2314     bcopy(vfrom, vto, len);
2315 #else
2316     const unsigned char *from = (const unsigned char *)vfrom;
2317     unsigned char *to = (unsigned char *)vto;
2318
2319     PERL_ARGS_ASSERT_MY_BCOPY;
2320
2321     if (from - to >= 0) {
2322         while (len--)
2323             *to++ = *from++;
2324     }
2325     else {
2326         to += len;
2327         from += len;
2328         while (len--)
2329             *(--to) = *(--from);
2330     }
2331 #endif
2332
2333     return vto;
2334 }
2335 #endif
2336
2337 /* this is a drop-in replacement for memset() */
2338 #ifndef HAS_MEMSET
2339 void *
2340 Perl_my_memset(void *vloc, int ch, size_t len)
2341 {
2342     unsigned char *loc = (unsigned char *)vloc;
2343
2344     PERL_ARGS_ASSERT_MY_MEMSET;
2345
2346     while (len--)
2347         *loc++ = ch;
2348     return vloc;
2349 }
2350 #endif
2351
2352 /* this is a drop-in replacement for bzero() */
2353 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2354 void *
2355 Perl_my_bzero(void *vloc, size_t len)
2356 {
2357     unsigned char *loc = (unsigned char *)vloc;
2358
2359     PERL_ARGS_ASSERT_MY_BZERO;
2360
2361     while (len--)
2362         *loc++ = 0;
2363     return vloc;
2364 }
2365 #endif
2366
2367 /* this is a drop-in replacement for memcmp() */
2368 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2369 int
2370 Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
2371 {
2372     const U8 *a = (const U8 *)vs1;
2373     const U8 *b = (const U8 *)vs2;
2374     int tmp;
2375
2376     PERL_ARGS_ASSERT_MY_MEMCMP;
2377
2378     while (len--) {
2379         if ((tmp = *a++ - *b++))
2380             return tmp;
2381     }
2382     return 0;
2383 }
2384 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2385
2386 #ifndef HAS_VPRINTF
2387 /* This vsprintf replacement should generally never get used, since
2388    vsprintf was available in both System V and BSD 2.11.  (There may
2389    be some cross-compilation or embedded set-ups where it is needed,
2390    however.)
2391
2392    If you encounter a problem in this function, it's probably a symptom
2393    that Configure failed to detect your system's vprintf() function.
2394    See the section on "item vsprintf" in the INSTALL file.
2395
2396    This version may compile on systems with BSD-ish <stdio.h>,
2397    but probably won't on others.
2398 */
2399
2400 #ifdef USE_CHAR_VSPRINTF
2401 char *
2402 #else
2403 int
2404 #endif
2405 vsprintf(char *dest, const char *pat, void *args)
2406 {
2407     FILE fakebuf;
2408
2409 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2410     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2411     FILE_cnt(&fakebuf) = 32767;
2412 #else
2413     /* These probably won't compile -- If you really need
2414        this, you'll have to figure out some other method. */
2415     fakebuf._ptr = dest;
2416     fakebuf._cnt = 32767;
2417 #endif
2418 #ifndef _IOSTRG
2419 #define _IOSTRG 0
2420 #endif
2421     fakebuf._flag = _IOWRT|_IOSTRG;
2422     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2423 #if defined(STDIO_PTR_LVALUE)
2424     *(FILE_ptr(&fakebuf)++) = '\0';
2425 #else
2426     /* PerlIO has probably #defined away fputc, but we want it here. */
2427 #  ifdef fputc
2428 #    undef fputc  /* XXX Should really restore it later */
2429 #  endif
2430     (void)fputc('\0', &fakebuf);
2431 #endif
2432 #ifdef USE_CHAR_VSPRINTF
2433     return(dest);
2434 #else
2435     return 0;           /* perl doesn't use return value */
2436 #endif
2437 }
2438
2439 #endif /* HAS_VPRINTF */
2440
2441 PerlIO *
2442 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2443 {
2444 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2445     int p[2];
2446     I32 This, that;
2447     Pid_t pid;
2448     SV *sv;
2449     I32 did_pipes = 0;
2450     int pp[2];
2451
2452     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2453
2454     PERL_FLUSHALL_FOR_CHILD;
2455     This = (*mode == 'w');
2456     that = !This;
2457     if (TAINTING_get) {
2458         taint_env();
2459         taint_proper("Insecure %s%s", "EXEC");
2460     }
2461     if (PerlProc_pipe(p) < 0)
2462         return NULL;
2463     /* Try for another pipe pair for error return */
2464     if (PerlProc_pipe(pp) >= 0)
2465         did_pipes = 1;
2466     while ((pid = PerlProc_fork()) < 0) {
2467         if (errno != EAGAIN) {
2468             PerlLIO_close(p[This]);
2469             PerlLIO_close(p[that]);
2470             if (did_pipes) {
2471                 PerlLIO_close(pp[0]);
2472                 PerlLIO_close(pp[1]);
2473             }
2474             return NULL;
2475         }
2476         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2477         sleep(5);
2478     }
2479     if (pid == 0) {
2480         /* Child */
2481 #undef THIS
2482 #undef THAT
2483 #define THIS that
2484 #define THAT This
2485         /* Close parent's end of error status pipe (if any) */
2486         if (did_pipes) {
2487             PerlLIO_close(pp[0]);
2488 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2489             /* Close error pipe automatically if exec works */
2490             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2491                 return NULL;
2492 #endif
2493         }
2494         /* Now dup our end of _the_ pipe to right position */
2495         if (p[THIS] != (*mode == 'r')) {
2496             PerlLIO_dup2(p[THIS], *mode == 'r');
2497             PerlLIO_close(p[THIS]);
2498             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2499                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2500         }
2501         else
2502             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2503 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2504         /* No automatic close - do it by hand */
2505 #  ifndef NOFILE
2506 #  define NOFILE 20
2507 #  endif
2508         {
2509             int fd;
2510
2511             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2512                 if (fd != pp[1])
2513                     PerlLIO_close(fd);
2514             }
2515         }
2516 #endif
2517         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2518         PerlProc__exit(1);
2519 #undef THIS
2520 #undef THAT
2521     }
2522     /* Parent */
2523     do_execfree();      /* free any memory malloced by child on fork */
2524     if (did_pipes)
2525         PerlLIO_close(pp[1]);
2526     /* Keep the lower of the two fd numbers */
2527     if (p[that] < p[This]) {
2528         PerlLIO_dup2(p[This], p[that]);
2529         PerlLIO_close(p[This]);
2530         p[This] = p[that];
2531     }
2532     else
2533         PerlLIO_close(p[that]);         /* close child's end of pipe */
2534
2535     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2536     SvUPGRADE(sv,SVt_IV);
2537     SvIV_set(sv, pid);
2538     PL_forkprocess = pid;
2539     /* If we managed to get status pipe check for exec fail */
2540     if (did_pipes && pid > 0) {
2541         int errkid;
2542         unsigned n = 0;
2543
2544         while (n < sizeof(int)) {
2545             const SSize_t n1 = PerlLIO_read(pp[0],
2546                               (void*)(((char*)&errkid)+n),
2547                               (sizeof(int)) - n);
2548             if (n1 <= 0)
2549                 break;
2550             n += n1;
2551         }
2552         PerlLIO_close(pp[0]);
2553         did_pipes = 0;
2554         if (n) {                        /* Error */
2555             int pid2, status;
2556             PerlLIO_close(p[This]);
2557             if (n != sizeof(int))
2558                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2559             do {
2560                 pid2 = wait4pid(pid, &status, 0);
2561             } while (pid2 == -1 && errno == EINTR);
2562             errno = errkid;             /* Propagate errno from kid */
2563             return NULL;
2564         }
2565     }
2566     if (did_pipes)
2567          PerlLIO_close(pp[0]);
2568     return PerlIO_fdopen(p[This], mode);
2569 #else
2570 #  if defined(OS2)      /* Same, without fork()ing and all extra overhead... */
2571     return my_syspopen4(aTHX_ NULL, mode, n, args);
2572 #  elif defined(WIN32)
2573     return win32_popenlist(mode, n, args);
2574 #  else
2575     Perl_croak(aTHX_ "List form of piped open not implemented");
2576     return (PerlIO *) NULL;
2577 #  endif
2578 #endif
2579 }
2580
2581     /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
2582 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
2583 PerlIO *
2584 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2585 {
2586     int p[2];
2587     I32 This, that;
2588     Pid_t pid;
2589     SV *sv;
2590     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2591     I32 did_pipes = 0;
2592     int pp[2];
2593
2594     PERL_ARGS_ASSERT_MY_POPEN;
2595
2596     PERL_FLUSHALL_FOR_CHILD;
2597 #ifdef OS2
2598     if (doexec) {
2599         return my_syspopen(aTHX_ cmd,mode);
2600     }
2601 #endif
2602     This = (*mode == 'w');
2603     that = !This;
2604     if (doexec && TAINTING_get) {
2605         taint_env();
2606         taint_proper("Insecure %s%s", "EXEC");
2607     }
2608     if (PerlProc_pipe(p) < 0)
2609         return NULL;
2610     if (doexec && PerlProc_pipe(pp) >= 0)
2611         did_pipes = 1;
2612     while ((pid = PerlProc_fork()) < 0) {
2613         if (errno != EAGAIN) {
2614             PerlLIO_close(p[This]);
2615             PerlLIO_close(p[that]);
2616             if (did_pipes) {
2617                 PerlLIO_close(pp[0]);
2618                 PerlLIO_close(pp[1]);
2619             }
2620             if (!doexec)
2621                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2622             return NULL;
2623         }
2624         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2625         sleep(5);
2626     }
2627     if (pid == 0) {
2628
2629 #undef THIS
2630 #undef THAT
2631 #define THIS that
2632 #define THAT This
2633         if (did_pipes) {
2634             PerlLIO_close(pp[0]);
2635 #if defined(HAS_FCNTL) && defined(F_SETFD)
2636             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
2637                 return NULL;
2638 #endif
2639         }
2640         if (p[THIS] != (*mode == 'r')) {
2641             PerlLIO_dup2(p[THIS], *mode == 'r');
2642             PerlLIO_close(p[THIS]);
2643             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2644                 PerlLIO_close(p[THAT]);
2645         }
2646         else
2647             PerlLIO_close(p[THAT]);
2648 #ifndef OS2
2649         if (doexec) {
2650 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2651 #ifndef NOFILE
2652 #define NOFILE 20
2653 #endif
2654             {
2655                 int fd;
2656
2657                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2658                     if (fd != pp[1])
2659                         PerlLIO_close(fd);
2660             }
2661 #endif
2662             /* may or may not use the shell */
2663             do_exec3(cmd, pp[1], did_pipes);
2664             PerlProc__exit(1);
2665         }
2666 #endif  /* defined OS2 */
2667
2668 #ifdef PERLIO_USING_CRLF
2669    /* Since we circumvent IO layers when we manipulate low-level
2670       filedescriptors directly, need to manually switch to the
2671       default, binary, low-level mode; see PerlIOBuf_open(). */
2672    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2673 #endif
2674         PL_forkprocess = 0;
2675 #ifdef PERL_USES_PL_PIDSTATUS
2676         hv_clear(PL_pidstatus); /* we have no children */
2677 #endif
2678         return NULL;
2679 #undef THIS
2680 #undef THAT
2681     }
2682     do_execfree();      /* free any memory malloced by child on vfork */
2683     if (did_pipes)
2684         PerlLIO_close(pp[1]);
2685     if (p[that] < p[This]) {
2686         PerlLIO_dup2(p[This], p[that]);
2687         PerlLIO_close(p[This]);
2688         p[This] = p[that];
2689     }
2690     else
2691         PerlLIO_close(p[that]);
2692
2693     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2694     SvUPGRADE(sv,SVt_IV);
2695     SvIV_set(sv, pid);
2696     PL_forkprocess = pid;
2697     if (did_pipes && pid > 0) {
2698         int errkid;
2699         unsigned n = 0;
2700
2701         while (n < sizeof(int)) {
2702             const SSize_t n1 = PerlLIO_read(pp[0],
2703                               (void*)(((char*)&errkid)+n),
2704                               (sizeof(int)) - n);
2705             if (n1 <= 0)
2706                 break;
2707             n += n1;
2708         }
2709         PerlLIO_close(pp[0]);
2710         did_pipes = 0;
2711         if (n) {                        /* Error */
2712             int pid2, status;
2713             PerlLIO_close(p[This]);
2714             if (n != sizeof(int))
2715                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2716             do {
2717                 pid2 = wait4pid(pid, &status, 0);
2718             } while (pid2 == -1 && errno == EINTR);
2719             errno = errkid;             /* Propagate errno from kid */
2720             return NULL;
2721         }
2722     }
2723     if (did_pipes)
2724          PerlLIO_close(pp[0]);
2725     return PerlIO_fdopen(p[This], mode);
2726 }
2727 #else
2728 #if defined(DJGPP)
2729 FILE *djgpp_popen();
2730 PerlIO *
2731 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2732 {
2733     PERL_FLUSHALL_FOR_CHILD;
2734     /* Call system's popen() to get a FILE *, then import it.
2735        used 0 for 2nd parameter to PerlIO_importFILE;
2736        apparently not used
2737     */
2738     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2739 }
2740 #else
2741 #if defined(__LIBCATAMOUNT__)
2742 PerlIO *
2743 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2744 {
2745     return NULL;
2746 }
2747 #endif
2748 #endif
2749
2750 #endif /* !DOSISH */
2751
2752 /* this is called in parent before the fork() */
2753 void
2754 Perl_atfork_lock(void)
2755 #if defined(USE_ITHREADS)
2756 #  ifdef USE_PERLIO
2757   PERL_TSA_ACQUIRE(PL_perlio_mutex)
2758 #  endif
2759 #  ifdef MYMALLOC
2760   PERL_TSA_ACQUIRE(PL_malloc_mutex)
2761 #  endif
2762   PERL_TSA_ACQUIRE(PL_op_mutex)
2763 #endif
2764 {
2765 #if defined(USE_ITHREADS)
2766     dVAR;
2767     /* locks must be held in locking order (if any) */
2768 #  ifdef USE_PERLIO
2769     MUTEX_LOCK(&PL_perlio_mutex);
2770 #  endif
2771 #  ifdef MYMALLOC
2772     MUTEX_LOCK(&PL_malloc_mutex);
2773 #  endif
2774     OP_REFCNT_LOCK;
2775 #endif
2776 }
2777
2778 /* this is called in both parent and child after the fork() */
2779 void
2780 Perl_atfork_unlock(void)
2781 #if defined(USE_ITHREADS)
2782 #  ifdef USE_PERLIO
2783   PERL_TSA_RELEASE(PL_perlio_mutex)
2784 #  endif
2785 #  ifdef MYMALLOC
2786   PERL_TSA_RELEASE(PL_malloc_mutex)
2787 #  endif
2788   PERL_TSA_RELEASE(PL_op_mutex)
2789 #endif
2790 {
2791 #if defined(USE_ITHREADS)
2792     dVAR;
2793     /* locks must be released in same order as in atfork_lock() */
2794 #  ifdef USE_PERLIO
2795     MUTEX_UNLOCK(&PL_perlio_mutex);
2796 #  endif
2797 #  ifdef MYMALLOC
2798     MUTEX_UNLOCK(&PL_malloc_mutex);
2799 #  endif
2800     OP_REFCNT_UNLOCK;
2801 #endif
2802 }
2803
2804 Pid_t
2805 Perl_my_fork(void)
2806 {
2807 #if defined(HAS_FORK)
2808     Pid_t pid;
2809 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2810     atfork_lock();
2811     pid = fork();
2812     atfork_unlock();
2813 #else
2814     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2815      * handlers elsewhere in the code */
2816     pid = fork();
2817 #endif
2818     return pid;
2819 #elif defined(__amigaos4__)
2820     return amigaos_fork();
2821 #else
2822     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2823     Perl_croak_nocontext("fork() not available");
2824     return 0;
2825 #endif /* HAS_FORK */
2826 }
2827
2828 #ifndef HAS_DUP2
2829 int
2830 dup2(int oldfd, int newfd)
2831 {
2832 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2833     if (oldfd == newfd)
2834         return oldfd;
2835     PerlLIO_close(newfd);
2836     return fcntl(oldfd, F_DUPFD, newfd);
2837 #else
2838 #define DUP2_MAX_FDS 256
2839     int fdtmp[DUP2_MAX_FDS];
2840     I32 fdx = 0;
2841     int fd;
2842
2843     if (oldfd == newfd)
2844         return oldfd;
2845     PerlLIO_close(newfd);
2846     /* good enough for low fd's... */
2847     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2848         if (fdx >= DUP2_MAX_FDS) {
2849             PerlLIO_close(fd);
2850             fd = -1;
2851             break;
2852         }
2853         fdtmp[fdx++] = fd;
2854     }
2855     while (fdx > 0)
2856         PerlLIO_close(fdtmp[--fdx]);
2857     return fd;
2858 #endif
2859 }
2860 #endif
2861
2862 #ifndef PERL_MICRO
2863 #ifdef HAS_SIGACTION
2864
2865 Sighandler_t
2866 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2867 {
2868     struct sigaction act, oact;
2869
2870 #ifdef USE_ITHREADS
2871     dVAR;
2872     /* only "parent" interpreter can diddle signals */
2873     if (PL_curinterp != aTHX)
2874         return (Sighandler_t) SIG_ERR;
2875 #endif
2876
2877     act.sa_handler = (void(*)(int))handler;
2878     sigemptyset(&act.sa_mask);
2879     act.sa_flags = 0;
2880 #ifdef SA_RESTART
2881     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2882         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2883 #endif
2884 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2885     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2886         act.sa_flags |= SA_NOCLDWAIT;
2887 #endif
2888     if (sigaction(signo, &act, &oact) == -1)
2889         return (Sighandler_t) SIG_ERR;
2890     else
2891         return (Sighandler_t) oact.sa_handler;
2892 }
2893
2894 Sighandler_t
2895 Perl_rsignal_state(pTHX_ int signo)
2896 {
2897     struct sigaction oact;
2898     PERL_UNUSED_CONTEXT;
2899
2900     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2901         return (Sighandler_t) SIG_ERR;
2902     else
2903         return (Sighandler_t) oact.sa_handler;
2904 }
2905
2906 int
2907 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2908 {
2909 #ifdef USE_ITHREADS
2910     dVAR;
2911 #endif
2912     struct sigaction act;
2913
2914     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2915
2916 #ifdef USE_ITHREADS
2917     /* only "parent" interpreter can diddle signals */
2918     if (PL_curinterp != aTHX)
2919         return -1;
2920 #endif
2921
2922     act.sa_handler = (void(*)(int))handler;
2923     sigemptyset(&act.sa_mask);
2924     act.sa_flags = 0;
2925 #ifdef SA_RESTART
2926     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2927         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2928 #endif
2929 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2930     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2931         act.sa_flags |= SA_NOCLDWAIT;
2932 #endif
2933     return sigaction(signo, &act, save);
2934 }
2935
2936 int
2937 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2938 {
2939 #ifdef USE_ITHREADS
2940     dVAR;
2941 #endif
2942     PERL_UNUSED_CONTEXT;
2943 #ifdef USE_ITHREADS
2944     /* only "parent" interpreter can diddle signals */
2945     if (PL_curinterp != aTHX)
2946         return -1;
2947 #endif
2948
2949     return sigaction(signo, save, (struct sigaction *)NULL);
2950 }
2951
2952 #else /* !HAS_SIGACTION */
2953
2954 Sighandler_t
2955 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2956 {
2957 #if defined(USE_ITHREADS) && !defined(WIN32)
2958     /* only "parent" interpreter can diddle signals */
2959     if (PL_curinterp != aTHX)
2960         return (Sighandler_t) SIG_ERR;
2961 #endif
2962
2963     return PerlProc_signal(signo, handler);
2964 }
2965
2966 static Signal_t
2967 sig_trap(int signo)
2968 {
2969     dVAR;
2970     PL_sig_trapped++;
2971 }
2972
2973 Sighandler_t
2974 Perl_rsignal_state(pTHX_ int signo)
2975 {
2976     dVAR;
2977     Sighandler_t oldsig;
2978
2979 #if defined(USE_ITHREADS) && !defined(WIN32)
2980     /* only "parent" interpreter can diddle signals */
2981     if (PL_curinterp != aTHX)
2982         return (Sighandler_t) SIG_ERR;
2983 #endif
2984
2985     PL_sig_trapped = 0;
2986     oldsig = PerlProc_signal(signo, sig_trap);
2987     PerlProc_signal(signo, oldsig);
2988     if (PL_sig_trapped)
2989         PerlProc_kill(PerlProc_getpid(), signo);
2990     return oldsig;
2991 }
2992
2993 int
2994 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2995 {
2996 #if defined(USE_ITHREADS) && !defined(WIN32)
2997     /* only "parent" interpreter can diddle signals */
2998     if (PL_curinterp != aTHX)
2999         return -1;
3000 #endif
3001     *save = PerlProc_signal(signo, handler);
3002     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3003 }
3004
3005 int
3006 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3007 {
3008 #if defined(USE_ITHREADS) && !defined(WIN32)
3009     /* only "parent" interpreter can diddle signals */
3010     if (PL_curinterp != aTHX)
3011         return -1;
3012 #endif
3013     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3014 }
3015
3016 #endif /* !HAS_SIGACTION */
3017 #endif /* !PERL_MICRO */
3018
3019     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3020 #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
3021 I32
3022 Perl_my_pclose(pTHX_ PerlIO *ptr)
3023 {
3024     int status;
3025     SV **svp;
3026     Pid_t pid;
3027     Pid_t pid2 = 0;
3028     bool close_failed;
3029     dSAVEDERRNO;
3030     const int fd = PerlIO_fileno(ptr);
3031     bool should_wait;
3032
3033     svp = av_fetch(PL_fdpid,fd,TRUE);
3034     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3035     SvREFCNT_dec(*svp);
3036     *svp = NULL;
3037
3038 #if defined(USE_PERLIO)
3039     /* Find out whether the refcount is low enough for us to wait for the
3040        child proc without blocking. */
3041     should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
3042 #else
3043     should_wait = pid > 0;
3044 #endif
3045
3046 #ifdef OS2
3047     if (pid == -1) {                    /* Opened by popen. */
3048         return my_syspclose(ptr);
3049     }
3050 #endif
3051     close_failed = (PerlIO_close(ptr) == EOF);
3052     SAVE_ERRNO;
3053     if (should_wait) do {
3054         pid2 = wait4pid(pid, &status, 0);
3055     } while (pid2 == -1 && errno == EINTR);
3056     if (close_failed) {
3057         RESTORE_ERRNO;
3058         return -1;
3059     }
3060     return(
3061       should_wait
3062        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3063        : 0
3064     );
3065 }
3066 #else
3067 #if defined(__LIBCATAMOUNT__)
3068 I32
3069 Perl_my_pclose(pTHX_ PerlIO *ptr)
3070 {
3071     return -1;
3072 }
3073 #endif
3074 #endif /* !DOSISH */
3075
3076 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3077 I32
3078 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3079 {
3080     I32 result = 0;
3081     PERL_ARGS_ASSERT_WAIT4PID;
3082 #ifdef PERL_USES_PL_PIDSTATUS
3083     if (!pid) {
3084         /* PERL_USES_PL_PIDSTATUS is only defined when neither
3085            waitpid() nor wait4() is available, or on OS/2, which
3086            doesn't appear to support waiting for a progress group
3087            member, so we can only treat a 0 pid as an unknown child.
3088         */
3089         errno = ECHILD;
3090         return -1;
3091     }
3092     {
3093         if (pid > 0) {
3094             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3095                pid, rather than a string form.  */
3096             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3097             if (svp && *svp != &PL_sv_undef) {
3098                 *statusp = SvIVX(*svp);
3099                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3100                                 G_DISCARD);
3101                 return pid;
3102             }
3103         }
3104         else {
3105             HE *entry;
3106
3107             hv_iterinit(PL_pidstatus);
3108             if ((entry = hv_iternext(PL_pidstatus))) {
3109                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3110                 I32 len;
3111                 const char * const spid = hv_iterkey(entry,&len);
3112
3113                 assert (len == sizeof(Pid_t));
3114                 memcpy((char *)&pid, spid, len);
3115                 *statusp = SvIVX(sv);
3116                 /* The hash iterator is currently on this entry, so simply
3117                    calling hv_delete would trigger the lazy delete, which on
3118                    aggregate does more work, because next call to hv_iterinit()
3119                    would spot the flag, and have to call the delete routine,
3120                    while in the meantime any new entries can't re-use that
3121                    memory.  */
3122                 hv_iterinit(PL_pidstatus);
3123                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3124                 return pid;
3125             }
3126         }
3127     }
3128 #endif
3129 #ifdef HAS_WAITPID
3130 #  ifdef HAS_WAITPID_RUNTIME
3131     if (!HAS_WAITPID_RUNTIME)
3132         goto hard_way;
3133 #  endif
3134     result = PerlProc_waitpid(pid,statusp,flags);
3135     goto finish;
3136 #endif
3137 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3138     result = wait4(pid,statusp,flags,NULL);
3139     goto finish;
3140 #endif
3141 #ifdef PERL_USES_PL_PIDSTATUS
3142 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3143   hard_way:
3144 #endif
3145     {
3146         if (flags)
3147             Perl_croak(aTHX_ "Can't do waitpid with flags");
3148         else {
3149             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3150                 pidgone(result,*statusp);
3151             if (result < 0)
3152                 *statusp = -1;
3153         }
3154     }
3155 #endif
3156 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3157   finish:
3158 #endif
3159     if (result < 0 && errno == EINTR) {
3160         PERL_ASYNC_CHECK();
3161         errno = EINTR; /* reset in case a signal handler changed $! */
3162     }
3163     return result;
3164 }
3165 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3166
3167 #ifdef PERL_USES_PL_PIDSTATUS
3168 void
3169 S_pidgone(pTHX_ Pid_t pid, int status)
3170 {
3171     SV *sv;
3172
3173     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3174     SvUPGRADE(sv,SVt_IV);
3175     SvIV_set(sv, status);
3176     return;
3177 }
3178 #endif
3179
3180 #if defined(OS2)
3181 int pclose();
3182 #ifdef HAS_FORK
3183 int                                     /* Cannot prototype with I32
3184                                            in os2ish.h. */
3185 my_syspclose(PerlIO *ptr)
3186 #else
3187 I32
3188 Perl_my_pclose(pTHX_ PerlIO *ptr)
3189 #endif
3190 {
3191     /* Needs work for PerlIO ! */
3192     FILE * const f = PerlIO_findFILE(ptr);
3193     const I32 result = pclose(f);
3194     PerlIO_releaseFILE(ptr,f);
3195     return result;
3196 }
3197 #endif
3198
3199 #if defined(DJGPP)
3200 int djgpp_pclose();
3201 I32
3202 Perl_my_pclose(pTHX_ PerlIO *ptr)
3203 {
3204     /* Needs work for PerlIO ! */
3205     FILE * const f = PerlIO_findFILE(ptr);
3206     I32 result = djgpp_pclose(f);
3207     result = (result << 8) & 0xff00;
3208     PerlIO_releaseFILE(ptr,f);
3209     return result;
3210 }
3211 #endif
3212
3213 #define PERL_REPEATCPY_LINEAR 4
3214 void
3215 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3216 {
3217     PERL_ARGS_ASSERT_REPEATCPY;
3218
3219     assert(len >= 0);
3220
3221     if (count < 0)
3222         croak_memory_wrap();
3223
3224     if (len == 1)
3225         memset(to, *from, count);
3226     else if (count) {
3227         char *p = to;
3228         IV items, linear, half;
3229
3230         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3231         for (items = 0; items < linear; ++items) {
3232             const char *q = from;
3233             IV todo;
3234             for (todo = len; todo > 0; todo--)
3235                 *p++ = *q++;
3236         }
3237
3238         half = count / 2;
3239         while (items <= half) {
3240             IV size = items * len;
3241             memcpy(p, to, size);
3242             p     += size;
3243             items *= 2;
3244         }
3245
3246         if (count > items)
3247             memcpy(p, to, (count - items) * len);
3248     }
3249 }
3250
3251 #ifndef HAS_RENAME
3252 I32
3253 Perl_same_dirent(pTHX_ const char *a, const char *b)
3254 {
3255     char *fa = strrchr(a,'/');
3256     char *fb = strrchr(b,'/');
3257     Stat_t tmpstatbuf1;
3258     Stat_t tmpstatbuf2;
3259     SV * const tmpsv = sv_newmortal();
3260
3261     PERL_ARGS_ASSERT_SAME_DIRENT;
3262
3263     if (fa)
3264         fa++;
3265     else
3266         fa = a;
3267     if (fb)
3268         fb++;
3269     else
3270         fb = b;
3271     if (strNE(a,b))
3272         return FALSE;
3273     if (fa == a)
3274         sv_setpvs(tmpsv, ".");
3275     else
3276         sv_setpvn(tmpsv, a, fa - a);
3277     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3278         return FALSE;
3279     if (fb == b)
3280         sv_setpvs(tmpsv, ".");
3281     else
3282         sv_setpvn(tmpsv, b, fb - b);
3283     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3284         return FALSE;
3285     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3286            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3287 }
3288 #endif /* !HAS_RENAME */
3289
3290 char*
3291 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3292                  const char *const *const search_ext, I32 flags)
3293 {
3294     const char *xfound = NULL;
3295     char *xfailed = NULL;
3296     char tmpbuf[MAXPATHLEN];
3297     char *s;
3298     I32 len = 0;
3299     int retval;
3300     char *bufend;
3301 #if defined(DOSISH) && !defined(OS2)
3302 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3303 #  define MAX_EXT_LEN 4
3304 #endif
3305 #ifdef OS2
3306 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3307 #  define MAX_EXT_LEN 4
3308 #endif
3309 #ifdef VMS
3310 #  define SEARCH_EXTS ".pl", ".com", NULL
3311 #  define MAX_EXT_LEN 4
3312 #endif
3313     /* additional extensions to try in each dir if scriptname not found */
3314 #ifdef SEARCH_EXTS
3315     static const char *const exts[] = { SEARCH_EXTS };
3316     const char *const *const ext = search_ext ? search_ext : exts;
3317     int extidx = 0, i = 0;
3318     const char *curext = NULL;
3319 #else
3320     PERL_UNUSED_ARG(search_ext);
3321 #  define MAX_EXT_LEN 0
3322 #endif
3323
3324     PERL_ARGS_ASSERT_FIND_SCRIPT;
3325
3326     /*
3327      * If dosearch is true and if scriptname does not contain path
3328      * delimiters, search the PATH for scriptname.
3329      *
3330      * If SEARCH_EXTS is also defined, will look for each
3331      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3332      * while searching the PATH.
3333      *
3334      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3335      * proceeds as follows:
3336      *   If DOSISH or VMSISH:
3337      *     + look for ./scriptname{,.foo,.bar}
3338      *     + search the PATH for scriptname{,.foo,.bar}
3339      *
3340      *   If !DOSISH:
3341      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3342      *       this will not look in '.' if it's not in the PATH)
3343      */
3344     tmpbuf[0] = '\0';
3345
3346 #ifdef VMS
3347 #  ifdef ALWAYS_DEFTYPES
3348     len = strlen(scriptname);
3349     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3350         int idx = 0, deftypes = 1;
3351         bool seen_dot = 1;
3352
3353         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3354 #  else
3355     if (dosearch) {
3356         int idx = 0, deftypes = 1;
3357         bool seen_dot = 1;
3358
3359         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3360 #  endif
3361         /* The first time through, just add SEARCH_EXTS to whatever we
3362          * already have, so we can check for default file types. */
3363         while (deftypes ||
3364                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3365         {
3366             Stat_t statbuf;
3367             if (deftypes) {
3368                 deftypes = 0;
3369                 *tmpbuf = '\0';
3370             }
3371             if ((strlen(tmpbuf) + strlen(scriptname)
3372                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3373                 continue;       /* don't search dir with too-long name */
3374             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3375 #else  /* !VMS */
3376
3377 #ifdef DOSISH
3378     if (strEQ(scriptname, "-"))
3379         dosearch = 0;
3380     if (dosearch) {             /* Look in '.' first. */
3381         const char *cur = scriptname;
3382 #ifdef SEARCH_EXTS
3383         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3384             while (ext[i])
3385                 if (strEQ(ext[i++],curext)) {
3386                     extidx = -1;                /* already has an ext */
3387                     break;
3388                 }
3389         do {
3390 #endif
3391             DEBUG_p(PerlIO_printf(Perl_debug_log,
3392                                   "Looking for %s\n",cur));
3393             {
3394                 Stat_t statbuf;
3395                 if (PerlLIO_stat(cur,&statbuf) >= 0
3396                     && !S_ISDIR(statbuf.st_mode)) {
3397                     dosearch = 0;
3398                     scriptname = cur;
3399 #ifdef SEARCH_EXTS
3400                     break;
3401 #endif
3402                 }
3403             }
3404 #ifdef SEARCH_EXTS
3405             if (cur == scriptname) {
3406                 len = strlen(scriptname);
3407                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3408                     break;
3409                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3410                 cur = tmpbuf;
3411             }
3412         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3413                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3414 #endif
3415     }
3416 #endif
3417
3418     if (dosearch && !strchr(scriptname, '/')
3419 #ifdef DOSISH
3420                  && !strchr(scriptname, '\\')
3421 #endif
3422                  && (s = PerlEnv_getenv("PATH")))
3423     {
3424         bool seen_dot = 0;
3425
3426         bufend = s + strlen(s);
3427         while (s < bufend) {
3428             Stat_t statbuf;
3429 #  ifdef DOSISH
3430             for (len = 0; *s
3431                     && *s != ';'; len++, s++) {
3432                 if (len < sizeof tmpbuf)
3433                     tmpbuf[len] = *s;
3434             }
3435             if (len < sizeof tmpbuf)
3436                 tmpbuf[len] = '\0';
3437 #  else
3438             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3439                         ':',
3440                         &len);
3441 #  endif
3442             if (s < bufend)
3443                 s++;
3444             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3445                 continue;       /* don't search dir with too-long name */
3446             if (len
3447 #  ifdef DOSISH
3448                 && tmpbuf[len - 1] != '/'
3449                 && tmpbuf[len - 1] != '\\'
3450 #  endif
3451                )
3452                 tmpbuf[len++] = '/';
3453             if (len == 2 && tmpbuf[0] == '.')
3454                 seen_dot = 1;
3455             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3456 #endif  /* !VMS */
3457
3458 #ifdef SEARCH_EXTS
3459             len = strlen(tmpbuf);
3460             if (extidx > 0)     /* reset after previous loop */
3461                 extidx = 0;
3462             do {
3463 #endif
3464                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3465                 retval = PerlLIO_stat(tmpbuf,&statbuf);
3466                 if (S_ISDIR(statbuf.st_mode)) {
3467                     retval = -1;
3468                 }
3469 #ifdef SEARCH_EXTS
3470             } while (  retval < 0               /* not there */
3471                     && extidx>=0 && ext[extidx] /* try an extension? */
3472                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3473                 );
3474 #endif
3475             if (retval < 0)
3476                 continue;
3477             if (S_ISREG(statbuf.st_mode)
3478                 && cando(S_IRUSR,TRUE,&statbuf)
3479 #if !defined(DOSISH)
3480                 && cando(S_IXUSR,TRUE,&statbuf)
3481 #endif
3482                 )
3483             {
3484                 xfound = tmpbuf;                /* bingo! */
3485                 break;
3486             }
3487             if (!xfailed)
3488                 xfailed = savepv(tmpbuf);
3489         }
3490 #ifndef DOSISH
3491         {
3492             Stat_t statbuf;
3493             if (!xfound && !seen_dot && !xfailed &&
3494                 (PerlLIO_stat(scriptname,&statbuf) < 0
3495                  || S_ISDIR(statbuf.st_mode)))
3496 #endif
3497                 seen_dot = 1;                   /* Disable message. */
3498 #ifndef DOSISH
3499         }
3500 #endif
3501         if (!xfound) {
3502             if (flags & 1) {                    /* do or die? */
3503                 /* diag_listed_as: Can't execute %s */
3504                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3505                       (xfailed ? "execute" : "find"),
3506                       (xfailed ? xfailed : scriptname),
3507                       (xfailed ? "" : " on PATH"),
3508                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3509             }
3510             scriptname = NULL;
3511         }
3512         Safefree(xfailed);
3513         scriptname = xfound;
3514     }
3515     return (scriptname ? savepv(scriptname) : NULL);
3516 }
3517
3518 #ifndef PERL_GET_CONTEXT_DEFINED
3519
3520 void *
3521 Perl_get_context(void)
3522 {
3523 #if defined(USE_ITHREADS)
3524     dVAR;
3525 #  ifdef OLD_PTHREADS_API
3526     pthread_addr_t t;
3527     int error = pthread_getspecific(PL_thr_key, &t)
3528     if (error)
3529         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3530     return (void*)t;
3531 #  else
3532 #    ifdef I_MACH_CTHREADS
3533     return (void*)cthread_data(cthread_self());
3534 #    else
3535     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3536 #    endif
3537 #  endif
3538 #else
3539     return (void*)NULL;
3540 #endif
3541 }
3542
3543 void
3544 Perl_set_context(void *t)
3545 {
3546 #if defined(USE_ITHREADS)
3547     dVAR;
3548 #endif
3549     PERL_ARGS_ASSERT_SET_CONTEXT;
3550 #if defined(USE_ITHREADS)
3551 #  ifdef I_MACH_CTHREADS
3552     cthread_set_data(cthread_self(), t);
3553 #  else
3554     {
3555         const int error = pthread_setspecific(PL_thr_key, t);
3556         if (error)
3557             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3558     }
3559 #  endif
3560 #else
3561     PERL_UNUSED_ARG(t);
3562 #endif
3563 }
3564
3565 #endif /* !PERL_GET_CONTEXT_DEFINED */
3566
3567 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3568 struct perl_vars *
3569 Perl_GetVars(pTHX)
3570 {
3571     PERL_UNUSED_CONTEXT;
3572     return &PL_Vars;
3573 }
3574 #endif
3575
3576 char **
3577 Perl_get_op_names(pTHX)
3578 {
3579     PERL_UNUSED_CONTEXT;
3580     return (char **)PL_op_name;
3581 }
3582
3583 char **
3584 Perl_get_op_descs(pTHX)
3585 {
3586     PERL_UNUSED_CONTEXT;
3587     return (char **)PL_op_desc;
3588 }
3589
3590 const char *
3591 Perl_get_no_modify(pTHX)
3592 {
3593     PERL_UNUSED_CONTEXT;
3594     return PL_no_modify;
3595 }
3596
3597 U32 *
3598 Perl_get_opargs(pTHX)
3599 {
3600     PERL_UNUSED_CONTEXT;
3601     return (U32 *)PL_opargs;
3602 }
3603
3604 PPADDR_t*
3605 Perl_get_ppaddr(pTHX)
3606 {
3607     dVAR;
3608     PERL_UNUSED_CONTEXT;
3609     return (PPADDR_t*)PL_ppaddr;
3610 }
3611
3612 #ifndef HAS_GETENV_LEN
3613 char *
3614 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3615 {
3616     char * const env_trans = PerlEnv_getenv(env_elem);
3617     PERL_UNUSED_CONTEXT;
3618     PERL_ARGS_ASSERT_GETENV_LEN;
3619     if (env_trans)
3620         *len = strlen(env_trans);
3621     return env_trans;
3622 }
3623 #endif
3624
3625
3626 MGVTBL*
3627 Perl_get_vtbl(pTHX_ int vtbl_id)
3628 {
3629     PERL_UNUSED_CONTEXT;
3630
3631     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3632         ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
3633 }
3634
3635 I32
3636 Perl_my_fflush_all(pTHX)
3637 {
3638 #if defined(USE_PERLIO) || defined(FFLUSH_NULL)
3639     return PerlIO_flush(NULL);
3640 #else
3641 # if defined(HAS__FWALK)
3642     extern int fflush(FILE *);
3643     /* undocumented, unprototyped, but very useful BSDism */
3644     extern void _fwalk(int (*)(FILE *));
3645     _fwalk(&fflush);
3646     return 0;
3647 # else
3648 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3649     long open_max = -1;
3650 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3651     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3652 #   else
3653 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3654     open_max = sysconf(_SC_OPEN_MAX);
3655 #     else
3656 #      ifdef FOPEN_MAX
3657     open_max = FOPEN_MAX;
3658 #      else
3659 #       ifdef OPEN_MAX
3660     open_max = OPEN_MAX;
3661 #       else
3662 #        ifdef _NFILE
3663     open_max = _NFILE;
3664 #        endif
3665 #       endif
3666 #      endif
3667 #     endif
3668 #    endif
3669     if (open_max > 0) {
3670       long i;
3671       for (i = 0; i < open_max; i++)
3672             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3673                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3674                 STDIO_STREAM_ARRAY[i]._flag)
3675                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3676       return 0;
3677     }
3678 #  endif
3679     SETERRNO(EBADF,RMS_IFI);
3680     return EOF;
3681 # endif
3682 #endif
3683 }
3684
3685 void
3686 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3687 {
3688     if (ckWARN(WARN_IO)) {
3689         HEK * const name
3690            = gv && (isGV_with_GP(gv))
3691                 ? GvENAME_HEK((gv))
3692                 : NULL;
3693         const char * const direction = have == '>' ? "out" : "in";
3694
3695         if (name && HEK_LEN(name))
3696             Perl_warner(aTHX_ packWARN(WARN_IO),
3697                         "Filehandle %" HEKf " opened only for %sput",
3698                         HEKfARG(name), direction);
3699         else
3700             Perl_warner(aTHX_ packWARN(WARN_IO),
3701                         "Filehandle opened only for %sput", direction);
3702     }
3703 }
3704
3705 void
3706 Perl_report_evil_fh(pTHX_ const GV *gv)
3707 {
3708     const IO *io = gv ? GvIO(gv) : NULL;
3709     const PERL_BITFIELD16 op = PL_op->op_type;
3710     const char *vile;
3711     I32 warn_type;
3712
3713     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3714         vile = "closed";
3715         warn_type = WARN_CLOSED;
3716     }
3717     else {
3718         vile = "unopened";
3719         warn_type = WARN_UNOPENED;
3720     }
3721
3722     if (ckWARN(warn_type)) {
3723         SV * const name
3724             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3725                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3726         const char * const pars =
3727             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3728         const char * const func =
3729             (const char *)
3730             (op == OP_READLINE || op == OP_RCATLINE
3731                                  ? "readline"  :        /* "<HANDLE>" not nice */
3732              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3733              PL_op_desc[op]);
3734         const char * const type =
3735             (const char *)
3736             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3737              ? "socket" : "filehandle");
3738         const bool have_name = name && SvCUR(name);
3739         Perl_warner(aTHX_ packWARN(warn_type),
3740                    "%s%s on %s %s%s%" SVf, func, pars, vile, type,
3741                     have_name ? " " : "",
3742                     SVfARG(have_name ? name : &PL_sv_no));
3743         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3744                 Perl_warner(
3745                             aTHX_ packWARN(warn_type),
3746                         "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
3747                         func, pars, have_name ? " " : "",
3748                         SVfARG(have_name ? name : &PL_sv_no)
3749                             );
3750     }
3751 }
3752
3753 /* To workaround core dumps from the uninitialised tm_zone we get the
3754  * system to give us a reasonable struct to copy.  This fix means that
3755  * strftime uses the tm_zone and tm_gmtoff values returned by
3756  * localtime(time()). That should give the desired result most of the
3757  * time. But probably not always!
3758  *
3759  * This does not address tzname aspects of NETaa14816.
3760  *
3761  */
3762
3763 #ifdef __GLIBC__
3764 # ifndef STRUCT_TM_HASZONE
3765 #    define STRUCT_TM_HASZONE
3766 # endif
3767 #endif
3768
3769 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3770 # ifndef HAS_TM_TM_ZONE
3771 #    define HAS_TM_TM_ZONE
3772 # endif
3773 #endif
3774
3775 void
3776 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3777 {
3778 #ifdef HAS_TM_TM_ZONE
3779     Time_t now;
3780     const struct tm* my_tm;
3781     PERL_UNUSED_CONTEXT;
3782     PERL_ARGS_ASSERT_INIT_TM;
3783     (void)time(&now);
3784     my_tm = localtime(&now);
3785     if (my_tm)
3786         Copy(my_tm, ptm, 1, struct tm);
3787 #else
3788     PERL_UNUSED_CONTEXT;
3789     PERL_ARGS_ASSERT_INIT_TM;
3790     PERL_UNUSED_ARG(ptm);
3791 #endif
3792 }
3793
3794 /*
3795  * mini_mktime - normalise struct tm values without the localtime()
3796  * semantics (and overhead) of mktime().
3797  */
3798 void
3799 Perl_mini_mktime(struct tm *ptm)
3800 {
3801     int yearday;
3802     int secs;
3803     int month, mday, year, jday;
3804     int odd_cent, odd_year;
3805
3806     PERL_ARGS_ASSERT_MINI_MKTIME;
3807
3808 #define DAYS_PER_YEAR   365
3809 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3810 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3811 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3812 #define SECS_PER_HOUR   (60*60)
3813 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3814 /* parentheses deliberately absent on these two, otherwise they don't work */
3815 #define MONTH_TO_DAYS   153/5
3816 #define DAYS_TO_MONTH   5/153
3817 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3818 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3819 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3820 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3821
3822 /*
3823  * Year/day algorithm notes:
3824  *
3825  * With a suitable offset for numeric value of the month, one can find
3826  * an offset into the year by considering months to have 30.6 (153/5) days,
3827  * using integer arithmetic (i.e., with truncation).  To avoid too much
3828  * messing about with leap days, we consider January and February to be
3829  * the 13th and 14th month of the previous year.  After that transformation,
3830  * we need the month index we use to be high by 1 from 'normal human' usage,
3831  * so the month index values we use run from 4 through 15.
3832  *
3833  * Given that, and the rules for the Gregorian calendar (leap years are those
3834  * divisible by 4 unless also divisible by 100, when they must be divisible
3835  * by 400 instead), we can simply calculate the number of days since some
3836  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3837  * the days we derive from our month index, and adding in the day of the
3838  * month.  The value used here is not adjusted for the actual origin which
3839  * it normally would use (1 January A.D. 1), since we're not exposing it.
3840  * We're only building the value so we can turn around and get the
3841  * normalised values for the year, month, day-of-month, and day-of-year.
3842  *
3843  * For going backward, we need to bias the value we're using so that we find
3844  * the right year value.  (Basically, we don't want the contribution of
3845  * March 1st to the number to apply while deriving the year).  Having done
3846  * that, we 'count up' the contribution to the year number by accounting for
3847  * full quadracenturies (400-year periods) with their extra leap days, plus
3848  * the contribution from full centuries (to avoid counting in the lost leap
3849  * days), plus the contribution from full quad-years (to count in the normal
3850  * leap days), plus the leftover contribution from any non-leap years.
3851  * At this point, if we were working with an actual leap day, we'll have 0
3852  * days left over.  This is also true for March 1st, however.  So, we have
3853  * to special-case that result, and (earlier) keep track of the 'odd'
3854  * century and year contributions.  If we got 4 extra centuries in a qcent,
3855  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3856  * Otherwise, we add back in the earlier bias we removed (the 123 from
3857  * figuring in March 1st), find the month index (integer division by 30.6),
3858  * and the remainder is the day-of-month.  We then have to convert back to
3859  * 'real' months (including fixing January and February from being 14/15 in
3860  * the previous year to being in the proper year).  After that, to get
3861  * tm_yday, we work with the normalised year and get a new yearday value for
3862  * January 1st, which we subtract from the yearday value we had earlier,
3863  * representing the date we've re-built.  This is done from January 1
3864  * because tm_yday is 0-origin.
3865  *
3866  * Since POSIX time routines are only guaranteed to work for times since the
3867  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3868  * applies Gregorian calendar rules even to dates before the 16th century
3869  * doesn't bother me.  Besides, you'd need cultural context for a given
3870  * date to know whether it was Julian or Gregorian calendar, and that's
3871  * outside the scope for this routine.  Since we convert back based on the
3872  * same rules we used to build the yearday, you'll only get strange results
3873  * for input which needed normalising, or for the 'odd' century years which
3874  * were leap years in the Julian calendar but not in the Gregorian one.
3875  * I can live with that.
3876  *
3877  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3878  * that's still outside the scope for POSIX time manipulation, so I don't
3879  * care.
3880  */
3881
3882     year = 1900 + ptm->tm_year;
3883     month = ptm->tm_mon;
3884     mday = ptm->tm_mday;
3885     jday = 0;
3886     if (month >= 2)
3887         month+=2;
3888     else
3889         month+=14, year--;
3890     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3891     yearday += month*MONTH_TO_DAYS + mday + jday;
3892     /*
3893      * Note that we don't know when leap-seconds were or will be,
3894      * so we have to trust the user if we get something which looks
3895      * like a sensible leap-second.  Wild values for seconds will
3896      * be rationalised, however.
3897      */
3898     if ((unsigned) ptm->tm_sec <= 60) {
3899         secs = 0;
3900     }
3901     else {
3902         secs = ptm->tm_sec;
3903         ptm->tm_sec = 0;
3904     }
3905     secs += 60 * ptm->tm_min;
3906     secs += SECS_PER_HOUR * ptm->tm_hour;
3907     if (secs < 0) {
3908         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3909             /* got negative remainder, but need positive time */
3910             /* back off an extra day to compensate */
3911             yearday += (secs/SECS_PER_DAY)-1;
3912             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3913         }
3914         else {
3915             yearday += (secs/SECS_PER_DAY);
3916             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3917         }
3918     }
3919     else if (secs >= SECS_PER_DAY) {
3920         yearday += (secs/SECS_PER_DAY);
3921         secs %= SECS_PER_DAY;
3922     }
3923     ptm->tm_hour = secs/SECS_PER_HOUR;
3924     secs %= SECS_PER_HOUR;
3925     ptm->tm_min = secs/60;
3926     secs %= 60;
3927     ptm->tm_sec += secs;
3928     /* done with time of day effects */
3929     /*
3930      * The algorithm for yearday has (so far) left it high by 428.
3931      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3932      * bias it by 123 while trying to figure out what year it
3933      * really represents.  Even with this tweak, the reverse
3934      * translation fails for years before A.D. 0001.
3935      * It would still fail for Feb 29, but we catch that one below.
3936      */
3937     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3938     yearday -= YEAR_ADJUST;
3939     year = (yearday / DAYS_PER_QCENT) * 400;
3940     yearday %= DAYS_PER_QCENT;
3941     odd_cent = yearday / DAYS_PER_CENT;
3942     year += odd_cent * 100;
3943     yearday %= DAYS_PER_CENT;
3944     year += (yearday / DAYS_PER_QYEAR) * 4;
3945     yearday %= DAYS_PER_QYEAR;
3946     odd_year = yearday / DAYS_PER_YEAR;
3947     year += odd_year;
3948     yearday %= DAYS_PER_YEAR;
3949     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3950         month = 1;
3951         yearday = 29;
3952     }
3953     else {
3954         yearday += YEAR_ADJUST; /* recover March 1st crock */
3955         month = yearday*DAYS_TO_MONTH;
3956         yearday -= month*MONTH_TO_DAYS;
3957         /* recover other leap-year adjustment */
3958         if (month > 13) {
3959             month-=14;
3960             year++;
3961         }
3962         else {
3963             month-=2;
3964         }
3965     }
3966     ptm->tm_year = year - 1900;
3967     if (yearday) {
3968       ptm->tm_mday = yearday;
3969       ptm->tm_mon = month;
3970     }
3971     else {
3972       ptm->tm_mday = 31;
3973       ptm->tm_mon = month - 1;
3974     }
3975     /* re-build yearday based on Jan 1 to get tm_yday */
3976     year--;
3977     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3978     yearday += 14*MONTH_TO_DAYS + 1;
3979     ptm->tm_yday = jday - yearday;
3980     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3981 }
3982
3983 char *
3984 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)
3985 {
3986 #ifdef HAS_STRFTIME
3987
3988   /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */
3989
3990   char *buf;
3991   int buflen;
3992   struct tm mytm;
3993   int len;
3994
3995   PERL_ARGS_ASSERT_MY_STRFTIME;
3996
3997   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3998   mytm.tm_sec = sec;
3999   mytm.tm_min = min;
4000   mytm.tm_hour = hour;
4001   mytm.tm_mday = mday;
4002   mytm.tm_mon = mon;
4003   mytm.tm_year = year;
4004   mytm.tm_wday = wday;
4005   mytm.tm_yday = yday;
4006   mytm.tm_isdst = isdst;
4007   mini_mktime(&mytm);
4008   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4009 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4010   STMT_START {
4011     struct tm mytm2;
4012     mytm2 = mytm;
4013     mktime(&mytm2);
4014 #ifdef HAS_TM_TM_GMTOFF
4015     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4016 #endif
4017 #ifdef HAS_TM_TM_ZONE
4018     mytm.tm_zone = mytm2.tm_zone;
4019 #endif
4020   } STMT_END;
4021 #endif
4022   buflen = 64;
4023   Newx(buf, buflen, char);
4024
4025   GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4026   len = strftime(buf, buflen, fmt, &mytm);
4027   GCC_DIAG_RESTORE;
4028
4029   /*
4030   ** The following is needed to handle to the situation where
4031   ** tmpbuf overflows.  Basically we want to allocate a buffer
4032   ** and try repeatedly.  The reason why it is so complicated
4033   ** is that getting a return value of 0 from strftime can indicate
4034   ** one of the following:
4035   ** 1. buffer overflowed,
4036   ** 2. illegal conversion specifier, or
4037   ** 3. the format string specifies nothing to be returned(not
4038   **      an error).  This could be because format is an empty string
4039   **    or it specifies %p that yields an empty string in some locale.
4040   ** If there is a better way to make it portable, go ahead by
4041   ** all means.
4042   */
4043   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4044     return buf;
4045   else {
4046     /* Possibly buf overflowed - try again with a bigger buf */
4047     const int fmtlen = strlen(fmt);
4048     int bufsize = fmtlen + buflen;
4049
4050     Renew(buf, bufsize, char);
4051     while (buf) {
4052
4053       GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
4054       buflen = strftime(buf, bufsize, fmt, &mytm);
4055       GCC_DIAG_RESTORE;
4056
4057       if (buflen > 0 && buflen < bufsize)
4058         break;
4059       /* heuristic to prevent out-of-memory errors */
4060       if (bufsize > 100*fmtlen) {
4061         Safefree(buf);
4062         buf = NULL;
4063         break;
4064       }
4065       bufsize *= 2;
4066       Renew(buf, bufsize, char);
4067     }
4068     return buf;
4069   }
4070 #else
4071   Perl_croak(aTHX_ "panic: no strftime");
4072   return NULL;
4073 #endif
4074 }
4075
4076
4077 #define SV_CWD_RETURN_UNDEF \
4078     sv_set_undef(sv); \
4079     return FALSE
4080
4081 #define SV_CWD_ISDOT(dp) \
4082     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4083         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4084
4085 /*
4086 =head1 Miscellaneous Functions
4087
4088 =for apidoc getcwd_sv
4089
4090 Fill C<sv> with current working directory
4091
4092 =cut
4093 */
4094
4095 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4096  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4097  * getcwd(3) if available
4098  * Comments from the original:
4099  *     This is a faster version of getcwd.  It's also more dangerous
4100  *     because you might chdir out of a directory that you can't chdir
4101  *     back into. */
4102
4103 int
4104 Perl_getcwd_sv(pTHX_ SV *sv)
4105 {
4106 #ifndef PERL_MICRO
4107     SvTAINTED_on(sv);
4108
4109     PERL_ARGS_ASSERT_GETCWD_SV;
4110
4111 #ifdef HAS_GETCWD
4112     {
4113         char buf[MAXPATHLEN];
4114
4115         /* Some getcwd()s automatically allocate a buffer of the given
4116          * size from the heap if they are given a NULL buffer pointer.
4117          * The problem is that this behaviour is not portable. */
4118         if (getcwd(buf, sizeof(buf) - 1)) {
4119             sv_setpv(sv, buf);
4120             return TRUE;
4121         }
4122         else {
4123             SV_CWD_RETURN_UNDEF;
4124         }
4125     }
4126
4127 #else
4128
4129     Stat_t statbuf;
4130     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4131     int pathlen=0;
4132     Direntry_t *dp;
4133
4134     SvUPGRADE(sv, SVt_PV);
4135
4136     if (PerlLIO_lstat(".", &statbuf) < 0) {
4137         SV_CWD_RETURN_UNDEF;
4138     }
4139
4140     orig_cdev = statbuf.st_dev;
4141     orig_cino = statbuf.st_ino;
4142     cdev = orig_cdev;
4143     cino = orig_cino;
4144
4145     for (;;) {
4146         DIR *dir;
4147         int namelen;
4148         odev = cdev;
4149         oino = cino;
4150
4151         if (PerlDir_chdir("..") < 0) {
4152             SV_CWD_RETURN_UNDEF;
4153         }
4154         if (PerlLIO_stat(".", &statbuf) < 0) {
4155             SV_CWD_RETURN_UNDEF;
4156         }
4157
4158         cdev = statbuf.st_dev;
4159         cino = statbuf.st_ino;
4160
4161         if (odev == cdev && oino == cino) {
4162             break;
4163         }
4164         if (!(dir = PerlDir_open("."))) {
4165             SV_CWD_RETURN_UNDEF;
4166         }
4167
4168         while ((dp = PerlDir_read(dir)) != NULL) {
4169 #ifdef DIRNAMLEN
4170             namelen = dp->d_namlen;
4171 #else
4172             namelen = strlen(dp->d_name);
4173 #endif
4174             /* skip . and .. */
4175             if (SV_CWD_ISDOT(dp)) {
4176                 continue;
4177             }
4178
4179             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4180                 SV_CWD_RETURN_UNDEF;
4181             }
4182
4183             tdev = statbuf.st_dev;
4184             tino = statbuf.st_ino;
4185             if (tino == oino && tdev == odev) {
4186                 break;
4187             }
4188         }
4189
4190         if (!dp) {
4191             SV_CWD_RETURN_UNDEF;
4192         }
4193
4194         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4195             SV_CWD_RETURN_UNDEF;
4196         }
4197
4198         SvGROW(sv, pathlen + namelen + 1);
4199
4200         if (pathlen) {
4201             /* shift down */
4202             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4203         }
4204
4205         /* prepend current directory to the front */
4206         *SvPVX(sv) = '/';
4207         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4208         pathlen += (namelen + 1);
4209
4210 #ifdef VOID_CLOSEDIR
4211         PerlDir_close(dir);
4212 #else
4213         if (PerlDir_close(dir) < 0) {
4214             SV_CWD_RETURN_UNDEF;
4215         }
4216 #endif
4217     }
4218
4219     if (pathlen) {
4220         SvCUR_set(sv, pathlen);
4221         *SvEND(sv) = '\0';
4222         SvPOK_only(sv);
4223
4224         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4225             SV_CWD_RETURN_UNDEF;
4226         }
4227     }
4228     if (PerlLIO_stat(".", &statbuf) < 0) {
4229         SV_CWD_RETURN_UNDEF;
4230     }
4231
4232     cdev = statbuf.st_dev;
4233     cino = statbuf.st_ino;
4234
4235     if (cdev != orig_cdev || cino != orig_cino) {
4236         Perl_croak(aTHX_ "Unstable directory path, "
4237                    "current directory changed unexpectedly");
4238     }
4239
4240     return TRUE;
4241 #endif
4242
4243 #else
4244     return FALSE;
4245 #endif
4246 }
4247
4248 #include "vutil.c"
4249
4250 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4251 #   define EMULATE_SOCKETPAIR_UDP
4252 #endif
4253
4254 #ifdef EMULATE_SOCKETPAIR_UDP
4255 static int
4256 S_socketpair_udp (int fd[2]) {
4257     dTHX;
4258     /* Fake a datagram socketpair using UDP to localhost.  */
4259     int sockets[2] = {-1, -1};
4260     struct sockaddr_in addresses[2];
4261     int i;
4262     Sock_size_t size = sizeof(struct sockaddr_in);
4263     unsigned short port;
4264     int got;
4265
4266     memset(&addresses, 0, sizeof(addresses));
4267     i = 1;
4268     do {
4269         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4270         if (sockets[i] == -1)
4271             goto tidy_up_and_fail;
4272
4273         addresses[i].sin_family = AF_INET;
4274         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4275         addresses[i].sin_port = 0;      /* kernel choses port.  */
4276         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4277                 sizeof(struct sockaddr_in)) == -1)
4278             goto tidy_up_and_fail;
4279     } while (i--);
4280
4281     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4282        for each connect the other socket to it.  */
4283     i = 1;
4284     do {
4285         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4286                 &size) == -1)
4287             goto tidy_up_and_fail;
4288         if (size != sizeof(struct sockaddr_in))
4289             goto abort_tidy_up_and_fail;
4290         /* !1 is 0, !0 is 1 */
4291         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4292                 sizeof(struct sockaddr_in)) == -1)
4293             goto tidy_up_and_fail;
4294     } while (i--);
4295
4296     /* Now we have 2 sockets connected to each other. I don't trust some other
4297        process not to have already sent a packet to us (by random) so send
4298        a packet from each to the other.  */
4299     i = 1;
4300     do {
4301         /* I'm going to send my own port number.  As a short.
4302            (Who knows if someone somewhere has sin_port as a bitfield and needs
4303            this routine. (I'm assuming crays have socketpair)) */
4304         port = addresses[i].sin_port;
4305         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4306         if (got != sizeof(port)) {
4307             if (got == -1)
4308                 goto tidy_up_and_fail;
4309             goto abort_tidy_up_and_fail;
4310         }
4311     } while (i--);
4312
4313     /* Packets sent. I don't trust them to have arrived though.
4314        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4315        connect to localhost will use a second kernel thread. In 2.6 the
4316        first thread running the connect() returns before the second completes,
4317        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4318        returns 0. Poor programs have tripped up. One poor program's authors'
4319        had a 50-1 reverse stock split. Not sure how connected these were.)
4320        So I don't trust someone not to have an unpredictable UDP stack.
4321     */
4322
4323     {
4324         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4325         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4326         fd_set rset;
4327
4328         FD_ZERO(&rset);
4329         FD_SET((unsigned int)sockets[0], &rset);
4330         FD_SET((unsigned int)sockets[1], &rset);
4331
4332         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4333         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4334                 || !FD_ISSET(sockets[1], &rset)) {
4335             /* I hope this is portable and appropriate.  */
4336             if (got == -1)
4337                 goto tidy_up_and_fail;
4338             goto abort_tidy_up_and_fail;
4339         }
4340     }
4341
4342     /* And the paranoia department even now doesn't trust it to have arrive
4343        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4344     {
4345         struct sockaddr_in readfrom;
4346         unsigned short buffer[2];
4347
4348         i = 1;
4349         do {
4350 #ifdef MSG_DONTWAIT
4351             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4352                     sizeof(buffer), MSG_DONTWAIT,
4353                     (struct sockaddr *) &readfrom, &size);
4354 #else
4355             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4356                     sizeof(buffer), 0,
4357                     (struct sockaddr *) &readfrom, &size);
4358 #endif
4359
4360             if (got == -1)
4361                 goto tidy_up_and_fail;
4362             if (got != sizeof(port)
4363                     || size != sizeof(struct sockaddr_in)
4364                     /* Check other socket sent us its port.  */
4365                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4366                     /* Check kernel says we got the datagram from that socket */
4367                     || readfrom.sin_family != addresses[!i].sin_family
4368                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4369                     || readfrom.sin_port != addresses[!i].sin_port)
4370                 goto abort_tidy_up_and_fail;
4371         } while (i--);
4372     }
4373     /* My caller (my_socketpair) has validated that this is non-NULL  */
4374     fd[0] = sockets[0];
4375     fd[1] = sockets[1];
4376     /* I hereby declare this connection open.  May God bless all who cross
4377        her.  */
4378     return 0;
4379
4380   abort_tidy_up_and_fail:
4381     errno = ECONNABORTED;
4382   tidy_up_and_fail:
4383     {
4384         dSAVE_ERRNO;
4385         if (sockets[0] != -1)
4386             PerlLIO_close(sockets[0]);
4387         if (sockets[1] != -1)
4388             PerlLIO_close(sockets[1]);
4389         RESTORE_ERRNO;
4390         return -1;
4391     }
4392 }
4393 #endif /*  EMULATE_SOCKETPAIR_UDP */
4394
4395 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4396 int
4397 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4398     /* Stevens says that family must be AF_LOCAL, protocol 0.
4399        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4400     dTHXa(NULL);
4401     int listener = -1;
4402     int connector = -1;
4403     int acceptor = -1;
4404     struct sockaddr_in listen_addr;
4405     struct sockaddr_in connect_addr;
4406     Sock_size_t size;
4407
4408     if (protocol
4409 #ifdef AF_UNIX
4410         || family != AF_UNIX
4411 #endif
4412     ) {
4413         errno = EAFNOSUPPORT;
4414         return -1;
4415     }
4416     if (!fd) {
4417         errno = EINVAL;
4418         return -1;
4419     }
4420
4421 #ifdef EMULATE_SOCKETPAIR_UDP
4422     if (type == SOCK_DGRAM)
4423         return S_socketpair_udp(fd);
4424 #endif
4425
4426     aTHXa(PERL_GET_THX);
4427     listener = PerlSock_socket(AF_INET, type, 0);
4428     if (listener == -1)
4429         return -1;
4430     memset(&listen_addr, 0, sizeof(listen_addr));
4431     listen_addr.sin_family = AF_INET;
4432     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4433     listen_addr.sin_port = 0;   /* kernel choses port.  */
4434     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4435             sizeof(listen_addr)) == -1)
4436         goto tidy_up_and_fail;
4437     if (PerlSock_listen(listener, 1) == -1)
4438         goto tidy_up_and_fail;
4439
4440     connector = PerlSock_socket(AF_INET, type, 0);
4441     if (connector == -1)
4442         goto tidy_up_and_fail;
4443     /* We want to find out the port number to connect to.  */
4444     size = sizeof(connect_addr);
4445     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4446             &size) == -1)
4447         goto tidy_up_and_fail;
4448     if (size != sizeof(connect_addr))
4449         goto abort_tidy_up_and_fail;
4450     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4451             sizeof(connect_addr)) == -1)
4452         goto tidy_up_and_fail;
4453
4454     size = sizeof(listen_addr);
4455     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4456             &size);
4457     if (acceptor == -1)
4458         goto tidy_up_and_fail;
4459     if (size != sizeof(listen_addr))
4460         goto abort_tidy_up_and_fail;
4461     PerlLIO_close(listener);
4462     /* Now check we are talking to ourself by matching port and host on the
4463        two sockets.  */
4464     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4465             &size) == -1)
4466         goto tidy_up_and_fail;
4467     if (size != sizeof(connect_addr)
4468             || listen_addr.sin_family != connect_addr.sin_family
4469             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4470             || listen_addr.sin_port != connect_addr.sin_port) {
4471         goto abort_tidy_up_and_fail;
4472     }
4473     fd[0] = connector;
4474     fd[1] = acceptor;
4475     return 0;
4476
4477   abort_tidy_up_and_fail:
4478 #ifdef ECONNABORTED
4479   errno = ECONNABORTED; /* This would be the standard thing to do. */
4480 #else
4481 #  ifdef ECONNREFUSED
4482   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4483 #  else
4484   errno = ETIMEDOUT;    /* Desperation time. */
4485 #  endif
4486 #endif
4487   tidy_up_and_fail:
4488     {
4489         dSAVE_ERRNO;
4490         if (listener != -1)
4491             PerlLIO_close(listener);
4492         if (connector != -1)
4493             PerlLIO_close(connector);
4494         if (acceptor != -1)
4495             PerlLIO_close(acceptor);
4496         RESTORE_ERRNO;
4497         return -1;
4498     }
4499 }
4500 #else
4501 /* In any case have a stub so that there's code corresponding
4502  * to the my_socketpair in embed.fnc. */
4503 int
4504 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4505 #ifdef HAS_SOCKETPAIR
4506     return socketpair(family, type, protocol, fd);
4507 #else
4508     return -1;
4509 #endif
4510 }
4511 #endif
4512
4513 /*
4514
4515 =for apidoc sv_nosharing
4516
4517 Dummy routine which "shares" an SV when there is no sharing module present.
4518 Or "locks" it.  Or "unlocks" it.  In other
4519 words, ignores its single SV argument.
4520 Exists to avoid test for a C<NULL> function pointer and because it could
4521 potentially warn under some level of strict-ness.
4522
4523 =cut
4524 */
4525
4526 void
4527 Perl_sv_nosharing(pTHX_ SV *sv)
4528 {
4529     PERL_UNUSED_CONTEXT;
4530     PERL_UNUSED_ARG(sv);
4531 }
4532
4533 /*
4534
4535 =for apidoc sv_destroyable
4536
4537 Dummy routine which reports that object can be destroyed when there is no
4538 sharing module present.  It ignores its single SV argument, and returns
4539 'true'.  Exists to avoid test for a C<NULL> function pointer and because it
4540 could potentially warn under some level of strict-ness.
4541
4542 =cut
4543 */
4544
4545 bool
4546 Perl_sv_destroyable(pTHX_ SV *sv)
4547 {
4548     PERL_UNUSED_CONTEXT;
4549     PERL_UNUSED_ARG(sv);
4550     return TRUE;
4551 }
4552
4553 U32
4554 Perl_parse_unicode_opts(pTHX_ const char **popt)
4555 {
4556   const char *p = *popt;
4557   U32 opt = 0;
4558
4559   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
4560
4561   if (*p) {
4562        if (isDIGIT(*p)) {
4563             const char* endptr;
4564             UV uv;
4565             if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
4566                 opt = (U32)uv;
4567                 p = endptr;
4568                 if (p && *p && *p != '\n' && *p != '\r') {
4569                     if (isSPACE(*p))
4570                         goto the_end_of_the_opts_parser;
4571                     else
4572                         Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4573                 }
4574             }
4575             else {
4576                 Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
4577             }
4578         }
4579         else {
4580             for (; *p; p++) {
4581                  switch (*p) {
4582                  case PERL_UNICODE_STDIN:
4583                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4584                  case PERL_UNICODE_STDOUT:
4585                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4586                  case PERL_UNICODE_STDERR:
4587                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4588                  case PERL_UNICODE_STD:
4589                       opt |= PERL_UNICODE_STD_FLAG;     break;
4590                  case PERL_UNICODE_IN:
4591                       opt |= PERL_UNICODE_IN_FLAG;      break;
4592                  case PERL_UNICODE_OUT:
4593                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4594                  case PERL_UNICODE_INOUT:
4595                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4596                  case PERL_UNICODE_LOCALE:
4597                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4598                  case PERL_UNICODE_ARGV:
4599                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4600                  case PERL_UNICODE_UTF8CACHEASSERT:
4601                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4602                  default:
4603                       if (*p != '\n' && *p != '\r') {
4604                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
4605                         else
4606                           Perl_croak(aTHX_
4607                                      "Unknown Unicode option letter '%c'", *p);
4608                       }
4609                  }
4610             }
4611        }
4612   }
4613   else
4614        opt = PERL_UNICODE_DEFAULT_FLAGS;
4615
4616   the_end_of_the_opts_parser:
4617
4618   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4619        Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
4620                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4621
4622   *popt = p;
4623
4624   return opt;
4625 }
4626
4627 #ifdef VMS
4628 #  include <starlet.h>
4629 #endif
4630
4631 U32
4632 Perl_seed(pTHX)
4633 {
4634     /*
4635      * This is really just a quick hack which grabs various garbage
4636      * values.  It really should be a real hash algorithm which
4637      * spreads the effect of every input bit onto every output bit,
4638      * if someone who knows about such things would bother to write it.
4639      * Might be a good idea to add that function to CORE as well.
4640      * No numbers below come from careful analysis or anything here,
4641      * except they are primes and SEED_C1 > 1E6 to get a full-width
4642      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4643      * probably be bigger too.
4644      */
4645 #if RANDBITS > 16
4646 #  define SEED_C1       1000003
4647 #define   SEED_C4       73819
4648 #else
4649 #  define SEED_C1       25747
4650 #define   SEED_C4       20639
4651 #endif
4652 #define   SEED_C2       3
4653 #define   SEED_C3       269
4654 #define   SEED_C5       26107
4655
4656 #ifndef PERL_NO_DEV_RANDOM
4657     int fd;
4658 #endif
4659     U32 u;
4660 #ifdef HAS_GETTIMEOFDAY
4661     struct timeval when;
4662 #else
4663     Time_t when;
4664 #endif
4665
4666 /* This test is an escape hatch, this symbol isn't set by Configure. */
4667 #ifndef PERL_NO_DEV_RANDOM
4668 #ifndef PERL_RANDOM_DEVICE
4669    /* /dev/random isn't used by default because reads from it will block
4670     * if there isn't enough entropy available.  You can compile with
4671     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4672     * is enough real entropy to fill the seed. */
4673 #  ifdef __amigaos4__
4674 #    define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
4675 #  else
4676 #    define PERL_RANDOM_DEVICE "/dev/urandom"
4677 #  endif
4678 #endif
4679     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4680     if (fd != -1) {
4681         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
4682             u = 0;
4683         PerlLIO_close(fd);
4684         if (u)
4685             return u;
4686     }
4687 #endif
4688
4689 #ifdef HAS_GETTIMEOFDAY
4690     PerlProc_gettimeofday(&when,NULL);
4691     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4692 #else
4693     (void)time(&when);
4694     u = (U32)SEED_C1 * when;
4695 #endif
4696     u += SEED_C3 * (U32)PerlProc_getpid();
4697     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4698 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
4699     u += SEED_C5 * (U32)PTR2UV(&when);
4700 #endif
4701     return u;
4702 }
4703
4704 void
4705 Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
4706 {
4707 #ifndef NO_PERL_HASH_ENV
4708     const char *env_pv;
4709 #endif
4710     unsigned long i;
4711
4712     PERL_ARGS_ASSERT_GET_HASH_SEED;
4713
4714 #ifndef NO_PERL_HASH_ENV
4715     env_pv= PerlEnv_getenv("PERL_HASH_SEED");
4716
4717     if ( env_pv )
4718 #  ifndef USE_HASH_SEED_EXPLICIT
4719     {
4720         /* ignore leading spaces */
4721         while (isSPACE(*env_pv))
4722             env_pv++;
4723 #    ifdef USE_PERL_PERTURB_KEYS
4724         /* if they set it to "0" we disable key traversal randomization completely */
4725         if (strEQ(env_pv,"0")) {
4726             PL_hash_rand_bits_enabled= 0;
4727         } else {
4728             /* otherwise switch to deterministic mode */
4729             PL_hash_rand_bits_enabled= 2;
4730         }
4731 #    endif
4732         /* ignore a leading 0x... if it is there */
4733         if (env_pv[0] == '0' && env_pv[1] == 'x')
4734             env_pv += 2;
4735
4736         for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) {
4737             seed_buffer[i] = READ_XDIGIT(env_pv) << 4;
4738             if ( isXDIGIT(*env_pv)) {
4739                 seed_buffer[i] |= READ_XDIGIT(env_pv);
4740             }
4741         }
4742         while (isSPACE(*env_pv))
4743             env_pv++;
4744
4745         if (*env_pv && !isXDIGIT(*env_pv)) {
4746             Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n");
4747         }
4748         /* should we check for unparsed crap? */
4749         /* should we warn about unused hex? */
4750         /* should we warn about insufficient hex? */
4751     }
4752     else
4753 #  endif
4754 #endif
4755     {
4756         (void)seedDrand01((Rand_seed_t)seed());
4757
4758         for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) {
4759             seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1));
4760         }
4761     }
4762 #ifdef USE_PERL_PERTURB_KEYS
4763     {   /* initialize PL_hash_rand_bits from the hash seed.
4764          * This value is highly volatile, it is updated every
4765          * hash insert, and is used as part of hash bucket chain
4766          * randomization and hash iterator randomization. */
4767         PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
4768         for( i = 0; i < sizeof(UV) ; i++ ) {
4769             PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES];
4770             PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8);
4771         }
4772     }
4773 #  ifndef NO_PERL_HASH_ENV
4774     env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
4775     if (env_pv) {
4776         if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
4777             PL_hash_rand_bits_enabled= 0;
4778         } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) {
4779             PL_hash_rand_bits_enabled= 1;
4780         } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) {
4781             PL_hash_rand_bits_enabled= 2;
4782         } else {
4783             Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
4784         }
4785     }
4786 #  endif
4787 #endif
4788 }
4789
4790 #ifdef PERL_GLOBAL_STRUCT
4791
4792 #define PERL_GLOBAL_STRUCT_INIT
4793 #include "opcode.h" /* the ppaddr and check */
4794
4795 struct perl_vars *
4796 Perl_init_global_struct(pTHX)
4797 {
4798     struct perl_vars *plvarsp = NULL;
4799 # ifdef PERL_GLOBAL_STRUCT
4800     const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
4801     const IV ncheck  = C_ARRAY_LENGTH(Gcheck);
4802     PERL_UNUSED_CONTEXT;
4803 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4804     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
4805     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
4806     if (!plvarsp)
4807         exit(1);
4808 #  else
4809     plvarsp = PL_VarsPtr;
4810 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
4811 #  undef PERLVAR
4812 #  undef PERLVARA
4813 #  undef PERLVARI
4814 #  undef PERLVARIC
4815 #  define PERLVAR(prefix,var,type) /**/
4816 #  define PERLVARA(prefix,var,n,type) /**/
4817 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
4818 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
4819 #  include "perlvars.h"
4820 #  undef PERLVAR
4821 #  undef PERLVARA
4822 #  undef PERLVARI
4823 #  undef PERLVARIC
4824 #  ifdef PERL_GLOBAL_STRUCT
4825     plvarsp->Gppaddr =
4826         (Perl_ppaddr_t*)
4827         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
4828     if (!plvarsp->Gppaddr)
4829         exit(1);
4830     plvarsp->Gcheck  =
4831         (Perl_check_t*)
4832         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
4833     if (!plvarsp->Gcheck)
4834         exit(1);
4835     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
4836     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
4837 #  endif
4838 #  ifdef PERL_SET_VARS
4839     PERL_SET_VARS(plvarsp);
4840 #  endif
4841 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4842     plvarsp->Gsv_placeholder.sv_flags = 0;
4843     memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
4844 #  endif
4845 # undef PERL_GLOBAL_STRUCT_INIT
4846 # endif
4847     return plvarsp;
4848 }
4849
4850 #endif /* PERL_GLOBAL_STRUCT */
4851
4852 #ifdef PERL_GLOBAL_STRUCT
4853
4854 void
4855 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
4856 {
4857     int veto = plvarsp->Gveto_cleanup;
4858
4859     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
4860     PERL_UNUSED_CONTEXT;
4861 # ifdef PERL_GLOBAL_STRUCT
4862 #  ifdef PERL_UNSET_VARS
4863     PERL_UNSET_VARS(plvarsp);
4864 #  endif
4865     if (veto)
4866         return;
4867     free(plvarsp->Gppaddr);
4868     free(plvarsp->Gcheck);
4869 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
4870     free(plvarsp);
4871 #  endif
4872 # endif
4873 }
4874
4875 #endif /* PERL_GLOBAL_STRUCT */
4876
4877 #ifdef PERL_MEM_LOG
4878
4879 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
4880  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
4881  * given, and you supply your own implementation.
4882  *
4883  * The default implementation reads a single env var, PERL_MEM_LOG,
4884  * expecting one or more of the following:
4885  *
4886  *    \d+ - fd          fd to write to          : must be 1st (grok_atoUV)
4887  *    'm' - memlog      was PERL_MEM_LOG=1
4888  *    's' - svlog       was PERL_SV_LOG=1
4889  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
4890  *
4891  * This makes the logger controllable enough that it can reasonably be
4892  * added to the system perl.
4893  */
4894
4895 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
4896  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
4897  */
4898 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
4899
4900 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
4901  * writes to.  In the default logger, this is settable at runtime.
4902  */
4903 #ifndef PERL_MEM_LOG_FD
4904 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
4905 #endif
4906
4907 #ifndef PERL_MEM_LOG_NOIMPL
4908
4909 # ifdef DEBUG_LEAKING_SCALARS
4910 #   define SV_LOG_SERIAL_FMT        " [%lu]"
4911 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
4912 # else
4913 #   define SV_LOG_SERIAL_FMT
4914 #   define _SV_LOG_SERIAL_ARG(sv)
4915 # endif
4916
4917 static void
4918 S_mem_log_common(enum mem_log_type mlt, const UV n,
4919                  const UV typesize, const char *type_name, const SV *sv,
4920                  Malloc_t oldalloc, Malloc_t newalloc,
4921                  const char *filename, const int linenumber,
4922                  const char *funcname)
4923 {
4924     const char *pmlenv;
4925
4926     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
4927
4928     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
4929     if (!pmlenv)
4930         return;
4931     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
4932     {
4933         /* We can't use SVs or PerlIO for obvious reasons,
4934          * so we'll use stdio and low-level IO instead. */
4935         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
4936
4937 #   ifdef HAS_GETTIMEOFDAY
4938 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
4939 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
4940         struct timeval tv;
4941         gettimeofday(&tv, 0);
4942 #   else
4943 #     define MEM_LOG_TIME_FMT   "%10d: "
4944 #     define MEM_LOG_TIME_ARG   (int)when
4945         Time_t when;
4946         (void)time(&when);
4947 #   endif
4948         /* If there are other OS specific ways of hires time than
4949          * gettimeofday() (see dist/Time-HiRes), the easiest way is
4950          * probably that they would be used to fill in the struct
4951          * timeval. */
4952         {
4953             STRLEN len;
4954             const char* endptr;
4955             int fd;
4956             UV uv;
4957             if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
4958                 && uv && uv <= PERL_INT_MAX
4959             ) {
4960                 fd = (int)uv;
4961             } else {
4962                 fd = PERL_MEM_LOG_FD;
4963             }
4964
4965             if (strchr(pmlenv, 't')) {
4966                 len = my_snprintf(buf, sizeof(buf),
4967                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
4968                 PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
4969             }
4970             switch (mlt) {
4971             case MLT_ALLOC:
4972                 len = my_snprintf(buf, sizeof(buf),
4973                         "alloc: %s:%d:%s: %" IVdf " %" UVuf
4974                         " %s = %" IVdf ": %" UVxf "\n",
4975                         filename, linenumber, funcname, n, typesize,
4976                         type_name, n * typesize, PTR2UV(newalloc));
4977                 break;
4978             case MLT_REALLOC:
4979                 len = my_snprintf(buf, sizeof(buf),
4980                         "realloc: %s:%d:%s: %" IVdf " %" UVuf
4981                         " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
4982                         filename, linenumber, funcname, n, typesize,
4983                         type_name, n * typesize, PTR2UV(oldalloc),
4984                         PTR2UV(newalloc));
4985                 break;
4986             case MLT_FREE:
4987                 len = my_snprintf(buf, sizeof(buf),
4988                         "free: %s:%d:%s: %" UVxf "\n",
4989                         filename, linenumber, funcname,
4990                         PTR2UV(oldalloc));
4991                 break;
4992             case MLT_NEW_SV:
4993             case MLT_DEL_SV:
4994                 len = my_snprintf(buf, sizeof(buf),
4995                         "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
4996                         mlt == MLT_NEW_SV ? "new" : "del",
4997                         filename, linenumber, funcname,
4998                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
4999                 break;
5000             default:
5001                 len = 0;
5002             }
5003             PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
5004         }
5005     }
5006 }
5007 #endif /* !PERL_MEM_LOG_NOIMPL */
5008
5009 #ifndef PERL_MEM_LOG_NOIMPL
5010 # define \
5011     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5012     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5013 #else
5014 /* this is suboptimal, but bug compatible.  User is providing their
5015    own implementation, but is getting these functions anyway, and they
5016    do nothing. But _NOIMPL users should be able to cope or fix */
5017 # define \
5018     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5019     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5020 #endif
5021
5022 Malloc_t
5023 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5024                    Malloc_t newalloc,
5025                    const char *filename, const int linenumber,
5026                    const char *funcname)
5027 {
5028     PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
5029
5030     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5031                       NULL, NULL, newalloc,
5032                       filename, linenumber, funcname);
5033     return newalloc;
5034 }
5035
5036 Malloc_t
5037 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5038                      Malloc_t oldalloc, Malloc_t newalloc,
5039                      const char *filename, const int linenumber,
5040                      const char *funcname)
5041 {
5042     PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
5043
5044     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5045                       NULL, oldalloc, newalloc,
5046                       filename, linenumber, funcname);
5047     return newalloc;
5048 }
5049
5050 Malloc_t
5051 Perl_mem_log_free(Malloc_t oldalloc,
5052                   const char *filename, const int linenumber,
5053                   const char *funcname)
5054 {
5055     PERL_ARGS_ASSERT_MEM_LOG_FREE;
5056
5057     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5058                       filename, linenumber, funcname);
5059     return oldalloc;
5060 }
5061
5062 void
5063 Perl_mem_log_new_sv(const SV *sv,
5064                     const char *filename, const int linenumber,
5065                     const char *funcname)
5066 {
5067     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5068                       filename, linenumber, funcname);
5069 }
5070
5071 void
5072 Perl_mem_log_del_sv(const SV *sv,
5073                     const char *filename, const int linenumber,
5074                     const char *funcname)
5075 {
5076     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5077                       filename, linenumber, funcname);
5078 }
5079
5080 #endif /* PERL_MEM_LOG */
5081
5082 /*
5083 =for apidoc my_sprintf
5084
5085 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5086 the length of the string written to the buffer.  Only rare pre-ANSI systems
5087 need the wrapper function - usually this is a direct call to C<sprintf>.