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