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