util.c

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