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