util.c

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