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