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