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