util.c

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