util.c

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