util.c

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