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