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