util.c

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