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