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_ck_warner(pTHX_ U32 err, const char* pat, ...)
1533 {
1534     PERL_ARGS_ASSERT_CK_WARNER;
1535
1536     if (Perl_ckwarn(aTHX_ err)) {
1537         va_list args;
1538         va_start(args, pat);
1539         vwarner(err, pat, &args);
1540         va_end(args);
1541     }
1542 }
1543
1544 void
1545 Perl_warner(pTHX_ U32  err, const char* pat,...)
1546 {
1547     va_list args;
1548     PERL_ARGS_ASSERT_WARNER;
1549     va_start(args, pat);
1550     vwarner(err, pat, &args);
1551     va_end(args);
1552 }
1553
1554 void
1555 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1556 {
1557     dVAR;
1558     PERL_ARGS_ASSERT_VWARNER;
1559     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1560         SV * const msv = vmess(pat, args);
1561         STRLEN msglen;
1562         const char * const message = SvPV_const(msv, msglen);
1563         const I32 utf8 = SvUTF8(msv);
1564
1565         if (PL_diehook) {
1566             assert(message);
1567             S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
1568         }
1569         if (PL_in_eval) {
1570             PL_restartop = die_where(message, msglen);
1571             SvFLAGS(ERRSV) |= utf8;
1572             JMPENV_JUMP(3);
1573         }
1574         write_to_stderr(message, msglen);
1575         my_failure_exit();
1576     }
1577     else {
1578         Perl_vwarn(aTHX_ pat, args);
1579     }
1580 }
1581
1582 /* implements the ckWARN? macros */
1583
1584 bool
1585 Perl_ckwarn(pTHX_ U32 w)
1586 {
1587     dVAR;
1588     return isLEXWARN_on
1589         ? (PL_curcop->cop_warnings != pWARN_NONE
1590            && (
1591                    PL_curcop->cop_warnings == pWARN_ALL
1592                 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1593                 || (unpackWARN2(w) &&
1594                      isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1595                 || (unpackWARN3(w) &&
1596                      isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1597                 || (unpackWARN4(w) &&
1598                      isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1599                 )
1600            )
1601         : (PL_dowarn & G_WARN_ON);
1602 }
1603
1604 /* implements the ckWARN?_d macro */
1605
1606 bool
1607 Perl_ckwarn_d(pTHX_ U32 w)
1608 {
1609     dVAR;
1610     return
1611            isLEXWARN_off
1612         || PL_curcop->cop_warnings == pWARN_ALL
1613         || (
1614               PL_curcop->cop_warnings != pWARN_NONE
1615            && (
1616                    isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1617               || (unpackWARN2(w) &&
1618                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1619               || (unpackWARN3(w) &&
1620                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1621               || (unpackWARN4(w) &&
1622                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1623               )
1624            )
1625         ;
1626 }
1627
1628 /* Set buffer=NULL to get a new one.  */
1629 STRLEN *
1630 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1631                            STRLEN size) {
1632     const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
1633     PERL_UNUSED_CONTEXT;
1634     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1635
1636     buffer = (STRLEN*)
1637         (specialWARN(buffer) ?
1638          PerlMemShared_malloc(len_wanted) :
1639          PerlMemShared_realloc(buffer, len_wanted));
1640     buffer[0] = size;
1641     Copy(bits, (buffer + 1), size, char);
1642     return buffer;
1643 }
1644
1645 /* since we've already done strlen() for both nam and val
1646  * we can use that info to make things faster than
1647  * sprintf(s, "%s=%s", nam, val)
1648  */
1649 #define my_setenv_format(s, nam, nlen, val, vlen) \
1650    Copy(nam, s, nlen, char); \
1651    *(s+nlen) = '='; \
1652    Copy(val, s+(nlen+1), vlen, char); \
1653    *(s+(nlen+1+vlen)) = '\0'
1654
1655 #ifdef USE_ENVIRON_ARRAY
1656        /* VMS' my_setenv() is in vms.c */
1657 #if !defined(WIN32) && !defined(NETWARE)
1658 void
1659 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1660 {
1661   dVAR;
1662 #ifdef USE_ITHREADS
1663   /* only parent thread can modify process environment */
1664   if (PL_curinterp == aTHX)
1665 #endif
1666   {
1667 #ifndef PERL_USE_SAFE_PUTENV
1668     if (!PL_use_safe_putenv) {
1669     /* most putenv()s leak, so we manipulate environ directly */
1670     register I32 i;
1671     register const I32 len = strlen(nam);
1672     int nlen, vlen;
1673
1674     /* where does it go? */
1675     for (i = 0; environ[i]; i++) {
1676         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1677             break;
1678     }
1679
1680     if (environ == PL_origenviron) {   /* need we copy environment? */
1681        I32 j;
1682        I32 max;
1683        char **tmpenv;
1684
1685        max = i;
1686        while (environ[max])
1687            max++;
1688        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1689        for (j=0; j<max; j++) {         /* copy environment */
1690            const int len = strlen(environ[j]);
1691            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1692            Copy(environ[j], tmpenv[j], len+1, char);
1693        }
1694        tmpenv[max] = NULL;
1695        environ = tmpenv;               /* tell exec where it is now */
1696     }
1697     if (!val) {
1698        safesysfree(environ[i]);
1699        while (environ[i]) {
1700            environ[i] = environ[i+1];
1701            i++;
1702         }
1703        return;
1704     }
1705     if (!environ[i]) {                 /* does not exist yet */
1706        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1707        environ[i+1] = NULL;    /* make sure it's null terminated */
1708     }
1709     else
1710        safesysfree(environ[i]);
1711        nlen = strlen(nam);
1712        vlen = strlen(val);
1713
1714        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1715        /* all that work just for this */
1716        my_setenv_format(environ[i], nam, nlen, val, vlen);
1717     } else {
1718 # endif
1719 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1720 #       if defined(HAS_UNSETENV)
1721         if (val == NULL) {
1722             (void)unsetenv(nam);
1723         } else {
1724             (void)setenv(nam, val, 1);
1725         }
1726 #       else /* ! HAS_UNSETENV */
1727         (void)setenv(nam, val, 1);
1728 #       endif /* HAS_UNSETENV */
1729 #   else
1730 #       if defined(HAS_UNSETENV)
1731         if (val == NULL) {
1732             (void)unsetenv(nam);
1733         } else {
1734             const int nlen = strlen(nam);
1735             const int vlen = strlen(val);
1736             char * const new_env =
1737                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1738             my_setenv_format(new_env, nam, nlen, val, vlen);
1739             (void)putenv(new_env);
1740         }
1741 #       else /* ! HAS_UNSETENV */
1742         char *new_env;
1743         const int nlen = strlen(nam);
1744         int vlen;
1745         if (!val) {
1746            val = "";
1747         }
1748         vlen = strlen(val);
1749         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1750         /* all that work just for this */
1751         my_setenv_format(new_env, nam, nlen, val, vlen);
1752         (void)putenv(new_env);
1753 #       endif /* HAS_UNSETENV */
1754 #   endif /* __CYGWIN__ */
1755 #ifndef PERL_USE_SAFE_PUTENV
1756     }
1757 #endif
1758   }
1759 }
1760
1761 #else /* WIN32 || NETWARE */
1762
1763 void
1764 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1765 {
1766     dVAR;
1767     register char *envstr;
1768     const int nlen = strlen(nam);
1769     int vlen;
1770
1771     if (!val) {
1772        val = "";
1773     }
1774     vlen = strlen(val);
1775     Newx(envstr, nlen+vlen+2, char);
1776     my_setenv_format(envstr, nam, nlen, val, vlen);
1777     (void)PerlEnv_putenv(envstr);
1778     Safefree(envstr);
1779 }
1780
1781 #endif /* WIN32 || NETWARE */
1782
1783 #endif /* !VMS && !EPOC*/
1784
1785 #ifdef UNLINK_ALL_VERSIONS
1786 I32
1787 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
1788 {
1789     I32 retries = 0;
1790
1791     PERL_ARGS_ASSERT_UNLNK;
1792
1793     while (PerlLIO_unlink(f) >= 0)
1794         retries++;
1795     return retries ? 0 : -1;
1796 }
1797 #endif
1798
1799 /* this is a drop-in replacement for bcopy() */
1800 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
1801 char *
1802 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
1803 {
1804     char * const retval = to;
1805
1806     PERL_ARGS_ASSERT_MY_BCOPY;
1807
1808     if (from - to >= 0) {
1809         while (len--)
1810             *to++ = *from++;
1811     }
1812     else {
1813         to += len;
1814         from += len;
1815         while (len--)
1816             *(--to) = *(--from);
1817     }
1818     return retval;
1819 }
1820 #endif
1821
1822 /* this is a drop-in replacement for memset() */
1823 #ifndef HAS_MEMSET
1824 void *
1825 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
1826 {
1827     char * const retval = loc;
1828
1829     PERL_ARGS_ASSERT_MY_MEMSET;
1830
1831     while (len--)
1832         *loc++ = ch;
1833     return retval;
1834 }
1835 #endif
1836
1837 /* this is a drop-in replacement for bzero() */
1838 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
1839 char *
1840 Perl_my_bzero(register char *loc, register I32 len)
1841 {
1842     char * const retval = loc;
1843
1844     PERL_ARGS_ASSERT_MY_BZERO;
1845
1846     while (len--)
1847         *loc++ = 0;
1848     return retval;
1849 }
1850 #endif
1851
1852 /* this is a drop-in replacement for memcmp() */
1853 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
1854 I32
1855 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
1856 {
1857     register const U8 *a = (const U8 *)s1;
1858     register const U8 *b = (const U8 *)s2;
1859     register I32 tmp;
1860
1861     PERL_ARGS_ASSERT_MY_MEMCMP;
1862
1863     while (len--) {
1864         if ((tmp = *a++ - *b++))
1865             return tmp;
1866     }
1867     return 0;
1868 }
1869 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
1870
1871 #ifndef HAS_VPRINTF
1872 /* This vsprintf replacement should generally never get used, since
1873    vsprintf was available in both System V and BSD 2.11.  (There may
1874    be some cross-compilation or embedded set-ups where it is needed,
1875    however.)
1876
1877    If you encounter a problem in this function, it's probably a symptom
1878    that Configure failed to detect your system's vprintf() function.
1879    See the section on "item vsprintf" in the INSTALL file.
1880
1881    This version may compile on systems with BSD-ish <stdio.h>,
1882    but probably won't on others.
1883 */
1884
1885 #ifdef USE_CHAR_VSPRINTF
1886 char *
1887 #else
1888 int
1889 #endif
1890 vsprintf(char *dest, const char *pat, void *args)
1891 {
1892     FILE fakebuf;
1893
1894 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
1895     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
1896     FILE_cnt(&fakebuf) = 32767;
1897 #else
1898     /* These probably won't compile -- If you really need
1899        this, you'll have to figure out some other method. */
1900     fakebuf._ptr = dest;
1901     fakebuf._cnt = 32767;
1902 #endif
1903 #ifndef _IOSTRG
1904 #define _IOSTRG 0
1905 #endif
1906     fakebuf._flag = _IOWRT|_IOSTRG;
1907     _doprnt(pat, args, &fakebuf);       /* what a kludge */
1908 #if defined(STDIO_PTR_LVALUE)
1909     *(FILE_ptr(&fakebuf)++) = '\0';
1910 #else
1911     /* PerlIO has probably #defined away fputc, but we want it here. */
1912 #  ifdef fputc
1913 #    undef fputc  /* XXX Should really restore it later */
1914 #  endif
1915     (void)fputc('\0', &fakebuf);
1916 #endif
1917 #ifdef USE_CHAR_VSPRINTF
1918     return(dest);
1919 #else
1920     return 0;           /* perl doesn't use return value */
1921 #endif
1922 }
1923
1924 #endif /* HAS_VPRINTF */
1925
1926 #ifdef MYSWAP
1927 #if BYTEORDER != 0x4321
1928 short
1929 Perl_my_swap(pTHX_ short s)
1930 {
1931 #if (BYTEORDER & 1) == 0
1932     short result;
1933
1934     result = ((s & 255) << 8) + ((s >> 8) & 255);
1935     return result;
1936 #else
1937     return s;
1938 #endif
1939 }
1940
1941 long
1942 Perl_my_htonl(pTHX_ long l)
1943 {
1944     union {
1945         long result;
1946         char c[sizeof(long)];
1947     } u;
1948
1949 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1950 #if BYTEORDER == 0x12345678
1951     u.result = 0;
1952 #endif
1953     u.c[0] = (l >> 24) & 255;
1954     u.c[1] = (l >> 16) & 255;
1955     u.c[2] = (l >> 8) & 255;
1956     u.c[3] = l & 255;
1957     return u.result;
1958 #else
1959 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1960     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1961 #else
1962     register I32 o;
1963     register I32 s;
1964
1965     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1966         u.c[o & 0xf] = (l >> s) & 255;
1967     }
1968     return u.result;
1969 #endif
1970 #endif
1971 }
1972
1973 long
1974 Perl_my_ntohl(pTHX_ long l)
1975 {
1976     union {
1977         long l;
1978         char c[sizeof(long)];
1979     } u;
1980
1981 #if BYTEORDER == 0x1234
1982     u.c[0] = (l >> 24) & 255;
1983     u.c[1] = (l >> 16) & 255;
1984     u.c[2] = (l >> 8) & 255;
1985     u.c[3] = l & 255;
1986     return u.l;
1987 #else
1988 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
1989     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
1990 #else
1991     register I32 o;
1992     register I32 s;
1993
1994     u.l = l;
1995     l = 0;
1996     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1997         l |= (u.c[o & 0xf] & 255) << s;
1998     }
1999     return l;
2000 #endif
2001 #endif
2002 }
2003
2004 #endif /* BYTEORDER != 0x4321 */
2005 #endif /* MYSWAP */
2006
2007 /*
2008  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2009  * If these functions are defined,
2010  * the BYTEORDER is neither 0x1234 nor 0x4321.
2011  * However, this is not assumed.
2012  * -DWS
2013  */
2014
2015 #define HTOLE(name,type)                                        \
2016         type                                                    \
2017         name (register type n)                                  \
2018         {                                                       \
2019             union {                                             \
2020                 type value;                                     \
2021                 char c[sizeof(type)];                           \
2022             } u;                                                \
2023             register U32 i;                                     \
2024             register U32 s = 0;                                 \
2025             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2026                 u.c[i] = (n >> s) & 0xFF;                       \
2027             }                                                   \
2028             return u.value;                                     \
2029         }
2030
2031 #define LETOH(name,type)                                        \
2032         type                                                    \
2033         name (register type n)                                  \
2034         {                                                       \
2035             union {                                             \
2036                 type value;                                     \
2037                 char c[sizeof(type)];                           \
2038             } u;                                                \
2039             register U32 i;                                     \
2040             register U32 s = 0;                                 \
2041             u.value = n;                                        \
2042             n = 0;                                              \
2043             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2044                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2045             }                                                   \
2046             return n;                                           \
2047         }
2048
2049 /*
2050  * Big-endian byte order functions.
2051  */
2052
2053 #define HTOBE(name,type)                                        \
2054         type                                                    \
2055         name (register type n)                                  \
2056         {                                                       \
2057             union {                                             \
2058                 type value;                                     \
2059                 char c[sizeof(type)];                           \
2060             } u;                                                \
2061             register U32 i;                                     \
2062             register U32 s = 8*(sizeof(u.c)-1);                 \
2063             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2064                 u.c[i] = (n >> s) & 0xFF;                       \
2065             }                                                   \
2066             return u.value;                                     \
2067         }
2068
2069 #define BETOH(name,type)                                        \
2070         type                                                    \
2071         name (register type n)                                  \
2072         {                                                       \
2073             union {                                             \
2074                 type value;                                     \
2075                 char c[sizeof(type)];                           \
2076             } u;                                                \
2077             register U32 i;                                     \
2078             register U32 s = 8*(sizeof(u.c)-1);                 \
2079             u.value = n;                                        \
2080             n = 0;                                              \
2081             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2082                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2083             }                                                   \
2084             return n;                                           \
2085         }
2086
2087 /*
2088  * If we just can't do it...
2089  */
2090
2091 #define NOT_AVAIL(name,type)                                    \
2092         type                                                    \
2093         name (register type n)                                  \
2094         {                                                       \
2095             Perl_croak_nocontext(#name "() not available");     \
2096             return n; /* not reached */                         \
2097         }
2098
2099
2100 #if defined(HAS_HTOVS) && !defined(htovs)
2101 HTOLE(htovs,short)
2102 #endif
2103 #if defined(HAS_HTOVL) && !defined(htovl)
2104 HTOLE(htovl,long)
2105 #endif
2106 #if defined(HAS_VTOHS) && !defined(vtohs)
2107 LETOH(vtohs,short)
2108 #endif
2109 #if defined(HAS_VTOHL) && !defined(vtohl)
2110 LETOH(vtohl,long)
2111 #endif
2112
2113 #ifdef PERL_NEED_MY_HTOLE16
2114 # if U16SIZE == 2
2115 HTOLE(Perl_my_htole16,U16)
2116 # else
2117 NOT_AVAIL(Perl_my_htole16,U16)
2118 # endif
2119 #endif
2120 #ifdef PERL_NEED_MY_LETOH16
2121 # if U16SIZE == 2
2122 LETOH(Perl_my_letoh16,U16)
2123 # else
2124 NOT_AVAIL(Perl_my_letoh16,U16)
2125 # endif
2126 #endif
2127 #ifdef PERL_NEED_MY_HTOBE16
2128 # if U16SIZE == 2
2129 HTOBE(Perl_my_htobe16,U16)
2130 # else
2131 NOT_AVAIL(Perl_my_htobe16,U16)
2132 # endif
2133 #endif
2134 #ifdef PERL_NEED_MY_BETOH16
2135 # if U16SIZE == 2
2136 BETOH(Perl_my_betoh16,U16)
2137 # else
2138 NOT_AVAIL(Perl_my_betoh16,U16)
2139 # endif
2140 #endif
2141
2142 #ifdef PERL_NEED_MY_HTOLE32
2143 # if U32SIZE == 4
2144 HTOLE(Perl_my_htole32,U32)
2145 # else
2146 NOT_AVAIL(Perl_my_htole32,U32)
2147 # endif
2148 #endif
2149 #ifdef PERL_NEED_MY_LETOH32
2150 # if U32SIZE == 4
2151 LETOH(Perl_my_letoh32,U32)
2152 # else
2153 NOT_AVAIL(Perl_my_letoh32,U32)
2154 # endif
2155 #endif
2156 #ifdef PERL_NEED_MY_HTOBE32
2157 # if U32SIZE == 4
2158 HTOBE(Perl_my_htobe32,U32)
2159 # else
2160 NOT_AVAIL(Perl_my_htobe32,U32)
2161 # endif
2162 #endif
2163 #ifdef PERL_NEED_MY_BETOH32
2164 # if U32SIZE == 4
2165 BETOH(Perl_my_betoh32,U32)
2166 # else
2167 NOT_AVAIL(Perl_my_betoh32,U32)
2168 # endif
2169 #endif
2170
2171 #ifdef PERL_NEED_MY_HTOLE64
2172 # if U64SIZE == 8
2173 HTOLE(Perl_my_htole64,U64)
2174 # else
2175 NOT_AVAIL(Perl_my_htole64,U64)
2176 # endif
2177 #endif
2178 #ifdef PERL_NEED_MY_LETOH64
2179 # if U64SIZE == 8
2180 LETOH(Perl_my_letoh64,U64)
2181 # else
2182 NOT_AVAIL(Perl_my_letoh64,U64)
2183 # endif
2184 #endif
2185 #ifdef PERL_NEED_MY_HTOBE64
2186 # if U64SIZE == 8
2187 HTOBE(Perl_my_htobe64,U64)
2188 # else
2189 NOT_AVAIL(Perl_my_htobe64,U64)
2190 # endif
2191 #endif
2192 #ifdef PERL_NEED_MY_BETOH64
2193 # if U64SIZE == 8
2194 BETOH(Perl_my_betoh64,U64)
2195 # else
2196 NOT_AVAIL(Perl_my_betoh64,U64)
2197 # endif
2198 #endif
2199
2200 #ifdef PERL_NEED_MY_HTOLES
2201 HTOLE(Perl_my_htoles,short)
2202 #endif
2203 #ifdef PERL_NEED_MY_LETOHS
2204 LETOH(Perl_my_letohs,short)
2205 #endif
2206 #ifdef PERL_NEED_MY_HTOBES
2207 HTOBE(Perl_my_htobes,short)
2208 #endif
2209 #ifdef PERL_NEED_MY_BETOHS
2210 BETOH(Perl_my_betohs,short)
2211 #endif
2212
2213 #ifdef PERL_NEED_MY_HTOLEI
2214 HTOLE(Perl_my_htolei,int)
2215 #endif
2216 #ifdef PERL_NEED_MY_LETOHI
2217 LETOH(Perl_my_letohi,int)
2218 #endif
2219 #ifdef PERL_NEED_MY_HTOBEI
2220 HTOBE(Perl_my_htobei,int)
2221 #endif
2222 #ifdef PERL_NEED_MY_BETOHI
2223 BETOH(Perl_my_betohi,int)
2224 #endif
2225
2226 #ifdef PERL_NEED_MY_HTOLEL
2227 HTOLE(Perl_my_htolel,long)
2228 #endif
2229 #ifdef PERL_NEED_MY_LETOHL
2230 LETOH(Perl_my_letohl,long)
2231 #endif
2232 #ifdef PERL_NEED_MY_HTOBEL
2233 HTOBE(Perl_my_htobel,long)
2234 #endif
2235 #ifdef PERL_NEED_MY_BETOHL
2236 BETOH(Perl_my_betohl,long)
2237 #endif
2238
2239 void
2240 Perl_my_swabn(void *ptr, int n)
2241 {
2242     register char *s = (char *)ptr;
2243     register char *e = s + (n-1);
2244     register char tc;
2245
2246     PERL_ARGS_ASSERT_MY_SWABN;
2247
2248     for (n /= 2; n > 0; s++, e--, n--) {
2249       tc = *s;
2250       *s = *e;
2251       *e = tc;
2252     }
2253 }
2254
2255 PerlIO *
2256 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2257 {
2258 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2259     dVAR;
2260     int p[2];
2261     register I32 This, that;
2262     register Pid_t pid;
2263     SV *sv;
2264     I32 did_pipes = 0;
2265     int pp[2];
2266
2267     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2268
2269     PERL_FLUSHALL_FOR_CHILD;
2270     This = (*mode == 'w');
2271     that = !This;
2272     if (PL_tainting) {
2273         taint_env();
2274         taint_proper("Insecure %s%s", "EXEC");
2275     }
2276     if (PerlProc_pipe(p) < 0)
2277         return NULL;
2278     /* Try for another pipe pair for error return */
2279     if (PerlProc_pipe(pp) >= 0)
2280         did_pipes = 1;
2281     while ((pid = PerlProc_fork()) < 0) {
2282         if (errno != EAGAIN) {
2283             PerlLIO_close(p[This]);
2284             PerlLIO_close(p[that]);
2285             if (did_pipes) {
2286                 PerlLIO_close(pp[0]);
2287                 PerlLIO_close(pp[1]);
2288             }
2289             return NULL;
2290         }
2291         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2292         sleep(5);
2293     }
2294     if (pid == 0) {
2295         /* Child */
2296 #undef THIS
2297 #undef THAT
2298 #define THIS that
2299 #define THAT This
2300         /* Close parent's end of error status pipe (if any) */
2301         if (did_pipes) {
2302             PerlLIO_close(pp[0]);
2303 #if defined(HAS_FCNTL) && defined(F_SETFD)
2304             /* Close error pipe automatically if exec works */
2305             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2306 #endif
2307         }
2308         /* Now dup our end of _the_ pipe to right position */
2309         if (p[THIS] != (*mode == 'r')) {
2310             PerlLIO_dup2(p[THIS], *mode == 'r');
2311             PerlLIO_close(p[THIS]);
2312             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2313                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2314         }
2315         else
2316             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2317 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2318         /* No automatic close - do it by hand */
2319 #  ifndef NOFILE
2320 #  define NOFILE 20
2321 #  endif
2322         {
2323             int fd;
2324
2325             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2326                 if (fd != pp[1])
2327                     PerlLIO_close(fd);
2328             }
2329         }
2330 #endif
2331         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2332         PerlProc__exit(1);
2333 #undef THIS
2334 #undef THAT
2335     }
2336     /* Parent */
2337     do_execfree();      /* free any memory malloced by child on fork */
2338     if (did_pipes)
2339         PerlLIO_close(pp[1]);
2340     /* Keep the lower of the two fd numbers */
2341     if (p[that] < p[This]) {
2342         PerlLIO_dup2(p[This], p[that]);
2343         PerlLIO_close(p[This]);
2344         p[This] = p[that];
2345     }
2346     else
2347         PerlLIO_close(p[that]);         /* close child's end of pipe */
2348
2349     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2350     SvUPGRADE(sv,SVt_IV);
2351     SvIV_set(sv, pid);
2352     PL_forkprocess = pid;
2353     /* If we managed to get status pipe check for exec fail */
2354     if (did_pipes && pid > 0) {
2355         int errkid;
2356         unsigned n = 0;
2357         SSize_t n1;
2358
2359         while (n < sizeof(int)) {
2360             n1 = PerlLIO_read(pp[0],
2361                               (void*)(((char*)&errkid)+n),
2362                               (sizeof(int)) - n);
2363             if (n1 <= 0)
2364                 break;
2365             n += n1;
2366         }
2367         PerlLIO_close(pp[0]);
2368         did_pipes = 0;
2369         if (n) {                        /* Error */
2370             int pid2, status;
2371             PerlLIO_close(p[This]);
2372             if (n != sizeof(int))
2373                 Perl_croak(aTHX_ "panic: kid popen errno read");
2374             do {
2375                 pid2 = wait4pid(pid, &status, 0);
2376             } while (pid2 == -1 && errno == EINTR);
2377             errno = errkid;             /* Propagate errno from kid */
2378             return NULL;
2379         }
2380     }
2381     if (did_pipes)
2382          PerlLIO_close(pp[0]);
2383     return PerlIO_fdopen(p[This], mode);
2384 #else
2385 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2386     return my_syspopen4(aTHX_ NULL, mode, n, args);
2387 #  else
2388     Perl_croak(aTHX_ "List form of piped open not implemented");
2389     return (PerlIO *) NULL;
2390 #  endif
2391 #endif
2392 }
2393
2394     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2395 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2396 PerlIO *
2397 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2398 {
2399     dVAR;
2400     int p[2];
2401     register I32 This, that;
2402     register Pid_t pid;
2403     SV *sv;
2404     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2405     I32 did_pipes = 0;
2406     int pp[2];
2407
2408     PERL_ARGS_ASSERT_MY_POPEN;
2409
2410     PERL_FLUSHALL_FOR_CHILD;
2411 #ifdef OS2
2412     if (doexec) {
2413         return my_syspopen(aTHX_ cmd,mode);
2414     }
2415 #endif
2416     This = (*mode == 'w');
2417     that = !This;
2418     if (doexec && PL_tainting) {
2419         taint_env();
2420         taint_proper("Insecure %s%s", "EXEC");
2421     }
2422     if (PerlProc_pipe(p) < 0)
2423         return NULL;
2424     if (doexec && PerlProc_pipe(pp) >= 0)
2425         did_pipes = 1;
2426     while ((pid = PerlProc_fork()) < 0) {
2427         if (errno != EAGAIN) {
2428             PerlLIO_close(p[This]);
2429             PerlLIO_close(p[that]);
2430             if (did_pipes) {
2431                 PerlLIO_close(pp[0]);
2432                 PerlLIO_close(pp[1]);
2433             }
2434             if (!doexec)
2435                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2436             return NULL;
2437         }
2438         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2439         sleep(5);
2440     }
2441     if (pid == 0) {
2442         GV* tmpgv;
2443
2444 #undef THIS
2445 #undef THAT
2446 #define THIS that
2447 #define THAT This
2448         if (did_pipes) {
2449             PerlLIO_close(pp[0]);
2450 #if defined(HAS_FCNTL) && defined(F_SETFD)
2451             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2452 #endif
2453         }
2454         if (p[THIS] != (*mode == 'r')) {
2455             PerlLIO_dup2(p[THIS], *mode == 'r');
2456             PerlLIO_close(p[THIS]);
2457             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2458                 PerlLIO_close(p[THAT]);
2459         }
2460         else
2461             PerlLIO_close(p[THAT]);
2462 #ifndef OS2
2463         if (doexec) {
2464 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2465 #ifndef NOFILE
2466 #define NOFILE 20
2467 #endif
2468             {
2469                 int fd;
2470
2471                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2472                     if (fd != pp[1])
2473                         PerlLIO_close(fd);
2474             }
2475 #endif
2476             /* may or may not use the shell */
2477             do_exec3(cmd, pp[1], did_pipes);
2478             PerlProc__exit(1);
2479         }
2480 #endif  /* defined OS2 */
2481
2482 #ifdef PERLIO_USING_CRLF
2483    /* Since we circumvent IO layers when we manipulate low-level
2484       filedescriptors directly, need to manually switch to the
2485       default, binary, low-level mode; see PerlIOBuf_open(). */
2486    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2487 #endif
2488
2489         if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
2490             SvREADONLY_off(GvSV(tmpgv));
2491             sv_setiv(GvSV(tmpgv), PerlProc_getpid());
2492             SvREADONLY_on(GvSV(tmpgv));
2493         }
2494 #ifdef THREADS_HAVE_PIDS
2495         PL_ppid = (IV)getppid();
2496 #endif
2497         PL_forkprocess = 0;
2498 #ifdef PERL_USES_PL_PIDSTATUS
2499         hv_clear(PL_pidstatus); /* we have no children */
2500 #endif
2501         return NULL;
2502 #undef THIS
2503 #undef THAT
2504     }
2505     do_execfree();      /* free any memory malloced by child on vfork */
2506     if (did_pipes)
2507         PerlLIO_close(pp[1]);
2508     if (p[that] < p[This]) {
2509         PerlLIO_dup2(p[This], p[that]);
2510         PerlLIO_close(p[This]);
2511         p[This] = p[that];
2512     }
2513     else
2514         PerlLIO_close(p[that]);
2515
2516     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2517     SvUPGRADE(sv,SVt_IV);
2518     SvIV_set(sv, pid);
2519     PL_forkprocess = pid;
2520     if (did_pipes && pid > 0) {
2521         int errkid;
2522         unsigned n = 0;
2523         SSize_t n1;
2524
2525         while (n < sizeof(int)) {
2526             n1 = PerlLIO_read(pp[0],
2527                               (void*)(((char*)&errkid)+n),
2528                               (sizeof(int)) - n);
2529             if (n1 <= 0)
2530                 break;
2531             n += n1;
2532         }
2533         PerlLIO_close(pp[0]);
2534         did_pipes = 0;
2535         if (n) {                        /* Error */
2536             int pid2, status;
2537             PerlLIO_close(p[This]);
2538             if (n != sizeof(int))
2539                 Perl_croak(aTHX_ "panic: kid popen errno read");
2540             do {
2541                 pid2 = wait4pid(pid, &status, 0);
2542             } while (pid2 == -1 && errno == EINTR);
2543             errno = errkid;             /* Propagate errno from kid */
2544             return NULL;
2545         }
2546     }
2547     if (did_pipes)
2548          PerlLIO_close(pp[0]);
2549     return PerlIO_fdopen(p[This], mode);
2550 }
2551 #else
2552 #if defined(atarist) || defined(EPOC)
2553 FILE *popen();
2554 PerlIO *
2555 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2556 {
2557     PERL_ARGS_ASSERT_MY_POPEN;
2558     PERL_FLUSHALL_FOR_CHILD;
2559     /* Call system's popen() to get a FILE *, then import it.
2560        used 0 for 2nd parameter to PerlIO_importFILE;
2561        apparently not used
2562     */
2563     return PerlIO_importFILE(popen(cmd, mode), 0);
2564 }
2565 #else
2566 #if defined(DJGPP)
2567 FILE *djgpp_popen();
2568 PerlIO *
2569 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2570 {
2571     PERL_FLUSHALL_FOR_CHILD;
2572     /* Call system's popen() to get a FILE *, then import it.
2573        used 0 for 2nd parameter to PerlIO_importFILE;
2574        apparently not used
2575     */
2576     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2577 }
2578 #else
2579 #if defined(__LIBCATAMOUNT__)
2580 PerlIO *
2581 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2582 {
2583     return NULL;
2584 }
2585 #endif
2586 #endif
2587 #endif
2588
2589 #endif /* !DOSISH */
2590
2591 /* this is called in parent before the fork() */
2592 void
2593 Perl_atfork_lock(void)
2594 {
2595    dVAR;
2596 #if defined(USE_ITHREADS)
2597     /* locks must be held in locking order (if any) */
2598 #  ifdef MYMALLOC
2599     MUTEX_LOCK(&PL_malloc_mutex);
2600 #  endif
2601     OP_REFCNT_LOCK;
2602 #endif
2603 }
2604
2605 /* this is called in both parent and child after the fork() */
2606 void
2607 Perl_atfork_unlock(void)
2608 {
2609     dVAR;
2610 #if defined(USE_ITHREADS)
2611     /* locks must be released in same order as in atfork_lock() */
2612 #  ifdef MYMALLOC
2613     MUTEX_UNLOCK(&PL_malloc_mutex);
2614 #  endif
2615     OP_REFCNT_UNLOCK;
2616 #endif
2617 }
2618
2619 Pid_t
2620 Perl_my_fork(void)
2621 {
2622 #if defined(HAS_FORK)
2623     Pid_t pid;
2624 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2625     atfork_lock();
2626     pid = fork();
2627     atfork_unlock();
2628 #else
2629     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2630      * handlers elsewhere in the code */
2631     pid = fork();
2632 #endif
2633     return pid;
2634 #else
2635     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2636     Perl_croak_nocontext("fork() not available");
2637     return 0;
2638 #endif /* HAS_FORK */
2639 }
2640
2641 #ifdef DUMP_FDS
2642 void
2643 Perl_dump_fds(pTHX_ const char *const s)
2644 {
2645     int fd;
2646     Stat_t tmpstatbuf;
2647
2648     PERL_ARGS_ASSERT_DUMP_FDS;
2649
2650     PerlIO_printf(Perl_debug_log,"%s", s);
2651     for (fd = 0; fd < 32; fd++) {
2652         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2653             PerlIO_printf(Perl_debug_log," %d",fd);
2654     }
2655     PerlIO_printf(Perl_debug_log,"\n");
2656     return;
2657 }
2658 #endif  /* DUMP_FDS */
2659
2660 #ifndef HAS_DUP2
2661 int
2662 dup2(int oldfd, int newfd)
2663 {
2664 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2665     if (oldfd == newfd)
2666         return oldfd;
2667     PerlLIO_close(newfd);
2668     return fcntl(oldfd, F_DUPFD, newfd);
2669 #else
2670 #define DUP2_MAX_FDS 256
2671     int fdtmp[DUP2_MAX_FDS];
2672     I32 fdx = 0;
2673     int fd;
2674
2675     if (oldfd == newfd)
2676         return oldfd;
2677     PerlLIO_close(newfd);
2678     /* good enough for low fd's... */
2679     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2680         if (fdx >= DUP2_MAX_FDS) {
2681             PerlLIO_close(fd);
2682             fd = -1;
2683             break;
2684         }
2685         fdtmp[fdx++] = fd;
2686     }
2687     while (fdx > 0)
2688         PerlLIO_close(fdtmp[--fdx]);
2689     return fd;
2690 #endif
2691 }
2692 #endif
2693
2694 #ifndef PERL_MICRO
2695 #ifdef HAS_SIGACTION
2696
2697 Sighandler_t
2698 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2699 {
2700     dVAR;
2701     struct sigaction act, oact;
2702
2703 #ifdef USE_ITHREADS
2704     /* only "parent" interpreter can diddle signals */
2705     if (PL_curinterp != aTHX)
2706         return (Sighandler_t) SIG_ERR;
2707 #endif
2708
2709     act.sa_handler = (void(*)(int))handler;
2710     sigemptyset(&act.sa_mask);
2711     act.sa_flags = 0;
2712 #ifdef SA_RESTART
2713     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2714         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2715 #endif
2716 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2717     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2718         act.sa_flags |= SA_NOCLDWAIT;
2719 #endif
2720     if (sigaction(signo, &act, &oact) == -1)
2721         return (Sighandler_t) SIG_ERR;
2722     else
2723         return (Sighandler_t) oact.sa_handler;
2724 }
2725
2726 Sighandler_t
2727 Perl_rsignal_state(pTHX_ int signo)
2728 {
2729     struct sigaction oact;
2730     PERL_UNUSED_CONTEXT;
2731
2732     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2733         return (Sighandler_t) SIG_ERR;
2734     else
2735         return (Sighandler_t) oact.sa_handler;
2736 }
2737
2738 int
2739 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2740 {
2741     dVAR;
2742     struct sigaction act;
2743
2744     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2745
2746 #ifdef USE_ITHREADS
2747     /* only "parent" interpreter can diddle signals */
2748     if (PL_curinterp != aTHX)
2749         return -1;
2750 #endif
2751
2752     act.sa_handler = (void(*)(int))handler;
2753     sigemptyset(&act.sa_mask);
2754     act.sa_flags = 0;
2755 #ifdef SA_RESTART
2756     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2757         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2758 #endif
2759 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2760     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2761         act.sa_flags |= SA_NOCLDWAIT;
2762 #endif
2763     return sigaction(signo, &act, save);
2764 }
2765
2766 int
2767 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2768 {
2769     dVAR;
2770 #ifdef USE_ITHREADS
2771     /* only "parent" interpreter can diddle signals */
2772     if (PL_curinterp != aTHX)
2773         return -1;
2774 #endif
2775
2776     return sigaction(signo, save, (struct sigaction *)NULL);
2777 }
2778
2779 #else /* !HAS_SIGACTION */
2780
2781 Sighandler_t
2782 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2783 {
2784 #if defined(USE_ITHREADS) && !defined(WIN32)
2785     /* only "parent" interpreter can diddle signals */
2786     if (PL_curinterp != aTHX)
2787         return (Sighandler_t) SIG_ERR;
2788 #endif
2789
2790     return PerlProc_signal(signo, handler);
2791 }
2792
2793 static Signal_t
2794 sig_trap(int signo)
2795 {
2796     dVAR;
2797     PL_sig_trapped++;
2798 }
2799
2800 Sighandler_t
2801 Perl_rsignal_state(pTHX_ int signo)
2802 {
2803     dVAR;
2804     Sighandler_t oldsig;
2805
2806 #if defined(USE_ITHREADS) && !defined(WIN32)
2807     /* only "parent" interpreter can diddle signals */
2808     if (PL_curinterp != aTHX)
2809         return (Sighandler_t) SIG_ERR;
2810 #endif
2811
2812     PL_sig_trapped = 0;
2813     oldsig = PerlProc_signal(signo, sig_trap);
2814     PerlProc_signal(signo, oldsig);
2815     if (PL_sig_trapped)
2816         PerlProc_kill(PerlProc_getpid(), signo);
2817     return oldsig;
2818 }
2819
2820 int
2821 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2822 {
2823 #if defined(USE_ITHREADS) && !defined(WIN32)
2824     /* only "parent" interpreter can diddle signals */
2825     if (PL_curinterp != aTHX)
2826         return -1;
2827 #endif
2828     *save = PerlProc_signal(signo, handler);
2829     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
2830 }
2831
2832 int
2833 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2834 {
2835 #if defined(USE_ITHREADS) && !defined(WIN32)
2836     /* only "parent" interpreter can diddle signals */
2837     if (PL_curinterp != aTHX)
2838         return -1;
2839 #endif
2840     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
2841 }
2842
2843 #endif /* !HAS_SIGACTION */
2844 #endif /* !PERL_MICRO */
2845
2846     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
2847 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2848 I32
2849 Perl_my_pclose(pTHX_ PerlIO *ptr)
2850 {
2851     dVAR;
2852     Sigsave_t hstat, istat, qstat;
2853     int status;
2854     SV **svp;
2855     Pid_t pid;
2856     Pid_t pid2;
2857     bool close_failed;
2858     dSAVEDERRNO;
2859
2860     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
2861     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
2862     SvREFCNT_dec(*svp);
2863     *svp = &PL_sv_undef;
2864 #ifdef OS2
2865     if (pid == -1) {                    /* Opened by popen. */
2866         return my_syspclose(ptr);
2867     }
2868 #endif
2869     close_failed = (PerlIO_close(ptr) == EOF);
2870     SAVE_ERRNO;
2871 #ifdef UTS
2872     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
2873 #endif
2874 #ifndef PERL_MICRO
2875     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
2876     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
2877     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
2878 #endif
2879     do {
2880         pid2 = wait4pid(pid, &status, 0);
2881     } while (pid2 == -1 && errno == EINTR);
2882 #ifndef PERL_MICRO
2883     rsignal_restore(SIGHUP, &hstat);
2884     rsignal_restore(SIGINT, &istat);
2885     rsignal_restore(SIGQUIT, &qstat);
2886 #endif
2887     if (close_failed) {
2888         RESTORE_ERRNO;
2889         return -1;
2890     }
2891     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
2892 }
2893 #else
2894 #if defined(__LIBCATAMOUNT__)
2895 I32
2896 Perl_my_pclose(pTHX_ PerlIO *ptr)
2897 {
2898     return -1;
2899 }
2900 #endif
2901 #endif /* !DOSISH */
2902
2903 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
2904 I32
2905 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
2906 {
2907     dVAR;
2908     I32 result = 0;
2909     PERL_ARGS_ASSERT_WAIT4PID;
2910     if (!pid)
2911         return -1;
2912 #ifdef PERL_USES_PL_PIDSTATUS
2913     {
2914         if (pid > 0) {
2915             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2916                pid, rather than a string form.  */
2917             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
2918             if (svp && *svp != &PL_sv_undef) {
2919                 *statusp = SvIVX(*svp);
2920                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2921                                 G_DISCARD);
2922                 return pid;
2923             }
2924         }
2925         else {
2926             HE *entry;
2927
2928             hv_iterinit(PL_pidstatus);
2929             if ((entry = hv_iternext(PL_pidstatus))) {
2930                 SV * const sv = hv_iterval(PL_pidstatus,entry);
2931                 I32 len;
2932                 const char * const spid = hv_iterkey(entry,&len);
2933
2934                 assert (len == sizeof(Pid_t));
2935                 memcpy((char *)&pid, spid, len);
2936                 *statusp = SvIVX(sv);
2937                 /* The hash iterator is currently on this entry, so simply
2938                    calling hv_delete would trigger the lazy delete, which on
2939                    aggregate does more work, beacuse next call to hv_iterinit()
2940                    would spot the flag, and have to call the delete routine,
2941                    while in the meantime any new entries can't re-use that
2942                    memory.  */
2943                 hv_iterinit(PL_pidstatus);
2944                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
2945                 return pid;
2946             }
2947         }
2948     }
2949 #endif
2950 #ifdef HAS_WAITPID
2951 #  ifdef HAS_WAITPID_RUNTIME
2952     if (!HAS_WAITPID_RUNTIME)
2953         goto hard_way;
2954 #  endif
2955     result = PerlProc_waitpid(pid,statusp,flags);
2956     goto finish;
2957 #endif
2958 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
2959     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
2960     goto finish;
2961 #endif
2962 #ifdef PERL_USES_PL_PIDSTATUS
2963 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
2964   hard_way:
2965 #endif
2966     {
2967         if (flags)
2968             Perl_croak(aTHX_ "Can't do waitpid with flags");
2969         else {
2970             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
2971                 pidgone(result,*statusp);
2972             if (result < 0)
2973                 *statusp = -1;
2974         }
2975     }
2976 #endif
2977 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
2978   finish:
2979 #endif
2980     if (result < 0 && errno == EINTR) {
2981         PERL_ASYNC_CHECK();
2982         errno = EINTR; /* reset in case a signal handler changed $! */
2983     }
2984     return result;
2985 }
2986 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
2987
2988 #ifdef PERL_USES_PL_PIDSTATUS
2989 void
2990 S_pidgone(pTHX_ Pid_t pid, int status)
2991 {
2992     register SV *sv;
2993
2994     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
2995     SvUPGRADE(sv,SVt_IV);
2996     SvIV_set(sv, status);
2997     return;
2998 }
2999 #endif
3000
3001 #if defined(atarist) || defined(OS2) || defined(EPOC)
3002 int pclose();
3003 #ifdef HAS_FORK
3004 int                                     /* Cannot prototype with I32
3005                                            in os2ish.h. */
3006 my_syspclose(PerlIO *ptr)
3007 #else
3008 I32
3009 Perl_my_pclose(pTHX_ PerlIO *ptr)
3010 #endif
3011 {
3012     /* Needs work for PerlIO ! */
3013     FILE * const f = PerlIO_findFILE(ptr);
3014     const I32 result = pclose(f);
3015     PerlIO_releaseFILE(ptr,f);
3016     return result;
3017 }
3018 #endif
3019
3020 #if defined(DJGPP)
3021 int djgpp_pclose();
3022 I32
3023 Perl_my_pclose(pTHX_ PerlIO *ptr)
3024 {
3025     /* Needs work for PerlIO ! */
3026     FILE * const f = PerlIO_findFILE(ptr);
3027     I32 result = djgpp_pclose(f);
3028     result = (result << 8) & 0xff00;
3029     PerlIO_releaseFILE(ptr,f);
3030     return result;
3031 }
3032 #endif
3033
3034 #define PERL_REPEATCPY_LINEAR 4
3035 void
3036 Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
3037 {
3038     PERL_ARGS_ASSERT_REPEATCPY;
3039
3040     if (len == 1)
3041         memset(to, *from, count);
3042     else if (count) {
3043         register char *p = to;
3044         I32 items, linear, half;
3045
3046         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3047         for (items = 0; items < linear; ++items) {
3048             register const char *q = from;
3049             I32 todo;
3050             for (todo = len; todo > 0; todo--)
3051                 *p++ = *q++;
3052         }
3053
3054         half = count / 2;
3055         while (items <= half) {
3056             I32 size = items * len;
3057             memcpy(p, to, size);
3058             p     += size;
3059             items *= 2;
3060         }
3061
3062         if (count > items)
3063             memcpy(p, to, (count - items) * len);
3064     }
3065 }
3066
3067 #ifndef HAS_RENAME
3068 I32
3069 Perl_same_dirent(pTHX_ const char *a, const char *b)
3070 {
3071     char *fa = strrchr(a,'/');
3072     char *fb = strrchr(b,'/');
3073     Stat_t tmpstatbuf1;
3074     Stat_t tmpstatbuf2;
3075     SV * const tmpsv = sv_newmortal();
3076
3077     PERL_ARGS_ASSERT_SAME_DIRENT;
3078
3079     if (fa)
3080         fa++;
3081     else
3082         fa = a;
3083     if (fb)
3084         fb++;
3085     else
3086         fb = b;
3087     if (strNE(a,b))
3088         return FALSE;
3089     if (fa == a)
3090         sv_setpvs(tmpsv, ".");
3091     else
3092         sv_setpvn(tmpsv, a, fa - a);
3093     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3094         return FALSE;
3095     if (fb == b)
3096         sv_setpvs(tmpsv, ".");
3097     else
3098         sv_setpvn(tmpsv, b, fb - b);
3099     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3100         return FALSE;
3101     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3102            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3103 }
3104 #endif /* !HAS_RENAME */
3105
3106 char*
3107 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3108                  const char *const *const search_ext, I32 flags)
3109 {
3110     dVAR;
3111     const char *xfound = NULL;
3112     char *xfailed = NULL;
3113     char tmpbuf[MAXPATHLEN];
3114     register char *s;
3115     I32 len = 0;
3116     int retval;
3117     char *bufend;
3118 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3119 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3120 #  define MAX_EXT_LEN 4
3121 #endif
3122 #ifdef OS2
3123 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3124 #  define MAX_EXT_LEN 4
3125 #endif
3126 #ifdef VMS
3127 #  define SEARCH_EXTS ".pl", ".com", NULL
3128 #  define MAX_EXT_LEN 4
3129 #endif
3130     /* additional extensions to try in each dir if scriptname not found */
3131 #ifdef SEARCH_EXTS
3132     static const char *const exts[] = { SEARCH_EXTS };
3133     const char *const *const ext = search_ext ? search_ext : exts;
3134     int extidx = 0, i = 0;
3135     const char *curext = NULL;
3136 #else
3137     PERL_UNUSED_ARG(search_ext);
3138 #  define MAX_EXT_LEN 0
3139 #endif
3140
3141     PERL_ARGS_ASSERT_FIND_SCRIPT;
3142
3143     /*
3144      * If dosearch is true and if scriptname does not contain path
3145      * delimiters, search the PATH for scriptname.
3146      *
3147      * If SEARCH_EXTS is also defined, will look for each
3148      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3149      * while searching the PATH.
3150      *
3151      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3152      * proceeds as follows:
3153      *   If DOSISH or VMSISH:
3154      *     + look for ./scriptname{,.foo,.bar}
3155      *     + search the PATH for scriptname{,.foo,.bar}
3156      *
3157      *   If !DOSISH:
3158      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3159      *       this will not look in '.' if it's not in the PATH)
3160      */
3161     tmpbuf[0] = '\0';
3162
3163 #ifdef VMS
3164 #  ifdef ALWAYS_DEFTYPES
3165     len = strlen(scriptname);
3166     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3167         int idx = 0, deftypes = 1;
3168         bool seen_dot = 1;
3169
3170         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3171 #  else
3172     if (dosearch) {
3173         int idx = 0, deftypes = 1;
3174         bool seen_dot = 1;
3175
3176         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3177 #  endif
3178         /* The first time through, just add SEARCH_EXTS to whatever we
3179          * already have, so we can check for default file types. */
3180         while (deftypes ||
3181                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3182         {
3183             if (deftypes) {
3184                 deftypes = 0;
3185                 *tmpbuf = '\0';
3186             }
3187             if ((strlen(tmpbuf) + strlen(scriptname)
3188                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3189                 continue;       /* don't search dir with too-long name */
3190             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3191 #else  /* !VMS */
3192
3193 #ifdef DOSISH
3194     if (strEQ(scriptname, "-"))
3195         dosearch = 0;
3196     if (dosearch) {             /* Look in '.' first. */
3197         const char *cur = scriptname;
3198 #ifdef SEARCH_EXTS
3199         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3200             while (ext[i])
3201                 if (strEQ(ext[i++],curext)) {
3202                     extidx = -1;                /* already has an ext */
3203                     break;
3204                 }
3205         do {
3206 #endif
3207             DEBUG_p(PerlIO_printf(Perl_debug_log,
3208                                   "Looking for %s\n",cur));
3209             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3210                 && !S_ISDIR(PL_statbuf.st_mode)) {
3211                 dosearch = 0;
3212                 scriptname = cur;
3213 #ifdef SEARCH_EXTS
3214                 break;
3215 #endif
3216             }
3217 #ifdef SEARCH_EXTS
3218             if (cur == scriptname) {
3219                 len = strlen(scriptname);
3220                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3221                     break;
3222                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3223                 cur = tmpbuf;
3224             }
3225         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3226                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3227 #endif
3228     }
3229 #endif
3230
3231     if (dosearch && !strchr(scriptname, '/')
3232 #ifdef DOSISH
3233                  && !strchr(scriptname, '\\')
3234 #endif
3235                  && (s = PerlEnv_getenv("PATH")))
3236     {
3237         bool seen_dot = 0;
3238
3239         bufend = s + strlen(s);
3240         while (s < bufend) {
3241 #if defined(atarist) || defined(DOSISH)
3242             for (len = 0; *s
3243 #  ifdef atarist
3244                     && *s != ','
3245 #  endif
3246                     && *s != ';'; len++, s++) {
3247                 if (len < sizeof tmpbuf)
3248                     tmpbuf[len] = *s;
3249             }
3250             if (len < sizeof tmpbuf)
3251                 tmpbuf[len] = '\0';
3252 #else  /* ! (atarist || DOSISH) */
3253             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3254                         ':',
3255                         &len);
3256 #endif /* ! (atarist || DOSISH) */
3257             if (s < bufend)
3258                 s++;
3259             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3260                 continue;       /* don't search dir with too-long name */
3261             if (len
3262 #  if defined(atarist) || defined(DOSISH)
3263                 && tmpbuf[len - 1] != '/'
3264                 && tmpbuf[len - 1] != '\\'
3265 #  endif
3266                )
3267                 tmpbuf[len++] = '/';
3268             if (len == 2 && tmpbuf[0] == '.')
3269                 seen_dot = 1;
3270             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3271 #endif  /* !VMS */
3272
3273 #ifdef SEARCH_EXTS
3274             len = strlen(tmpbuf);
3275             if (extidx > 0)     /* reset after previous loop */
3276                 extidx = 0;
3277             do {
3278 #endif
3279                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3281                 if (S_ISDIR(PL_statbuf.st_mode)) {
3282                     retval = -1;
3283                 }
3284 #ifdef SEARCH_EXTS
3285             } while (  retval < 0               /* not there */
3286                     && extidx>=0 && ext[extidx] /* try an extension? */
3287                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3288                 );
3289 #endif
3290             if (retval < 0)
3291                 continue;
3292             if (S_ISREG(PL_statbuf.st_mode)
3293                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3294 #if !defined(DOSISH)
3295                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3296 #endif
3297                 )
3298             {
3299                 xfound = tmpbuf;                /* bingo! */
3300                 break;
3301             }
3302             if (!xfailed)
3303                 xfailed = savepv(tmpbuf);
3304         }
3305 #ifndef DOSISH
3306         if (!xfound && !seen_dot && !xfailed &&
3307             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3308              || S_ISDIR(PL_statbuf.st_mode)))
3309 #endif
3310             seen_dot = 1;                       /* Disable message. */
3311         if (!xfound) {
3312             if (flags & 1) {                    /* do or die? */
3313                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3314                       (xfailed ? "execute" : "find"),
3315                       (xfailed ? xfailed : scriptname),
3316                       (xfailed ? "" : " on PATH"),
3317                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3318             }
3319             scriptname = NULL;
3320         }
3321         Safefree(xfailed);
3322         scriptname = xfound;
3323     }
3324     return (scriptname ? savepv(scriptname) : NULL);
3325 }
3326
3327 #ifndef PERL_GET_CONTEXT_DEFINED
3328
3329 void *
3330 Perl_get_context(void)
3331 {
3332     dVAR;
3333 #if defined(USE_ITHREADS)
3334 #  ifdef OLD_PTHREADS_API
3335     pthread_addr_t t;
3336     if (pthread_getspecific(PL_thr_key, &t))
3337         Perl_croak_nocontext("panic: pthread_getspecific");
3338     return (void*)t;
3339 #  else
3340 #    ifdef I_MACH_CTHREADS
3341     return (void*)cthread_data(cthread_self());
3342 #    else
3343     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3344 #    endif
3345 #  endif
3346 #else
3347     return (void*)NULL;
3348 #endif
3349 }
3350
3351 void
3352 Perl_set_context(void *t)
3353 {
3354     dVAR;
3355     PERL_ARGS_ASSERT_SET_CONTEXT;
3356 #if defined(USE_ITHREADS)
3357 #  ifdef I_MACH_CTHREADS
3358     cthread_set_data(cthread_self(), t);
3359 #  else
3360     if (pthread_setspecific(PL_thr_key, t))
3361         Perl_croak_nocontext("panic: pthread_setspecific");
3362 #  endif
3363 #else
3364     PERL_UNUSED_ARG(t);
3365 #endif
3366 }
3367
3368 #endif /* !PERL_GET_CONTEXT_DEFINED */
3369
3370 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3371 struct perl_vars *
3372 Perl_GetVars(pTHX)
3373 {
3374  return &PL_Vars;
3375 }
3376 #endif
3377
3378 char **
3379 Perl_get_op_names(pTHX)
3380 {
3381     PERL_UNUSED_CONTEXT;
3382     return (char **)PL_op_name;
3383 }
3384
3385 char **
3386 Perl_get_op_descs(pTHX)
3387 {
3388     PERL_UNUSED_CONTEXT;
3389     return (char **)PL_op_desc;
3390 }
3391
3392 const char *
3393 Perl_get_no_modify(pTHX)
3394 {
3395     PERL_UNUSED_CONTEXT;
3396     return PL_no_modify;
3397 }
3398
3399 U32 *
3400 Perl_get_opargs(pTHX)
3401 {
3402     PERL_UNUSED_CONTEXT;
3403     return (U32 *)PL_opargs;
3404 }
3405
3406 PPADDR_t*
3407 Perl_get_ppaddr(pTHX)
3408 {
3409     dVAR;
3410     PERL_UNUSED_CONTEXT;
3411     return (PPADDR_t*)PL_ppaddr;
3412 }
3413
3414 #ifndef HAS_GETENV_LEN
3415 char *
3416 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3417 {
3418     char * const env_trans = PerlEnv_getenv(env_elem);
3419     PERL_UNUSED_CONTEXT;
3420     PERL_ARGS_ASSERT_GETENV_LEN;
3421     if (env_trans)
3422         *len = strlen(env_trans);
3423     return env_trans;
3424 }
3425 #endif
3426
3427
3428 MGVTBL*
3429 Perl_get_vtbl(pTHX_ int vtbl_id)
3430 {
3431     const MGVTBL* result;
3432     PERL_UNUSED_CONTEXT;
3433
3434     switch(vtbl_id) {
3435     case want_vtbl_sv:
3436         result = &PL_vtbl_sv;
3437         break;
3438     case want_vtbl_env:
3439         result = &PL_vtbl_env;
3440         break;
3441     case want_vtbl_envelem:
3442         result = &PL_vtbl_envelem;
3443         break;
3444     case want_vtbl_sig:
3445         result = &PL_vtbl_sig;
3446         break;
3447     case want_vtbl_sigelem:
3448         result = &PL_vtbl_sigelem;
3449         break;
3450     case want_vtbl_pack:
3451         result = &PL_vtbl_pack;
3452         break;
3453     case want_vtbl_packelem:
3454         result = &PL_vtbl_packelem;
3455         break;
3456     case want_vtbl_dbline:
3457         result = &PL_vtbl_dbline;
3458         break;
3459     case want_vtbl_isa:
3460         result = &PL_vtbl_isa;
3461         break;
3462     case want_vtbl_isaelem:
3463         result = &PL_vtbl_isaelem;
3464         break;
3465     case want_vtbl_arylen:
3466         result = &PL_vtbl_arylen;
3467         break;
3468     case want_vtbl_mglob:
3469         result = &PL_vtbl_mglob;
3470         break;
3471     case want_vtbl_nkeys:
3472         result = &PL_vtbl_nkeys;
3473         break;
3474     case want_vtbl_taint:
3475         result = &PL_vtbl_taint;
3476         break;
3477     case want_vtbl_substr:
3478         result = &PL_vtbl_substr;
3479         break;
3480     case want_vtbl_vec:
3481         result = &PL_vtbl_vec;
3482         break;
3483     case want_vtbl_pos:
3484         result = &PL_vtbl_pos;
3485         break;
3486     case want_vtbl_bm:
3487         result = &PL_vtbl_bm;
3488         break;
3489     case want_vtbl_fm:
3490         result = &PL_vtbl_fm;
3491         break;
3492     case want_vtbl_uvar:
3493         result = &PL_vtbl_uvar;
3494         break;
3495     case want_vtbl_defelem:
3496         result = &PL_vtbl_defelem;
3497         break;
3498     case want_vtbl_regexp:
3499         result = &PL_vtbl_regexp;
3500         break;
3501     case want_vtbl_regdata:
3502         result = &PL_vtbl_regdata;
3503         break;
3504     case want_vtbl_regdatum:
3505         result = &PL_vtbl_regdatum;
3506         break;
3507 #ifdef USE_LOCALE_COLLATE
3508     case want_vtbl_collxfrm:
3509         result = &PL_vtbl_collxfrm;
3510         break;
3511 #endif
3512     case want_vtbl_amagic:
3513         result = &PL_vtbl_amagic;
3514         break;
3515     case want_vtbl_amagicelem:
3516         result = &PL_vtbl_amagicelem;
3517         break;
3518     case want_vtbl_backref:
3519         result = &PL_vtbl_backref;
3520         break;
3521     case want_vtbl_utf8:
3522         result = &PL_vtbl_utf8;
3523         break;
3524     default:
3525         result = NULL;
3526         break;
3527     }
3528     return (MGVTBL*)result;
3529 }
3530
3531 I32
3532 Perl_my_fflush_all(pTHX)
3533 {
3534 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3535     return PerlIO_flush(NULL);
3536 #else
3537 # if defined(HAS__FWALK)
3538     extern int fflush(FILE *);
3539     /* undocumented, unprototyped, but very useful BSDism */
3540     extern void _fwalk(int (*)(FILE *));
3541     _fwalk(&fflush);
3542     return 0;
3543 # else
3544 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3545     long open_max = -1;
3546 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3547     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3548 #   else
3549 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3550     open_max = sysconf(_SC_OPEN_MAX);
3551 #     else
3552 #      ifdef FOPEN_MAX
3553     open_max = FOPEN_MAX;
3554 #      else
3555 #       ifdef OPEN_MAX
3556     open_max = OPEN_MAX;
3557 #       else
3558 #        ifdef _NFILE
3559     open_max = _NFILE;
3560 #        endif
3561 #       endif
3562 #      endif
3563 #     endif
3564 #    endif
3565     if (open_max > 0) {
3566       long i;
3567       for (i = 0; i < open_max; i++)
3568             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3569                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3570                 STDIO_STREAM_ARRAY[i]._flag)
3571                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3572       return 0;
3573     }
3574 #  endif
3575     SETERRNO(EBADF,RMS_IFI);
3576     return EOF;
3577 # endif
3578 #endif
3579 }
3580
3581 void
3582 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3583 {
3584     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3585
3586     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3587         if (ckWARN(WARN_IO)) {
3588             const char * const direction =
3589                 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3590             if (name && *name)
3591                 Perl_warner(aTHX_ packWARN(WARN_IO),
3592                             "Filehandle %s opened only for %sput",
3593                             name, direction);
3594             else
3595                 Perl_warner(aTHX_ packWARN(WARN_IO),
3596                             "Filehandle opened only for %sput", direction);
3597         }
3598     }
3599     else {
3600         const char *vile;
3601         I32   warn_type;
3602
3603         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3604             vile = "closed";
3605             warn_type = WARN_CLOSED;
3606         }
3607         else {
3608             vile = "unopened";
3609             warn_type = WARN_UNOPENED;
3610         }
3611
3612         if (ckWARN(warn_type)) {
3613             const char * const pars =
3614                 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3615             const char * const func =
3616                 (const char *)
3617                 (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
3618                  op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
3619                  op < 0              ? "" :              /* handle phoney cases */
3620                  PL_op_desc[op]);
3621             const char * const type =
3622                 (const char *)
3623                 (OP_IS_SOCKET(op) ||
3624                  (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3625                  "socket" : "filehandle");
3626             if (name && *name) {
3627                 Perl_warner(aTHX_ packWARN(warn_type),
3628                             "%s%s on %s %s %s", func, pars, vile, type, name);
3629                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3630                     Perl_warner(
3631                         aTHX_ packWARN(warn_type),
3632                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3633                         func, pars, name
3634                     );
3635             }
3636             else {
3637                 Perl_warner(aTHX_ packWARN(warn_type),
3638                             "%s%s on %s %s", func, pars, vile, type);
3639                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3640                     Perl_warner(
3641                         aTHX_ packWARN(warn_type),
3642                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3643                         func, pars
3644                     );
3645             }
3646         }
3647     }
3648 }
3649
3650 #ifdef EBCDIC
3651 /* in ASCII order, not that it matters */
3652 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3653
3654 int
3655 Perl_ebcdic_control(pTHX_ int ch)
3656 {
3657     if (ch > 'a') {
3658         const char *ctlp;
3659
3660         if (islower(ch))
3661             ch = toupper(ch);
3662
3663         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3664             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3665         }
3666
3667         if (ctlp == controllablechars)
3668             return('\177'); /* DEL */
3669         else
3670             return((unsigned char)(ctlp - controllablechars - 1));
3671     } else { /* Want uncontrol */
3672         if (ch == '\177' || ch == -1)
3673             return('?');
3674         else if (ch == '\157')
3675             return('\177');
3676         else if (ch == '\174')
3677             return('\000');
3678         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3679             return('\036');
3680         else if (ch == '\155')
3681             return('\037');
3682         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3683             return(controllablechars[ch+1]);
3684         else
3685             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3686     }
3687 }
3688 #endif
3689
3690 /* To workaround core dumps from the uninitialised tm_zone we get the
3691  * system to give us a reasonable struct to copy.  This fix means that
3692  * strftime uses the tm_zone and tm_gmtoff values returned by
3693  * localtime(time()). That should give the desired result most of the
3694  * time. But probably not always!
3695  *
3696  * This does not address tzname aspects of NETaa14816.
3697  *
3698  */
3699
3700 #ifdef HAS_GNULIBC
3701 # ifndef STRUCT_TM_HASZONE
3702 #    define STRUCT_TM_HASZONE
3703 # endif
3704 #endif
3705
3706 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3707 # ifndef HAS_TM_TM_ZONE
3708 #    define HAS_TM_TM_ZONE
3709 # endif
3710 #endif
3711
3712 void
3713 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3714 {
3715 #ifdef HAS_TM_TM_ZONE
3716     Time_t now;
3717     const struct tm* my_tm;
3718     PERL_ARGS_ASSERT_INIT_TM;
3719     (void)time(&now);
3720     my_tm = localtime(&now);
3721     if (my_tm)
3722         Copy(my_tm, ptm, 1, struct tm);
3723 #else
3724     PERL_ARGS_ASSERT_INIT_TM;
3725     PERL_UNUSED_ARG(ptm);
3726 #endif
3727 }
3728
3729 /*
3730  * mini_mktime - normalise struct tm values without the localtime()
3731  * semantics (and overhead) of mktime().
3732  */
3733 void
3734 Perl_mini_mktime(pTHX_ struct tm *ptm)
3735 {
3736     int yearday;
3737     int secs;
3738     int month, mday, year, jday;
3739     int odd_cent, odd_year;
3740     PERL_UNUSED_CONTEXT;
3741
3742     PERL_ARGS_ASSERT_MINI_MKTIME;
3743
3744 #define DAYS_PER_YEAR   365
3745 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3746 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3747 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3748 #define SECS_PER_HOUR   (60*60)
3749 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3750 /* parentheses deliberately absent on these two, otherwise they don't work */
3751 #define MONTH_TO_DAYS   153/5
3752 #define DAYS_TO_MONTH   5/153
3753 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3754 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3755 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3756 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3757
3758 /*
3759  * Year/day algorithm notes:
3760  *
3761  * With a suitable offset for numeric value of the month, one can find
3762  * an offset into the year by considering months to have 30.6 (153/5) days,
3763  * using integer arithmetic (i.e., with truncation).  To avoid too much
3764  * messing about with leap days, we consider January and February to be
3765  * the 13th and 14th month of the previous year.  After that transformation,
3766  * we need the month index we use to be high by 1 from 'normal human' usage,
3767  * so the month index values we use run from 4 through 15.
3768  *
3769  * Given that, and the rules for the Gregorian calendar (leap years are those
3770  * divisible by 4 unless also divisible by 100, when they must be divisible
3771  * by 400 instead), we can simply calculate the number of days since some
3772  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3773  * the days we derive from our month index, and adding in the day of the
3774  * month.  The value used here is not adjusted for the actual origin which
3775  * it normally would use (1 January A.D. 1), since we're not exposing it.
3776  * We're only building the value so we can turn around and get the
3777  * normalised values for the year, month, day-of-month, and day-of-year.
3778  *
3779  * For going backward, we need to bias the value we're using so that we find
3780  * the right year value.  (Basically, we don't want the contribution of
3781  * March 1st to the number to apply while deriving the year).  Having done
3782  * that, we 'count up' the contribution to the year number by accounting for
3783  * full quadracenturies (400-year periods) with their extra leap days, plus
3784  * the contribution from full centuries (to avoid counting in the lost leap
3785  * days), plus the contribution from full quad-years (to count in the normal
3786  * leap days), plus the leftover contribution from any non-leap years.
3787  * At this point, if we were working with an actual leap day, we'll have 0
3788  * days left over.  This is also true for March 1st, however.  So, we have
3789  * to special-case that result, and (earlier) keep track of the 'odd'
3790  * century and year contributions.  If we got 4 extra centuries in a qcent,
3791  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3792  * Otherwise, we add back in the earlier bias we removed (the 123 from
3793  * figuring in March 1st), find the month index (integer division by 30.6),
3794  * and the remainder is the day-of-month.  We then have to convert back to
3795  * 'real' months (including fixing January and February from being 14/15 in
3796  * the previous year to being in the proper year).  After that, to get
3797  * tm_yday, we work with the normalised year and get a new yearday value for
3798  * January 1st, which we subtract from the yearday value we had earlier,
3799  * representing the date we've re-built.  This is done from January 1
3800  * because tm_yday is 0-origin.
3801  *
3802  * Since POSIX time routines are only guaranteed to work for times since the
3803  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3804  * applies Gregorian calendar rules even to dates before the 16th century
3805  * doesn't bother me.  Besides, you'd need cultural context for a given
3806  * date to know whether it was Julian or Gregorian calendar, and that's
3807  * outside the scope for this routine.  Since we convert back based on the
3808  * same rules we used to build the yearday, you'll only get strange results
3809  * for input which needed normalising, or for the 'odd' century years which
3810  * were leap years in the Julian calander but not in the Gregorian one.
3811  * I can live with that.
3812  *
3813  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3814  * that's still outside the scope for POSIX time manipulation, so I don't
3815  * care.
3816  */
3817
3818     year = 1900 + ptm->tm_year;
3819     month = ptm->tm_mon;
3820     mday = ptm->tm_mday;
3821     /* allow given yday with no month & mday to dominate the result */
3822     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3823         month = 0;
3824         mday = 0;
3825         jday = 1 + ptm->tm_yday;
3826     }
3827     else {
3828         jday = 0;
3829     }
3830     if (month >= 2)
3831         month+=2;
3832     else
3833         month+=14, year--;
3834     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3835     yearday += month*MONTH_TO_DAYS + mday + jday;
3836     /*
3837      * Note that we don't know when leap-seconds were or will be,
3838      * so we have to trust the user if we get something which looks
3839      * like a sensible leap-second.  Wild values for seconds will
3840      * be rationalised, however.
3841      */
3842     if ((unsigned) ptm->tm_sec <= 60) {
3843         secs = 0;
3844     }
3845     else {
3846         secs = ptm->tm_sec;
3847         ptm->tm_sec = 0;
3848     }
3849     secs += 60 * ptm->tm_min;
3850     secs += SECS_PER_HOUR * ptm->tm_hour;
3851     if (secs < 0) {
3852         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3853             /* got negative remainder, but need positive time */
3854             /* back off an extra day to compensate */
3855             yearday += (secs/SECS_PER_DAY)-1;
3856             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3857         }
3858         else {
3859             yearday += (secs/SECS_PER_DAY);
3860             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3861         }
3862     }
3863     else if (secs >= SECS_PER_DAY) {
3864         yearday += (secs/SECS_PER_DAY);
3865         secs %= SECS_PER_DAY;
3866     }
3867     ptm->tm_hour = secs/SECS_PER_HOUR;
3868     secs %= SECS_PER_HOUR;
3869     ptm->tm_min = secs/60;
3870     secs %= 60;
3871     ptm->tm_sec += secs;
3872     /* done with time of day effects */
3873     /*
3874      * The algorithm for yearday has (so far) left it high by 428.
3875      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3876      * bias it by 123 while trying to figure out what year it
3877      * really represents.  Even with this tweak, the reverse
3878      * translation fails for years before A.D. 0001.
3879      * It would still fail for Feb 29, but we catch that one below.
3880      */
3881     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3882     yearday -= YEAR_ADJUST;
3883     year = (yearday / DAYS_PER_QCENT) * 400;
3884     yearday %= DAYS_PER_QCENT;
3885     odd_cent = yearday / DAYS_PER_CENT;
3886     year += odd_cent * 100;
3887     yearday %= DAYS_PER_CENT;
3888     year += (yearday / DAYS_PER_QYEAR) * 4;
3889     yearday %= DAYS_PER_QYEAR;
3890     odd_year = yearday / DAYS_PER_YEAR;
3891     year += odd_year;
3892     yearday %= DAYS_PER_YEAR;
3893     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3894         month = 1;
3895         yearday = 29;
3896     }
3897     else {
3898         yearday += YEAR_ADJUST; /* recover March 1st crock */
3899         month = yearday*DAYS_TO_MONTH;
3900         yearday -= month*MONTH_TO_DAYS;
3901         /* recover other leap-year adjustment */
3902         if (month > 13) {
3903             month-=14;
3904             year++;
3905         }
3906         else {
3907             month-=2;
3908         }
3909     }
3910     ptm->tm_year = year - 1900;
3911     if (yearday) {
3912       ptm->tm_mday = yearday;
3913       ptm->tm_mon = month;
3914     }
3915     else {
3916       ptm->tm_mday = 31;
3917       ptm->tm_mon = month - 1;
3918     }
3919     /* re-build yearday based on Jan 1 to get tm_yday */
3920     year--;
3921     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3922     yearday += 14*MONTH_TO_DAYS + 1;
3923     ptm->tm_yday = jday - yearday;
3924     /* fix tm_wday if not overridden by caller */
3925     if ((unsigned)ptm->tm_wday > 6)
3926         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3927 }
3928
3929 char *
3930 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)
3931 {
3932 #ifdef HAS_STRFTIME
3933   char *buf;
3934   int buflen;
3935   struct tm mytm;
3936   int len;
3937
3938   PERL_ARGS_ASSERT_MY_STRFTIME;
3939
3940   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3941   mytm.tm_sec = sec;
3942   mytm.tm_min = min;
3943   mytm.tm_hour = hour;
3944   mytm.tm_mday = mday;
3945   mytm.tm_mon = mon;
3946   mytm.tm_year = year;
3947   mytm.tm_wday = wday;
3948   mytm.tm_yday = yday;
3949   mytm.tm_isdst = isdst;
3950   mini_mktime(&mytm);
3951   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3952 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3953   STMT_START {
3954     struct tm mytm2;
3955     mytm2 = mytm;
3956     mktime(&mytm2);
3957 #ifdef HAS_TM_TM_GMTOFF
3958     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3959 #endif
3960 #ifdef HAS_TM_TM_ZONE
3961     mytm.tm_zone = mytm2.tm_zone;
3962 #endif
3963   } STMT_END;
3964 #endif
3965   buflen = 64;
3966   Newx(buf, buflen, char);
3967   len = strftime(buf, buflen, fmt, &mytm);
3968   /*
3969   ** The following is needed to handle to the situation where
3970   ** tmpbuf overflows.  Basically we want to allocate a buffer
3971   ** and try repeatedly.  The reason why it is so complicated
3972   ** is that getting a return value of 0 from strftime can indicate
3973   ** one of the following:
3974   ** 1. buffer overflowed,
3975   ** 2. illegal conversion specifier, or
3976   ** 3. the format string specifies nothing to be returned(not
3977   **      an error).  This could be because format is an empty string
3978   **    or it specifies %p that yields an empty string in some locale.
3979   ** If there is a better way to make it portable, go ahead by
3980   ** all means.
3981   */
3982   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3983     return buf;
3984   else {
3985     /* Possibly buf overflowed - try again with a bigger buf */
3986     const int fmtlen = strlen(fmt);
3987     int bufsize = fmtlen + buflen;
3988
3989     Newx(buf, bufsize, char);
3990     while (buf) {
3991       buflen = strftime(buf, bufsize, fmt, &mytm);
3992       if (buflen > 0 && buflen < bufsize)
3993         break;
3994       /* heuristic to prevent out-of-memory errors */
3995       if (bufsize > 100*fmtlen) {
3996         Safefree(buf);
3997         buf = NULL;
3998         break;
3999       }
4000       bufsize *= 2;
4001       Renew(buf, bufsize, char);
4002     }
4003     return buf;
4004   }
4005 #else
4006   Perl_croak(aTHX_ "panic: no strftime");
4007   return NULL;
4008 #endif
4009 }
4010
4011
4012 #define SV_CWD_RETURN_UNDEF \
4013 sv_setsv(sv, &PL_sv_undef); \
4014 return FALSE
4015
4016 #define SV_CWD_ISDOT(dp) \
4017     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4018         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4019
4020 /*
4021 =head1 Miscellaneous Functions
4022
4023 =for apidoc getcwd_sv
4024
4025 Fill the sv with current working directory
4026
4027 =cut
4028 */
4029
4030 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4031  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4032  * getcwd(3) if available
4033  * Comments from the orignal:
4034  *     This is a faster version of getcwd.  It's also more dangerous
4035  *     because you might chdir out of a directory that you can't chdir
4036  *     back into. */
4037
4038 int
4039 Perl_getcwd_sv(pTHX_ register SV *sv)
4040 {
4041 #ifndef PERL_MICRO
4042     dVAR;
4043 #ifndef INCOMPLETE_TAINTS
4044     SvTAINTED_on(sv);
4045 #endif
4046
4047     PERL_ARGS_ASSERT_GETCWD_SV;
4048
4049 #ifdef HAS_GETCWD
4050     {
4051         char buf[MAXPATHLEN];
4052
4053         /* Some getcwd()s automatically allocate a buffer of the given
4054          * size from the heap if they are given a NULL buffer pointer.
4055          * The problem is that this behaviour is not portable. */
4056         if (getcwd(buf, sizeof(buf) - 1)) {
4057             sv_setpv(sv, buf);
4058             return TRUE;
4059         }
4060         else {
4061             sv_setsv(sv, &PL_sv_undef);
4062             return FALSE;
4063         }
4064     }
4065
4066 #else
4067
4068     Stat_t statbuf;
4069     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4070     int pathlen=0;
4071     Direntry_t *dp;
4072
4073     SvUPGRADE(sv, SVt_PV);
4074
4075     if (PerlLIO_lstat(".", &statbuf) < 0) {
4076         SV_CWD_RETURN_UNDEF;
4077     }
4078
4079     orig_cdev = statbuf.st_dev;
4080     orig_cino = statbuf.st_ino;
4081     cdev = orig_cdev;
4082     cino = orig_cino;
4083
4084     for (;;) {
4085         DIR *dir;
4086         int namelen;
4087         odev = cdev;
4088         oino = cino;
4089
4090         if (PerlDir_chdir("..") < 0) {
4091             SV_CWD_RETURN_UNDEF;
4092         }
4093         if (PerlLIO_stat(".", &statbuf) < 0) {
4094             SV_CWD_RETURN_UNDEF;
4095         }
4096
4097         cdev = statbuf.st_dev;
4098         cino = statbuf.st_ino;
4099
4100         if (odev == cdev && oino == cino) {
4101             break;
4102         }
4103         if (!(dir = PerlDir_open("."))) {
4104             SV_CWD_RETURN_UNDEF;
4105         }
4106
4107         while ((dp = PerlDir_read(dir)) != NULL) {
4108 #ifdef DIRNAMLEN
4109             namelen = dp->d_namlen;
4110 #else
4111             namelen = strlen(dp->d_name);
4112 #endif
4113             /* skip . and .. */
4114             if (SV_CWD_ISDOT(dp)) {
4115                 continue;
4116             }
4117
4118             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4119                 SV_CWD_RETURN_UNDEF;
4120             }
4121
4122             tdev = statbuf.st_dev;
4123             tino = statbuf.st_ino;
4124             if (tino == oino && tdev == odev) {
4125                 break;
4126             }
4127         }
4128
4129         if (!dp) {
4130             SV_CWD_RETURN_UNDEF;
4131         }
4132
4133         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4134             SV_CWD_RETURN_UNDEF;
4135         }
4136
4137         SvGROW(sv, pathlen + namelen + 1);
4138
4139         if (pathlen) {
4140             /* shift down */
4141             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4142         }
4143
4144         /* prepend current directory to the front */
4145         *SvPVX(sv) = '/';
4146         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4147         pathlen += (namelen + 1);
4148
4149 #ifdef VOID_CLOSEDIR
4150         PerlDir_close(dir);
4151 #else
4152         if (PerlDir_close(dir) < 0) {
4153             SV_CWD_RETURN_UNDEF;
4154         }
4155 #endif
4156     }
4157
4158     if (pathlen) {
4159         SvCUR_set(sv, pathlen);
4160         *SvEND(sv) = '\0';
4161         SvPOK_only(sv);
4162
4163         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4164             SV_CWD_RETURN_UNDEF;
4165         }
4166     }
4167     if (PerlLIO_stat(".", &statbuf) < 0) {
4168         SV_CWD_RETURN_UNDEF;
4169     }
4170
4171     cdev = statbuf.st_dev;
4172     cino = statbuf.st_ino;
4173
4174     if (cdev != orig_cdev || cino != orig_cino) {
4175         Perl_croak(aTHX_ "Unstable directory path, "
4176                    "current directory changed unexpectedly");
4177     }
4178
4179     return TRUE;
4180 #endif
4181
4182 #else
4183     return FALSE;
4184 #endif
4185 }
4186
4187 #define VERSION_MAX 0x7FFFFFFF
4188 /*
4189 =for apidoc scan_version
4190
4191 Returns a pointer to the next character after the parsed
4192 version string, as well as upgrading the passed in SV to
4193 an RV.
4194
4195 Function must be called with an already existing SV like
4196
4197     sv = newSV(0);
4198     s = scan_version(s, SV *sv, bool qv);
4199
4200 Performs some preprocessing to the string to ensure that
4201 it has the correct characteristics of a version.  Flags the
4202 object if it contains an underscore (which denotes this
4203 is an alpha version).  The boolean qv denotes that the version
4204 should be interpreted as if it had multiple decimals, even if
4205 it doesn't.
4206
4207 =cut
4208 */
4209
4210 const char *
4211 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4212 {
4213     const char *start;
4214     const char *pos;
4215     const char *last;
4216     int saw_period = 0;
4217     int alpha = 0;
4218     int width = 3;
4219     bool vinf = FALSE;
4220     AV * const av = newAV();
4221     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4222
4223     PERL_ARGS_ASSERT_SCAN_VERSION;
4224
4225     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4226
4227     while (isSPACE(*s)) /* leading whitespace is OK */
4228         s++;
4229
4230     start = last = s;
4231
4232     if (*s == 'v') {
4233         s++;  /* get past 'v' */
4234         qv = 1; /* force quoted version processing */
4235     }
4236
4237     pos = s;
4238
4239     /* pre-scan the input string to check for decimals/underbars */
4240     while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) )
4241     {
4242         if ( *pos == '.' )
4243         {
4244             if ( alpha )
4245                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4246             saw_period++ ;
4247             last = pos;
4248         }
4249         else if ( *pos == '_' )
4250         {
4251             if ( alpha )
4252                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4253             alpha = 1;
4254             width = pos - last - 1; /* natural width of sub-version */
4255         }
4256         else if ( *pos == ',' && isDIGIT(pos[1]) )
4257         {
4258             saw_period++ ;
4259             last = pos;
4260         }
4261
4262         pos++;
4263     }
4264
4265     if ( alpha && !saw_period )
4266         Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4267
4268     if ( alpha && saw_period && width == 0 )
4269         Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4270
4271     if ( saw_period > 1 )
4272         qv = 1; /* force quoted version processing */
4273
4274     last = pos;
4275     pos = s;
4276
4277     if ( qv )
4278         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4279     if ( alpha )
4280         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4281     if ( !qv && width < 3 )
4282         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4283
4284     while (isDIGIT(*pos))
4285         pos++;
4286     if (!isALPHA(*pos)) {
4287         I32 rev;
4288
4289         for (;;) {
4290             rev = 0;
4291             {
4292                 /* this is atoi() that delimits on underscores */
4293                 const char *end = pos;
4294                 I32 mult = 1;
4295                 I32 orev;
4296
4297                 /* the following if() will only be true after the decimal
4298                  * point of a version originally created with a bare
4299                  * floating point number, i.e. not quoted in any way
4300                  */
4301                 if ( !qv && s > start && saw_period == 1 ) {
4302                     mult *= 100;
4303                     while ( s < end ) {
4304                         orev = rev;
4305                         rev += (*s - '0') * mult;
4306                         mult /= 10;
4307                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4308                             || (PERL_ABS(rev) > VERSION_MAX )) {
4309                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4310                                            "Integer overflow in version %d",VERSION_MAX);
4311                             s = end - 1;
4312                             rev = VERSION_MAX;
4313                             vinf = 1;
4314                         }
4315                         s++;
4316                         if ( *s == '_' )
4317                             s++;
4318                     }
4319                 }
4320                 else {
4321                     while (--end >= s) {
4322                         orev = rev;
4323                         rev += (*end - '0') * mult;
4324                         mult *= 10;
4325                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4326                             || (PERL_ABS(rev) > VERSION_MAX )) {
4327                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4328                                            "Integer overflow in version");
4329                             end = s - 1;
4330                             rev = VERSION_MAX;
4331                             vinf = 1;
4332                         }
4333                     }
4334                 }
4335             }
4336
4337             /* Append revision */
4338             av_push(av, newSViv(rev));
4339             if ( vinf ) {
4340                 s = last;
4341                 break;
4342             }
4343             else if ( *pos == '.' )
4344                 s = ++pos;
4345             else if ( *pos == '_' && isDIGIT(pos[1]) )
4346                 s = ++pos;
4347             else if ( *pos == ',' && isDIGIT(pos[1]) )
4348                 s = ++pos;
4349             else if ( isDIGIT(*pos) )
4350                 s = pos;
4351             else {
4352                 s = pos;
4353                 break;
4354             }
4355             if ( qv ) {
4356                 while ( isDIGIT(*pos) )
4357                     pos++;
4358             }
4359             else {
4360                 int digits = 0;
4361                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4362                     if ( *pos != '_' )
4363                         digits++;
4364                     pos++;
4365                 }
4366             }
4367         }
4368     }
4369     if ( qv ) { /* quoted versions always get at least three terms*/
4370         I32 len = av_len(av);
4371         /* This for loop appears to trigger a compiler bug on OS X, as it
4372            loops infinitely. Yes, len is negative. No, it makes no sense.
4373            Compiler in question is:
4374            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4375            for ( len = 2 - len; len > 0; len-- )
4376            av_push(MUTABLE_AV(sv), newSViv(0));
4377         */
4378         len = 2 - len;
4379         while (len-- > 0)
4380             av_push(av, newSViv(0));
4381     }
4382
4383     /* need to save off the current version string for later */
4384     if ( vinf ) {
4385         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4386         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4387         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4388     }
4389     else if ( s > start ) {
4390         SV * orig = newSVpvn(start,s-start);
4391         if ( qv && saw_period == 1 && *start != 'v' ) {
4392             /* need to insert a v to be consistent */
4393             sv_insert(orig, 0, 0, "v", 1);
4394         }
4395         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4396     }
4397     else {
4398         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4399         av_push(av, newSViv(0));
4400     }
4401
4402     /* And finally, store the AV in the hash */
4403     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4404
4405     /* fix RT#19517 - special case 'undef' as string */
4406     if ( *s == 'u' && strEQ(s,"undef") ) {
4407         s += 5;
4408     }
4409
4410     return s;
4411 }
4412
4413 /*
4414 =for apidoc new_version
4415
4416 Returns a new version object based on the passed in SV:
4417
4418     SV *sv = new_version(SV *ver);
4419
4420 Does not alter the passed in ver SV.  See "upg_version" if you
4421 want to upgrade the SV.
4422
4423 =cut
4424 */
4425
4426 SV *
4427 Perl_new_version(pTHX_ SV *ver)
4428 {
4429     dVAR;
4430     SV * const rv = newSV(0);
4431     PERL_ARGS_ASSERT_NEW_VERSION;
4432     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4433     {
4434         I32 key;
4435         AV * const av = newAV();
4436         AV *sav;
4437         /* This will get reblessed later if a derived class*/
4438         SV * const hv = newSVrv(rv, "version");
4439         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4440
4441         if ( SvROK(ver) )
4442             ver = SvRV(ver);
4443
4444         /* Begin copying all of the elements */
4445         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4446             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4447
4448         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4449             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4450
4451         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4452         {
4453             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4454             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4455         }
4456
4457         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4458         {
4459             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4460             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4461         }
4462
4463         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4464         /* This will get reblessed later if a derived class*/
4465         for ( key = 0; key <= av_len(sav); key++ )
4466         {
4467             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4468             av_push(av, newSViv(rev));
4469         }
4470
4471         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4472         return rv;
4473     }
4474 #ifdef SvVOK
4475     {
4476         const MAGIC* const mg = SvVSTRING_mg(ver);
4477         if ( mg ) { /* already a v-string */
4478             const STRLEN len = mg->mg_len;
4479             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4480             sv_setpvn(rv,version,len);
4481             /* this is for consistency with the pure Perl class */
4482             if ( *version != 'v' )
4483                 sv_insert(rv, 0, 0, "v", 1);
4484             Safefree(version);
4485         }
4486         else {
4487 #endif
4488         sv_setsv(rv,ver); /* make a duplicate */
4489 #ifdef SvVOK
4490         }
4491     }
4492 #endif
4493     return upg_version(rv, FALSE);
4494 }
4495
4496 /*
4497 =for apidoc upg_version
4498
4499 In-place upgrade of the supplied SV to a version object.
4500
4501     SV *sv = upg_version(SV *sv, bool qv);
4502
4503 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4504 to force this SV to be interpreted as an "extended" version.
4505
4506 =cut
4507 */
4508
4509 SV *
4510 Perl_upg_version(pTHX_ SV *ver, bool qv)
4511 {
4512     const char *version, *s;
4513 #ifdef SvVOK
4514     const MAGIC *mg;
4515 #endif
4516
4517     PERL_ARGS_ASSERT_UPG_VERSION;
4518
4519     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4520     {
4521         /* may get too much accuracy */
4522         char tbuf[64];
4523 #ifdef USE_LOCALE_NUMERIC
4524         char *loc = setlocale(LC_NUMERIC, "C");
4525 #endif
4526         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4527 #ifdef USE_LOCALE_NUMERIC
4528         setlocale(LC_NUMERIC, loc);
4529 #endif
4530         while (tbuf[len-1] == '0' && len > 0) len--;
4531         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4532         version = savepvn(tbuf, len);
4533     }
4534 #ifdef SvVOK
4535     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4536         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4537         qv = 1;
4538     }
4539 #endif
4540     else /* must be a string or something like a string */
4541     {
4542         STRLEN len;
4543         version = savepv(SvPV(ver,len));
4544 #ifndef SvVOK
4545 #  if PERL_VERSION > 5
4546         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4547         if ( len == 3 && !instr(version,".") && !instr(version,"_") ) {
4548             /* may be a v-string */
4549             SV * const nsv = sv_newmortal();
4550             const char *nver;
4551             const char *pos;
4552             int saw_period = 0;
4553             sv_setpvf(nsv,"v%vd",ver);
4554             pos = nver = savepv(SvPV_nolen(nsv));
4555
4556             /* scan the resulting formatted string */
4557             pos++; /* skip the leading 'v' */
4558             while ( *pos == '.' || isDIGIT(*pos) ) {
4559                 if ( *pos == '.' )
4560                     saw_period++ ;
4561                 pos++;
4562             }
4563
4564             /* is definitely a v-string */
4565             if ( saw_period == 2 ) {
4566                 Safefree(version);
4567                 version = nver;
4568             }
4569         }
4570 #  endif
4571 #endif
4572     }
4573
4574     s = scan_version(version, ver, qv);
4575     if ( *s != '\0' )
4576         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4577                        "Version string '%s' contains invalid data; "
4578                        "ignoring: '%s'", version, s);
4579     Safefree(version);
4580     return ver;
4581 }
4582
4583 /*
4584 =for apidoc vverify
4585
4586 Validates that the SV contains a valid version object.
4587
4588     bool vverify(SV *vobj);
4589
4590 Note that it only confirms the bare minimum structure (so as not to get
4591 confused by derived classes which may contain additional hash entries):
4592
4593 =over 4
4594
4595 =item * The SV contains a [reference to a] hash
4596
4597 =item * The hash contains a "version" key
4598
4599 =item * The "version" key has [a reference to] an AV as its value
4600
4601 =back
4602
4603 =cut
4604 */
4605
4606 bool
4607 Perl_vverify(pTHX_ SV *vs)
4608 {
4609     SV *sv;
4610
4611     PERL_ARGS_ASSERT_VVERIFY;
4612
4613     if ( SvROK(vs) )
4614         vs = SvRV(vs);
4615
4616     /* see if the appropriate elements exist */
4617     if ( SvTYPE(vs) == SVt_PVHV
4618          && hv_exists(MUTABLE_HV(vs), "version", 7)
4619          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4620          && SvTYPE(sv) == SVt_PVAV )
4621         return TRUE;
4622     else
4623         return FALSE;
4624 }
4625
4626 /*
4627 =for apidoc vnumify
4628
4629 Accepts a version object and returns the normalized floating
4630 point representation.  Call like:
4631
4632     sv = vnumify(rv);
4633
4634 NOTE: you can pass either the object directly or the SV
4635 contained within the RV.
4636
4637 =cut
4638 */
4639
4640 SV *
4641 Perl_vnumify(pTHX_ SV *vs)
4642 {
4643     I32 i, len, digit;
4644     int width;
4645     bool alpha = FALSE;
4646     SV * const sv = newSV(0);
4647     AV *av;
4648
4649     PERL_ARGS_ASSERT_VNUMIFY;
4650
4651     if ( SvROK(vs) )
4652         vs = SvRV(vs);
4653
4654     if ( !vverify(vs) )
4655         Perl_croak(aTHX_ "Invalid version object");
4656
4657     /* see if various flags exist */
4658     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4659         alpha = TRUE;
4660     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4661         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4662     else
4663         width = 3;
4664
4665
4666     /* attempt to retrieve the version array */
4667     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4668         sv_catpvs(sv,"0");
4669         return sv;
4670     }
4671
4672     len = av_len(av);
4673     if ( len == -1 )
4674     {
4675         sv_catpvs(sv,"0");
4676         return sv;
4677     }
4678
4679     digit = SvIV(*av_fetch(av, 0, 0));
4680     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4681     for ( i = 1 ; i < len ; i++ )
4682     {
4683         digit = SvIV(*av_fetch(av, i, 0));
4684         if ( width < 3 ) {
4685             const int denom = (width == 2 ? 10 : 100);
4686             const div_t term = div((int)PERL_ABS(digit),denom);
4687             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4688         }
4689         else {
4690             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4691         }
4692     }
4693
4694     if ( len > 0 )
4695     {
4696         digit = SvIV(*av_fetch(av, len, 0));
4697         if ( alpha && width == 3 ) /* alpha version */
4698             sv_catpvs(sv,"_");
4699         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4700     }
4701     else /* len == 0 */
4702     {
4703         sv_catpvs(sv, "000");
4704     }
4705     return sv;
4706 }
4707
4708 /*
4709 =for apidoc vnormal
4710
4711 Accepts a version object and returns the normalized string
4712 representation.  Call like:
4713
4714     sv = vnormal(rv);
4715
4716 NOTE: you can pass either the object directly or the SV
4717 contained within the RV.
4718
4719 =cut
4720 */
4721
4722 SV *
4723 Perl_vnormal(pTHX_ SV *vs)
4724 {
4725     I32 i, len, digit;
4726     bool alpha = FALSE;
4727     SV * const sv = newSV(0);
4728     AV *av;
4729
4730     PERL_ARGS_ASSERT_VNORMAL;
4731
4732     if ( SvROK(vs) )
4733         vs = SvRV(vs);
4734
4735     if ( !vverify(vs) )
4736         Perl_croak(aTHX_ "Invalid version object");
4737
4738     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4739         alpha = TRUE;
4740     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4741
4742     len = av_len(av);
4743     if ( len == -1 )
4744     {
4745         sv_catpvs(sv,"");
4746         return sv;
4747     }
4748     digit = SvIV(*av_fetch(av, 0, 0));
4749     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4750     for ( i = 1 ; i < len ; i++ ) {
4751         digit = SvIV(*av_fetch(av, i, 0));
4752         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4753     }
4754
4755     if ( len > 0 )
4756     {
4757         /* handle last digit specially */
4758         digit = SvIV(*av_fetch(av, len, 0));
4759         if ( alpha )
4760             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4761         else
4762             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4763     }
4764
4765     if ( len <= 2 ) { /* short version, must be at least three */
4766         for ( len = 2 - len; len != 0; len-- )
4767             sv_catpvs(sv,".0");
4768     }
4769     return sv;
4770 }
4771
4772 /*
4773 =for apidoc vstringify
4774
4775 In order to maintain maximum compatibility with earlier versions
4776 of Perl, this function will return either the floating point
4777 notation or the multiple dotted notation, depending on whether
4778 the original version contained 1 or more dots, respectively
4779
4780 =cut
4781 */
4782
4783 SV *
4784 Perl_vstringify(pTHX_ SV *vs)
4785 {
4786     PERL_ARGS_ASSERT_VSTRINGIFY;
4787
4788     if ( SvROK(vs) )
4789         vs = SvRV(vs);
4790
4791     if ( !vverify(vs) )
4792         Perl_croak(aTHX_ "Invalid version object");
4793
4794     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
4795         SV *pv;
4796         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
4797         if ( SvPOK(pv) )
4798             return newSVsv(pv);
4799         else
4800             return &PL_sv_undef;
4801     }
4802     else {
4803         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
4804             return vnormal(vs);
4805         else
4806             return vnumify(vs);
4807     }
4808 }
4809
4810 /*
4811 =for apidoc vcmp
4812
4813 Version object aware cmp.  Both operands must already have been
4814 converted into version objects.
4815
4816 =cut
4817 */
4818
4819 int
4820 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4821 {
4822     I32 i,l,m,r,retval;
4823     bool lalpha = FALSE;
4824     bool ralpha = FALSE;
4825     I32 left = 0;
4826     I32 right = 0;
4827     AV *lav, *rav;
4828
4829     PERL_ARGS_ASSERT_VCMP;
4830
4831     if ( SvROK(lhv) )
4832         lhv = SvRV(lhv);
4833     if ( SvROK(rhv) )
4834         rhv = SvRV(rhv);
4835
4836     if ( !vverify(lhv) )
4837         Perl_croak(aTHX_ "Invalid version object");
4838
4839     if ( !vverify(rhv) )
4840         Perl_croak(aTHX_ "Invalid version object");
4841
4842     /* get the left hand term */
4843     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
4844     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
4845         lalpha = TRUE;
4846
4847     /* and the right hand term */
4848     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
4849     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
4850         ralpha = TRUE;
4851
4852     l = av_len(lav);
4853     r = av_len(rav);
4854     m = l < r ? l : r;
4855     retval = 0;
4856     i = 0;
4857     while ( i <= m && retval == 0 )
4858     {
4859         left  = SvIV(*av_fetch(lav,i,0));
4860         right = SvIV(*av_fetch(rav,i,0));
4861         if ( left < right  )
4862             retval = -1;
4863         if ( left > right )
4864             retval = +1;
4865         i++;
4866     }
4867
4868     /* tiebreaker for alpha with identical terms */
4869     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4870     {
4871         if ( lalpha && !ralpha )
4872         {
4873             retval = -1;
4874         }
4875         else if ( ralpha && !lalpha)
4876         {
4877             retval = +1;
4878         }
4879     }
4880
4881     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4882     {
4883         if ( l < r )
4884         {
4885             while ( i <= r && retval == 0 )
4886             {
4887                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4888                     retval = -1; /* not a match after all */
4889                 i++;
4890             }
4891         }
4892         else
4893         {
4894             while ( i <= l && retval == 0 )
4895             {
4896                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4897                     retval = +1; /* not a match after all */
4898                 i++;
4899             }
4900         }
4901     }
4902     return retval;
4903 }
4904
4905 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4906 #   define EMULATE_SOCKETPAIR_UDP
4907 #endif
4908
4909 #ifdef EMULATE_SOCKETPAIR_UDP
4910 static int
4911 S_socketpair_udp (int fd[2]) {
4912     dTHX;
4913     /* Fake a datagram socketpair using UDP to localhost.  */
4914     int sockets[2] = {-1, -1};
4915     struct sockaddr_in addresses[2];
4916     int i;
4917     Sock_size_t size = sizeof(struct sockaddr_in);
4918     unsigned short port;
4919     int got;
4920
4921     memset(&addresses, 0, sizeof(addresses));
4922     i = 1;
4923     do {
4924         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4925         if (sockets[i] == -1)
4926             goto tidy_up_and_fail;
4927
4928         addresses[i].sin_family = AF_INET;
4929         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4930         addresses[i].sin_port = 0;      /* kernel choses port.  */
4931         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4932                 sizeof(struct sockaddr_in)) == -1)
4933             goto tidy_up_and_fail;
4934     } while (i--);
4935
4936     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4937        for each connect the other socket to it.  */
4938     i = 1;
4939     do {
4940         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4941                 &size) == -1)
4942             goto tidy_up_and_fail;
4943         if (size != sizeof(struct sockaddr_in))
4944             goto abort_tidy_up_and_fail;
4945         /* !1 is 0, !0 is 1 */
4946         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4947                 sizeof(struct sockaddr_in)) == -1)
4948             goto tidy_up_and_fail;
4949     } while (i--);
4950
4951     /* Now we have 2 sockets connected to each other. I don't trust some other
4952        process not to have already sent a packet to us (by random) so send
4953        a packet from each to the other.  */
4954     i = 1;
4955     do {
4956         /* I'm going to send my own port number.  As a short.
4957            (Who knows if someone somewhere has sin_port as a bitfield and needs
4958            this routine. (I'm assuming crays have socketpair)) */
4959         port = addresses[i].sin_port;
4960         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4961         if (got != sizeof(port)) {
4962             if (got == -1)
4963                 goto tidy_up_and_fail;
4964             goto abort_tidy_up_and_fail;
4965         }
4966     } while (i--);
4967
4968     /* Packets sent. I don't trust them to have arrived though.
4969        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4970        connect to localhost will use a second kernel thread. In 2.6 the
4971        first thread running the connect() returns before the second completes,
4972        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4973        returns 0. Poor programs have tripped up. One poor program's authors'
4974        had a 50-1 reverse stock split. Not sure how connected these were.)
4975        So I don't trust someone not to have an unpredictable UDP stack.
4976     */
4977
4978     {
4979         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4980         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4981         fd_set rset;
4982
4983         FD_ZERO(&rset);
4984         FD_SET((unsigned int)sockets[0], &rset);
4985         FD_SET((unsigned int)sockets[1], &rset);
4986
4987         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4988         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4989                 || !FD_ISSET(sockets[1], &rset)) {
4990             /* I hope this is portable and appropriate.  */
4991             if (got == -1)
4992                 goto tidy_up_and_fail;
4993             goto abort_tidy_up_and_fail;
4994         }
4995     }
4996
4997     /* And the paranoia department even now doesn't trust it to have arrive
4998        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4999     {
5000         struct sockaddr_in readfrom;
5001         unsigned short buffer[2];
5002
5003         i = 1;
5004         do {
5005 #ifdef MSG_DONTWAIT
5006             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5007                     sizeof(buffer), MSG_DONTWAIT,
5008                     (struct sockaddr *) &readfrom, &size);
5009 #else
5010             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5011                     sizeof(buffer), 0,
5012                     (struct sockaddr *) &readfrom, &size);
5013 #endif
5014
5015             if (got == -1)
5016                 goto tidy_up_and_fail;
5017             if (got != sizeof(port)
5018                     || size != sizeof(struct sockaddr_in)
5019                     /* Check other socket sent us its port.  */
5020                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5021                     /* Check kernel says we got the datagram from that socket */
5022                     || readfrom.sin_family != addresses[!i].sin_family
5023                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5024                     || readfrom.sin_port != addresses[!i].sin_port)
5025                 goto abort_tidy_up_and_fail;
5026         } while (i--);
5027     }
5028     /* My caller (my_socketpair) has validated that this is non-NULL  */
5029     fd[0] = sockets[0];
5030     fd[1] = sockets[1];
5031     /* I hereby declare this connection open.  May God bless all who cross
5032        her.  */
5033     return 0;
5034
5035   abort_tidy_up_and_fail:
5036     errno = ECONNABORTED;
5037   tidy_up_and_fail:
5038     {
5039         dSAVE_ERRNO;
5040         if (sockets[0] != -1)
5041             PerlLIO_close(sockets[0]);
5042         if (sockets[1] != -1)
5043             PerlLIO_close(sockets[1]);
5044         RESTORE_ERRNO;
5045         return -1;
5046     }
5047 }
5048 #endif /*  EMULATE_SOCKETPAIR_UDP */
5049
5050 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5051 int
5052 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5053     /* Stevens says that family must be AF_LOCAL, protocol 0.
5054        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5055     dTHX;
5056     int listener = -1;
5057     int connector = -1;
5058     int acceptor = -1;
5059     struct sockaddr_in listen_addr;
5060     struct sockaddr_in connect_addr;
5061     Sock_size_t size;
5062
5063     if (protocol
5064 #ifdef AF_UNIX
5065         || family != AF_UNIX
5066 #endif
5067     ) {
5068         errno = EAFNOSUPPORT;
5069         return -1;
5070     }
5071     if (!fd) {
5072         errno = EINVAL;
5073         return -1;
5074     }
5075
5076 #ifdef EMULATE_SOCKETPAIR_UDP
5077     if (type == SOCK_DGRAM)
5078         return S_socketpair_udp(fd);
5079 #endif
5080
5081     listener = PerlSock_socket(AF_INET, type, 0);
5082     if (listener == -1)
5083         return -1;
5084     memset(&listen_addr, 0, sizeof(listen_addr));
5085     listen_addr.sin_family = AF_INET;
5086     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5087     listen_addr.sin_port = 0;   /* kernel choses port.  */
5088     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5089             sizeof(listen_addr)) == -1)
5090         goto tidy_up_and_fail;
5091     if (PerlSock_listen(listener, 1) == -1)
5092         goto tidy_up_and_fail;
5093
5094     connector = PerlSock_socket(AF_INET, type, 0);
5095     if (connector == -1)
5096         goto tidy_up_and_fail;
5097     /* We want to find out the port number to connect to.  */
5098     size = sizeof(connect_addr);
5099     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5100             &size) == -1)
5101         goto tidy_up_and_fail;
5102     if (size != sizeof(connect_addr))
5103         goto abort_tidy_up_and_fail;
5104     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5105             sizeof(connect_addr)) == -1)
5106         goto tidy_up_and_fail;
5107
5108     size = sizeof(listen_addr);
5109     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5110             &size);
5111     if (acceptor == -1)
5112         goto tidy_up_and_fail;
5113     if (size != sizeof(listen_addr))
5114         goto abort_tidy_up_and_fail;
5115     PerlLIO_close(listener);
5116     /* Now check we are talking to ourself by matching port and host on the
5117        two sockets.  */
5118     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5119             &size) == -1)
5120         goto tidy_up_and_fail;
5121     if (size != sizeof(connect_addr)
5122             || listen_addr.sin_family != connect_addr.sin_family
5123             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5124             || listen_addr.sin_port != connect_addr.sin_port) {
5125         goto abort_tidy_up_and_fail;
5126     }
5127     fd[0] = connector;
5128     fd[1] = acceptor;
5129     return 0;
5130
5131   abort_tidy_up_and_fail:
5132 #ifdef ECONNABORTED
5133   errno = ECONNABORTED; /* This would be the standard thing to do. */
5134 #else
5135 #  ifdef ECONNREFUSED
5136   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5137 #  else
5138   errno = ETIMEDOUT;    /* Desperation time. */
5139 #  endif
5140 #endif
5141   tidy_up_and_fail:
5142     {
5143         dSAVE_ERRNO;
5144         if (listener != -1)
5145             PerlLIO_close(listener);
5146         if (connector != -1)
5147             PerlLIO_close(connector);
5148         if (acceptor != -1)
5149             PerlLIO_close(acceptor);
5150         RESTORE_ERRNO;
5151         return -1;
5152     }
5153 }
5154 #else
5155 /* In any case have a stub so that there's code corresponding
5156  * to the my_socketpair in global.sym. */
5157 int
5158 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5159 #ifdef HAS_SOCKETPAIR
5160     return socketpair(family, type, protocol, fd);
5161 #else
5162     return -1;
5163 #endif
5164 }
5165 #endif
5166
5167 /*
5168
5169 =for apidoc sv_nosharing
5170
5171 Dummy routine which "shares" an SV when there is no sharing module present.
5172 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5173 Exists to avoid test for a NULL function pointer and because it could
5174 potentially warn under some level of strict-ness.
5175
5176 =cut
5177 */
5178
5179 void
5180 Perl_sv_nosharing(pTHX_ SV *sv)
5181 {
5182     PERL_UNUSED_CONTEXT;
5183     PERL_UNUSED_ARG(sv);
5184 }
5185
5186 /*
5187
5188 =for apidoc sv_destroyable
5189
5190 Dummy routine which reports that object can be destroyed when there is no
5191 sharing module present.  It ignores its single SV argument, and returns
5192 'true'.  Exists to avoid test for a NULL function pointer and because it
5193 could potentially warn under some level of strict-ness.
5194
5195 =cut
5196 */
5197
5198 bool
5199 Perl_sv_destroyable(pTHX_ SV *sv)
5200 {
5201     PERL_UNUSED_CONTEXT;
5202     PERL_UNUSED_ARG(sv);
5203     return TRUE;
5204 }
5205
5206 U32
5207 Perl_parse_unicode_opts(pTHX_ const char **popt)
5208 {
5209   const char *p = *popt;
5210   U32 opt = 0;
5211
5212   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5213
5214   if (*p) {
5215        if (isDIGIT(*p)) {
5216             opt = (U32) atoi(p);
5217             while (isDIGIT(*p))
5218                 p++;
5219             if (*p && *p != '\n' && *p != '\r')
5220                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5221        }
5222        else {
5223             for (; *p; p++) {
5224                  switch (*p) {
5225                  case PERL_UNICODE_STDIN:
5226                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5227                  case PERL_UNICODE_STDOUT:
5228                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5229                  case PERL_UNICODE_STDERR:
5230                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5231                  case PERL_UNICODE_STD:
5232                       opt |= PERL_UNICODE_STD_FLAG;     break;
5233                  case PERL_UNICODE_IN:
5234                       opt |= PERL_UNICODE_IN_FLAG;      break;
5235                  case PERL_UNICODE_OUT:
5236                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5237                  case PERL_UNICODE_INOUT:
5238                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5239                  case PERL_UNICODE_LOCALE:
5240                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5241                  case PERL_UNICODE_ARGV:
5242                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5243                  case PERL_UNICODE_UTF8CACHEASSERT:
5244                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5245                  default:
5246                       if (*p != '\n' && *p != '\r')
5247                           Perl_croak(aTHX_
5248                                      "Unknown Unicode option letter '%c'", *p);
5249                  }
5250             }
5251        }
5252   }
5253   else
5254        opt = PERL_UNICODE_DEFAULT_FLAGS;
5255
5256   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5257        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5258                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5259
5260   *popt = p;
5261
5262   return opt;
5263 }
5264
5265 U32
5266 Perl_seed(pTHX)
5267 {
5268     dVAR;
5269     /*
5270      * This is really just a quick hack which grabs various garbage
5271      * values.  It really should be a real hash algorithm which
5272      * spreads the effect of every input bit onto every output bit,
5273      * if someone who knows about such things would bother to write it.
5274      * Might be a good idea to add that function to CORE as well.
5275      * No numbers below come from careful analysis or anything here,
5276      * except they are primes and SEED_C1 > 1E6 to get a full-width
5277      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5278      * probably be bigger too.
5279      */
5280 #if RANDBITS > 16
5281 #  define SEED_C1       1000003
5282 #define   SEED_C4       73819
5283 #else
5284 #  define SEED_C1       25747
5285 #define   SEED_C4       20639
5286 #endif
5287 #define   SEED_C2       3
5288 #define   SEED_C3       269
5289 #define   SEED_C5       26107
5290
5291 #ifndef PERL_NO_DEV_RANDOM
5292     int fd;
5293 #endif
5294     U32 u;
5295 #ifdef VMS
5296 #  include <starlet.h>
5297     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5298      * in 100-ns units, typically incremented ever 10 ms.        */
5299     unsigned int when[2];
5300 #else
5301 #  ifdef HAS_GETTIMEOFDAY
5302     struct timeval when;
5303 #  else
5304     Time_t when;
5305 #  endif
5306 #endif
5307
5308 /* This test is an escape hatch, this symbol isn't set by Configure. */
5309 #ifndef PERL_NO_DEV_RANDOM
5310 #ifndef PERL_RANDOM_DEVICE
5311    /* /dev/random isn't used by default because reads from it will block
5312     * if there isn't enough entropy available.  You can compile with
5313     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5314     * is enough real entropy to fill the seed. */
5315 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5316 #endif
5317     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5318     if (fd != -1) {
5319         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5320             u = 0;
5321         PerlLIO_close(fd);
5322         if (u)
5323             return u;
5324     }
5325 #endif
5326
5327 #ifdef VMS
5328     _ckvmssts(sys$gettim(when));
5329     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5330 #else
5331 #  ifdef HAS_GETTIMEOFDAY
5332     PerlProc_gettimeofday(&when,NULL);
5333     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5334 #  else
5335     (void)time(&when);
5336     u = (U32)SEED_C1 * when;
5337 #  endif
5338 #endif
5339     u += SEED_C3 * (U32)PerlProc_getpid();
5340     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5341 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5342     u += SEED_C5 * (U32)PTR2UV(&when);
5343 #endif
5344     return u;
5345 }
5346
5347 UV
5348 Perl_get_hash_seed(pTHX)
5349 {
5350     dVAR;
5351      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5352      UV myseed = 0;
5353
5354      if (s)
5355         while (isSPACE(*s))
5356             s++;
5357      if (s && isDIGIT(*s))
5358           myseed = (UV)Atoul(s);
5359      else
5360 #ifdef USE_HASH_SEED_EXPLICIT
5361      if (s)
5362 #endif
5363      {
5364           /* Compute a random seed */
5365           (void)seedDrand01((Rand_seed_t)seed());
5366           myseed = (UV)(Drand01() * (NV)UV_MAX);
5367 #if RANDBITS < (UVSIZE * 8)
5368           /* Since there are not enough randbits to to reach all
5369            * the bits of a UV, the low bits might need extra
5370            * help.  Sum in another random number that will
5371            * fill in the low bits. */
5372           myseed +=
5373                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5374 #endif /* RANDBITS < (UVSIZE * 8) */
5375           if (myseed == 0) { /* Superparanoia. */
5376               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5377               if (myseed == 0)
5378                   Perl_croak(aTHX_ "Your random numbers are not that random");
5379           }
5380      }
5381      PL_rehash_seed_set = TRUE;
5382
5383      return myseed;
5384 }
5385
5386 #ifdef USE_ITHREADS
5387 bool
5388 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5389 {
5390     const char * const stashpv = CopSTASHPV(c);
5391     const char * const name = HvNAME_get(hv);
5392     PERL_UNUSED_CONTEXT;
5393     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5394
5395     if (stashpv == name)
5396         return TRUE;
5397     if (stashpv && name)
5398         if (strEQ(stashpv, name))
5399             return TRUE;
5400     return FALSE;
5401 }
5402 #endif
5403
5404
5405 #ifdef PERL_GLOBAL_STRUCT
5406
5407 #define PERL_GLOBAL_STRUCT_INIT
5408 #include "opcode.h" /* the ppaddr and check */
5409
5410 struct perl_vars *
5411 Perl_init_global_struct(pTHX)
5412 {
5413     struct perl_vars *plvarsp = NULL;
5414 # ifdef PERL_GLOBAL_STRUCT
5415     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5416     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5417 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5418     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5419     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5420     if (!plvarsp)
5421         exit(1);
5422 #  else
5423     plvarsp = PL_VarsPtr;
5424 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5425 #  undef PERLVAR
5426 #  undef PERLVARA
5427 #  undef PERLVARI
5428 #  undef PERLVARIC
5429 #  undef PERLVARISC
5430 #  define PERLVAR(var,type) /**/
5431 #  define PERLVARA(var,n,type) /**/
5432 #  define PERLVARI(var,type,init) plvarsp->var = init;
5433 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5434 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5435 #  include "perlvars.h"
5436 #  undef PERLVAR
5437 #  undef PERLVARA
5438 #  undef PERLVARI
5439 #  undef PERLVARIC
5440 #  undef PERLVARISC
5441 #  ifdef PERL_GLOBAL_STRUCT
5442     plvarsp->Gppaddr =
5443         (Perl_ppaddr_t*)
5444         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5445     if (!plvarsp->Gppaddr)
5446         exit(1);
5447     plvarsp->Gcheck  =
5448         (Perl_check_t*)
5449         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5450     if (!plvarsp->Gcheck)
5451         exit(1);
5452     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5453     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5454 #  endif
5455 #  ifdef PERL_SET_VARS
5456     PERL_SET_VARS(plvarsp);
5457 #  endif
5458 # undef PERL_GLOBAL_STRUCT_INIT
5459 # endif
5460     return plvarsp;
5461 }
5462
5463 #endif /* PERL_GLOBAL_STRUCT */
5464
5465 #ifdef PERL_GLOBAL_STRUCT
5466
5467 void
5468 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5469 {
5470     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5471 # ifdef PERL_GLOBAL_STRUCT
5472 #  ifdef PERL_UNSET_VARS
5473     PERL_UNSET_VARS(plvarsp);
5474 #  endif
5475     free(plvarsp->Gppaddr);
5476     free(plvarsp->Gcheck);
5477 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5478     free(plvarsp);
5479 #  endif
5480 # endif
5481 }
5482
5483 #endif /* PERL_GLOBAL_STRUCT */
5484
5485 #ifdef PERL_MEM_LOG
5486
5487 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5488  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5489  * given, and you supply your own implementation.
5490  *
5491  * The default implementation reads a single env var, PERL_MEM_LOG,
5492  * expecting one or more of the following:
5493  *
5494  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5495  *    'm' - memlog      was PERL_MEM_LOG=1
5496  *    's' - svlog       was PERL_SV_LOG=1
5497  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5498  *
5499  * This makes the logger controllable enough that it can reasonably be
5500  * added to the system perl.
5501  */
5502
5503 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5504  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5505  */
5506 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5507
5508 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5509  * writes to.  In the default logger, this is settable at runtime.
5510  */
5511 #ifndef PERL_MEM_LOG_FD
5512 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5513 #endif
5514
5515 #ifndef PERL_MEM_LOG_NOIMPL
5516
5517 # ifdef DEBUG_LEAKING_SCALARS
5518 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5519 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5520 # else
5521 #   define SV_LOG_SERIAL_FMT
5522 #   define _SV_LOG_SERIAL_ARG(sv)
5523 # endif
5524
5525 static void
5526 S_mem_log_common(enum mem_log_type mlt, const UV n,
5527                  const UV typesize, const char *type_name, const SV *sv,
5528                  Malloc_t oldalloc, Malloc_t newalloc,
5529                  const char *filename, const int linenumber,
5530                  const char *funcname)
5531 {
5532     const char *pmlenv;
5533
5534     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5535
5536     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5537     if (!pmlenv)
5538         return;
5539     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5540     {
5541         /* We can't use SVs or PerlIO for obvious reasons,
5542          * so we'll use stdio and low-level IO instead. */
5543         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5544
5545 #   ifdef HAS_GETTIMEOFDAY
5546 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5547 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5548         struct timeval tv;
5549         gettimeofday(&tv, 0);
5550 #   else
5551 #     define MEM_LOG_TIME_FMT   "%10d: "
5552 #     define MEM_LOG_TIME_ARG   (int)when
5553         Time_t when;
5554         (void)time(&when);
5555 #   endif
5556         /* If there are other OS specific ways of hires time than
5557          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5558          * probably that they would be used to fill in the struct
5559          * timeval. */
5560         {
5561             STRLEN len;
5562             int fd = atoi(pmlenv);
5563             if (!fd)
5564                 fd = PERL_MEM_LOG_FD;
5565
5566             if (strchr(pmlenv, 't')) {
5567                 len = my_snprintf(buf, sizeof(buf),
5568                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5569                 PerlLIO_write(fd, buf, len);
5570             }
5571             switch (mlt) {
5572             case MLT_ALLOC:
5573                 len = my_snprintf(buf, sizeof(buf),
5574                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5575                         " %s = %"IVdf": %"UVxf"\n",
5576                         filename, linenumber, funcname, n, typesize,
5577                         type_name, n * typesize, PTR2UV(newalloc));
5578                 break;
5579             case MLT_REALLOC:
5580                 len = my_snprintf(buf, sizeof(buf),
5581                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5582                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5583                         filename, linenumber, funcname, n, typesize,
5584                         type_name, n * typesize, PTR2UV(oldalloc),
5585                         PTR2UV(newalloc));
5586                 break;
5587             case MLT_FREE:
5588                 len = my_snprintf(buf, sizeof(buf),
5589                         "free: %s:%d:%s: %"UVxf"\n",
5590                         filename, linenumber, funcname,
5591                         PTR2UV(oldalloc));
5592                 break;
5593             case MLT_NEW_SV:
5594             case MLT_DEL_SV:
5595                 len = my_snprintf(buf, sizeof(buf),
5596                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5597                         mlt == MLT_NEW_SV ? "new" : "del",
5598                         filename, linenumber, funcname,
5599                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5600                 break;
5601             default:
5602                 len = 0;
5603             }
5604             PerlLIO_write(fd, buf, len);
5605         }
5606     }
5607 }
5608 #endif /* !PERL_MEM_LOG_NOIMPL */
5609
5610 #ifndef PERL_MEM_LOG_NOIMPL
5611 # define \
5612     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5613     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5614 #else
5615 /* this is suboptimal, but bug compatible.  User is providing their
5616    own implemenation, but is getting these functions anyway, and they
5617    do nothing. But _NOIMPL users should be able to cope or fix */
5618 # define \
5619     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5620     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5621 #endif
5622
5623 Malloc_t
5624 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5625                    Malloc_t newalloc,
5626                    const char *filename, const int linenumber,
5627                    const char *funcname)
5628 {
5629     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5630                       NULL, NULL, newalloc,
5631                       filename, linenumber, funcname);
5632     return newalloc;
5633 }
5634
5635 Malloc_t
5636 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5637                      Malloc_t oldalloc, Malloc_t newalloc,
5638                      const char *filename, const int linenumber,
5639                      const char *funcname)
5640 {
5641     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5642                       NULL, oldalloc, newalloc,
5643                       filename, linenumber, funcname);
5644     return newalloc;
5645 }
5646
5647 Malloc_t
5648 Perl_mem_log_free(Malloc_t oldalloc,
5649                   const char *filename, const int linenumber,
5650                   const char *funcname)
5651 {
5652     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5653                       filename, linenumber, funcname);
5654     return oldalloc;
5655 }
5656
5657 void
5658 Perl_mem_log_new_sv(const SV *sv,
5659                     const char *filename, const int linenumber,
5660                     const char *funcname)
5661 {
5662     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5663                       filename, linenumber, funcname);
5664 }
5665
5666 void
5667 Perl_mem_log_del_sv(const SV *sv,
5668                     const char *filename, const int linenumber,
5669                     const char *funcname)
5670 {
5671     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5672                       filename, linenumber, funcname);
5673 }
5674
5675 #endif /* PERL_MEM_LOG */
5676
5677 /*
5678 =for apidoc my_sprintf
5679
5680 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5681 the length of the string written to the buffer. Only rare pre-ANSI systems
5682 need the wrapper function - usually this is a direct call to C<sprintf>.
5683
5684 =cut
5685 */
5686 #ifndef SPRINTF_RETURNS_STRLEN
5687 int
5688 Perl_my_sprintf(char *buffer, const char* pat, ...)
5689 {
5690     va_list args;
5691     PERL_ARGS_ASSERT_MY_SPRINTF;
5692     va_start(args, pat);
5693     vsprintf(buffer, pat, args);
5694     va_end(args);
5695     return strlen(buffer);
5696 }
5697 #endif
5698
5699 /*
5700 =for apidoc my_snprintf
5701
5702 The C library C<snprintf> functionality, if available and
5703 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5704 C<vsnprintf> is not available, will unfortunately use the unsafe
5705 C<vsprintf> which can overrun the buffer (there is an overrun check,
5706 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5707 getting C<vsnprintf>.
5708
5709 =cut
5710 */
5711 int
5712 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5713 {
5714     dTHX;
5715     int retval;
5716     va_list ap;
5717     PERL_ARGS_ASSERT_MY_SNPRINTF;
5718     va_start(ap, format);
5719 #ifdef HAS_VSNPRINTF
5720     retval = vsnprintf(buffer, len, format, ap);
5721 #else
5722     retval = vsprintf(buffer, format, ap);
5723 #endif
5724     va_end(ap);
5725     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5726     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5727         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5728     return retval;
5729 }
5730
5731 /*
5732 =for apidoc my_vsnprintf
5733
5734 The C library C<vsnprintf> if available and standards-compliant.
5735 However, if if the C<vsnprintf> is not available, will unfortunately
5736 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5737 overrun check, but that may be too late).  Consider using
5738 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5739
5740 =cut
5741 */
5742 int
5743 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5744 {
5745     dTHX;
5746     int retval;
5747 #ifdef NEED_VA_COPY
5748     va_list apc;
5749
5750     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5751
5752     Perl_va_copy(ap, apc);
5753 # ifdef HAS_VSNPRINTF
5754     retval = vsnprintf(buffer, len, format, apc);
5755 # else
5756     retval = vsprintf(buffer, format, apc);
5757 # endif
5758 #else
5759 # ifdef HAS_VSNPRINTF
5760     retval = vsnprintf(buffer, len, format, ap);
5761 # else
5762     retval = vsprintf(buffer, format, ap);
5763 # endif
5764 #endif /* #ifdef NEED_VA_COPY */
5765     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5766     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5767         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5768     return retval;
5769 }
5770
5771 void
5772 Perl_my_clearenv(pTHX)
5773 {
5774     dVAR;
5775 #if ! defined(PERL_MICRO)
5776 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5777     PerlEnv_clearenv();
5778 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5779 #    if defined(USE_ENVIRON_ARRAY)
5780 #      if defined(USE_ITHREADS)
5781     /* only the parent thread can clobber the process environment */
5782     if (PL_curinterp == aTHX)
5783 #      endif /* USE_ITHREADS */
5784     {
5785 #      if ! defined(PERL_USE_SAFE_PUTENV)
5786     if ( !PL_use_safe_putenv) {
5787       I32 i;
5788       if (environ == PL_origenviron)
5789         environ = (char**)safesysmalloc(sizeof(char*));
5790       else
5791         for (i = 0; environ[i]; i++)
5792           (void)safesysfree(environ[i]);
5793     }
5794     environ[0] = NULL;
5795 #      else /* PERL_USE_SAFE_PUTENV */
5796 #        if defined(HAS_CLEARENV)
5797     (void)clearenv();
5798 #        elif defined(HAS_UNSETENV)
5799     int bsiz = 80; /* Most envvar names will be shorter than this. */
5800     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5801     char *buf = (char*)safesysmalloc(bufsiz);
5802     while (*environ != NULL) {
5803       char *e = strchr(*environ, '=');
5804       int l = e ? e - *environ : (int)strlen(*environ);
5805       if (bsiz < l + 1) {
5806         (void)safesysfree(buf);
5807         bsiz = l + 1; /* + 1 for the \0. */
5808         buf = (char*)safesysmalloc(bufsiz);
5809       }
5810       memcpy(buf, *environ, l);
5811       buf[l] = '\0';
5812       (void)unsetenv(buf);
5813     }
5814     (void)safesysfree(buf);
5815 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5816     /* Just null environ and accept the leakage. */
5817     *environ = NULL;
5818 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5819 #      endif /* ! PERL_USE_SAFE_PUTENV */
5820     }
5821 #    endif /* USE_ENVIRON_ARRAY */
5822 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5823 #endif /* PERL_MICRO */
5824 }
5825
5826 #ifdef PERL_IMPLICIT_CONTEXT
5827
5828 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
5829 the global PL_my_cxt_index is incremented, and that value is assigned to
5830 that module's static my_cxt_index (who's address is passed as an arg).
5831 Then, for each interpreter this function is called for, it makes sure a
5832 void* slot is available to hang the static data off, by allocating or
5833 extending the interpreter's PL_my_cxt_list array */
5834
5835 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
5836 void *
5837 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5838 {
5839     dVAR;
5840     void *p;
5841     PERL_ARGS_ASSERT_MY_CXT_INIT;
5842     if (*index == -1) {
5843         /* this module hasn't been allocated an index yet */
5844         MUTEX_LOCK(&PL_my_ctx_mutex);
5845         *index = PL_my_cxt_index++;
5846         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5847     }
5848
5849     /* make sure the array is big enough */
5850     if (PL_my_cxt_size <= *index) {
5851         if (PL_my_cxt_size) {
5852             while (PL_my_cxt_size <= *index)
5853                 PL_my_cxt_size *= 2;
5854             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5855         }
5856         else {
5857             PL_my_cxt_size = 16;
5858             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5859         }
5860     }
5861     /* newSV() allocates one more than needed */
5862     p = (void*)SvPVX(newSV(size-1));
5863     PL_my_cxt_list[*index] = p;
5864     Zero(p, size, char);
5865     return p;
5866 }
5867
5868 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5869
5870 int
5871 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5872 {
5873     dVAR;
5874     int index;
5875
5876     PERL_ARGS_ASSERT_MY_CXT_INDEX;
5877
5878     for (index = 0; index < PL_my_cxt_index; index++) {
5879         const char *key = PL_my_cxt_keys[index];
5880         /* try direct pointer compare first - there are chances to success,
5881          * and it's much faster.
5882          */
5883         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5884             return index;
5885     }
5886     return -1;
5887 }
5888
5889 void *
5890 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5891 {
5892     dVAR;
5893     void *p;
5894     int index;
5895
5896     PERL_ARGS_ASSERT_MY_CXT_INIT;
5897
5898     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5899     if (index == -1) {
5900         /* this module hasn't been allocated an index yet */
5901         MUTEX_LOCK(&PL_my_ctx_mutex);
5902         index = PL_my_cxt_index++;
5903         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5904     }
5905
5906     /* make sure the array is big enough */
5907     if (PL_my_cxt_size <= index) {
5908         int old_size = PL_my_cxt_size;
5909         int i;
5910         if (PL_my_cxt_size) {
5911             while (PL_my_cxt_size <= index)
5912                 PL_my_cxt_size *= 2;
5913             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5914             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5915         }
5916         else {
5917             PL_my_cxt_size = 16;
5918             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5919             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5920         }
5921         for (i = old_size; i < PL_my_cxt_size; i++) {
5922             PL_my_cxt_keys[i] = 0;
5923             PL_my_cxt_list[i] = 0;
5924         }
5925     }
5926     PL_my_cxt_keys[index] = my_cxt_key;
5927     /* newSV() allocates one more than needed */
5928     p = (void*)SvPVX(newSV(size-1));
5929     PL_my_cxt_list[index] = p;
5930     Zero(p, size, char);
5931     return p;
5932 }
5933 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5934 #endif /* PERL_IMPLICIT_CONTEXT */
5935
5936 #ifndef HAS_STRLCAT
5937 Size_t
5938 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5939 {
5940     Size_t used, length, copy;
5941
5942     used = strlen(dst);
5943     length = strlen(src);
5944     if (size > 0 && used < size - 1) {
5945         copy = (length >= size - used) ? size - used - 1 : length;
5946         memcpy(dst + used, src, copy);
5947         dst[used + copy] = '\0';
5948     }
5949     return used + length;
5950 }
5951 #endif
5952
5953 #ifndef HAS_STRLCPY
5954 Size_t
5955 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5956 {
5957     Size_t length, copy;
5958
5959     length = strlen(src);
5960     if (size > 0) {
5961         copy = (length >= size) ? size - 1 : length;
5962         memcpy(dst, src, copy);
5963         dst[copy] = '\0';
5964     }
5965     return length;
5966 }
5967 #endif
5968
5969 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5970 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5971 long _ftol( double ); /* Defined by VC6 C libs. */
5972 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5973 #endif
5974
5975 void
5976 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5977 {
5978     dVAR;
5979     SV * const dbsv = GvSVn(PL_DBsub);
5980     /* We do not care about using sv to call CV;
5981      * it's for informational purposes only.
5982      */
5983
5984     PERL_ARGS_ASSERT_GET_DB_SUB;
5985
5986     save_item(dbsv);
5987     if (!PERLDB_SUB_NN) {
5988         GV * const gv = CvGV(cv);
5989
5990         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5991              || strEQ(GvNAME(gv), "END")
5992              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5993                  !( (SvTYPE(*svp) == SVt_PVGV)
5994                     && (GvCV((const GV *)*svp) == cv) )))) {
5995             /* Use GV from the stack as a fallback. */
5996             /* GV is potentially non-unique, or contain different CV. */
5997             SV * const tmp = newRV(MUTABLE_SV(cv));
5998             sv_setsv(dbsv, tmp);
5999             SvREFCNT_dec(tmp);
6000         }
6001         else {
6002             gv_efullname3(dbsv, gv, NULL);
6003         }
6004     }
6005     else {
6006         const int type = SvTYPE(dbsv);
6007         if (type < SVt_PVIV && type != SVt_IV)
6008             sv_upgrade(dbsv, SVt_PVIV);
6009         (void)SvIOK_on(dbsv);
6010         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6011     }
6012 }
6013
6014 int
6015 Perl_my_dirfd(pTHX_ DIR * dir) {
6016
6017     /* Most dirfd implementations have problems when passed NULL. */
6018     if(!dir)
6019         return -1;
6020 #ifdef HAS_DIRFD
6021     return dirfd(dir);
6022 #elif defined(HAS_DIR_DD_FD)
6023     return dir->dd_fd;
6024 #else
6025     Perl_die(aTHX_ PL_no_func, "dirfd");
6026    /* NOT REACHED */
6027     return 0;
6028 #endif
6029 }
6030
6031 REGEXP *
6032 Perl_get_re_arg(pTHX_ SV *sv) {
6033     SV    *tmpsv;
6034
6035     if (sv) {
6036         if (SvMAGICAL(sv))
6037             mg_get(sv);
6038         if (SvROK(sv) &&
6039             (tmpsv = MUTABLE_SV(SvRV(sv))) &&            /* assign deliberate */
6040             SvTYPE(tmpsv) == SVt_REGEXP)
6041         {
6042             return (REGEXP*) tmpsv;
6043         }
6044     }
6045
6046     return NULL;
6047 }
6048
6049 /*
6050  * Local variables:
6051  * c-indentation-style: bsd
6052  * c-basic-offset: 4
6053  * indent-tabs-mode: t
6054  * End:
6055  *
6056  * ex: set ts=8 sts=4 sw=4 noet:
6057  */