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