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