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