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