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 /* XXX Add documentation after final interface and behavior is decided */
3687 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
3688     U8 source = *current;
3689
3690     May want to add eg, WARN_REGEX
3691 */
3692
3693 char
3694 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
3695 {
3696
3697     U8 result;
3698
3699     if (! isASCII(source)) {
3700         Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
3701     }
3702
3703     result = toCTRL(source);
3704     if (! isCNTRL(result)) {
3705         if (source == '{') {
3706             Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
3707         }
3708         else if (output_warning) {
3709             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
3710                             "\"\\c%c\" more clearly written simply as \"%c\"",
3711                             source,
3712                             result);
3713         }
3714     }
3715
3716     return result;
3717 }
3718
3719 /* To workaround core dumps from the uninitialised tm_zone we get the
3720  * system to give us a reasonable struct to copy.  This fix means that
3721  * strftime uses the tm_zone and tm_gmtoff values returned by
3722  * localtime(time()). That should give the desired result most of the
3723  * time. But probably not always!
3724  *
3725  * This does not address tzname aspects of NETaa14816.
3726  *
3727  */
3728
3729 #ifdef HAS_GNULIBC
3730 # ifndef STRUCT_TM_HASZONE
3731 #    define STRUCT_TM_HASZONE
3732 # endif
3733 #endif
3734
3735 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3736 # ifndef HAS_TM_TM_ZONE
3737 #    define HAS_TM_TM_ZONE
3738 # endif
3739 #endif
3740
3741 void
3742 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3743 {
3744 #ifdef HAS_TM_TM_ZONE
3745     Time_t now;
3746     const struct tm* my_tm;
3747     PERL_ARGS_ASSERT_INIT_TM;
3748     (void)time(&now);
3749     my_tm = localtime(&now);
3750     if (my_tm)
3751         Copy(my_tm, ptm, 1, struct tm);
3752 #else
3753     PERL_ARGS_ASSERT_INIT_TM;
3754     PERL_UNUSED_ARG(ptm);
3755 #endif
3756 }
3757
3758 /*
3759  * mini_mktime - normalise struct tm values without the localtime()
3760  * semantics (and overhead) of mktime().
3761  */
3762 void
3763 Perl_mini_mktime(pTHX_ struct tm *ptm)
3764 {
3765     int yearday;
3766     int secs;
3767     int month, mday, year, jday;
3768     int odd_cent, odd_year;
3769     PERL_UNUSED_CONTEXT;
3770
3771     PERL_ARGS_ASSERT_MINI_MKTIME;
3772
3773 #define DAYS_PER_YEAR   365
3774 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3775 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3776 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3777 #define SECS_PER_HOUR   (60*60)
3778 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3779 /* parentheses deliberately absent on these two, otherwise they don't work */
3780 #define MONTH_TO_DAYS   153/5
3781 #define DAYS_TO_MONTH   5/153
3782 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3783 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3784 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3785 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3786
3787 /*
3788  * Year/day algorithm notes:
3789  *
3790  * With a suitable offset for numeric value of the month, one can find
3791  * an offset into the year by considering months to have 30.6 (153/5) days,
3792  * using integer arithmetic (i.e., with truncation).  To avoid too much
3793  * messing about with leap days, we consider January and February to be
3794  * the 13th and 14th month of the previous year.  After that transformation,
3795  * we need the month index we use to be high by 1 from 'normal human' usage,
3796  * so the month index values we use run from 4 through 15.
3797  *
3798  * Given that, and the rules for the Gregorian calendar (leap years are those
3799  * divisible by 4 unless also divisible by 100, when they must be divisible
3800  * by 400 instead), we can simply calculate the number of days since some
3801  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3802  * the days we derive from our month index, and adding in the day of the
3803  * month.  The value used here is not adjusted for the actual origin which
3804  * it normally would use (1 January A.D. 1), since we're not exposing it.
3805  * We're only building the value so we can turn around and get the
3806  * normalised values for the year, month, day-of-month, and day-of-year.
3807  *
3808  * For going backward, we need to bias the value we're using so that we find
3809  * the right year value.  (Basically, we don't want the contribution of
3810  * March 1st to the number to apply while deriving the year).  Having done
3811  * that, we 'count up' the contribution to the year number by accounting for
3812  * full quadracenturies (400-year periods) with their extra leap days, plus
3813  * the contribution from full centuries (to avoid counting in the lost leap
3814  * days), plus the contribution from full quad-years (to count in the normal
3815  * leap days), plus the leftover contribution from any non-leap years.
3816  * At this point, if we were working with an actual leap day, we'll have 0
3817  * days left over.  This is also true for March 1st, however.  So, we have
3818  * to special-case that result, and (earlier) keep track of the 'odd'
3819  * century and year contributions.  If we got 4 extra centuries in a qcent,
3820  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3821  * Otherwise, we add back in the earlier bias we removed (the 123 from
3822  * figuring in March 1st), find the month index (integer division by 30.6),
3823  * and the remainder is the day-of-month.  We then have to convert back to
3824  * 'real' months (including fixing January and February from being 14/15 in
3825  * the previous year to being in the proper year).  After that, to get
3826  * tm_yday, we work with the normalised year and get a new yearday value for
3827  * January 1st, which we subtract from the yearday value we had earlier,
3828  * representing the date we've re-built.  This is done from January 1
3829  * because tm_yday is 0-origin.
3830  *
3831  * Since POSIX time routines are only guaranteed to work for times since the
3832  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3833  * applies Gregorian calendar rules even to dates before the 16th century
3834  * doesn't bother me.  Besides, you'd need cultural context for a given
3835  * date to know whether it was Julian or Gregorian calendar, and that's
3836  * outside the scope for this routine.  Since we convert back based on the
3837  * same rules we used to build the yearday, you'll only get strange results
3838  * for input which needed normalising, or for the 'odd' century years which
3839  * were leap years in the Julian calander but not in the Gregorian one.
3840  * I can live with that.
3841  *
3842  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3843  * that's still outside the scope for POSIX time manipulation, so I don't
3844  * care.
3845  */
3846
3847     year = 1900 + ptm->tm_year;
3848     month = ptm->tm_mon;
3849     mday = ptm->tm_mday;
3850     /* allow given yday with no month & mday to dominate the result */
3851     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3852         month = 0;
3853         mday = 0;
3854         jday = 1 + ptm->tm_yday;
3855     }
3856     else {
3857         jday = 0;
3858     }
3859     if (month >= 2)
3860         month+=2;
3861     else
3862         month+=14, year--;
3863     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3864     yearday += month*MONTH_TO_DAYS + mday + jday;
3865     /*
3866      * Note that we don't know when leap-seconds were or will be,
3867      * so we have to trust the user if we get something which looks
3868      * like a sensible leap-second.  Wild values for seconds will
3869      * be rationalised, however.
3870      */
3871     if ((unsigned) ptm->tm_sec <= 60) {
3872         secs = 0;
3873     }
3874     else {
3875         secs = ptm->tm_sec;
3876         ptm->tm_sec = 0;
3877     }
3878     secs += 60 * ptm->tm_min;
3879     secs += SECS_PER_HOUR * ptm->tm_hour;
3880     if (secs < 0) {
3881         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3882             /* got negative remainder, but need positive time */
3883             /* back off an extra day to compensate */
3884             yearday += (secs/SECS_PER_DAY)-1;
3885             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3886         }
3887         else {
3888             yearday += (secs/SECS_PER_DAY);
3889             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3890         }
3891     }
3892     else if (secs >= SECS_PER_DAY) {
3893         yearday += (secs/SECS_PER_DAY);
3894         secs %= SECS_PER_DAY;
3895     }
3896     ptm->tm_hour = secs/SECS_PER_HOUR;
3897     secs %= SECS_PER_HOUR;
3898     ptm->tm_min = secs/60;
3899     secs %= 60;
3900     ptm->tm_sec += secs;
3901     /* done with time of day effects */
3902     /*
3903      * The algorithm for yearday has (so far) left it high by 428.
3904      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3905      * bias it by 123 while trying to figure out what year it
3906      * really represents.  Even with this tweak, the reverse
3907      * translation fails for years before A.D. 0001.
3908      * It would still fail for Feb 29, but we catch that one below.
3909      */
3910     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3911     yearday -= YEAR_ADJUST;
3912     year = (yearday / DAYS_PER_QCENT) * 400;
3913     yearday %= DAYS_PER_QCENT;
3914     odd_cent = yearday / DAYS_PER_CENT;
3915     year += odd_cent * 100;
3916     yearday %= DAYS_PER_CENT;
3917     year += (yearday / DAYS_PER_QYEAR) * 4;
3918     yearday %= DAYS_PER_QYEAR;
3919     odd_year = yearday / DAYS_PER_YEAR;
3920     year += odd_year;
3921     yearday %= DAYS_PER_YEAR;
3922     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3923         month = 1;
3924         yearday = 29;
3925     }
3926     else {
3927         yearday += YEAR_ADJUST; /* recover March 1st crock */
3928         month = yearday*DAYS_TO_MONTH;
3929         yearday -= month*MONTH_TO_DAYS;
3930         /* recover other leap-year adjustment */
3931         if (month > 13) {
3932             month-=14;
3933             year++;
3934         }
3935         else {
3936             month-=2;
3937         }
3938     }
3939     ptm->tm_year = year - 1900;
3940     if (yearday) {
3941       ptm->tm_mday = yearday;
3942       ptm->tm_mon = month;
3943     }
3944     else {
3945       ptm->tm_mday = 31;
3946       ptm->tm_mon = month - 1;
3947     }
3948     /* re-build yearday based on Jan 1 to get tm_yday */
3949     year--;
3950     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3951     yearday += 14*MONTH_TO_DAYS + 1;
3952     ptm->tm_yday = jday - yearday;
3953     /* fix tm_wday if not overridden by caller */
3954     if ((unsigned)ptm->tm_wday > 6)
3955         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3956 }
3957
3958 char *
3959 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)
3960 {
3961 #ifdef HAS_STRFTIME
3962   char *buf;
3963   int buflen;
3964   struct tm mytm;
3965   int len;
3966
3967   PERL_ARGS_ASSERT_MY_STRFTIME;
3968
3969   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3970   mytm.tm_sec = sec;
3971   mytm.tm_min = min;
3972   mytm.tm_hour = hour;
3973   mytm.tm_mday = mday;
3974   mytm.tm_mon = mon;
3975   mytm.tm_year = year;
3976   mytm.tm_wday = wday;
3977   mytm.tm_yday = yday;
3978   mytm.tm_isdst = isdst;
3979   mini_mktime(&mytm);
3980   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3981 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3982   STMT_START {
3983     struct tm mytm2;
3984     mytm2 = mytm;
3985     mktime(&mytm2);
3986 #ifdef HAS_TM_TM_GMTOFF
3987     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3988 #endif
3989 #ifdef HAS_TM_TM_ZONE
3990     mytm.tm_zone = mytm2.tm_zone;
3991 #endif
3992   } STMT_END;
3993 #endif
3994   buflen = 64;
3995   Newx(buf, buflen, char);
3996   len = strftime(buf, buflen, fmt, &mytm);
3997   /*
3998   ** The following is needed to handle to the situation where
3999   ** tmpbuf overflows.  Basically we want to allocate a buffer
4000   ** and try repeatedly.  The reason why it is so complicated
4001   ** is that getting a return value of 0 from strftime can indicate
4002   ** one of the following:
4003   ** 1. buffer overflowed,
4004   ** 2. illegal conversion specifier, or
4005   ** 3. the format string specifies nothing to be returned(not
4006   **      an error).  This could be because format is an empty string
4007   **    or it specifies %p that yields an empty string in some locale.
4008   ** If there is a better way to make it portable, go ahead by
4009   ** all means.
4010   */
4011   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4012     return buf;
4013   else {
4014     /* Possibly buf overflowed - try again with a bigger buf */
4015     const int fmtlen = strlen(fmt);
4016     int bufsize = fmtlen + buflen;
4017
4018     Newx(buf, bufsize, char);
4019     while (buf) {
4020       buflen = strftime(buf, bufsize, fmt, &mytm);
4021       if (buflen > 0 && buflen < bufsize)
4022         break;
4023       /* heuristic to prevent out-of-memory errors */
4024       if (bufsize > 100*fmtlen) {
4025         Safefree(buf);
4026         buf = NULL;
4027         break;
4028       }
4029       bufsize *= 2;
4030       Renew(buf, bufsize, char);
4031     }
4032     return buf;
4033   }
4034 #else
4035   Perl_croak(aTHX_ "panic: no strftime");
4036   return NULL;
4037 #endif
4038 }
4039
4040
4041 #define SV_CWD_RETURN_UNDEF \
4042 sv_setsv(sv, &PL_sv_undef); \
4043 return FALSE
4044
4045 #define SV_CWD_ISDOT(dp) \
4046     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4047         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4048
4049 /*
4050 =head1 Miscellaneous Functions
4051
4052 =for apidoc getcwd_sv
4053
4054 Fill the sv with current working directory
4055
4056 =cut
4057 */
4058
4059 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4060  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4061  * getcwd(3) if available
4062  * Comments from the orignal:
4063  *     This is a faster version of getcwd.  It's also more dangerous
4064  *     because you might chdir out of a directory that you can't chdir
4065  *     back into. */
4066
4067 int
4068 Perl_getcwd_sv(pTHX_ register SV *sv)
4069 {
4070 #ifndef PERL_MICRO
4071     dVAR;
4072 #ifndef INCOMPLETE_TAINTS
4073     SvTAINTED_on(sv);
4074 #endif
4075
4076     PERL_ARGS_ASSERT_GETCWD_SV;
4077
4078 #ifdef HAS_GETCWD
4079     {
4080         char buf[MAXPATHLEN];
4081
4082         /* Some getcwd()s automatically allocate a buffer of the given
4083          * size from the heap if they are given a NULL buffer pointer.
4084          * The problem is that this behaviour is not portable. */
4085         if (getcwd(buf, sizeof(buf) - 1)) {
4086             sv_setpv(sv, buf);
4087             return TRUE;
4088         }
4089         else {
4090             sv_setsv(sv, &PL_sv_undef);
4091             return FALSE;
4092         }
4093     }
4094
4095 #else
4096
4097     Stat_t statbuf;
4098     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4099     int pathlen=0;
4100     Direntry_t *dp;
4101
4102     SvUPGRADE(sv, SVt_PV);
4103
4104     if (PerlLIO_lstat(".", &statbuf) < 0) {
4105         SV_CWD_RETURN_UNDEF;
4106     }
4107
4108     orig_cdev = statbuf.st_dev;
4109     orig_cino = statbuf.st_ino;
4110     cdev = orig_cdev;
4111     cino = orig_cino;
4112
4113     for (;;) {
4114         DIR *dir;
4115         int namelen;
4116         odev = cdev;
4117         oino = cino;
4118
4119         if (PerlDir_chdir("..") < 0) {
4120             SV_CWD_RETURN_UNDEF;
4121         }
4122         if (PerlLIO_stat(".", &statbuf) < 0) {
4123             SV_CWD_RETURN_UNDEF;
4124         }
4125
4126         cdev = statbuf.st_dev;
4127         cino = statbuf.st_ino;
4128
4129         if (odev == cdev && oino == cino) {
4130             break;
4131         }
4132         if (!(dir = PerlDir_open("."))) {
4133             SV_CWD_RETURN_UNDEF;
4134         }
4135
4136         while ((dp = PerlDir_read(dir)) != NULL) {
4137 #ifdef DIRNAMLEN
4138             namelen = dp->d_namlen;
4139 #else
4140             namelen = strlen(dp->d_name);
4141 #endif
4142             /* skip . and .. */
4143             if (SV_CWD_ISDOT(dp)) {
4144                 continue;
4145             }
4146
4147             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4148                 SV_CWD_RETURN_UNDEF;
4149             }
4150
4151             tdev = statbuf.st_dev;
4152             tino = statbuf.st_ino;
4153             if (tino == oino && tdev == odev) {
4154                 break;
4155             }
4156         }
4157
4158         if (!dp) {
4159             SV_CWD_RETURN_UNDEF;
4160         }
4161
4162         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4163             SV_CWD_RETURN_UNDEF;
4164         }
4165
4166         SvGROW(sv, pathlen + namelen + 1);
4167
4168         if (pathlen) {
4169             /* shift down */
4170             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4171         }
4172
4173         /* prepend current directory to the front */
4174         *SvPVX(sv) = '/';
4175         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4176         pathlen += (namelen + 1);
4177
4178 #ifdef VOID_CLOSEDIR
4179         PerlDir_close(dir);
4180 #else
4181         if (PerlDir_close(dir) < 0) {
4182             SV_CWD_RETURN_UNDEF;
4183         }
4184 #endif
4185     }
4186
4187     if (pathlen) {
4188         SvCUR_set(sv, pathlen);
4189         *SvEND(sv) = '\0';
4190         SvPOK_only(sv);
4191
4192         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4193             SV_CWD_RETURN_UNDEF;
4194         }
4195     }
4196     if (PerlLIO_stat(".", &statbuf) < 0) {
4197         SV_CWD_RETURN_UNDEF;
4198     }
4199
4200     cdev = statbuf.st_dev;
4201     cino = statbuf.st_ino;
4202
4203     if (cdev != orig_cdev || cino != orig_cino) {
4204         Perl_croak(aTHX_ "Unstable directory path, "
4205                    "current directory changed unexpectedly");
4206     }
4207
4208     return TRUE;
4209 #endif
4210
4211 #else
4212     return FALSE;
4213 #endif
4214 }
4215
4216 #define VERSION_MAX 0x7FFFFFFF
4217
4218 /*
4219 =for apidoc prescan_version
4220
4221 =cut
4222 */
4223 const char *
4224 Perl_prescan_version(pTHX_ const char *s, bool strict,
4225                      const char **errstr,
4226                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4227     bool qv = (sqv ? *sqv : FALSE);
4228     int width = 3;
4229     int saw_decimal = 0;
4230     bool alpha = FALSE;
4231     const char *d = s;
4232
4233     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4234
4235     if (qv && isDIGIT(*d))
4236         goto dotted_decimal_version;
4237
4238     if (*d == 'v') { /* explicit v-string */
4239         d++;
4240         if (isDIGIT(*d)) {
4241             qv = TRUE;
4242         }
4243         else { /* degenerate v-string */
4244             /* requires v1.2.3 */
4245             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4246         }
4247
4248 dotted_decimal_version:
4249         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4250             /* no leading zeros allowed */
4251             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4252         }
4253
4254         while (isDIGIT(*d))     /* integer part */
4255             d++;
4256
4257         if (*d == '.')
4258         {
4259             saw_decimal++;
4260             d++;                /* decimal point */
4261         }
4262         else
4263         {
4264             if (strict) {
4265                 /* require v1.2.3 */
4266                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4267             }
4268             else {
4269                 goto version_prescan_finish;
4270             }
4271         }
4272
4273         {
4274             int i = 0;
4275             int j = 0;
4276             while (isDIGIT(*d)) {       /* just keep reading */
4277                 i++;
4278                 while (isDIGIT(*d)) {
4279                     d++; j++;
4280                     /* maximum 3 digits between decimal */
4281                     if (strict && j > 3) {
4282                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4283                     }
4284                 }
4285                 if (*d == '_') {
4286                     if (strict) {
4287                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4288                     }
4289                     if ( alpha ) {
4290                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4291                     }
4292                     d++;
4293                     alpha = TRUE;
4294                 }
4295                 else if (*d == '.') {
4296                     if (alpha) {
4297                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4298                     }
4299                     saw_decimal++;
4300                     d++;
4301                 }
4302                 else if (!isDIGIT(*d)) {
4303                     break;
4304                 }
4305                 j = 0;
4306             }
4307
4308             if (strict && i < 2) {
4309                 /* requires v1.2.3 */
4310                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4311             }
4312         }
4313     }                                   /* end if dotted-decimal */
4314     else
4315     {                                   /* decimal versions */
4316         /* special strict case for leading '.' or '0' */
4317         if (strict) {
4318             if (*d == '.') {
4319                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4320             }
4321             if (*d == '0' && isDIGIT(d[1])) {
4322                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4323             }
4324         }
4325
4326         /* consume all of the integer part */
4327         while (isDIGIT(*d))
4328             d++;
4329
4330         /* look for a fractional part */
4331         if (*d == '.') {
4332             /* we found it, so consume it */
4333             saw_decimal++;
4334             d++;
4335         }
4336         else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') {
4337             if ( d == s ) {
4338                 /* found nothing */
4339                 BADVERSION(s,errstr,"Invalid version format (version required)");
4340             }
4341             /* found just an integer */
4342             goto version_prescan_finish;
4343         }
4344         else if ( d == s ) {
4345             /* didn't find either integer or period */
4346             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4347         }
4348         else if (*d == '_') {
4349             /* underscore can't come after integer part */
4350             if (strict) {
4351                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4352             }
4353             else if (isDIGIT(d[1])) {
4354                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4355             }
4356             else {
4357                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4358             }
4359         }
4360         else {
4361             /* anything else after integer part is just invalid data */
4362             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4363         }
4364
4365         /* scan the fractional part after the decimal point*/
4366
4367         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) {
4368                 /* strict or lax-but-not-the-end */
4369                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4370         }
4371
4372         while (isDIGIT(*d)) {
4373             d++;
4374             if (*d == '.' && isDIGIT(d[-1])) {
4375                 if (alpha) {
4376                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4377                 }
4378                 if (strict) {
4379                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4380                 }
4381                 d = (char *)s;          /* start all over again */
4382                 qv = TRUE;
4383                 goto dotted_decimal_version;
4384             }
4385             if (*d == '_') {
4386                 if (strict) {
4387                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4388                 }
4389                 if ( alpha ) {
4390                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4391                 }
4392                 if ( ! isDIGIT(d[1]) ) {
4393                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4394                 }
4395                 d++;
4396                 alpha = TRUE;
4397             }
4398         }
4399     }
4400
4401 version_prescan_finish:
4402     while (isSPACE(*d))
4403         d++;
4404
4405     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) {
4406         /* trailing non-numeric data */
4407         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4408     }
4409
4410     if (sqv)
4411         *sqv = qv;
4412     if (swidth)
4413         *swidth = width;
4414     if (ssaw_decimal)
4415         *ssaw_decimal = saw_decimal;
4416     if (salpha)
4417         *salpha = alpha;
4418     return d;
4419 }
4420
4421 /*
4422 =for apidoc scan_version
4423
4424 Returns a pointer to the next character after the parsed
4425 version string, as well as upgrading the passed in SV to
4426 an RV.
4427
4428 Function must be called with an already existing SV like
4429
4430     sv = newSV(0);
4431     s = scan_version(s, SV *sv, bool qv);
4432
4433 Performs some preprocessing to the string to ensure that
4434 it has the correct characteristics of a version.  Flags the
4435 object if it contains an underscore (which denotes this
4436 is an alpha version).  The boolean qv denotes that the version
4437 should be interpreted as if it had multiple decimals, even if
4438 it doesn't.
4439
4440 =cut
4441 */
4442
4443 const char *
4444 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4445 {
4446     const char *start;
4447     const char *pos;
4448     const char *last;
4449     const char *errstr = NULL;
4450     int saw_decimal = 0;
4451     int width = 3;
4452     bool alpha = FALSE;
4453     bool vinf = FALSE;
4454     AV * const av = newAV();
4455     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4456
4457     PERL_ARGS_ASSERT_SCAN_VERSION;
4458
4459     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4460
4461 #ifndef NODEFAULT_SHAREKEYS
4462     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4463 #endif
4464
4465     while (isSPACE(*s)) /* leading whitespace is OK */
4466         s++;
4467
4468     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4469     if (errstr) {
4470         /* "undef" is a special case and not an error */
4471         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4472             Perl_croak(aTHX_ "%s", errstr);
4473         }
4474     }
4475
4476     start = s;
4477     if (*s == 'v')
4478         s++;
4479     pos = s;
4480
4481     if ( qv )
4482         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4483     if ( alpha )
4484         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4485     if ( !qv && width < 3 )
4486         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4487
4488     while (isDIGIT(*pos))
4489         pos++;
4490     if (!isALPHA(*pos)) {
4491         I32 rev;
4492
4493         for (;;) {
4494             rev = 0;
4495             {
4496                 /* this is atoi() that delimits on underscores */
4497                 const char *end = pos;
4498                 I32 mult = 1;
4499                 I32 orev;
4500
4501                 /* the following if() will only be true after the decimal
4502                  * point of a version originally created with a bare
4503                  * floating point number, i.e. not quoted in any way
4504                  */
4505                 if ( !qv && s > start && saw_decimal == 1 ) {
4506                     mult *= 100;
4507                     while ( s < end ) {
4508                         orev = rev;
4509                         rev += (*s - '0') * mult;
4510                         mult /= 10;
4511                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4512                             || (PERL_ABS(rev) > VERSION_MAX )) {
4513                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4514                                            "Integer overflow in version %d",VERSION_MAX);
4515                             s = end - 1;
4516                             rev = VERSION_MAX;
4517                             vinf = 1;
4518                         }
4519                         s++;
4520                         if ( *s == '_' )
4521                             s++;
4522                     }
4523                 }
4524                 else {
4525                     while (--end >= s) {
4526                         orev = rev;
4527                         rev += (*end - '0') * mult;
4528                         mult *= 10;
4529                         if (   (PERL_ABS(orev) > PERL_ABS(rev))
4530                             || (PERL_ABS(rev) > VERSION_MAX )) {
4531                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4532                                            "Integer overflow in version");
4533                             end = s - 1;
4534                             rev = VERSION_MAX;
4535                             vinf = 1;
4536                         }
4537                     }
4538                 }
4539             }
4540
4541             /* Append revision */
4542             av_push(av, newSViv(rev));
4543             if ( vinf ) {
4544                 s = last;
4545                 break;
4546             }
4547             else if ( *pos == '.' )
4548                 s = ++pos;
4549             else if ( *pos == '_' && isDIGIT(pos[1]) )
4550                 s = ++pos;
4551             else if ( *pos == ',' && isDIGIT(pos[1]) )
4552                 s = ++pos;
4553             else if ( isDIGIT(*pos) )
4554                 s = pos;
4555             else {
4556                 s = pos;
4557                 break;
4558             }
4559             if ( qv ) {
4560                 while ( isDIGIT(*pos) )
4561                     pos++;
4562             }
4563             else {
4564                 int digits = 0;
4565                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4566                     if ( *pos != '_' )
4567                         digits++;
4568                     pos++;
4569                 }
4570             }
4571         }
4572     }
4573     if ( qv ) { /* quoted versions always get at least three terms*/
4574         I32 len = av_len(av);
4575         /* This for loop appears to trigger a compiler bug on OS X, as it
4576            loops infinitely. Yes, len is negative. No, it makes no sense.
4577            Compiler in question is:
4578            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4579            for ( len = 2 - len; len > 0; len-- )
4580            av_push(MUTABLE_AV(sv), newSViv(0));
4581         */
4582         len = 2 - len;
4583         while (len-- > 0)
4584             av_push(av, newSViv(0));
4585     }
4586
4587     /* need to save off the current version string for later */
4588     if ( vinf ) {
4589         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4590         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4591         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4592     }
4593     else if ( s > start ) {
4594         SV * orig = newSVpvn(start,s-start);
4595         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4596             /* need to insert a v to be consistent */
4597             sv_insert(orig, 0, 0, "v", 1);
4598         }
4599         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4600     }
4601     else {
4602         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4603         av_push(av, newSViv(0));
4604     }
4605
4606     /* And finally, store the AV in the hash */
4607     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4608
4609     /* fix RT#19517 - special case 'undef' as string */
4610     if ( *s == 'u' && strEQ(s,"undef") ) {
4611         s += 5;
4612     }
4613
4614     return s;
4615 }
4616
4617 /*
4618 =for apidoc new_version
4619
4620 Returns a new version object based on the passed in SV:
4621
4622     SV *sv = new_version(SV *ver);
4623
4624 Does not alter the passed in ver SV.  See "upg_version" if you
4625 want to upgrade the SV.
4626
4627 =cut
4628 */
4629
4630 SV *
4631 Perl_new_version(pTHX_ SV *ver)
4632 {
4633     dVAR;
4634     SV * const rv = newSV(0);
4635     PERL_ARGS_ASSERT_NEW_VERSION;
4636     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4637     {
4638         I32 key;
4639         AV * const av = newAV();
4640         AV *sav;
4641         /* This will get reblessed later if a derived class*/
4642         SV * const hv = newSVrv(rv, "version");
4643         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4644 #ifndef NODEFAULT_SHAREKEYS
4645         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4646 #endif
4647
4648         if ( SvROK(ver) )
4649             ver = SvRV(ver);
4650
4651         /* Begin copying all of the elements */
4652         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4653             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4654
4655         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4656             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4657
4658         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4659         {
4660             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4661             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4662         }
4663
4664         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4665         {
4666             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4667             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4668         }
4669
4670         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4671         /* This will get reblessed later if a derived class*/
4672         for ( key = 0; key <= av_len(sav); key++ )
4673         {
4674             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4675             av_push(av, newSViv(rev));
4676         }
4677
4678         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4679         return rv;
4680     }
4681 #ifdef SvVOK
4682     {
4683         const MAGIC* const mg = SvVSTRING_mg(ver);
4684         if ( mg ) { /* already a v-string */
4685             const STRLEN len = mg->mg_len;
4686             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4687             sv_setpvn(rv,version,len);
4688             /* this is for consistency with the pure Perl class */
4689             if ( isDIGIT(*version) )
4690                 sv_insert(rv, 0, 0, "v", 1);
4691             Safefree(version);
4692         }
4693         else {
4694 #endif
4695         sv_setsv(rv,ver); /* make a duplicate */
4696 #ifdef SvVOK
4697         }
4698     }
4699 #endif
4700     return upg_version(rv, FALSE);
4701 }
4702
4703 /*
4704 =for apidoc upg_version
4705
4706 In-place upgrade of the supplied SV to a version object.
4707
4708     SV *sv = upg_version(SV *sv, bool qv);
4709
4710 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4711 to force this SV to be interpreted as an "extended" version.
4712
4713 =cut
4714 */
4715
4716 SV *
4717 Perl_upg_version(pTHX_ SV *ver, bool qv)
4718 {
4719     const char *version, *s;
4720 #ifdef SvVOK
4721     const MAGIC *mg;
4722 #endif
4723
4724     PERL_ARGS_ASSERT_UPG_VERSION;
4725
4726     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4727     {
4728         /* may get too much accuracy */
4729         char tbuf[64];
4730 #ifdef USE_LOCALE_NUMERIC
4731         char *loc = setlocale(LC_NUMERIC, "C");
4732 #endif
4733         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4734 #ifdef USE_LOCALE_NUMERIC
4735         setlocale(LC_NUMERIC, loc);
4736 #endif
4737         while (tbuf[len-1] == '0' && len > 0) len--;
4738         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4739         version = savepvn(tbuf, len);
4740     }
4741 #ifdef SvVOK
4742     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4743         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4744         qv = TRUE;
4745     }
4746 #endif
4747     else /* must be a string or something like a string */
4748     {
4749         STRLEN len;
4750         version = savepv(SvPV(ver,len));
4751 #ifndef SvVOK
4752 #  if PERL_VERSION > 5
4753         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4754         if ( len >= 3 && !instr(version,".") && !instr(version,"_")
4755             && !(*version == 'u' && strEQ(version, "undef"))
4756             && (*version < '0' || *version > '9') ) {
4757             /* may be a v-string */
4758             SV * const nsv = sv_newmortal();
4759             const char *nver;
4760             const char *pos;
4761             int saw_decimal = 0;
4762             sv_setpvf(nsv,"v%vd",ver);
4763             pos = nver = savepv(SvPV_nolen(nsv));
4764
4765             /* scan the resulting formatted string */
4766             pos++; /* skip the leading 'v' */
4767             while ( *pos == '.' || isDIGIT(*pos) ) {
4768                 if ( *pos == '.' )
4769                     saw_decimal++ ;
4770                 pos++;
4771             }
4772
4773             /* is definitely a v-string */
4774             if ( saw_decimal >= 2 ) {
4775                 Safefree(version);
4776                 version = nver;
4777             }
4778         }
4779 #  endif
4780 #endif
4781     }
4782
4783     s = scan_version(version, ver, qv);
4784     if ( *s != '\0' )
4785         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4786                        "Version string '%s' contains invalid data; "
4787                        "ignoring: '%s'", version, s);
4788     Safefree(version);
4789     return ver;
4790 }
4791
4792 /*
4793 =for apidoc vverify
4794
4795 Validates that the SV contains a valid version object.
4796
4797     bool vverify(SV *vobj);
4798
4799 Note that it only confirms the bare minimum structure (so as not to get
4800 confused by derived classes which may contain additional hash entries):
4801
4802 =over 4
4803
4804 =item * The SV contains a [reference to a] hash
4805
4806 =item * The hash contains a "version" key
4807
4808 =item * The "version" key has [a reference to] an AV as its value
4809
4810 =back
4811
4812 =cut
4813 */
4814
4815 bool
4816 Perl_vverify(pTHX_ SV *vs)
4817 {
4818     SV *sv;
4819
4820     PERL_ARGS_ASSERT_VVERIFY;
4821
4822     if ( SvROK(vs) )
4823         vs = SvRV(vs);
4824
4825     /* see if the appropriate elements exist */
4826     if ( SvTYPE(vs) == SVt_PVHV
4827          && hv_exists(MUTABLE_HV(vs), "version", 7)
4828          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4829          && SvTYPE(sv) == SVt_PVAV )
4830         return TRUE;
4831     else
4832         return FALSE;
4833 }
4834
4835 /*
4836 =for apidoc vnumify
4837
4838 Accepts a version object and returns the normalized floating
4839 point representation.  Call like:
4840
4841     sv = vnumify(rv);
4842
4843 NOTE: you can pass either the object directly or the SV
4844 contained within the RV.
4845
4846 =cut
4847 */
4848
4849 SV *
4850 Perl_vnumify(pTHX_ SV *vs)
4851 {
4852     I32 i, len, digit;
4853     int width;
4854     bool alpha = FALSE;
4855     SV *sv;
4856     AV *av;
4857
4858     PERL_ARGS_ASSERT_VNUMIFY;
4859
4860     if ( SvROK(vs) )
4861         vs = SvRV(vs);
4862
4863     if ( !vverify(vs) )
4864         Perl_croak(aTHX_ "Invalid version object");
4865
4866     /* see if various flags exist */
4867     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4868         alpha = TRUE;
4869     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4870         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4871     else
4872         width = 3;
4873
4874
4875     /* attempt to retrieve the version array */
4876     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4877         return newSVpvs("0");
4878     }
4879
4880     len = av_len(av);
4881     if ( len == -1 )
4882     {
4883         return newSVpvs("0");
4884     }
4885
4886     digit = SvIV(*av_fetch(av, 0, 0));
4887     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4888     for ( i = 1 ; i < len ; i++ )
4889     {
4890         digit = SvIV(*av_fetch(av, i, 0));
4891         if ( width < 3 ) {
4892             const int denom = (width == 2 ? 10 : 100);
4893             const div_t term = div((int)PERL_ABS(digit),denom);
4894             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4895         }
4896         else {
4897             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4898         }
4899     }
4900
4901     if ( len > 0 )
4902     {
4903         digit = SvIV(*av_fetch(av, len, 0));
4904         if ( alpha && width == 3 ) /* alpha version */
4905             sv_catpvs(sv,"_");
4906         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4907     }
4908     else /* len == 0 */
4909     {
4910         sv_catpvs(sv, "000");
4911     }
4912     return sv;
4913 }
4914
4915 /*
4916 =for apidoc vnormal
4917
4918 Accepts a version object and returns the normalized string
4919 representation.  Call like:
4920
4921     sv = vnormal(rv);
4922
4923 NOTE: you can pass either the object directly or the SV
4924 contained within the RV.
4925
4926 =cut
4927 */
4928
4929 SV *
4930 Perl_vnormal(pTHX_ SV *vs)
4931 {
4932     I32 i, len, digit;
4933     bool alpha = FALSE;
4934     SV *sv;
4935     AV *av;
4936
4937     PERL_ARGS_ASSERT_VNORMAL;
4938
4939     if ( SvROK(vs) )
4940         vs = SvRV(vs);
4941
4942     if ( !vverify(vs) )
4943         Perl_croak(aTHX_ "Invalid version object");
4944
4945     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4946         alpha = TRUE;
4947     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
4948
4949     len = av_len(av);
4950     if ( len == -1 )
4951     {
4952         return newSVpvs("");
4953     }
4954     digit = SvIV(*av_fetch(av, 0, 0));
4955     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
4956     for ( i = 1 ; i < len ; i++ ) {
4957         digit = SvIV(*av_fetch(av, i, 0));
4958         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4959     }
4960
4961     if ( len > 0 )
4962     {
4963         /* handle last digit specially */
4964         digit = SvIV(*av_fetch(av, len, 0));
4965         if ( alpha )
4966             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4967         else
4968             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4969     }
4970
4971     if ( len <= 2 ) { /* short version, must be at least three */
4972         for ( len = 2 - len; len != 0; len-- )
4973             sv_catpvs(sv,".0");
4974     }
4975     return sv;
4976 }
4977
4978 /*
4979 =for apidoc vstringify
4980
4981 In order to maintain maximum compatibility with earlier versions
4982 of Perl, this function will return either the floating point
4983 notation or the multiple dotted notation, depending on whether
4984 the original version contained 1 or more dots, respectively
4985
4986 =cut
4987 */
4988
4989 SV *
4990 Perl_vstringify(pTHX_ SV *vs)
4991 {
4992     PERL_ARGS_ASSERT_VSTRINGIFY;
4993
4994     if ( SvROK(vs) )
4995         vs = SvRV(vs);
4996
4997     if ( !vverify(vs) )
4998         Perl_croak(aTHX_ "Invalid version object");
4999
5000     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
5001         SV *pv;
5002         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5003         if ( SvPOK(pv) )
5004             return newSVsv(pv);
5005         else
5006             return &PL_sv_undef;
5007     }
5008     else {
5009         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5010             return vnormal(vs);
5011         else
5012             return vnumify(vs);
5013     }
5014 }
5015
5016 /*
5017 =for apidoc vcmp
5018
5019 Version object aware cmp.  Both operands must already have been
5020 converted into version objects.
5021
5022 =cut
5023 */
5024
5025 int
5026 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5027 {
5028     I32 i,l,m,r,retval;
5029     bool lalpha = FALSE;
5030     bool ralpha = FALSE;
5031     I32 left = 0;
5032     I32 right = 0;
5033     AV *lav, *rav;
5034
5035     PERL_ARGS_ASSERT_VCMP;
5036
5037     if ( SvROK(lhv) )
5038         lhv = SvRV(lhv);
5039     if ( SvROK(rhv) )
5040         rhv = SvRV(rhv);
5041
5042     if ( !vverify(lhv) )
5043         Perl_croak(aTHX_ "Invalid version object");
5044
5045     if ( !vverify(rhv) )
5046         Perl_croak(aTHX_ "Invalid version object");
5047
5048     /* get the left hand term */
5049     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5050     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5051         lalpha = TRUE;
5052
5053     /* and the right hand term */
5054     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5055     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5056         ralpha = TRUE;
5057
5058     l = av_len(lav);
5059     r = av_len(rav);
5060     m = l < r ? l : r;
5061     retval = 0;
5062     i = 0;
5063     while ( i <= m && retval == 0 )
5064     {
5065         left  = SvIV(*av_fetch(lav,i,0));
5066         right = SvIV(*av_fetch(rav,i,0));
5067         if ( left < right  )
5068             retval = -1;
5069         if ( left > right )
5070             retval = +1;
5071         i++;
5072     }
5073
5074     /* tiebreaker for alpha with identical terms */
5075     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5076     {
5077         if ( lalpha && !ralpha )
5078         {
5079             retval = -1;
5080         }
5081         else if ( ralpha && !lalpha)
5082         {
5083             retval = +1;
5084         }
5085     }
5086
5087     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5088     {
5089         if ( l < r )
5090         {
5091             while ( i <= r && retval == 0 )
5092             {
5093                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5094                     retval = -1; /* not a match after all */
5095                 i++;
5096             }
5097         }
5098         else
5099         {
5100             while ( i <= l && retval == 0 )
5101             {
5102                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5103                     retval = +1; /* not a match after all */
5104                 i++;
5105             }
5106         }
5107     }
5108     return retval;
5109 }
5110
5111 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5112 #   define EMULATE_SOCKETPAIR_UDP
5113 #endif
5114
5115 #ifdef EMULATE_SOCKETPAIR_UDP
5116 static int
5117 S_socketpair_udp (int fd[2]) {
5118     dTHX;
5119     /* Fake a datagram socketpair using UDP to localhost.  */
5120     int sockets[2] = {-1, -1};
5121     struct sockaddr_in addresses[2];
5122     int i;
5123     Sock_size_t size = sizeof(struct sockaddr_in);
5124     unsigned short port;
5125     int got;
5126
5127     memset(&addresses, 0, sizeof(addresses));
5128     i = 1;
5129     do {
5130         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5131         if (sockets[i] == -1)
5132             goto tidy_up_and_fail;
5133
5134         addresses[i].sin_family = AF_INET;
5135         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5136         addresses[i].sin_port = 0;      /* kernel choses port.  */
5137         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5138                 sizeof(struct sockaddr_in)) == -1)
5139             goto tidy_up_and_fail;
5140     } while (i--);
5141
5142     /* Now have 2 UDP sockets. Find out which port each is connected to, and
5143        for each connect the other socket to it.  */
5144     i = 1;
5145     do {
5146         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5147                 &size) == -1)
5148             goto tidy_up_and_fail;
5149         if (size != sizeof(struct sockaddr_in))
5150             goto abort_tidy_up_and_fail;
5151         /* !1 is 0, !0 is 1 */
5152         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5153                 sizeof(struct sockaddr_in)) == -1)
5154             goto tidy_up_and_fail;
5155     } while (i--);
5156
5157     /* Now we have 2 sockets connected to each other. I don't trust some other
5158        process not to have already sent a packet to us (by random) so send
5159        a packet from each to the other.  */
5160     i = 1;
5161     do {
5162         /* I'm going to send my own port number.  As a short.
5163            (Who knows if someone somewhere has sin_port as a bitfield and needs
5164            this routine. (I'm assuming crays have socketpair)) */
5165         port = addresses[i].sin_port;
5166         got = PerlLIO_write(sockets[i], &port, sizeof(port));
5167         if (got != sizeof(port)) {
5168             if (got == -1)
5169                 goto tidy_up_and_fail;
5170             goto abort_tidy_up_and_fail;
5171         }
5172     } while (i--);
5173
5174     /* Packets sent. I don't trust them to have arrived though.
5175        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5176        connect to localhost will use a second kernel thread. In 2.6 the
5177        first thread running the connect() returns before the second completes,
5178        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5179        returns 0. Poor programs have tripped up. One poor program's authors'
5180        had a 50-1 reverse stock split. Not sure how connected these were.)
5181        So I don't trust someone not to have an unpredictable UDP stack.
5182     */
5183
5184     {
5185         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5186         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5187         fd_set rset;
5188
5189         FD_ZERO(&rset);
5190         FD_SET((unsigned int)sockets[0], &rset);
5191         FD_SET((unsigned int)sockets[1], &rset);
5192
5193         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5194         if (got != 2 || !FD_ISSET(sockets[0], &rset)
5195                 || !FD_ISSET(sockets[1], &rset)) {
5196             /* I hope this is portable and appropriate.  */
5197             if (got == -1)
5198                 goto tidy_up_and_fail;
5199             goto abort_tidy_up_and_fail;
5200         }
5201     }
5202
5203     /* And the paranoia department even now doesn't trust it to have arrive
5204        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
5205     {
5206         struct sockaddr_in readfrom;
5207         unsigned short buffer[2];
5208
5209         i = 1;
5210         do {
5211 #ifdef MSG_DONTWAIT
5212             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5213                     sizeof(buffer), MSG_DONTWAIT,
5214                     (struct sockaddr *) &readfrom, &size);
5215 #else
5216             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5217                     sizeof(buffer), 0,
5218                     (struct sockaddr *) &readfrom, &size);
5219 #endif
5220
5221             if (got == -1)
5222                 goto tidy_up_and_fail;
5223             if (got != sizeof(port)
5224                     || size != sizeof(struct sockaddr_in)
5225                     /* Check other socket sent us its port.  */
5226                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5227                     /* Check kernel says we got the datagram from that socket */
5228                     || readfrom.sin_family != addresses[!i].sin_family
5229                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5230                     || readfrom.sin_port != addresses[!i].sin_port)
5231                 goto abort_tidy_up_and_fail;
5232         } while (i--);
5233     }
5234     /* My caller (my_socketpair) has validated that this is non-NULL  */
5235     fd[0] = sockets[0];
5236     fd[1] = sockets[1];
5237     /* I hereby declare this connection open.  May God bless all who cross
5238        her.  */
5239     return 0;
5240
5241   abort_tidy_up_and_fail:
5242     errno = ECONNABORTED;
5243   tidy_up_and_fail:
5244     {
5245         dSAVE_ERRNO;
5246         if (sockets[0] != -1)
5247             PerlLIO_close(sockets[0]);
5248         if (sockets[1] != -1)
5249             PerlLIO_close(sockets[1]);
5250         RESTORE_ERRNO;
5251         return -1;
5252     }
5253 }
5254 #endif /*  EMULATE_SOCKETPAIR_UDP */
5255
5256 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5257 int
5258 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5259     /* Stevens says that family must be AF_LOCAL, protocol 0.
5260        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5261     dTHX;
5262     int listener = -1;
5263     int connector = -1;
5264     int acceptor = -1;
5265     struct sockaddr_in listen_addr;
5266     struct sockaddr_in connect_addr;
5267     Sock_size_t size;
5268
5269     if (protocol
5270 #ifdef AF_UNIX
5271         || family != AF_UNIX
5272 #endif
5273     ) {
5274         errno = EAFNOSUPPORT;
5275         return -1;
5276     }
5277     if (!fd) {
5278         errno = EINVAL;
5279         return -1;
5280     }
5281
5282 #ifdef EMULATE_SOCKETPAIR_UDP
5283     if (type == SOCK_DGRAM)
5284         return S_socketpair_udp(fd);
5285 #endif
5286
5287     listener = PerlSock_socket(AF_INET, type, 0);
5288     if (listener == -1)
5289         return -1;
5290     memset(&listen_addr, 0, sizeof(listen_addr));
5291     listen_addr.sin_family = AF_INET;
5292     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5293     listen_addr.sin_port = 0;   /* kernel choses port.  */
5294     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5295             sizeof(listen_addr)) == -1)
5296         goto tidy_up_and_fail;
5297     if (PerlSock_listen(listener, 1) == -1)
5298         goto tidy_up_and_fail;
5299
5300     connector = PerlSock_socket(AF_INET, type, 0);
5301     if (connector == -1)
5302         goto tidy_up_and_fail;
5303     /* We want to find out the port number to connect to.  */
5304     size = sizeof(connect_addr);
5305     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5306             &size) == -1)
5307         goto tidy_up_and_fail;
5308     if (size != sizeof(connect_addr))
5309         goto abort_tidy_up_and_fail;
5310     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5311             sizeof(connect_addr)) == -1)
5312         goto tidy_up_and_fail;
5313
5314     size = sizeof(listen_addr);
5315     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5316             &size);
5317     if (acceptor == -1)
5318         goto tidy_up_and_fail;
5319     if (size != sizeof(listen_addr))
5320         goto abort_tidy_up_and_fail;
5321     PerlLIO_close(listener);
5322     /* Now check we are talking to ourself by matching port and host on the
5323        two sockets.  */
5324     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5325             &size) == -1)
5326         goto tidy_up_and_fail;
5327     if (size != sizeof(connect_addr)
5328             || listen_addr.sin_family != connect_addr.sin_family
5329             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5330             || listen_addr.sin_port != connect_addr.sin_port) {
5331         goto abort_tidy_up_and_fail;
5332     }
5333     fd[0] = connector;
5334     fd[1] = acceptor;
5335     return 0;
5336
5337   abort_tidy_up_and_fail:
5338 #ifdef ECONNABORTED
5339   errno = ECONNABORTED; /* This would be the standard thing to do. */
5340 #else
5341 #  ifdef ECONNREFUSED
5342   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5343 #  else
5344   errno = ETIMEDOUT;    /* Desperation time. */
5345 #  endif
5346 #endif
5347   tidy_up_and_fail:
5348     {
5349         dSAVE_ERRNO;
5350         if (listener != -1)
5351             PerlLIO_close(listener);
5352         if (connector != -1)
5353             PerlLIO_close(connector);
5354         if (acceptor != -1)
5355             PerlLIO_close(acceptor);
5356         RESTORE_ERRNO;
5357         return -1;
5358     }
5359 }
5360 #else
5361 /* In any case have a stub so that there's code corresponding
5362  * to the my_socketpair in global.sym. */
5363 int
5364 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5365 #ifdef HAS_SOCKETPAIR
5366     return socketpair(family, type, protocol, fd);
5367 #else
5368     return -1;
5369 #endif
5370 }
5371 #endif
5372
5373 /*
5374
5375 =for apidoc sv_nosharing
5376
5377 Dummy routine which "shares" an SV when there is no sharing module present.
5378 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5379 Exists to avoid test for a NULL function pointer and because it could
5380 potentially warn under some level of strict-ness.
5381
5382 =cut
5383 */
5384
5385 void
5386 Perl_sv_nosharing(pTHX_ SV *sv)
5387 {
5388     PERL_UNUSED_CONTEXT;
5389     PERL_UNUSED_ARG(sv);
5390 }
5391
5392 /*
5393
5394 =for apidoc sv_destroyable
5395
5396 Dummy routine which reports that object can be destroyed when there is no
5397 sharing module present.  It ignores its single SV argument, and returns
5398 'true'.  Exists to avoid test for a NULL function pointer and because it
5399 could potentially warn under some level of strict-ness.
5400
5401 =cut
5402 */
5403
5404 bool
5405 Perl_sv_destroyable(pTHX_ SV *sv)
5406 {
5407     PERL_UNUSED_CONTEXT;
5408     PERL_UNUSED_ARG(sv);
5409     return TRUE;
5410 }
5411
5412 U32
5413 Perl_parse_unicode_opts(pTHX_ const char **popt)
5414 {
5415   const char *p = *popt;
5416   U32 opt = 0;
5417
5418   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5419
5420   if (*p) {
5421        if (isDIGIT(*p)) {
5422             opt = (U32) atoi(p);
5423             while (isDIGIT(*p))
5424                 p++;
5425             if (*p && *p != '\n' && *p != '\r')
5426                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5427        }
5428        else {
5429             for (; *p; p++) {
5430                  switch (*p) {
5431                  case PERL_UNICODE_STDIN:
5432                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5433                  case PERL_UNICODE_STDOUT:
5434                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5435                  case PERL_UNICODE_STDERR:
5436                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5437                  case PERL_UNICODE_STD:
5438                       opt |= PERL_UNICODE_STD_FLAG;     break;
5439                  case PERL_UNICODE_IN:
5440                       opt |= PERL_UNICODE_IN_FLAG;      break;
5441                  case PERL_UNICODE_OUT:
5442                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5443                  case PERL_UNICODE_INOUT:
5444                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5445                  case PERL_UNICODE_LOCALE:
5446                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5447                  case PERL_UNICODE_ARGV:
5448                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5449                  case PERL_UNICODE_UTF8CACHEASSERT:
5450                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5451                  default:
5452                       if (*p != '\n' && *p != '\r')
5453                           Perl_croak(aTHX_
5454                                      "Unknown Unicode option letter '%c'", *p);
5455                  }
5456             }
5457        }
5458   }
5459   else
5460        opt = PERL_UNICODE_DEFAULT_FLAGS;
5461
5462   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5463        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5464                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5465
5466   *popt = p;
5467
5468   return opt;
5469 }
5470
5471 U32
5472 Perl_seed(pTHX)
5473 {
5474     dVAR;
5475     /*
5476      * This is really just a quick hack which grabs various garbage
5477      * values.  It really should be a real hash algorithm which
5478      * spreads the effect of every input bit onto every output bit,
5479      * if someone who knows about such things would bother to write it.
5480      * Might be a good idea to add that function to CORE as well.
5481      * No numbers below come from careful analysis or anything here,
5482      * except they are primes and SEED_C1 > 1E6 to get a full-width
5483      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5484      * probably be bigger too.
5485      */
5486 #if RANDBITS > 16
5487 #  define SEED_C1       1000003
5488 #define   SEED_C4       73819
5489 #else
5490 #  define SEED_C1       25747
5491 #define   SEED_C4       20639
5492 #endif
5493 #define   SEED_C2       3
5494 #define   SEED_C3       269
5495 #define   SEED_C5       26107
5496
5497 #ifndef PERL_NO_DEV_RANDOM
5498     int fd;
5499 #endif
5500     U32 u;
5501 #ifdef VMS
5502 #  include <starlet.h>
5503     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5504      * in 100-ns units, typically incremented ever 10 ms.        */
5505     unsigned int when[2];
5506 #else
5507 #  ifdef HAS_GETTIMEOFDAY
5508     struct timeval when;
5509 #  else
5510     Time_t when;
5511 #  endif
5512 #endif
5513
5514 /* This test is an escape hatch, this symbol isn't set by Configure. */
5515 #ifndef PERL_NO_DEV_RANDOM
5516 #ifndef PERL_RANDOM_DEVICE
5517    /* /dev/random isn't used by default because reads from it will block
5518     * if there isn't enough entropy available.  You can compile with
5519     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5520     * is enough real entropy to fill the seed. */
5521 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5522 #endif
5523     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5524     if (fd != -1) {
5525         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5526             u = 0;
5527         PerlLIO_close(fd);
5528         if (u)
5529             return u;
5530     }
5531 #endif
5532
5533 #ifdef VMS
5534     _ckvmssts(sys$gettim(when));
5535     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5536 #else
5537 #  ifdef HAS_GETTIMEOFDAY
5538     PerlProc_gettimeofday(&when,NULL);
5539     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5540 #  else
5541     (void)time(&when);
5542     u = (U32)SEED_C1 * when;
5543 #  endif
5544 #endif
5545     u += SEED_C3 * (U32)PerlProc_getpid();
5546     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5547 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5548     u += SEED_C5 * (U32)PTR2UV(&when);
5549 #endif
5550     return u;
5551 }
5552
5553 UV
5554 Perl_get_hash_seed(pTHX)
5555 {
5556     dVAR;
5557      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5558      UV myseed = 0;
5559
5560      if (s)
5561         while (isSPACE(*s))
5562             s++;
5563      if (s && isDIGIT(*s))
5564           myseed = (UV)Atoul(s);
5565      else
5566 #ifdef USE_HASH_SEED_EXPLICIT
5567      if (s)
5568 #endif
5569      {
5570           /* Compute a random seed */
5571           (void)seedDrand01((Rand_seed_t)seed());
5572           myseed = (UV)(Drand01() * (NV)UV_MAX);
5573 #if RANDBITS < (UVSIZE * 8)
5574           /* Since there are not enough randbits to to reach all
5575            * the bits of a UV, the low bits might need extra
5576            * help.  Sum in another random number that will
5577            * fill in the low bits. */
5578           myseed +=
5579                (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1));
5580 #endif /* RANDBITS < (UVSIZE * 8) */
5581           if (myseed == 0) { /* Superparanoia. */
5582               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5583               if (myseed == 0)
5584                   Perl_croak(aTHX_ "Your random numbers are not that random");
5585           }
5586      }
5587      PL_rehash_seed_set = TRUE;
5588
5589      return myseed;
5590 }
5591
5592 #ifdef USE_ITHREADS
5593 bool
5594 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5595 {
5596     const char * const stashpv = CopSTASHPV(c);
5597     const char * const name = HvNAME_get(hv);
5598     PERL_UNUSED_CONTEXT;
5599     PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH;
5600
5601     if (stashpv == name)
5602         return TRUE;
5603     if (stashpv && name)
5604         if (strEQ(stashpv, name))
5605             return TRUE;
5606     return FALSE;
5607 }
5608 #endif
5609
5610
5611 #ifdef PERL_GLOBAL_STRUCT
5612
5613 #define PERL_GLOBAL_STRUCT_INIT
5614 #include "opcode.h" /* the ppaddr and check */
5615
5616 struct perl_vars *
5617 Perl_init_global_struct(pTHX)
5618 {
5619     struct perl_vars *plvarsp = NULL;
5620 # ifdef PERL_GLOBAL_STRUCT
5621     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5622     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5623 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5624     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5625     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5626     if (!plvarsp)
5627         exit(1);
5628 #  else
5629     plvarsp = PL_VarsPtr;
5630 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5631 #  undef PERLVAR
5632 #  undef PERLVARA
5633 #  undef PERLVARI
5634 #  undef PERLVARIC
5635 #  undef PERLVARISC
5636 #  define PERLVAR(var,type) /**/
5637 #  define PERLVARA(var,n,type) /**/
5638 #  define PERLVARI(var,type,init) plvarsp->var = init;
5639 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5640 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5641 #  include "perlvars.h"
5642 #  undef PERLVAR
5643 #  undef PERLVARA
5644 #  undef PERLVARI
5645 #  undef PERLVARIC
5646 #  undef PERLVARISC
5647 #  ifdef PERL_GLOBAL_STRUCT
5648     plvarsp->Gppaddr =
5649         (Perl_ppaddr_t*)
5650         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5651     if (!plvarsp->Gppaddr)
5652         exit(1);
5653     plvarsp->Gcheck  =
5654         (Perl_check_t*)
5655         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5656     if (!plvarsp->Gcheck)
5657         exit(1);
5658     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5659     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5660 #  endif
5661 #  ifdef PERL_SET_VARS
5662     PERL_SET_VARS(plvarsp);
5663 #  endif
5664 # undef PERL_GLOBAL_STRUCT_INIT
5665 # endif
5666     return plvarsp;
5667 }
5668
5669 #endif /* PERL_GLOBAL_STRUCT */
5670
5671 #ifdef PERL_GLOBAL_STRUCT
5672
5673 void
5674 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5675 {
5676     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5677 # ifdef PERL_GLOBAL_STRUCT
5678 #  ifdef PERL_UNSET_VARS
5679     PERL_UNSET_VARS(plvarsp);
5680 #  endif
5681     free(plvarsp->Gppaddr);
5682     free(plvarsp->Gcheck);
5683 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5684     free(plvarsp);
5685 #  endif
5686 # endif
5687 }
5688
5689 #endif /* PERL_GLOBAL_STRUCT */
5690
5691 #ifdef PERL_MEM_LOG
5692
5693 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5694  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5695  * given, and you supply your own implementation.
5696  *
5697  * The default implementation reads a single env var, PERL_MEM_LOG,
5698  * expecting one or more of the following:
5699  *
5700  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5701  *    'm' - memlog      was PERL_MEM_LOG=1
5702  *    's' - svlog       was PERL_SV_LOG=1
5703  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5704  *
5705  * This makes the logger controllable enough that it can reasonably be
5706  * added to the system perl.
5707  */
5708
5709 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5710  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5711  */
5712 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5713
5714 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5715  * writes to.  In the default logger, this is settable at runtime.
5716  */
5717 #ifndef PERL_MEM_LOG_FD
5718 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5719 #endif
5720
5721 #ifndef PERL_MEM_LOG_NOIMPL
5722
5723 # ifdef DEBUG_LEAKING_SCALARS
5724 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5725 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5726 # else
5727 #   define SV_LOG_SERIAL_FMT
5728 #   define _SV_LOG_SERIAL_ARG(sv)
5729 # endif
5730
5731 static void
5732 S_mem_log_common(enum mem_log_type mlt, const UV n,
5733                  const UV typesize, const char *type_name, const SV *sv,
5734                  Malloc_t oldalloc, Malloc_t newalloc,
5735                  const char *filename, const int linenumber,
5736                  const char *funcname)
5737 {
5738     const char *pmlenv;
5739
5740     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5741
5742     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5743     if (!pmlenv)
5744         return;
5745     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5746     {
5747         /* We can't use SVs or PerlIO for obvious reasons,
5748          * so we'll use stdio and low-level IO instead. */
5749         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5750
5751 #   ifdef HAS_GETTIMEOFDAY
5752 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5753 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5754         struct timeval tv;
5755         gettimeofday(&tv, 0);
5756 #   else
5757 #     define MEM_LOG_TIME_FMT   "%10d: "
5758 #     define MEM_LOG_TIME_ARG   (int)when
5759         Time_t when;
5760         (void)time(&when);
5761 #   endif
5762         /* If there are other OS specific ways of hires time than
5763          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5764          * probably that they would be used to fill in the struct
5765          * timeval. */
5766         {
5767             STRLEN len;
5768             int fd = atoi(pmlenv);
5769             if (!fd)
5770                 fd = PERL_MEM_LOG_FD;
5771
5772             if (strchr(pmlenv, 't')) {
5773                 len = my_snprintf(buf, sizeof(buf),
5774                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5775                 PerlLIO_write(fd, buf, len);
5776             }
5777             switch (mlt) {
5778             case MLT_ALLOC:
5779                 len = my_snprintf(buf, sizeof(buf),
5780                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5781                         " %s = %"IVdf": %"UVxf"\n",
5782                         filename, linenumber, funcname, n, typesize,
5783                         type_name, n * typesize, PTR2UV(newalloc));
5784                 break;
5785             case MLT_REALLOC:
5786                 len = my_snprintf(buf, sizeof(buf),
5787                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5788                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5789                         filename, linenumber, funcname, n, typesize,
5790                         type_name, n * typesize, PTR2UV(oldalloc),
5791                         PTR2UV(newalloc));
5792                 break;
5793             case MLT_FREE:
5794                 len = my_snprintf(buf, sizeof(buf),
5795                         "free: %s:%d:%s: %"UVxf"\n",
5796                         filename, linenumber, funcname,
5797                         PTR2UV(oldalloc));
5798                 break;
5799             case MLT_NEW_SV:
5800             case MLT_DEL_SV:
5801                 len = my_snprintf(buf, sizeof(buf),
5802                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5803                         mlt == MLT_NEW_SV ? "new" : "del",
5804                         filename, linenumber, funcname,
5805                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5806                 break;
5807             default:
5808                 len = 0;
5809             }
5810             PerlLIO_write(fd, buf, len);
5811         }
5812     }
5813 }
5814 #endif /* !PERL_MEM_LOG_NOIMPL */
5815
5816 #ifndef PERL_MEM_LOG_NOIMPL
5817 # define \
5818     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5819     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5820 #else
5821 /* this is suboptimal, but bug compatible.  User is providing their
5822    own implemenation, but is getting these functions anyway, and they
5823    do nothing. But _NOIMPL users should be able to cope or fix */
5824 # define \
5825     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5826     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5827 #endif
5828
5829 Malloc_t
5830 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5831                    Malloc_t newalloc,
5832                    const char *filename, const int linenumber,
5833                    const char *funcname)
5834 {
5835     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5836                       NULL, NULL, newalloc,
5837                       filename, linenumber, funcname);
5838     return newalloc;
5839 }
5840
5841 Malloc_t
5842 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5843                      Malloc_t oldalloc, Malloc_t newalloc,
5844                      const char *filename, const int linenumber,
5845                      const char *funcname)
5846 {
5847     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5848                       NULL, oldalloc, newalloc,
5849                       filename, linenumber, funcname);
5850     return newalloc;
5851 }
5852
5853 Malloc_t
5854 Perl_mem_log_free(Malloc_t oldalloc,
5855                   const char *filename, const int linenumber,
5856                   const char *funcname)
5857 {
5858     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
5859                       filename, linenumber, funcname);
5860     return oldalloc;
5861 }
5862
5863 void
5864 Perl_mem_log_new_sv(const SV *sv,
5865                     const char *filename, const int linenumber,
5866                     const char *funcname)
5867 {
5868     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5869                       filename, linenumber, funcname);
5870 }
5871
5872 void
5873 Perl_mem_log_del_sv(const SV *sv,
5874                     const char *filename, const int linenumber,
5875                     const char *funcname)
5876 {
5877     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
5878                       filename, linenumber, funcname);
5879 }
5880
5881 #endif /* PERL_MEM_LOG */
5882
5883 /*
5884 =for apidoc my_sprintf
5885
5886 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5887 the length of the string written to the buffer. Only rare pre-ANSI systems
5888 need the wrapper function - usually this is a direct call to C<sprintf>.
5889
5890 =cut
5891 */
5892 #ifndef SPRINTF_RETURNS_STRLEN
5893 int
5894 Perl_my_sprintf(char *buffer, const char* pat, ...)
5895 {
5896     va_list args;
5897     PERL_ARGS_ASSERT_MY_SPRINTF;
5898     va_start(args, pat);
5899     vsprintf(buffer, pat, args);
5900     va_end(args);
5901     return strlen(buffer);
5902 }
5903 #endif
5904
5905 /*
5906 =for apidoc my_snprintf
5907
5908 The C library C<snprintf> functionality, if available and
5909 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5910 C<vsnprintf> is not available, will unfortunately use the unsafe
5911 C<vsprintf> which can overrun the buffer (there is an overrun check,
5912 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5913 getting C<vsnprintf>.
5914
5915 =cut
5916 */
5917 int
5918 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5919 {
5920     dTHX;
5921     int retval;
5922     va_list ap;
5923     PERL_ARGS_ASSERT_MY_SNPRINTF;
5924     va_start(ap, format);
5925 #ifdef HAS_VSNPRINTF
5926     retval = vsnprintf(buffer, len, format, ap);
5927 #else
5928     retval = vsprintf(buffer, format, ap);
5929 #endif
5930     va_end(ap);
5931     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5932     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5933         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5934     return retval;
5935 }
5936
5937 /*
5938 =for apidoc my_vsnprintf
5939
5940 The C library C<vsnprintf> if available and standards-compliant.
5941 However, if if the C<vsnprintf> is not available, will unfortunately
5942 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5943 overrun check, but that may be too late).  Consider using
5944 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5945
5946 =cut
5947 */
5948 int
5949 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5950 {
5951     dTHX;
5952     int retval;
5953 #ifdef NEED_VA_COPY
5954     va_list apc;
5955
5956     PERL_ARGS_ASSERT_MY_VSNPRINTF;
5957
5958     Perl_va_copy(ap, apc);
5959 # ifdef HAS_VSNPRINTF
5960     retval = vsnprintf(buffer, len, format, apc);
5961 # else
5962     retval = vsprintf(buffer, format, apc);
5963 # endif
5964 #else
5965 # ifdef HAS_VSNPRINTF
5966     retval = vsnprintf(buffer, len, format, ap);
5967 # else
5968     retval = vsprintf(buffer, format, ap);
5969 # endif
5970 #endif /* #ifdef NEED_VA_COPY */
5971     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5972     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5973         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5974     return retval;
5975 }
5976
5977 void
5978 Perl_my_clearenv(pTHX)
5979 {
5980     dVAR;
5981 #if ! defined(PERL_MICRO)
5982 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5983     PerlEnv_clearenv();
5984 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5985 #    if defined(USE_ENVIRON_ARRAY)
5986 #      if defined(USE_ITHREADS)
5987     /* only the parent thread can clobber the process environment */
5988     if (PL_curinterp == aTHX)
5989 #      endif /* USE_ITHREADS */
5990     {
5991 #      if ! defined(PERL_USE_SAFE_PUTENV)
5992     if ( !PL_use_safe_putenv) {
5993       I32 i;
5994       if (environ == PL_origenviron)
5995         environ = (char**)safesysmalloc(sizeof(char*));
5996       else
5997         for (i = 0; environ[i]; i++)
5998           (void)safesysfree(environ[i]);
5999     }
6000     environ[0] = NULL;
6001 #      else /* PERL_USE_SAFE_PUTENV */
6002 #        if defined(HAS_CLEARENV)
6003     (void)clearenv();
6004 #        elif defined(HAS_UNSETENV)
6005     int bsiz = 80; /* Most envvar names will be shorter than this. */
6006     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6007     char *buf = (char*)safesysmalloc(bufsiz);
6008     while (*environ != NULL) {
6009       char *e = strchr(*environ, '=');
6010       int l = e ? e - *environ : (int)strlen(*environ);
6011       if (bsiz < l + 1) {
6012         (void)safesysfree(buf);
6013         bsiz = l + 1; /* + 1 for the \0. */
6014         buf = (char*)safesysmalloc(bufsiz);
6015       }
6016       memcpy(buf, *environ, l);
6017       buf[l] = '\0';
6018       (void)unsetenv(buf);
6019     }
6020     (void)safesysfree(buf);
6021 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6022     /* Just null environ and accept the leakage. */
6023     *environ = NULL;
6024 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
6025 #      endif /* ! PERL_USE_SAFE_PUTENV */
6026     }
6027 #    endif /* USE_ENVIRON_ARRAY */
6028 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
6029 #endif /* PERL_MICRO */
6030 }
6031
6032 #ifdef PERL_IMPLICIT_CONTEXT
6033
6034 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6035 the global PL_my_cxt_index is incremented, and that value is assigned to
6036 that module's static my_cxt_index (who's address is passed as an arg).
6037 Then, for each interpreter this function is called for, it makes sure a
6038 void* slot is available to hang the static data off, by allocating or
6039 extending the interpreter's PL_my_cxt_list array */
6040
6041 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6042 void *
6043 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6044 {
6045     dVAR;
6046     void *p;
6047     PERL_ARGS_ASSERT_MY_CXT_INIT;
6048     if (*index == -1) {
6049         /* this module hasn't been allocated an index yet */
6050 #if defined(USE_ITHREADS)
6051         MUTEX_LOCK(&PL_my_ctx_mutex);
6052 #endif
6053         *index = PL_my_cxt_index++;
6054 #if defined(USE_ITHREADS)
6055         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6056 #endif
6057     }
6058
6059     /* make sure the array is big enough */
6060     if (PL_my_cxt_size <= *index) {
6061         if (PL_my_cxt_size) {
6062             while (PL_my_cxt_size <= *index)
6063                 PL_my_cxt_size *= 2;
6064             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6065         }
6066         else {
6067             PL_my_cxt_size = 16;
6068             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6069         }
6070     }
6071     /* newSV() allocates one more than needed */
6072     p = (void*)SvPVX(newSV(size-1));
6073     PL_my_cxt_list[*index] = p;
6074     Zero(p, size, char);
6075     return p;
6076 }
6077
6078 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6079
6080 int
6081 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6082 {
6083     dVAR;
6084     int index;
6085
6086     PERL_ARGS_ASSERT_MY_CXT_INDEX;
6087
6088     for (index = 0; index < PL_my_cxt_index; index++) {
6089         const char *key = PL_my_cxt_keys[index];
6090         /* try direct pointer compare first - there are chances to success,
6091          * and it's much faster.
6092          */
6093         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6094             return index;
6095     }
6096     return -1;
6097 }
6098
6099 void *
6100 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6101 {
6102     dVAR;
6103     void *p;
6104     int index;
6105
6106     PERL_ARGS_ASSERT_MY_CXT_INIT;
6107
6108     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6109     if (index == -1) {
6110         /* this module hasn't been allocated an index yet */
6111 #if defined(USE_ITHREADS)
6112         MUTEX_LOCK(&PL_my_ctx_mutex);
6113 #endif
6114         index = PL_my_cxt_index++;
6115 #if defined(USE_ITHREADS)
6116         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6117 #endif
6118     }
6119
6120     /* make sure the array is big enough */
6121     if (PL_my_cxt_size <= index) {
6122         int old_size = PL_my_cxt_size;
6123         int i;
6124         if (PL_my_cxt_size) {
6125             while (PL_my_cxt_size <= index)
6126                 PL_my_cxt_size *= 2;
6127             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6128             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6129         }
6130         else {
6131             PL_my_cxt_size = 16;
6132             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6133             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6134         }
6135         for (i = old_size; i < PL_my_cxt_size; i++) {
6136             PL_my_cxt_keys[i] = 0;
6137             PL_my_cxt_list[i] = 0;
6138         }
6139     }
6140     PL_my_cxt_keys[index] = my_cxt_key;
6141     /* newSV() allocates one more than needed */
6142     p = (void*)SvPVX(newSV(size-1));
6143     PL_my_cxt_list[index] = p;
6144     Zero(p, size, char);
6145     return p;
6146 }
6147 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6148 #endif /* PERL_IMPLICIT_CONTEXT */
6149
6150 #ifndef HAS_STRLCAT
6151 Size_t
6152 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6153 {
6154     Size_t used, length, copy;
6155
6156     used = strlen(dst);
6157     length = strlen(src);
6158     if (size > 0 && used < size - 1) {
6159         copy = (length >= size - used) ? size - used - 1 : length;
6160         memcpy(dst + used, src, copy);
6161         dst[used + copy] = '\0';
6162     }
6163     return used + length;
6164 }
6165 #endif
6166
6167 #ifndef HAS_STRLCPY
6168 Size_t
6169 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6170 {
6171     Size_t length, copy;
6172
6173     length = strlen(src);
6174     if (size > 0) {
6175         copy = (length >= size) ? size - 1 : length;
6176         memcpy(dst, src, copy);
6177         dst[copy] = '\0';
6178     }
6179     return length;
6180 }
6181 #endif
6182
6183 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6184 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6185 long _ftol( double ); /* Defined by VC6 C libs. */
6186 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6187 #endif
6188
6189 void
6190 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6191 {
6192     dVAR;
6193     SV * const dbsv = GvSVn(PL_DBsub);
6194     /* We do not care about using sv to call CV;
6195      * it's for informational purposes only.
6196      */
6197
6198     PERL_ARGS_ASSERT_GET_DB_SUB;
6199
6200     save_item(dbsv);
6201     if (!PERLDB_SUB_NN) {
6202         GV * const gv = CvGV(cv);
6203
6204         if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6205              || strEQ(GvNAME(gv), "END")
6206              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
6207                  !( (SvTYPE(*svp) == SVt_PVGV)
6208                     && (GvCV((const GV *)*svp) == cv) )))) {
6209             /* Use GV from the stack as a fallback. */
6210             /* GV is potentially non-unique, or contain different CV. */
6211             SV * const tmp = newRV(MUTABLE_SV(cv));
6212             sv_setsv(dbsv, tmp);
6213             SvREFCNT_dec(tmp);
6214         }
6215         else {
6216             gv_efullname3(dbsv, gv, NULL);
6217         }
6218     }
6219     else {
6220         const int type = SvTYPE(dbsv);
6221         if (type < SVt_PVIV && type != SVt_IV)
6222             sv_upgrade(dbsv, SVt_PVIV);
6223         (void)SvIOK_on(dbsv);
6224         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6225     }
6226 }
6227
6228 int
6229 Perl_my_dirfd(pTHX_ DIR * dir) {
6230
6231     /* Most dirfd implementations have problems when passed NULL. */
6232     if(!dir)
6233         return -1;
6234 #ifdef HAS_DIRFD
6235     return dirfd(dir);
6236 #elif defined(HAS_DIR_DD_FD)
6237     return dir->dd_fd;
6238 #else
6239     Perl_die(aTHX_ PL_no_func, "dirfd");
6240    /* NOT REACHED */
6241     return 0;
6242 #endif
6243 }
6244
6245 REGEXP *
6246 Perl_get_re_arg(pTHX_ SV *sv) {
6247
6248     if (sv) {
6249         if (SvMAGICAL(sv))
6250             mg_get(sv);
6251         if (SvROK(sv))
6252             sv = MUTABLE_SV(SvRV(sv));
6253         if (SvTYPE(sv) == SVt_REGEXP)
6254             return (REGEXP*) sv;
6255     }
6256
6257     return NULL;
6258 }
6259
6260 /*
6261  * Local variables:
6262  * c-indentation-style: bsd
6263  * c-basic-offset: 4
6264  * indent-tabs-mode: t
6265  * End:
6266  *
6267  * ex: set ts=8 sts=4 sw=4 noet:
6268  */