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