util.c

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