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