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