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