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             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
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                 cur = my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3058             }
3059         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3060                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3061 #endif
3062     }
3063 #endif
3064
3065 #ifdef MACOS_TRADITIONAL
3066     if (dosearch && !strchr(scriptname, ':') &&
3067         (s = PerlEnv_getenv("Commands")))
3068 #else
3069     if (dosearch && !strchr(scriptname, '/')
3070 #ifdef DOSISH
3071                  && !strchr(scriptname, '\\')
3072 #endif
3073                  && (s = PerlEnv_getenv("PATH")))
3074 #endif
3075     {
3076         bool seen_dot = 0;
3077
3078         PL_bufend = s + strlen(s);
3079         while (s < PL_bufend) {
3080 #ifdef MACOS_TRADITIONAL
3081             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3082                         ',',
3083                         &len);
3084 #else
3085 #if defined(atarist) || defined(DOSISH)
3086             for (len = 0; *s
3087 #  ifdef atarist
3088                     && *s != ','
3089 #  endif
3090                     && *s != ';'; len++, s++) {
3091                 if (len < sizeof tmpbuf)
3092                     tmpbuf[len] = *s;
3093             }
3094             if (len < sizeof tmpbuf)
3095                 tmpbuf[len] = '\0';
3096 #else  /* ! (atarist || DOSISH) */
3097             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3098                         ':',
3099                         &len);
3100 #endif /* ! (atarist || DOSISH) */
3101 #endif /* MACOS_TRADITIONAL */
3102             if (s < PL_bufend)
3103                 s++;
3104             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3105                 continue;       /* don't search dir with too-long name */
3106 #ifdef MACOS_TRADITIONAL
3107             if (len && tmpbuf[len - 1] != ':')
3108                 tmpbuf[len++] = ':';
3109 #else
3110             if (len
3111 #  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
3112                 && tmpbuf[len - 1] != '/'
3113                 && tmpbuf[len - 1] != '\\'
3114 #  endif
3115                )
3116                 tmpbuf[len++] = '/';
3117             if (len == 2 && tmpbuf[0] == '.')
3118                 seen_dot = 1;
3119 #endif
3120             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3121 #endif  /* !VMS */
3122
3123 #ifdef SEARCH_EXTS
3124             len = strlen(tmpbuf);
3125             if (extidx > 0)     /* reset after previous loop */
3126                 extidx = 0;
3127             do {
3128 #endif
3129                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3130                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3131                 if (S_ISDIR(PL_statbuf.st_mode)) {
3132                     retval = -1;
3133                 }
3134 #ifdef SEARCH_EXTS
3135             } while (  retval < 0               /* not there */
3136                     && extidx>=0 && ext[extidx] /* try an extension? */
3137                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3138                 );
3139 #endif
3140             if (retval < 0)
3141                 continue;
3142             if (S_ISREG(PL_statbuf.st_mode)
3143                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3144 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3145                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3146 #endif
3147                 )
3148             {
3149                 xfound = tmpbuf;                /* bingo! */
3150                 break;
3151             }
3152             if (!xfailed)
3153                 xfailed = savepv(tmpbuf);
3154         }
3155 #ifndef DOSISH
3156         if (!xfound && !seen_dot && !xfailed &&
3157             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3158              || S_ISDIR(PL_statbuf.st_mode)))
3159 #endif
3160             seen_dot = 1;                       /* Disable message. */
3161         if (!xfound) {
3162             if (flags & 1) {                    /* do or die? */
3163                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3164                       (xfailed ? "execute" : "find"),
3165                       (xfailed ? xfailed : scriptname),
3166                       (xfailed ? "" : " on PATH"),
3167                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3168             }
3169             scriptname = NULL;
3170         }
3171         Safefree(xfailed);
3172         scriptname = xfound;
3173     }
3174     return (scriptname ? savepv(scriptname) : NULL);
3175 }
3176
3177 #ifndef PERL_GET_CONTEXT_DEFINED
3178
3179 void *
3180 Perl_get_context(void)
3181 {
3182     dVAR;
3183 #if defined(USE_ITHREADS)
3184 #  ifdef OLD_PTHREADS_API
3185     pthread_addr_t t;
3186     if (pthread_getspecific(PL_thr_key, &t))
3187         Perl_croak_nocontext("panic: pthread_getspecific");
3188     return (void*)t;
3189 #  else
3190 #    ifdef I_MACH_CTHREADS
3191     return (void*)cthread_data(cthread_self());
3192 #    else
3193     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3194 #    endif
3195 #  endif
3196 #else
3197     return (void*)NULL;
3198 #endif
3199 }
3200
3201 void
3202 Perl_set_context(void *t)
3203 {
3204     dVAR;
3205 #if defined(USE_ITHREADS)
3206 #  ifdef I_MACH_CTHREADS
3207     cthread_set_data(cthread_self(), t);
3208 #  else
3209     if (pthread_setspecific(PL_thr_key, t))
3210         Perl_croak_nocontext("panic: pthread_setspecific");
3211 #  endif
3212 #else
3213     PERL_UNUSED_ARG(t);
3214 #endif
3215 }
3216
3217 #endif /* !PERL_GET_CONTEXT_DEFINED */
3218
3219 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3220 struct perl_vars *
3221 Perl_GetVars(pTHX)
3222 {
3223  return &PL_Vars;
3224 }
3225 #endif
3226
3227 char **
3228 Perl_get_op_names(pTHX)
3229 {
3230     PERL_UNUSED_CONTEXT;
3231     return (char **)PL_op_name;
3232 }
3233
3234 char **
3235 Perl_get_op_descs(pTHX)
3236 {
3237     PERL_UNUSED_CONTEXT;
3238     return (char **)PL_op_desc;
3239 }
3240
3241 const char *
3242 Perl_get_no_modify(pTHX)
3243 {
3244     PERL_UNUSED_CONTEXT;
3245     return PL_no_modify;
3246 }
3247
3248 U32 *
3249 Perl_get_opargs(pTHX)
3250 {
3251     PERL_UNUSED_CONTEXT;
3252     return (U32 *)PL_opargs;
3253 }
3254
3255 PPADDR_t*
3256 Perl_get_ppaddr(pTHX)
3257 {
3258     dVAR;
3259     PERL_UNUSED_CONTEXT;
3260     return (PPADDR_t*)PL_ppaddr;
3261 }
3262
3263 #ifndef HAS_GETENV_LEN
3264 char *
3265 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3266 {
3267     char * const env_trans = PerlEnv_getenv(env_elem);
3268     PERL_UNUSED_CONTEXT;
3269     if (env_trans)
3270         *len = strlen(env_trans);
3271     return env_trans;
3272 }
3273 #endif
3274
3275
3276 MGVTBL*
3277 Perl_get_vtbl(pTHX_ int vtbl_id)
3278 {
3279     const MGVTBL* result;
3280     PERL_UNUSED_CONTEXT;
3281
3282     switch(vtbl_id) {
3283     case want_vtbl_sv:
3284         result = &PL_vtbl_sv;
3285         break;
3286     case want_vtbl_env:
3287         result = &PL_vtbl_env;
3288         break;
3289     case want_vtbl_envelem:
3290         result = &PL_vtbl_envelem;
3291         break;
3292     case want_vtbl_sig:
3293         result = &PL_vtbl_sig;
3294         break;
3295     case want_vtbl_sigelem:
3296         result = &PL_vtbl_sigelem;
3297         break;
3298     case want_vtbl_pack:
3299         result = &PL_vtbl_pack;
3300         break;
3301     case want_vtbl_packelem:
3302         result = &PL_vtbl_packelem;
3303         break;
3304     case want_vtbl_dbline:
3305         result = &PL_vtbl_dbline;
3306         break;
3307     case want_vtbl_isa:
3308         result = &PL_vtbl_isa;
3309         break;
3310     case want_vtbl_isaelem:
3311         result = &PL_vtbl_isaelem;
3312         break;
3313     case want_vtbl_arylen:
3314         result = &PL_vtbl_arylen;
3315         break;
3316     case want_vtbl_mglob:
3317         result = &PL_vtbl_mglob;
3318         break;
3319     case want_vtbl_nkeys:
3320         result = &PL_vtbl_nkeys;
3321         break;
3322     case want_vtbl_taint:
3323         result = &PL_vtbl_taint;
3324         break;
3325     case want_vtbl_substr:
3326         result = &PL_vtbl_substr;
3327         break;
3328     case want_vtbl_vec:
3329         result = &PL_vtbl_vec;
3330         break;
3331     case want_vtbl_pos:
3332         result = &PL_vtbl_pos;
3333         break;
3334     case want_vtbl_bm:
3335         result = &PL_vtbl_bm;
3336         break;
3337     case want_vtbl_fm:
3338         result = &PL_vtbl_fm;
3339         break;
3340     case want_vtbl_uvar:
3341         result = &PL_vtbl_uvar;
3342         break;
3343     case want_vtbl_defelem:
3344         result = &PL_vtbl_defelem;
3345         break;
3346     case want_vtbl_regexp:
3347         result = &PL_vtbl_regexp;
3348         break;
3349     case want_vtbl_regdata:
3350         result = &PL_vtbl_regdata;
3351         break;
3352     case want_vtbl_regdatum:
3353         result = &PL_vtbl_regdatum;
3354         break;
3355 #ifdef USE_LOCALE_COLLATE
3356     case want_vtbl_collxfrm:
3357         result = &PL_vtbl_collxfrm;
3358         break;
3359 #endif
3360     case want_vtbl_amagic:
3361         result = &PL_vtbl_amagic;
3362         break;
3363     case want_vtbl_amagicelem:
3364         result = &PL_vtbl_amagicelem;
3365         break;
3366     case want_vtbl_backref:
3367         result = &PL_vtbl_backref;
3368         break;
3369     case want_vtbl_utf8:
3370         result = &PL_vtbl_utf8;
3371         break;
3372     default:
3373         result = NULL;
3374         break;
3375     }
3376     return (MGVTBL*)result;
3377 }
3378
3379 I32
3380 Perl_my_fflush_all(pTHX)
3381 {
3382 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3383     return PerlIO_flush(NULL);
3384 #else
3385 # if defined(HAS__FWALK)
3386     extern int fflush(FILE *);
3387     /* undocumented, unprototyped, but very useful BSDism */
3388     extern void _fwalk(int (*)(FILE *));
3389     _fwalk(&fflush);
3390     return 0;
3391 # else
3392 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3393     long open_max = -1;
3394 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3395     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3396 #   else
3397 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3398     open_max = sysconf(_SC_OPEN_MAX);
3399 #     else
3400 #      ifdef FOPEN_MAX
3401     open_max = FOPEN_MAX;
3402 #      else
3403 #       ifdef OPEN_MAX
3404     open_max = OPEN_MAX;
3405 #       else
3406 #        ifdef _NFILE
3407     open_max = _NFILE;
3408 #        endif
3409 #       endif
3410 #      endif
3411 #     endif
3412 #    endif
3413     if (open_max > 0) {
3414       long i;
3415       for (i = 0; i < open_max; i++)
3416             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3417                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3418                 STDIO_STREAM_ARRAY[i]._flag)
3419                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3420       return 0;
3421     }
3422 #  endif
3423     SETERRNO(EBADF,RMS_IFI);
3424     return EOF;
3425 # endif
3426 #endif
3427 }
3428
3429 void
3430 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
3431 {
3432     const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
3433
3434     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3435         if (ckWARN(WARN_IO)) {
3436             const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3437             if (name && *name)
3438                 Perl_warner(aTHX_ packWARN(WARN_IO),
3439                             "Filehandle %s opened only for %sput",
3440                             name, direction);
3441             else
3442                 Perl_warner(aTHX_ packWARN(WARN_IO),
3443                             "Filehandle opened only for %sput", direction);
3444         }
3445     }
3446     else {
3447         const char *vile;
3448         I32   warn_type;
3449
3450         if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3451             vile = "closed";
3452             warn_type = WARN_CLOSED;
3453         }
3454         else {
3455             vile = "unopened";
3456             warn_type = WARN_UNOPENED;
3457         }
3458
3459         if (ckWARN(warn_type)) {
3460             const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3461             const char * const func =
3462                 op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
3463                 op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
3464                 op < 0              ? "" :              /* handle phoney cases */
3465                 PL_op_desc[op];
3466             const char * const type = OP_IS_SOCKET(op)
3467                     || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3468                         ?  "socket" : "filehandle";
3469             if (name && *name) {
3470                 Perl_warner(aTHX_ packWARN(warn_type),
3471                             "%s%s on %s %s %s", func, pars, vile, type, name);
3472                 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3473                     Perl_warner(
3474                         aTHX_ packWARN(warn_type),
3475                         "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3476                         func, pars, name
3477                     );
3478             }
3479             else {
3480                 Perl_warner(aTHX_ packWARN(warn_type),
3481                             "%s%s on %s %s", func, pars, vile, type);
3482                 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3483                     Perl_warner(
3484                         aTHX_ packWARN(warn_type),
3485                         "\t(Are you trying to call %s%s on dirhandle?)\n",
3486                         func, pars
3487                     );
3488             }
3489         }
3490     }
3491 }
3492
3493 #ifdef EBCDIC
3494 /* in ASCII order, not that it matters */
3495 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3496
3497 int
3498 Perl_ebcdic_control(pTHX_ int ch)
3499 {
3500     if (ch > 'a') {
3501         const char *ctlp;
3502
3503         if (islower(ch))
3504             ch = toupper(ch);
3505
3506         if ((ctlp = strchr(controllablechars, ch)) == 0) {
3507             Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
3508         }
3509
3510         if (ctlp == controllablechars)
3511             return('\177'); /* DEL */
3512         else
3513             return((unsigned char)(ctlp - controllablechars - 1));
3514     } else { /* Want uncontrol */
3515         if (ch == '\177' || ch == -1)
3516             return('?');
3517         else if (ch == '\157')
3518             return('\177');
3519         else if (ch == '\174')
3520             return('\000');
3521         else if (ch == '^')    /* '\137' in 1047, '\260' in 819 */
3522             return('\036');
3523         else if (ch == '\155')
3524             return('\037');
3525         else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3526             return(controllablechars[ch+1]);
3527         else
3528             Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3529     }
3530 }
3531 #endif
3532
3533 /* To workaround core dumps from the uninitialised tm_zone we get the
3534  * system to give us a reasonable struct to copy.  This fix means that
3535  * strftime uses the tm_zone and tm_gmtoff values returned by
3536  * localtime(time()). That should give the desired result most of the
3537  * time. But probably not always!
3538  *
3539  * This does not address tzname aspects of NETaa14816.
3540  *
3541  */
3542
3543 #ifdef HAS_GNULIBC
3544 # ifndef STRUCT_TM_HASZONE
3545 #    define STRUCT_TM_HASZONE
3546 # endif
3547 #endif
3548
3549 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3550 # ifndef HAS_TM_TM_ZONE
3551 #    define HAS_TM_TM_ZONE
3552 # endif
3553 #endif
3554
3555 void
3556 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3557 {
3558 #ifdef HAS_TM_TM_ZONE
3559     Time_t now;
3560     const struct tm* my_tm;
3561     (void)time(&now);
3562     my_tm = localtime(&now);
3563     if (my_tm)
3564         Copy(my_tm, ptm, 1, struct tm);
3565 #else
3566     PERL_UNUSED_ARG(ptm);
3567 #endif
3568 }
3569
3570 /*
3571  * mini_mktime - normalise struct tm values without the localtime()
3572  * semantics (and overhead) of mktime().
3573  */
3574 void
3575 Perl_mini_mktime(pTHX_ struct tm *ptm)
3576 {
3577     int yearday;
3578     int secs;
3579     int month, mday, year, jday;
3580     int odd_cent, odd_year;
3581     PERL_UNUSED_CONTEXT;
3582
3583 #define DAYS_PER_YEAR   365
3584 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3585 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3586 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3587 #define SECS_PER_HOUR   (60*60)
3588 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3589 /* parentheses deliberately absent on these two, otherwise they don't work */
3590 #define MONTH_TO_DAYS   153/5
3591 #define DAYS_TO_MONTH   5/153
3592 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3593 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3594 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3595 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3596
3597 /*
3598  * Year/day algorithm notes:
3599  *
3600  * With a suitable offset for numeric value of the month, one can find
3601  * an offset into the year by considering months to have 30.6 (153/5) days,
3602  * using integer arithmetic (i.e., with truncation).  To avoid too much
3603  * messing about with leap days, we consider January and February to be
3604  * the 13th and 14th month of the previous year.  After that transformation,
3605  * we need the month index we use to be high by 1 from 'normal human' usage,
3606  * so the month index values we use run from 4 through 15.
3607  *
3608  * Given that, and the rules for the Gregorian calendar (leap years are those
3609  * divisible by 4 unless also divisible by 100, when they must be divisible
3610  * by 400 instead), we can simply calculate the number of days since some
3611  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3612  * the days we derive from our month index, and adding in the day of the
3613  * month.  The value used here is not adjusted for the actual origin which
3614  * it normally would use (1 January A.D. 1), since we're not exposing it.
3615  * We're only building the value so we can turn around and get the
3616  * normalised values for the year, month, day-of-month, and day-of-year.
3617  *
3618  * For going backward, we need to bias the value we're using so that we find
3619  * the right year value.  (Basically, we don't want the contribution of
3620  * March 1st to the number to apply while deriving the year).  Having done
3621  * that, we 'count up' the contribution to the year number by accounting for
3622  * full quadracenturies (400-year periods) with their extra leap days, plus
3623  * the contribution from full centuries (to avoid counting in the lost leap
3624  * days), plus the contribution from full quad-years (to count in the normal
3625  * leap days), plus the leftover contribution from any non-leap years.
3626  * At this point, if we were working with an actual leap day, we'll have 0
3627  * days left over.  This is also true for March 1st, however.  So, we have
3628  * to special-case that result, and (earlier) keep track of the 'odd'
3629  * century and year contributions.  If we got 4 extra centuries in a qcent,
3630  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3631  * Otherwise, we add back in the earlier bias we removed (the 123 from
3632  * figuring in March 1st), find the month index (integer division by 30.6),
3633  * and the remainder is the day-of-month.  We then have to convert back to
3634  * 'real' months (including fixing January and February from being 14/15 in
3635  * the previous year to being in the proper year).  After that, to get
3636  * tm_yday, we work with the normalised year and get a new yearday value for
3637  * January 1st, which we subtract from the yearday value we had earlier,
3638  * representing the date we've re-built.  This is done from January 1
3639  * because tm_yday is 0-origin.
3640  *
3641  * Since POSIX time routines are only guaranteed to work for times since the
3642  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3643  * applies Gregorian calendar rules even to dates before the 16th century
3644  * doesn't bother me.  Besides, you'd need cultural context for a given
3645  * date to know whether it was Julian or Gregorian calendar, and that's
3646  * outside the scope for this routine.  Since we convert back based on the
3647  * same rules we used to build the yearday, you'll only get strange results
3648  * for input which needed normalising, or for the 'odd' century years which
3649  * were leap years in the Julian calander but not in the Gregorian one.
3650  * I can live with that.
3651  *
3652  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3653  * that's still outside the scope for POSIX time manipulation, so I don't
3654  * care.
3655  */
3656
3657     year = 1900 + ptm->tm_year;
3658     month = ptm->tm_mon;
3659     mday = ptm->tm_mday;
3660     /* allow given yday with no month & mday to dominate the result */
3661     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3662         month = 0;
3663         mday = 0;
3664         jday = 1 + ptm->tm_yday;
3665     }
3666     else {
3667         jday = 0;
3668     }
3669     if (month >= 2)
3670         month+=2;
3671     else
3672         month+=14, year--;
3673     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3674     yearday += month*MONTH_TO_DAYS + mday + jday;
3675     /*
3676      * Note that we don't know when leap-seconds were or will be,
3677      * so we have to trust the user if we get something which looks
3678      * like a sensible leap-second.  Wild values for seconds will
3679      * be rationalised, however.
3680      */
3681     if ((unsigned) ptm->tm_sec <= 60) {
3682         secs = 0;
3683     }
3684     else {
3685         secs = ptm->tm_sec;
3686         ptm->tm_sec = 0;
3687     }
3688     secs += 60 * ptm->tm_min;
3689     secs += SECS_PER_HOUR * ptm->tm_hour;
3690     if (secs < 0) {
3691         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3692             /* got negative remainder, but need positive time */
3693             /* back off an extra day to compensate */
3694             yearday += (secs/SECS_PER_DAY)-1;
3695             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3696         }
3697         else {
3698             yearday += (secs/SECS_PER_DAY);
3699             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3700         }
3701     }
3702     else if (secs >= SECS_PER_DAY) {
3703         yearday += (secs/SECS_PER_DAY);
3704         secs %= SECS_PER_DAY;
3705     }
3706     ptm->tm_hour = secs/SECS_PER_HOUR;
3707     secs %= SECS_PER_HOUR;
3708     ptm->tm_min = secs/60;
3709     secs %= 60;
3710     ptm->tm_sec += secs;
3711     /* done with time of day effects */
3712     /*
3713      * The algorithm for yearday has (so far) left it high by 428.
3714      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3715      * bias it by 123 while trying to figure out what year it
3716      * really represents.  Even with this tweak, the reverse
3717      * translation fails for years before A.D. 0001.
3718      * It would still fail for Feb 29, but we catch that one below.
3719      */
3720     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3721     yearday -= YEAR_ADJUST;
3722     year = (yearday / DAYS_PER_QCENT) * 400;
3723     yearday %= DAYS_PER_QCENT;
3724     odd_cent = yearday / DAYS_PER_CENT;
3725     year += odd_cent * 100;
3726     yearday %= DAYS_PER_CENT;
3727     year += (yearday / DAYS_PER_QYEAR) * 4;
3728     yearday %= DAYS_PER_QYEAR;
3729     odd_year = yearday / DAYS_PER_YEAR;
3730     year += odd_year;
3731     yearday %= DAYS_PER_YEAR;
3732     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3733         month = 1;
3734         yearday = 29;
3735     }
3736     else {
3737         yearday += YEAR_ADJUST; /* recover March 1st crock */
3738         month = yearday*DAYS_TO_MONTH;
3739         yearday -= month*MONTH_TO_DAYS;
3740         /* recover other leap-year adjustment */
3741         if (month > 13) {
3742             month-=14;
3743             year++;
3744         }
3745         else {
3746             month-=2;
3747         }
3748     }
3749     ptm->tm_year = year - 1900;
3750     if (yearday) {
3751       ptm->tm_mday = yearday;
3752       ptm->tm_mon = month;
3753     }
3754     else {
3755       ptm->tm_mday = 31;
3756       ptm->tm_mon = month - 1;
3757     }
3758     /* re-build yearday based on Jan 1 to get tm_yday */
3759     year--;
3760     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3761     yearday += 14*MONTH_TO_DAYS + 1;
3762     ptm->tm_yday = jday - yearday;
3763     /* fix tm_wday if not overridden by caller */
3764     if ((unsigned)ptm->tm_wday > 6)
3765         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3766 }
3767
3768 char *
3769 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)
3770 {
3771 #ifdef HAS_STRFTIME
3772   char *buf;
3773   int buflen;
3774   struct tm mytm;
3775   int len;
3776
3777   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
3778   mytm.tm_sec = sec;
3779   mytm.tm_min = min;
3780   mytm.tm_hour = hour;
3781   mytm.tm_mday = mday;
3782   mytm.tm_mon = mon;
3783   mytm.tm_year = year;
3784   mytm.tm_wday = wday;
3785   mytm.tm_yday = yday;
3786   mytm.tm_isdst = isdst;
3787   mini_mktime(&mytm);
3788   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3789 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3790   STMT_START {
3791     struct tm mytm2;
3792     mytm2 = mytm;
3793     mktime(&mytm2);
3794 #ifdef HAS_TM_TM_GMTOFF
3795     mytm.tm_gmtoff = mytm2.tm_gmtoff;
3796 #endif
3797 #ifdef HAS_TM_TM_ZONE
3798     mytm.tm_zone = mytm2.tm_zone;
3799 #endif
3800   } STMT_END;
3801 #endif
3802   buflen = 64;
3803   Newx(buf, buflen, char);
3804   len = strftime(buf, buflen, fmt, &mytm);
3805   /*
3806   ** The following is needed to handle to the situation where
3807   ** tmpbuf overflows.  Basically we want to allocate a buffer
3808   ** and try repeatedly.  The reason why it is so complicated
3809   ** is that getting a return value of 0 from strftime can indicate
3810   ** one of the following:
3811   ** 1. buffer overflowed,
3812   ** 2. illegal conversion specifier, or
3813   ** 3. the format string specifies nothing to be returned(not
3814   **      an error).  This could be because format is an empty string
3815   **    or it specifies %p that yields an empty string in some locale.
3816   ** If there is a better way to make it portable, go ahead by
3817   ** all means.
3818   */
3819   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3820     return buf;
3821   else {
3822     /* Possibly buf overflowed - try again with a bigger buf */
3823     const int fmtlen = strlen(fmt);
3824     const int bufsize = fmtlen + buflen;
3825
3826     Newx(buf, bufsize, char);
3827     while (buf) {
3828       buflen = strftime(buf, bufsize, fmt, &mytm);
3829       if (buflen > 0 && buflen < bufsize)
3830         break;
3831       /* heuristic to prevent out-of-memory errors */
3832       if (bufsize > 100*fmtlen) {
3833         Safefree(buf);
3834         buf = NULL;
3835         break;
3836       }
3837       Renew(buf, bufsize*2, char);
3838     }
3839     return buf;
3840   }
3841 #else
3842   Perl_croak(aTHX_ "panic: no strftime");
3843   return NULL;
3844 #endif
3845 }
3846
3847
3848 #define SV_CWD_RETURN_UNDEF \
3849 sv_setsv(sv, &PL_sv_undef); \
3850 return FALSE
3851
3852 #define SV_CWD_ISDOT(dp) \
3853     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3854         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
3855
3856 /*
3857 =head1 Miscellaneous Functions
3858
3859 =for apidoc getcwd_sv
3860
3861 Fill the sv with current working directory
3862
3863 =cut
3864 */
3865
3866 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3867  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3868  * getcwd(3) if available
3869  * Comments from the orignal:
3870  *     This is a faster version of getcwd.  It's also more dangerous
3871  *     because you might chdir out of a directory that you can't chdir
3872  *     back into. */
3873
3874 int
3875 Perl_getcwd_sv(pTHX_ register SV *sv)
3876 {
3877 #ifndef PERL_MICRO
3878     dVAR;
3879 #ifndef INCOMPLETE_TAINTS
3880     SvTAINTED_on(sv);
3881 #endif
3882
3883 #ifdef HAS_GETCWD
3884     {
3885         char buf[MAXPATHLEN];
3886
3887         /* Some getcwd()s automatically allocate a buffer of the given
3888          * size from the heap if they are given a NULL buffer pointer.
3889          * The problem is that this behaviour is not portable. */
3890         if (getcwd(buf, sizeof(buf) - 1)) {
3891             sv_setpv(sv, buf);
3892             return TRUE;
3893         }
3894         else {
3895             sv_setsv(sv, &PL_sv_undef);
3896             return FALSE;
3897         }
3898     }
3899
3900 #else
3901
3902     Stat_t statbuf;
3903     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3904     int pathlen=0;
3905     Direntry_t *dp;
3906
3907     SvUPGRADE(sv, SVt_PV);
3908
3909     if (PerlLIO_lstat(".", &statbuf) < 0) {
3910         SV_CWD_RETURN_UNDEF;
3911     }
3912
3913     orig_cdev = statbuf.st_dev;
3914     orig_cino = statbuf.st_ino;
3915     cdev = orig_cdev;
3916     cino = orig_cino;
3917
3918     for (;;) {
3919         DIR *dir;
3920         odev = cdev;
3921         oino = cino;
3922
3923         if (PerlDir_chdir("..") < 0) {
3924             SV_CWD_RETURN_UNDEF;
3925         }
3926         if (PerlLIO_stat(".", &statbuf) < 0) {
3927             SV_CWD_RETURN_UNDEF;
3928         }
3929
3930         cdev = statbuf.st_dev;
3931         cino = statbuf.st_ino;
3932
3933         if (odev == cdev && oino == cino) {
3934             break;
3935         }
3936         if (!(dir = PerlDir_open("."))) {
3937             SV_CWD_RETURN_UNDEF;
3938         }
3939
3940         while ((dp = PerlDir_read(dir)) != NULL) {
3941 #ifdef DIRNAMLEN
3942             const int namelen = dp->d_namlen;
3943 #else
3944             const int namelen = strlen(dp->d_name);
3945 #endif
3946             /* skip . and .. */
3947             if (SV_CWD_ISDOT(dp)) {
3948                 continue;
3949             }
3950
3951             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3952                 SV_CWD_RETURN_UNDEF;
3953             }
3954
3955             tdev = statbuf.st_dev;
3956             tino = statbuf.st_ino;
3957             if (tino == oino && tdev == odev) {
3958                 break;
3959             }
3960         }
3961
3962         if (!dp) {
3963             SV_CWD_RETURN_UNDEF;
3964         }
3965
3966         if (pathlen + namelen + 1 >= MAXPATHLEN) {
3967             SV_CWD_RETURN_UNDEF;
3968         }
3969
3970         SvGROW(sv, pathlen + namelen + 1);
3971
3972         if (pathlen) {
3973             /* shift down */
3974             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3975         }
3976
3977         /* prepend current directory to the front */
3978         *SvPVX(sv) = '/';
3979         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3980         pathlen += (namelen + 1);
3981
3982 #ifdef VOID_CLOSEDIR
3983         PerlDir_close(dir);
3984 #else
3985         if (PerlDir_close(dir) < 0) {
3986             SV_CWD_RETURN_UNDEF;
3987         }
3988 #endif
3989     }
3990
3991     if (pathlen) {
3992         SvCUR_set(sv, pathlen);
3993         *SvEND(sv) = '\0';
3994         SvPOK_only(sv);
3995
3996         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3997             SV_CWD_RETURN_UNDEF;
3998         }
3999     }
4000     if (PerlLIO_stat(".", &statbuf) < 0) {
4001         SV_CWD_RETURN_UNDEF;
4002     }
4003
4004     cdev = statbuf.st_dev;
4005     cino = statbuf.st_ino;
4006
4007     if (cdev != orig_cdev || cino != orig_cino) {
4008         Perl_croak(aTHX_ "Unstable directory path, "
4009                    "current directory changed unexpectedly");
4010     }
4011
4012     return TRUE;
4013 #endif
4014
4015 #else
4016     return FALSE;
4017 #endif
4018 }
4019
4020 /*
4021 =for apidoc scan_version
4022
4023 Returns a pointer to the next character after the parsed
4024 version string, as well as upgrading the passed in SV to
4025 an RV.
4026
4027 Function must be called with an already existing SV like
4028
4029     sv = newSV(0);
4030     s = scan_version(s,SV *sv, bool qv);
4031
4032 Performs some preprocessing to the string to ensure that
4033 it has the correct characteristics of a version.  Flags the
4034 object if it contains an underscore (which denotes this
4035 is a alpha version).  The boolean qv denotes that the version
4036 should be interpreted as if it had multiple decimals, even if
4037 it doesn't.
4038
4039 =cut
4040 */
4041
4042 const char *
4043 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4044 {
4045     const char *start;
4046     const char *pos;
4047     const char *last;
4048     int saw_period = 0;
4049     int alpha = 0;
4050     int width = 3;
4051     AV * const av = newAV();
4052     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4053     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4054
4055 #ifndef NODEFAULT_SHAREKEYS
4056     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4057 #endif
4058
4059     while (isSPACE(*s)) /* leading whitespace is OK */
4060         s++;
4061
4062     if (*s == 'v') {
4063         s++;  /* get past 'v' */
4064         qv = 1; /* force quoted version processing */
4065     }
4066
4067     start = last = pos = s;
4068
4069     /* pre-scan the input string to check for decimals/underbars */
4070     while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4071     {
4072         if ( *pos == '.' )
4073         {
4074             if ( alpha )
4075                 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
4076             saw_period++ ;
4077             last = pos;
4078         }
4079         else if ( *pos == '_' )
4080         {
4081             if ( alpha )
4082                 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
4083             alpha = 1;
4084             width = pos - last - 1; /* natural width of sub-version */
4085         }
4086         pos++;
4087     }
4088
4089     if ( alpha && !saw_period )
4090         Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4091
4092     if ( saw_period > 1 )
4093         qv = 1; /* force quoted version processing */
4094
4095     pos = s;
4096
4097     if ( qv )
4098         hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4099     if ( alpha )
4100         hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
4101     if ( !qv && width < 3 )
4102         hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4103
4104     while (isDIGIT(*pos))
4105         pos++;
4106     if (!isALPHA(*pos)) {
4107         I32 rev;
4108
4109         for (;;) {
4110             rev = 0;
4111             {
4112                 /* this is atoi() that delimits on underscores */
4113                 const char *end = pos;
4114                 I32 mult = 1;
4115                 I32 orev;
4116
4117                 /* the following if() will only be true after the decimal
4118                  * point of a version originally created with a bare
4119                  * floating point number, i.e. not quoted in any way
4120                  */
4121                 if ( !qv && s > start && saw_period == 1 ) {
4122                     mult *= 100;
4123                     while ( s < end ) {
4124                         orev = rev;
4125                         rev += (*s - '0') * mult;
4126                         mult /= 10;
4127                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
4128                             Perl_croak(aTHX_ "Integer overflow in version");
4129                         s++;
4130                         if ( *s == '_' )
4131                             s++;
4132                     }
4133                 }
4134                 else {
4135                     while (--end >= s) {
4136                         orev = rev;
4137                         rev += (*end - '0') * mult;
4138                         mult *= 10;
4139                         if ( PERL_ABS(orev) > PERL_ABS(rev) )
4140                             Perl_croak(aTHX_ "Integer overflow in version");
4141                     }
4142                 }
4143             }
4144
4145             /* Append revision */
4146             av_push(av, newSViv(rev));
4147             if ( *pos == '.' )
4148                 s = ++pos;
4149             else if ( *pos == '_' && isDIGIT(pos[1]) )
4150                 s = ++pos;
4151             else if ( isDIGIT(*pos) )
4152                 s = pos;
4153             else {
4154                 s = pos;
4155                 break;
4156             }
4157             if ( qv ) {
4158                 while ( isDIGIT(*pos) )
4159                     pos++;
4160             }
4161             else {
4162                 int digits = 0;
4163                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4164                     if ( *pos != '_' )
4165                         digits++;
4166                     pos++;
4167                 }
4168             }
4169         }
4170     }
4171     if ( qv ) { /* quoted versions always get at least three terms*/
4172         I32 len = av_len(av);
4173         /* This for loop appears to trigger a compiler bug on OS X, as it
4174            loops infinitely. Yes, len is negative. No, it makes no sense.
4175            Compiler in question is:
4176            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4177            for ( len = 2 - len; len > 0; len-- )
4178            av_push((AV *)sv, newSViv(0));
4179         */
4180         len = 2 - len;
4181         while (len-- > 0)
4182             av_push(av, newSViv(0));
4183     }
4184
4185     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4186         av_push(av, newSViv(0));
4187
4188     /* fix RT#19517 - special case 'undef' as string */
4189     if ( *s == 'u' && strEQ(s,"undef") ) {
4190         s += 5;
4191     }
4192
4193     /* And finally, store the AV in the hash */
4194     hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4195     return s;
4196 }
4197
4198 /*
4199 =for apidoc new_version
4200
4201 Returns a new version object based on the passed in SV:
4202
4203     SV *sv = new_version(SV *ver);
4204
4205 Does not alter the passed in ver SV.  See "upg_version" if you
4206 want to upgrade the SV.
4207
4208 =cut
4209 */
4210
4211 SV *
4212 Perl_new_version(pTHX_ SV *ver)
4213 {
4214     dVAR;
4215     SV * const rv = newSV(0);
4216     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4217     {
4218         I32 key;
4219         AV * const av = newAV();
4220         AV *sav;
4221         /* This will get reblessed later if a derived class*/
4222         SV * const hv = newSVrv(rv, "version");
4223         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4224 #ifndef NODEFAULT_SHAREKEYS
4225         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4226 #endif
4227
4228         if ( SvROK(ver) )
4229             ver = SvRV(ver);
4230
4231         /* Begin copying all of the elements */
4232         if ( hv_exists((HV *)ver, "qv", 2) )
4233             hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4234
4235         if ( hv_exists((HV *)ver, "alpha", 5) )
4236             hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4237
4238         if ( hv_exists((HV*)ver, "width", 5 ) )
4239         {
4240             const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
4241             hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4242         }
4243
4244         sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
4245         /* This will get reblessed later if a derived class*/
4246         for ( key = 0; key <= av_len(sav); key++ )
4247         {
4248             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4249             av_push(av, newSViv(rev));
4250         }
4251
4252         hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
4253         return rv;
4254     }
4255 #ifdef SvVOK
4256     {
4257         const MAGIC* const mg = SvVSTRING_mg(ver);
4258         if ( mg ) { /* already a v-string */
4259             const STRLEN len = mg->mg_len;
4260             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4261             sv_setpvn(rv,version,len);
4262             Safefree(version);
4263         }
4264         else {
4265 #endif
4266         sv_setsv(rv,ver); /* make a duplicate */
4267 #ifdef SvVOK
4268         }
4269     }
4270 #endif
4271     return upg_version(rv);
4272 }
4273
4274 /*
4275 =for apidoc upg_version
4276
4277 In-place upgrade of the supplied SV to a version object.
4278
4279     SV *sv = upg_version(SV *sv);
4280
4281 Returns a pointer to the upgraded SV.
4282
4283 =cut
4284 */
4285
4286 SV *
4287 Perl_upg_version(pTHX_ SV *ver)
4288 {
4289     const char *version, *s;
4290     bool qv = 0;
4291 #ifdef SvVOK
4292     const MAGIC *mg;
4293 #endif
4294
4295     if ( SvNOK(ver) ) /* may get too much accuracy */
4296     {
4297         char tbuf[64];
4298         STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4299         while (tbuf[len-1] == '0' && len > 0) len--;
4300         version = savepvn(tbuf, len);
4301     }
4302 #ifdef SvVOK
4303     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4304         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4305         qv = 1;
4306     }
4307 #endif
4308     else /* must be a string or something like a string */
4309     {
4310         version = savepv(SvPV_nolen(ver));
4311     }
4312
4313     s = scan_version(version, ver, qv);
4314     if ( *s != '\0' )
4315         if(ckWARN(WARN_MISC))
4316             Perl_warner(aTHX_ packWARN(WARN_MISC),
4317                 "Version string '%s' contains invalid data; "
4318                 "ignoring: '%s'", version, s);
4319     Safefree(version);
4320     return ver;
4321 }
4322
4323 /*
4324 =for apidoc vverify
4325
4326 Validates that the SV contains a valid version object.
4327
4328     bool vverify(SV *vobj);
4329
4330 Note that it only confirms the bare minimum structure (so as not to get
4331 confused by derived classes which may contain additional hash entries):
4332
4333 =over 4
4334
4335 =item * The SV contains a [reference to a] hash
4336
4337 =item * The hash contains a "version" key
4338
4339 =item * The "version" key has [a reference to] an AV as its value
4340
4341 =back
4342
4343 =cut
4344 */
4345
4346 bool
4347 Perl_vverify(pTHX_ SV *vs)
4348 {
4349     SV *sv;
4350     if ( SvROK(vs) )
4351         vs = SvRV(vs);
4352
4353     /* see if the appropriate elements exist */
4354     if ( SvTYPE(vs) == SVt_PVHV
4355          && hv_exists((HV*)vs, "version", 7)
4356          && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
4357          && SvTYPE(sv) == SVt_PVAV )
4358         return TRUE;
4359     else
4360         return FALSE;
4361 }
4362
4363 /*
4364 =for apidoc vnumify
4365
4366 Accepts a version object and returns the normalized floating
4367 point representation.  Call like:
4368
4369     sv = vnumify(rv);
4370
4371 NOTE: you can pass either the object directly or the SV
4372 contained within the RV.
4373
4374 =cut
4375 */
4376
4377 SV *
4378 Perl_vnumify(pTHX_ SV *vs)
4379 {
4380     I32 i, len, digit;
4381     int width;
4382     bool alpha = FALSE;
4383     SV * const sv = newSV(0);
4384     AV *av;
4385     if ( SvROK(vs) )
4386         vs = SvRV(vs);
4387
4388     if ( !vverify(vs) )
4389         Perl_croak(aTHX_ "Invalid version object");
4390
4391     /* see if various flags exist */
4392     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4393         alpha = TRUE;
4394     if ( hv_exists((HV*)vs, "width", 5 ) )
4395         width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
4396     else
4397         width = 3;
4398
4399
4400     /* attempt to retrieve the version array */
4401     if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
4402         sv_catpvs(sv,"0");
4403         return sv;
4404     }
4405
4406     len = av_len(av);
4407     if ( len == -1 )
4408     {
4409         sv_catpvs(sv,"0");
4410         return sv;
4411     }
4412
4413     digit = SvIV(*av_fetch(av, 0, 0));
4414     Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
4415     for ( i = 1 ; i < len ; i++ )
4416     {
4417         digit = SvIV(*av_fetch(av, i, 0));
4418         if ( width < 3 ) {
4419             const int denom = (width == 2 ? 10 : 100);
4420             const div_t term = div((int)PERL_ABS(digit),denom);
4421             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4422         }
4423         else {
4424             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4425         }
4426     }
4427
4428     if ( len > 0 )
4429     {
4430         digit = SvIV(*av_fetch(av, len, 0));
4431         if ( alpha && width == 3 ) /* alpha version */
4432             sv_catpvs(sv,"_");
4433         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4434     }
4435     else /* len == 0 */
4436     {
4437         sv_catpvs(sv, "000");
4438     }
4439     return sv;
4440 }
4441
4442 /*
4443 =for apidoc vnormal
4444
4445 Accepts a version object and returns the normalized string
4446 representation.  Call like:
4447
4448     sv = vnormal(rv);
4449
4450 NOTE: you can pass either the object directly or the SV
4451 contained within the RV.
4452
4453 =cut
4454 */
4455
4456 SV *
4457 Perl_vnormal(pTHX_ SV *vs)
4458 {
4459     I32 i, len, digit;
4460     bool alpha = FALSE;
4461     SV * const sv = newSV(0);
4462     AV *av;
4463     if ( SvROK(vs) )
4464         vs = SvRV(vs);
4465
4466     if ( !vverify(vs) )
4467         Perl_croak(aTHX_ "Invalid version object");
4468
4469     if ( hv_exists((HV*)vs, "alpha", 5 ) )
4470         alpha = TRUE;
4471     av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
4472
4473     len = av_len(av);
4474     if ( len == -1 )
4475     {
4476         sv_catpvs(sv,"");
4477         return sv;
4478     }
4479     digit = SvIV(*av_fetch(av, 0, 0));
4480     Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
4481     for ( i = 1 ; i < len ; i++ ) {
4482         digit = SvIV(*av_fetch(av, i, 0));
4483         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4484     }
4485
4486     if ( len > 0 )
4487     {
4488         /* handle last digit specially */
4489         digit = SvIV(*av_fetch(av, len, 0));
4490         if ( alpha )
4491             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
4492         else
4493             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
4494     }
4495
4496     if ( len <= 2 ) { /* short version, must be at least three */
4497         for ( len = 2 - len; len != 0; len-- )
4498             sv_catpvs(sv,".0");
4499     }
4500     return sv;
4501 }
4502
4503 /*
4504 =for apidoc vstringify
4505
4506 In order to maintain maximum compatibility with earlier versions
4507 of Perl, this function will return either the floating point
4508 notation or the multiple dotted notation, depending on whether
4509 the original version contained 1 or more dots, respectively
4510
4511 =cut
4512 */
4513
4514 SV *
4515 Perl_vstringify(pTHX_ SV *vs)
4516 {
4517     if ( SvROK(vs) )
4518         vs = SvRV(vs);
4519
4520     if ( !vverify(vs) )
4521         Perl_croak(aTHX_ "Invalid version object");
4522
4523     if ( hv_exists((HV *)vs, "qv", 2) )
4524         return vnormal(vs);
4525     else
4526         return vnumify(vs);
4527 }
4528
4529 /*
4530 =for apidoc vcmp
4531
4532 Version object aware cmp.  Both operands must already have been
4533 converted into version objects.
4534
4535 =cut
4536 */
4537
4538 int
4539 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
4540 {
4541     I32 i,l,m,r,retval;
4542     bool lalpha = FALSE;
4543     bool ralpha = FALSE;
4544     I32 left = 0;
4545     I32 right = 0;
4546     AV *lav, *rav;
4547     if ( SvROK(lhv) )
4548         lhv = SvRV(lhv);
4549     if ( SvROK(rhv) )
4550         rhv = SvRV(rhv);
4551
4552     if ( !vverify(lhv) )
4553         Perl_croak(aTHX_ "Invalid version object");
4554
4555     if ( !vverify(rhv) )
4556         Perl_croak(aTHX_ "Invalid version object");
4557
4558     /* get the left hand term */
4559     lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
4560     if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4561         lalpha = TRUE;
4562
4563     /* and the right hand term */
4564     rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
4565     if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4566         ralpha = TRUE;
4567
4568     l = av_len(lav);
4569     r = av_len(rav);
4570     m = l < r ? l : r;
4571     retval = 0;
4572     i = 0;
4573     while ( i <= m && retval == 0 )
4574     {
4575         left  = SvIV(*av_fetch(lav,i,0));
4576         right = SvIV(*av_fetch(rav,i,0));
4577         if ( left < right  )
4578             retval = -1;
4579         if ( left > right )
4580             retval = +1;
4581         i++;
4582     }
4583
4584     /* tiebreaker for alpha with identical terms */
4585     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4586     {
4587         if ( lalpha && !ralpha )
4588         {
4589             retval = -1;
4590         }
4591         else if ( ralpha && !lalpha)
4592         {
4593             retval = +1;
4594         }
4595     }
4596
4597     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
4598     {
4599         if ( l < r )
4600         {
4601             while ( i <= r && retval == 0 )
4602             {
4603                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
4604                     retval = -1; /* not a match after all */
4605                 i++;
4606             }
4607         }
4608         else
4609         {
4610             while ( i <= l && retval == 0 )
4611             {
4612                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
4613                     retval = +1; /* not a match after all */
4614                 i++;
4615             }
4616         }
4617     }
4618     return retval;
4619 }
4620
4621 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
4622 #   define EMULATE_SOCKETPAIR_UDP
4623 #endif
4624
4625 #ifdef EMULATE_SOCKETPAIR_UDP
4626 static int
4627 S_socketpair_udp (int fd[2]) {
4628     dTHX;
4629     /* Fake a datagram socketpair using UDP to localhost.  */
4630     int sockets[2] = {-1, -1};
4631     struct sockaddr_in addresses[2];
4632     int i;
4633     Sock_size_t size = sizeof(struct sockaddr_in);
4634     unsigned short port;
4635     int got;
4636
4637     memset(&addresses, 0, sizeof(addresses));
4638     i = 1;
4639     do {
4640         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4641         if (sockets[i] == -1)
4642             goto tidy_up_and_fail;
4643
4644         addresses[i].sin_family = AF_INET;
4645         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4646         addresses[i].sin_port = 0;      /* kernel choses port.  */
4647         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4648                 sizeof(struct sockaddr_in)) == -1)
4649             goto tidy_up_and_fail;
4650     } while (i--);
4651
4652     /* Now have 2 UDP sockets. Find out which port each is connected to, and
4653        for each connect the other socket to it.  */
4654     i = 1;
4655     do {
4656         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4657                 &size) == -1)
4658             goto tidy_up_and_fail;
4659         if (size != sizeof(struct sockaddr_in))
4660             goto abort_tidy_up_and_fail;
4661         /* !1 is 0, !0 is 1 */
4662         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4663                 sizeof(struct sockaddr_in)) == -1)
4664             goto tidy_up_and_fail;
4665     } while (i--);
4666
4667     /* Now we have 2 sockets connected to each other. I don't trust some other
4668        process not to have already sent a packet to us (by random) so send
4669        a packet from each to the other.  */
4670     i = 1;
4671     do {
4672         /* I'm going to send my own port number.  As a short.
4673            (Who knows if someone somewhere has sin_port as a bitfield and needs
4674            this routine. (I'm assuming crays have socketpair)) */
4675         port = addresses[i].sin_port;
4676         got = PerlLIO_write(sockets[i], &port, sizeof(port));
4677         if (got != sizeof(port)) {
4678             if (got == -1)
4679                 goto tidy_up_and_fail;
4680             goto abort_tidy_up_and_fail;
4681         }
4682     } while (i--);
4683
4684     /* Packets sent. I don't trust them to have arrived though.
4685        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4686        connect to localhost will use a second kernel thread. In 2.6 the
4687        first thread running the connect() returns before the second completes,
4688        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4689        returns 0. Poor programs have tripped up. One poor program's authors'
4690        had a 50-1 reverse stock split. Not sure how connected these were.)
4691        So I don't trust someone not to have an unpredictable UDP stack.
4692     */
4693
4694     {
4695         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4696         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4697         fd_set rset;
4698
4699         FD_ZERO(&rset);
4700         FD_SET((unsigned int)sockets[0], &rset);
4701         FD_SET((unsigned int)sockets[1], &rset);
4702
4703         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4704         if (got != 2 || !FD_ISSET(sockets[0], &rset)
4705                 || !FD_ISSET(sockets[1], &rset)) {
4706             /* I hope this is portable and appropriate.  */
4707             if (got == -1)
4708                 goto tidy_up_and_fail;
4709             goto abort_tidy_up_and_fail;
4710         }
4711     }
4712
4713     /* And the paranoia department even now doesn't trust it to have arrive
4714        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
4715     {
4716         struct sockaddr_in readfrom;
4717         unsigned short buffer[2];
4718
4719         i = 1;
4720         do {
4721 #ifdef MSG_DONTWAIT
4722             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4723                     sizeof(buffer), MSG_DONTWAIT,
4724                     (struct sockaddr *) &readfrom, &size);
4725 #else
4726             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4727                     sizeof(buffer), 0,
4728                     (struct sockaddr *) &readfrom, &size);
4729 #endif
4730
4731             if (got == -1)
4732                 goto tidy_up_and_fail;
4733             if (got != sizeof(port)
4734                     || size != sizeof(struct sockaddr_in)
4735                     /* Check other socket sent us its port.  */
4736                     || buffer[0] != (unsigned short) addresses[!i].sin_port
4737                     /* Check kernel says we got the datagram from that socket */
4738                     || readfrom.sin_family != addresses[!i].sin_family
4739                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4740                     || readfrom.sin_port != addresses[!i].sin_port)
4741                 goto abort_tidy_up_and_fail;
4742         } while (i--);
4743     }
4744     /* My caller (my_socketpair) has validated that this is non-NULL  */
4745     fd[0] = sockets[0];
4746     fd[1] = sockets[1];
4747     /* I hereby declare this connection open.  May God bless all who cross
4748        her.  */
4749     return 0;
4750
4751   abort_tidy_up_and_fail:
4752     errno = ECONNABORTED;
4753   tidy_up_and_fail:
4754     {
4755         const int save_errno = errno;
4756         if (sockets[0] != -1)
4757             PerlLIO_close(sockets[0]);
4758         if (sockets[1] != -1)
4759             PerlLIO_close(sockets[1]);
4760         errno = save_errno;
4761         return -1;
4762     }
4763 }
4764 #endif /*  EMULATE_SOCKETPAIR_UDP */
4765
4766 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
4767 int
4768 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4769     /* Stevens says that family must be AF_LOCAL, protocol 0.
4770        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
4771     dTHX;
4772     int listener = -1;
4773     int connector = -1;
4774     int acceptor = -1;
4775     struct sockaddr_in listen_addr;
4776     struct sockaddr_in connect_addr;
4777     Sock_size_t size;
4778
4779     if (protocol
4780 #ifdef AF_UNIX
4781         || family != AF_UNIX
4782 #endif
4783     ) {
4784         errno = EAFNOSUPPORT;
4785         return -1;
4786     }
4787     if (!fd) {
4788         errno = EINVAL;
4789         return -1;
4790     }
4791
4792 #ifdef EMULATE_SOCKETPAIR_UDP
4793     if (type == SOCK_DGRAM)
4794         return S_socketpair_udp(fd);
4795 #endif
4796
4797     listener = PerlSock_socket(AF_INET, type, 0);
4798     if (listener == -1)
4799         return -1;
4800     memset(&listen_addr, 0, sizeof(listen_addr));
4801     listen_addr.sin_family = AF_INET;
4802     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4803     listen_addr.sin_port = 0;   /* kernel choses port.  */
4804     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4805             sizeof(listen_addr)) == -1)
4806         goto tidy_up_and_fail;
4807     if (PerlSock_listen(listener, 1) == -1)
4808         goto tidy_up_and_fail;
4809
4810     connector = PerlSock_socket(AF_INET, type, 0);
4811     if (connector == -1)
4812         goto tidy_up_and_fail;
4813     /* We want to find out the port number to connect to.  */
4814     size = sizeof(connect_addr);
4815     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4816             &size) == -1)
4817         goto tidy_up_and_fail;
4818     if (size != sizeof(connect_addr))
4819         goto abort_tidy_up_and_fail;
4820     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
4821             sizeof(connect_addr)) == -1)
4822         goto tidy_up_and_fail;
4823
4824     size = sizeof(listen_addr);
4825     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4826             &size);
4827     if (acceptor == -1)
4828         goto tidy_up_and_fail;
4829     if (size != sizeof(listen_addr))
4830         goto abort_tidy_up_and_fail;
4831     PerlLIO_close(listener);
4832     /* Now check we are talking to ourself by matching port and host on the
4833        two sockets.  */
4834     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4835             &size) == -1)
4836         goto tidy_up_and_fail;
4837     if (size != sizeof(connect_addr)
4838             || listen_addr.sin_family != connect_addr.sin_family
4839             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4840             || listen_addr.sin_port != connect_addr.sin_port) {
4841         goto abort_tidy_up_and_fail;
4842     }
4843     fd[0] = connector;
4844     fd[1] = acceptor;
4845     return 0;
4846
4847   abort_tidy_up_and_fail:
4848 #ifdef ECONNABORTED
4849   errno = ECONNABORTED; /* This would be the standard thing to do. */
4850 #else
4851 #  ifdef ECONNREFUSED
4852   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4853 #  else
4854   errno = ETIMEDOUT;    /* Desperation time. */
4855 #  endif
4856 #endif
4857   tidy_up_and_fail:
4858     {
4859         const int save_errno = errno;
4860         if (listener != -1)
4861             PerlLIO_close(listener);
4862         if (connector != -1)
4863             PerlLIO_close(connector);
4864         if (acceptor != -1)
4865             PerlLIO_close(acceptor);
4866         errno = save_errno;
4867         return -1;
4868     }
4869 }
4870 #else
4871 /* In any case have a stub so that there's code corresponding
4872  * to the my_socketpair in global.sym. */
4873 int
4874 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4875 #ifdef HAS_SOCKETPAIR
4876     return socketpair(family, type, protocol, fd);
4877 #else
4878     return -1;
4879 #endif
4880 }
4881 #endif
4882
4883 /*
4884
4885 =for apidoc sv_nosharing
4886
4887 Dummy routine which "shares" an SV when there is no sharing module present.
4888 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4889 Exists to avoid test for a NULL function pointer and because it could
4890 potentially warn under some level of strict-ness.
4891
4892 =cut
4893 */
4894
4895 void
4896 Perl_sv_nosharing(pTHX_ SV *sv)
4897 {
4898     PERL_UNUSED_CONTEXT;
4899     PERL_UNUSED_ARG(sv);
4900 }
4901
4902 U32
4903 Perl_parse_unicode_opts(pTHX_ const char **popt)
4904 {
4905   const char *p = *popt;
4906   U32 opt = 0;
4907
4908   if (*p) {
4909        if (isDIGIT(*p)) {
4910             opt = (U32) atoi(p);
4911             while (isDIGIT(*p))
4912                 p++;
4913             if (*p && *p != '\n' && *p != '\r')
4914                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4915        }
4916        else {
4917             for (; *p; p++) {
4918                  switch (*p) {
4919                  case PERL_UNICODE_STDIN:
4920                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
4921                  case PERL_UNICODE_STDOUT:
4922                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
4923                  case PERL_UNICODE_STDERR:
4924                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
4925                  case PERL_UNICODE_STD:
4926                       opt |= PERL_UNICODE_STD_FLAG;     break;
4927                  case PERL_UNICODE_IN:
4928                       opt |= PERL_UNICODE_IN_FLAG;      break;
4929                  case PERL_UNICODE_OUT:
4930                       opt |= PERL_UNICODE_OUT_FLAG;     break;
4931                  case PERL_UNICODE_INOUT:
4932                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
4933                  case PERL_UNICODE_LOCALE:
4934                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
4935                  case PERL_UNICODE_ARGV:
4936                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
4937                  case PERL_UNICODE_UTF8CACHEASSERT:
4938                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
4939                  default:
4940                       if (*p != '\n' && *p != '\r')
4941                           Perl_croak(aTHX_
4942                                      "Unknown Unicode option letter '%c'", *p);
4943                  }
4944             }
4945        }
4946   }
4947   else
4948        opt = PERL_UNICODE_DEFAULT_FLAGS;
4949
4950   if (opt & ~PERL_UNICODE_ALL_FLAGS)
4951        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
4952                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4953
4954   *popt = p;
4955
4956   return opt;
4957 }
4958
4959 U32
4960 Perl_seed(pTHX)
4961 {
4962     dVAR;
4963     /*
4964      * This is really just a quick hack which grabs various garbage
4965      * values.  It really should be a real hash algorithm which
4966      * spreads the effect of every input bit onto every output bit,
4967      * if someone who knows about such things would bother to write it.
4968      * Might be a good idea to add that function to CORE as well.
4969      * No numbers below come from careful analysis or anything here,
4970      * except they are primes and SEED_C1 > 1E6 to get a full-width
4971      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
4972      * probably be bigger too.
4973      */
4974 #if RANDBITS > 16
4975 #  define SEED_C1       1000003
4976 #define   SEED_C4       73819
4977 #else
4978 #  define SEED_C1       25747
4979 #define   SEED_C4       20639
4980 #endif
4981 #define   SEED_C2       3
4982 #define   SEED_C3       269
4983 #define   SEED_C5       26107
4984
4985 #ifndef PERL_NO_DEV_RANDOM
4986     int fd;
4987 #endif
4988     U32 u;
4989 #ifdef VMS
4990 #  include <starlet.h>
4991     /* when[] = (low 32 bits, high 32 bits) of time since epoch
4992      * in 100-ns units, typically incremented ever 10 ms.        */
4993     unsigned int when[2];
4994 #else
4995 #  ifdef HAS_GETTIMEOFDAY
4996     struct timeval when;
4997 #  else
4998     Time_t when;
4999 #  endif
5000 #endif
5001
5002 /* This test is an escape hatch, this symbol isn't set by Configure. */
5003 #ifndef PERL_NO_DEV_RANDOM
5004 #ifndef PERL_RANDOM_DEVICE
5005    /* /dev/random isn't used by default because reads from it will block
5006     * if there isn't enough entropy available.  You can compile with
5007     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5008     * is enough real entropy to fill the seed. */
5009 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5010 #endif
5011     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5012     if (fd != -1) {
5013         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5014             u = 0;
5015         PerlLIO_close(fd);
5016         if (u)
5017             return u;
5018     }
5019 #endif
5020
5021 #ifdef VMS
5022     _ckvmssts(sys$gettim(when));
5023     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5024 #else
5025 #  ifdef HAS_GETTIMEOFDAY
5026     PerlProc_gettimeofday(&when,NULL);
5027     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5028 #  else
5029     (void)time(&when);
5030     u = (U32)SEED_C1 * when;
5031 #  endif
5032 #endif
5033     u += SEED_C3 * (U32)PerlProc_getpid();
5034     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5035 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5036     u += SEED_C5 * (U32)PTR2UV(&when);
5037 #endif
5038     return u;
5039 }
5040
5041 UV
5042 Perl_get_hash_seed(pTHX)
5043 {
5044     dVAR;
5045      const char *s = PerlEnv_getenv("PERL_HASH_SEED");
5046      UV myseed = 0;
5047
5048      if (s)
5049         while (isSPACE(*s))
5050             s++;
5051      if (s && isDIGIT(*s))
5052           myseed = (UV)Atoul(s);
5053      else
5054 #ifdef USE_HASH_SEED_EXPLICIT
5055      if (s)
5056 #endif
5057      {
5058           /* Compute a random seed */
5059           (void)seedDrand01((Rand_seed_t)seed());
5060           myseed = (UV)(Drand01() * (NV)UV_MAX);
5061 #if RANDBITS < (UVSIZE * 8)
5062           /* Since there are not enough randbits to to reach all
5063            * the bits of a UV, the low bits might need extra
5064            * help.  Sum in another random number that will
5065            * fill in the low bits. */
5066           myseed +=
5067                (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5068 #endif /* RANDBITS < (UVSIZE * 8) */
5069           if (myseed == 0) { /* Superparanoia. */
5070               myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5071               if (myseed == 0)
5072                   Perl_croak(aTHX_ "Your random numbers are not that random");
5073           }
5074      }
5075      PL_rehash_seed_set = TRUE;
5076
5077      return myseed;
5078 }
5079
5080 #ifdef USE_ITHREADS
5081 bool
5082 Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5083 {
5084     const char * const stashpv = CopSTASHPV(c);
5085     const char * const name = HvNAME_get(hv);
5086     PERL_UNUSED_CONTEXT;
5087
5088     if (stashpv == name)
5089         return TRUE;
5090     if (stashpv && name)
5091         if (strEQ(stashpv, name))
5092             return TRUE;
5093     return FALSE;
5094 }
5095 #endif
5096
5097
5098 #ifdef PERL_GLOBAL_STRUCT
5099
5100 struct perl_vars *
5101 Perl_init_global_struct(pTHX)
5102 {
5103     struct perl_vars *plvarsp = NULL;
5104 #ifdef PERL_GLOBAL_STRUCT
5105 #  define PERL_GLOBAL_STRUCT_INIT
5106 #  include "opcode.h" /* the ppaddr and check */
5107     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5108     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5109 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5110     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5111     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5112     if (!plvarsp)
5113         exit(1);
5114 #  else
5115     plvarsp = PL_VarsPtr;
5116 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5117 #  undef PERLVAR
5118 #  undef PERLVARA
5119 #  undef PERLVARI
5120 #  undef PERLVARIC
5121 #  undef PERLVARISC
5122 #  define PERLVAR(var,type) /**/
5123 #  define PERLVARA(var,n,type) /**/
5124 #  define PERLVARI(var,type,init) plvarsp->var = init;
5125 #  define PERLVARIC(var,type,init) plvarsp->var = init;
5126 #  define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5127 #  include "perlvars.h"
5128 #  undef PERLVAR
5129 #  undef PERLVARA
5130 #  undef PERLVARI
5131 #  undef PERLVARIC
5132 #  undef PERLVARISC
5133 #  ifdef PERL_GLOBAL_STRUCT
5134     plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5135     if (!plvarsp->Gppaddr)
5136         exit(1);
5137     plvarsp->Gcheck  = PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5138     if (!plvarsp->Gcheck)
5139         exit(1);
5140     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5141     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t);
5142 #  endif
5143 #  ifdef PERL_SET_VARS
5144     PERL_SET_VARS(plvarsp);
5145 #  endif
5146 #  undef PERL_GLOBAL_STRUCT_INIT
5147 #endif
5148     return plvarsp;
5149 }
5150
5151 #endif /* PERL_GLOBAL_STRUCT */
5152
5153 #ifdef PERL_GLOBAL_STRUCT
5154
5155 void
5156 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5157 {
5158 #ifdef PERL_GLOBAL_STRUCT
5159 #  ifdef PERL_UNSET_VARS
5160     PERL_UNSET_VARS(plvarsp);
5161 #  endif
5162     free(plvarsp->Gppaddr);
5163     free(plvarsp->Gcheck);
5164 #    ifdef PERL_GLOBAL_STRUCT_PRIVATE
5165     free(plvarsp);
5166 #    endif
5167 #endif
5168 }
5169
5170 #endif /* PERL_GLOBAL_STRUCT */
5171
5172 #ifdef PERL_MEM_LOG
5173
5174 /*
5175  * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5176  *
5177  * PERL_MEM_LOG_ENV: if defined, during run time the environment
5178  * variable PERL_MEM_LOG will be consulted, and if the integer value
5179  * of that is true, the logging will happen.  (The default is to
5180  * always log if the PERL_MEM_LOG define was in effect.)
5181  */
5182
5183 /*
5184  * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5185  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5186  */
5187 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5188
5189 /*
5190  * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5191  * log to.  You can also define in compile time PERL_MEM_LOG_ENV_FD,
5192  * in which case the environment variable PERL_MEM_LOG_FD will be
5193  * consulted for the file descriptor number to use.
5194  */
5195 #ifndef PERL_MEM_LOG_FD
5196 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5197 #endif
5198
5199 Malloc_t
5200 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)
5201 {
5202 #ifdef PERL_MEM_LOG_STDERR
5203 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5204     char *s;
5205 # endif
5206 # ifdef PERL_MEM_LOG_ENV
5207     s = getenv("PERL_MEM_LOG");
5208     if (s ? atoi(s) : 0)
5209 # endif
5210     {
5211         /* We can't use SVs or PerlIO for obvious reasons,
5212          * so we'll use stdio and low-level IO instead. */
5213         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5214 # ifdef PERL_MEM_LOG_TIMESTAMP
5215         struct timeval tv;
5216 #   ifdef HAS_GETTIMEOFDAY
5217         gettimeofday(&tv, 0);
5218 #   endif
5219         /* If there are other OS specific ways of hires time than
5220          * gettimeofday() (see ext/Time/HiRes), the easiest way is
5221          * probably that they would be used to fill in the struct
5222          * timeval. */
5223 # endif
5224         {
5225             const STRLEN len =
5226                 my_snprintf(buf,
5227                             PERL_MEM_LOG_SPRINTF_BUF_SIZE,
5228 #  ifdef PERL_MEM_LOG_TIMESTAMP
5229                             "%10d.%06d: "
5230 # endif
5231                             "alloc: %s:%d:%s: %"IVdf" %"UVuf
5232                             " %s = %"IVdf": %"UVxf"\n",
5233 #  ifdef PERL_MEM_LOG_TIMESTAMP
5234                             (int)tv.tv_sec, (int)tv.tv_usec,
5235 # endif
5236                             filename, linenumber, funcname, n, typesize,
5237                             typename, n * typesize, PTR2UV(newalloc));
5238 # ifdef PERL_MEM_LOG_ENV_FD
5239             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5240             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5241 # else
5242             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5243 #endif
5244         }
5245     }
5246 #endif
5247     return newalloc;
5248 }
5249
5250 Malloc_t
5251 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)
5252 {
5253 #ifdef PERL_MEM_LOG_STDERR
5254 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5255     char *s;
5256 # endif
5257 # ifdef PERL_MEM_LOG_ENV
5258     s = PerlEnv_getenv("PERL_MEM_LOG");
5259     if (s ? atoi(s) : 0)
5260 # endif
5261     {
5262         /* We can't use SVs or PerlIO for obvious reasons,
5263          * so we'll use stdio and low-level IO instead. */
5264         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5265 #  ifdef PERL_MEM_LOG_TIMESTAMP
5266         struct timeval tv;
5267         gettimeofday(&tv, 0);
5268 # endif
5269         {
5270             const STRLEN len =
5271                 my_snprintf(buf,
5272                             PERL_MEM_LOG_SPRINTF_BUF_SIZE,
5273 #  ifdef PERL_MEM_LOG_TIMESTAMP
5274                             "%10d.%06d: "
5275 # endif
5276                             "realloc: %s:%d:%s: %"IVdf" %"UVuf
5277                             " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5278 #  ifdef PERL_MEM_LOG_TIMESTAMP
5279                             (int)tv.tv_sec, (int)tv.tv_usec,
5280 # endif
5281                             filename, linenumber, funcname, n, typesize,
5282                             typename, n * typesize, PTR2UV(oldalloc),
5283                             PTR2UV(newalloc));
5284 # ifdef PERL_MEM_LOG_ENV_FD
5285             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5286             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5287 # else
5288             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5289 # endif
5290         }
5291     }
5292 #endif
5293     return newalloc;
5294 }
5295
5296 Malloc_t
5297 Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
5298 {
5299 #ifdef PERL_MEM_LOG_STDERR
5300 # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5301     char *s;
5302 # endif
5303 # ifdef PERL_MEM_LOG_ENV
5304     s = PerlEnv_getenv("PERL_MEM_LOG");
5305     if (s ? atoi(s) : 0)
5306 # endif
5307     {
5308         /* We can't use SVs or PerlIO for obvious reasons,
5309          * so we'll use stdio and low-level IO instead. */
5310         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5311 #  ifdef PERL_MEM_LOG_TIMESTAMP
5312         struct timeval tv;
5313         gettimeofday(&tv, 0);
5314 # endif
5315         {
5316             const STRLEN len =
5317                 my_snprintf(buf,
5318                             PERL_MEM_LOG_SPRINTF_BUF_SIZE,
5319 #  ifdef PERL_MEM_LOG_TIMESTAMP
5320                             "%10d.%06d: "
5321 # endif
5322                             "free: %s:%d:%s: %"UVxf"\n",
5323 #  ifdef PERL_MEM_LOG_TIMESTAMP
5324                             (int)tv.tv_sec, (int)tv.tv_usec,
5325 # endif
5326                             filename, linenumber, funcname,
5327                             PTR2UV(oldalloc));
5328 # ifdef PERL_MEM_LOG_ENV_FD
5329             s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5330             PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5331 # else
5332             PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5333 # endif
5334         }
5335     }
5336 #endif
5337     return oldalloc;
5338 }
5339
5340 #endif /* PERL_MEM_LOG */
5341
5342 /*
5343 =for apidoc my_sprintf
5344
5345 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5346 the length of the string written to the buffer. Only rare pre-ANSI systems
5347 need the wrapper function - usually this is a direct call to C<sprintf>.
5348
5349 =cut
5350 */
5351 #ifndef SPRINTF_RETURNS_STRLEN
5352 int
5353 Perl_my_sprintf(char *buffer, const char* pat, ...)
5354 {
5355     va_list args;
5356     va_start(args, pat);
5357     vsprintf(buffer, pat, args);
5358     va_end(args);
5359     return strlen(buffer);
5360 }
5361 #endif
5362
5363 /*
5364 =for apidoc my_snprintf
5365
5366 The C library C<snprintf> functionality, if available and
5367 standards-compliant (uses C<vsnprintf>, actually).  However, if the
5368 C<vsnprintf> is not available, will unfortunately use the unsafe
5369 C<vsprintf> which can overrun the buffer (there is an overrun check,
5370 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
5371 getting C<vsnprintf>.
5372
5373 =cut
5374 */
5375 int
5376 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
5377 {
5378     dTHX;
5379     int retval;
5380     va_list ap;
5381     va_start(ap, format);
5382 #ifdef HAS_VSNPRINTF
5383     retval = vsnprintf(buffer, len, format, ap);
5384 #else
5385     retval = vsprintf(buffer, format, ap);
5386 #endif
5387     va_end(ap);
5388     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5389     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5390         Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
5391     return retval;
5392 }
5393
5394 /*
5395 =for apidoc my_vsnprintf
5396
5397 The C library C<vsnprintf> if available and standards-compliant.
5398 However, if if the C<vsnprintf> is not available, will unfortunately
5399 use the unsafe C<vsprintf> which can overrun the buffer (there is an
5400 overrun check, but that may be too late).  Consider using
5401 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
5402
5403 =cut
5404 */
5405 int
5406 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
5407 {
5408     dTHX;
5409     int retval;
5410 #ifdef NEED_VA_COPY
5411     va_list apc;
5412     Perl_va_copy(ap, apc);
5413 # ifdef HAS_VSNPRINTF
5414     retval = vsnprintf(buffer, len, format, apc);
5415 # else
5416     retval = vsprintf(buffer, format, apc);
5417 # endif
5418 #else
5419 # ifdef HAS_VSNPRINTF
5420     retval = vsnprintf(buffer, len, format, ap);
5421 # else
5422     retval = vsprintf(buffer, format, ap);
5423 # endif
5424 #endif /* #ifdef NEED_VA_COPY */
5425     /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
5426     if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5427         Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
5428     return retval;
5429 }
5430
5431 void
5432 Perl_my_clearenv(pTHX)
5433 {
5434     dVAR;
5435 #if ! defined(PERL_MICRO)
5436 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5437     PerlEnv_clearenv();
5438 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5439 #    if defined(USE_ENVIRON_ARRAY)
5440 #      if defined(USE_ITHREADS)
5441     /* only the parent thread can clobber the process environment */
5442     if (PL_curinterp == aTHX)
5443 #      endif /* USE_ITHREADS */
5444     {
5445 #      if ! defined(PERL_USE_SAFE_PUTENV)
5446     if ( !PL_use_safe_putenv) {
5447       I32 i;
5448       if (environ == PL_origenviron)
5449         environ = (char**)safesysmalloc(sizeof(char*));
5450       else
5451         for (i = 0; environ[i]; i++)
5452           (void)safesysfree(environ[i]);
5453     }
5454     environ[0] = NULL;
5455 #      else /* PERL_USE_SAFE_PUTENV */
5456 #        if defined(HAS_CLEARENV)
5457     (void)clearenv();
5458 #        elif defined(HAS_UNSETENV)
5459     int bsiz = 80; /* Most envvar names will be shorter than this. */
5460     char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
5461     while (*environ != NULL) {
5462       char *e = strchr(*environ, '=');
5463       int l = e ? e - *environ : strlen(*environ);
5464       if (bsiz < l + 1) {
5465         (void)safesysfree(buf);
5466         bsiz = l + 1;
5467         buf = (char*)safesysmalloc(bsiz * sizeof(char));
5468       }
5469       strncpy(buf, *environ, l);
5470       *(buf + l) = '\0';
5471       (void)unsetenv(buf);
5472     }
5473     (void)safesysfree(buf);
5474 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5475     /* Just null environ and accept the leakage. */
5476     *environ = NULL;
5477 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
5478 #      endif /* ! PERL_USE_SAFE_PUTENV */
5479     }
5480 #    endif /* USE_ENVIRON_ARRAY */
5481 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
5482 #endif /* PERL_MICRO */
5483 }
5484
5485 #ifdef PERL_IMPLICIT_CONTEXT
5486
5487 /* implements the MY_CXT_INIT macro. The first time a module is loaded,
5488 the global PL_my_cxt_index is incremented, and that value is assigned to
5489 that module's static my_cxt_index (who's address is passed as an arg).
5490 Then, for each interpreter this function is called for, it makes sure a
5491 void* slot is available to hang the static data off, by allocating or
5492 extending the interpreter's PL_my_cxt_list array */
5493
5494 void *
5495 Perl_my_cxt_init(pTHX_ int *index, size_t size)
5496 {
5497     dVAR;
5498     void *p;
5499     if (*index == -1) {
5500         /* this module hasn't been allocated an index yet */
5501         MUTEX_LOCK(&PL_my_ctx_mutex);
5502         *index = PL_my_cxt_index++;
5503         MUTEX_UNLOCK(&PL_my_ctx_mutex);
5504     }
5505
5506     /* make sure the array is big enough */
5507     if (PL_my_cxt_size <= *index) {
5508         if (PL_my_cxt_size) {
5509             while (PL_my_cxt_size <= *index)
5510                 PL_my_cxt_size *= 2;
5511             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5512         }
5513         else {
5514             PL_my_cxt_size = 16;
5515             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5516         }
5517     }
5518     /* newSV() allocates one more than needed */
5519     p = (void*)SvPVX(newSV(size-1));
5520     PL_my_cxt_list[*index] = p;
5521     Zero(p, size, char);
5522     return p;
5523 }
5524 #endif
5525
5526 #ifndef HAS_STRLCAT
5527 Size_t
5528 Perl_my_strlcat(char *dst, const char *src, Size_t size)
5529 {
5530     Size_t used, length, copy;
5531
5532     used = strlen(dst);
5533     length = strlen(src);
5534     if (size > 0 && used < size - 1) {
5535         copy = (length >= size - used) ? size - used - 1 : length;
5536         memcpy(dst + used, src, copy);
5537         dst[used + copy] = '\0';
5538     }
5539     return used + length;
5540 }
5541 #endif
5542
5543 #ifndef HAS_STRLCPY
5544 Size_t
5545 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5546 {
5547     Size_t length, copy;
5548
5549     length = strlen(src);
5550     if (size > 0) {
5551         copy = (length >= size) ? size - 1 : length;
5552         memcpy(dst, src, copy);
5553         dst[copy] = '\0';
5554     }
5555     return length;
5556 }
5557 #endif
5558
5559 /*
5560  * Local variables:
5561  * c-indentation-style: bsd
5562  * c-basic-offset: 4
5563  * indent-tabs-mode: t
5564  * End:
5565  *
5566  * ex: set ts=8 sts=4 sw=4 noet:
5567  */