Stop inadvertently skipping Spec.t on VMS.
[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                 /* diag_listed_as: Can't execute %s */
3685                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3686                       (xfailed ? "execute" : "find"),
3687                       (xfailed ? xfailed : scriptname),
3688                       (xfailed ? "" : " on PATH"),
3689                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3690             }
3691             scriptname = NULL;
3692         }
3693         Safefree(xfailed);
3694         scriptname = xfound;
3695     }
3696     return (scriptname ? savepv(scriptname) : NULL);
3697 }
3698
3699 #ifndef PERL_GET_CONTEXT_DEFINED
3700
3701 void *
3702 Perl_get_context(void)
3703 {
3704     dVAR;
3705 #if defined(USE_ITHREADS)
3706 #  ifdef OLD_PTHREADS_API
3707     pthread_addr_t t;
3708     if (pthread_getspecific(PL_thr_key, &t))
3709         Perl_croak_nocontext("panic: pthread_getspecific");
3710     return (void*)t;
3711 #  else
3712 #    ifdef I_MACH_CTHREADS
3713     return (void*)cthread_data(cthread_self());
3714 #    else
3715     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3716 #    endif
3717 #  endif
3718 #else
3719     return (void*)NULL;
3720 #endif
3721 }
3722
3723 void
3724 Perl_set_context(void *t)
3725 {
3726     dVAR;
3727     PERL_ARGS_ASSERT_SET_CONTEXT;
3728 #if defined(USE_ITHREADS)
3729 #  ifdef I_MACH_CTHREADS
3730     cthread_set_data(cthread_self(), t);
3731 #  else
3732     if (pthread_setspecific(PL_thr_key, t))
3733         Perl_croak_nocontext("panic: pthread_setspecific");
3734 #  endif
3735 #else
3736     PERL_UNUSED_ARG(t);
3737 #endif
3738 }
3739
3740 #endif /* !PERL_GET_CONTEXT_DEFINED */
3741
3742 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3743 struct perl_vars *
3744 Perl_GetVars(pTHX)
3745 {
3746  return &PL_Vars;
3747 }
3748 #endif
3749
3750 char **
3751 Perl_get_op_names(pTHX)
3752 {
3753     PERL_UNUSED_CONTEXT;
3754     return (char **)PL_op_name;
3755 }
3756
3757 char **
3758 Perl_get_op_descs(pTHX)
3759 {
3760     PERL_UNUSED_CONTEXT;
3761     return (char **)PL_op_desc;
3762 }
3763
3764 const char *
3765 Perl_get_no_modify(pTHX)
3766 {
3767     PERL_UNUSED_CONTEXT;
3768     return PL_no_modify;
3769 }
3770
3771 U32 *
3772 Perl_get_opargs(pTHX)
3773 {
3774     PERL_UNUSED_CONTEXT;
3775     return (U32 *)PL_opargs;
3776 }
3777
3778 PPADDR_t*
3779 Perl_get_ppaddr(pTHX)
3780 {
3781     dVAR;
3782     PERL_UNUSED_CONTEXT;
3783     return (PPADDR_t*)PL_ppaddr;
3784 }
3785
3786 #ifndef HAS_GETENV_LEN
3787 char *
3788 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3789 {
3790     char * const env_trans = PerlEnv_getenv(env_elem);
3791     PERL_UNUSED_CONTEXT;
3792     PERL_ARGS_ASSERT_GETENV_LEN;
3793     if (env_trans)
3794         *len = strlen(env_trans);
3795     return env_trans;
3796 }
3797 #endif
3798
3799
3800 MGVTBL*
3801 Perl_get_vtbl(pTHX_ int vtbl_id)
3802 {
3803     PERL_UNUSED_CONTEXT;
3804
3805     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3806         ? NULL : PL_magic_vtables + vtbl_id;
3807 }
3808
3809 I32
3810 Perl_my_fflush_all(pTHX)
3811 {
3812 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3813     return PerlIO_flush(NULL);
3814 #else
3815 # if defined(HAS__FWALK)
3816     extern int fflush(FILE *);
3817     /* undocumented, unprototyped, but very useful BSDism */
3818     extern void _fwalk(int (*)(FILE *));
3819     _fwalk(&fflush);
3820     return 0;
3821 # else
3822 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3823     long open_max = -1;
3824 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3825     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3826 #   else
3827 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3828     open_max = sysconf(_SC_OPEN_MAX);
3829 #     else
3830 #      ifdef FOPEN_MAX
3831     open_max = FOPEN_MAX;
3832 #      else
3833 #       ifdef OPEN_MAX
3834     open_max = OPEN_MAX;
3835 #       else
3836 #        ifdef _NFILE
3837     open_max = _NFILE;
3838 #        endif
3839 #       endif
3840 #      endif
3841 #     endif
3842 #    endif
3843     if (open_max > 0) {
3844       long i;
3845       for (i = 0; i < open_max; i++)
3846             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3847                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3848                 STDIO_STREAM_ARRAY[i]._flag)
3849                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3850       return 0;
3851     }
3852 #  endif
3853     SETERRNO(EBADF,RMS_IFI);
3854     return EOF;
3855 # endif
3856 #endif
3857 }
3858
3859 void
3860 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3861 {
3862     if (ckWARN(WARN_IO)) {
3863         SV * const name
3864            = gv && (isGV(gv) || isGV_with_GP(gv))
3865                 ? sv_2mortal(newSVhek(GvENAME_HEK((gv))))
3866                 : NULL;
3867         const char * const direction = have == '>' ? "out" : "in";
3868
3869         if (name && SvPOK(name) && *SvPV_nolen(name))
3870             Perl_warner(aTHX_ packWARN(WARN_IO),
3871                         "Filehandle %"SVf" opened only for %sput",
3872                         name, direction);
3873         else
3874             Perl_warner(aTHX_ packWARN(WARN_IO),
3875                         "Filehandle opened only for %sput", direction);
3876     }
3877 }
3878
3879 void
3880 Perl_report_evil_fh(pTHX_ const GV *gv)
3881 {
3882     const IO *io = gv ? GvIO(gv) : NULL;
3883     const PERL_BITFIELD16 op = PL_op->op_type;
3884     const char *vile;
3885     I32 warn_type;
3886
3887     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3888         vile = "closed";
3889         warn_type = WARN_CLOSED;
3890     }
3891     else {
3892         vile = "unopened";
3893         warn_type = WARN_UNOPENED;
3894     }
3895
3896     if (ckWARN(warn_type)) {
3897         SV * const name
3898             = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ?
3899                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3900         const char * const pars =
3901             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3902         const char * const func =
3903             (const char *)
3904             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3905              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3906              PL_op_desc[op]);
3907         const char * const type =
3908             (const char *)
3909             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3910              ? "socket" : "filehandle");
3911         const bool have_name = name && SvPOK(name) && *SvPV_nolen(name);
3912         Perl_warner(aTHX_ packWARN(warn_type),
3913                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3914                     have_name ? " " : "",
3915                     SVfARG(have_name ? name : &PL_sv_no));
3916         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3917                 Perl_warner(
3918                             aTHX_ packWARN(warn_type),
3919                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3920                         func, pars, have_name ? " " : "",
3921                         SVfARG(have_name ? name : &PL_sv_no)
3922                             );
3923     }
3924 }
3925
3926 /* To workaround core dumps from the uninitialised tm_zone we get the
3927  * system to give us a reasonable struct to copy.  This fix means that
3928  * strftime uses the tm_zone and tm_gmtoff values returned by
3929  * localtime(time()). That should give the desired result most of the
3930  * time. But probably not always!
3931  *
3932  * This does not address tzname aspects of NETaa14816.
3933  *
3934  */
3935
3936 #ifdef HAS_GNULIBC
3937 # ifndef STRUCT_TM_HASZONE
3938 #    define STRUCT_TM_HASZONE
3939 # endif
3940 #endif
3941
3942 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3943 # ifndef HAS_TM_TM_ZONE
3944 #    define HAS_TM_TM_ZONE
3945 # endif
3946 #endif
3947
3948 void
3949 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3950 {
3951 #ifdef HAS_TM_TM_ZONE
3952     Time_t now;
3953     const struct tm* my_tm;
3954     PERL_ARGS_ASSERT_INIT_TM;
3955     (void)time(&now);
3956     my_tm = localtime(&now);
3957     if (my_tm)
3958         Copy(my_tm, ptm, 1, struct tm);
3959 #else
3960     PERL_ARGS_ASSERT_INIT_TM;
3961     PERL_UNUSED_ARG(ptm);
3962 #endif
3963 }
3964
3965 /*
3966  * mini_mktime - normalise struct tm values without the localtime()
3967  * semantics (and overhead) of mktime().
3968  */
3969 void
3970 Perl_mini_mktime(pTHX_ struct tm *ptm)
3971 {
3972     int yearday;
3973     int secs;
3974     int month, mday, year, jday;
3975     int odd_cent, odd_year;
3976     PERL_UNUSED_CONTEXT;
3977
3978     PERL_ARGS_ASSERT_MINI_MKTIME;
3979
3980 #define DAYS_PER_YEAR   365
3981 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3982 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3983 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3984 #define SECS_PER_HOUR   (60*60)
3985 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3986 /* parentheses deliberately absent on these two, otherwise they don't work */
3987 #define MONTH_TO_DAYS   153/5
3988 #define DAYS_TO_MONTH   5/153
3989 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3990 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3991 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3992 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3993
3994 /*
3995  * Year/day algorithm notes:
3996  *
3997  * With a suitable offset for numeric value of the month, one can find
3998  * an offset into the year by considering months to have 30.6 (153/5) days,
3999  * using integer arithmetic (i.e., with truncation).  To avoid too much
4000  * messing about with leap days, we consider January and February to be
4001  * the 13th and 14th month of the previous year.  After that transformation,
4002  * we need the month index we use to be high by 1 from 'normal human' usage,
4003  * so the month index values we use run from 4 through 15.
4004  *
4005  * Given that, and the rules for the Gregorian calendar (leap years are those
4006  * divisible by 4 unless also divisible by 100, when they must be divisible
4007  * by 400 instead), we can simply calculate the number of days since some
4008  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
4009  * the days we derive from our month index, and adding in the day of the
4010  * month.  The value used here is not adjusted for the actual origin which
4011  * it normally would use (1 January A.D. 1), since we're not exposing it.
4012  * We're only building the value so we can turn around and get the
4013  * normalised values for the year, month, day-of-month, and day-of-year.
4014  *
4015  * For going backward, we need to bias the value we're using so that we find
4016  * the right year value.  (Basically, we don't want the contribution of
4017  * March 1st to the number to apply while deriving the year).  Having done
4018  * that, we 'count up' the contribution to the year number by accounting for
4019  * full quadracenturies (400-year periods) with their extra leap days, plus
4020  * the contribution from full centuries (to avoid counting in the lost leap
4021  * days), plus the contribution from full quad-years (to count in the normal
4022  * leap days), plus the leftover contribution from any non-leap years.
4023  * At this point, if we were working with an actual leap day, we'll have 0
4024  * days left over.  This is also true for March 1st, however.  So, we have
4025  * to special-case that result, and (earlier) keep track of the 'odd'
4026  * century and year contributions.  If we got 4 extra centuries in a qcent,
4027  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
4028  * Otherwise, we add back in the earlier bias we removed (the 123 from
4029  * figuring in March 1st), find the month index (integer division by 30.6),
4030  * and the remainder is the day-of-month.  We then have to convert back to
4031  * 'real' months (including fixing January and February from being 14/15 in
4032  * the previous year to being in the proper year).  After that, to get
4033  * tm_yday, we work with the normalised year and get a new yearday value for
4034  * January 1st, which we subtract from the yearday value we had earlier,
4035  * representing the date we've re-built.  This is done from January 1
4036  * because tm_yday is 0-origin.
4037  *
4038  * Since POSIX time routines are only guaranteed to work for times since the
4039  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
4040  * applies Gregorian calendar rules even to dates before the 16th century
4041  * doesn't bother me.  Besides, you'd need cultural context for a given
4042  * date to know whether it was Julian or Gregorian calendar, and that's
4043  * outside the scope for this routine.  Since we convert back based on the
4044  * same rules we used to build the yearday, you'll only get strange results
4045  * for input which needed normalising, or for the 'odd' century years which
4046  * were leap years in the Julian calendar but not in the Gregorian one.
4047  * I can live with that.
4048  *
4049  * This algorithm also fails to handle years before A.D. 1 gracefully, but
4050  * that's still outside the scope for POSIX time manipulation, so I don't
4051  * care.
4052  */
4053
4054     year = 1900 + ptm->tm_year;
4055     month = ptm->tm_mon;
4056     mday = ptm->tm_mday;
4057     /* allow given yday with no month & mday to dominate the result */
4058     if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
4059         month = 0;
4060         mday = 0;
4061         jday = 1 + ptm->tm_yday;
4062     }
4063     else {
4064         jday = 0;
4065     }
4066     if (month >= 2)
4067         month+=2;
4068     else
4069         month+=14, year--;
4070     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
4071     yearday += month*MONTH_TO_DAYS + mday + jday;
4072     /*
4073      * Note that we don't know when leap-seconds were or will be,
4074      * so we have to trust the user if we get something which looks
4075      * like a sensible leap-second.  Wild values for seconds will
4076      * be rationalised, however.
4077      */
4078     if ((unsigned) ptm->tm_sec <= 60) {
4079         secs = 0;
4080     }
4081     else {
4082         secs = ptm->tm_sec;
4083         ptm->tm_sec = 0;
4084     }
4085     secs += 60 * ptm->tm_min;
4086     secs += SECS_PER_HOUR * ptm->tm_hour;
4087     if (secs < 0) {
4088         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
4089             /* got negative remainder, but need positive time */
4090             /* back off an extra day to compensate */
4091             yearday += (secs/SECS_PER_DAY)-1;
4092             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
4093         }
4094         else {
4095             yearday += (secs/SECS_PER_DAY);
4096             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
4097         }
4098     }
4099     else if (secs >= SECS_PER_DAY) {
4100         yearday += (secs/SECS_PER_DAY);
4101         secs %= SECS_PER_DAY;
4102     }
4103     ptm->tm_hour = secs/SECS_PER_HOUR;
4104     secs %= SECS_PER_HOUR;
4105     ptm->tm_min = secs/60;
4106     secs %= 60;
4107     ptm->tm_sec += secs;
4108     /* done with time of day effects */
4109     /*
4110      * The algorithm for yearday has (so far) left it high by 428.
4111      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
4112      * bias it by 123 while trying to figure out what year it
4113      * really represents.  Even with this tweak, the reverse
4114      * translation fails for years before A.D. 0001.
4115      * It would still fail for Feb 29, but we catch that one below.
4116      */
4117     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
4118     yearday -= YEAR_ADJUST;
4119     year = (yearday / DAYS_PER_QCENT) * 400;
4120     yearday %= DAYS_PER_QCENT;
4121     odd_cent = yearday / DAYS_PER_CENT;
4122     year += odd_cent * 100;
4123     yearday %= DAYS_PER_CENT;
4124     year += (yearday / DAYS_PER_QYEAR) * 4;
4125     yearday %= DAYS_PER_QYEAR;
4126     odd_year = yearday / DAYS_PER_YEAR;
4127     year += odd_year;
4128     yearday %= DAYS_PER_YEAR;
4129     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
4130         month = 1;
4131         yearday = 29;
4132     }
4133     else {
4134         yearday += YEAR_ADJUST; /* recover March 1st crock */
4135         month = yearday*DAYS_TO_MONTH;
4136         yearday -= month*MONTH_TO_DAYS;
4137         /* recover other leap-year adjustment */
4138         if (month > 13) {
4139             month-=14;
4140             year++;
4141         }
4142         else {
4143             month-=2;
4144         }
4145     }
4146     ptm->tm_year = year - 1900;
4147     if (yearday) {
4148       ptm->tm_mday = yearday;
4149       ptm->tm_mon = month;
4150     }
4151     else {
4152       ptm->tm_mday = 31;
4153       ptm->tm_mon = month - 1;
4154     }
4155     /* re-build yearday based on Jan 1 to get tm_yday */
4156     year--;
4157     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4158     yearday += 14*MONTH_TO_DAYS + 1;
4159     ptm->tm_yday = jday - yearday;
4160     /* fix tm_wday if not overridden by caller */
4161     if ((unsigned)ptm->tm_wday > 6)
4162         ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4163 }
4164
4165 char *
4166 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)
4167 {
4168 #ifdef HAS_STRFTIME
4169   char *buf;
4170   int buflen;
4171   struct tm mytm;
4172   int len;
4173
4174   PERL_ARGS_ASSERT_MY_STRFTIME;
4175
4176   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4177   mytm.tm_sec = sec;
4178   mytm.tm_min = min;
4179   mytm.tm_hour = hour;
4180   mytm.tm_mday = mday;
4181   mytm.tm_mon = mon;
4182   mytm.tm_year = year;
4183   mytm.tm_wday = wday;
4184   mytm.tm_yday = yday;
4185   mytm.tm_isdst = isdst;
4186   mini_mktime(&mytm);
4187   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4188 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4189   STMT_START {
4190     struct tm mytm2;
4191     mytm2 = mytm;
4192     mktime(&mytm2);
4193 #ifdef HAS_TM_TM_GMTOFF
4194     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4195 #endif
4196 #ifdef HAS_TM_TM_ZONE
4197     mytm.tm_zone = mytm2.tm_zone;
4198 #endif
4199   } STMT_END;
4200 #endif
4201   buflen = 64;
4202   Newx(buf, buflen, char);
4203   len = strftime(buf, buflen, fmt, &mytm);
4204   /*
4205   ** The following is needed to handle to the situation where
4206   ** tmpbuf overflows.  Basically we want to allocate a buffer
4207   ** and try repeatedly.  The reason why it is so complicated
4208   ** is that getting a return value of 0 from strftime can indicate
4209   ** one of the following:
4210   ** 1. buffer overflowed,
4211   ** 2. illegal conversion specifier, or
4212   ** 3. the format string specifies nothing to be returned(not
4213   **      an error).  This could be because format is an empty string
4214   **    or it specifies %p that yields an empty string in some locale.
4215   ** If there is a better way to make it portable, go ahead by
4216   ** all means.
4217   */
4218   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4219     return buf;
4220   else {
4221     /* Possibly buf overflowed - try again with a bigger buf */
4222     const int fmtlen = strlen(fmt);
4223     int bufsize = fmtlen + buflen;
4224
4225     Renew(buf, bufsize, char);
4226     while (buf) {
4227       buflen = strftime(buf, bufsize, fmt, &mytm);
4228       if (buflen > 0 && buflen < bufsize)
4229         break;
4230       /* heuristic to prevent out-of-memory errors */
4231       if (bufsize > 100*fmtlen) {
4232         Safefree(buf);
4233         buf = NULL;
4234         break;
4235       }
4236       bufsize *= 2;
4237       Renew(buf, bufsize, char);
4238     }
4239     return buf;
4240   }
4241 #else
4242   Perl_croak(aTHX_ "panic: no strftime");
4243   return NULL;
4244 #endif
4245 }
4246
4247
4248 #define SV_CWD_RETURN_UNDEF \
4249 sv_setsv(sv, &PL_sv_undef); \
4250 return FALSE
4251
4252 #define SV_CWD_ISDOT(dp) \
4253     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4254         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4255
4256 /*
4257 =head1 Miscellaneous Functions
4258
4259 =for apidoc getcwd_sv
4260
4261 Fill the sv with current working directory
4262
4263 =cut
4264 */
4265
4266 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4267  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4268  * getcwd(3) if available
4269  * Comments from the orignal:
4270  *     This is a faster version of getcwd.  It's also more dangerous
4271  *     because you might chdir out of a directory that you can't chdir
4272  *     back into. */
4273
4274 int
4275 Perl_getcwd_sv(pTHX_ register SV *sv)
4276 {
4277 #ifndef PERL_MICRO
4278     dVAR;
4279 #ifndef INCOMPLETE_TAINTS
4280     SvTAINTED_on(sv);
4281 #endif
4282
4283     PERL_ARGS_ASSERT_GETCWD_SV;
4284
4285 #ifdef HAS_GETCWD
4286     {
4287         char buf[MAXPATHLEN];
4288
4289         /* Some getcwd()s automatically allocate a buffer of the given
4290          * size from the heap if they are given a NULL buffer pointer.
4291          * The problem is that this behaviour is not portable. */
4292         if (getcwd(buf, sizeof(buf) - 1)) {
4293             sv_setpv(sv, buf);
4294             return TRUE;
4295         }
4296         else {
4297             sv_setsv(sv, &PL_sv_undef);
4298             return FALSE;
4299         }
4300     }
4301
4302 #else
4303
4304     Stat_t statbuf;
4305     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4306     int pathlen=0;
4307     Direntry_t *dp;
4308
4309     SvUPGRADE(sv, SVt_PV);
4310
4311     if (PerlLIO_lstat(".", &statbuf) < 0) {
4312         SV_CWD_RETURN_UNDEF;
4313     }
4314
4315     orig_cdev = statbuf.st_dev;
4316     orig_cino = statbuf.st_ino;
4317     cdev = orig_cdev;
4318     cino = orig_cino;
4319
4320     for (;;) {
4321         DIR *dir;
4322         int namelen;
4323         odev = cdev;
4324         oino = cino;
4325
4326         if (PerlDir_chdir("..") < 0) {
4327             SV_CWD_RETURN_UNDEF;
4328         }
4329         if (PerlLIO_stat(".", &statbuf) < 0) {
4330             SV_CWD_RETURN_UNDEF;
4331         }
4332
4333         cdev = statbuf.st_dev;
4334         cino = statbuf.st_ino;
4335
4336         if (odev == cdev && oino == cino) {
4337             break;
4338         }
4339         if (!(dir = PerlDir_open("."))) {
4340             SV_CWD_RETURN_UNDEF;
4341         }
4342
4343         while ((dp = PerlDir_read(dir)) != NULL) {
4344 #ifdef DIRNAMLEN
4345             namelen = dp->d_namlen;
4346 #else
4347             namelen = strlen(dp->d_name);
4348 #endif
4349             /* skip . and .. */
4350             if (SV_CWD_ISDOT(dp)) {
4351                 continue;
4352             }
4353
4354             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4355                 SV_CWD_RETURN_UNDEF;
4356             }
4357
4358             tdev = statbuf.st_dev;
4359             tino = statbuf.st_ino;
4360             if (tino == oino && tdev == odev) {
4361                 break;
4362             }
4363         }
4364
4365         if (!dp) {
4366             SV_CWD_RETURN_UNDEF;
4367         }
4368
4369         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4370             SV_CWD_RETURN_UNDEF;
4371         }
4372
4373         SvGROW(sv, pathlen + namelen + 1);
4374
4375         if (pathlen) {
4376             /* shift down */
4377             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4378         }
4379
4380         /* prepend current directory to the front */
4381         *SvPVX(sv) = '/';
4382         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4383         pathlen += (namelen + 1);
4384
4385 #ifdef VOID_CLOSEDIR
4386         PerlDir_close(dir);
4387 #else
4388         if (PerlDir_close(dir) < 0) {
4389             SV_CWD_RETURN_UNDEF;
4390         }
4391 #endif
4392     }
4393
4394     if (pathlen) {
4395         SvCUR_set(sv, pathlen);
4396         *SvEND(sv) = '\0';
4397         SvPOK_only(sv);
4398
4399         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4400             SV_CWD_RETURN_UNDEF;
4401         }
4402     }
4403     if (PerlLIO_stat(".", &statbuf) < 0) {
4404         SV_CWD_RETURN_UNDEF;
4405     }
4406
4407     cdev = statbuf.st_dev;
4408     cino = statbuf.st_ino;
4409
4410     if (cdev != orig_cdev || cino != orig_cino) {
4411         Perl_croak(aTHX_ "Unstable directory path, "
4412                    "current directory changed unexpectedly");
4413     }
4414
4415     return TRUE;
4416 #endif
4417
4418 #else
4419     return FALSE;
4420 #endif
4421 }
4422
4423 #define VERSION_MAX 0x7FFFFFFF
4424
4425 /*
4426 =for apidoc prescan_version
4427
4428 Validate that a given string can be parsed as a version object, but doesn't
4429 actually perform the parsing.  Can use either strict or lax validation rules.
4430 Can optionally set a number of hint variables to save the parsing code
4431 some time when tokenizing.
4432
4433 =cut
4434 */
4435 const char *
4436 Perl_prescan_version(pTHX_ const char *s, bool strict,
4437                      const char **errstr,
4438                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4439     bool qv = (sqv ? *sqv : FALSE);
4440     int width = 3;
4441     int saw_decimal = 0;
4442     bool alpha = FALSE;
4443     const char *d = s;
4444
4445     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4446
4447     if (qv && isDIGIT(*d))
4448         goto dotted_decimal_version;
4449
4450     if (*d == 'v') { /* explicit v-string */
4451         d++;
4452         if (isDIGIT(*d)) {
4453             qv = TRUE;
4454         }
4455         else { /* degenerate v-string */
4456             /* requires v1.2.3 */
4457             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4458         }
4459
4460 dotted_decimal_version:
4461         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4462             /* no leading zeros allowed */
4463             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4464         }
4465
4466         while (isDIGIT(*d))     /* integer part */
4467             d++;
4468
4469         if (*d == '.')
4470         {
4471             saw_decimal++;
4472             d++;                /* decimal point */
4473         }
4474         else
4475         {
4476             if (strict) {
4477                 /* require v1.2.3 */
4478                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4479             }
4480             else {
4481                 goto version_prescan_finish;
4482             }
4483         }
4484
4485         {
4486             int i = 0;
4487             int j = 0;
4488             while (isDIGIT(*d)) {       /* just keep reading */
4489                 i++;
4490                 while (isDIGIT(*d)) {
4491                     d++; j++;
4492                     /* maximum 3 digits between decimal */
4493                     if (strict && j > 3) {
4494                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4495                     }
4496                 }
4497                 if (*d == '_') {
4498                     if (strict) {
4499                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4500                     }
4501                     if ( alpha ) {
4502                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4503                     }
4504                     d++;
4505                     alpha = TRUE;
4506                 }
4507                 else if (*d == '.') {
4508                     if (alpha) {
4509                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4510                     }
4511                     saw_decimal++;
4512                     d++;
4513                 }
4514                 else if (!isDIGIT(*d)) {
4515                     break;
4516                 }
4517                 j = 0;
4518             }
4519
4520             if (strict && i < 2) {
4521                 /* requires v1.2.3 */
4522                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4523             }
4524         }
4525     }                                   /* end if dotted-decimal */
4526     else
4527     {                                   /* decimal versions */
4528         /* special strict case for leading '.' or '0' */
4529         if (strict) {
4530             if (*d == '.') {
4531                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4532             }
4533             if (*d == '0' && isDIGIT(d[1])) {
4534                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4535             }
4536         }
4537
4538         /* and we never support negative versions */
4539         if ( *d == '-') {
4540                 BADVERSION(s,errstr,"Invalid version format (negative version number)");                
4541         }
4542
4543         /* consume all of the integer part */
4544         while (isDIGIT(*d))
4545             d++;
4546
4547         /* look for a fractional part */
4548         if (*d == '.') {
4549             /* we found it, so consume it */
4550             saw_decimal++;
4551             d++;
4552         }
4553         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4554             if ( d == s ) {
4555                 /* found nothing */
4556                 BADVERSION(s,errstr,"Invalid version format (version required)");
4557             }
4558             /* found just an integer */
4559             goto version_prescan_finish;
4560         }
4561         else if ( d == s ) {
4562             /* didn't find either integer or period */
4563             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4564         }
4565         else if (*d == '_') {
4566             /* underscore can't come after integer part */
4567             if (strict) {
4568                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4569             }
4570             else if (isDIGIT(d[1])) {
4571                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4572             }
4573             else {
4574                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4575             }
4576         }
4577         else {
4578             /* anything else after integer part is just invalid data */
4579             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4580         }
4581
4582         /* scan the fractional part after the decimal point*/
4583
4584         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4585                 /* strict or lax-but-not-the-end */
4586                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4587         }
4588
4589         while (isDIGIT(*d)) {
4590             d++;
4591             if (*d == '.' && isDIGIT(d[-1])) {
4592                 if (alpha) {
4593                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4594                 }
4595                 if (strict) {
4596                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4597                 }
4598                 d = (char *)s;          /* start all over again */
4599                 qv = TRUE;
4600                 goto dotted_decimal_version;
4601             }
4602             if (*d == '_') {
4603                 if (strict) {
4604                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4605                 }
4606                 if ( alpha ) {
4607                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4608                 }
4609                 if ( ! isDIGIT(d[1]) ) {
4610                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4611                 }
4612                 d++;
4613                 alpha = TRUE;
4614             }
4615         }
4616     }
4617
4618 version_prescan_finish:
4619     while (isSPACE(*d))
4620         d++;
4621
4622     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4623         /* trailing non-numeric data */
4624         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4625     }
4626
4627     if (sqv)
4628         *sqv = qv;
4629     if (swidth)
4630         *swidth = width;
4631     if (ssaw_decimal)
4632         *ssaw_decimal = saw_decimal;
4633     if (salpha)
4634         *salpha = alpha;
4635     return d;
4636 }
4637
4638 /*
4639 =for apidoc scan_version
4640
4641 Returns a pointer to the next character after the parsed
4642 version string, as well as upgrading the passed in SV to
4643 an RV.
4644
4645 Function must be called with an already existing SV like
4646
4647     sv = newSV(0);
4648     s = scan_version(s, SV *sv, bool qv);
4649
4650 Performs some preprocessing to the string to ensure that
4651 it has the correct characteristics of a version.  Flags the
4652 object if it contains an underscore (which denotes this
4653 is an alpha version).  The boolean qv denotes that the version
4654 should be interpreted as if it had multiple decimals, even if
4655 it doesn't.
4656
4657 =cut
4658 */
4659
4660 const char *
4661 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4662 {
4663     const char *start;
4664     const char *pos;
4665     const char *last;
4666     const char *errstr = NULL;
4667     int saw_decimal = 0;
4668     int width = 3;
4669     bool alpha = FALSE;
4670     bool vinf = FALSE;
4671     AV * const av = newAV();
4672     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4673
4674     PERL_ARGS_ASSERT_SCAN_VERSION;
4675
4676     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4677
4678 #ifndef NODEFAULT_SHAREKEYS
4679     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4680 #endif
4681
4682     while (isSPACE(*s)) /* leading whitespace is OK */
4683         s++;
4684
4685     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4686     if (errstr) {
4687         /* "undef" is a special case and not an error */
4688         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4689             Perl_croak(aTHX_ "%s", errstr);
4690         }
4691     }
4692
4693     start = s;
4694     if (*s == 'v')
4695         s++;
4696     pos = s;
4697
4698     if ( qv )
4699         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4700     if ( alpha )
4701         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4702     if ( !qv && width < 3 )
4703         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4704     
4705     while (isDIGIT(*pos))
4706         pos++;
4707     if (!isALPHA(*pos)) {
4708         I32 rev;
4709
4710         for (;;) {
4711             rev = 0;
4712             {
4713                 /* this is atoi() that delimits on underscores */
4714                 const char *end = pos;
4715                 I32 mult = 1;
4716                 I32 orev;
4717
4718                 /* the following if() will only be true after the decimal
4719                  * point of a version originally created with a bare
4720                  * floating point number, i.e. not quoted in any way
4721                  */
4722                 if ( !qv && s > start && saw_decimal == 1 ) {
4723                     mult *= 100;
4724                     while ( s < end ) {
4725                         orev = rev;
4726                         rev += (*s - '0') * mult;
4727                         mult /= 10;
4728                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4729                             || (PERL_ABS(rev) > VERSION_MAX )) {
4730                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4731                                            "Integer overflow in version %d",VERSION_MAX);
4732                             s = end - 1;
4733                             rev = VERSION_MAX;
4734                             vinf = 1;
4735                         }
4736                         s++;
4737                         if ( *s == '_' )
4738                             s++;
4739                     }
4740                 }
4741                 else {
4742                     while (--end >= s) {
4743                         orev = rev;
4744                         rev += (*end - '0') * mult;
4745                         mult *= 10;
4746                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4747                             || (PERL_ABS(rev) > VERSION_MAX )) {
4748                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4749                                            "Integer overflow in version");
4750                             end = s - 1;
4751                             rev = VERSION_MAX;
4752                             vinf = 1;
4753                         }
4754                     }
4755                 } 
4756             }
4757
4758             /* Append revision */
4759             av_push(av, newSViv(rev));
4760             if ( vinf ) {
4761                 s = last;
4762                 break;
4763             }
4764             else if ( *pos == '.' )
4765                 s = ++pos;
4766             else if ( *pos == '_' && isDIGIT(pos[1]) )
4767                 s = ++pos;
4768             else if ( *pos == ',' && isDIGIT(pos[1]) )
4769                 s = ++pos;
4770             else if ( isDIGIT(*pos) )
4771                 s = pos;
4772             else {
4773                 s = pos;
4774                 break;
4775             }
4776             if ( qv ) {
4777                 while ( isDIGIT(*pos) )
4778                     pos++;
4779             }
4780             else {
4781                 int digits = 0;
4782                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4783                     if ( *pos != '_' )
4784                         digits++;
4785                     pos++;
4786                 }
4787             }
4788         }
4789     }
4790     if ( qv ) { /* quoted versions always get at least three terms*/
4791         I32 len = av_len(av);
4792         /* This for loop appears to trigger a compiler bug on OS X, as it
4793            loops infinitely. Yes, len is negative. No, it makes no sense.
4794            Compiler in question is:
4795            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4796            for ( len = 2 - len; len > 0; len-- )
4797            av_push(MUTABLE_AV(sv), newSViv(0));
4798         */
4799         len = 2 - len;
4800         while (len-- > 0)
4801             av_push(av, newSViv(0));
4802     }
4803
4804     /* need to save off the current version string for later */
4805     if ( vinf ) {
4806         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4807         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4808         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4809     }
4810     else if ( s > start ) {
4811         SV * orig = newSVpvn(start,s-start);
4812         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4813             /* need to insert a v to be consistent */
4814             sv_insert(orig, 0, 0, "v", 1);
4815         }
4816         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4817     }
4818     else {
4819         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4820         av_push(av, newSViv(0));
4821     }
4822
4823     /* And finally, store the AV in the hash */
4824     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4825
4826     /* fix RT#19517 - special case 'undef' as string */
4827     if ( *s == 'u' && strEQ(s,"undef") ) {
4828         s += 5;
4829     }
4830
4831     return s;
4832 }
4833
4834 /*
4835 =for apidoc new_version
4836
4837 Returns a new version object based on the passed in SV:
4838
4839     SV *sv = new_version(SV *ver);
4840
4841 Does not alter the passed in ver SV.  See "upg_version" if you
4842 want to upgrade the SV.
4843
4844 =cut
4845 */
4846
4847 SV *
4848 Perl_new_version(pTHX_ SV *ver)
4849 {
4850     dVAR;
4851     SV * const rv = newSV(0);
4852     PERL_ARGS_ASSERT_NEW_VERSION;
4853     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4854          /* can just copy directly */
4855     {
4856         I32 key;
4857         AV * const av = newAV();
4858         AV *sav;
4859         /* This will get reblessed later if a derived class*/
4860         SV * const hv = newSVrv(rv, "version"); 
4861         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4862 #ifndef NODEFAULT_SHAREKEYS
4863         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4864 #endif
4865
4866         if ( SvROK(ver) )
4867             ver = SvRV(ver);
4868
4869         /* Begin copying all of the elements */
4870         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4871             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4872
4873         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4874             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4875         
4876         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4877         {
4878             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4879             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4880         }
4881
4882         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4883         {
4884             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4885             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4886         }
4887
4888         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4889         /* This will get reblessed later if a derived class*/
4890         for ( key = 0; key <= av_len(sav); key++ )
4891         {
4892             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4893             av_push(av, newSViv(rev));
4894         }
4895
4896         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4897         return rv;
4898     }
4899 #ifdef SvVOK
4900     {
4901         const MAGIC* const mg = SvVSTRING_mg(ver);
4902         if ( mg ) { /* already a v-string */
4903             const STRLEN len = mg->mg_len;
4904             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4905             sv_setpvn(rv,version,len);
4906             /* this is for consistency with the pure Perl class */
4907             if ( isDIGIT(*version) )
4908                 sv_insert(rv, 0, 0, "v", 1);
4909             Safefree(version);
4910         }
4911         else {
4912 #endif
4913         sv_setsv(rv,ver); /* make a duplicate */
4914 #ifdef SvVOK
4915         }
4916     }
4917 #endif
4918     return upg_version(rv, FALSE);
4919 }
4920
4921 /*
4922 =for apidoc upg_version
4923
4924 In-place upgrade of the supplied SV to a version object.
4925
4926     SV *sv = upg_version(SV *sv, bool qv);
4927
4928 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4929 to force this SV to be interpreted as an "extended" version.
4930
4931 =cut
4932 */
4933
4934 SV *
4935 Perl_upg_version(pTHX_ SV *ver, bool qv)
4936 {
4937     const char *version, *s;
4938 #ifdef SvVOK
4939     const MAGIC *mg;
4940 #endif
4941
4942     PERL_ARGS_ASSERT_UPG_VERSION;
4943
4944     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4945     {
4946         STRLEN len;
4947
4948         /* may get too much accuracy */ 
4949         char tbuf[64];
4950 #ifdef USE_LOCALE_NUMERIC
4951         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
4952         setlocale(LC_NUMERIC, "C");
4953 #endif
4954         len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4955 #ifdef USE_LOCALE_NUMERIC
4956         setlocale(LC_NUMERIC, loc);
4957         Safefree(loc);
4958 #endif
4959         while (tbuf[len-1] == '0' && len > 0) len--;
4960         if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */
4961         version = savepvn(tbuf, len);
4962     }
4963 #ifdef SvVOK
4964     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4965         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4966         qv = TRUE;
4967     }
4968 #endif
4969     else /* must be a string or something like a string */
4970     {
4971         STRLEN len;
4972         version = savepv(SvPV(ver,len));
4973 #ifndef SvVOK
4974 #  if PERL_VERSION > 5
4975         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4976         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4977             /* may be a v-string */
4978             char *testv = (char *)version;
4979             STRLEN tlen = len;
4980             for (tlen=0; tlen < len; tlen++, testv++) {
4981                 /* if one of the characters is non-text assume v-string */
4982                 if (testv[0] < ' ') {
4983                     SV * const nsv = sv_newmortal();
4984                     const char *nver;
4985                     const char *pos;
4986                     int saw_decimal = 0;
4987                     sv_setpvf(nsv,"v%vd",ver);
4988                     pos = nver = savepv(SvPV_nolen(nsv));
4989
4990                     /* scan the resulting formatted string */
4991                     pos++; /* skip the leading 'v' */
4992                     while ( *pos == '.' || isDIGIT(*pos) ) {
4993                         if ( *pos == '.' )
4994                             saw_decimal++ ;
4995                         pos++;
4996                     }
4997
4998                     /* is definitely a v-string */
4999                     if ( saw_decimal >= 2 ) {   
5000                         Safefree(version);
5001                         version = nver;
5002                     }
5003                     break;
5004                 }
5005             }
5006         }
5007 #  endif
5008 #endif
5009     }
5010
5011     s = scan_version(version, ver, qv);
5012     if ( *s != '\0' ) 
5013         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
5014                        "Version string '%s' contains invalid data; "
5015                        "ignoring: '%s'", version, s);
5016     Safefree(version);
5017     return ver;
5018 }
5019
5020 /*
5021 =for apidoc vverify
5022
5023 Validates that the SV contains valid internal structure for a version object.
5024 It may be passed either the version object (RV) or the hash itself (HV).  If
5025 the structure is valid, it returns the HV.  If the structure is invalid,
5026 it returns NULL.
5027
5028     SV *hv = vverify(sv);
5029
5030 Note that it only confirms the bare minimum structure (so as not to get
5031 confused by derived classes which may contain additional hash entries):
5032
5033 =over 4
5034
5035 =item * The SV is an HV or a reference to an HV
5036
5037 =item * The hash contains a "version" key
5038
5039 =item * The "version" key has a reference to an AV as its value
5040
5041 =back
5042
5043 =cut
5044 */