util.c

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