util.c

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