This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
75381f1227046c257a027c2f5cdae81853b8b760
[perl5.git] / util.c
1 /*    util.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13  *  not content.'                                    --Gandalf to Pippin
14  *
15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16  */
17
18 /* This file contains assorted utility routines.
19  * Which is a polite way of saying any stuff that people couldn't think of
20  * a better place for. Amongst other things, it includes the warning and
21  * dieing stuff, plus wrappers for malloc code.
22  */
23
24 #include "EXTERN.h"
25 #define PERL_IN_UTIL_C
26 #include "perl.h"
27 #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 USE_PERLIO
2802     MUTEX_LOCK(&PL_perlio_mutex);
2803 #  endif
2804 #  ifdef MYMALLOC
2805     MUTEX_LOCK(&PL_malloc_mutex);
2806 #  endif
2807     OP_REFCNT_LOCK;
2808 #endif
2809 }
2810
2811 /* this is called in both parent and child after the fork() */
2812 void
2813 Perl_atfork_unlock(void)
2814 {
2815     dVAR;
2816 #if defined(USE_ITHREADS)
2817     /* locks must be released in same order as in atfork_lock() */
2818 #  ifdef USE_PERLIO
2819     MUTEX_UNLOCK(&PL_perlio_mutex);
2820 #  endif
2821 #  ifdef MYMALLOC
2822     MUTEX_UNLOCK(&PL_malloc_mutex);
2823 #  endif
2824     OP_REFCNT_UNLOCK;
2825 #endif
2826 }
2827
2828 Pid_t
2829 Perl_my_fork(void)
2830 {
2831 #if defined(HAS_FORK)
2832     Pid_t pid;
2833 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2834     atfork_lock();
2835     pid = fork();
2836     atfork_unlock();
2837 #else
2838     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2839      * handlers elsewhere in the code */
2840     pid = fork();
2841 #endif
2842     return pid;
2843 #else
2844     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2845     Perl_croak_nocontext("fork() not available");
2846     return 0;
2847 #endif /* HAS_FORK */
2848 }
2849
2850 #ifdef DUMP_FDS
2851 void
2852 Perl_dump_fds(pTHX_ const char *const s)
2853 {
2854     int fd;
2855     Stat_t tmpstatbuf;
2856
2857     PERL_ARGS_ASSERT_DUMP_FDS;
2858
2859     PerlIO_printf(Perl_debug_log,"%s", s);
2860     for (fd = 0; fd < 32; fd++) {
2861         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2862             PerlIO_printf(Perl_debug_log," %d",fd);
2863     }
2864     PerlIO_printf(Perl_debug_log,"\n");
2865     return;
2866 }
2867 #endif  /* DUMP_FDS */
2868
2869 #ifndef HAS_DUP2
2870 int
2871 dup2(int oldfd, int newfd)
2872 {
2873 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2874     if (oldfd == newfd)
2875         return oldfd;
2876     PerlLIO_close(newfd);
2877     return fcntl(oldfd, F_DUPFD, newfd);
2878 #else
2879 #define DUP2_MAX_FDS 256
2880     int fdtmp[DUP2_MAX_FDS];
2881     I32 fdx = 0;
2882     int fd;
2883
2884     if (oldfd == newfd)
2885         return oldfd;
2886     PerlLIO_close(newfd);
2887     /* good enough for low fd's... */
2888     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2889         if (fdx >= DUP2_MAX_FDS) {
2890             PerlLIO_close(fd);
2891             fd = -1;
2892             break;
2893         }
2894         fdtmp[fdx++] = fd;
2895     }
2896     while (fdx > 0)
2897         PerlLIO_close(fdtmp[--fdx]);
2898     return fd;
2899 #endif
2900 }
2901 #endif
2902
2903 #ifndef PERL_MICRO
2904 #ifdef HAS_SIGACTION
2905
2906 Sighandler_t
2907 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2908 {
2909     dVAR;
2910     struct sigaction act, oact;
2911
2912 #ifdef USE_ITHREADS
2913     /* only "parent" interpreter can diddle signals */
2914     if (PL_curinterp != aTHX)
2915         return (Sighandler_t) SIG_ERR;
2916 #endif
2917
2918     act.sa_handler = (void(*)(int))handler;
2919     sigemptyset(&act.sa_mask);
2920     act.sa_flags = 0;
2921 #ifdef SA_RESTART
2922     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2923         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2924 #endif
2925 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2926     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2927         act.sa_flags |= SA_NOCLDWAIT;
2928 #endif
2929     if (sigaction(signo, &act, &oact) == -1)
2930         return (Sighandler_t) SIG_ERR;
2931     else
2932         return (Sighandler_t) oact.sa_handler;
2933 }
2934
2935 Sighandler_t
2936 Perl_rsignal_state(pTHX_ int signo)
2937 {
2938     struct sigaction oact;
2939     PERL_UNUSED_CONTEXT;
2940
2941     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2942         return (Sighandler_t) SIG_ERR;
2943     else
2944         return (Sighandler_t) oact.sa_handler;
2945 }
2946
2947 int
2948 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2949 {
2950     dVAR;
2951     struct sigaction act;
2952
2953     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2954
2955 #ifdef USE_ITHREADS
2956     /* only "parent" interpreter can diddle signals */
2957     if (PL_curinterp != aTHX)
2958         return -1;
2959 #endif
2960
2961     act.sa_handler = (void(*)(int))handler;
2962     sigemptyset(&act.sa_mask);
2963     act.sa_flags = 0;
2964 #ifdef SA_RESTART
2965     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2966         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2967 #endif
2968 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2969     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2970         act.sa_flags |= SA_NOCLDWAIT;
2971 #endif
2972     return sigaction(signo, &act, save);
2973 }
2974
2975 int
2976 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2977 {
2978     dVAR;
2979 #ifdef USE_ITHREADS
2980     /* only "parent" interpreter can diddle signals */
2981     if (PL_curinterp != aTHX)
2982         return -1;
2983 #endif
2984
2985     return sigaction(signo, save, (struct sigaction *)NULL);
2986 }
2987
2988 #else /* !HAS_SIGACTION */
2989
2990 Sighandler_t
2991 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2992 {
2993 #if defined(USE_ITHREADS) && !defined(WIN32)
2994     /* only "parent" interpreter can diddle signals */
2995     if (PL_curinterp != aTHX)
2996         return (Sighandler_t) SIG_ERR;
2997 #endif
2998
2999     return PerlProc_signal(signo, handler);
3000 }
3001
3002 static Signal_t
3003 sig_trap(int signo)
3004 {
3005     dVAR;
3006     PL_sig_trapped++;
3007 }
3008
3009 Sighandler_t
3010 Perl_rsignal_state(pTHX_ int signo)
3011 {
3012     dVAR;
3013     Sighandler_t oldsig;
3014
3015 #if defined(USE_ITHREADS) && !defined(WIN32)
3016     /* only "parent" interpreter can diddle signals */
3017     if (PL_curinterp != aTHX)
3018         return (Sighandler_t) SIG_ERR;
3019 #endif
3020
3021     PL_sig_trapped = 0;
3022     oldsig = PerlProc_signal(signo, sig_trap);
3023     PerlProc_signal(signo, oldsig);
3024     if (PL_sig_trapped)
3025         PerlProc_kill(PerlProc_getpid(), signo);
3026     return oldsig;
3027 }
3028
3029 int
3030 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3031 {
3032 #if defined(USE_ITHREADS) && !defined(WIN32)
3033     /* only "parent" interpreter can diddle signals */
3034     if (PL_curinterp != aTHX)
3035         return -1;
3036 #endif
3037     *save = PerlProc_signal(signo, handler);
3038     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3039 }
3040
3041 int
3042 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3043 {
3044 #if defined(USE_ITHREADS) && !defined(WIN32)
3045     /* only "parent" interpreter can diddle signals */
3046     if (PL_curinterp != aTHX)
3047         return -1;
3048 #endif
3049     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3050 }
3051
3052 #endif /* !HAS_SIGACTION */
3053 #endif /* !PERL_MICRO */
3054
3055     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3056 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
3057 I32
3058 Perl_my_pclose(pTHX_ PerlIO *ptr)
3059 {
3060     dVAR;
3061     Sigsave_t hstat, istat, qstat;
3062     int status;
3063     SV **svp;
3064     Pid_t pid;
3065     Pid_t pid2 = 0;
3066     bool close_failed;
3067     dSAVEDERRNO;
3068     const int fd = PerlIO_fileno(ptr);
3069
3070 #ifdef USE_PERLIO
3071     /* Find out whether the refcount is low enough for us to wait for the
3072        child proc without blocking. */
3073     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3074 #else
3075     const bool should_wait = 1;
3076 #endif
3077
3078     svp = av_fetch(PL_fdpid,fd,TRUE);
3079     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3080     SvREFCNT_dec(*svp);
3081     *svp = &PL_sv_undef;
3082 #ifdef OS2
3083     if (pid == -1) {                    /* Opened by popen. */
3084         return my_syspclose(ptr);
3085     }
3086 #endif
3087     close_failed = (PerlIO_close(ptr) == EOF);
3088     SAVE_ERRNO;
3089 #ifndef PERL_MICRO
3090     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
3091     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
3092     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3093 #endif
3094     if (should_wait) do {
3095         pid2 = wait4pid(pid, &status, 0);
3096     } while (pid2 == -1 && errno == EINTR);
3097 #ifndef PERL_MICRO
3098     rsignal_restore(SIGHUP, &hstat);
3099     rsignal_restore(SIGINT, &istat);
3100     rsignal_restore(SIGQUIT, &qstat);
3101 #endif
3102     if (close_failed) {
3103         RESTORE_ERRNO;
3104         return -1;
3105     }
3106     return(
3107       should_wait
3108        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3109        : 0
3110     );
3111 }
3112 #else
3113 #if defined(__LIBCATAMOUNT__)
3114 I32
3115 Perl_my_pclose(pTHX_ PerlIO *ptr)
3116 {
3117     return -1;
3118 }
3119 #endif
3120 #endif /* !DOSISH */
3121
3122 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3123 I32
3124 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3125 {
3126     dVAR;
3127     I32 result = 0;
3128     PERL_ARGS_ASSERT_WAIT4PID;
3129     if (!pid)
3130         return -1;
3131 #ifdef PERL_USES_PL_PIDSTATUS
3132     {
3133         if (pid > 0) {
3134             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3135                pid, rather than a string form.  */
3136             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3137             if (svp && *svp != &PL_sv_undef) {
3138                 *statusp = SvIVX(*svp);
3139                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3140                                 G_DISCARD);
3141                 return pid;
3142             }
3143         }
3144         else {
3145             HE *entry;
3146
3147             hv_iterinit(PL_pidstatus);
3148             if ((entry = hv_iternext(PL_pidstatus))) {
3149                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3150                 I32 len;
3151                 const char * const spid = hv_iterkey(entry,&len);
3152
3153                 assert (len == sizeof(Pid_t));
3154                 memcpy((char *)&pid, spid, len);
3155                 *statusp = SvIVX(sv);
3156                 /* The hash iterator is currently on this entry, so simply
3157                    calling hv_delete would trigger the lazy delete, which on
3158                    aggregate does more work, beacuse next call to hv_iterinit()
3159                    would spot the flag, and have to call the delete routine,
3160                    while in the meantime any new entries can't re-use that
3161                    memory.  */
3162                 hv_iterinit(PL_pidstatus);
3163                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3164                 return pid;
3165             }
3166         }
3167     }
3168 #endif
3169 #ifdef HAS_WAITPID
3170 #  ifdef HAS_WAITPID_RUNTIME
3171     if (!HAS_WAITPID_RUNTIME)
3172         goto hard_way;
3173 #  endif
3174     result = PerlProc_waitpid(pid,statusp,flags);
3175     goto finish;
3176 #endif
3177 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3178     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3179     goto finish;
3180 #endif
3181 #ifdef PERL_USES_PL_PIDSTATUS
3182 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3183   hard_way:
3184 #endif
3185     {
3186         if (flags)
3187             Perl_croak(aTHX_ "Can't do waitpid with flags");
3188         else {
3189             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3190                 pidgone(result,*statusp);
3191             if (result < 0)
3192                 *statusp = -1;
3193         }
3194     }
3195 #endif
3196 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3197   finish:
3198 #endif
3199     if (result < 0 && errno == EINTR) {
3200         PERL_ASYNC_CHECK();
3201         errno = EINTR; /* reset in case a signal handler changed $! */
3202     }
3203     return result;
3204 }
3205 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3206
3207 #ifdef PERL_USES_PL_PIDSTATUS
3208 void
3209 S_pidgone(pTHX_ Pid_t pid, int status)
3210 {
3211     SV *sv;
3212
3213     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3214     SvUPGRADE(sv,SVt_IV);
3215     SvIV_set(sv, status);
3216     return;
3217 }
3218 #endif
3219
3220 #if defined(OS2)
3221 int pclose();
3222 #ifdef HAS_FORK
3223 int                                     /* Cannot prototype with I32
3224                                            in os2ish.h. */
3225 my_syspclose(PerlIO *ptr)
3226 #else
3227 I32
3228 Perl_my_pclose(pTHX_ PerlIO *ptr)
3229 #endif
3230 {
3231     /* Needs work for PerlIO ! */
3232     FILE * const f = PerlIO_findFILE(ptr);
3233     const I32 result = pclose(f);
3234     PerlIO_releaseFILE(ptr,f);
3235     return result;
3236 }
3237 #endif
3238
3239 #if defined(DJGPP)
3240 int djgpp_pclose();
3241 I32
3242 Perl_my_pclose(pTHX_ PerlIO *ptr)
3243 {
3244     /* Needs work for PerlIO ! */
3245     FILE * const f = PerlIO_findFILE(ptr);
3246     I32 result = djgpp_pclose(f);
3247     result = (result << 8) & 0xff00;
3248     PerlIO_releaseFILE(ptr,f);
3249     return result;
3250 }
3251 #endif
3252
3253 #define PERL_REPEATCPY_LINEAR 4
3254 void
3255 Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
3256 {
3257     PERL_ARGS_ASSERT_REPEATCPY;
3258
3259     assert(len >= 0);
3260
3261     if (count < 0)
3262         croak_memory_wrap();
3263
3264     if (len == 1)
3265         memset(to, *from, count);
3266     else if (count) {
3267         char *p = to;
3268         IV items, linear, half;
3269
3270         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3271         for (items = 0; items < linear; ++items) {
3272             const char *q = from;
3273             IV todo;
3274             for (todo = len; todo > 0; todo--)
3275                 *p++ = *q++;
3276         }
3277
3278         half = count / 2;
3279         while (items <= half) {
3280             IV size = items * len;
3281             memcpy(p, to, size);
3282             p     += size;
3283             items *= 2;
3284         }
3285
3286         if (count > items)
3287             memcpy(p, to, (count - items) * len);
3288     }
3289 }
3290
3291 #ifndef HAS_RENAME
3292 I32
3293 Perl_same_dirent(pTHX_ const char *a, const char *b)
3294 {
3295     char *fa = strrchr(a,'/');
3296     char *fb = strrchr(b,'/');
3297     Stat_t tmpstatbuf1;
3298     Stat_t tmpstatbuf2;
3299     SV * const tmpsv = sv_newmortal();
3300
3301     PERL_ARGS_ASSERT_SAME_DIRENT;
3302
3303     if (fa)
3304         fa++;
3305     else
3306         fa = a;
3307     if (fb)
3308         fb++;
3309     else
3310         fb = b;
3311     if (strNE(a,b))
3312         return FALSE;
3313     if (fa == a)
3314         sv_setpvs(tmpsv, ".");
3315     else
3316         sv_setpvn(tmpsv, a, fa - a);
3317     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3318         return FALSE;
3319     if (fb == b)
3320         sv_setpvs(tmpsv, ".");
3321     else
3322         sv_setpvn(tmpsv, b, fb - b);
3323     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3324         return FALSE;
3325     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3326            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3327 }
3328 #endif /* !HAS_RENAME */
3329
3330 char*
3331 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3332                  const char *const *const search_ext, I32 flags)
3333 {
3334     dVAR;
3335     const char *xfound = NULL;
3336     char *xfailed = NULL;
3337     char tmpbuf[MAXPATHLEN];
3338     char *s;
3339     I32 len = 0;
3340     int retval;
3341     char *bufend;
3342 #if defined(DOSISH) && !defined(OS2)
3343 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3344 #  define MAX_EXT_LEN 4
3345 #endif
3346 #ifdef OS2
3347 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3348 #  define MAX_EXT_LEN 4
3349 #endif
3350 #ifdef VMS
3351 #  define SEARCH_EXTS ".pl", ".com", NULL
3352 #  define MAX_EXT_LEN 4
3353 #endif
3354     /* additional extensions to try in each dir if scriptname not found */
3355 #ifdef SEARCH_EXTS
3356     static const char *const exts[] = { SEARCH_EXTS };
3357     const char *const *const ext = search_ext ? search_ext : exts;
3358     int extidx = 0, i = 0;
3359     const char *curext = NULL;
3360 #else
3361     PERL_UNUSED_ARG(search_ext);
3362 #  define MAX_EXT_LEN 0
3363 #endif
3364
3365     PERL_ARGS_ASSERT_FIND_SCRIPT;
3366
3367     /*
3368      * If dosearch is true and if scriptname does not contain path
3369      * delimiters, search the PATH for scriptname.
3370      *
3371      * If SEARCH_EXTS is also defined, will look for each
3372      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3373      * while searching the PATH.
3374      *
3375      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3376      * proceeds as follows:
3377      *   If DOSISH or VMSISH:
3378      *     + look for ./scriptname{,.foo,.bar}
3379      *     + search the PATH for scriptname{,.foo,.bar}
3380      *
3381      *   If !DOSISH:
3382      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3383      *       this will not look in '.' if it's not in the PATH)
3384      */
3385     tmpbuf[0] = '\0';
3386
3387 #ifdef VMS
3388 #  ifdef ALWAYS_DEFTYPES
3389     len = strlen(scriptname);
3390     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3391         int idx = 0, deftypes = 1;
3392         bool seen_dot = 1;
3393
3394         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3395 #  else
3396     if (dosearch) {
3397         int idx = 0, deftypes = 1;
3398         bool seen_dot = 1;
3399
3400         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3401 #  endif
3402         /* The first time through, just add SEARCH_EXTS to whatever we
3403          * already have, so we can check for default file types. */
3404         while (deftypes ||
3405                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3406         {
3407             if (deftypes) {
3408                 deftypes = 0;
3409                 *tmpbuf = '\0';
3410             }
3411             if ((strlen(tmpbuf) + strlen(scriptname)
3412                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3413                 continue;       /* don't search dir with too-long name */
3414             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3415 #else  /* !VMS */
3416
3417 #ifdef DOSISH
3418     if (strEQ(scriptname, "-"))
3419         dosearch = 0;
3420     if (dosearch) {             /* Look in '.' first. */
3421         const char *cur = scriptname;
3422 #ifdef SEARCH_EXTS
3423         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3424             while (ext[i])
3425                 if (strEQ(ext[i++],curext)) {
3426                     extidx = -1;                /* already has an ext */
3427                     break;
3428                 }
3429         do {
3430 #endif
3431             DEBUG_p(PerlIO_printf(Perl_debug_log,
3432                                   "Looking for %s\n",cur));
3433             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3434                 && !S_ISDIR(PL_statbuf.st_mode)) {
3435                 dosearch = 0;
3436                 scriptname = cur;
3437 #ifdef SEARCH_EXTS
3438                 break;
3439 #endif
3440             }
3441 #ifdef SEARCH_EXTS
3442             if (cur == scriptname) {
3443                 len = strlen(scriptname);
3444                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3445                     break;
3446                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3447                 cur = tmpbuf;
3448             }
3449         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3450                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3451 #endif
3452     }
3453 #endif
3454
3455     if (dosearch && !strchr(scriptname, '/')
3456 #ifdef DOSISH
3457                  && !strchr(scriptname, '\\')
3458 #endif
3459                  && (s = PerlEnv_getenv("PATH")))
3460     {
3461         bool seen_dot = 0;
3462
3463         bufend = s + strlen(s);
3464         while (s < bufend) {
3465 #  ifdef DOSISH
3466             for (len = 0; *s
3467                     && *s != ';'; len++, s++) {
3468                 if (len < sizeof tmpbuf)
3469                     tmpbuf[len] = *s;
3470             }
3471             if (len < sizeof tmpbuf)
3472                 tmpbuf[len] = '\0';
3473 #  else
3474             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3475                         ':',
3476                         &len);
3477 #  endif
3478             if (s < bufend)
3479                 s++;
3480             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3481                 continue;       /* don't search dir with too-long name */
3482             if (len
3483 #  ifdef DOSISH
3484                 && tmpbuf[len - 1] != '/'
3485                 && tmpbuf[len - 1] != '\\'
3486 #  endif
3487                )
3488                 tmpbuf[len++] = '/';
3489             if (len == 2 && tmpbuf[0] == '.')
3490                 seen_dot = 1;
3491             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3492 #endif  /* !VMS */
3493
3494 #ifdef SEARCH_EXTS
3495             len = strlen(tmpbuf);
3496             if (extidx > 0)     /* reset after previous loop */
3497                 extidx = 0;
3498             do {
3499 #endif
3500                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3501                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3502                 if (S_ISDIR(PL_statbuf.st_mode)) {
3503                     retval = -1;
3504                 }
3505 #ifdef SEARCH_EXTS
3506             } while (  retval < 0               /* not there */
3507                     && extidx>=0 && ext[extidx] /* try an extension? */
3508                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3509                 );
3510 #endif
3511             if (retval < 0)
3512                 continue;
3513             if (S_ISREG(PL_statbuf.st_mode)
3514                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3515 #if !defined(DOSISH)
3516                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3517 #endif
3518                 )
3519             {
3520                 xfound = tmpbuf;                /* bingo! */
3521                 break;
3522             }
3523             if (!xfailed)
3524                 xfailed = savepv(tmpbuf);
3525         }
3526 #ifndef DOSISH
3527         if (!xfound && !seen_dot && !xfailed &&
3528             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3529              || S_ISDIR(PL_statbuf.st_mode)))
3530 #endif
3531             seen_dot = 1;                       /* Disable message. */
3532         if (!xfound) {
3533             if (flags & 1) {                    /* do or die? */
3534                 /* diag_listed_as: Can't execute %s */
3535                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3536                       (xfailed ? "execute" : "find"),
3537                       (xfailed ? xfailed : scriptname),
3538                       (xfailed ? "" : " on PATH"),
3539                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3540             }
3541             scriptname = NULL;
3542         }
3543         Safefree(xfailed);
3544         scriptname = xfound;
3545     }
3546     return (scriptname ? savepv(scriptname) : NULL);
3547 }
3548
3549 #ifndef PERL_GET_CONTEXT_DEFINED
3550
3551 void *
3552 Perl_get_context(void)
3553 {
3554     dVAR;
3555 #if defined(USE_ITHREADS)
3556 #  ifdef OLD_PTHREADS_API
3557     pthread_addr_t t;
3558     int error = pthread_getspecific(PL_thr_key, &t)
3559     if (error)
3560         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3561     return (void*)t;
3562 #  else
3563 #    ifdef I_MACH_CTHREADS
3564     return (void*)cthread_data(cthread_self());
3565 #    else
3566     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3567 #    endif
3568 #  endif
3569 #else
3570     return (void*)NULL;
3571 #endif
3572 }
3573
3574 void
3575 Perl_set_context(void *t)
3576 {
3577     dVAR;
3578     PERL_ARGS_ASSERT_SET_CONTEXT;
3579 #if defined(USE_ITHREADS)
3580 #  ifdef I_MACH_CTHREADS
3581     cthread_set_data(cthread_self(), t);
3582 #  else
3583     {
3584         const int error = pthread_setspecific(PL_thr_key, t);
3585         if (error)
3586             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3587     }
3588 #  endif
3589 #else
3590     PERL_UNUSED_ARG(t);
3591 #endif
3592 }
3593
3594 #endif /* !PERL_GET_CONTEXT_DEFINED */
3595
3596 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3597 struct perl_vars *
3598 Perl_GetVars(pTHX)
3599 {
3600  return &PL_Vars;
3601 }
3602 #endif
3603
3604 char **
3605 Perl_get_op_names(pTHX)
3606 {
3607     PERL_UNUSED_CONTEXT;
3608     return (char **)PL_op_name;
3609 }
3610
3611 char **
3612 Perl_get_op_descs(pTHX)
3613 {
3614     PERL_UNUSED_CONTEXT;
3615     return (char **)PL_op_desc;
3616 }
3617
3618 const char *
3619 Perl_get_no_modify(pTHX)
3620 {
3621     PERL_UNUSED_CONTEXT;
3622     return PL_no_modify;
3623 }
3624
3625 U32 *
3626 Perl_get_opargs(pTHX)
3627 {
3628     PERL_UNUSED_CONTEXT;
3629     return (U32 *)PL_opargs;
3630 }
3631
3632 PPADDR_t*
3633 Perl_get_ppaddr(pTHX)
3634 {
3635     dVAR;
3636     PERL_UNUSED_CONTEXT;
3637     return (PPADDR_t*)PL_ppaddr;
3638 }
3639
3640 #ifndef HAS_GETENV_LEN
3641 char *
3642 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3643 {
3644     char * const env_trans = PerlEnv_getenv(env_elem);
3645     PERL_UNUSED_CONTEXT;
3646     PERL_ARGS_ASSERT_GETENV_LEN;
3647     if (env_trans)
3648         *len = strlen(env_trans);
3649     return env_trans;
3650 }
3651 #endif
3652
3653
3654 MGVTBL*
3655 Perl_get_vtbl(pTHX_ int vtbl_id)
3656 {
3657     PERL_UNUSED_CONTEXT;
3658
3659     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3660         ? NULL : PL_magic_vtables + vtbl_id;
3661 }
3662
3663 I32
3664 Perl_my_fflush_all(pTHX)
3665 {
3666 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3667     return PerlIO_flush(NULL);
3668 #else
3669 # if defined(HAS__FWALK)
3670     extern int fflush(FILE *);
3671     /* undocumented, unprototyped, but very useful BSDism */
3672     extern void _fwalk(int (*)(FILE *));
3673     _fwalk(&fflush);
3674     return 0;
3675 # else
3676 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3677     long open_max = -1;
3678 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3679     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3680 #   else
3681 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3682     open_max = sysconf(_SC_OPEN_MAX);
3683 #     else
3684 #      ifdef FOPEN_MAX
3685     open_max = FOPEN_MAX;
3686 #      else
3687 #       ifdef OPEN_MAX
3688     open_max = OPEN_MAX;
3689 #       else
3690 #        ifdef _NFILE
3691     open_max = _NFILE;
3692 #        endif
3693 #       endif
3694 #      endif
3695 #     endif
3696 #    endif
3697     if (open_max > 0) {
3698       long i;
3699       for (i = 0; i < open_max; i++)
3700             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3701                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3702                 STDIO_STREAM_ARRAY[i]._flag)
3703                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3704       return 0;
3705     }
3706 #  endif
3707     SETERRNO(EBADF,RMS_IFI);
3708     return EOF;
3709 # endif
3710 #endif
3711 }
3712
3713 void
3714 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3715 {
3716     if (ckWARN(WARN_IO)) {
3717         HEK * const name
3718            = gv && (isGV_with_GP(gv))
3719                 ? GvENAME_HEK((gv))
3720                 : NULL;
3721         const char * const direction = have == '>' ? "out" : "in";
3722
3723         if (name && HEK_LEN(name))
3724             Perl_warner(aTHX_ packWARN(WARN_IO),
3725                         "Filehandle %"HEKf" opened only for %sput",
3726                         name, direction);
3727         else
3728             Perl_warner(aTHX_ packWARN(WARN_IO),
3729                         "Filehandle opened only for %sput", direction);
3730     }
3731 }
3732
3733 void
3734 Perl_report_evil_fh(pTHX_ const GV *gv)
3735 {
3736     const IO *io = gv ? GvIO(gv) : NULL;
3737     const PERL_BITFIELD16 op = PL_op->op_type;
3738     const char *vile;
3739     I32 warn_type;
3740
3741     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3742         vile = "closed";
3743         warn_type = WARN_CLOSED;
3744     }
3745     else {
3746         vile = "unopened";
3747         warn_type = WARN_UNOPENED;
3748     }
3749
3750     if (ckWARN(warn_type)) {
3751         SV * const name
3752             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3753                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3754         const char * const pars =
3755             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3756         const char * const func =
3757             (const char *)
3758             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3759              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3760              PL_op_desc[op]);
3761         const char * const type =
3762             (const char *)
3763             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3764              ? "socket" : "filehandle");
3765         const bool have_name = name && SvCUR(name);
3766         Perl_warner(aTHX_ packWARN(warn_type),
3767                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3768                     have_name ? " " : "",
3769                     SVfARG(have_name ? name : &PL_sv_no));
3770         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3771                 Perl_warner(
3772                             aTHX_ packWARN(warn_type),
3773                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3774                         func, pars, have_name ? " " : "",
3775                         SVfARG(have_name ? name : &PL_sv_no)
3776                             );
3777     }
3778 }
3779
3780 /* To workaround core dumps from the uninitialised tm_zone we get the
3781  * system to give us a reasonable struct to copy.  This fix means that
3782  * strftime uses the tm_zone and tm_gmtoff values returned by
3783  * localtime(time()). That should give the desired result most of the
3784  * time. But probably not always!
3785  *
3786  * This does not address tzname aspects of NETaa14816.
3787  *
3788  */
3789
3790 #ifdef HAS_GNULIBC
3791 # ifndef STRUCT_TM_HASZONE
3792 #    define STRUCT_TM_HASZONE
3793 # endif
3794 #endif
3795
3796 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3797 # ifndef HAS_TM_TM_ZONE
3798 #    define HAS_TM_TM_ZONE
3799 # endif
3800 #endif
3801
3802 void
3803 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3804 {
3805 #ifdef HAS_TM_TM_ZONE
3806     Time_t now;
3807     const struct tm* my_tm;
3808     PERL_ARGS_ASSERT_INIT_TM;
3809     (void)time(&now);
3810     my_tm = localtime(&now);
3811     if (my_tm)
3812         Copy(my_tm, ptm, 1, struct tm);
3813 #else
3814     PERL_ARGS_ASSERT_INIT_TM;
3815     PERL_UNUSED_ARG(ptm);
3816 #endif
3817 }
3818
3819 /*
3820  * mini_mktime - normalise struct tm values without the localtime()
3821  * semantics (and overhead) of mktime().
3822  */
3823 void
3824 Perl_mini_mktime(pTHX_ struct tm *ptm)
3825 {
3826     int yearday;
3827     int secs;
3828     int month, mday, year, jday;
3829     int odd_cent, odd_year;
3830     PERL_UNUSED_CONTEXT;
3831
3832     PERL_ARGS_ASSERT_MINI_MKTIME;
3833
3834 #define DAYS_PER_YEAR   365
3835 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3836 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3837 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3838 #define SECS_PER_HOUR   (60*60)
3839 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3840 /* parentheses deliberately absent on these two, otherwise they don't work */
3841 #define MONTH_TO_DAYS   153/5
3842 #define DAYS_TO_MONTH   5/153
3843 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3844 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3845 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3846 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3847
3848 /*
3849  * Year/day algorithm notes:
3850  *
3851  * With a suitable offset for numeric value of the month, one can find
3852  * an offset into the year by considering months to have 30.6 (153/5) days,
3853  * using integer arithmetic (i.e., with truncation).  To avoid too much
3854  * messing about with leap days, we consider January and February to be
3855  * the 13th and 14th month of the previous year.  After that transformation,
3856  * we need the month index we use to be high by 1 from 'normal human' usage,
3857  * so the month index values we use run from 4 through 15.
3858  *
3859  * Given that, and the rules for the Gregorian calendar (leap years are those
3860  * divisible by 4 unless also divisible by 100, when they must be divisible
3861  * by 400 instead), we can simply calculate the number of days since some
3862  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3863  * the days we derive from our month index, and adding in the day of the
3864  * month.  The value used here is not adjusted for the actual origin which
3865  * it normally would use (1 January A.D. 1), since we're not exposing it.
3866  * We're only building the value so we can turn around and get the
3867  * normalised values for the year, month, day-of-month, and day-of-year.
3868  *
3869  * For going backward, we need to bias the value we're using so that we find
3870  * the right year value.  (Basically, we don't want the contribution of
3871  * March 1st to the number to apply while deriving the year).  Having done
3872  * that, we 'count up' the contribution to the year number by accounting for
3873  * full quadracenturies (400-year periods) with their extra leap days, plus
3874  * the contribution from full centuries (to avoid counting in the lost leap
3875  * days), plus the contribution from full quad-years (to count in the normal
3876  * leap days), plus the leftover contribution from any non-leap years.
3877  * At this point, if we were working with an actual leap day, we'll have 0
3878  * days left over.  This is also true for March 1st, however.  So, we have
3879  * to special-case that result, and (earlier) keep track of the 'odd'
3880  * century and year contributions.  If we got 4 extra centuries in a qcent,
3881  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3882  * Otherwise, we add back in the earlier bias we removed (the 123 from
3883  * figuring in March 1st), find the month index (integer division by 30.6),
3884  * and the remainder is the day-of-month.  We then have to convert back to
3885  * 'real' months (including fixing January and February from being 14/15 in
3886  * the previous year to being in the proper year).  After that, to get
3887  * tm_yday, we work with the normalised year and get a new yearday value for
3888  * January 1st, which we subtract from the yearday value we had earlier,
3889  * representing the date we've re-built.  This is done from January 1
3890  * because tm_yday is 0-origin.
3891  *
3892  * Since POSIX time routines are only guaranteed to work for times since the
3893  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3894  * applies Gregorian calendar rules even to dates before the 16th century
3895  * doesn't bother me.  Besides, you'd need cultural context for a given
3896  * date to know whether it was Julian or Gregorian calendar, and that's
3897  * outside the scope for this routine.  Since we convert back based on the
3898  * same rules we used to build the yearday, you'll only get strange results
3899  * for input which needed normalising, or for the 'odd' century years which
3900  * were leap years in the Julian calendar but not in the Gregorian one.
3901  * I can live with that.
3902  *
3903  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3904  * that's still outside the scope for POSIX time manipulation, so I don't
3905  * care.
3906  */
3907
3908     year = 1900 + ptm->tm_year;
3909     month = ptm->tm_mon;
3910     mday = ptm->tm_mday;
3911     jday = 0;
3912     if (month >= 2)
3913         month+=2;
3914     else
3915         month+=14, year--;
3916     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3917     yearday += month*MONTH_TO_DAYS + mday + jday;
3918     /*
3919      * Note that we don't know when leap-seconds were or will be,
3920      * so we have to trust the user if we get something which looks
3921      * like a sensible leap-second.  Wild values for seconds will
3922      * be rationalised, however.
3923      */
3924     if ((unsigned) ptm->tm_sec <= 60) {
3925         secs = 0;
3926     }
3927     else {
3928         secs = ptm->tm_sec;
3929         ptm->tm_sec = 0;
3930     }
3931     secs += 60 * ptm->tm_min;
3932     secs += SECS_PER_HOUR * ptm->tm_hour;
3933     if (secs < 0) {
3934         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3935             /* got negative remainder, but need positive time */
3936             /* back off an extra day to compensate */
3937             yearday += (secs/SECS_PER_DAY)-1;
3938             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3939         }
3940         else {
3941             yearday += (secs/SECS_PER_DAY);
3942             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3943         }
3944     }
3945     else if (secs >= SECS_PER_DAY) {
3946         yearday += (secs/SECS_PER_DAY);
3947         secs %= SECS_PER_DAY;
3948     }
3949     ptm->tm_hour = secs/SECS_PER_HOUR;
3950     secs %= SECS_PER_HOUR;
3951     ptm->tm_min = secs/60;
3952     secs %= 60;
3953     ptm->tm_sec += secs;
3954     /* done with time of day effects */
3955     /*
3956      * The algorithm for yearday has (so far) left it high by 428.
3957      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3958      * bias it by 123 while trying to figure out what year it
3959      * really represents.  Even with this tweak, the reverse
3960      * translation fails for years before A.D. 0001.
3961      * It would still fail for Feb 29, but we catch that one below.
3962      */
3963     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3964     yearday -= YEAR_ADJUST;
3965     year = (yearday / DAYS_PER_QCENT) * 400;
3966     yearday %= DAYS_PER_QCENT;
3967     odd_cent = yearday / DAYS_PER_CENT;
3968     year += odd_cent * 100;
3969     yearday %= DAYS_PER_CENT;
3970     year += (yearday / DAYS_PER_QYEAR) * 4;
3971     yearday %= DAYS_PER_QYEAR;
3972     odd_year = yearday / DAYS_PER_YEAR;
3973     year += odd_year;
3974     yearday %= DAYS_PER_YEAR;
3975     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3976         month = 1;
3977         yearday = 29;
3978     }
3979     else {
3980         yearday += YEAR_ADJUST; /* recover March 1st crock */
3981         month = yearday*DAYS_TO_MONTH;
3982         yearday -= month*MONTH_TO_DAYS;
3983         /* recover other leap-year adjustment */
3984         if (month > 13) {
3985             month-=14;
3986             year++;
3987         }
3988         else {
3989             month-=2;
3990         }
3991     }
3992     ptm->tm_year = year - 1900;
3993     if (yearday) {
3994       ptm->tm_mday = yearday;
3995       ptm->tm_mon = month;
3996     }
3997     else {
3998       ptm->tm_mday = 31;
3999       ptm->tm_mon = month - 1;
4000     }
4001     /* re-build yearday based on Jan 1 to get tm_yday */
4002     year--;
4003     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4004     yearday += 14*MONTH_TO_DAYS + 1;
4005     ptm->tm_yday = jday - yearday;
4006     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4007 }
4008
4009 char *
4010 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)
4011 {
4012 #ifdef HAS_STRFTIME
4013   char *buf;
4014   int buflen;
4015   struct tm mytm;
4016   int len;
4017
4018   PERL_ARGS_ASSERT_MY_STRFTIME;
4019
4020   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4021   mytm.tm_sec = sec;
4022   mytm.tm_min = min;
4023   mytm.tm_hour = hour;
4024   mytm.tm_mday = mday;
4025   mytm.tm_mon = mon;
4026   mytm.tm_year = year;
4027   mytm.tm_wday = wday;
4028   mytm.tm_yday = yday;
4029   mytm.tm_isdst = isdst;
4030   mini_mktime(&mytm);
4031   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4032 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4033   STMT_START {
4034     struct tm mytm2;
4035     mytm2 = mytm;
4036     mktime(&mytm2);
4037 #ifdef HAS_TM_TM_GMTOFF
4038     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4039 #endif
4040 #ifdef HAS_TM_TM_ZONE
4041     mytm.tm_zone = mytm2.tm_zone;
4042 #endif
4043   } STMT_END;
4044 #endif
4045   buflen = 64;
4046   Newx(buf, buflen, char);
4047   len = strftime(buf, buflen, fmt, &mytm);
4048   /*
4049   ** The following is needed to handle to the situation where
4050   ** tmpbuf overflows.  Basically we want to allocate a buffer
4051   ** and try repeatedly.  The reason why it is so complicated
4052   ** is that getting a return value of 0 from strftime can indicate
4053   ** one of the following:
4054   ** 1. buffer overflowed,
4055   ** 2. illegal conversion specifier, or
4056   ** 3. the format string specifies nothing to be returned(not
4057   **      an error).  This could be because format is an empty string
4058   **    or it specifies %p that yields an empty string in some locale.
4059   ** If there is a better way to make it portable, go ahead by
4060   ** all means.
4061   */
4062   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4063     return buf;
4064   else {
4065     /* Possibly buf overflowed - try again with a bigger buf */
4066     const int fmtlen = strlen(fmt);
4067     int bufsize = fmtlen + buflen;
4068
4069     Renew(buf, bufsize, char);
4070     while (buf) {
4071       buflen = strftime(buf, bufsize, fmt, &mytm);
4072       if (buflen > 0 && buflen < bufsize)
4073         break;
4074       /* heuristic to prevent out-of-memory errors */
4075       if (bufsize > 100*fmtlen) {
4076         Safefree(buf);
4077         buf = NULL;
4078         break;
4079       }
4080       bufsize *= 2;
4081       Renew(buf, bufsize, char);
4082     }
4083     return buf;
4084   }
4085 #else
4086   Perl_croak(aTHX_ "panic: no strftime");
4087   return NULL;
4088 #endif
4089 }
4090
4091
4092 #define SV_CWD_RETURN_UNDEF \
4093 sv_setsv(sv, &PL_sv_undef); \
4094 return FALSE
4095
4096 #define SV_CWD_ISDOT(dp) \
4097     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4098         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4099
4100 /*
4101 =head1 Miscellaneous Functions
4102
4103 =for apidoc getcwd_sv
4104
4105 Fill the sv with current working directory
4106
4107 =cut
4108 */
4109
4110 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4111  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4112  * getcwd(3) if available
4113  * Comments from the orignal:
4114  *     This is a faster version of getcwd.  It's also more dangerous
4115  *     because you might chdir out of a directory that you can't chdir
4116  *     back into. */
4117
4118 int
4119 Perl_getcwd_sv(pTHX_ SV *sv)
4120 {
4121 #ifndef PERL_MICRO
4122     dVAR;
4123 #ifndef INCOMPLETE_TAINTS
4124     SvTAINTED_on(sv);
4125 #endif
4126
4127     PERL_ARGS_ASSERT_GETCWD_SV;
4128
4129 #ifdef HAS_GETCWD
4130     {
4131         char buf[MAXPATHLEN];
4132
4133         /* Some getcwd()s automatically allocate a buffer of the given
4134          * size from the heap if they are given a NULL buffer pointer.
4135          * The problem is that this behaviour is not portable. */
4136         if (getcwd(buf, sizeof(buf) - 1)) {
4137             sv_setpv(sv, buf);
4138             return TRUE;
4139         }
4140         else {
4141             sv_setsv(sv, &PL_sv_undef);
4142             return FALSE;
4143         }
4144     }
4145
4146 #else
4147
4148     Stat_t statbuf;
4149     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4150     int pathlen=0;
4151     Direntry_t *dp;
4152
4153     SvUPGRADE(sv, SVt_PV);
4154
4155     if (PerlLIO_lstat(".", &statbuf) < 0) {
4156         SV_CWD_RETURN_UNDEF;
4157     }
4158
4159     orig_cdev = statbuf.st_dev;
4160     orig_cino = statbuf.st_ino;
4161     cdev = orig_cdev;
4162     cino = orig_cino;
4163
4164     for (;;) {
4165         DIR *dir;
4166         int namelen;
4167         odev = cdev;
4168         oino = cino;
4169
4170         if (PerlDir_chdir("..") < 0) {
4171             SV_CWD_RETURN_UNDEF;
4172         }
4173         if (PerlLIO_stat(".", &statbuf) < 0) {
4174             SV_CWD_RETURN_UNDEF;
4175         }
4176
4177         cdev = statbuf.st_dev;
4178         cino = statbuf.st_ino;
4179
4180         if (odev == cdev && oino == cino) {
4181             break;
4182         }
4183         if (!(dir = PerlDir_open("."))) {
4184             SV_CWD_RETURN_UNDEF;
4185         }
4186
4187         while ((dp = PerlDir_read(dir)) != NULL) {
4188 #ifdef DIRNAMLEN
4189             namelen = dp->d_namlen;
4190 #else
4191             namelen = strlen(dp->d_name);
4192 #endif
4193             /* skip . and .. */
4194             if (SV_CWD_ISDOT(dp)) {
4195                 continue;
4196             }
4197
4198             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4199                 SV_CWD_RETURN_UNDEF;
4200             }
4201
4202             tdev = statbuf.st_dev;
4203             tino = statbuf.st_ino;
4204             if (tino == oino && tdev == odev) {
4205                 break;
4206             }
4207         }
4208
4209         if (!dp) {
4210             SV_CWD_RETURN_UNDEF;
4211         }
4212
4213         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4214             SV_CWD_RETURN_UNDEF;
4215         }
4216
4217         SvGROW(sv, pathlen + namelen + 1);
4218
4219         if (pathlen) {
4220             /* shift down */
4221             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4222         }
4223
4224         /* prepend current directory to the front */
4225         *SvPVX(sv) = '/';
4226         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4227         pathlen += (namelen + 1);
4228
4229 #ifdef VOID_CLOSEDIR
4230         PerlDir_close(dir);
4231 #else
4232         if (PerlDir_close(dir) < 0) {
4233             SV_CWD_RETURN_UNDEF;
4234         }
4235 #endif
4236     }
4237
4238     if (pathlen) {
4239         SvCUR_set(sv, pathlen);
4240         *SvEND(sv) = '\0';
4241         SvPOK_only(sv);
4242
4243         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4244             SV_CWD_RETURN_UNDEF;
4245         }
4246     }
4247     if (PerlLIO_stat(".", &statbuf) < 0) {
4248         SV_CWD_RETURN_UNDEF;
4249     }
4250
4251     cdev = statbuf.st_dev;
4252     cino = statbuf.st_ino;
4253
4254     if (cdev != orig_cdev || cino != orig_cino) {
4255         Perl_croak(aTHX_ "Unstable directory path, "
4256                    "current directory changed unexpectedly");
4257     }
4258
4259     return TRUE;
4260 #endif
4261
4262 #else
4263     return FALSE;
4264 #endif
4265 }
4266
4267 #define VERSION_MAX 0x7FFFFFFF
4268
4269 /*
4270 =for apidoc prescan_version
4271
4272 Validate that a given string can be parsed as a version object, but doesn't
4273 actually perform the parsing.  Can use either strict or lax validation rules.
4274 Can optionally set a number of hint variables to save the parsing code
4275 some time when tokenizing.
4276
4277 =cut
4278 */
4279 const char *
4280 Perl_prescan_version(pTHX_ const char *s, bool strict,
4281                      const char **errstr,
4282                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4283     bool qv = (sqv ? *sqv : FALSE);
4284     int width = 3;
4285     int saw_decimal = 0;
4286     bool alpha = FALSE;
4287     const char *d = s;
4288
4289     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4290
4291     if (qv && isDIGIT(*d))
4292         goto dotted_decimal_version;
4293
4294     if (*d == 'v') { /* explicit v-string */
4295         d++;
4296         if (isDIGIT(*d)) {
4297             qv = TRUE;
4298         }
4299         else { /* degenerate v-string */
4300             /* requires v1.2.3 */
4301             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4302         }
4303
4304 dotted_decimal_version:
4305         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4306             /* no leading zeros allowed */
4307             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4308         }
4309
4310         while (isDIGIT(*d))     /* integer part */
4311             d++;
4312
4313         if (*d == '.')
4314         {
4315             saw_decimal++;
4316             d++;                /* decimal point */
4317         }
4318         else
4319         {
4320             if (strict) {
4321                 /* require v1.2.3 */
4322                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4323             }
4324             else {
4325                 goto version_prescan_finish;
4326             }
4327         }
4328
4329         {
4330             int i = 0;
4331             int j = 0;
4332             while (isDIGIT(*d)) {       /* just keep reading */
4333                 i++;
4334                 while (isDIGIT(*d)) {
4335                     d++; j++;
4336                     /* maximum 3 digits between decimal */
4337                     if (strict && j > 3) {
4338                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4339                     }
4340                 }
4341                 if (*d == '_') {
4342                     if (strict) {
4343                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4344                     }
4345                     if ( alpha ) {
4346                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4347                     }
4348                     d++;
4349                     alpha = TRUE;
4350                 }
4351                 else if (*d == '.') {
4352                     if (alpha) {
4353                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4354                     }
4355                     saw_decimal++;
4356                     d++;
4357                 }
4358                 else if (!isDIGIT(*d)) {
4359                     break;
4360                 }
4361                 j = 0;
4362             }
4363
4364             if (strict && i < 2) {
4365                 /* requires v1.2.3 */
4366                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4367             }
4368         }
4369     }                                   /* end if dotted-decimal */
4370     else
4371     {                                   /* decimal versions */
4372         int j = 0;                      /* may need this later */
4373         /* special strict case for leading '.' or '0' */
4374         if (strict) {
4375             if (*d == '.') {
4376                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4377             }
4378             if (*d == '0' && isDIGIT(d[1])) {
4379                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4380             }
4381         }
4382
4383         /* and we never support negative versions */
4384         if ( *d == '-') {
4385             BADVERSION(s,errstr,"Invalid version format (negative version number)");
4386         }
4387
4388         /* consume all of the integer part */
4389         while (isDIGIT(*d))
4390             d++;
4391
4392         /* look for a fractional part */
4393         if (*d == '.') {
4394             /* we found it, so consume it */
4395             saw_decimal++;
4396             d++;
4397         }
4398         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4399             if ( d == s ) {
4400                 /* found nothing */
4401                 BADVERSION(s,errstr,"Invalid version format (version required)");
4402             }
4403             /* found just an integer */
4404             goto version_prescan_finish;
4405         }
4406         else if ( d == s ) {
4407             /* didn't find either integer or period */
4408             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4409         }
4410         else if (*d == '_') {
4411             /* underscore can't come after integer part */
4412             if (strict) {
4413                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4414             }
4415             else if (isDIGIT(d[1])) {
4416                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4417             }
4418             else {
4419                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4420             }
4421         }
4422         else {
4423             /* anything else after integer part is just invalid data */
4424             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4425         }
4426
4427         /* scan the fractional part after the decimal point*/
4428
4429         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4430                 /* strict or lax-but-not-the-end */
4431                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4432         }
4433
4434         while (isDIGIT(*d)) {
4435             d++; j++;
4436             if (*d == '.' && isDIGIT(d[-1])) {
4437                 if (alpha) {
4438                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4439                 }
4440                 if (strict) {
4441                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4442                 }
4443                 d = (char *)s;          /* start all over again */
4444                 qv = TRUE;
4445                 goto dotted_decimal_version;
4446             }
4447             if (*d == '_') {
4448                 if (strict) {
4449                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4450                 }
4451                 if ( alpha ) {
4452                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4453                 }
4454                 if ( ! isDIGIT(d[1]) ) {
4455                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4456                 }
4457                 width = j;
4458                 d++;
4459                 alpha = TRUE;
4460             }
4461         }
4462     }
4463
4464 version_prescan_finish:
4465     while (isSPACE(*d))
4466         d++;
4467
4468     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4469         /* trailing non-numeric data */
4470         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4471     }
4472
4473     if (sqv)
4474         *sqv = qv;
4475     if (swidth)
4476         *swidth = width;
4477     if (ssaw_decimal)
4478         *ssaw_decimal = saw_decimal;
4479     if (salpha)
4480         *salpha = alpha;
4481     return d;
4482 }
4483
4484 /*
4485 =for apidoc scan_version
4486
4487 Returns a pointer to the next character after the parsed
4488 version string, as well as upgrading the passed in SV to
4489 an RV.
4490
4491 Function must be called with an already existing SV like
4492
4493     sv = newSV(0);
4494     s = scan_version(s, SV *sv, bool qv);
4495
4496 Performs some preprocessing to the string to ensure that
4497 it has the correct characteristics of a version.  Flags the
4498 object if it contains an underscore (which denotes this
4499 is an alpha version).  The boolean qv denotes that the version
4500 should be interpreted as if it had multiple decimals, even if
4501 it doesn't.
4502
4503 =cut
4504 */
4505
4506 const char *
4507 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4508 {
4509     const char *start = s;
4510     const char *pos;
4511     const char *last;
4512     const char *errstr = NULL;
4513     int saw_decimal = 0;
4514     int width = 3;
4515     bool alpha = FALSE;
4516     bool vinf = FALSE;
4517     AV * av;
4518     SV * hv;
4519
4520     PERL_ARGS_ASSERT_SCAN_VERSION;
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             Safefree(start);
4530             Perl_croak(aTHX_ "%s", errstr);
4531         }
4532     }
4533
4534     start = s;
4535     if (*s == 'v')
4536         s++;
4537     pos = s;
4538
4539     /* Now that we are through the prescan, start creating the object */
4540     av = newAV();
4541     hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4542     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4543
4544 #ifndef NODEFAULT_SHAREKEYS
4545     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4546 #endif
4547
4548     if ( qv )
4549         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4550     if ( alpha )
4551         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4552     if ( !qv && width < 3 )
4553         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4554
4555     while (isDIGIT(*pos))
4556         pos++;
4557     if (!isALPHA(*pos)) {
4558         I32 rev;
4559
4560         for (;;) {
4561             rev = 0;
4562             {
4563                 /* this is atoi() that delimits on underscores */
4564                 const char *end = pos;
4565                 I32 mult = 1;
4566                 I32 orev;
4567
4568                 /* the following if() will only be true after the decimal
4569                  * point of a version originally created with a bare
4570                  * floating point number, i.e. not quoted in any way
4571                  */
4572                 if ( !qv && s > start && saw_decimal == 1 ) {
4573                     mult *= 100;
4574                     while ( s < end ) {
4575                         orev = rev;
4576                         rev += (*s - '0') * mult;
4577                         mult /= 10;
4578                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4579                             || (PERL_ABS(rev) > VERSION_MAX )) {
4580                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4581                                            "Integer overflow in version %d",VERSION_MAX);
4582                             s = end - 1;
4583                             rev = VERSION_MAX;
4584                             vinf = 1;
4585                         }
4586                         s++;
4587                         if ( *s == '_' )
4588                             s++;
4589                     }
4590                 }
4591                 else {
4592                     while (--end >= s) {
4593                         orev = rev;
4594                         rev += (*end - '0') * mult;
4595                         mult *= 10;
4596                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4597                             || (PERL_ABS(rev) > VERSION_MAX )) {
4598                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4599                                            "Integer overflow in version");
4600                             end = s - 1;
4601                             rev = VERSION_MAX;
4602                             vinf = 1;
4603                         }
4604                     }
4605                 } 
4606             }
4607
4608             /* Append revision */
4609             av_push(av, newSViv(rev));
4610             if ( vinf ) {
4611                 s = last;
4612                 break;
4613             }
4614             else if ( *pos == '.' )
4615                 s = ++pos;
4616             else if ( *pos == '_' && isDIGIT(pos[1]) )
4617                 s = ++pos;
4618             else if ( *pos == ',' && isDIGIT(pos[1]) )
4619                 s = ++pos;
4620             else if ( isDIGIT(*pos) )
4621                 s = pos;
4622             else {
4623                 s = pos;
4624                 break;
4625             }
4626             if ( qv ) {
4627                 while ( isDIGIT(*pos) )
4628                     pos++;
4629             }
4630             else {
4631                 int digits = 0;
4632                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4633                     if ( *pos != '_' )
4634                         digits++;
4635                     pos++;
4636                 }
4637             }
4638         }
4639     }
4640     if ( qv ) { /* quoted versions always get at least three terms*/
4641         I32 len = av_len(av);
4642         /* This for loop appears to trigger a compiler bug on OS X, as it
4643            loops infinitely. Yes, len is negative. No, it makes no sense.
4644            Compiler in question is:
4645            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4646            for ( len = 2 - len; len > 0; len-- )
4647            av_push(MUTABLE_AV(sv), newSViv(0));
4648         */
4649         len = 2 - len;
4650         while (len-- > 0)
4651             av_push(av, newSViv(0));
4652     }
4653
4654     /* need to save off the current version string for later */
4655     if ( vinf ) {
4656         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4657         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4658         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4659     }
4660     else if ( s > start ) {
4661         SV * orig = newSVpvn(start,s-start);
4662         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4663             /* need to insert a v to be consistent */
4664             sv_insert(orig, 0, 0, "v", 1);
4665         }
4666         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4667     }
4668     else {
4669         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4670         av_push(av, newSViv(0));
4671     }
4672
4673     /* And finally, store the AV in the hash */
4674     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4675
4676     /* fix RT#19517 - special case 'undef' as string */
4677     if ( *s == 'u' && strEQ(s,"undef") ) {
4678         s += 5;
4679     }
4680
4681     return s;
4682 }
4683
4684 /*
4685 =for apidoc new_version
4686
4687 Returns a new version object based on the passed in SV:
4688
4689     SV *sv = new_version(SV *ver);
4690
4691 Does not alter the passed in ver SV.  See "upg_version" if you
4692 want to upgrade the SV.
4693
4694 =cut
4695 */
4696
4697 SV *
4698 Perl_new_version(pTHX_ SV *ver)
4699 {
4700     dVAR;
4701     SV * const rv = newSV(0);
4702     PERL_ARGS_ASSERT_NEW_VERSION;
4703     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4704          /* can just copy directly */
4705     {
4706         I32 key;
4707         AV * const av = newAV();
4708         AV *sav;
4709         /* This will get reblessed later if a derived class*/
4710         SV * const hv = newSVrv(rv, "version"); 
4711         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4712 #ifndef NODEFAULT_SHAREKEYS
4713         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4714 #endif
4715
4716         if ( SvROK(ver) )
4717             ver = SvRV(ver);
4718
4719         /* Begin copying all of the elements */
4720         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4721             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4722
4723         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4724             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4725
4726         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4727         {
4728             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4729             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4730         }
4731
4732         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4733         {
4734             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4735             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4736         }
4737
4738         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4739         /* This will get reblessed later if a derived class*/
4740         for ( key = 0; key <= av_len(sav); key++ )
4741         {
4742             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4743             av_push(av, newSViv(rev));
4744         }
4745
4746         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4747         return rv;
4748     }
4749 #ifdef SvVOK
4750     {
4751         const MAGIC* const mg = SvVSTRING_mg(ver);
4752         if ( mg ) { /* already a v-string */
4753             const STRLEN len = mg->mg_len;
4754             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4755             sv_setpvn(rv,version,len);
4756             /* this is for consistency with the pure Perl class */
4757             if ( isDIGIT(*version) )
4758                 sv_insert(rv, 0, 0, "v", 1);
4759             Safefree(version);
4760         }
4761         else {
4762 #endif
4763         sv_setsv(rv,ver); /* make a duplicate */
4764 #ifdef SvVOK
4765         }
4766     }
4767 #endif
4768     return upg_version(rv, FALSE);
4769 }
4770
4771 /*
4772 =for apidoc upg_version
4773
4774 In-place upgrade of the supplied SV to a version object.
4775
4776     SV *sv = upg_version(SV *sv, bool qv);
4777
4778 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4779 to force this SV to be interpreted as an "extended" version.
4780
4781 =cut
4782 */
4783
4784 SV *
4785 Perl_upg_version(pTHX_ SV *ver, bool qv)
4786 {
4787     const char *version, *s;
4788 #ifdef SvVOK
4789     const MAGIC *mg;
4790 #endif
4791
4792     PERL_ARGS_ASSERT_UPG_VERSION;
4793
4794     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4795     {
4796         STRLEN len;
4797
4798         /* may get too much accuracy */ 
4799         char tbuf[64];
4800         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4801         char *buf;
4802 #ifdef USE_LOCALE_NUMERIC
4803         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
4804         setlocale(LC_NUMERIC, "C");
4805 #endif
4806         if (sv) {
4807             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4808             buf = SvPV(sv, len);
4809         }
4810         else {
4811             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4812             buf = tbuf;
4813         }
4814 #ifdef USE_LOCALE_NUMERIC
4815         setlocale(LC_NUMERIC, loc);
4816         Safefree(loc);
4817 #endif
4818         while (buf[len-1] == '0' && len > 0) len--;
4819         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4820         version = savepvn(buf, len);
4821         SvREFCNT_dec(sv);
4822     }
4823 #ifdef SvVOK
4824     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4825         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4826         qv = TRUE;
4827     }
4828 #endif
4829     else /* must be a string or something like a string */
4830     {
4831         STRLEN len;
4832         version = savepv(SvPV(ver,len));
4833 #ifndef SvVOK
4834 #  if PERL_VERSION > 5
4835         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4836         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4837             /* may be a v-string */
4838             char *testv = (char *)version;
4839             STRLEN tlen = len;
4840             for (tlen=0; tlen < len; tlen++, testv++) {
4841                 /* if one of the characters is non-text assume v-string */
4842                 if (testv[0] < ' ') {
4843                     SV * const nsv = sv_newmortal();
4844                     const char *nver;
4845                     const char *pos;
4846                     int saw_decimal = 0;
4847                     sv_setpvf(nsv,"v%vd",ver);
4848                     pos = nver = savepv(SvPV_nolen(nsv));
4849
4850                     /* scan the resulting formatted string */
4851                     pos++; /* skip the leading 'v' */
4852                     while ( *pos == '.' || isDIGIT(*pos) ) {
4853                         if ( *pos == '.' )
4854                             saw_decimal++ ;
4855                         pos++;
4856                     }
4857
4858                     /* is definitely a v-string */
4859                     if ( saw_decimal >= 2 ) {
4860                         Safefree(version);
4861                         version = nver;
4862                     }
4863                     break;
4864                 }
4865             }
4866         }
4867 #  endif
4868 #endif
4869     }
4870
4871     s = scan_version(version, ver, qv);
4872     if ( *s != '\0' ) 
4873         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
4874                        "Version string '%s' contains invalid data; "
4875                        "ignoring: '%s'", version, s);
4876     Safefree(version);
4877     return ver;
4878 }
4879
4880 /*
4881 =for apidoc vverify
4882
4883 Validates that the SV contains valid internal structure for a version object.
4884 It may be passed either the version object (RV) or the hash itself (HV).  If
4885 the structure is valid, it returns the HV.  If the structure is invalid,
4886 it returns NULL.
4887
4888     SV *hv = vverify(sv);
4889
4890 Note that it only confirms the bare minimum structure (so as not to get
4891 confused by derived classes which may contain additional hash entries):
4892
4893 =over 4
4894
4895 =item * The SV is an HV or a reference to an HV
4896
4897 =item * The hash contains a "version" key
4898
4899 =item * The "version" key has a reference to an AV as its value
4900
4901 =back
4902
4903 =cut
4904 */
4905
4906 SV *
4907 Perl_vverify(pTHX_ SV *vs)
4908 {
4909     SV *sv;
4910
4911     PERL_ARGS_ASSERT_VVERIFY;
4912
4913     if ( SvROK(vs) )
4914         vs = SvRV(vs);
4915
4916     /* see if the appropriate elements exist */
4917     if ( SvTYPE(vs) == SVt_PVHV
4918          && hv_exists(MUTABLE_HV(vs), "version", 7)
4919          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4920          && SvTYPE(sv) == SVt_PVAV )
4921         return vs;
4922     else
4923         return NULL;
4924 }
4925
4926 /*
4927 =for apidoc vnumify
4928
4929 Accepts a version object and returns the normalized floating
4930 point representation.  Call like:
4931
4932     sv = vnumify(rv);
4933
4934 NOTE: you can pass either the object directly or the SV
4935 contained within the RV.
4936
4937 The SV returned has a refcount of 1.
4938
4939 =cut
4940 */
4941
4942 SV *
4943 Perl_vnumify(pTHX_ SV *vs)
4944 {
4945     I32 i, len, digit;
4946     int width;
4947     bool alpha = FALSE;
4948     SV *sv;
4949     AV *av;
4950
4951     PERL_ARGS_ASSERT_VNUMIFY;
4952
4953     /* extract the HV from the object */
4954     vs = vverify(vs);
4955     if ( ! vs )
4956         Perl_croak(aTHX_ "Invalid version object");
4957
4958     /* see if various flags exist */
4959     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4960         alpha = TRUE;
4961     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4962         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4963     else
4964         width = 3;
4965
4966
4967     /* attempt to retrieve the version array */
4968     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4969         return newSVpvs("0");
4970     }
4971
4972     len = av_len(av);
4973     if ( len == -1 )
4974     {
4975         return newSVpvs("0");
4976     }
4977
4978     digit = SvIV(*av_fetch(av, 0, 0));
4979     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4980     for ( i = 1 ; i < len ; i++ )
4981     {
4982         digit = SvIV(*av_fetch(av, i, 0));
4983         if ( width < 3 ) {
4984             const int denom = (width == 2 ? 10 : 100);
4985             const div_t term = div((int)PERL_ABS(digit),denom);
4986             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
4987         }
4988         else {
4989             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4990         }
4991     }
4992
4993     if ( len > 0 )
4994     {
4995         digit = SvIV(*av_fetch(av, len, 0));
4996         if ( alpha && width == 3 ) /* alpha version */
4997             sv_catpvs(sv,"_");
4998         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
4999     }
5000     else /* len == 0 */
5001     {
5002         sv_catpvs(sv, "000");
5003     }
5004     return sv;
5005 }
5006
5007 /*
5008 =for apidoc vnormal
5009
5010 Accepts a version object and returns the normalized string
5011 representation.  Call like:
5012
5013     sv = vnormal(rv);
5014
5015 NOTE: you can pass either the object directly or the SV
5016 contained within the RV.
5017
5018 The SV returned has a refcount of 1.
5019
5020 =cut
5021 */
5022
5023 SV *
5024 Perl_vnormal(pTHX_ SV *vs)
5025 {
5026     I32 i, len, digit;
5027     bool alpha = FALSE;
5028     SV *sv;
5029     AV *av;