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