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