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