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