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