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