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