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