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