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