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