util.c

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