util.c

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