util.c

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