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