Hash Function Change - Murmur hash and true per process hash seed
[perl.git] / util.c
1 /*    util.c
2  *
3  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4  *    2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Very useful, no doubt, that was to Saruman; yet it seems that he was
13  *  not content.'                                    --Gandalf to Pippin
14  *
15  *     [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"]
16  */
17
18 /* This file contains assorted utility routines.
19  * Which is a polite way of saying any stuff that people couldn't think of
20  * a better place for. Amongst other things, it includes the warning and
21  * dieing stuff, plus wrappers for malloc code.
22  */
23
24 #include "EXTERN.h"
25 #define PERL_IN_UTIL_C
26 #include "perl.h"
27 #include "reentr.h"
28
29 #ifdef USE_PERLIO
30 #include "perliol.h" /* For PerlIOUnix_refcnt */
31 #endif
32
33 #ifndef PERL_MICRO
34 #include <signal.h>
35 #ifndef SIG_ERR
36 # define SIG_ERR ((Sighandler_t) -1)
37 #endif
38 #endif
39
40 #ifdef __Lynx__
41 /* Missing protos on LynxOS */
42 int putenv(char *);
43 #endif
44
45 #ifdef HAS_SELECT
46 # ifdef I_SYS_SELECT
47 #  include <sys/select.h>
48 # endif
49 #endif
50
51 #define FLUSH
52
53 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
54 #  define FD_CLOEXEC 1                  /* NeXT needs this */
55 #endif
56
57 /* NOTE:  Do not call the next three routines directly.  Use the macros
58  * in handy.h, so that we can easily redefine everything to do tracking of
59  * allocated hunks back to the original New to track down any memory leaks.
60  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
61  */
62
63 #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
64 #  define ALWAYS_NEED_THX
65 #endif
66
67 /* paranoid version of system's malloc() */
68
69 Malloc_t
70 Perl_safesysmalloc(MEM_SIZE size)
71 {
72 #ifdef ALWAYS_NEED_THX
73     dTHX;
74 #endif
75     Malloc_t ptr;
76 #ifdef HAS_64K_LIMIT
77         if (size > 0xffff) {
78             PerlIO_printf(Perl_error_log,
79                           "Allocation too large: %lx\n", size) FLUSH;
80             my_exit(1);
81         }
82 #endif /* HAS_64K_LIMIT */
83 #ifdef PERL_TRACK_MEMPOOL
84     size += sTHX;
85 #endif
86 #ifdef DEBUGGING
87     if ((SSize_t)size < 0)
88         Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
89 #endif
90     ptr = (Malloc_t)PerlMem_malloc(size?size:1);        /* malloc(0) is NASTY on our system */
91     PERL_ALLOC_CHECK(ptr);
92     if (ptr != NULL) {
93 #ifdef PERL_TRACK_MEMPOOL
94         struct perl_memory_debug_header *const header
95             = (struct perl_memory_debug_header *)ptr;
96 #endif
97
98 #ifdef PERL_POISON
99         PoisonNew(((char *)ptr), size, char);
100 #endif
101
102 #ifdef PERL_TRACK_MEMPOOL
103         header->interpreter = aTHX;
104         /* Link us into the list.  */
105         header->prev = &PL_memory_debug_header;
106         header->next = PL_memory_debug_header.next;
107         PL_memory_debug_header.next = header;
108         header->next->prev = header;
109 #  ifdef PERL_POISON
110         header->size = size;
111 #  endif
112         ptr = (Malloc_t)((char*)ptr+sTHX);
113 #endif
114         DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
115         return ptr;
116 }
117     else {
118 #ifndef ALWAYS_NEED_THX
119         dTHX;
120 #endif
121         if (PL_nomemok)
122             return NULL;
123         else {
124             croak_no_mem();
125         }
126     }
127     /*NOTREACHED*/
128 }
129
130 /* paranoid version of system's realloc() */
131
132 Malloc_t
133 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
134 {
135 #ifdef ALWAYS_NEED_THX
136     dTHX;
137 #endif
138     Malloc_t ptr;
139 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
140     Malloc_t PerlMem_realloc();
141 #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
142
143 #ifdef HAS_64K_LIMIT
144     if (size > 0xffff) {
145         PerlIO_printf(Perl_error_log,
146                       "Reallocation too large: %lx\n", size) FLUSH;
147         my_exit(1);
148     }
149 #endif /* HAS_64K_LIMIT */
150     if (!size) {
151         safesysfree(where);
152         return NULL;
153     }
154
155     if (!where)
156         return safesysmalloc(size);
157 #ifdef PERL_TRACK_MEMPOOL
158     where = (Malloc_t)((char*)where-sTHX);
159     size += sTHX;
160     {
161         struct perl_memory_debug_header *const header
162             = (struct perl_memory_debug_header *)where;
163
164         if (header->interpreter != aTHX) {
165             Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
166                                  header->interpreter, aTHX);
167         }
168         assert(header->next->prev == header);
169         assert(header->prev->next == header);
170 #  ifdef PERL_POISON
171         if (header->size > size) {
172             const MEM_SIZE freed_up = header->size - size;
173             char *start_of_freed = ((char *)where) + size;
174             PoisonFree(start_of_freed, freed_up, char);
175         }
176         header->size = size;
177 #  endif
178     }
179 #endif
180 #ifdef DEBUGGING
181     if ((SSize_t)size < 0)
182         Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
183 #endif
184     ptr = (Malloc_t)PerlMem_realloc(where,size);
185     PERL_ALLOC_CHECK(ptr);
186
187     /* MUST do this fixup first, before doing ANYTHING else, as anything else
188        might allocate memory/free/move memory, and until we do the fixup, it
189        may well be chasing (and writing to) free memory.  */
190 #ifdef PERL_TRACK_MEMPOOL
191     if (ptr != NULL) {
192         struct perl_memory_debug_header *const header
193             = (struct perl_memory_debug_header *)ptr;
194
195 #  ifdef PERL_POISON
196         if (header->size < size) {
197             const MEM_SIZE fresh = size - header->size;
198             char *start_of_fresh = ((char *)ptr) + size;
199             PoisonNew(start_of_fresh, fresh, char);
200         }
201 #  endif
202
203         header->next->prev = header;
204         header->prev->next = header;
205
206         ptr = (Malloc_t)((char*)ptr+sTHX);
207     }
208 #endif
209
210     /* In particular, must do that fixup above before logging anything via
211      *printf(), as it can reallocate memory, which can cause SEGVs.  */
212
213     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
214     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
215
216
217     if (ptr != NULL) {
218         return ptr;
219     }
220     else {
221 #ifndef ALWAYS_NEED_THX
222         dTHX;
223 #endif
224         if (PL_nomemok)
225             return NULL;
226         else {
227             croak_no_mem();
228         }
229     }
230     /*NOTREACHED*/
231 }
232
233 /* safe version of system's free() */
234
235 Free_t
236 Perl_safesysfree(Malloc_t where)
237 {
238 #ifdef ALWAYS_NEED_THX
239     dTHX;
240 #else
241     dVAR;
242 #endif
243     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
244     if (where) {
245 #ifdef PERL_TRACK_MEMPOOL
246         where = (Malloc_t)((char*)where-sTHX);
247         {
248             struct perl_memory_debug_header *const header
249                 = (struct perl_memory_debug_header *)where;
250
251             if (header->interpreter != aTHX) {
252                 Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
253                                      header->interpreter, aTHX);
254             }
255             if (!header->prev) {
256                 Perl_croak_nocontext("panic: duplicate free");
257             }
258             if (!(header->next))
259                 Perl_croak_nocontext("panic: bad free, header->next==NULL");
260             if (header->next->prev != header || header->prev->next != header) {
261                 Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
262                                      "header=%p, ->prev->next=%p",
263                                      header->next->prev, header,
264                                      header->prev->next);
265             }
266             /* Unlink us from the chain.  */
267             header->next->prev = header->prev;
268             header->prev->next = header->next;
269 #  ifdef PERL_POISON
270             PoisonNew(where, header->size, char);
271 #  endif
272             /* Trigger the duplicate free warning.  */
273             header->next = NULL;
274         }
275 #endif
276         PerlMem_free(where);
277     }
278 }
279
280 /* safe version of system's calloc() */
281
282 Malloc_t
283 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
284 {
285 #ifdef ALWAYS_NEED_THX
286     dTHX;
287 #endif
288     Malloc_t ptr;
289 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
290     MEM_SIZE total_size = 0;
291 #endif
292
293     /* Even though calloc() for zero bytes is strange, be robust. */
294     if (size && (count <= MEM_SIZE_MAX / size)) {
295 #if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
296         total_size = size * count;
297 #endif
298     }
299     else
300         croak_memory_wrap();
301 #ifdef PERL_TRACK_MEMPOOL
302     if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
303         total_size += sTHX;
304     else
305         croak_memory_wrap();
306 #endif
307 #ifdef HAS_64K_LIMIT
308     if (total_size > 0xffff) {
309         PerlIO_printf(Perl_error_log,
310                       "Allocation too large: %lx\n", total_size) FLUSH;
311         my_exit(1);
312     }
313 #endif /* HAS_64K_LIMIT */
314 #ifdef DEBUGGING
315     if ((SSize_t)size < 0 || (SSize_t)count < 0)
316         Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
317                              (UV)size, (UV)count);
318 #endif
319 #ifdef PERL_TRACK_MEMPOOL
320     /* Have to use malloc() because we've added some space for our tracking
321        header.  */
322     /* malloc(0) is non-portable. */
323     ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1);
324 #else
325     /* Use calloc() because it might save a memset() if the memory is fresh
326        and clean from the OS.  */
327     if (count && size)
328         ptr = (Malloc_t)PerlMem_calloc(count, size);
329     else /* calloc(0) is non-portable. */
330         ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
331 #endif
332     PERL_ALLOC_CHECK(ptr);
333     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
334     if (ptr != NULL) {
335 #ifdef PERL_TRACK_MEMPOOL
336         {
337             struct perl_memory_debug_header *const header
338                 = (struct perl_memory_debug_header *)ptr;
339
340             memset((void*)ptr, 0, total_size);
341             header->interpreter = aTHX;
342             /* Link us into the list.  */
343             header->prev = &PL_memory_debug_header;
344             header->next = PL_memory_debug_header.next;
345             PL_memory_debug_header.next = header;
346             header->next->prev = header;
347 #  ifdef PERL_POISON
348             header->size = total_size;
349 #  endif
350             ptr = (Malloc_t)((char*)ptr+sTHX);
351         }
352 #endif
353         return ptr;
354     }
355     else {
356 #ifndef ALWAYS_NEED_THX
357         dTHX;
358 #endif
359         if (PL_nomemok)
360             return NULL;
361         croak_no_mem();
362     }
363 }
364
365 /* These must be defined when not using Perl's malloc for binary
366  * compatibility */
367
368 #ifndef MYMALLOC
369
370 Malloc_t Perl_malloc (MEM_SIZE nbytes)
371 {
372     dTHXs;
373     return (Malloc_t)PerlMem_malloc(nbytes);
374 }
375
376 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
377 {
378     dTHXs;
379     return (Malloc_t)PerlMem_calloc(elements, size);
380 }
381
382 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
383 {
384     dTHXs;
385     return (Malloc_t)PerlMem_realloc(where, nbytes);
386 }
387
388 Free_t   Perl_mfree (Malloc_t where)
389 {
390     dTHXs;
391     PerlMem_free(where);
392 }
393
394 #endif
395
396 /* copy a string up to some (non-backslashed) delimiter, if any */
397
398 char *
399 Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register 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(register const char *big, register const char *little)
430 {
431     I32 first;
432
433     PERL_ARGS_ASSERT_INSTR;
434
435     if (!little)
436         return (char*)big;
437     first = *little++;
438     if (!first)
439         return (char*)big;
440     while (*big) {
441         const char *s, *x;
442         if (*big++ != first)
443             continue;
444         for (x=big,s=little; *s; /**/ ) {
445             if (!*x)
446                 return NULL;
447             if (*s != *x)
448                 break;
449             else {
450                 s++;
451                 x++;
452             }
453         }
454         if (!*s)
455             return (char*)(big-1);
456     }
457     return NULL;
458 }
459
460 /* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
461  * the final character desired to be checked */
462
463 char *
464 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
465 {
466     PERL_ARGS_ASSERT_NINSTR;
467     if (little >= lend)
468         return (char*)big;
469     {
470         const char first = *little;
471         const char *s, *x;
472         bigend -= lend - little++;
473     OUTER:
474         while (big <= bigend) {
475             if (*big++ == first) {
476                 for (x=big,s=little; s < lend; x++,s++) {
477                     if (*s != *x)
478                         goto OUTER;
479                 }
480                 return (char*)(big-1);
481             }
482         }
483     }
484     return NULL;
485 }
486
487 /* reverse of the above--find last substring */
488
489 char *
490 Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
491 {
492     const char *bigbeg;
493     const I32 first = *little;
494     const char * const littleend = lend;
495
496     PERL_ARGS_ASSERT_RNINSTR;
497
498     if (little >= littleend)
499         return (char*)bigend;
500     bigbeg = big;
501     big = bigend - (littleend - little++);
502     while (big >= bigbeg) {
503         const char *s, *x;
504         if (*big-- != first)
505             continue;
506         for (x=big+2,s=little; s < littleend; /**/ ) {
507             if (*s != *x)
508                 break;
509             else {
510                 x++;
511                 s++;
512             }
513         }
514         if (s >= littleend)
515             return (char*)(big+1);
516     }
517     return NULL;
518 }
519
520 /* As a space optimization, we do not compile tables for strings of length
521    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
522    special-cased in fbm_instr().
523
524    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
525
526 /*
527 =head1 Miscellaneous Functions
528
529 =for apidoc fbm_compile
530
531 Analyses the string in order to make fast searches on it using fbm_instr()
532 -- the Boyer-Moore algorithm.
533
534 =cut
535 */
536
537 void
538 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
539 {
540     dVAR;
541     const U8 *s;
542     STRLEN i;
543     STRLEN len;
544     STRLEN rarest = 0;
545     U32 frequency = 256;
546     MAGIC *mg;
547
548     PERL_ARGS_ASSERT_FBM_COMPILE;
549
550     if (isGV_with_GP(sv))
551         return;
552
553     if (SvVALID(sv))
554         return;
555
556     if (flags & FBMcf_TAIL) {
557         MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
558         sv_catpvs(sv, "\n");            /* Taken into account in fbm_instr() */
559         if (mg && mg->mg_len >= 0)
560             mg->mg_len++;
561     }
562     s = (U8*)SvPV_force_mutable(sv, len);
563     if (len == 0)               /* TAIL might be on a zero-length string. */
564         return;
565     SvUPGRADE(sv, SVt_PVMG);
566     SvIOK_off(sv);
567     SvNOK_off(sv);
568     SvVALID_on(sv);
569
570     /* "deep magic", the comment used to add. The use of MAGIC itself isn't
571        really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
572        to call SvVALID_off() if the scalar was assigned to.
573
574        The comment itself (and "deeper magic" below) date back to
575        378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
576        str->str_pok |= 2;
577        where the magic (presumably) was that the scalar had a BM table hidden
578        inside itself.
579
580        As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
581        the table instead of the previous (somewhat hacky) approach of co-opting
582        the string buffer and storing it after the string.  */
583
584     assert(!mg_find(sv, PERL_MAGIC_bm));
585     mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
586     assert(mg);
587
588     if (len > 2) {
589         /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
590            the BM table.  */
591         const U8 mlen = (len>255) ? 255 : (U8)len;
592         const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
593         U8 *table;
594
595         Newx(table, 256, U8);
596         memset((void*)table, mlen, 256);
597         mg->mg_ptr = (char *)table;
598         mg->mg_len = 256;
599
600         s += len - 1; /* last char */
601         i = 0;
602         while (s >= sb) {
603             if (table[*s] == mlen)
604                 table[*s] = (U8)i;
605             s--, i++;
606         }
607     }
608
609     s = (const unsigned char*)(SvPVX_const(sv));        /* deeper magic */
610     for (i = 0; i < len; i++) {
611         if (PL_freq[s[i]] < frequency) {
612             rarest = i;
613             frequency = PL_freq[s[i]];
614         }
615     }
616     BmRARE(sv) = s[rarest];
617     BmPREVIOUS(sv) = rarest;
618     BmUSEFUL(sv) = 100;                 /* Initial value */
619     if (flags & FBMcf_TAIL)
620         SvTAIL_on(sv);
621     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
622                           BmRARE(sv), BmPREVIOUS(sv)));
623 }
624
625 /* If SvTAIL(littlestr), it has a fake '\n' at end. */
626 /* If SvTAIL is actually due to \Z or \z, this gives false positives
627    if multiline */
628
629 /*
630 =for apidoc fbm_instr
631
632 Returns the location of the SV in the string delimited by C<big> and
633 C<bigend>.  It returns C<NULL> if the string can't be found.  The C<sv>
634 does not have to be fbm_compiled, but the search will not be as fast
635 then.
636
637 =cut
638 */
639
640 char *
641 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
642 {
643     unsigned char *s;
644     STRLEN l;
645     const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
646     STRLEN littlelen = l;
647     const I32 multiline = flags & FBMrf_MULTILINE;
648
649     PERL_ARGS_ASSERT_FBM_INSTR;
650
651     if ((STRLEN)(bigend - big) < littlelen) {
652         if ( SvTAIL(littlestr)
653              && ((STRLEN)(bigend - big) == littlelen - 1)
654              && (littlelen == 1
655                  || (*big == *little &&
656                      memEQ((char *)big, (char *)little, littlelen - 1))))
657             return (char*)big;
658         return NULL;
659     }
660
661     switch (littlelen) { /* Special cases for 0, 1 and 2  */
662     case 0:
663         return (char*)big;              /* Cannot be SvTAIL! */
664     case 1:
665             if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
666                 /* Know that bigend != big.  */
667                 if (bigend[-1] == '\n')
668                     return (char *)(bigend - 1);
669                 return (char *) bigend;
670             }
671             s = big;
672             while (s < bigend) {
673                 if (*s == *little)
674                     return (char *)s;
675                 s++;
676             }
677             if (SvTAIL(littlestr))
678                 return (char *) bigend;
679             return NULL;
680     case 2:
681         if (SvTAIL(littlestr) && !multiline) {
682             if (bigend[-1] == '\n' && bigend[-2] == *little)
683                 return (char*)bigend - 2;
684             if (bigend[-1] == *little)
685                 return (char*)bigend - 1;
686             return NULL;
687         }
688         {
689             /* This should be better than FBM if c1 == c2, and almost
690                as good otherwise: maybe better since we do less indirection.
691                And we save a lot of memory by caching no table. */
692             const unsigned char c1 = little[0];
693             const unsigned char c2 = little[1];
694
695             s = big + 1;
696             bigend--;
697             if (c1 != c2) {
698                 while (s <= bigend) {
699                     if (s[0] == c2) {
700                         if (s[-1] == c1)
701                             return (char*)s - 1;
702                         s += 2;
703                         continue;
704                     }
705                   next_chars:
706                     if (s[0] == c1) {
707                         if (s == bigend)
708                             goto check_1char_anchor;
709                         if (s[1] == c2)
710                             return (char*)s;
711                         else {
712                             s++;
713                             goto next_chars;
714                         }
715                     }
716                     else
717                         s += 2;
718                 }
719                 goto check_1char_anchor;
720             }
721             /* Now c1 == c2 */
722             while (s <= bigend) {
723                 if (s[0] == c1) {
724                     if (s[-1] == c1)
725                         return (char*)s - 1;
726                     if (s == bigend)
727                         goto check_1char_anchor;
728                     if (s[1] == c1)
729                         return (char*)s;
730                     s += 3;
731                 }
732                 else
733                     s += 2;
734             }
735         }
736       check_1char_anchor:               /* One char and anchor! */
737         if (SvTAIL(littlestr) && (*bigend == *little))
738             return (char *)bigend;      /* bigend is already decremented. */
739         return NULL;
740     default:
741         break; /* Only lengths 0 1 and 2 have special-case code.  */
742     }
743
744     if (SvTAIL(littlestr) && !multiline) {      /* tail anchored? */
745         s = bigend - littlelen;
746         if (s >= big && bigend[-1] == '\n' && *s == *little
747             /* Automatically of length > 2 */
748             && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
749         {
750             return (char*)s;            /* how sweet it is */
751         }
752         if (s[1] == *little
753             && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
754         {
755             return (char*)s + 1;        /* how sweet it is */
756         }
757         return NULL;
758     }
759     if (!SvVALID(littlestr)) {
760         char * const b = ninstr((char*)big,(char*)bigend,
761                          (char*)little, (char*)little + littlelen);
762
763         if (!b && SvTAIL(littlestr)) {  /* Automatically multiline!  */
764             /* Chop \n from littlestr: */
765             s = bigend - littlelen + 1;
766             if (*s == *little
767                 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
768             {
769                 return (char*)s;
770             }
771             return NULL;
772         }
773         return b;
774     }
775
776     /* Do actual FBM.  */
777     if (littlelen > (STRLEN)(bigend - big))
778         return NULL;
779
780     {
781         const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
782         const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
783         const unsigned char *oldlittle;
784
785         --littlelen;                    /* Last char found by table lookup */
786
787         s = big + littlelen;
788         little += littlelen;            /* last char */
789         oldlittle = little;
790         if (s < bigend) {
791             I32 tmp;
792
793           top2:
794             if ((tmp = table[*s])) {
795                 if ((s += tmp) < bigend)
796                     goto top2;
797                 goto check_end;
798             }
799             else {              /* less expensive than calling strncmp() */
800                 unsigned char * const olds = s;
801
802                 tmp = littlelen;
803
804                 while (tmp--) {
805                     if (*--s == *--little)
806                         continue;
807                     s = olds + 1;       /* here we pay the price for failure */
808                     little = oldlittle;
809                     if (s < bigend)     /* fake up continue to outer loop */
810                         goto top2;
811                     goto check_end;
812                 }
813                 return (char *)s;
814             }
815         }
816       check_end:
817         if ( s == bigend
818              && SvTAIL(littlestr)
819              && memEQ((char *)(bigend - littlelen),
820                       (char *)(oldlittle - littlelen), littlelen) )
821             return (char*)bigend - littlelen;
822         return NULL;
823     }
824 }
825
826 char *
827 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
828 {
829     dVAR;
830     PERL_ARGS_ASSERT_SCREAMINSTR;
831     PERL_UNUSED_ARG(bigstr);
832     PERL_UNUSED_ARG(littlestr);
833     PERL_UNUSED_ARG(start_shift);
834     PERL_UNUSED_ARG(end_shift);
835     PERL_UNUSED_ARG(old_posp);
836     PERL_UNUSED_ARG(last);
837
838     /* This function must only ever be called on a scalar with study magic,
839        but those do not happen any more. */
840     Perl_croak(aTHX_ "panic: screaminstr");
841     return NULL;
842 }
843
844 /*
845 =for apidoc foldEQ
846
847 Returns true if the leading len bytes of the strings s1 and s2 are the same
848 case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
849 match themselves and their opposite case counterparts.  Non-cased and non-ASCII
850 range bytes match only themselves.
851
852 =cut
853 */
854
855
856 I32
857 Perl_foldEQ(const char *s1, const char *s2, register I32 len)
858 {
859     const U8 *a = (const U8 *)s1;
860     const U8 *b = (const U8 *)s2;
861
862     PERL_ARGS_ASSERT_FOLDEQ;
863
864     assert(len >= 0);
865
866     while (len--) {
867         if (*a != *b && *a != PL_fold[*b])
868             return 0;
869         a++,b++;
870     }
871     return 1;
872 }
873 I32
874 Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
875 {
876     /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
877      * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
878      * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
879      * does it check that the strings each have at least 'len' characters */
880
881     const U8 *a = (const U8 *)s1;
882     const U8 *b = (const U8 *)s2;
883
884     PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
885
886     assert(len >= 0);
887
888     while (len--) {
889         if (*a != *b && *a != PL_fold_latin1[*b]) {
890             return 0;
891         }
892         a++, b++;
893     }
894     return 1;
895 }
896
897 /*
898 =for apidoc foldEQ_locale
899
900 Returns true if the leading len bytes of the strings s1 and s2 are the same
901 case-insensitively in the current locale; false otherwise.
902
903 =cut
904 */
905
906 I32
907 Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)
908 {
909     dVAR;
910     const U8 *a = (const U8 *)s1;
911     const U8 *b = (const U8 *)s2;
912
913     PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
914
915     assert(len >= 0);
916
917     while (len--) {
918         if (*a != *b && *a != PL_fold_locale[*b])
919             return 0;
920         a++,b++;
921     }
922     return 1;
923 }
924
925 /* copy a string to a safe spot */
926
927 /*
928 =head1 Memory Management
929
930 =for apidoc savepv
931
932 Perl's version of C<strdup()>. Returns a pointer to a newly allocated
933 string which is a duplicate of C<pv>. The size of the string is
934 determined by C<strlen()>. The memory allocated for the new string can
935 be freed with the C<Safefree()> function.
936
937 =cut
938 */
939
940 char *
941 Perl_savepv(pTHX_ const char *pv)
942 {
943     PERL_UNUSED_CONTEXT;
944     if (!pv)
945         return NULL;
946     else {
947         char *newaddr;
948         const STRLEN pvlen = strlen(pv)+1;
949         Newx(newaddr, pvlen, char);
950         return (char*)memcpy(newaddr, pv, pvlen);
951     }
952 }
953
954 /* same thing but with a known length */
955
956 /*
957 =for apidoc savepvn
958
959 Perl's version of what C<strndup()> would be if it existed. Returns a
960 pointer to a newly allocated string which is a duplicate of the first
961 C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
962 the new string can be freed with the C<Safefree()> function.
963
964 =cut
965 */
966
967 char *
968 Perl_savepvn(pTHX_ const char *pv, register I32 len)
969 {
970     char *newaddr;
971     PERL_UNUSED_CONTEXT;
972
973     assert(len >= 0);
974
975     Newx(newaddr,len+1,char);
976     /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
977     if (pv) {
978         /* might not be null terminated */
979         newaddr[len] = '\0';
980         return (char *) CopyD(pv,newaddr,len,char);
981     }
982     else {
983         return (char *) ZeroD(newaddr,len+1,char);
984     }
985 }
986
987 /*
988 =for apidoc savesharedpv
989
990 A version of C<savepv()> which allocates the duplicate string in memory
991 which is shared between threads.
992
993 =cut
994 */
995 char *
996 Perl_savesharedpv(pTHX_ const char *pv)
997 {
998     char *newaddr;
999     STRLEN pvlen;
1000     if (!pv)
1001         return NULL;
1002
1003     pvlen = strlen(pv)+1;
1004     newaddr = (char*)PerlMemShared_malloc(pvlen);
1005     if (!newaddr) {
1006         croak_no_mem();
1007     }
1008     return (char*)memcpy(newaddr, pv, pvlen);
1009 }
1010
1011 /*
1012 =for apidoc savesharedpvn
1013
1014 A version of C<savepvn()> which allocates the duplicate string in memory
1015 which is shared between threads. (With the specific difference that a NULL
1016 pointer is not acceptable)
1017
1018 =cut
1019 */
1020 char *
1021 Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
1022 {
1023     char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
1024
1025     /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
1026
1027     if (!newaddr) {
1028         croak_no_mem();
1029     }
1030     newaddr[len] = '\0';
1031     return (char*)memcpy(newaddr, pv, len);
1032 }
1033
1034 /*
1035 =for apidoc savesvpv
1036
1037 A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
1038 the passed in SV using C<SvPV()>
1039
1040 =cut
1041 */
1042
1043 char *
1044 Perl_savesvpv(pTHX_ SV *sv)
1045 {
1046     STRLEN len;
1047     const char * const pv = SvPV_const(sv, len);
1048     char *newaddr;
1049
1050     PERL_ARGS_ASSERT_SAVESVPV;
1051
1052     ++len;
1053     Newx(newaddr,len,char);
1054     return (char *) CopyD(pv,newaddr,len,char);
1055 }
1056
1057 /*
1058 =for apidoc savesharedsvpv
1059
1060 A version of C<savesharedpv()> which allocates the duplicate string in
1061 memory which is shared between threads.
1062
1063 =cut
1064 */
1065
1066 char *
1067 Perl_savesharedsvpv(pTHX_ SV *sv)
1068 {
1069     STRLEN len;
1070     const char * const pv = SvPV_const(sv, len);
1071
1072     PERL_ARGS_ASSERT_SAVESHAREDSVPV;
1073
1074     return savesharedpvn(pv, len);
1075 }
1076
1077 /* the SV for Perl_form() and mess() is not kept in an arena */
1078
1079 STATIC SV *
1080 S_mess_alloc(pTHX)
1081 {
1082     dVAR;
1083     SV *sv;
1084     XPVMG *any;
1085
1086     if (PL_phase != PERL_PHASE_DESTRUCT)
1087         return newSVpvs_flags("", SVs_TEMP);
1088
1089     if (PL_mess_sv)
1090         return PL_mess_sv;
1091
1092     /* Create as PVMG now, to avoid any upgrading later */
1093     Newx(sv, 1, SV);
1094     Newxz(any, 1, XPVMG);
1095     SvFLAGS(sv) = SVt_PVMG;
1096     SvANY(sv) = (void*)any;
1097     SvPV_set(sv, NULL);
1098     SvREFCNT(sv) = 1 << 30; /* practically infinite */
1099     PL_mess_sv = sv;
1100     return sv;
1101 }
1102
1103 #if defined(PERL_IMPLICIT_CONTEXT)
1104 char *
1105 Perl_form_nocontext(const char* pat, ...)
1106 {
1107     dTHX;
1108     char *retval;
1109     va_list args;
1110     PERL_ARGS_ASSERT_FORM_NOCONTEXT;
1111     va_start(args, pat);
1112     retval = vform(pat, &args);
1113     va_end(args);
1114     return retval;
1115 }
1116 #endif /* PERL_IMPLICIT_CONTEXT */
1117
1118 /*
1119 =head1 Miscellaneous Functions
1120 =for apidoc form
1121
1122 Takes a sprintf-style format pattern and conventional
1123 (non-SV) arguments and returns the formatted string.
1124
1125     (char *) Perl_form(pTHX_ const char* pat, ...)
1126
1127 can be used any place a string (char *) is required:
1128
1129     char * s = Perl_form("%d.%d",major,minor);
1130
1131 Uses a single private buffer so if you want to format several strings you
1132 must explicitly copy the earlier strings away (and free the copies when you
1133 are done).
1134
1135 =cut
1136 */
1137
1138 char *
1139 Perl_form(pTHX_ const char* pat, ...)
1140 {
1141     char *retval;
1142     va_list args;
1143     PERL_ARGS_ASSERT_FORM;
1144     va_start(args, pat);
1145     retval = vform(pat, &args);
1146     va_end(args);
1147     return retval;
1148 }
1149
1150 char *
1151 Perl_vform(pTHX_ const char *pat, va_list *args)
1152 {
1153     SV * const sv = mess_alloc();
1154     PERL_ARGS_ASSERT_VFORM;
1155     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1156     return SvPVX(sv);
1157 }
1158
1159 /*
1160 =for apidoc Am|SV *|mess|const char *pat|...
1161
1162 Take a sprintf-style format pattern and argument list.  These are used to
1163 generate a string message.  If the message does not end with a newline,
1164 then it will be extended with some indication of the current location
1165 in the code, as described for L</mess_sv>.
1166
1167 Normally, the resulting message is returned in a new mortal SV.
1168 During global destruction a single SV may be shared between uses of
1169 this function.
1170
1171 =cut
1172 */
1173
1174 #if defined(PERL_IMPLICIT_CONTEXT)
1175 SV *
1176 Perl_mess_nocontext(const char *pat, ...)
1177 {
1178     dTHX;
1179     SV *retval;
1180     va_list args;
1181     PERL_ARGS_ASSERT_MESS_NOCONTEXT;
1182     va_start(args, pat);
1183     retval = vmess(pat, &args);
1184     va_end(args);
1185     return retval;
1186 }
1187 #endif /* PERL_IMPLICIT_CONTEXT */
1188
1189 SV *
1190 Perl_mess(pTHX_ const char *pat, ...)
1191 {
1192     SV *retval;
1193     va_list args;
1194     PERL_ARGS_ASSERT_MESS;
1195     va_start(args, pat);
1196     retval = vmess(pat, &args);
1197     va_end(args);
1198     return retval;
1199 }
1200
1201 STATIC const COP*
1202 S_closest_cop(pTHX_ const COP *cop, const OP *o)
1203 {
1204     dVAR;
1205     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
1206
1207     PERL_ARGS_ASSERT_CLOSEST_COP;
1208
1209     if (!o || o == PL_op)
1210         return cop;
1211
1212     if (o->op_flags & OPf_KIDS) {
1213         const OP *kid;
1214         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
1215             const COP *new_cop;
1216
1217             /* If the OP_NEXTSTATE has been optimised away we can still use it
1218              * the get the file and line number. */
1219
1220             if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
1221                 cop = (const COP *)kid;
1222
1223             /* Keep searching, and return when we've found something. */
1224
1225             new_cop = closest_cop(cop, kid);
1226             if (new_cop)
1227                 return new_cop;
1228         }
1229     }
1230
1231     /* Nothing found. */
1232
1233     return NULL;
1234 }
1235
1236 /*
1237 =for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
1238
1239 Expands a message, intended for the user, to include an indication of
1240 the current location in the code, if the message does not already appear
1241 to be complete.
1242
1243 C<basemsg> is the initial message or object.  If it is a reference, it
1244 will be used as-is and will be the result of this function.  Otherwise it
1245 is used as a string, and if it already ends with a newline, it is taken
1246 to be complete, and the result of this function will be the same string.
1247 If the message does not end with a newline, then a segment such as C<at
1248 foo.pl line 37> will be appended, and possibly other clauses indicating
1249 the current state of execution.  The resulting message will end with a
1250 dot and a newline.
1251
1252 Normally, the resulting message is returned in a new mortal SV.
1253 During global destruction a single SV may be shared between uses of this
1254 function.  If C<consume> is true, then the function is permitted (but not
1255 required) to modify and return C<basemsg> instead of allocating a new SV.
1256
1257 =cut
1258 */
1259
1260 SV *
1261 Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
1262 {
1263     dVAR;
1264     SV *sv;
1265
1266     PERL_ARGS_ASSERT_MESS_SV;
1267
1268     if (SvROK(basemsg)) {
1269         if (consume) {
1270             sv = basemsg;
1271         }
1272         else {
1273             sv = mess_alloc();
1274             sv_setsv(sv, basemsg);
1275         }
1276         return sv;
1277     }
1278
1279     if (SvPOK(basemsg) && consume) {
1280         sv = basemsg;
1281     }
1282     else {
1283         sv = mess_alloc();
1284         sv_copypv(sv, basemsg);
1285     }
1286
1287     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
1288         /*
1289          * Try and find the file and line for PL_op.  This will usually be
1290          * PL_curcop, but it might be a cop that has been optimised away.  We
1291          * can try to find such a cop by searching through the optree starting
1292          * from the sibling of PL_curcop.
1293          */
1294
1295         const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
1296         if (!cop)
1297             cop = PL_curcop;
1298
1299         if (CopLINE(cop))
1300             Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
1301             OutCopFILE(cop), (IV)CopLINE(cop));
1302         /* Seems that GvIO() can be untrustworthy during global destruction. */
1303         if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO)
1304                 && IoLINES(GvIOp(PL_last_in_gv)))
1305         {
1306             STRLEN l;
1307             const bool line_mode = (RsSIMPLE(PL_rs) &&
1308                                    *SvPV_const(PL_rs,l) == '\n' && l == 1);
1309             Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf,
1310                            SVfARG(PL_last_in_gv == PL_argvgv
1311                                  ? &PL_sv_no
1312                                  : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))),
1313                            line_mode ? "line" : "chunk",
1314                            (IV)IoLINES(GvIOp(PL_last_in_gv)));
1315         }
1316         if (PL_phase == PERL_PHASE_DESTRUCT)
1317             sv_catpvs(sv, " during global destruction");
1318         sv_catpvs(sv, ".\n");
1319     }
1320     return sv;
1321 }
1322
1323 /*
1324 =for apidoc Am|SV *|vmess|const char *pat|va_list *args
1325
1326 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1327 argument list.  These are used to generate a string message.  If the
1328 message does not end with a newline, then it will be extended with
1329 some indication of the current location in the code, as described for
1330 L</mess_sv>.
1331
1332 Normally, the resulting message is returned in a new mortal SV.
1333 During global destruction a single SV may be shared between uses of
1334 this function.
1335
1336 =cut
1337 */
1338
1339 SV *
1340 Perl_vmess(pTHX_ const char *pat, va_list *args)
1341 {
1342     dVAR;
1343     SV * const sv = mess_alloc();
1344
1345     PERL_ARGS_ASSERT_VMESS;
1346
1347     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
1348     return mess_sv(sv, 1);
1349 }
1350
1351 void
1352 Perl_write_to_stderr(pTHX_ SV* msv)
1353 {
1354     dVAR;
1355     IO *io;
1356     MAGIC *mg;
1357
1358     PERL_ARGS_ASSERT_WRITE_TO_STDERR;
1359
1360     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
1361         && (io = GvIO(PL_stderrgv))
1362         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
1363         Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
1364                             G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
1365     else {
1366 #ifdef USE_SFIO
1367         /* SFIO can really mess with your errno */
1368         dSAVED_ERRNO;
1369 #endif
1370         PerlIO * const serr = Perl_error_log;
1371
1372         do_print(msv, serr);
1373         (void)PerlIO_flush(serr);
1374 #ifdef USE_SFIO
1375         RESTORE_ERRNO;
1376 #endif
1377     }
1378 }
1379
1380 /*
1381 =head1 Warning and Dieing
1382 */
1383
1384 /* Common code used in dieing and warning */
1385
1386 STATIC SV *
1387 S_with_queued_errors(pTHX_ SV *ex)
1388 {
1389     PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
1390     if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
1391         sv_catsv(PL_errors, ex);
1392         ex = sv_mortalcopy(PL_errors);
1393         SvCUR_set(PL_errors, 0);
1394     }
1395     return ex;
1396 }
1397
1398 STATIC bool
1399 S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
1400 {
1401     dVAR;
1402     HV *stash;
1403     GV *gv;
1404     CV *cv;
1405     SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1406     /* sv_2cv might call Perl_croak() or Perl_warner() */
1407     SV * const oldhook = *hook;
1408
1409     if (!oldhook)
1410         return FALSE;
1411
1412     ENTER;
1413     SAVESPTR(*hook);
1414     *hook = NULL;
1415     cv = sv_2cv(oldhook, &stash, &gv, 0);
1416     LEAVE;
1417     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1418         dSP;
1419         SV *exarg;
1420
1421         ENTER;
1422         save_re_context();
1423         if (warn) {
1424             SAVESPTR(*hook);
1425             *hook = NULL;
1426         }
1427         exarg = newSVsv(ex);
1428         SvREADONLY_on(exarg);
1429         SAVEFREESV(exarg);
1430
1431         PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
1432         PUSHMARK(SP);
1433         XPUSHs(exarg);
1434         PUTBACK;
1435         call_sv(MUTABLE_SV(cv), G_DISCARD);
1436         POPSTACK;
1437         LEAVE;
1438         return TRUE;
1439     }
1440     return FALSE;
1441 }
1442
1443 /*
1444 =for apidoc Am|OP *|die_sv|SV *baseex
1445
1446 Behaves the same as L</croak_sv>, except for the return type.
1447 It should be used only where the C<OP *> return type is required.
1448 The function never actually returns.
1449
1450 =cut
1451 */
1452
1453 OP *
1454 Perl_die_sv(pTHX_ SV *baseex)
1455 {
1456     PERL_ARGS_ASSERT_DIE_SV;
1457     croak_sv(baseex);
1458     assert(0); /* NOTREACHED */
1459     return NULL;
1460 }
1461
1462 /*
1463 =for apidoc Am|OP *|die|const char *pat|...
1464
1465 Behaves the same as L</croak>, except for the return type.
1466 It should be used only where the C<OP *> return type is required.
1467 The function never actually returns.
1468
1469 =cut
1470 */
1471
1472 #if defined(PERL_IMPLICIT_CONTEXT)
1473 OP *
1474 Perl_die_nocontext(const char* pat, ...)
1475 {
1476     dTHX;
1477     va_list args;
1478     va_start(args, pat);
1479     vcroak(pat, &args);
1480     assert(0); /* NOTREACHED */
1481     va_end(args);
1482     return NULL;
1483 }
1484 #endif /* PERL_IMPLICIT_CONTEXT */
1485
1486 OP *
1487 Perl_die(pTHX_ const char* pat, ...)
1488 {
1489     va_list args;
1490     va_start(args, pat);
1491     vcroak(pat, &args);
1492     assert(0); /* NOTREACHED */
1493     va_end(args);
1494     return NULL;
1495 }
1496
1497 /*
1498 =for apidoc Am|void|croak_sv|SV *baseex
1499
1500 This is an XS interface to Perl's C<die> function.
1501
1502 C<baseex> is the error message or object.  If it is a reference, it
1503 will be used as-is.  Otherwise it is used as a string, and if it does
1504 not end with a newline then it will be extended with some indication of
1505 the current location in the code, as described for L</mess_sv>.
1506
1507 The error message or object will be used as an exception, by default
1508 returning control to the nearest enclosing C<eval>, but subject to
1509 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak_sv>
1510 function never returns normally.
1511
1512 To die with a simple string message, the L</croak> function may be
1513 more convenient.
1514
1515 =cut
1516 */
1517
1518 void
1519 Perl_croak_sv(pTHX_ SV *baseex)
1520 {
1521     SV *ex = with_queued_errors(mess_sv(baseex, 0));
1522     PERL_ARGS_ASSERT_CROAK_SV;
1523     invoke_exception_hook(ex, FALSE);
1524     die_unwind(ex);
1525 }
1526
1527 /*
1528 =for apidoc Am|void|vcroak|const char *pat|va_list *args
1529
1530 This is an XS interface to Perl's C<die> function.
1531
1532 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1533 argument list.  These are used to generate a string message.  If the
1534 message does not end with a newline, then it will be extended with
1535 some indication of the current location in the code, as described for
1536 L</mess_sv>.
1537
1538 The error message will be used as an exception, by default
1539 returning control to the nearest enclosing C<eval>, but subject to
1540 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1541 function never returns normally.
1542
1543 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1544 (C<$@>) will be used as an error message or object instead of building an
1545 error message from arguments.  If you want to throw a non-string object,
1546 or build an error message in an SV yourself, it is preferable to use
1547 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1548
1549 =cut
1550 */
1551
1552 void
1553 Perl_vcroak(pTHX_ const char* pat, va_list *args)
1554 {
1555     SV *ex = with_queued_errors(pat ? vmess(pat, args) : mess_sv(ERRSV, 0));
1556     invoke_exception_hook(ex, FALSE);
1557     die_unwind(ex);
1558 }
1559
1560 /*
1561 =for apidoc Am|void|croak|const char *pat|...
1562
1563 This is an XS interface to Perl's C<die> function.
1564
1565 Take a sprintf-style format pattern and argument list.  These are used to
1566 generate a string message.  If the message does not end with a newline,
1567 then it will be extended with some indication of the current location
1568 in the code, as described for L</mess_sv>.
1569
1570 The error message will be used as an exception, by default
1571 returning control to the nearest enclosing C<eval>, but subject to
1572 modification by a C<$SIG{__DIE__}> handler.  In any case, the C<croak>
1573 function never returns normally.
1574
1575 For historical reasons, if C<pat> is null then the contents of C<ERRSV>
1576 (C<$@>) will be used as an error message or object instead of building an
1577 error message from arguments.  If you want to throw a non-string object,
1578 or build an error message in an SV yourself, it is preferable to use
1579 the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
1580
1581 =cut
1582 */
1583
1584 #if defined(PERL_IMPLICIT_CONTEXT)
1585 void
1586 Perl_croak_nocontext(const char *pat, ...)
1587 {
1588     dTHX;
1589     va_list args;
1590     va_start(args, pat);
1591     vcroak(pat, &args);
1592     assert(0); /* NOTREACHED */
1593     va_end(args);
1594 }
1595 #endif /* PERL_IMPLICIT_CONTEXT */
1596
1597 void
1598 Perl_croak(pTHX_ const char *pat, ...)
1599 {
1600     va_list args;
1601     va_start(args, pat);
1602     vcroak(pat, &args);
1603     assert(0); /* NOTREACHED */
1604     va_end(args);
1605 }
1606
1607 /*
1608 =for apidoc Am|void|croak_no_modify
1609
1610 Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
1611 terser object code than using C<Perl_croak>. Less code used on exception code
1612 paths reduces CPU cache pressure.
1613
1614 =cut
1615 */
1616
1617 void
1618 Perl_croak_no_modify()
1619 {
1620     Perl_croak_nocontext( "%s", PL_no_modify);
1621 }
1622
1623 /* does not return, used in util.c perlio.c and win32.c
1624    This is typically called when malloc returns NULL.
1625 */
1626 void
1627 Perl_croak_no_mem()
1628 {
1629     dTHX;
1630
1631     /* Can't use PerlIO to write as it allocates memory */
1632     PerlLIO_write(PerlIO_fileno(Perl_error_log),
1633                   PL_no_mem, sizeof(PL_no_mem)-1);
1634     my_exit(1);
1635 }
1636
1637 /*
1638 =for apidoc Am|void|warn_sv|SV *baseex
1639
1640 This is an XS interface to Perl's C<warn> function.
1641
1642 C<baseex> is the error message or object.  If it is a reference, it
1643 will be used as-is.  Otherwise it is used as a string, and if it does
1644 not end with a newline then it will be extended with some indication of
1645 the current location in the code, as described for L</mess_sv>.
1646
1647 The error message or object will by default be written to standard error,
1648 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1649
1650 To warn with a simple string message, the L</warn> function may be
1651 more convenient.
1652
1653 =cut
1654 */
1655
1656 void
1657 Perl_warn_sv(pTHX_ SV *baseex)
1658 {
1659     SV *ex = mess_sv(baseex, 0);
1660     PERL_ARGS_ASSERT_WARN_SV;
1661     if (!invoke_exception_hook(ex, TRUE))
1662         write_to_stderr(ex);
1663 }
1664
1665 /*
1666 =for apidoc Am|void|vwarn|const char *pat|va_list *args
1667
1668 This is an XS interface to Perl's C<warn> function.
1669
1670 C<pat> and C<args> are a sprintf-style format pattern and encapsulated
1671 argument list.  These are used to generate a string message.  If the
1672 message does not end with a newline, then it will be extended with
1673 some indication of the current location in the code, as described for
1674 L</mess_sv>.
1675
1676 The error message or object will by default be written to standard error,
1677 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1678
1679 Unlike with L</vcroak>, C<pat> is not permitted to be null.
1680
1681 =cut
1682 */
1683
1684 void
1685 Perl_vwarn(pTHX_ const char* pat, va_list *args)
1686 {
1687     SV *ex = vmess(pat, args);
1688     PERL_ARGS_ASSERT_VWARN;
1689     if (!invoke_exception_hook(ex, TRUE))
1690         write_to_stderr(ex);
1691 }
1692
1693 /*
1694 =for apidoc Am|void|warn|const char *pat|...
1695
1696 This is an XS interface to Perl's C<warn> function.
1697
1698 Take a sprintf-style format pattern and argument list.  These are used to
1699 generate a string message.  If the message does not end with a newline,
1700 then it will be extended with some indication of the current location
1701 in the code, as described for L</mess_sv>.
1702
1703 The error message or object will by default be written to standard error,
1704 but this is subject to modification by a C<$SIG{__WARN__}> handler.
1705
1706 Unlike with L</croak>, C<pat> is not permitted to be null.
1707
1708 =cut
1709 */
1710
1711 #if defined(PERL_IMPLICIT_CONTEXT)
1712 void
1713 Perl_warn_nocontext(const char *pat, ...)
1714 {
1715     dTHX;
1716     va_list args;
1717     PERL_ARGS_ASSERT_WARN_NOCONTEXT;
1718     va_start(args, pat);
1719     vwarn(pat, &args);
1720     va_end(args);
1721 }
1722 #endif /* PERL_IMPLICIT_CONTEXT */
1723
1724 void
1725 Perl_warn(pTHX_ const char *pat, ...)
1726 {
1727     va_list args;
1728     PERL_ARGS_ASSERT_WARN;
1729     va_start(args, pat);
1730     vwarn(pat, &args);
1731     va_end(args);
1732 }
1733
1734 #if defined(PERL_IMPLICIT_CONTEXT)
1735 void
1736 Perl_warner_nocontext(U32 err, const char *pat, ...)
1737 {
1738     dTHX; 
1739     va_list args;
1740     PERL_ARGS_ASSERT_WARNER_NOCONTEXT;
1741     va_start(args, pat);
1742     vwarner(err, pat, &args);
1743     va_end(args);
1744 }
1745 #endif /* PERL_IMPLICIT_CONTEXT */
1746
1747 void
1748 Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
1749 {
1750     PERL_ARGS_ASSERT_CK_WARNER_D;
1751
1752     if (Perl_ckwarn_d(aTHX_ err)) {
1753         va_list args;
1754         va_start(args, pat);
1755         vwarner(err, pat, &args);
1756         va_end(args);
1757     }
1758 }
1759
1760 void
1761 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
1762 {
1763     PERL_ARGS_ASSERT_CK_WARNER;
1764
1765     if (Perl_ckwarn(aTHX_ err)) {
1766         va_list args;
1767         va_start(args, pat);
1768         vwarner(err, pat, &args);
1769         va_end(args);
1770     }
1771 }
1772
1773 void
1774 Perl_warner(pTHX_ U32  err, const char* pat,...)
1775 {
1776     va_list args;
1777     PERL_ARGS_ASSERT_WARNER;
1778     va_start(args, pat);
1779     vwarner(err, pat, &args);
1780     va_end(args);
1781 }
1782
1783 void
1784 Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
1785 {
1786     dVAR;
1787     PERL_ARGS_ASSERT_VWARNER;
1788     if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
1789         SV * const msv = vmess(pat, args);
1790
1791         invoke_exception_hook(msv, FALSE);
1792         die_unwind(msv);
1793     }
1794     else {
1795         Perl_vwarn(aTHX_ pat, args);
1796     }
1797 }
1798
1799 /* implements the ckWARN? macros */
1800
1801 bool
1802 Perl_ckwarn(pTHX_ U32 w)
1803 {
1804     dVAR;
1805     /* If lexical warnings have not been set, use $^W.  */
1806     if (isLEXWARN_off)
1807         return PL_dowarn & G_WARN_ON;
1808
1809     return ckwarn_common(w);
1810 }
1811
1812 /* implements the ckWARN?_d macro */
1813
1814 bool
1815 Perl_ckwarn_d(pTHX_ U32 w)
1816 {
1817     dVAR;
1818     /* If lexical warnings have not been set then default classes warn.  */
1819     if (isLEXWARN_off)
1820         return TRUE;
1821
1822     return ckwarn_common(w);
1823 }
1824
1825 static bool
1826 S_ckwarn_common(pTHX_ U32 w)
1827 {
1828     if (PL_curcop->cop_warnings == pWARN_ALL)
1829         return TRUE;
1830
1831     if (PL_curcop->cop_warnings == pWARN_NONE)
1832         return FALSE;
1833
1834     /* Check the assumption that at least the first slot is non-zero.  */
1835     assert(unpackWARN1(w));
1836
1837     /* Check the assumption that it is valid to stop as soon as a zero slot is
1838        seen.  */
1839     if (!unpackWARN2(w)) {
1840         assert(!unpackWARN3(w));
1841         assert(!unpackWARN4(w));
1842     } else if (!unpackWARN3(w)) {
1843         assert(!unpackWARN4(w));
1844     }
1845         
1846     /* Right, dealt with all the special cases, which are implemented as non-
1847        pointers, so there is a pointer to a real warnings mask.  */
1848     do {
1849         if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
1850             return TRUE;
1851     } while (w >>= WARNshift);
1852
1853     return FALSE;
1854 }
1855
1856 /* Set buffer=NULL to get a new one.  */
1857 STRLEN *
1858 Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
1859                            STRLEN size) {
1860     const MEM_SIZE len_wanted =
1861         sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
1862     PERL_UNUSED_CONTEXT;
1863     PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
1864
1865     buffer = (STRLEN*)
1866         (specialWARN(buffer) ?
1867          PerlMemShared_malloc(len_wanted) :
1868          PerlMemShared_realloc(buffer, len_wanted));
1869     buffer[0] = size;
1870     Copy(bits, (buffer + 1), size, char);
1871     if (size < WARNsize)
1872         Zero((char *)(buffer + 1) + size, WARNsize - size, char);
1873     return buffer;
1874 }
1875
1876 /* since we've already done strlen() for both nam and val
1877  * we can use that info to make things faster than
1878  * sprintf(s, "%s=%s", nam, val)
1879  */
1880 #define my_setenv_format(s, nam, nlen, val, vlen) \
1881    Copy(nam, s, nlen, char); \
1882    *(s+nlen) = '='; \
1883    Copy(val, s+(nlen+1), vlen, char); \
1884    *(s+(nlen+1+vlen)) = '\0'
1885
1886 #ifdef USE_ENVIRON_ARRAY
1887        /* VMS' my_setenv() is in vms.c */
1888 #if !defined(WIN32) && !defined(NETWARE)
1889 void
1890 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1891 {
1892   dVAR;
1893 #ifdef USE_ITHREADS
1894   /* only parent thread can modify process environment */
1895   if (PL_curinterp == aTHX)
1896 #endif
1897   {
1898 #ifndef PERL_USE_SAFE_PUTENV
1899     if (!PL_use_safe_putenv) {
1900     /* most putenv()s leak, so we manipulate environ directly */
1901     I32 i;
1902     const I32 len = strlen(nam);
1903     int nlen, vlen;
1904
1905     /* where does it go? */
1906     for (i = 0; environ[i]; i++) {
1907         if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
1908             break;
1909     }
1910
1911     if (environ == PL_origenviron) {   /* need we copy environment? */
1912        I32 j;
1913        I32 max;
1914        char **tmpenv;
1915
1916        max = i;
1917        while (environ[max])
1918            max++;
1919        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1920        for (j=0; j<max; j++) {         /* copy environment */
1921            const int len = strlen(environ[j]);
1922            tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1923            Copy(environ[j], tmpenv[j], len+1, char);
1924        }
1925        tmpenv[max] = NULL;
1926        environ = tmpenv;               /* tell exec where it is now */
1927     }
1928     if (!val) {
1929        safesysfree(environ[i]);
1930        while (environ[i]) {
1931            environ[i] = environ[i+1];
1932            i++;
1933         }
1934        return;
1935     }
1936     if (!environ[i]) {                 /* does not exist yet */
1937        environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1938        environ[i+1] = NULL;    /* make sure it's null terminated */
1939     }
1940     else
1941        safesysfree(environ[i]);
1942        nlen = strlen(nam);
1943        vlen = strlen(val);
1944
1945        environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1946        /* all that work just for this */
1947        my_setenv_format(environ[i], nam, nlen, val, vlen);
1948     } else {
1949 # endif
1950 #   if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
1951 #       if defined(HAS_UNSETENV)
1952         if (val == NULL) {
1953             (void)unsetenv(nam);
1954         } else {
1955             (void)setenv(nam, val, 1);
1956         }
1957 #       else /* ! HAS_UNSETENV */
1958         (void)setenv(nam, val, 1);
1959 #       endif /* HAS_UNSETENV */
1960 #   else
1961 #       if defined(HAS_UNSETENV)
1962         if (val == NULL) {
1963             (void)unsetenv(nam);
1964         } else {
1965             const int nlen = strlen(nam);
1966             const int vlen = strlen(val);
1967             char * const new_env =
1968                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1969             my_setenv_format(new_env, nam, nlen, val, vlen);
1970             (void)putenv(new_env);
1971         }
1972 #       else /* ! HAS_UNSETENV */
1973         char *new_env;
1974         const int nlen = strlen(nam);
1975         int vlen;
1976         if (!val) {
1977            val = "";
1978         }
1979         vlen = strlen(val);
1980         new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1981         /* all that work just for this */
1982         my_setenv_format(new_env, nam, nlen, val, vlen);
1983         (void)putenv(new_env);
1984 #       endif /* HAS_UNSETENV */
1985 #   endif /* __CYGWIN__ */
1986 #ifndef PERL_USE_SAFE_PUTENV
1987     }
1988 #endif
1989   }
1990 }
1991
1992 #else /* WIN32 || NETWARE */
1993
1994 void
1995 Perl_my_setenv(pTHX_ const char *nam, const char *val)
1996 {
1997     dVAR;
1998     char *envstr;
1999     const int nlen = strlen(nam);
2000     int vlen;
2001
2002     if (!val) {
2003        val = "";
2004     }
2005     vlen = strlen(val);
2006     Newx(envstr, nlen+vlen+2, char);
2007     my_setenv_format(envstr, nam, nlen, val, vlen);
2008     (void)PerlEnv_putenv(envstr);
2009     Safefree(envstr);
2010 }
2011
2012 #endif /* WIN32 || NETWARE */
2013
2014 #endif /* !VMS && !EPOC*/
2015
2016 #ifdef UNLINK_ALL_VERSIONS
2017 I32
2018 Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
2019 {
2020     I32 retries = 0;
2021
2022     PERL_ARGS_ASSERT_UNLNK;
2023
2024     while (PerlLIO_unlink(f) >= 0)
2025         retries++;
2026     return retries ? 0 : -1;
2027 }
2028 #endif
2029
2030 /* this is a drop-in replacement for bcopy() */
2031 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
2032 char *
2033 Perl_my_bcopy(register const char *from,register char *to,register I32 len)
2034 {
2035     char * const retval = to;
2036
2037     PERL_ARGS_ASSERT_MY_BCOPY;
2038
2039     assert(len >= 0);
2040
2041     if (from - to >= 0) {
2042         while (len--)
2043             *to++ = *from++;
2044     }
2045     else {
2046         to += len;
2047         from += len;
2048         while (len--)
2049             *(--to) = *(--from);
2050     }
2051     return retval;
2052 }
2053 #endif
2054
2055 /* this is a drop-in replacement for memset() */
2056 #ifndef HAS_MEMSET
2057 void *
2058 Perl_my_memset(register char *loc, register I32 ch, register I32 len)
2059 {
2060     char * const retval = loc;
2061
2062     PERL_ARGS_ASSERT_MY_MEMSET;
2063
2064     assert(len >= 0);
2065
2066     while (len--)
2067         *loc++ = ch;
2068     return retval;
2069 }
2070 #endif
2071
2072 /* this is a drop-in replacement for bzero() */
2073 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
2074 char *
2075 Perl_my_bzero(register char *loc, register I32 len)
2076 {
2077     char * const retval = loc;
2078
2079     PERL_ARGS_ASSERT_MY_BZERO;
2080
2081     assert(len >= 0);
2082
2083     while (len--)
2084         *loc++ = 0;
2085     return retval;
2086 }
2087 #endif
2088
2089 /* this is a drop-in replacement for memcmp() */
2090 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
2091 I32
2092 Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
2093 {
2094     const U8 *a = (const U8 *)s1;
2095     const U8 *b = (const U8 *)s2;
2096     I32 tmp;
2097
2098     PERL_ARGS_ASSERT_MY_MEMCMP;
2099
2100     assert(len >= 0);
2101
2102     while (len--) {
2103         if ((tmp = *a++ - *b++))
2104             return tmp;
2105     }
2106     return 0;
2107 }
2108 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
2109
2110 #ifndef HAS_VPRINTF
2111 /* This vsprintf replacement should generally never get used, since
2112    vsprintf was available in both System V and BSD 2.11.  (There may
2113    be some cross-compilation or embedded set-ups where it is needed,
2114    however.)
2115
2116    If you encounter a problem in this function, it's probably a symptom
2117    that Configure failed to detect your system's vprintf() function.
2118    See the section on "item vsprintf" in the INSTALL file.
2119
2120    This version may compile on systems with BSD-ish <stdio.h>,
2121    but probably won't on others.
2122 */
2123
2124 #ifdef USE_CHAR_VSPRINTF
2125 char *
2126 #else
2127 int
2128 #endif
2129 vsprintf(char *dest, const char *pat, void *args)
2130 {
2131     FILE fakebuf;
2132
2133 #if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
2134     FILE_ptr(&fakebuf) = (STDCHAR *) dest;
2135     FILE_cnt(&fakebuf) = 32767;
2136 #else
2137     /* These probably won't compile -- If you really need
2138        this, you'll have to figure out some other method. */
2139     fakebuf._ptr = dest;
2140     fakebuf._cnt = 32767;
2141 #endif
2142 #ifndef _IOSTRG
2143 #define _IOSTRG 0
2144 #endif
2145     fakebuf._flag = _IOWRT|_IOSTRG;
2146     _doprnt(pat, args, &fakebuf);       /* what a kludge */
2147 #if defined(STDIO_PTR_LVALUE)
2148     *(FILE_ptr(&fakebuf)++) = '\0';
2149 #else
2150     /* PerlIO has probably #defined away fputc, but we want it here. */
2151 #  ifdef fputc
2152 #    undef fputc  /* XXX Should really restore it later */
2153 #  endif
2154     (void)fputc('\0', &fakebuf);
2155 #endif
2156 #ifdef USE_CHAR_VSPRINTF
2157     return(dest);
2158 #else
2159     return 0;           /* perl doesn't use return value */
2160 #endif
2161 }
2162
2163 #endif /* HAS_VPRINTF */
2164
2165 #ifdef MYSWAP
2166 #if BYTEORDER != 0x4321
2167 short
2168 Perl_my_swap(pTHX_ short s)
2169 {
2170 #if (BYTEORDER & 1) == 0
2171     short result;
2172
2173     result = ((s & 255) << 8) + ((s >> 8) & 255);
2174     return result;
2175 #else
2176     return s;
2177 #endif
2178 }
2179
2180 long
2181 Perl_my_htonl(pTHX_ long l)
2182 {
2183     union {
2184         long result;
2185         char c[sizeof(long)];
2186     } u;
2187
2188 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
2189 #if BYTEORDER == 0x12345678
2190     u.result = 0; 
2191 #endif 
2192     u.c[0] = (l >> 24) & 255;
2193     u.c[1] = (l >> 16) & 255;
2194     u.c[2] = (l >> 8) & 255;
2195     u.c[3] = l & 255;
2196     return u.result;
2197 #else
2198 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2199     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2200 #else
2201     I32 o;
2202     I32 s;
2203
2204     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2205         u.c[o & 0xf] = (l >> s) & 255;
2206     }
2207     return u.result;
2208 #endif
2209 #endif
2210 }
2211
2212 long
2213 Perl_my_ntohl(pTHX_ long l)
2214 {
2215     union {
2216         long l;
2217         char c[sizeof(long)];
2218     } u;
2219
2220 #if BYTEORDER == 0x1234
2221     u.c[0] = (l >> 24) & 255;
2222     u.c[1] = (l >> 16) & 255;
2223     u.c[2] = (l >> 8) & 255;
2224     u.c[3] = l & 255;
2225     return u.l;
2226 #else
2227 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
2228     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
2229 #else
2230     I32 o;
2231     I32 s;
2232
2233     u.l = l;
2234     l = 0;
2235     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
2236         l |= (u.c[o & 0xf] & 255) << s;
2237     }
2238     return l;
2239 #endif
2240 #endif
2241 }
2242
2243 #endif /* BYTEORDER != 0x4321 */
2244 #endif /* MYSWAP */
2245
2246 /*
2247  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
2248  * If these functions are defined,
2249  * the BYTEORDER is neither 0x1234 nor 0x4321.
2250  * However, this is not assumed.
2251  * -DWS
2252  */
2253
2254 #define HTOLE(name,type)                                        \
2255         type                                                    \
2256         name (register type n)                                  \
2257         {                                                       \
2258             union {                                             \
2259                 type value;                                     \
2260                 char c[sizeof(type)];                           \
2261             } u;                                                \
2262             U32 i;                                      \
2263             U32 s = 0;                                  \
2264             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2265                 u.c[i] = (n >> s) & 0xFF;                       \
2266             }                                                   \
2267             return u.value;                                     \
2268         }
2269
2270 #define LETOH(name,type)                                        \
2271         type                                                    \
2272         name (register type n)                                  \
2273         {                                                       \
2274             union {                                             \
2275                 type value;                                     \
2276                 char c[sizeof(type)];                           \
2277             } u;                                                \
2278             U32 i;                                      \
2279             U32 s = 0;                                  \
2280             u.value = n;                                        \
2281             n = 0;                                              \
2282             for (i = 0; i < sizeof(u.c); i++, s += 8) {         \
2283                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2284             }                                                   \
2285             return n;                                           \
2286         }
2287
2288 /*
2289  * Big-endian byte order functions.
2290  */
2291
2292 #define HTOBE(name,type)                                        \
2293         type                                                    \
2294         name (register type n)                                  \
2295         {                                                       \
2296             union {                                             \
2297                 type value;                                     \
2298                 char c[sizeof(type)];                           \
2299             } u;                                                \
2300             U32 i;                                      \
2301             U32 s = 8*(sizeof(u.c)-1);                  \
2302             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2303                 u.c[i] = (n >> s) & 0xFF;                       \
2304             }                                                   \
2305             return u.value;                                     \
2306         }
2307
2308 #define BETOH(name,type)                                        \
2309         type                                                    \
2310         name (register type n)                                  \
2311         {                                                       \
2312             union {                                             \
2313                 type value;                                     \
2314                 char c[sizeof(type)];                           \
2315             } u;                                                \
2316             U32 i;                                      \
2317             U32 s = 8*(sizeof(u.c)-1);                  \
2318             u.value = n;                                        \
2319             n = 0;                                              \
2320             for (i = 0; i < sizeof(u.c); i++, s -= 8) {         \
2321                 n |= ((type)(u.c[i] & 0xFF)) << s;              \
2322             }                                                   \
2323             return n;                                           \
2324         }
2325
2326 /*
2327  * If we just can't do it...
2328  */
2329
2330 #define NOT_AVAIL(name,type)                                    \
2331         type                                                    \
2332         name (register type n)                                  \
2333         {                                                       \
2334             Perl_croak_nocontext(#name "() not available");     \
2335             return n; /* not reached */                         \
2336         }
2337
2338
2339 #if defined(HAS_HTOVS) && !defined(htovs)
2340 HTOLE(htovs,short)
2341 #endif
2342 #if defined(HAS_HTOVL) && !defined(htovl)
2343 HTOLE(htovl,long)
2344 #endif
2345 #if defined(HAS_VTOHS) && !defined(vtohs)
2346 LETOH(vtohs,short)
2347 #endif
2348 #if defined(HAS_VTOHL) && !defined(vtohl)
2349 LETOH(vtohl,long)
2350 #endif
2351
2352 #ifdef PERL_NEED_MY_HTOLE16
2353 # if U16SIZE == 2
2354 HTOLE(Perl_my_htole16,U16)
2355 # else
2356 NOT_AVAIL(Perl_my_htole16,U16)
2357 # endif
2358 #endif
2359 #ifdef PERL_NEED_MY_LETOH16
2360 # if U16SIZE == 2
2361 LETOH(Perl_my_letoh16,U16)
2362 # else
2363 NOT_AVAIL(Perl_my_letoh16,U16)
2364 # endif
2365 #endif
2366 #ifdef PERL_NEED_MY_HTOBE16
2367 # if U16SIZE == 2
2368 HTOBE(Perl_my_htobe16,U16)
2369 # else
2370 NOT_AVAIL(Perl_my_htobe16,U16)
2371 # endif
2372 #endif
2373 #ifdef PERL_NEED_MY_BETOH16
2374 # if U16SIZE == 2
2375 BETOH(Perl_my_betoh16,U16)
2376 # else
2377 NOT_AVAIL(Perl_my_betoh16,U16)
2378 # endif
2379 #endif
2380
2381 #ifdef PERL_NEED_MY_HTOLE32
2382 # if U32SIZE == 4
2383 HTOLE(Perl_my_htole32,U32)
2384 # else
2385 NOT_AVAIL(Perl_my_htole32,U32)
2386 # endif
2387 #endif
2388 #ifdef PERL_NEED_MY_LETOH32
2389 # if U32SIZE == 4
2390 LETOH(Perl_my_letoh32,U32)
2391 # else
2392 NOT_AVAIL(Perl_my_letoh32,U32)
2393 # endif
2394 #endif
2395 #ifdef PERL_NEED_MY_HTOBE32
2396 # if U32SIZE == 4
2397 HTOBE(Perl_my_htobe32,U32)
2398 # else
2399 NOT_AVAIL(Perl_my_htobe32,U32)
2400 # endif
2401 #endif
2402 #ifdef PERL_NEED_MY_BETOH32
2403 # if U32SIZE == 4
2404 BETOH(Perl_my_betoh32,U32)
2405 # else
2406 NOT_AVAIL(Perl_my_betoh32,U32)
2407 # endif
2408 #endif
2409
2410 #ifdef PERL_NEED_MY_HTOLE64
2411 # if U64SIZE == 8
2412 HTOLE(Perl_my_htole64,U64)
2413 # else
2414 NOT_AVAIL(Perl_my_htole64,U64)
2415 # endif
2416 #endif
2417 #ifdef PERL_NEED_MY_LETOH64
2418 # if U64SIZE == 8
2419 LETOH(Perl_my_letoh64,U64)
2420 # else
2421 NOT_AVAIL(Perl_my_letoh64,U64)
2422 # endif
2423 #endif
2424 #ifdef PERL_NEED_MY_HTOBE64
2425 # if U64SIZE == 8
2426 HTOBE(Perl_my_htobe64,U64)
2427 # else
2428 NOT_AVAIL(Perl_my_htobe64,U64)
2429 # endif
2430 #endif
2431 #ifdef PERL_NEED_MY_BETOH64
2432 # if U64SIZE == 8
2433 BETOH(Perl_my_betoh64,U64)
2434 # else
2435 NOT_AVAIL(Perl_my_betoh64,U64)
2436 # endif
2437 #endif
2438
2439 #ifdef PERL_NEED_MY_HTOLES
2440 HTOLE(Perl_my_htoles,short)
2441 #endif
2442 #ifdef PERL_NEED_MY_LETOHS
2443 LETOH(Perl_my_letohs,short)
2444 #endif
2445 #ifdef PERL_NEED_MY_HTOBES
2446 HTOBE(Perl_my_htobes,short)
2447 #endif
2448 #ifdef PERL_NEED_MY_BETOHS
2449 BETOH(Perl_my_betohs,short)
2450 #endif
2451
2452 #ifdef PERL_NEED_MY_HTOLEI
2453 HTOLE(Perl_my_htolei,int)
2454 #endif
2455 #ifdef PERL_NEED_MY_LETOHI
2456 LETOH(Perl_my_letohi,int)
2457 #endif
2458 #ifdef PERL_NEED_MY_HTOBEI
2459 HTOBE(Perl_my_htobei,int)
2460 #endif
2461 #ifdef PERL_NEED_MY_BETOHI
2462 BETOH(Perl_my_betohi,int)
2463 #endif
2464
2465 #ifdef PERL_NEED_MY_HTOLEL
2466 HTOLE(Perl_my_htolel,long)
2467 #endif
2468 #ifdef PERL_NEED_MY_LETOHL
2469 LETOH(Perl_my_letohl,long)
2470 #endif
2471 #ifdef PERL_NEED_MY_HTOBEL
2472 HTOBE(Perl_my_htobel,long)
2473 #endif
2474 #ifdef PERL_NEED_MY_BETOHL
2475 BETOH(Perl_my_betohl,long)
2476 #endif
2477
2478 void
2479 Perl_my_swabn(void *ptr, int n)
2480 {
2481     char *s = (char *)ptr;
2482     char *e = s + (n-1);
2483     char tc;
2484
2485     PERL_ARGS_ASSERT_MY_SWABN;
2486
2487     for (n /= 2; n > 0; s++, e--, n--) {
2488       tc = *s;
2489       *s = *e;
2490       *e = tc;
2491     }
2492 }
2493
2494 PerlIO *
2495 Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
2496 {
2497 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
2498     dVAR;
2499     int p[2];
2500     I32 This, that;
2501     Pid_t pid;
2502     SV *sv;
2503     I32 did_pipes = 0;
2504     int pp[2];
2505
2506     PERL_ARGS_ASSERT_MY_POPEN_LIST;
2507
2508     PERL_FLUSHALL_FOR_CHILD;
2509     This = (*mode == 'w');
2510     that = !This;
2511     if (TAINTING_get) {
2512         taint_env();
2513         taint_proper("Insecure %s%s", "EXEC");
2514     }
2515     if (PerlProc_pipe(p) < 0)
2516         return NULL;
2517     /* Try for another pipe pair for error return */
2518     if (PerlProc_pipe(pp) >= 0)
2519         did_pipes = 1;
2520     while ((pid = PerlProc_fork()) < 0) {
2521         if (errno != EAGAIN) {
2522             PerlLIO_close(p[This]);
2523             PerlLIO_close(p[that]);
2524             if (did_pipes) {
2525                 PerlLIO_close(pp[0]);
2526                 PerlLIO_close(pp[1]);
2527             }
2528             return NULL;
2529         }
2530         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2531         sleep(5);
2532     }
2533     if (pid == 0) {
2534         /* Child */
2535 #undef THIS
2536 #undef THAT
2537 #define THIS that
2538 #define THAT This
2539         /* Close parent's end of error status pipe (if any) */
2540         if (did_pipes) {
2541             PerlLIO_close(pp[0]);
2542 #if defined(HAS_FCNTL) && defined(F_SETFD)
2543             /* Close error pipe automatically if exec works */
2544             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2545 #endif
2546         }
2547         /* Now dup our end of _the_ pipe to right position */
2548         if (p[THIS] != (*mode == 'r')) {
2549             PerlLIO_dup2(p[THIS], *mode == 'r');
2550             PerlLIO_close(p[THIS]);
2551             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2552                 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
2553         }
2554         else
2555             PerlLIO_close(p[THAT]);     /* close parent's end of _the_ pipe */
2556 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2557         /* No automatic close - do it by hand */
2558 #  ifndef NOFILE
2559 #  define NOFILE 20
2560 #  endif
2561         {
2562             int fd;
2563
2564             for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
2565                 if (fd != pp[1])
2566                     PerlLIO_close(fd);
2567             }
2568         }
2569 #endif
2570         do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
2571         PerlProc__exit(1);
2572 #undef THIS
2573 #undef THAT
2574     }
2575     /* Parent */
2576     do_execfree();      /* free any memory malloced by child on fork */
2577     if (did_pipes)
2578         PerlLIO_close(pp[1]);
2579     /* Keep the lower of the two fd numbers */
2580     if (p[that] < p[This]) {
2581         PerlLIO_dup2(p[This], p[that]);
2582         PerlLIO_close(p[This]);
2583         p[This] = p[that];
2584     }
2585     else
2586         PerlLIO_close(p[that]);         /* close child's end of pipe */
2587
2588     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2589     SvUPGRADE(sv,SVt_IV);
2590     SvIV_set(sv, pid);
2591     PL_forkprocess = pid;
2592     /* If we managed to get status pipe check for exec fail */
2593     if (did_pipes && pid > 0) {
2594         int errkid;
2595         unsigned n = 0;
2596         SSize_t n1;
2597
2598         while (n < sizeof(int)) {
2599             n1 = PerlLIO_read(pp[0],
2600                               (void*)(((char*)&errkid)+n),
2601                               (sizeof(int)) - n);
2602             if (n1 <= 0)
2603                 break;
2604             n += n1;
2605         }
2606         PerlLIO_close(pp[0]);
2607         did_pipes = 0;
2608         if (n) {                        /* Error */
2609             int pid2, status;
2610             PerlLIO_close(p[This]);
2611             if (n != sizeof(int))
2612                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2613             do {
2614                 pid2 = wait4pid(pid, &status, 0);
2615             } while (pid2 == -1 && errno == EINTR);
2616             errno = errkid;             /* Propagate errno from kid */
2617             return NULL;
2618         }
2619     }
2620     if (did_pipes)
2621          PerlLIO_close(pp[0]);
2622     return PerlIO_fdopen(p[This], mode);
2623 #else
2624 #  ifdef OS2    /* Same, without fork()ing and all extra overhead... */
2625     return my_syspopen4(aTHX_ NULL, mode, n, args);
2626 #  else
2627     Perl_croak(aTHX_ "List form of piped open not implemented");
2628     return (PerlIO *) NULL;
2629 #  endif
2630 #endif
2631 }
2632
2633     /* VMS' my_popen() is in VMS.c, same with OS/2. */
2634 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
2635 PerlIO *
2636 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2637 {
2638     dVAR;
2639     int p[2];
2640     I32 This, that;
2641     Pid_t pid;
2642     SV *sv;
2643     const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
2644     I32 did_pipes = 0;
2645     int pp[2];
2646
2647     PERL_ARGS_ASSERT_MY_POPEN;
2648
2649     PERL_FLUSHALL_FOR_CHILD;
2650 #ifdef OS2
2651     if (doexec) {
2652         return my_syspopen(aTHX_ cmd,mode);
2653     }
2654 #endif
2655     This = (*mode == 'w');
2656     that = !This;
2657     if (doexec && TAINTING_get) {
2658         taint_env();
2659         taint_proper("Insecure %s%s", "EXEC");
2660     }
2661     if (PerlProc_pipe(p) < 0)
2662         return NULL;
2663     if (doexec && PerlProc_pipe(pp) >= 0)
2664         did_pipes = 1;
2665     while ((pid = PerlProc_fork()) < 0) {
2666         if (errno != EAGAIN) {
2667             PerlLIO_close(p[This]);
2668             PerlLIO_close(p[that]);
2669             if (did_pipes) {
2670                 PerlLIO_close(pp[0]);
2671                 PerlLIO_close(pp[1]);
2672             }
2673             if (!doexec)
2674                 Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
2675             return NULL;
2676         }
2677         Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
2678         sleep(5);
2679     }
2680     if (pid == 0) {
2681
2682 #undef THIS
2683 #undef THAT
2684 #define THIS that
2685 #define THAT This
2686         if (did_pipes) {
2687             PerlLIO_close(pp[0]);
2688 #if defined(HAS_FCNTL) && defined(F_SETFD)
2689             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2690 #endif
2691         }
2692         if (p[THIS] != (*mode == 'r')) {
2693             PerlLIO_dup2(p[THIS], *mode == 'r');
2694             PerlLIO_close(p[THIS]);
2695             if (p[THAT] != (*mode == 'r'))      /* if dup2() didn't close it */
2696                 PerlLIO_close(p[THAT]);
2697         }
2698         else
2699             PerlLIO_close(p[THAT]);
2700 #ifndef OS2
2701         if (doexec) {
2702 #if !defined(HAS_FCNTL) || !defined(F_SETFD)
2703 #ifndef NOFILE
2704 #define NOFILE 20
2705 #endif
2706             {
2707                 int fd;
2708
2709                 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2710                     if (fd != pp[1])
2711                         PerlLIO_close(fd);
2712             }
2713 #endif
2714             /* may or may not use the shell */
2715             do_exec3(cmd, pp[1], did_pipes);
2716             PerlProc__exit(1);
2717         }
2718 #endif  /* defined OS2 */
2719
2720 #ifdef PERLIO_USING_CRLF
2721    /* Since we circumvent IO layers when we manipulate low-level
2722       filedescriptors directly, need to manually switch to the
2723       default, binary, low-level mode; see PerlIOBuf_open(). */
2724    PerlLIO_setmode((*mode == 'r'), O_BINARY);
2725 #endif 
2726         PL_forkprocess = 0;
2727 #ifdef PERL_USES_PL_PIDSTATUS
2728         hv_clear(PL_pidstatus); /* we have no children */
2729 #endif
2730         return NULL;
2731 #undef THIS
2732 #undef THAT
2733     }
2734     do_execfree();      /* free any memory malloced by child on vfork */
2735     if (did_pipes)
2736         PerlLIO_close(pp[1]);
2737     if (p[that] < p[This]) {
2738         PerlLIO_dup2(p[This], p[that]);
2739         PerlLIO_close(p[This]);
2740         p[This] = p[that];
2741     }
2742     else
2743         PerlLIO_close(p[that]);
2744
2745     sv = *av_fetch(PL_fdpid,p[This],TRUE);
2746     SvUPGRADE(sv,SVt_IV);
2747     SvIV_set(sv, pid);
2748     PL_forkprocess = pid;
2749     if (did_pipes && pid > 0) {
2750         int errkid;
2751         unsigned n = 0;
2752         SSize_t n1;
2753
2754         while (n < sizeof(int)) {
2755             n1 = PerlLIO_read(pp[0],
2756                               (void*)(((char*)&errkid)+n),
2757                               (sizeof(int)) - n);
2758             if (n1 <= 0)
2759                 break;
2760             n += n1;
2761         }
2762         PerlLIO_close(pp[0]);
2763         did_pipes = 0;
2764         if (n) {                        /* Error */
2765             int pid2, status;
2766             PerlLIO_close(p[This]);
2767             if (n != sizeof(int))
2768                 Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
2769             do {
2770                 pid2 = wait4pid(pid, &status, 0);
2771             } while (pid2 == -1 && errno == EINTR);
2772             errno = errkid;             /* Propagate errno from kid */
2773             return NULL;
2774         }
2775     }
2776     if (did_pipes)
2777          PerlLIO_close(pp[0]);
2778     return PerlIO_fdopen(p[This], mode);
2779 }
2780 #else
2781 #if defined(EPOC)
2782 FILE *popen();
2783 PerlIO *
2784 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2785 {
2786     PERL_ARGS_ASSERT_MY_POPEN;
2787     PERL_FLUSHALL_FOR_CHILD;
2788     /* Call system's popen() to get a FILE *, then import it.
2789        used 0 for 2nd parameter to PerlIO_importFILE;
2790        apparently not used
2791     */
2792     return PerlIO_importFILE(popen(cmd, mode), 0);
2793 }
2794 #else
2795 #if defined(DJGPP)
2796 FILE *djgpp_popen();
2797 PerlIO *
2798 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2799 {
2800     PERL_FLUSHALL_FOR_CHILD;
2801     /* Call system's popen() to get a FILE *, then import it.
2802        used 0 for 2nd parameter to PerlIO_importFILE;
2803        apparently not used
2804     */
2805     return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2806 }
2807 #else
2808 #if defined(__LIBCATAMOUNT__)
2809 PerlIO *
2810 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
2811 {
2812     return NULL;
2813 }
2814 #endif
2815 #endif
2816 #endif
2817
2818 #endif /* !DOSISH */
2819
2820 /* this is called in parent before the fork() */
2821 void
2822 Perl_atfork_lock(void)
2823 {
2824    dVAR;
2825 #if defined(USE_ITHREADS)
2826     /* locks must be held in locking order (if any) */
2827 #  ifdef MYMALLOC
2828     MUTEX_LOCK(&PL_malloc_mutex);
2829 #  endif
2830     OP_REFCNT_LOCK;
2831 #endif
2832 }
2833
2834 /* this is called in both parent and child after the fork() */
2835 void
2836 Perl_atfork_unlock(void)
2837 {
2838     dVAR;
2839 #if defined(USE_ITHREADS)
2840     /* locks must be released in same order as in atfork_lock() */
2841 #  ifdef MYMALLOC
2842     MUTEX_UNLOCK(&PL_malloc_mutex);
2843 #  endif
2844     OP_REFCNT_UNLOCK;
2845 #endif
2846 }
2847
2848 Pid_t
2849 Perl_my_fork(void)
2850 {
2851 #if defined(HAS_FORK)
2852     Pid_t pid;
2853 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
2854     atfork_lock();
2855     pid = fork();
2856     atfork_unlock();
2857 #else
2858     /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2859      * handlers elsewhere in the code */
2860     pid = fork();
2861 #endif
2862     return pid;
2863 #else
2864     /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2865     Perl_croak_nocontext("fork() not available");
2866     return 0;
2867 #endif /* HAS_FORK */
2868 }
2869
2870 #ifdef DUMP_FDS
2871 void
2872 Perl_dump_fds(pTHX_ const char *const s)
2873 {
2874     int fd;
2875     Stat_t tmpstatbuf;
2876
2877     PERL_ARGS_ASSERT_DUMP_FDS;
2878
2879     PerlIO_printf(Perl_debug_log,"%s", s);
2880     for (fd = 0; fd < 32; fd++) {
2881         if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
2882             PerlIO_printf(Perl_debug_log," %d",fd);
2883     }
2884     PerlIO_printf(Perl_debug_log,"\n");
2885     return;
2886 }
2887 #endif  /* DUMP_FDS */
2888
2889 #ifndef HAS_DUP2
2890 int
2891 dup2(int oldfd, int newfd)
2892 {
2893 #if defined(HAS_FCNTL) && defined(F_DUPFD)
2894     if (oldfd == newfd)
2895         return oldfd;
2896     PerlLIO_close(newfd);
2897     return fcntl(oldfd, F_DUPFD, newfd);
2898 #else
2899 #define DUP2_MAX_FDS 256
2900     int fdtmp[DUP2_MAX_FDS];
2901     I32 fdx = 0;
2902     int fd;
2903
2904     if (oldfd == newfd)
2905         return oldfd;
2906     PerlLIO_close(newfd);
2907     /* good enough for low fd's... */
2908     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
2909         if (fdx >= DUP2_MAX_FDS) {
2910             PerlLIO_close(fd);
2911             fd = -1;
2912             break;
2913         }
2914         fdtmp[fdx++] = fd;
2915     }
2916     while (fdx > 0)
2917         PerlLIO_close(fdtmp[--fdx]);
2918     return fd;
2919 #endif
2920 }
2921 #endif
2922
2923 #ifndef PERL_MICRO
2924 #ifdef HAS_SIGACTION
2925
2926 Sighandler_t
2927 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
2928 {
2929     dVAR;
2930     struct sigaction act, oact;
2931
2932 #ifdef USE_ITHREADS
2933     /* only "parent" interpreter can diddle signals */
2934     if (PL_curinterp != aTHX)
2935         return (Sighandler_t) SIG_ERR;
2936 #endif
2937
2938     act.sa_handler = (void(*)(int))handler;
2939     sigemptyset(&act.sa_mask);
2940     act.sa_flags = 0;
2941 #ifdef SA_RESTART
2942     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2943         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2944 #endif
2945 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2946     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2947         act.sa_flags |= SA_NOCLDWAIT;
2948 #endif
2949     if (sigaction(signo, &act, &oact) == -1)
2950         return (Sighandler_t) SIG_ERR;
2951     else
2952         return (Sighandler_t) oact.sa_handler;
2953 }
2954
2955 Sighandler_t
2956 Perl_rsignal_state(pTHX_ int signo)
2957 {
2958     struct sigaction oact;
2959     PERL_UNUSED_CONTEXT;
2960
2961     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
2962         return (Sighandler_t) SIG_ERR;
2963     else
2964         return (Sighandler_t) oact.sa_handler;
2965 }
2966
2967 int
2968 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
2969 {
2970     dVAR;
2971     struct sigaction act;
2972
2973     PERL_ARGS_ASSERT_RSIGNAL_SAVE;
2974
2975 #ifdef USE_ITHREADS
2976     /* only "parent" interpreter can diddle signals */
2977     if (PL_curinterp != aTHX)
2978         return -1;
2979 #endif
2980
2981     act.sa_handler = (void(*)(int))handler;
2982     sigemptyset(&act.sa_mask);
2983     act.sa_flags = 0;
2984 #ifdef SA_RESTART
2985     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2986         act.sa_flags |= SA_RESTART;     /* SVR4, 4.3+BSD */
2987 #endif
2988 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
2989     if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
2990         act.sa_flags |= SA_NOCLDWAIT;
2991 #endif
2992     return sigaction(signo, &act, save);
2993 }
2994
2995 int
2996 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
2997 {
2998     dVAR;
2999 #ifdef USE_ITHREADS
3000     /* only "parent" interpreter can diddle signals */
3001     if (PL_curinterp != aTHX)
3002         return -1;
3003 #endif
3004
3005     return sigaction(signo, save, (struct sigaction *)NULL);
3006 }
3007
3008 #else /* !HAS_SIGACTION */
3009
3010 Sighandler_t
3011 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
3012 {
3013 #if defined(USE_ITHREADS) && !defined(WIN32)
3014     /* only "parent" interpreter can diddle signals */
3015     if (PL_curinterp != aTHX)
3016         return (Sighandler_t) SIG_ERR;
3017 #endif
3018
3019     return PerlProc_signal(signo, handler);
3020 }
3021
3022 static Signal_t
3023 sig_trap(int signo)
3024 {
3025     dVAR;
3026     PL_sig_trapped++;
3027 }
3028
3029 Sighandler_t
3030 Perl_rsignal_state(pTHX_ int signo)
3031 {
3032     dVAR;
3033     Sighandler_t oldsig;
3034
3035 #if defined(USE_ITHREADS) && !defined(WIN32)
3036     /* only "parent" interpreter can diddle signals */
3037     if (PL_curinterp != aTHX)
3038         return (Sighandler_t) SIG_ERR;
3039 #endif
3040
3041     PL_sig_trapped = 0;
3042     oldsig = PerlProc_signal(signo, sig_trap);
3043     PerlProc_signal(signo, oldsig);
3044     if (PL_sig_trapped)
3045         PerlProc_kill(PerlProc_getpid(), signo);
3046     return oldsig;
3047 }
3048
3049 int
3050 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
3051 {
3052 #if defined(USE_ITHREADS) && !defined(WIN32)
3053     /* only "parent" interpreter can diddle signals */
3054     if (PL_curinterp != aTHX)
3055         return -1;
3056 #endif
3057     *save = PerlProc_signal(signo, handler);
3058     return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
3059 }
3060
3061 int
3062 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
3063 {
3064 #if defined(USE_ITHREADS) && !defined(WIN32)
3065     /* only "parent" interpreter can diddle signals */
3066     if (PL_curinterp != aTHX)
3067         return -1;
3068 #endif
3069     return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
3070 }
3071
3072 #endif /* !HAS_SIGACTION */
3073 #endif /* !PERL_MICRO */
3074
3075     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
3076 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(EPOC) && !defined(__LIBCATAMOUNT__)
3077 I32
3078 Perl_my_pclose(pTHX_ PerlIO *ptr)
3079 {
3080     dVAR;
3081     Sigsave_t hstat, istat, qstat;
3082     int status;
3083     SV **svp;
3084     Pid_t pid;
3085     Pid_t pid2 = 0;
3086     bool close_failed;
3087     dSAVEDERRNO;
3088     const int fd = PerlIO_fileno(ptr);
3089
3090 #ifdef USE_PERLIO
3091     /* Find out whether the refcount is low enough for us to wait for the
3092        child proc without blocking. */
3093     const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
3094 #else
3095     const bool should_wait = 1;
3096 #endif
3097
3098     svp = av_fetch(PL_fdpid,fd,TRUE);
3099     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
3100     SvREFCNT_dec(*svp);
3101     *svp = &PL_sv_undef;
3102 #ifdef OS2
3103     if (pid == -1) {                    /* Opened by popen. */
3104         return my_syspclose(ptr);
3105     }
3106 #endif
3107     close_failed = (PerlIO_close(ptr) == EOF);
3108     SAVE_ERRNO;
3109 #ifndef PERL_MICRO
3110     rsignal_save(SIGHUP,  (Sighandler_t) SIG_IGN, &hstat);
3111     rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &istat);
3112     rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
3113 #endif
3114     if (should_wait) do {
3115         pid2 = wait4pid(pid, &status, 0);
3116     } while (pid2 == -1 && errno == EINTR);
3117 #ifndef PERL_MICRO
3118     rsignal_restore(SIGHUP, &hstat);
3119     rsignal_restore(SIGINT, &istat);
3120     rsignal_restore(SIGQUIT, &qstat);
3121 #endif
3122     if (close_failed) {
3123         RESTORE_ERRNO;
3124         return -1;
3125     }
3126     return(
3127       should_wait
3128        ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
3129        : 0
3130     );
3131 }
3132 #else
3133 #if defined(__LIBCATAMOUNT__)
3134 I32
3135 Perl_my_pclose(pTHX_ PerlIO *ptr)
3136 {
3137     return -1;
3138 }
3139 #endif
3140 #endif /* !DOSISH */
3141
3142 #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
3143 I32
3144 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
3145 {
3146     dVAR;
3147     I32 result = 0;
3148     PERL_ARGS_ASSERT_WAIT4PID;
3149     if (!pid)
3150         return -1;
3151 #ifdef PERL_USES_PL_PIDSTATUS
3152     {
3153         if (pid > 0) {
3154             /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
3155                pid, rather than a string form.  */
3156             SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3157             if (svp && *svp != &PL_sv_undef) {
3158                 *statusp = SvIVX(*svp);
3159                 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
3160                                 G_DISCARD);
3161                 return pid;
3162             }
3163         }
3164         else {
3165             HE *entry;
3166
3167             hv_iterinit(PL_pidstatus);
3168             if ((entry = hv_iternext(PL_pidstatus))) {
3169                 SV * const sv = hv_iterval(PL_pidstatus,entry);
3170                 I32 len;
3171                 const char * const spid = hv_iterkey(entry,&len);
3172
3173                 assert (len == sizeof(Pid_t));
3174                 memcpy((char *)&pid, spid, len);
3175                 *statusp = SvIVX(sv);
3176                 /* The hash iterator is currently on this entry, so simply
3177                    calling hv_delete would trigger the lazy delete, which on
3178                    aggregate does more work, beacuse next call to hv_iterinit()
3179                    would spot the flag, and have to call the delete routine,
3180                    while in the meantime any new entries can't re-use that
3181                    memory.  */
3182                 hv_iterinit(PL_pidstatus);
3183                 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3184                 return pid;
3185             }
3186         }
3187     }
3188 #endif
3189 #ifdef HAS_WAITPID
3190 #  ifdef HAS_WAITPID_RUNTIME
3191     if (!HAS_WAITPID_RUNTIME)
3192         goto hard_way;
3193 #  endif
3194     result = PerlProc_waitpid(pid,statusp,flags);
3195     goto finish;
3196 #endif
3197 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
3198     result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
3199     goto finish;
3200 #endif
3201 #ifdef PERL_USES_PL_PIDSTATUS
3202 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
3203   hard_way:
3204 #endif
3205     {
3206         if (flags)
3207             Perl_croak(aTHX_ "Can't do waitpid with flags");
3208         else {
3209             while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
3210                 pidgone(result,*statusp);
3211             if (result < 0)
3212                 *statusp = -1;
3213         }
3214     }
3215 #endif
3216 #if defined(HAS_WAITPID) || defined(HAS_WAIT4)
3217   finish:
3218 #endif
3219     if (result < 0 && errno == EINTR) {
3220         PERL_ASYNC_CHECK();
3221         errno = EINTR; /* reset in case a signal handler changed $! */
3222     }
3223     return result;
3224 }
3225 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
3226
3227 #ifdef PERL_USES_PL_PIDSTATUS
3228 void
3229 S_pidgone(pTHX_ Pid_t pid, int status)
3230 {
3231     SV *sv;
3232
3233     sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
3234     SvUPGRADE(sv,SVt_IV);
3235     SvIV_set(sv, status);
3236     return;
3237 }
3238 #endif
3239
3240 #if defined(OS2) || defined(EPOC)
3241 int pclose();
3242 #ifdef HAS_FORK
3243 int                                     /* Cannot prototype with I32
3244                                            in os2ish.h. */
3245 my_syspclose(PerlIO *ptr)
3246 #else
3247 I32
3248 Perl_my_pclose(pTHX_ PerlIO *ptr)
3249 #endif
3250 {
3251     /* Needs work for PerlIO ! */
3252     FILE * const f = PerlIO_findFILE(ptr);
3253     const I32 result = pclose(f);
3254     PerlIO_releaseFILE(ptr,f);
3255     return result;
3256 }
3257 #endif
3258
3259 #if defined(DJGPP)
3260 int djgpp_pclose();
3261 I32
3262 Perl_my_pclose(pTHX_ PerlIO *ptr)
3263 {
3264     /* Needs work for PerlIO ! */
3265     FILE * const f = PerlIO_findFILE(ptr);
3266     I32 result = djgpp_pclose(f);
3267     result = (result << 8) & 0xff00;
3268     PerlIO_releaseFILE(ptr,f);
3269     return result;
3270 }
3271 #endif
3272
3273 #define PERL_REPEATCPY_LINEAR 4
3274 void
3275 Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count)
3276 {
3277     PERL_ARGS_ASSERT_REPEATCPY;
3278
3279     assert(len >= 0);
3280
3281     if (count < 0)
3282         croak_memory_wrap();
3283
3284     if (len == 1)
3285         memset(to, *from, count);
3286     else if (count) {
3287         char *p = to;
3288         IV items, linear, half;
3289
3290         linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
3291         for (items = 0; items < linear; ++items) {
3292             const char *q = from;
3293             IV todo;
3294             for (todo = len; todo > 0; todo--)
3295                 *p++ = *q++;
3296         }
3297
3298         half = count / 2;
3299         while (items <= half) {
3300             IV size = items * len;
3301             memcpy(p, to, size);
3302             p     += size;
3303             items *= 2;
3304         }
3305
3306         if (count > items)
3307             memcpy(p, to, (count - items) * len);
3308     }
3309 }
3310
3311 #ifndef HAS_RENAME
3312 I32
3313 Perl_same_dirent(pTHX_ const char *a, const char *b)
3314 {
3315     char *fa = strrchr(a,'/');
3316     char *fb = strrchr(b,'/');
3317     Stat_t tmpstatbuf1;
3318     Stat_t tmpstatbuf2;
3319     SV * const tmpsv = sv_newmortal();
3320
3321     PERL_ARGS_ASSERT_SAME_DIRENT;
3322
3323     if (fa)
3324         fa++;
3325     else
3326         fa = a;
3327     if (fb)
3328         fb++;
3329     else
3330         fb = b;
3331     if (strNE(a,b))
3332         return FALSE;
3333     if (fa == a)
3334         sv_setpvs(tmpsv, ".");
3335     else
3336         sv_setpvn(tmpsv, a, fa - a);
3337     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
3338         return FALSE;
3339     if (fb == b)
3340         sv_setpvs(tmpsv, ".");
3341     else
3342         sv_setpvn(tmpsv, b, fb - b);
3343     if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
3344         return FALSE;
3345     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
3346            tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
3347 }
3348 #endif /* !HAS_RENAME */
3349
3350 char*
3351 Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
3352                  const char *const *const search_ext, I32 flags)
3353 {
3354     dVAR;
3355     const char *xfound = NULL;
3356     char *xfailed = NULL;
3357     char tmpbuf[MAXPATHLEN];
3358     char *s;
3359     I32 len = 0;
3360     int retval;
3361     char *bufend;
3362 #if defined(DOSISH) && !defined(OS2)
3363 #  define SEARCH_EXTS ".bat", ".cmd", NULL
3364 #  define MAX_EXT_LEN 4
3365 #endif
3366 #ifdef OS2
3367 #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3368 #  define MAX_EXT_LEN 4
3369 #endif
3370 #ifdef VMS
3371 #  define SEARCH_EXTS ".pl", ".com", NULL
3372 #  define MAX_EXT_LEN 4
3373 #endif
3374     /* additional extensions to try in each dir if scriptname not found */
3375 #ifdef SEARCH_EXTS
3376     static const char *const exts[] = { SEARCH_EXTS };
3377     const char *const *const ext = search_ext ? search_ext : exts;
3378     int extidx = 0, i = 0;
3379     const char *curext = NULL;
3380 #else
3381     PERL_UNUSED_ARG(search_ext);
3382 #  define MAX_EXT_LEN 0
3383 #endif
3384
3385     PERL_ARGS_ASSERT_FIND_SCRIPT;
3386
3387     /*
3388      * If dosearch is true and if scriptname does not contain path
3389      * delimiters, search the PATH for scriptname.
3390      *
3391      * If SEARCH_EXTS is also defined, will look for each
3392      * scriptname{SEARCH_EXTS} whenever scriptname is not found
3393      * while searching the PATH.
3394      *
3395      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3396      * proceeds as follows:
3397      *   If DOSISH or VMSISH:
3398      *     + look for ./scriptname{,.foo,.bar}
3399      *     + search the PATH for scriptname{,.foo,.bar}
3400      *
3401      *   If !DOSISH:
3402      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
3403      *       this will not look in '.' if it's not in the PATH)
3404      */
3405     tmpbuf[0] = '\0';
3406
3407 #ifdef VMS
3408 #  ifdef ALWAYS_DEFTYPES
3409     len = strlen(scriptname);
3410     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
3411         int idx = 0, deftypes = 1;
3412         bool seen_dot = 1;
3413
3414         const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
3415 #  else
3416     if (dosearch) {
3417         int idx = 0, deftypes = 1;
3418         bool seen_dot = 1;
3419
3420         const int hasdir = (strpbrk(scriptname,":[</") != NULL);
3421 #  endif
3422         /* The first time through, just add SEARCH_EXTS to whatever we
3423          * already have, so we can check for default file types. */
3424         while (deftypes ||
3425                (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
3426         {
3427             if (deftypes) {
3428                 deftypes = 0;
3429                 *tmpbuf = '\0';
3430             }
3431             if ((strlen(tmpbuf) + strlen(scriptname)
3432                  + MAX_EXT_LEN) >= sizeof tmpbuf)
3433                 continue;       /* don't search dir with too-long name */
3434             my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
3435 #else  /* !VMS */
3436
3437 #ifdef DOSISH
3438     if (strEQ(scriptname, "-"))
3439         dosearch = 0;
3440     if (dosearch) {             /* Look in '.' first. */
3441         const char *cur = scriptname;
3442 #ifdef SEARCH_EXTS
3443         if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3444             while (ext[i])
3445                 if (strEQ(ext[i++],curext)) {
3446                     extidx = -1;                /* already has an ext */
3447                     break;
3448                 }
3449         do {
3450 #endif
3451             DEBUG_p(PerlIO_printf(Perl_debug_log,
3452                                   "Looking for %s\n",cur));
3453             if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3454                 && !S_ISDIR(PL_statbuf.st_mode)) {
3455                 dosearch = 0;
3456                 scriptname = cur;
3457 #ifdef SEARCH_EXTS
3458                 break;
3459 #endif
3460             }
3461 #ifdef SEARCH_EXTS
3462             if (cur == scriptname) {
3463                 len = strlen(scriptname);
3464                 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
3465                     break;
3466                 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3467                 cur = tmpbuf;
3468             }
3469         } while (extidx >= 0 && ext[extidx]     /* try an extension? */
3470                  && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
3471 #endif
3472     }
3473 #endif
3474
3475     if (dosearch && !strchr(scriptname, '/')
3476 #ifdef DOSISH
3477                  && !strchr(scriptname, '\\')
3478 #endif
3479                  && (s = PerlEnv_getenv("PATH")))
3480     {
3481         bool seen_dot = 0;
3482
3483         bufend = s + strlen(s);
3484         while (s < bufend) {
3485 #  ifdef DOSISH
3486             for (len = 0; *s
3487                     && *s != ';'; len++, s++) {
3488                 if (len < sizeof tmpbuf)
3489                     tmpbuf[len] = *s;
3490             }
3491             if (len < sizeof tmpbuf)
3492                 tmpbuf[len] = '\0';
3493 #  else
3494             s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
3495                         ':',
3496                         &len);
3497 #  endif
3498             if (s < bufend)
3499                 s++;
3500             if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
3501                 continue;       /* don't search dir with too-long name */
3502             if (len
3503 #  ifdef DOSISH
3504                 && tmpbuf[len - 1] != '/'
3505                 && tmpbuf[len - 1] != '\\'
3506 #  endif
3507                )
3508                 tmpbuf[len++] = '/';
3509             if (len == 2 && tmpbuf[0] == '.')
3510                 seen_dot = 1;
3511             (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
3512 #endif  /* !VMS */
3513
3514 #ifdef SEARCH_EXTS
3515             len = strlen(tmpbuf);
3516             if (extidx > 0)     /* reset after previous loop */
3517                 extidx = 0;
3518             do {
3519 #endif
3520                 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3521                 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
3522                 if (S_ISDIR(PL_statbuf.st_mode)) {
3523                     retval = -1;
3524                 }
3525 #ifdef SEARCH_EXTS
3526             } while (  retval < 0               /* not there */
3527                     && extidx>=0 && ext[extidx] /* try an extension? */
3528                     && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
3529                 );
3530 #endif
3531             if (retval < 0)
3532                 continue;
3533             if (S_ISREG(PL_statbuf.st_mode)
3534                 && cando(S_IRUSR,TRUE,&PL_statbuf)
3535 #if !defined(DOSISH)
3536                 && cando(S_IXUSR,TRUE,&PL_statbuf)
3537 #endif
3538                 )
3539             {
3540                 xfound = tmpbuf;                /* bingo! */
3541                 break;
3542             }
3543             if (!xfailed)
3544                 xfailed = savepv(tmpbuf);
3545         }
3546 #ifndef DOSISH
3547         if (!xfound && !seen_dot && !xfailed &&
3548             (PerlLIO_stat(scriptname,&PL_statbuf) < 0
3549              || S_ISDIR(PL_statbuf.st_mode)))
3550 #endif
3551             seen_dot = 1;                       /* Disable message. */
3552         if (!xfound) {
3553             if (flags & 1) {                    /* do or die? */
3554                 /* diag_listed_as: Can't execute %s */
3555                 Perl_croak(aTHX_ "Can't %s %s%s%s",
3556                       (xfailed ? "execute" : "find"),
3557                       (xfailed ? xfailed : scriptname),
3558                       (xfailed ? "" : " on PATH"),
3559                       (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3560             }
3561             scriptname = NULL;
3562         }
3563         Safefree(xfailed);
3564         scriptname = xfound;
3565     }
3566     return (scriptname ? savepv(scriptname) : NULL);
3567 }
3568
3569 #ifndef PERL_GET_CONTEXT_DEFINED
3570
3571 void *
3572 Perl_get_context(void)
3573 {
3574     dVAR;
3575 #if defined(USE_ITHREADS)
3576 #  ifdef OLD_PTHREADS_API
3577     pthread_addr_t t;
3578     int error = pthread_getspecific(PL_thr_key, &t)
3579     if (error)
3580         Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
3581     return (void*)t;
3582 #  else
3583 #    ifdef I_MACH_CTHREADS
3584     return (void*)cthread_data(cthread_self());
3585 #    else
3586     return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3587 #    endif
3588 #  endif
3589 #else
3590     return (void*)NULL;
3591 #endif
3592 }
3593
3594 void
3595 Perl_set_context(void *t)
3596 {
3597     dVAR;
3598     PERL_ARGS_ASSERT_SET_CONTEXT;
3599 #if defined(USE_ITHREADS)
3600 #  ifdef I_MACH_CTHREADS
3601     cthread_set_data(cthread_self(), t);
3602 #  else
3603     {
3604         const int error = pthread_setspecific(PL_thr_key, t);
3605         if (error)
3606             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
3607     }
3608 #  endif
3609 #else
3610     PERL_UNUSED_ARG(t);
3611 #endif
3612 }
3613
3614 #endif /* !PERL_GET_CONTEXT_DEFINED */
3615
3616 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
3617 struct perl_vars *
3618 Perl_GetVars(pTHX)
3619 {
3620  return &PL_Vars;
3621 }
3622 #endif
3623
3624 char **
3625 Perl_get_op_names(pTHX)
3626 {
3627     PERL_UNUSED_CONTEXT;
3628     return (char **)PL_op_name;
3629 }
3630
3631 char **
3632 Perl_get_op_descs(pTHX)
3633 {
3634     PERL_UNUSED_CONTEXT;
3635     return (char **)PL_op_desc;
3636 }
3637
3638 const char *
3639 Perl_get_no_modify(pTHX)
3640 {
3641     PERL_UNUSED_CONTEXT;
3642     return PL_no_modify;
3643 }
3644
3645 U32 *
3646 Perl_get_opargs(pTHX)
3647 {
3648     PERL_UNUSED_CONTEXT;
3649     return (U32 *)PL_opargs;
3650 }
3651
3652 PPADDR_t*
3653 Perl_get_ppaddr(pTHX)
3654 {
3655     dVAR;
3656     PERL_UNUSED_CONTEXT;
3657     return (PPADDR_t*)PL_ppaddr;
3658 }
3659
3660 #ifndef HAS_GETENV_LEN
3661 char *
3662 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
3663 {
3664     char * const env_trans = PerlEnv_getenv(env_elem);
3665     PERL_UNUSED_CONTEXT;
3666     PERL_ARGS_ASSERT_GETENV_LEN;
3667     if (env_trans)
3668         *len = strlen(env_trans);
3669     return env_trans;
3670 }
3671 #endif
3672
3673
3674 MGVTBL*
3675 Perl_get_vtbl(pTHX_ int vtbl_id)
3676 {
3677     PERL_UNUSED_CONTEXT;
3678
3679     return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
3680         ? NULL : PL_magic_vtables + vtbl_id;
3681 }
3682
3683 I32
3684 Perl_my_fflush_all(pTHX)
3685 {
3686 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
3687     return PerlIO_flush(NULL);
3688 #else
3689 # if defined(HAS__FWALK)
3690     extern int fflush(FILE *);
3691     /* undocumented, unprototyped, but very useful BSDism */
3692     extern void _fwalk(int (*)(FILE *));
3693     _fwalk(&fflush);
3694     return 0;
3695 # else
3696 #  if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
3697     long open_max = -1;
3698 #   ifdef PERL_FFLUSH_ALL_FOPEN_MAX
3699     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
3700 #   else
3701 #    if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
3702     open_max = sysconf(_SC_OPEN_MAX);
3703 #     else
3704 #      ifdef FOPEN_MAX
3705     open_max = FOPEN_MAX;
3706 #      else
3707 #       ifdef OPEN_MAX
3708     open_max = OPEN_MAX;
3709 #       else
3710 #        ifdef _NFILE
3711     open_max = _NFILE;
3712 #        endif
3713 #       endif
3714 #      endif
3715 #     endif
3716 #    endif
3717     if (open_max > 0) {
3718       long i;
3719       for (i = 0; i < open_max; i++)
3720             if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3721                 STDIO_STREAM_ARRAY[i]._file < open_max &&
3722                 STDIO_STREAM_ARRAY[i]._flag)
3723                 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
3724       return 0;
3725     }
3726 #  endif
3727     SETERRNO(EBADF,RMS_IFI);
3728     return EOF;
3729 # endif
3730 #endif
3731 }
3732
3733 void
3734 Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have)
3735 {
3736     if (ckWARN(WARN_IO)) {
3737         HEK * const name
3738            = gv && (isGV_with_GP(gv))
3739                 ? GvENAME_HEK((gv))
3740                 : NULL;
3741         const char * const direction = have == '>' ? "out" : "in";
3742
3743         if (name && HEK_LEN(name))
3744             Perl_warner(aTHX_ packWARN(WARN_IO),
3745                         "Filehandle %"HEKf" opened only for %sput",
3746                         name, direction);
3747         else
3748             Perl_warner(aTHX_ packWARN(WARN_IO),
3749                         "Filehandle opened only for %sput", direction);
3750     }
3751 }
3752
3753 void
3754 Perl_report_evil_fh(pTHX_ const GV *gv)
3755 {
3756     const IO *io = gv ? GvIO(gv) : NULL;
3757     const PERL_BITFIELD16 op = PL_op->op_type;
3758     const char *vile;
3759     I32 warn_type;
3760
3761     if (io && IoTYPE(io) == IoTYPE_CLOSED) {
3762         vile = "closed";
3763         warn_type = WARN_CLOSED;
3764     }
3765     else {
3766         vile = "unopened";
3767         warn_type = WARN_UNOPENED;
3768     }
3769
3770     if (ckWARN(warn_type)) {
3771         SV * const name
3772             = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ?
3773                                      sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL;
3774         const char * const pars =
3775             (const char *)(OP_IS_FILETEST(op) ? "" : "()");
3776         const char * const func =
3777             (const char *)
3778             (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
3779              op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
3780              PL_op_desc[op]);
3781         const char * const type =
3782             (const char *)
3783             (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
3784              ? "socket" : "filehandle");
3785         const bool have_name = name && SvCUR(name);
3786         Perl_warner(aTHX_ packWARN(warn_type),
3787                    "%s%s on %s %s%s%"SVf, func, pars, vile, type,
3788                     have_name ? " " : "",
3789                     SVfARG(have_name ? name : &PL_sv_no));
3790         if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3791                 Perl_warner(
3792                             aTHX_ packWARN(warn_type),
3793                         "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
3794                         func, pars, have_name ? " " : "",
3795                         SVfARG(have_name ? name : &PL_sv_no)
3796                             );
3797     }
3798 }
3799
3800 /* To workaround core dumps from the uninitialised tm_zone we get the
3801  * system to give us a reasonable struct to copy.  This fix means that
3802  * strftime uses the tm_zone and tm_gmtoff values returned by
3803  * localtime(time()). That should give the desired result most of the
3804  * time. But probably not always!
3805  *
3806  * This does not address tzname aspects of NETaa14816.
3807  *
3808  */
3809
3810 #ifdef HAS_GNULIBC
3811 # ifndef STRUCT_TM_HASZONE
3812 #    define STRUCT_TM_HASZONE
3813 # endif
3814 #endif
3815
3816 #ifdef STRUCT_TM_HASZONE /* Backward compat */
3817 # ifndef HAS_TM_TM_ZONE
3818 #    define HAS_TM_TM_ZONE
3819 # endif
3820 #endif
3821
3822 void
3823 Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
3824 {
3825 #ifdef HAS_TM_TM_ZONE
3826     Time_t now;
3827     const struct tm* my_tm;
3828     PERL_ARGS_ASSERT_INIT_TM;
3829     (void)time(&now);
3830     my_tm = localtime(&now);
3831     if (my_tm)
3832         Copy(my_tm, ptm, 1, struct tm);
3833 #else
3834     PERL_ARGS_ASSERT_INIT_TM;
3835     PERL_UNUSED_ARG(ptm);
3836 #endif
3837 }
3838
3839 /*
3840  * mini_mktime - normalise struct tm values without the localtime()
3841  * semantics (and overhead) of mktime().
3842  */
3843 void
3844 Perl_mini_mktime(pTHX_ struct tm *ptm)
3845 {
3846     int yearday;
3847     int secs;
3848     int month, mday, year, jday;
3849     int odd_cent, odd_year;
3850     PERL_UNUSED_CONTEXT;
3851
3852     PERL_ARGS_ASSERT_MINI_MKTIME;
3853
3854 #define DAYS_PER_YEAR   365
3855 #define DAYS_PER_QYEAR  (4*DAYS_PER_YEAR+1)
3856 #define DAYS_PER_CENT   (25*DAYS_PER_QYEAR-1)
3857 #define DAYS_PER_QCENT  (4*DAYS_PER_CENT+1)
3858 #define SECS_PER_HOUR   (60*60)
3859 #define SECS_PER_DAY    (24*SECS_PER_HOUR)
3860 /* parentheses deliberately absent on these two, otherwise they don't work */
3861 #define MONTH_TO_DAYS   153/5
3862 #define DAYS_TO_MONTH   5/153
3863 /* offset to bias by March (month 4) 1st between month/mday & year finding */
3864 #define YEAR_ADJUST     (4*MONTH_TO_DAYS+1)
3865 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3866 #define WEEKDAY_BIAS    6       /* (1+6)%7 makes Sunday 0 again */
3867
3868 /*
3869  * Year/day algorithm notes:
3870  *
3871  * With a suitable offset for numeric value of the month, one can find
3872  * an offset into the year by considering months to have 30.6 (153/5) days,
3873  * using integer arithmetic (i.e., with truncation).  To avoid too much
3874  * messing about with leap days, we consider January and February to be
3875  * the 13th and 14th month of the previous year.  After that transformation,
3876  * we need the month index we use to be high by 1 from 'normal human' usage,
3877  * so the month index values we use run from 4 through 15.
3878  *
3879  * Given that, and the rules for the Gregorian calendar (leap years are those
3880  * divisible by 4 unless also divisible by 100, when they must be divisible
3881  * by 400 instead), we can simply calculate the number of days since some
3882  * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3883  * the days we derive from our month index, and adding in the day of the
3884  * month.  The value used here is not adjusted for the actual origin which
3885  * it normally would use (1 January A.D. 1), since we're not exposing it.
3886  * We're only building the value so we can turn around and get the
3887  * normalised values for the year, month, day-of-month, and day-of-year.
3888  *
3889  * For going backward, we need to bias the value we're using so that we find
3890  * the right year value.  (Basically, we don't want the contribution of
3891  * March 1st to the number to apply while deriving the year).  Having done
3892  * that, we 'count up' the contribution to the year number by accounting for
3893  * full quadracenturies (400-year periods) with their extra leap days, plus
3894  * the contribution from full centuries (to avoid counting in the lost leap
3895  * days), plus the contribution from full quad-years (to count in the normal
3896  * leap days), plus the leftover contribution from any non-leap years.
3897  * At this point, if we were working with an actual leap day, we'll have 0
3898  * days left over.  This is also true for March 1st, however.  So, we have
3899  * to special-case that result, and (earlier) keep track of the 'odd'
3900  * century and year contributions.  If we got 4 extra centuries in a qcent,
3901  * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3902  * Otherwise, we add back in the earlier bias we removed (the 123 from
3903  * figuring in March 1st), find the month index (integer division by 30.6),
3904  * and the remainder is the day-of-month.  We then have to convert back to
3905  * 'real' months (including fixing January and February from being 14/15 in
3906  * the previous year to being in the proper year).  After that, to get
3907  * tm_yday, we work with the normalised year and get a new yearday value for
3908  * January 1st, which we subtract from the yearday value we had earlier,
3909  * representing the date we've re-built.  This is done from January 1
3910  * because tm_yday is 0-origin.
3911  *
3912  * Since POSIX time routines are only guaranteed to work for times since the
3913  * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3914  * applies Gregorian calendar rules even to dates before the 16th century
3915  * doesn't bother me.  Besides, you'd need cultural context for a given
3916  * date to know whether it was Julian or Gregorian calendar, and that's
3917  * outside the scope for this routine.  Since we convert back based on the
3918  * same rules we used to build the yearday, you'll only get strange results
3919  * for input which needed normalising, or for the 'odd' century years which
3920  * were leap years in the Julian calendar but not in the Gregorian one.
3921  * I can live with that.
3922  *
3923  * This algorithm also fails to handle years before A.D. 1 gracefully, but
3924  * that's still outside the scope for POSIX time manipulation, so I don't
3925  * care.
3926  */
3927
3928     year = 1900 + ptm->tm_year;
3929     month = ptm->tm_mon;
3930     mday = ptm->tm_mday;
3931     jday = 0;
3932     if (month >= 2)
3933         month+=2;
3934     else
3935         month+=14, year--;
3936     yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3937     yearday += month*MONTH_TO_DAYS + mday + jday;
3938     /*
3939      * Note that we don't know when leap-seconds were or will be,
3940      * so we have to trust the user if we get something which looks
3941      * like a sensible leap-second.  Wild values for seconds will
3942      * be rationalised, however.
3943      */
3944     if ((unsigned) ptm->tm_sec <= 60) {
3945         secs = 0;
3946     }
3947     else {
3948         secs = ptm->tm_sec;
3949         ptm->tm_sec = 0;
3950     }
3951     secs += 60 * ptm->tm_min;
3952     secs += SECS_PER_HOUR * ptm->tm_hour;
3953     if (secs < 0) {
3954         if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3955             /* got negative remainder, but need positive time */
3956             /* back off an extra day to compensate */
3957             yearday += (secs/SECS_PER_DAY)-1;
3958             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3959         }
3960         else {
3961             yearday += (secs/SECS_PER_DAY);
3962             secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3963         }
3964     }
3965     else if (secs >= SECS_PER_DAY) {
3966         yearday += (secs/SECS_PER_DAY);
3967         secs %= SECS_PER_DAY;
3968     }
3969     ptm->tm_hour = secs/SECS_PER_HOUR;
3970     secs %= SECS_PER_HOUR;
3971     ptm->tm_min = secs/60;
3972     secs %= 60;
3973     ptm->tm_sec += secs;
3974     /* done with time of day effects */
3975     /*
3976      * The algorithm for yearday has (so far) left it high by 428.
3977      * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3978      * bias it by 123 while trying to figure out what year it
3979      * really represents.  Even with this tweak, the reverse
3980      * translation fails for years before A.D. 0001.
3981      * It would still fail for Feb 29, but we catch that one below.
3982      */
3983     jday = yearday;     /* save for later fixup vis-a-vis Jan 1 */
3984     yearday -= YEAR_ADJUST;
3985     year = (yearday / DAYS_PER_QCENT) * 400;
3986     yearday %= DAYS_PER_QCENT;
3987     odd_cent = yearday / DAYS_PER_CENT;
3988     year += odd_cent * 100;
3989     yearday %= DAYS_PER_CENT;
3990     year += (yearday / DAYS_PER_QYEAR) * 4;
3991     yearday %= DAYS_PER_QYEAR;
3992     odd_year = yearday / DAYS_PER_YEAR;
3993     year += odd_year;
3994     yearday %= DAYS_PER_YEAR;
3995     if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3996         month = 1;
3997         yearday = 29;
3998     }
3999     else {
4000         yearday += YEAR_ADJUST; /* recover March 1st crock */
4001         month = yearday*DAYS_TO_MONTH;
4002         yearday -= month*MONTH_TO_DAYS;
4003         /* recover other leap-year adjustment */
4004         if (month > 13) {
4005             month-=14;
4006             year++;
4007         }
4008         else {
4009             month-=2;
4010         }
4011     }
4012     ptm->tm_year = year - 1900;
4013     if (yearday) {
4014       ptm->tm_mday = yearday;
4015       ptm->tm_mon = month;
4016     }
4017     else {
4018       ptm->tm_mday = 31;
4019       ptm->tm_mon = month - 1;
4020     }
4021     /* re-build yearday based on Jan 1 to get tm_yday */
4022     year--;
4023     yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
4024     yearday += 14*MONTH_TO_DAYS + 1;
4025     ptm->tm_yday = jday - yearday;
4026     ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
4027 }
4028
4029 char *
4030 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)
4031 {
4032 #ifdef HAS_STRFTIME
4033   char *buf;
4034   int buflen;
4035   struct tm mytm;
4036   int len;
4037
4038   PERL_ARGS_ASSERT_MY_STRFTIME;
4039
4040   init_tm(&mytm);       /* XXX workaround - see init_tm() above */
4041   mytm.tm_sec = sec;
4042   mytm.tm_min = min;
4043   mytm.tm_hour = hour;
4044   mytm.tm_mday = mday;
4045   mytm.tm_mon = mon;
4046   mytm.tm_year = year;
4047   mytm.tm_wday = wday;
4048   mytm.tm_yday = yday;
4049   mytm.tm_isdst = isdst;
4050   mini_mktime(&mytm);
4051   /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
4052 #if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
4053   STMT_START {
4054     struct tm mytm2;
4055     mytm2 = mytm;
4056     mktime(&mytm2);
4057 #ifdef HAS_TM_TM_GMTOFF
4058     mytm.tm_gmtoff = mytm2.tm_gmtoff;
4059 #endif
4060 #ifdef HAS_TM_TM_ZONE
4061     mytm.tm_zone = mytm2.tm_zone;
4062 #endif
4063   } STMT_END;
4064 #endif
4065   buflen = 64;
4066   Newx(buf, buflen, char);
4067   len = strftime(buf, buflen, fmt, &mytm);
4068   /*
4069   ** The following is needed to handle to the situation where
4070   ** tmpbuf overflows.  Basically we want to allocate a buffer
4071   ** and try repeatedly.  The reason why it is so complicated
4072   ** is that getting a return value of 0 from strftime can indicate
4073   ** one of the following:
4074   ** 1. buffer overflowed,
4075   ** 2. illegal conversion specifier, or
4076   ** 3. the format string specifies nothing to be returned(not
4077   **      an error).  This could be because format is an empty string
4078   **    or it specifies %p that yields an empty string in some locale.
4079   ** If there is a better way to make it portable, go ahead by
4080   ** all means.
4081   */
4082   if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
4083     return buf;
4084   else {
4085     /* Possibly buf overflowed - try again with a bigger buf */
4086     const int fmtlen = strlen(fmt);
4087     int bufsize = fmtlen + buflen;
4088
4089     Renew(buf, bufsize, char);
4090     while (buf) {
4091       buflen = strftime(buf, bufsize, fmt, &mytm);
4092       if (buflen > 0 && buflen < bufsize)
4093         break;
4094       /* heuristic to prevent out-of-memory errors */
4095       if (bufsize > 100*fmtlen) {
4096         Safefree(buf);
4097         buf = NULL;
4098         break;
4099       }
4100       bufsize *= 2;
4101       Renew(buf, bufsize, char);
4102     }
4103     return buf;
4104   }
4105 #else
4106   Perl_croak(aTHX_ "panic: no strftime");
4107   return NULL;
4108 #endif
4109 }
4110
4111
4112 #define SV_CWD_RETURN_UNDEF \
4113 sv_setsv(sv, &PL_sv_undef); \
4114 return FALSE
4115
4116 #define SV_CWD_ISDOT(dp) \
4117     (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
4118         (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
4119
4120 /*
4121 =head1 Miscellaneous Functions
4122
4123 =for apidoc getcwd_sv
4124
4125 Fill the sv with current working directory
4126
4127 =cut
4128 */
4129
4130 /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
4131  * rewritten again by dougm, optimized for use with xs TARG, and to prefer
4132  * getcwd(3) if available
4133  * Comments from the orignal:
4134  *     This is a faster version of getcwd.  It's also more dangerous
4135  *     because you might chdir out of a directory that you can't chdir
4136  *     back into. */
4137
4138 int
4139 Perl_getcwd_sv(pTHX_ register SV *sv)
4140 {
4141 #ifndef PERL_MICRO
4142     dVAR;
4143 #ifndef INCOMPLETE_TAINTS
4144     SvTAINTED_on(sv);
4145 #endif
4146
4147     PERL_ARGS_ASSERT_GETCWD_SV;
4148
4149 #ifdef HAS_GETCWD
4150     {
4151         char buf[MAXPATHLEN];
4152
4153         /* Some getcwd()s automatically allocate a buffer of the given
4154          * size from the heap if they are given a NULL buffer pointer.
4155          * The problem is that this behaviour is not portable. */
4156         if (getcwd(buf, sizeof(buf) - 1)) {
4157             sv_setpv(sv, buf);
4158             return TRUE;
4159         }
4160         else {
4161             sv_setsv(sv, &PL_sv_undef);
4162             return FALSE;
4163         }
4164     }
4165
4166 #else
4167
4168     Stat_t statbuf;
4169     int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4170     int pathlen=0;
4171     Direntry_t *dp;
4172
4173     SvUPGRADE(sv, SVt_PV);
4174
4175     if (PerlLIO_lstat(".", &statbuf) < 0) {
4176         SV_CWD_RETURN_UNDEF;
4177     }
4178
4179     orig_cdev = statbuf.st_dev;
4180     orig_cino = statbuf.st_ino;
4181     cdev = orig_cdev;
4182     cino = orig_cino;
4183
4184     for (;;) {
4185         DIR *dir;
4186         int namelen;
4187         odev = cdev;
4188         oino = cino;
4189
4190         if (PerlDir_chdir("..") < 0) {
4191             SV_CWD_RETURN_UNDEF;
4192         }
4193         if (PerlLIO_stat(".", &statbuf) < 0) {
4194             SV_CWD_RETURN_UNDEF;
4195         }
4196
4197         cdev = statbuf.st_dev;
4198         cino = statbuf.st_ino;
4199
4200         if (odev == cdev && oino == cino) {
4201             break;
4202         }
4203         if (!(dir = PerlDir_open("."))) {
4204             SV_CWD_RETURN_UNDEF;
4205         }
4206
4207         while ((dp = PerlDir_read(dir)) != NULL) {
4208 #ifdef DIRNAMLEN
4209             namelen = dp->d_namlen;
4210 #else
4211             namelen = strlen(dp->d_name);
4212 #endif
4213             /* skip . and .. */
4214             if (SV_CWD_ISDOT(dp)) {
4215                 continue;
4216             }
4217
4218             if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4219                 SV_CWD_RETURN_UNDEF;
4220             }
4221
4222             tdev = statbuf.st_dev;
4223             tino = statbuf.st_ino;
4224             if (tino == oino && tdev == odev) {
4225                 break;
4226             }
4227         }
4228
4229         if (!dp) {
4230             SV_CWD_RETURN_UNDEF;
4231         }
4232
4233         if (pathlen + namelen + 1 >= MAXPATHLEN) {
4234             SV_CWD_RETURN_UNDEF;
4235         }
4236
4237         SvGROW(sv, pathlen + namelen + 1);
4238
4239         if (pathlen) {
4240             /* shift down */
4241             Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4242         }
4243
4244         /* prepend current directory to the front */
4245         *SvPVX(sv) = '/';
4246         Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4247         pathlen += (namelen + 1);
4248
4249 #ifdef VOID_CLOSEDIR
4250         PerlDir_close(dir);
4251 #else
4252         if (PerlDir_close(dir) < 0) {
4253             SV_CWD_RETURN_UNDEF;
4254         }
4255 #endif
4256     }
4257
4258     if (pathlen) {
4259         SvCUR_set(sv, pathlen);
4260         *SvEND(sv) = '\0';
4261         SvPOK_only(sv);
4262
4263         if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
4264             SV_CWD_RETURN_UNDEF;
4265         }
4266     }
4267     if (PerlLIO_stat(".", &statbuf) < 0) {
4268         SV_CWD_RETURN_UNDEF;
4269     }
4270
4271     cdev = statbuf.st_dev;
4272     cino = statbuf.st_ino;
4273
4274     if (cdev != orig_cdev || cino != orig_cino) {
4275         Perl_croak(aTHX_ "Unstable directory path, "
4276                    "current directory changed unexpectedly");
4277     }
4278
4279     return TRUE;
4280 #endif
4281
4282 #else
4283     return FALSE;
4284 #endif
4285 }
4286
4287 #define VERSION_MAX 0x7FFFFFFF
4288
4289 /*
4290 =for apidoc prescan_version
4291
4292 Validate that a given string can be parsed as a version object, but doesn't
4293 actually perform the parsing.  Can use either strict or lax validation rules.
4294 Can optionally set a number of hint variables to save the parsing code
4295 some time when tokenizing.
4296
4297 =cut
4298 */
4299 const char *
4300 Perl_prescan_version(pTHX_ const char *s, bool strict,
4301                      const char **errstr,
4302                      bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
4303     bool qv = (sqv ? *sqv : FALSE);
4304     int width = 3;
4305     int saw_decimal = 0;
4306     bool alpha = FALSE;
4307     const char *d = s;
4308
4309     PERL_ARGS_ASSERT_PRESCAN_VERSION;
4310
4311     if (qv && isDIGIT(*d))
4312         goto dotted_decimal_version;
4313
4314     if (*d == 'v') { /* explicit v-string */
4315         d++;
4316         if (isDIGIT(*d)) {
4317             qv = TRUE;
4318         }
4319         else { /* degenerate v-string */
4320             /* requires v1.2.3 */
4321             BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4322         }
4323
4324 dotted_decimal_version:
4325         if (strict && d[0] == '0' && isDIGIT(d[1])) {
4326             /* no leading zeros allowed */
4327             BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4328         }
4329
4330         while (isDIGIT(*d))     /* integer part */
4331             d++;
4332
4333         if (*d == '.')
4334         {
4335             saw_decimal++;
4336             d++;                /* decimal point */
4337         }
4338         else
4339         {
4340             if (strict) {
4341                 /* require v1.2.3 */
4342                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4343             }
4344             else {
4345                 goto version_prescan_finish;
4346             }
4347         }
4348
4349         {
4350             int i = 0;
4351             int j = 0;
4352             while (isDIGIT(*d)) {       /* just keep reading */
4353                 i++;
4354                 while (isDIGIT(*d)) {
4355                     d++; j++;
4356                     /* maximum 3 digits between decimal */
4357                     if (strict && j > 3) {
4358                         BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
4359                     }
4360                 }
4361                 if (*d == '_') {
4362                     if (strict) {
4363                         BADVERSION(s,errstr,"Invalid version format (no underscores)");
4364                     }
4365                     if ( alpha ) {
4366                         BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4367                     }
4368                     d++;
4369                     alpha = TRUE;
4370                 }
4371                 else if (*d == '.') {
4372                     if (alpha) {
4373                         BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4374                     }
4375                     saw_decimal++;
4376                     d++;
4377                 }
4378                 else if (!isDIGIT(*d)) {
4379                     break;
4380                 }
4381                 j = 0;
4382             }
4383
4384             if (strict && i < 2) {
4385                 /* requires v1.2.3 */
4386                 BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
4387             }
4388         }
4389     }                                   /* end if dotted-decimal */
4390     else
4391     {                                   /* decimal versions */
4392         int j = 0;                      /* may need this later */
4393         /* special strict case for leading '.' or '0' */
4394         if (strict) {
4395             if (*d == '.') {
4396                 BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
4397             }
4398             if (*d == '0' && isDIGIT(d[1])) {
4399                 BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
4400             }
4401         }
4402
4403         /* and we never support negative versions */
4404         if ( *d == '-') {
4405             BADVERSION(s,errstr,"Invalid version format (negative version number)");
4406         }
4407
4408         /* consume all of the integer part */
4409         while (isDIGIT(*d))
4410             d++;
4411
4412         /* look for a fractional part */
4413         if (*d == '.') {
4414             /* we found it, so consume it */
4415             saw_decimal++;
4416             d++;
4417         }
4418         else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
4419             if ( d == s ) {
4420                 /* found nothing */
4421                 BADVERSION(s,errstr,"Invalid version format (version required)");
4422             }
4423             /* found just an integer */
4424             goto version_prescan_finish;
4425         }
4426         else if ( d == s ) {
4427             /* didn't find either integer or period */
4428             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4429         }
4430         else if (*d == '_') {
4431             /* underscore can't come after integer part */
4432             if (strict) {
4433                 BADVERSION(s,errstr,"Invalid version format (no underscores)");
4434             }
4435             else if (isDIGIT(d[1])) {
4436                 BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
4437             }
4438             else {
4439                 BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4440             }
4441         }
4442         else {
4443             /* anything else after integer part is just invalid data */
4444             BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4445         }
4446
4447         /* scan the fractional part after the decimal point*/
4448
4449         if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
4450                 /* strict or lax-but-not-the-end */
4451                 BADVERSION(s,errstr,"Invalid version format (fractional part required)");
4452         }
4453
4454         while (isDIGIT(*d)) {
4455             d++; j++;
4456             if (*d == '.' && isDIGIT(d[-1])) {
4457                 if (alpha) {
4458                     BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
4459                 }
4460                 if (strict) {
4461                     BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
4462                 }
4463                 d = (char *)s;          /* start all over again */
4464                 qv = TRUE;
4465                 goto dotted_decimal_version;
4466             }
4467             if (*d == '_') {
4468                 if (strict) {
4469                     BADVERSION(s,errstr,"Invalid version format (no underscores)");
4470                 }
4471                 if ( alpha ) {
4472                     BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
4473                 }
4474                 if ( ! isDIGIT(d[1]) ) {
4475                     BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
4476                 }
4477                 width = j;
4478                 d++;
4479                 alpha = TRUE;
4480             }
4481         }
4482     }
4483
4484 version_prescan_finish:
4485     while (isSPACE(*d))
4486         d++;
4487
4488     if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
4489         /* trailing non-numeric data */
4490         BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
4491     }
4492
4493     if (sqv)
4494         *sqv = qv;
4495     if (swidth)
4496         *swidth = width;
4497     if (ssaw_decimal)
4498         *ssaw_decimal = saw_decimal;
4499     if (salpha)
4500         *salpha = alpha;
4501     return d;
4502 }
4503
4504 /*
4505 =for apidoc scan_version
4506
4507 Returns a pointer to the next character after the parsed
4508 version string, as well as upgrading the passed in SV to
4509 an RV.
4510
4511 Function must be called with an already existing SV like
4512
4513     sv = newSV(0);
4514     s = scan_version(s, SV *sv, bool qv);
4515
4516 Performs some preprocessing to the string to ensure that
4517 it has the correct characteristics of a version.  Flags the
4518 object if it contains an underscore (which denotes this
4519 is an alpha version).  The boolean qv denotes that the version
4520 should be interpreted as if it had multiple decimals, even if
4521 it doesn't.
4522
4523 =cut
4524 */
4525
4526 const char *
4527 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
4528 {
4529     const char *start;
4530     const char *pos;
4531     const char *last;
4532     const char *errstr = NULL;
4533     int saw_decimal = 0;
4534     int width = 3;
4535     bool alpha = FALSE;
4536     bool vinf = FALSE;
4537     AV * const av = newAV();
4538     SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
4539
4540     PERL_ARGS_ASSERT_SCAN_VERSION;
4541
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     while (isSPACE(*s)) /* leading whitespace is OK */
4549         s++;
4550
4551     last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
4552     if (errstr) {
4553         /* "undef" is a special case and not an error */
4554         if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
4555             Perl_croak(aTHX_ "%s", errstr);
4556         }
4557     }
4558
4559     start = s;
4560     if (*s == 'v')
4561         s++;
4562     pos = s;
4563
4564     if ( qv )
4565         (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
4566     if ( alpha )
4567         (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
4568     if ( !qv && width < 3 )
4569         (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4570     
4571     while (isDIGIT(*pos))
4572         pos++;
4573     if (!isALPHA(*pos)) {
4574         I32 rev;
4575
4576         for (;;) {
4577             rev = 0;
4578             {
4579                 /* this is atoi() that delimits on underscores */
4580                 const char *end = pos;
4581                 I32 mult = 1;
4582                 I32 orev;
4583
4584                 /* the following if() will only be true after the decimal
4585                  * point of a version originally created with a bare
4586                  * floating point number, i.e. not quoted in any way
4587                  */
4588                 if ( !qv && s > start && saw_decimal == 1 ) {
4589                     mult *= 100;
4590                     while ( s < end ) {
4591                         orev = rev;
4592                         rev += (*s - '0') * mult;
4593                         mult /= 10;
4594                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4595                             || (PERL_ABS(rev) > VERSION_MAX )) {
4596                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4597                                            "Integer overflow in version %d",VERSION_MAX);
4598                             s = end - 1;
4599                             rev = VERSION_MAX;
4600                             vinf = 1;
4601                         }
4602                         s++;
4603                         if ( *s == '_' )
4604                             s++;
4605                     }
4606                 }
4607                 else {
4608                     while (--end >= s) {
4609                         orev = rev;
4610                         rev += (*end - '0') * mult;
4611                         mult *= 10;
4612                         if (   (PERL_ABS(orev) > PERL_ABS(rev)) 
4613                             || (PERL_ABS(rev) > VERSION_MAX )) {
4614                             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), 
4615                                            "Integer overflow in version");
4616                             end = s - 1;
4617                             rev = VERSION_MAX;
4618                             vinf = 1;
4619                         }
4620                     }
4621                 } 
4622             }
4623
4624             /* Append revision */
4625             av_push(av, newSViv(rev));
4626             if ( vinf ) {
4627                 s = last;
4628                 break;
4629             }
4630             else if ( *pos == '.' )
4631                 s = ++pos;
4632             else if ( *pos == '_' && isDIGIT(pos[1]) )
4633                 s = ++pos;
4634             else if ( *pos == ',' && isDIGIT(pos[1]) )
4635                 s = ++pos;
4636             else if ( isDIGIT(*pos) )
4637                 s = pos;
4638             else {
4639                 s = pos;
4640                 break;
4641             }
4642             if ( qv ) {
4643                 while ( isDIGIT(*pos) )
4644                     pos++;
4645             }
4646             else {
4647                 int digits = 0;
4648                 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4649                     if ( *pos != '_' )
4650                         digits++;
4651                     pos++;
4652                 }
4653             }
4654         }
4655     }
4656     if ( qv ) { /* quoted versions always get at least three terms*/
4657         I32 len = av_len(av);
4658         /* This for loop appears to trigger a compiler bug on OS X, as it
4659            loops infinitely. Yes, len is negative. No, it makes no sense.
4660            Compiler in question is:
4661            gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4662            for ( len = 2 - len; len > 0; len-- )
4663            av_push(MUTABLE_AV(sv), newSViv(0));
4664         */
4665         len = 2 - len;
4666         while (len-- > 0)
4667             av_push(av, newSViv(0));
4668     }
4669
4670     /* need to save off the current version string for later */
4671     if ( vinf ) {
4672         SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
4673         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4674         (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
4675     }
4676     else if ( s > start ) {
4677         SV * orig = newSVpvn(start,s-start);
4678         if ( qv && saw_decimal == 1 && *start != 'v' ) {
4679             /* need to insert a v to be consistent */
4680             sv_insert(orig, 0, 0, "v", 1);
4681         }
4682         (void)hv_stores(MUTABLE_HV(hv), "original", orig);
4683     }
4684     else {
4685         (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
4686         av_push(av, newSViv(0));
4687     }
4688
4689     /* And finally, store the AV in the hash */
4690     (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4691
4692     /* fix RT#19517 - special case 'undef' as string */
4693     if ( *s == 'u' && strEQ(s,"undef") ) {
4694         s += 5;
4695     }
4696
4697     return s;
4698 }
4699
4700 /*
4701 =for apidoc new_version
4702
4703 Returns a new version object based on the passed in SV:
4704
4705     SV *sv = new_version(SV *ver);
4706
4707 Does not alter the passed in ver SV.  See "upg_version" if you
4708 want to upgrade the SV.
4709
4710 =cut
4711 */
4712
4713 SV *
4714 Perl_new_version(pTHX_ SV *ver)
4715 {
4716     dVAR;
4717     SV * const rv = newSV(0);
4718     PERL_ARGS_ASSERT_NEW_VERSION;
4719     if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
4720          /* can just copy directly */
4721     {
4722         I32 key;
4723         AV * const av = newAV();
4724         AV *sav;
4725         /* This will get reblessed later if a derived class*/
4726         SV * const hv = newSVrv(rv, "version"); 
4727         (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
4728 #ifndef NODEFAULT_SHAREKEYS
4729         HvSHAREKEYS_on(hv);         /* key-sharing on by default */
4730 #endif
4731
4732         if ( SvROK(ver) )
4733             ver = SvRV(ver);
4734
4735         /* Begin copying all of the elements */
4736         if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
4737             (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
4738
4739         if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
4740             (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
4741         
4742         if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
4743         {
4744             const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
4745             (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
4746         }
4747
4748         if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
4749         {
4750             SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
4751             (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
4752         }
4753
4754         sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
4755         /* This will get reblessed later if a derived class*/
4756         for ( key = 0; key <= av_len(sav); key++ )
4757         {
4758             const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4759             av_push(av, newSViv(rev));
4760         }
4761
4762         (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
4763         return rv;
4764     }
4765 #ifdef SvVOK
4766     {
4767         const MAGIC* const mg = SvVSTRING_mg(ver);
4768         if ( mg ) { /* already a v-string */
4769             const STRLEN len = mg->mg_len;
4770             char * const version = savepvn( (const char*)mg->mg_ptr, len);
4771             sv_setpvn(rv,version,len);
4772             /* this is for consistency with the pure Perl class */
4773             if ( isDIGIT(*version) )
4774                 sv_insert(rv, 0, 0, "v", 1);
4775             Safefree(version);
4776         }
4777         else {
4778 #endif
4779         sv_setsv(rv,ver); /* make a duplicate */
4780 #ifdef SvVOK
4781         }
4782     }
4783 #endif
4784     return upg_version(rv, FALSE);
4785 }
4786
4787 /*
4788 =for apidoc upg_version
4789
4790 In-place upgrade of the supplied SV to a version object.
4791
4792     SV *sv = upg_version(SV *sv, bool qv);
4793
4794 Returns a pointer to the upgraded SV.  Set the boolean qv if you want
4795 to force this SV to be interpreted as an "extended" version.
4796
4797 =cut
4798 */
4799
4800 SV *
4801 Perl_upg_version(pTHX_ SV *ver, bool qv)
4802 {
4803     const char *version, *s;
4804 #ifdef SvVOK
4805     const MAGIC *mg;
4806 #endif
4807
4808     PERL_ARGS_ASSERT_UPG_VERSION;
4809
4810     if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
4811     {
4812         STRLEN len;
4813
4814         /* may get too much accuracy */ 
4815         char tbuf[64];
4816         SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
4817         char *buf;
4818 #ifdef USE_LOCALE_NUMERIC
4819         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
4820         setlocale(LC_NUMERIC, "C");
4821 #endif
4822         if (sv) {
4823             Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
4824             buf = SvPV(sv, len);
4825         }
4826         else {
4827             len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
4828             buf = tbuf;
4829         }
4830 #ifdef USE_LOCALE_NUMERIC
4831         setlocale(LC_NUMERIC, loc);
4832         Safefree(loc);
4833 #endif
4834         while (buf[len-1] == '0' && len > 0) len--;
4835         if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
4836         version = savepvn(buf, len);
4837         SvREFCNT_dec(sv);
4838     }
4839 #ifdef SvVOK
4840     else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
4841         version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4842         qv = TRUE;
4843     }
4844 #endif
4845     else /* must be a string or something like a string */
4846     {
4847         STRLEN len;
4848         version = savepv(SvPV(ver,len));
4849 #ifndef SvVOK
4850 #  if PERL_VERSION > 5
4851         /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
4852         if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
4853             /* may be a v-string */
4854             char *testv = (char *)version;
4855             STRLEN tlen = len;
4856             for (tlen=0; tlen < len; tlen++, testv++) {
4857                 /* if one of the characters is non-text assume v-string */
4858                 if (testv[0] < ' ') {
4859                     SV * const nsv = sv_newmortal();
4860                     const char *nver;
4861                     const char *pos;
4862                     int saw_decimal = 0;
4863                     sv_setpvf(nsv,"v%vd",ver);
4864                     pos = nver = savepv(SvPV_nolen(nsv));
4865
4866                     /* scan the resulting formatted string */
4867                     pos++; /* skip the leading 'v' */
4868                     while ( *pos == '.' || isDIGIT(*pos) ) {
4869                         if ( *pos == '.' )
4870                             saw_decimal++ ;
4871                         pos++;
4872                     }
4873
4874                     /* is definitely a v-string */
4875                     if ( saw_decimal >= 2 ) {   
4876                         Safefree(version);
4877                         version = nver;
4878                     }
4879                     break;
4880                 }
4881             }
4882         }
4883 #  endif
4884 #endif
4885     }
4886
4887     s = scan_version(version, ver, qv);
4888     if ( *s != '\0' ) 
4889         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 
4890                        "Version string '%s' contains invalid data; "
4891                        "ignoring: '%s'", version, s);
4892     Safefree(version);
4893     return ver;
4894 }
4895
4896 /*
4897 =for apidoc vverify
4898
4899 Validates that the SV contains valid internal structure for a version object.
4900 It may be passed either the version object (RV) or the hash itself (HV).  If
4901 the structure is valid, it returns the HV.  If the structure is invalid,
4902 it returns NULL.
4903
4904     SV *hv = vverify(sv);
4905
4906 Note that it only confirms the bare minimum structure (so as not to get
4907 confused by derived classes which may contain additional hash entries):
4908
4909 =over 4
4910
4911 =item * The SV is an HV or a reference to an HV
4912
4913 =item * The hash contains a "version" key
4914
4915 =item * The "version" key has a reference to an AV as its value
4916
4917 =back
4918
4919 =cut
4920 */
4921
4922 SV *
4923 Perl_vverify(pTHX_ SV *vs)
4924 {
4925     SV *sv;
4926
4927     PERL_ARGS_ASSERT_VVERIFY;
4928
4929     if ( SvROK(vs) )
4930         vs = SvRV(vs);
4931
4932     /* see if the appropriate elements exist */
4933     if ( SvTYPE(vs) == SVt_PVHV
4934          && hv_exists(MUTABLE_HV(vs), "version", 7)
4935          && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
4936          && SvTYPE(sv) == SVt_PVAV )
4937         return vs;
4938     else
4939         return NULL;
4940 }
4941
4942 /*
4943 =for apidoc vnumify
4944
4945 Accepts a version object and returns the normalized floating
4946 point representation.  Call like:
4947
4948     sv = vnumify(rv);
4949
4950 NOTE: you can pass either the object directly or the SV
4951 contained within the RV.
4952
4953 The SV returned has a refcount of 1.
4954
4955 =cut
4956 */
4957
4958 SV *
4959 Perl_vnumify(pTHX_ SV *vs)
4960 {
4961     I32 i, len, digit;
4962     int width;
4963     bool alpha = FALSE;
4964     SV *sv;
4965     AV *av;
4966
4967     PERL_ARGS_ASSERT_VNUMIFY;
4968
4969     /* extract the HV from the object */
4970     vs = vverify(vs);
4971     if ( ! vs )
4972         Perl_croak(aTHX_ "Invalid version object");
4973
4974     /* see if various flags exist */
4975     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
4976         alpha = TRUE;
4977     if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
4978         width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
4979     else
4980         width = 3;
4981
4982
4983     /* attempt to retrieve the version array */
4984     if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
4985         return newSVpvs("0");
4986     }
4987
4988     len = av_len(av);
4989     if ( len == -1 )
4990     {
4991         return newSVpvs("0");
4992     }
4993
4994     digit = SvIV(*av_fetch(av, 0, 0));
4995     sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
4996     for ( i = 1 ; i < len ; i++ )
4997     {
4998         digit = SvIV(*av_fetch(av, i, 0));
4999         if ( width < 3 ) {
5000             const int denom = (width == 2 ? 10 : 100);
5001             const div_t term = div((int)PERL_ABS(digit),denom);
5002             Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
5003         }
5004         else {
5005             Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5006         }
5007     }
5008
5009     if ( len > 0 )
5010     {
5011         digit = SvIV(*av_fetch(av, len, 0));
5012         if ( alpha && width == 3 ) /* alpha version */
5013             sv_catpvs(sv,"_");
5014         Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
5015     }
5016     else /* len == 0 */
5017     {
5018         sv_catpvs(sv, "000");
5019     }
5020     return sv;
5021 }
5022
5023 /*
5024 =for apidoc vnormal
5025
5026 Accepts a version object and returns the normalized string
5027 representation.  Call like:
5028
5029     sv = vnormal(rv);
5030
5031 NOTE: you can pass either the object directly or the SV
5032 contained within the RV.
5033
5034 The SV returned has a refcount of 1.
5035
5036 =cut
5037 */
5038
5039 SV *
5040 Perl_vnormal(pTHX_ SV *vs)
5041 {
5042     I32 i, len, digit;
5043     bool alpha = FALSE;
5044     SV *sv;
5045     AV *av;
5046
5047     PERL_ARGS_ASSERT_VNORMAL;
5048
5049     /* extract the HV from the object */
5050     vs = vverify(vs);
5051     if ( ! vs )
5052         Perl_croak(aTHX_ "Invalid version object");
5053
5054     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
5055         alpha = TRUE;
5056     av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
5057
5058     len = av_len(av);
5059     if ( len == -1 )
5060     {
5061         return newSVpvs("");
5062     }
5063     digit = SvIV(*av_fetch(av, 0, 0));
5064     sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
5065     for ( i = 1 ; i < len ; i++ ) {
5066         digit = SvIV(*av_fetch(av, i, 0));
5067         Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5068     }
5069
5070     if ( len > 0 )
5071     {
5072         /* handle last digit specially */
5073         digit = SvIV(*av_fetch(av, len, 0));
5074         if ( alpha )
5075             Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
5076         else
5077             Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
5078     }
5079
5080     if ( len <= 2 ) { /* short version, must be at least three */
5081         for ( len = 2 - len; len != 0; len-- )
5082             sv_catpvs(sv,".0");
5083     }
5084     return sv;
5085 }
5086
5087 /*
5088 =for apidoc vstringify
5089
5090 In order to maintain maximum compatibility with earlier versions
5091 of Perl, this function will return either the floating point
5092 notation or the multiple dotted notation, depending on whether
5093 the original version contained 1 or more dots, respectively.
5094
5095 The SV returned has a refcount of 1.
5096
5097 =cut
5098 */
5099
5100 SV *
5101 Perl_vstringify(pTHX_ SV *vs)
5102 {
5103     PERL_ARGS_ASSERT_VSTRINGIFY;
5104
5105     /* extract the HV from the object */
5106     vs = vverify(vs);
5107     if ( ! vs )
5108         Perl_croak(aTHX_ "Invalid version object");
5109
5110     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
5111         SV *pv;
5112         pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
5113         if ( SvPOK(pv) )
5114             return newSVsv(pv);
5115         else
5116             return &PL_sv_undef;
5117     }
5118     else {
5119         if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
5120             return vnormal(vs);
5121         else
5122             return vnumify(vs);
5123     }
5124 }
5125
5126 /*
5127 =for apidoc vcmp
5128
5129 Version object aware cmp.  Both operands must already have been 
5130 converted into version objects.
5131
5132 =cut
5133 */
5134
5135 int
5136 Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
5137 {
5138     I32 i,l,m,r,retval;
5139     bool lalpha = FALSE;
5140     bool ralpha = FALSE;
5141     I32 left = 0;
5142     I32 right = 0;
5143     AV *lav, *rav;
5144
5145     PERL_ARGS_ASSERT_VCMP;
5146
5147     /* extract the HVs from the objects */
5148     lhv = vverify(lhv);
5149     rhv = vverify(rhv);
5150     if ( ! ( lhv && rhv ) )
5151         Perl_croak(aTHX_ "Invalid version object");
5152
5153     /* get the left hand term */
5154     lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
5155     if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
5156         lalpha = TRUE;
5157
5158     /* and the right hand term */
5159     rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
5160     if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
5161         ralpha = TRUE;
5162
5163     l = av_len(lav);
5164     r = av_len(rav);
5165     m = l < r ? l : r;
5166     retval = 0;
5167     i = 0;
5168     while ( i <= m && retval == 0 )
5169     {
5170         left  = SvIV(*av_fetch(lav,i,0));
5171         right = SvIV(*av_fetch(rav,i,0));
5172         if ( left < right  )
5173             retval = -1;
5174         if ( left > right )
5175             retval = +1;
5176         i++;
5177     }
5178
5179     /* tiebreaker for alpha with identical terms */
5180     if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
5181     {
5182         if ( lalpha && !ralpha )
5183         {
5184             retval = -1;
5185         }
5186         else if ( ralpha && !lalpha)
5187         {
5188             retval = +1;
5189         }
5190     }
5191
5192     if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
5193     {
5194         if ( l < r )
5195         {
5196             while ( i <= r && retval == 0 )
5197             {
5198                 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
5199                     retval = -1; /* not a match after all */
5200                 i++;
5201             }
5202         }
5203         else
5204         {
5205             while ( i <= l && retval == 0 )
5206             {
5207                 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
5208                     retval = +1; /* not a match after all */
5209                 i++;
5210             }
5211         }
5212     }
5213     return retval;
5214 }
5215
5216 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
5217 #   define EMULATE_SOCKETPAIR_UDP
5218 #endif
5219
5220 #ifdef EMULATE_SOCKETPAIR_UDP
5221 static int
5222 S_socketpair_udp (int fd[2]) {
5223     dTHX;
5224     /* Fake a datagram socketpair using UDP to localhost.  */
5225     int sockets[2] = {-1, -1};
5226     struct sockaddr_in addresses[2];
5227     int i;
5228     Sock_size_t size = sizeof(struct sockaddr_in);
5229     unsigned short port;
5230     int got;
5231
5232     memset(&addresses, 0, sizeof(addresses));
5233     i = 1;
5234     do {
5235         sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
5236         if (sockets[i] == -1)
5237             goto tidy_up_and_fail;
5238
5239         addresses[i].sin_family = AF_INET;
5240         addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5241         addresses[i].sin_port = 0;      /* kernel choses port.  */
5242         if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
5243                 sizeof(struct sockaddr_in)) == -1)
5244             goto tidy_up_and_fail;
5245     } while (i--);
5246
5247     /* Now have 2 UDP sockets. Find out which port each is connected to, and
5248        for each connect the other socket to it.  */
5249     i = 1;
5250     do {
5251         if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
5252                 &size) == -1)
5253             goto tidy_up_and_fail;
5254         if (size != sizeof(struct sockaddr_in))
5255             goto abort_tidy_up_and_fail;
5256         /* !1 is 0, !0 is 1 */
5257         if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
5258                 sizeof(struct sockaddr_in)) == -1)
5259             goto tidy_up_and_fail;
5260     } while (i--);
5261
5262     /* Now we have 2 sockets connected to each other. I don't trust some other
5263        process not to have already sent a packet to us (by random) so send
5264        a packet from each to the other.  */
5265     i = 1;
5266     do {
5267         /* I'm going to send my own port number.  As a short.
5268            (Who knows if someone somewhere has sin_port as a bitfield and needs
5269            this routine. (I'm assuming crays have socketpair)) */
5270         port = addresses[i].sin_port;
5271         got = PerlLIO_write(sockets[i], &port, sizeof(port));
5272         if (got != sizeof(port)) {
5273             if (got == -1)
5274                 goto tidy_up_and_fail;
5275             goto abort_tidy_up_and_fail;
5276         }
5277     } while (i--);
5278
5279     /* Packets sent. I don't trust them to have arrived though.
5280        (As I understand it Solaris TCP stack is multithreaded. Non-blocking
5281        connect to localhost will use a second kernel thread. In 2.6 the
5282        first thread running the connect() returns before the second completes,
5283        so EINPROGRESS> In 2.7 the improved stack is faster and connect()
5284        returns 0. Poor programs have tripped up. One poor program's authors'
5285        had a 50-1 reverse stock split. Not sure how connected these were.)
5286        So I don't trust someone not to have an unpredictable UDP stack.
5287     */
5288
5289     {
5290         struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
5291         int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
5292         fd_set rset;
5293
5294         FD_ZERO(&rset);
5295         FD_SET((unsigned int)sockets[0], &rset);
5296         FD_SET((unsigned int)sockets[1], &rset);
5297
5298         got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
5299         if (got != 2 || !FD_ISSET(sockets[0], &rset)
5300                 || !FD_ISSET(sockets[1], &rset)) {
5301             /* I hope this is portable and appropriate.  */
5302             if (got == -1)
5303                 goto tidy_up_and_fail;
5304             goto abort_tidy_up_and_fail;
5305         }
5306     }
5307
5308     /* And the paranoia department even now doesn't trust it to have arrive
5309        (hence MSG_DONTWAIT). Or that what arrives was sent by us.  */
5310     {
5311         struct sockaddr_in readfrom;
5312         unsigned short buffer[2];
5313
5314         i = 1;
5315         do {
5316 #ifdef MSG_DONTWAIT
5317             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5318                     sizeof(buffer), MSG_DONTWAIT,
5319                     (struct sockaddr *) &readfrom, &size);
5320 #else
5321             got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
5322                     sizeof(buffer), 0,
5323                     (struct sockaddr *) &readfrom, &size);
5324 #endif
5325
5326             if (got == -1)
5327                 goto tidy_up_and_fail;
5328             if (got != sizeof(port)
5329                     || size != sizeof(struct sockaddr_in)
5330                     /* Check other socket sent us its port.  */
5331                     || buffer[0] != (unsigned short) addresses[!i].sin_port
5332                     /* Check kernel says we got the datagram from that socket */
5333                     || readfrom.sin_family != addresses[!i].sin_family
5334                     || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
5335                     || readfrom.sin_port != addresses[!i].sin_port)
5336                 goto abort_tidy_up_and_fail;
5337         } while (i--);
5338     }
5339     /* My caller (my_socketpair) has validated that this is non-NULL  */
5340     fd[0] = sockets[0];
5341     fd[1] = sockets[1];
5342     /* I hereby declare this connection open.  May God bless all who cross
5343        her.  */
5344     return 0;
5345
5346   abort_tidy_up_and_fail:
5347     errno = ECONNABORTED;
5348   tidy_up_and_fail:
5349     {
5350         dSAVE_ERRNO;
5351         if (sockets[0] != -1)
5352             PerlLIO_close(sockets[0]);
5353         if (sockets[1] != -1)
5354             PerlLIO_close(sockets[1]);
5355         RESTORE_ERRNO;
5356         return -1;
5357     }
5358 }
5359 #endif /*  EMULATE_SOCKETPAIR_UDP */
5360
5361 #if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
5362 int
5363 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5364     /* Stevens says that family must be AF_LOCAL, protocol 0.
5365        I'm going to enforce that, then ignore it, and use TCP (or UDP).  */
5366     dTHXa(NULL);
5367     int listener = -1;
5368     int connector = -1;
5369     int acceptor = -1;
5370     struct sockaddr_in listen_addr;
5371     struct sockaddr_in connect_addr;
5372     Sock_size_t size;
5373
5374     if (protocol
5375 #ifdef AF_UNIX
5376         || family != AF_UNIX
5377 #endif
5378     ) {
5379         errno = EAFNOSUPPORT;
5380         return -1;
5381     }
5382     if (!fd) {
5383         errno = EINVAL;
5384         return -1;
5385     }
5386
5387 #ifdef EMULATE_SOCKETPAIR_UDP
5388     if (type == SOCK_DGRAM)
5389         return S_socketpair_udp(fd);
5390 #endif
5391
5392     aTHXa(PERL_GET_THX);
5393     listener = PerlSock_socket(AF_INET, type, 0);
5394     if (listener == -1)
5395         return -1;
5396     memset(&listen_addr, 0, sizeof(listen_addr));
5397     listen_addr.sin_family = AF_INET;
5398     listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
5399     listen_addr.sin_port = 0;   /* kernel choses port.  */
5400     if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
5401             sizeof(listen_addr)) == -1)
5402         goto tidy_up_and_fail;
5403     if (PerlSock_listen(listener, 1) == -1)
5404         goto tidy_up_and_fail;
5405
5406     connector = PerlSock_socket(AF_INET, type, 0);
5407     if (connector == -1)
5408         goto tidy_up_and_fail;
5409     /* We want to find out the port number to connect to.  */
5410     size = sizeof(connect_addr);
5411     if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
5412             &size) == -1)
5413         goto tidy_up_and_fail;
5414     if (size != sizeof(connect_addr))
5415         goto abort_tidy_up_and_fail;
5416     if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
5417             sizeof(connect_addr)) == -1)
5418         goto tidy_up_and_fail;
5419
5420     size = sizeof(listen_addr);
5421     acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
5422             &size);
5423     if (acceptor == -1)
5424         goto tidy_up_and_fail;
5425     if (size != sizeof(listen_addr))
5426         goto abort_tidy_up_and_fail;
5427     PerlLIO_close(listener);
5428     /* Now check we are talking to ourself by matching port and host on the
5429        two sockets.  */
5430     if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
5431             &size) == -1)
5432         goto tidy_up_and_fail;
5433     if (size != sizeof(connect_addr)
5434             || listen_addr.sin_family != connect_addr.sin_family
5435             || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
5436             || listen_addr.sin_port != connect_addr.sin_port) {
5437         goto abort_tidy_up_and_fail;
5438     }
5439     fd[0] = connector;
5440     fd[1] = acceptor;
5441     return 0;
5442
5443   abort_tidy_up_and_fail:
5444 #ifdef ECONNABORTED
5445   errno = ECONNABORTED; /* This would be the standard thing to do. */
5446 #else
5447 #  ifdef ECONNREFUSED
5448   errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
5449 #  else
5450   errno = ETIMEDOUT;    /* Desperation time. */
5451 #  endif
5452 #endif
5453   tidy_up_and_fail:
5454     {
5455         dSAVE_ERRNO;
5456         if (listener != -1)
5457             PerlLIO_close(listener);
5458         if (connector != -1)
5459             PerlLIO_close(connector);
5460         if (acceptor != -1)
5461             PerlLIO_close(acceptor);
5462         RESTORE_ERRNO;
5463         return -1;
5464     }
5465 }
5466 #else
5467 /* In any case have a stub so that there's code corresponding
5468  * to the my_socketpair in embed.fnc. */
5469 int
5470 Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
5471 #ifdef HAS_SOCKETPAIR
5472     return socketpair(family, type, protocol, fd);
5473 #else
5474     return -1;
5475 #endif
5476 }
5477 #endif
5478
5479 /*
5480
5481 =for apidoc sv_nosharing
5482
5483 Dummy routine which "shares" an SV when there is no sharing module present.
5484 Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
5485 Exists to avoid test for a NULL function pointer and because it could
5486 potentially warn under some level of strict-ness.
5487
5488 =cut
5489 */
5490
5491 void
5492 Perl_sv_nosharing(pTHX_ SV *sv)
5493 {
5494     PERL_UNUSED_CONTEXT;
5495     PERL_UNUSED_ARG(sv);
5496 }
5497
5498 /*
5499
5500 =for apidoc sv_destroyable
5501
5502 Dummy routine which reports that object can be destroyed when there is no
5503 sharing module present.  It ignores its single SV argument, and returns
5504 'true'.  Exists to avoid test for a NULL function pointer and because it
5505 could potentially warn under some level of strict-ness.
5506
5507 =cut
5508 */
5509
5510 bool
5511 Perl_sv_destroyable(pTHX_ SV *sv)
5512 {
5513     PERL_UNUSED_CONTEXT;
5514     PERL_UNUSED_ARG(sv);
5515     return TRUE;
5516 }
5517
5518 U32
5519 Perl_parse_unicode_opts(pTHX_ const char **popt)
5520 {
5521   const char *p = *popt;
5522   U32 opt = 0;
5523
5524   PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS;
5525
5526   if (*p) {
5527        if (isDIGIT(*p)) {
5528             opt = (U32) atoi(p);
5529             while (isDIGIT(*p))
5530                 p++;
5531             if (*p && *p != '\n' && *p != '\r') {
5532              if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5533              else
5534                  Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
5535             }
5536        }
5537        else {
5538             for (; *p; p++) {
5539                  switch (*p) {
5540                  case PERL_UNICODE_STDIN:
5541                       opt |= PERL_UNICODE_STDIN_FLAG;   break;
5542                  case PERL_UNICODE_STDOUT:
5543                       opt |= PERL_UNICODE_STDOUT_FLAG;  break;
5544                  case PERL_UNICODE_STDERR:
5545                       opt |= PERL_UNICODE_STDERR_FLAG;  break;
5546                  case PERL_UNICODE_STD:
5547                       opt |= PERL_UNICODE_STD_FLAG;     break;
5548                  case PERL_UNICODE_IN:
5549                       opt |= PERL_UNICODE_IN_FLAG;      break;
5550                  case PERL_UNICODE_OUT:
5551                       opt |= PERL_UNICODE_OUT_FLAG;     break;
5552                  case PERL_UNICODE_INOUT:
5553                       opt |= PERL_UNICODE_INOUT_FLAG;   break;
5554                  case PERL_UNICODE_LOCALE:
5555                       opt |= PERL_UNICODE_LOCALE_FLAG;  break;
5556                  case PERL_UNICODE_ARGV:
5557                       opt |= PERL_UNICODE_ARGV_FLAG;    break;
5558                  case PERL_UNICODE_UTF8CACHEASSERT:
5559                       opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
5560                  default:
5561                       if (*p != '\n' && *p != '\r') {
5562                         if(isSPACE(*p)) goto the_end_of_the_opts_parser;
5563                         else
5564                           Perl_croak(aTHX_
5565                                      "Unknown Unicode option letter '%c'", *p);
5566                       }
5567                  }
5568             }
5569        }
5570   }
5571   else
5572        opt = PERL_UNICODE_DEFAULT_FLAGS;
5573
5574   the_end_of_the_opts_parser:
5575
5576   if (opt & ~PERL_UNICODE_ALL_FLAGS)
5577        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
5578                   (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5579
5580   *popt = p;
5581
5582   return opt;
5583 }
5584
5585 #ifdef VMS
5586 #  include <starlet.h>
5587 #endif
5588
5589 U32
5590 Perl_seed(pTHX)
5591 {
5592     dVAR;
5593     /*
5594      * This is really just a quick hack which grabs various garbage
5595      * values.  It really should be a real hash algorithm which
5596      * spreads the effect of every input bit onto every output bit,
5597      * if someone who knows about such things would bother to write it.
5598      * Might be a good idea to add that function to CORE as well.
5599      * No numbers below come from careful analysis or anything here,
5600      * except they are primes and SEED_C1 > 1E6 to get a full-width
5601      * value from (tv_sec * SEED_C1 + tv_usec).  The multipliers should
5602      * probably be bigger too.
5603      */
5604 #if RANDBITS > 16
5605 #  define SEED_C1       1000003
5606 #define   SEED_C4       73819
5607 #else
5608 #  define SEED_C1       25747
5609 #define   SEED_C4       20639
5610 #endif
5611 #define   SEED_C2       3
5612 #define   SEED_C3       269
5613 #define   SEED_C5       26107
5614
5615 #ifndef PERL_NO_DEV_RANDOM
5616     int fd;
5617 #endif
5618     U32 u;
5619 #ifdef VMS
5620     /* when[] = (low 32 bits, high 32 bits) of time since epoch
5621      * in 100-ns units, typically incremented ever 10 ms.        */
5622     unsigned int when[2];
5623 #else
5624 #  ifdef HAS_GETTIMEOFDAY
5625     struct timeval when;
5626 #  else
5627     Time_t when;
5628 #  endif
5629 #endif
5630
5631 /* This test is an escape hatch, this symbol isn't set by Configure. */
5632 #ifndef PERL_NO_DEV_RANDOM
5633 #ifndef PERL_RANDOM_DEVICE
5634    /* /dev/random isn't used by default because reads from it will block
5635     * if there isn't enough entropy available.  You can compile with
5636     * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5637     * is enough real entropy to fill the seed. */
5638 #  define PERL_RANDOM_DEVICE "/dev/urandom"
5639 #endif
5640     fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5641     if (fd != -1) {
5642         if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
5643             u = 0;
5644         PerlLIO_close(fd);
5645         if (u)
5646             return u;
5647     }
5648 #endif
5649
5650 #ifdef VMS
5651     _ckvmssts(sys$gettim(when));
5652     u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5653 #else
5654 #  ifdef HAS_GETTIMEOFDAY
5655     PerlProc_gettimeofday(&when,NULL);
5656     u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5657 #  else
5658     (void)time(&when);
5659     u = (U32)SEED_C1 * when;
5660 #  endif
5661 #endif
5662     u += SEED_C3 * (U32)PerlProc_getpid();
5663     u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5664 #ifndef PLAN9           /* XXX Plan9 assembler chokes on this; fix needed  */
5665     u += SEED_C5 * (U32)PTR2UV(&when);
5666 #endif
5667     return u;
5668 }
5669
5670 void
5671 Perl_get_hash_seed(pTHX_ unsigned char *seed_buffer)
5672 {
5673     dVAR;
5674     const char *s;
5675     const unsigned char * const end= seed_buffer + PERL_HASH_SEED_BYTES;
5676
5677     PERL_ARGS_ASSERT_GET_HASH_SEED;
5678
5679     s= PerlEnv_getenv("PERL_HASH_SEED");
5680
5681     if ( s )
5682 #ifndef USE_HASH_SEED_EXPLICIT
5683     {
5684         while (isSPACE(*s))
5685             s++;
5686
5687         while (isXDIGIT(*s) && seed_buffer < end) {
5688             *seed_buffer = READ_XDIGIT(s) << 4;
5689             if (isXDIGIT(*s)) {
5690                 *seed_buffer |= READ_XDIGIT(s);
5691             }
5692             seed_buffer++;
5693         }
5694         /* should we check for unparsed crap? */
5695     }
5696     else
5697 #endif
5698     {
5699         (void)seedDrand01((Rand_seed_t)seed());
5700
5701         while (seed_buffer < end) {
5702             *seed_buffer++ = (unsigned char)(Drand01() * (U8_MAX+1));
5703         }
5704      }
5705 }
5706
5707 #ifdef PERL_GLOBAL_STRUCT
5708
5709 #define PERL_GLOBAL_STRUCT_INIT
5710 #include "opcode.h" /* the ppaddr and check */
5711
5712 struct perl_vars *
5713 Perl_init_global_struct(pTHX)
5714 {
5715     struct perl_vars *plvarsp = NULL;
5716 # ifdef PERL_GLOBAL_STRUCT
5717     const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5718     const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
5719 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5720     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5721     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5722     if (!plvarsp)
5723         exit(1);
5724 #  else
5725     plvarsp = PL_VarsPtr;
5726 #  endif /* PERL_GLOBAL_STRUCT_PRIVATE */
5727 #  undef PERLVAR
5728 #  undef PERLVARA
5729 #  undef PERLVARI
5730 #  undef PERLVARIC
5731 #  define PERLVAR(prefix,var,type) /**/
5732 #  define PERLVARA(prefix,var,n,type) /**/
5733 #  define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
5734 #  define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
5735 #  include "perlvars.h"
5736 #  undef PERLVAR
5737 #  undef PERLVARA
5738 #  undef PERLVARI
5739 #  undef PERLVARIC
5740 #  ifdef PERL_GLOBAL_STRUCT
5741     plvarsp->Gppaddr =
5742         (Perl_ppaddr_t*)
5743         PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5744     if (!plvarsp->Gppaddr)
5745         exit(1);
5746     plvarsp->Gcheck  =
5747         (Perl_check_t*)
5748         PerlMem_malloc(ncheck  * sizeof(Perl_check_t));
5749     if (!plvarsp->Gcheck)
5750         exit(1);
5751     Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); 
5752     Copy(Gcheck,  plvarsp->Gcheck,  ncheck,  Perl_check_t); 
5753 #  endif
5754 #  ifdef PERL_SET_VARS
5755     PERL_SET_VARS(plvarsp);
5756 #  endif
5757 # undef PERL_GLOBAL_STRUCT_INIT
5758 # endif
5759     return plvarsp;
5760 }
5761
5762 #endif /* PERL_GLOBAL_STRUCT */
5763
5764 #ifdef PERL_GLOBAL_STRUCT
5765
5766 void
5767 Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5768 {
5769     PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
5770 # ifdef PERL_GLOBAL_STRUCT
5771 #  ifdef PERL_UNSET_VARS
5772     PERL_UNSET_VARS(plvarsp);
5773 #  endif
5774     free(plvarsp->Gppaddr);
5775     free(plvarsp->Gcheck);
5776 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
5777     free(plvarsp);
5778 #  endif
5779 # endif
5780 }
5781
5782 #endif /* PERL_GLOBAL_STRUCT */
5783
5784 #ifdef PERL_MEM_LOG
5785
5786 /* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
5787  * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
5788  * given, and you supply your own implementation.
5789  *
5790  * The default implementation reads a single env var, PERL_MEM_LOG,
5791  * expecting one or more of the following:
5792  *
5793  *    \d+ - fd          fd to write to          : must be 1st (atoi)
5794  *    'm' - memlog      was PERL_MEM_LOG=1
5795  *    's' - svlog       was PERL_SV_LOG=1
5796  *    't' - timestamp   was PERL_MEM_LOG_TIMESTAMP=1
5797  *
5798  * This makes the logger controllable enough that it can reasonably be
5799  * added to the system perl.
5800  */
5801
5802 /* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
5803  * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5804  */
5805 #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5806
5807 /* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
5808  * writes to.  In the default logger, this is settable at runtime.
5809  */
5810 #ifndef PERL_MEM_LOG_FD
5811 #  define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5812 #endif
5813
5814 #ifndef PERL_MEM_LOG_NOIMPL
5815
5816 # ifdef DEBUG_LEAKING_SCALARS
5817 #   define SV_LOG_SERIAL_FMT        " [%lu]"
5818 #   define _SV_LOG_SERIAL_ARG(sv)   , (unsigned long) (sv)->sv_debug_serial
5819 # else
5820 #   define SV_LOG_SERIAL_FMT
5821 #   define _SV_LOG_SERIAL_ARG(sv)
5822 # endif
5823
5824 static void
5825 S_mem_log_common(enum mem_log_type mlt, const UV n, 
5826                  const UV typesize, const char *type_name, const SV *sv,
5827                  Malloc_t oldalloc, Malloc_t newalloc,
5828                  const char *filename, const int linenumber,
5829                  const char *funcname)
5830 {
5831     const char *pmlenv;
5832
5833     PERL_ARGS_ASSERT_MEM_LOG_COMMON;
5834
5835     pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
5836     if (!pmlenv)
5837         return;
5838     if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
5839     {
5840         /* We can't use SVs or PerlIO for obvious reasons,
5841          * so we'll use stdio and low-level IO instead. */
5842         char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5843
5844 #   ifdef HAS_GETTIMEOFDAY
5845 #     define MEM_LOG_TIME_FMT   "%10d.%06d: "
5846 #     define MEM_LOG_TIME_ARG   (int)tv.tv_sec, (int)tv.tv_usec
5847         struct timeval tv;
5848         gettimeofday(&tv, 0);
5849 #   else
5850 #     define MEM_LOG_TIME_FMT   "%10d: "
5851 #     define MEM_LOG_TIME_ARG   (int)when
5852         Time_t when;
5853         (void)time(&when);
5854 #   endif
5855         /* If there are other OS specific ways of hires time than
5856          * gettimeofday() (see ext/Time-HiRes), the easiest way is
5857          * probably that they would be used to fill in the struct
5858          * timeval. */
5859         {
5860             STRLEN len;
5861             int fd = atoi(pmlenv);
5862             if (!fd)
5863                 fd = PERL_MEM_LOG_FD;
5864
5865             if (strchr(pmlenv, 't')) {
5866                 len = my_snprintf(buf, sizeof(buf),
5867                                 MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
5868                 PerlLIO_write(fd, buf, len);
5869             }
5870             switch (mlt) {
5871             case MLT_ALLOC:
5872                 len = my_snprintf(buf, sizeof(buf),
5873                         "alloc: %s:%d:%s: %"IVdf" %"UVuf
5874                         " %s = %"IVdf": %"UVxf"\n",
5875                         filename, linenumber, funcname, n, typesize,
5876                         type_name, n * typesize, PTR2UV(newalloc));
5877                 break;
5878             case MLT_REALLOC:
5879                 len = my_snprintf(buf, sizeof(buf),
5880                         "realloc: %s:%d:%s: %"IVdf" %"UVuf
5881                         " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5882                         filename, linenumber, funcname, n, typesize,
5883                         type_name, n * typesize, PTR2UV(oldalloc),
5884                         PTR2UV(newalloc));
5885                 break;
5886             case MLT_FREE:
5887                 len = my_snprintf(buf, sizeof(buf),
5888                         "free: %s:%d:%s: %"UVxf"\n",
5889                         filename, linenumber, funcname,
5890                         PTR2UV(oldalloc));
5891                 break;
5892             case MLT_NEW_SV:
5893             case MLT_DEL_SV:
5894                 len = my_snprintf(buf, sizeof(buf),
5895                         "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n",
5896                         mlt == MLT_NEW_SV ? "new" : "del",
5897                         filename, linenumber, funcname,
5898                         PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
5899                 break;
5900             default:
5901                 len = 0;
5902             }
5903             PerlLIO_write(fd, buf, len);
5904         }
5905     }
5906 }
5907 #endif /* !PERL_MEM_LOG_NOIMPL */
5908
5909 #ifndef PERL_MEM_LOG_NOIMPL
5910 # define \
5911     mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \
5912     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
5913 #else
5914 /* this is suboptimal, but bug compatible.  User is providing their
5915    own implementation, but is getting these functions anyway, and they
5916    do nothing. But _NOIMPL users should be able to cope or fix */
5917 # define \
5918     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
5919     /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */
5920 #endif
5921
5922 Malloc_t
5923 Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
5924                    Malloc_t newalloc, 
5925                    const char *filename, const int linenumber,
5926                    const char *funcname)
5927 {
5928     mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
5929                       NULL, NULL, newalloc,
5930                       filename, linenumber, funcname);
5931     return newalloc;
5932 }
5933
5934 Malloc_t
5935 Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
5936                      Malloc_t oldalloc, Malloc_t newalloc, 
5937                      const char *filename, const int linenumber, 
5938                      const char *funcname)
5939 {
5940     mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
5941                       NULL, oldalloc, newalloc, 
5942                       filename, linenumber, funcname);
5943     return newalloc;
5944 }
5945
5946 Malloc_t
5947 Perl_mem_log_free(Malloc_t oldalloc, 
5948                   const char *filename, const int linenumber, 
5949                   const char *funcname)
5950 {
5951     mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, 
5952                       filename, linenumber, funcname);
5953     return oldalloc;
5954 }
5955
5956 void
5957 Perl_mem_log_new_sv(const SV *sv, 
5958                     const char *filename, const int linenumber,
5959                     const char *funcname)
5960 {
5961     mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
5962                       filename, linenumber, funcname);
5963 }
5964
5965 void
5966 Perl_mem_log_del_sv(const SV *sv,
5967                     const char *filename, const int linenumber, 
5968                     const char *funcname)
5969 {
5970     mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, 
5971                       filename, linenumber, funcname);
5972 }
5973
5974 #endif /* PERL_MEM_LOG */
5975
5976 /*
5977 =for apidoc my_sprintf
5978
5979 The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5980 the length of the string written to the buffer. Only rare pre-ANSI systems
5981 need the wrapper function - usually this is a direct call to C<sprintf>.
5982
5983 =cut
5984 */
5985 #ifndef SPRINTF_RETURNS_STRLEN
5986 int
5987 Perl_my_sprintf(char *buffer, const char* pat, ...)
5988 {
5989     va_list args;
5990     PERL_ARGS_ASSERT_MY_SPRINTF;
5991     va_start(args, pat);
5992     vsprintf(buffer, pat, args);
5993     va_end(args);
5994     return strlen(buffer);
5995 }
5996 #endif
5997
5998 /*
5999 =for apidoc my_snprintf
6000
6001 The C library C<snprintf> functionality, if available and
6002 standards-compliant (uses C<vsnprintf>, actually).  However, if the
6003 C<vsnprintf> is not available, will unfortunately use the unsafe
6004 C<vsprintf> which can overrun the buffer (there is an overrun check,
6005 but that may be too late).  Consider using C<sv_vcatpvf> instead, or
6006 getting C<vsnprintf>.
6007
6008 =cut
6009 */
6010 int
6011 Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
6012 {
6013     int retval;
6014     va_list ap;
6015     PERL_ARGS_ASSERT_MY_SNPRINTF;
6016     va_start(ap, format);
6017 #ifdef HAS_VSNPRINTF
6018     retval = vsnprintf(buffer, len, format, ap);
6019 #else
6020     retval = vsprintf(buffer, format, ap);
6021 #endif
6022     va_end(ap);
6023     /* vsprintf() shows failure with < 0 */
6024     if (retval < 0
6025 #ifdef HAS_VSNPRINTF
6026     /* vsnprintf() shows failure with >= len */
6027         ||
6028         (len > 0 && (Size_t)retval >= len) 
6029 #endif
6030     )
6031         Perl_croak_nocontext("panic: my_snprintf buffer overflow");
6032     return retval;
6033 }
6034
6035 /*
6036 =for apidoc my_vsnprintf
6037
6038 The C library C<vsnprintf> if available and standards-compliant.
6039 However, if if the C<vsnprintf> is not available, will unfortunately
6040 use the unsafe C<vsprintf> which can overrun the buffer (there is an
6041 overrun check, but that may be too late).  Consider using
6042 C<sv_vcatpvf> instead, or getting C<vsnprintf>.
6043
6044 =cut
6045 */
6046 int
6047 Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
6048 {
6049     int retval;
6050 #ifdef NEED_VA_COPY
6051     va_list apc;
6052
6053     PERL_ARGS_ASSERT_MY_VSNPRINTF;
6054
6055     Perl_va_copy(ap, apc);
6056 # ifdef HAS_VSNPRINTF
6057     retval = vsnprintf(buffer, len, format, apc);
6058 # else
6059     retval = vsprintf(buffer, format, apc);
6060 # endif
6061 #else
6062 # ifdef HAS_VSNPRINTF
6063     retval = vsnprintf(buffer, len, format, ap);
6064 # else
6065     retval = vsprintf(buffer, format, ap);
6066 # endif
6067 #endif /* #ifdef NEED_VA_COPY */
6068     /* vsprintf() shows failure with < 0 */
6069     if (retval < 0
6070 #ifdef HAS_VSNPRINTF
6071     /* vsnprintf() shows failure with >= len */
6072         ||
6073         (len > 0 && (Size_t)retval >= len) 
6074 #endif
6075     )
6076         Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
6077     return retval;
6078 }
6079
6080 void
6081 Perl_my_clearenv(pTHX)
6082 {
6083     dVAR;
6084 #if ! defined(PERL_MICRO)
6085 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
6086     PerlEnv_clearenv();
6087 #  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
6088 #    if defined(USE_ENVIRON_ARRAY)
6089 #      if defined(USE_ITHREADS)
6090     /* only the parent thread can clobber the process environment */
6091     if (PL_curinterp == aTHX)
6092 #      endif /* USE_ITHREADS */
6093     {
6094 #      if ! defined(PERL_USE_SAFE_PUTENV)
6095     if ( !PL_use_safe_putenv) {
6096       I32 i;
6097       if (environ == PL_origenviron)
6098         environ = (char**)safesysmalloc(sizeof(char*));
6099       else
6100         for (i = 0; environ[i]; i++)
6101           (void)safesysfree(environ[i]);
6102     }
6103     environ[0] = NULL;
6104 #      else /* PERL_USE_SAFE_PUTENV */
6105 #        if defined(HAS_CLEARENV)
6106     (void)clearenv();
6107 #        elif defined(HAS_UNSETENV)
6108     int bsiz = 80; /* Most envvar names will be shorter than this. */
6109     int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
6110     char *buf = (char*)safesysmalloc(bufsiz);
6111     while (*environ != NULL) {
6112       char *e = strchr(*environ, '=');
6113       int l = e ? e - *environ : (int)strlen(*environ);
6114       if (bsiz < l + 1) {
6115         (void)safesysfree(buf);
6116         bsiz = l + 1; /* + 1 for the \0. */
6117         buf = (char*)safesysmalloc(bufsiz);
6118       } 
6119       memcpy(buf, *environ, l);
6120       buf[l] = '\0';
6121       (void)unsetenv(buf);
6122     }
6123     (void)safesysfree(buf);
6124 #        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
6125     /* Just null environ and accept the leakage. */
6126     *environ = NULL;
6127 #        endif /* HAS_CLEARENV || HAS_UNSETENV */
6128 #      endif /* ! PERL_USE_SAFE_PUTENV */
6129     }
6130 #    endif /* USE_ENVIRON_ARRAY */
6131 #  endif /* PERL_IMPLICIT_SYS || WIN32 */
6132 #endif /* PERL_MICRO */
6133 }
6134
6135 #ifdef PERL_IMPLICIT_CONTEXT
6136
6137 /* Implements the MY_CXT_INIT macro. The first time a module is loaded,
6138 the global PL_my_cxt_index is incremented, and that value is assigned to
6139 that module's static my_cxt_index (who's address is passed as an arg).
6140 Then, for each interpreter this function is called for, it makes sure a
6141 void* slot is available to hang the static data off, by allocating or
6142 extending the interpreter's PL_my_cxt_list array */
6143
6144 #ifndef PERL_GLOBAL_STRUCT_PRIVATE
6145 void *
6146 Perl_my_cxt_init(pTHX_ int *index, size_t size)
6147 {
6148     dVAR;
6149     void *p;
6150     PERL_ARGS_ASSERT_MY_CXT_INIT;
6151     if (*index == -1) {
6152         /* this module hasn't been allocated an index yet */
6153 #if defined(USE_ITHREADS)
6154         MUTEX_LOCK(&PL_my_ctx_mutex);
6155 #endif
6156         *index = PL_my_cxt_index++;
6157 #if defined(USE_ITHREADS)
6158         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6159 #endif
6160     }
6161     
6162     /* make sure the array is big enough */
6163     if (PL_my_cxt_size <= *index) {
6164         if (PL_my_cxt_size) {
6165             while (PL_my_cxt_size <= *index)
6166                 PL_my_cxt_size *= 2;
6167             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6168         }
6169         else {
6170             PL_my_cxt_size = 16;
6171             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6172         }
6173     }
6174     /* newSV() allocates one more than needed */
6175     p = (void*)SvPVX(newSV(size-1));
6176     PL_my_cxt_list[*index] = p;
6177     Zero(p, size, char);
6178     return p;
6179 }
6180
6181 #else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6182
6183 int
6184 Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
6185 {
6186     dVAR;
6187     int index;
6188
6189     PERL_ARGS_ASSERT_MY_CXT_INDEX;
6190
6191     for (index = 0; index < PL_my_cxt_index; index++) {
6192         const char *key = PL_my_cxt_keys[index];
6193         /* try direct pointer compare first - there are chances to success,
6194          * and it's much faster.
6195          */
6196         if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
6197             return index;
6198     }
6199     return -1;
6200 }
6201
6202 void *
6203 Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
6204 {
6205     dVAR;
6206     void *p;
6207     int index;
6208
6209     PERL_ARGS_ASSERT_MY_CXT_INIT;
6210
6211     index = Perl_my_cxt_index(aTHX_ my_cxt_key);
6212     if (index == -1) {
6213         /* this module hasn't been allocated an index yet */
6214 #if defined(USE_ITHREADS)
6215         MUTEX_LOCK(&PL_my_ctx_mutex);
6216 #endif
6217         index = PL_my_cxt_index++;
6218 #if defined(USE_ITHREADS)
6219         MUTEX_UNLOCK(&PL_my_ctx_mutex);
6220 #endif
6221     }
6222
6223     /* make sure the array is big enough */
6224     if (PL_my_cxt_size <= index) {
6225         int old_size = PL_my_cxt_size;
6226         int i;
6227         if (PL_my_cxt_size) {
6228             while (PL_my_cxt_size <= index)
6229                 PL_my_cxt_size *= 2;
6230             Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
6231             Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6232         }
6233         else {
6234             PL_my_cxt_size = 16;
6235             Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
6236             Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
6237         }
6238         for (i = old_size; i < PL_my_cxt_size; i++) {
6239             PL_my_cxt_keys[i] = 0;
6240             PL_my_cxt_list[i] = 0;
6241         }
6242     }
6243     PL_my_cxt_keys[index] = my_cxt_key;
6244     /* newSV() allocates one more than needed */
6245     p = (void*)SvPVX(newSV(size-1));
6246     PL_my_cxt_list[index] = p;
6247     Zero(p, size, char);
6248     return p;
6249 }
6250 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
6251 #endif /* PERL_IMPLICIT_CONTEXT */
6252
6253 void
6254 Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
6255                           STRLEN xs_len)
6256 {
6257     SV *sv;
6258     const char *vn = NULL;
6259     SV *const module = PL_stack_base[ax];
6260
6261     PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
6262
6263     if (items >= 2)      /* version supplied as bootstrap arg */
6264         sv = PL_stack_base[ax + 1];
6265     else {
6266         /* XXX GV_ADDWARN */
6267         vn = "XS_VERSION";
6268         sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6269         if (!sv || !SvOK(sv)) {
6270             vn = "VERSION";
6271             sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
6272         }
6273     }
6274     if (sv) {
6275         SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
6276         SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
6277             ? sv : sv_2mortal(new_version(sv));
6278         xssv = upg_version(xssv, 0);
6279         if ( vcmp(pmsv,xssv) ) {
6280             SV *string = vstringify(xssv);
6281             SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
6282                                     " does not match ", module, string);
6283
6284             SvREFCNT_dec(string);
6285             string = vstringify(pmsv);
6286
6287             if (vn) {
6288                 Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
6289                                string);
6290             } else {
6291                 Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
6292             }
6293             SvREFCNT_dec(string);
6294
6295             Perl_sv_2mortal(aTHX_ xpt);
6296             Perl_croak_sv(aTHX_ xpt);
6297         }
6298     }
6299 }
6300
6301 void
6302 Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
6303                              STRLEN api_len)
6304 {
6305     SV *xpt = NULL;
6306     SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
6307     SV *runver;
6308
6309     PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
6310
6311     /* This might croak  */
6312     compver = upg_version(compver, 0);
6313     /* This should never croak */
6314     runver = new_version(PL_apiversion);
6315     if (vcmp(compver, runver)) {
6316         SV *compver_string = vstringify(compver);
6317         SV *runver_string = vstringify(runver);
6318         xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
6319                             " of %"SVf" does not match %"SVf,
6320                             compver_string, module, runver_string);
6321         Perl_sv_2mortal(aTHX_ xpt);
6322
6323         SvREFCNT_dec(compver_string);
6324         SvREFCNT_dec(runver_string);
6325     }
6326     SvREFCNT_dec(runver);
6327     if (xpt)
6328         Perl_croak_sv(aTHX_ xpt);
6329 }
6330
6331 #ifndef HAS_STRLCAT
6332 Size_t
6333 Perl_my_strlcat(char *dst, const char *src, Size_t size)
6334 {
6335     Size_t used, length, copy;
6336
6337     used = strlen(dst);
6338     length = strlen(src);
6339     if (size > 0 && used < size - 1) {
6340         copy = (length >= size - used) ? size - used - 1 : length;
6341         memcpy(dst + used, src, copy);
6342         dst[used + copy] = '\0';
6343     }
6344     return used + length;
6345 }
6346 #endif
6347
6348 #ifndef HAS_STRLCPY
6349 Size_t
6350 Perl_my_strlcpy(char *dst, const char *src, Size_t size)
6351 {
6352     Size_t length, copy;
6353
6354     length = strlen(src);
6355     if (size > 0) {
6356         copy = (length >= size) ? size - 1 : length;
6357         memcpy(dst, src, copy);
6358         dst[copy] = '\0';
6359     }
6360     return length;
6361 }
6362 #endif
6363
6364 #if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
6365 /* VC7 or 7.1, building with pre-VC7 runtime libraries. */
6366 long _ftol( double ); /* Defined by VC6 C libs. */
6367 long _ftol2( double dblSource ) { return _ftol( dblSource ); }
6368 #endif
6369
6370 PERL_STATIC_INLINE bool
6371 S_gv_has_usable_name(pTHX_ GV *gv)
6372 {
6373     GV **gvp;
6374     return GvSTASH(gv)
6375         && HvENAME(GvSTASH(gv))
6376         && (gvp = (GV **)hv_fetch(
6377                         GvSTASH(gv), GvNAME(gv),
6378                         GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
6379            ))
6380         && *gvp == gv;
6381 }
6382
6383 void
6384 Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
6385 {
6386     dVAR;
6387     SV * const dbsv = GvSVn(PL_DBsub);
6388     const bool save_taint = TAINT_get; /* Accepted unused var warning under NO_TAINT_SUPPORT */
6389
6390     /* When we are called from pp_goto (svp is null),
6391      * we do not care about using dbsv to call CV;
6392      * it's for informational purposes only.
6393      */
6394
6395     PERL_ARGS_ASSERT_GET_DB_SUB;
6396
6397     TAINT_set(FALSE);
6398     save_item(dbsv);
6399     if (!PERLDB_SUB_NN) {
6400         GV *gv = CvGV(cv);
6401
6402         if (!svp) {
6403             gv_efullname3(dbsv, gv, NULL);
6404         }
6405         else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
6406              || strEQ(GvNAME(gv), "END")
6407              || ( /* Could be imported, and old sub redefined. */
6408                  (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
6409                  &&
6410                  !( (SvTYPE(*svp) == SVt_PVGV)
6411                     && (GvCV((const GV *)*svp) == cv)
6412                     /* Use GV from the stack as a fallback. */
6413                     && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) 
6414                   )
6415                 )
6416         ) {
6417             /* GV is potentially non-unique, or contain different CV. */
6418             SV * const tmp = newRV(MUTABLE_SV(cv));
6419             sv_setsv(dbsv, tmp);
6420             SvREFCNT_dec(tmp);
6421         }
6422         else {
6423             sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
6424             sv_catpvs(dbsv, "::");
6425             sv_catpvn_flags(
6426               dbsv, GvNAME(gv), GvNAMELEN(gv),
6427               GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
6428             );
6429         }
6430     }
6431     else {
6432         const int type = SvTYPE(dbsv);
6433         if (type < SVt_PVIV && type != SVt_IV)
6434             sv_upgrade(dbsv, SVt_PVIV);
6435         (void)SvIOK_on(dbsv);
6436         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
6437     }
6438     TAINT_IF(save_taint);
6439 }
6440
6441 int
6442 Perl_my_dirfd(pTHX_ DIR * dir) {
6443
6444     /* Most dirfd implementations have problems when passed NULL. */
6445     if(!dir)
6446         return -1;
6447 #ifdef HAS_DIRFD
6448     return dirfd(dir);
6449 #elif defined(HAS_DIR_DD_FD)
6450     return dir->dd_fd;
6451 #else
6452     Perl_die(aTHX_ PL_no_func, "dirfd");
6453     assert(0); /* NOT REACHED */
6454     return 0;
6455 #endif 
6456 }
6457
6458 REGEXP *
6459 Perl_get_re_arg(pTHX_ SV *sv) {
6460
6461     if (sv) {
6462         if (SvMAGICAL(sv))
6463             mg_get(sv);
6464         if (SvROK(sv))
6465             sv = MUTABLE_SV(SvRV(sv));
6466         if (SvTYPE(sv) == SVt_REGEXP)
6467             return (REGEXP*) sv;
6468     }
6469  
6470     return NULL;
6471 }
6472
6473 /*
6474  * Local variables:
6475  * c-indentation-style: bsd
6476  * c-basic-offset: 4
6477  * indent-tabs-mode: nil
6478  * End:
6479  *
6480  * ex: set ts=8 sts=4 sw=4 et:
6481  */