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