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