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