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