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