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