util.c

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