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