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