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
Re: [PATCH] Version object combined patch
[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);
3aed30dc 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,
3aed30dc 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
3aed30dc 1336 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
4d1ff10f 1337#endif /* USE_5005THREADS */
3aed30dc
HS		 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();
3aed30dc
HS		 1352 msg = newSVpvn(message, msglen);
1353 SvREADONLY_on(msg);
1354 SAVEFREESV(msg);
a1d180c4 1355
3a1f2dc9 1356 PUSHSTACKi(PERLSI_DIEHOOK);
3aed30dc
HS		 1357 PUSHMARK(sp);
1358 XPUSHs(msg);
1359 PUTBACK;
1360 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1361 POPSTACK;
3aed30dc
HS		 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 }
3aed30dc 1374 my_failure_exit();
599cee73
PM		 1375 }
1376 else {
3aed30dc
HS		 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;
3aed30dc
HS		 1385 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1386 dSP;
1387 SV *msg;
a1d180c4 1388
3aed30dc 1389 ENTER;
3a1f2dc9 1390 save_re_context();
3aed30dc
HS		 1391 msg = newSVpvn(message, msglen);
1392 SvREADONLY_on(msg);
1393 SAVEFREESV(msg);
a1d180c4 1394
3a1f2dc9 1395 PUSHSTACKi(PERLSI_WARNHOOK);
3aed30dc
HS		 1396 PUSHMARK(sp);
1397 XPUSHs(msg);
1398 PUTBACK;
1399 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1400 POPSTACK;
3aed30dc
HS		 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 */
3aed30dc
HS		 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) {
3aed30dc 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++) {
3aed30dc 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 {
3aed30dc 1976 int fd;
a080fe3d
NIS		 1977
1978 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
1979 if (fd != pp[1])
3aed30dc 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))) {
4d76a344 1990 SvREADONLY_off(GvSV(tmpgv));
7766f137 1991 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 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
2182Sighandler_t
864dbfa3 2183Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2184{
2185 struct sigaction act, oact;
2186
a10b1e10
JH		 2187#ifdef USE_ITHREADS
2188 /* only "parent" interpreter can diddle signals */
2189 if (PL_curinterp != aTHX)
2190 return SIG_ERR;
2191#endif
2192
ff68c719 2193 act.sa_handler = handler;
2194 sigemptyset(&act.sa_mask);
2195 act.sa_flags = 0;
2196#ifdef SA_RESTART
0dd95eb2 2197#if defined(PERL_OLD_SIGNALS)
ff68c719 2198 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2199#endif
0a8e0eff 2200#endif
85264bed
CS		 2201#ifdef SA_NOCLDWAIT
2202 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2203 act.sa_flags |= SA_NOCLDWAIT;
2204#endif
ff68c719 2205 if (sigaction(signo, &act, &oact) == -1)
36477c24 2206 return SIG_ERR;
ff68c719 2207 else
36477c24 2208 return oact.sa_handler;
ff68c719 2209}
2210
2211Sighandler_t
864dbfa3 2212Perl_rsignal_state(pTHX_ int signo)
ff68c719 2213{
2214 struct sigaction oact;
2215
2216 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3aed30dc 2217 return SIG_ERR;
ff68c719 2218 else
3aed30dc 2219 return oact.sa_handler;
ff68c719 2220}
2221
2222int
864dbfa3 2223Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2224{
2225 struct sigaction act;
2226
a10b1e10
JH		 2227#ifdef USE_ITHREADS
2228 /* only "parent" interpreter can diddle signals */
2229 if (PL_curinterp != aTHX)
2230 return -1;
2231#endif
2232
ff68c719 2233 act.sa_handler = handler;
2234 sigemptyset(&act.sa_mask);
2235 act.sa_flags = 0;
2236#ifdef SA_RESTART
0dd95eb2 2237#if defined(PERL_OLD_SIGNALS)
ff68c719 2238 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2239#endif
0a8e0eff 2240#endif
85264bed
CS		 2241#ifdef SA_NOCLDWAIT
2242 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2243 act.sa_flags |= SA_NOCLDWAIT;
2244#endif
ff68c719 2245 return sigaction(signo, &act, save);
2246}
2247
2248int
864dbfa3 2249Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2250{
a10b1e10
JH		 2251#ifdef USE_ITHREADS
2252 /* only "parent" interpreter can diddle signals */
2253 if (PL_curinterp != aTHX)
2254 return -1;
2255#endif
2256
ff68c719 2257 return sigaction(signo, save, (struct sigaction *)NULL);
2258}
2259
2260#else /* !HAS_SIGACTION */
2261
2262Sighandler_t
864dbfa3 2263Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2264{
39f1703b 2265#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2266 /* only "parent" interpreter can diddle signals */
2267 if (PL_curinterp != aTHX)
2268 return SIG_ERR;
2269#endif
2270
6ad3d225 2271 return PerlProc_signal(signo, handler);
ff68c719 2272}
2273
df3728a2
JH		 2274static int sig_trapped; /* XXX signals are process-wide anyway, so we
2275 ignore the implications of this for threading */
ff68c719 2276
2277static
2278Signal_t
4e35701f 2279sig_trap(int signo)
ff68c719 2280{
2281 sig_trapped++;
2282}
2283
2284Sighandler_t
864dbfa3 2285Perl_rsignal_state(pTHX_ int signo)
ff68c719 2286{
2287 Sighandler_t oldsig;
2288
39f1703b 2289#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2290 /* only "parent" interpreter can diddle signals */
2291 if (PL_curinterp != aTHX)
2292 return SIG_ERR;
2293#endif
2294
ff68c719 2295 sig_trapped = 0;
6ad3d225
GS		 2296 oldsig = PerlProc_signal(signo, sig_trap);
2297 PerlProc_signal(signo, oldsig);
ff68c719 2298 if (sig_trapped)
3aed30dc 2299 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2300 return oldsig;
2301}
2302
2303int
864dbfa3 2304Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2305{
39f1703b 2306#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2307 /* only "parent" interpreter can diddle signals */
2308 if (PL_curinterp != aTHX)
2309 return -1;
2310#endif
6ad3d225 2311 *save = PerlProc_signal(signo, handler);
ff68c719 2312 return (*save == SIG_ERR) ? -1 : 0;
2313}
2314
2315int
864dbfa3 2316Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2317{
39f1703b 2318#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2319 /* only "parent" interpreter can diddle signals */
2320 if (PL_curinterp != aTHX)
2321 return -1;
2322#endif
6ad3d225 2323 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2324}
2325
2326#endif /* !HAS_SIGACTION */
64ca3a65 2327#endif /* !PERL_MICRO */
ff68c719 2328
5f05dabc 2329 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2330#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2331I32
864dbfa3 2332Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2333{
ff68c719 2334 Sigsave_t hstat, istat, qstat;
a687059c 2335 int status;
a0d0e21e 2336 SV **svp;
d8a83dd3
JH		 2337 Pid_t pid;
2338 Pid_t pid2;
03136e13 2339 bool close_failed;
b7953727 2340 int saved_errno = 0;
03136e13
CS		 2341#ifdef VMS
2342 int saved_vaxc_errno;
2343#endif
22fae026
TM		 2344#ifdef WIN32
2345 int saved_win32_errno;
2346#endif
a687059c 2347
4755096e 2348 LOCK_FDPID_MUTEX;
3280af22 2349 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2350 UNLOCK_FDPID_MUTEX;
25d92023 2351 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2352 SvREFCNT_dec(*svp);
3280af22 2353 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2354#ifdef OS2
2355 if (pid == -1) { /* Opened by popen. */
2356 return my_syspclose(ptr);
2357 }
a1d180c4 2358#endif
03136e13
CS		 2359 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2360 saved_errno = errno;
2361#ifdef VMS
2362 saved_vaxc_errno = vaxc$errno;
2363#endif
22fae026
TM		 2364#ifdef WIN32
2365 saved_win32_errno = GetLastError();
2366#endif
03136e13 2367 }
7c0587c8 2368#ifdef UTS
6ad3d225 2369 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2370#endif
64ca3a65 2371#ifndef PERL_MICRO
ff68c719 2372 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2373 rsignal_save(SIGINT, SIG_IGN, &istat);
2374 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2375#endif
748a9306 2376 do {
1d3434b8
GS		 2377 pid2 = wait4pid(pid, &status, 0);
2378 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2379#ifndef PERL_MICRO
ff68c719 2380 rsignal_restore(SIGHUP, &hstat);
2381 rsignal_restore(SIGINT, &istat);
2382 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2383#endif
03136e13
CS		 2384 if (close_failed) {
2385 SETERRNO(saved_errno, saved_vaxc_errno);
2386 return -1;
2387 }
1d3434b8 2388 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2389}
4633a7c4
LW		 2390#endif /* !DOSISH */
2391
2986a63f 2392#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2393I32
d8a83dd3 2394Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2395{
cddd4526 2396 I32 result;
b7953727
JH		 2397 if (!pid)
2398 return -1;
2399#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2400 {
3aed30dc
HS		 2401 SV *sv;
2402 SV** svp;
2403 char spid[TYPE_CHARS(int)];
20188a90 2404
3aed30dc 2405 if (pid > 0) {
7b0972df 2406 sprintf(spid, "%"IVdf, (IV)pid);
3aed30dc
HS		 2407 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2408 if (svp && *svp != &PL_sv_undef) {
2409 *statusp = SvIVX(*svp);
2410 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2411 return pid;
2412 }
2413 }
2414 else {
2415 HE *entry;
2416
2417 hv_iterinit(PL_pidstatus);
2418 if ((entry = hv_iternext(PL_pidstatus))) {
2419 SV *sv;
2420 char spid[TYPE_CHARS(int)];
2421
2422 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2423 sv = hv_iterval(PL_pidstatus,entry);
2424 *statusp = SvIVX(sv);
2425 sprintf(spid, "%"IVdf, (IV)pid);
2426 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2427 return pid;
2428 }
20188a90
LW		 2429 }
2430 }
68a29c53 2431#endif
79072805 2432#ifdef HAS_WAITPID
367f3c24
IZ		 2433# ifdef HAS_WAITPID_RUNTIME
2434 if (!HAS_WAITPID_RUNTIME)
2435 goto hard_way;
2436# endif
cddd4526 2437 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2438 goto finish;
367f3c24
IZ		 2439#endif
2440#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
cddd4526 2441 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
dfcfdb64 2442 goto finish;
367f3c24
IZ		 2443#endif
2444#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2445 hard_way:
a0d0e21e 2446 {
a0d0e21e 2447 if (flags)
cea2e8a9 2448 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2449 else {
76e3520e 2450 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2451 pidgone(result,*statusp);
2452 if (result < 0)
2453 *statusp = -1;
2454 }
a687059c
LW		 2455 }
2456#endif
dfcfdb64 2457 finish:
cddd4526
NIS		 2458 if (result < 0 && errno == EINTR) {
2459 PERL_ASYNC_CHECK();
2460 }
2461 return result;
a687059c 2462}
2986a63f 2463#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2464
7c0587c8 2465void
de3bb511 2466/*SUPPRESS 590*/
d8a83dd3 2467Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2468{
79072805 2469 register SV *sv;
fc36a67e 2470 char spid[TYPE_CHARS(int)];
a687059c 2471
7b0972df 2472 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2473 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2474 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2475 SvIVX(sv) = status;
20188a90 2476 return;
a687059c
LW		 2477}
2478
85ca448a 2479#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2480int pclose();
ddcf38b7
IZ		 2481#ifdef HAS_FORK
2482int /* Cannot prototype with I32
2483 in os2ish.h. */
ba106d47 2484my_syspclose(PerlIO *ptr)
ddcf38b7 2485#else
79072805 2486I32
864dbfa3 2487Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2488#endif
a687059c 2489{
760ac839
LW		 2490 /* Needs work for PerlIO ! */
2491 FILE *f = PerlIO_findFILE(ptr);
2492 I32 result = pclose(f);
2b96b0a5
JH		 2493 PerlIO_releaseFILE(ptr,f);
2494 return result;
2495}
2496#endif
2497
933fea7f 2498#if defined(DJGPP)
2b96b0a5
JH		 2499int djgpp_pclose();
2500I32
2501Perl_my_pclose(pTHX_ PerlIO *ptr)
2502{
2503 /* Needs work for PerlIO ! */
2504 FILE *f = PerlIO_findFILE(ptr);
2505 I32 result = djgpp_pclose(f);
933fea7f 2506 result = (result << 8) & 0xff00;
760ac839
LW		 2507 PerlIO_releaseFILE(ptr,f);
2508 return result;
a687059c 2509}
7c0587c8 2510#endif
9f68db38
LW		 2511
2512void
864dbfa3 2513Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2514{
79072805 2515 register I32 todo;
08105a92 2516 register const char *frombase = from;
9f68db38
LW		 2517
2518 if (len == 1) {
08105a92 2519 register const char c = *from;
9f68db38 2520 while (count-- > 0)
5926133d 2521 *to++ = c;
9f68db38
LW		 2522 return;
2523 }
2524 while (count-- > 0) {
2525 for (todo = len; todo > 0; todo--) {
2526 *to++ = *from++;
2527 }
2528 from = frombase;
2529 }
2530}
0f85fab0 2531
fe14fcc3 2532#ifndef HAS_RENAME
79072805 2533I32
864dbfa3 2534Perl_same_dirent(pTHX_ char *a, char *b)
62b28dd9 2535{
93a17b20
LW		 2536 char *fa = strrchr(a,'/');
2537 char *fb = strrchr(b,'/');
c623ac67
GS		 2538 Stat_t tmpstatbuf1;
2539 Stat_t tmpstatbuf2;
46fc3d4c 2540 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2541
2542 if (fa)
2543 fa++;
2544 else
2545 fa = a;
2546 if (fb)
2547 fb++;
2548 else
2549 fb = b;
2550 if (strNE(a,b))
2551 return FALSE;
2552 if (fa == a)
46fc3d4c 2553 sv_setpv(tmpsv, ".");
62b28dd9 2554 else
46fc3d4c 2555 sv_setpvn(tmpsv, a, fa - a);
c6ed36e1 2556 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2557 return FALSE;
2558 if (fb == b)
46fc3d4c 2559 sv_setpv(tmpsv, ".");
62b28dd9 2560 else
46fc3d4c 2561 sv_setpvn(tmpsv, b, fb - b);
c6ed36e1 2562 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2563 return FALSE;
2564 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2565 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2566}
fe14fcc3
LW		 2567#endif /* !HAS_RENAME */
2568
491527d0 2569char*
864dbfa3 2570Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
491527d0 2571{
491527d0
GS		 2572 char *xfound = Nullch;
2573 char *xfailed = Nullch;
0f31cffe 2574 char tmpbuf[MAXPATHLEN];
491527d0 2575 register char *s;
5f74f29c 2576 I32 len = 0;
491527d0
GS		 2577 int retval;
2578#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2579# define SEARCH_EXTS ".bat", ".cmd", NULL
2580# define MAX_EXT_LEN 4
2581#endif
2582#ifdef OS2
2583# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2584# define MAX_EXT_LEN 4
2585#endif
2586#ifdef VMS
2587# define SEARCH_EXTS ".pl", ".com", NULL
2588# define MAX_EXT_LEN 4
2589#endif
2590 /* additional extensions to try in each dir if scriptname not found */
2591#ifdef SEARCH_EXTS
2592 char *exts[] = { SEARCH_EXTS };
2593 char **ext = search_ext ? search_ext : exts;
2594 int extidx = 0, i = 0;
2595 char *curext = Nullch;
2596#else
2597# define MAX_EXT_LEN 0
2598#endif
2599
2600 /*
2601 * If dosearch is true and if scriptname does not contain path
2602 * delimiters, search the PATH for scriptname.
2603 *
2604 * If SEARCH_EXTS is also defined, will look for each
2605 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2606 * while searching the PATH.
2607 *
2608 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2609 * proceeds as follows:
2610 * If DOSISH or VMSISH:
2611 * + look for ./scriptname{,.foo,.bar}
2612 * + search the PATH for scriptname{,.foo,.bar}
2613 *
2614 * If !DOSISH:
2615 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2616 * this will not look in '.' if it's not in the PATH)
2617 */
84486fc6 2618 tmpbuf[0] = '\0';
491527d0
GS		 2619
2620#ifdef VMS
2621# ifdef ALWAYS_DEFTYPES
2622 len = strlen(scriptname);
2623 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2624 int hasdir, idx = 0, deftypes = 1;
2625 bool seen_dot = 1;
2626
2627 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2628# else
2629 if (dosearch) {
2630 int hasdir, idx = 0, deftypes = 1;
2631 bool seen_dot = 1;
2632
2633 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2634# endif
2635 /* The first time through, just add SEARCH_EXTS to whatever we
2636 * already have, so we can check for default file types. */
2637 while (deftypes ||
84486fc6 2638 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 2639 {
2640 if (deftypes) {
2641 deftypes = 0;
84486fc6 2642 *tmpbuf = '\0';
491527d0 2643 }
84486fc6
GS		 2644 if ((strlen(tmpbuf) + strlen(scriptname)
2645 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 2646 continue; /* don't search dir with too-long name */
84486fc6 2647 strcat(tmpbuf, scriptname);
491527d0
GS		 2648#else /* !VMS */
2649
2650#ifdef DOSISH
2651 if (strEQ(scriptname, "-"))
2652 dosearch = 0;
2653 if (dosearch) { /* Look in '.' first. */
2654 char *cur = scriptname;
2655#ifdef SEARCH_EXTS
2656 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2657 while (ext[i])
2658 if (strEQ(ext[i++],curext)) {
2659 extidx = -1; /* already has an ext */
2660 break;
2661 }
2662 do {
2663#endif
2664 DEBUG_p(PerlIO_printf(Perl_debug_log,
2665 "Looking for %s\n",cur));
017f25f1
IZ		 2666 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2667 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 2668 dosearch = 0;
2669 scriptname = cur;
2670#ifdef SEARCH_EXTS
2671 break;
2672#endif
2673 }
2674#ifdef SEARCH_EXTS
2675 if (cur == scriptname) {
2676 len = strlen(scriptname);
84486fc6 2677 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 2678 break;
84486fc6 2679 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 2680 }
2681 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 2682 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 2683#endif
2684 }
2685#endif
2686
cd39f2b6
JH		 2687#ifdef MACOS_TRADITIONAL
2688 if (dosearch && !strchr(scriptname, ':') &&
2689 (s = PerlEnv_getenv("Commands")))
2690#else
491527d0
GS		 2691 if (dosearch && !strchr(scriptname, '/')
2692#ifdef DOSISH
2693 && !strchr(scriptname, '\\')
2694#endif
cd39f2b6
JH		 2695 && (s = PerlEnv_getenv("PATH")))
2696#endif
2697 {
491527d0 2698 bool seen_dot = 0;
92f0c265 2699
3280af22
NIS		 2700 PL_bufend = s + strlen(s);
2701 while (s < PL_bufend) {
cd39f2b6
JH		 2702#ifdef MACOS_TRADITIONAL
2703 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2704 ',',
2705 &len);
2706#else
491527d0
GS		 2707#if defined(atarist) || defined(DOSISH)
2708 for (len = 0; *s
2709# ifdef atarist
2710 && *s != ','
2711# endif
2712 && *s != ';'; len++, s++) {
84486fc6
GS		 2713 if (len < sizeof tmpbuf)
2714 tmpbuf[len] = *s;
491527d0 2715 }
84486fc6
GS		 2716 if (len < sizeof tmpbuf)
2717 tmpbuf[len] = '\0';
491527d0 2718#else /* ! (atarist || DOSISH) */
3280af22 2719 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 2720 ':',
2721 &len);
2722#endif /* ! (atarist || DOSISH) */
cd39f2b6 2723#endif /* MACOS_TRADITIONAL */
3280af22 2724 if (s < PL_bufend)
491527d0 2725 s++;
84486fc6 2726 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 2727 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 2728#ifdef MACOS_TRADITIONAL
2729 if (len && tmpbuf[len - 1] != ':')
2730 tmpbuf[len++] = ':';
2731#else
491527d0 2732 if (len
61ae2fbf 2733#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 2734 && tmpbuf[len - 1] != '/'
2735 && tmpbuf[len - 1] != '\\'
491527d0
GS		 2736#endif
2737 )
84486fc6
GS		 2738 tmpbuf[len++] = '/';
2739 if (len == 2 && tmpbuf[0] == '.')
491527d0 2740 seen_dot = 1;
cd39f2b6 2741#endif
84486fc6 2742 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 2743#endif /* !VMS */
2744
2745#ifdef SEARCH_EXTS
84486fc6 2746 len = strlen(tmpbuf);
491527d0
GS		 2747 if (extidx > 0) /* reset after previous loop */
2748 extidx = 0;
2749 do {
2750#endif
84486fc6 2751 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 2752 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 2753 if (S_ISDIR(PL_statbuf.st_mode)) {
2754 retval = -1;
2755 }
491527d0
GS		 2756#ifdef SEARCH_EXTS
2757 } while ( retval < 0 /* not there */
2758 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 2759 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 2760 );
2761#endif
2762 if (retval < 0)
2763 continue;
3280af22
NIS		 2764 if (S_ISREG(PL_statbuf.st_mode)
2765 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 2766#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 2767 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 2768#endif
2769 )
2770 {
3aed30dc 2771 xfound = tmpbuf; /* bingo! */
491527d0
GS		 2772 break;
2773 }
2774 if (!xfailed)
84486fc6 2775 xfailed = savepv(tmpbuf);
491527d0
GS		 2776 }
2777#ifndef DOSISH
017f25f1 2778 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 2779 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 2780 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 2781#endif
2782 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 2783 if (!xfound) {
2784 if (flags & 1) { /* do or die? */
3aed30dc 2785 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 2786 (xfailed ? "execute" : "find"),
2787 (xfailed ? xfailed : scriptname),
2788 (xfailed ? "" : " on PATH"),
2789 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2790 }
2791 scriptname = Nullch;
2792 }
491527d0
GS		 2793 if (xfailed)
2794 Safefree(xfailed);
2795 scriptname = xfound;
2796 }
9ccb31f9 2797 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 2798}
2799
ba869deb
GS		 2800#ifndef PERL_GET_CONTEXT_DEFINED
2801
2802void *
2803Perl_get_context(void)
2804{
4d1ff10f 2805#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
ba869deb
GS		 2806# ifdef OLD_PTHREADS_API
2807 pthread_addr_t t;
2808 if (pthread_getspecific(PL_thr_key, &t))
2809 Perl_croak_nocontext("panic: pthread_getspecific");
2810 return (void*)t;
2811# else
bce813aa 2812# ifdef I_MACH_CTHREADS
8b8b35ab 2813 return (void*)cthread_data(cthread_self());
bce813aa 2814# else
8b8b35ab
JH		 2815 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2816# endif
c44d3fdb 2817# endif
ba869deb
GS		 2818#else
2819 return (void*)NULL;
2820#endif
2821}
2822
2823void
2824Perl_set_context(void *t)
2825{
4d1ff10f 2826#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
c44d3fdb
GS		 2827# ifdef I_MACH_CTHREADS
2828 cthread_set_data(cthread_self(), t);
2829# else
ba869deb
GS		 2830 if (pthread_setspecific(PL_thr_key, t))
2831 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 2832# endif
ba869deb
GS		 2833#endif
2834}
2835
2836#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 2837
4d1ff10f 2838#ifdef USE_5005THREADS
ba869deb 2839
12ca11f6
MB		 2840#ifdef FAKE_THREADS
2841/* Very simplistic scheduler for now */
2842void
2843schedule(void)
2844{
c7848ba1 2845 thr = thr->i.next_run;
12ca11f6
MB		 2846}
2847
2848void
864dbfa3 2849Perl_cond_init(pTHX_ perl_cond *cp)
12ca11f6
MB		 2850{
2851 *cp = 0;
2852}
2853
2854void
864dbfa3 2855Perl_cond_signal(pTHX_ perl_cond *cp)
12ca11f6 2856{
51dd5992 2857 perl_os_thread t;
12ca11f6 2858 perl_cond cond = *cp;
a1d180c4 2859
12ca11f6
MB		 2860 if (!cond)
2861 return;
2862 t = cond->thread;
2863 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB		 2864 t->i.next_run = thr->i.next_run;
2865 thr->i.next_run->i.prev_run = t;
2866 t->i.prev_run = thr;
2867 thr->i.next_run = t;
2868 thr->i.wait_queue = 0;
12ca11f6
MB		 2869 /* Remove from the wait queue */
2870 *cp = cond->next;
2871 Safefree(cond);
2872}
2873
2874void
864dbfa3 2875Perl_cond_broadcast(pTHX_ perl_cond *cp)
12ca11f6 2876{
51dd5992 2877 perl_os_thread t;
12ca11f6 2878 perl_cond cond, cond_next;
a1d180c4 2879
12ca11f6
MB		 2880 for (cond = *cp; cond; cond = cond_next) {
2881 t = cond->thread;
2882 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB		 2883 t->i.next_run = thr->i.next_run;
2884 thr->i.next_run->i.prev_run = t;
2885 t->i.prev_run = thr;
2886 thr->i.next_run = t;
2887 thr->i.wait_queue = 0;
12ca11f6
MB		 2888 /* Remove from the wait queue */
2889 cond_next = cond->next;
2890 Safefree(cond);
2891 }
2892 *cp = 0;
2893}
2894
2895void
864dbfa3 2896Perl_cond_wait(pTHX_ perl_cond *cp)
12ca11f6
MB		 2897{
2898 perl_cond cond;
2899
c7848ba1 2900 if (thr->i.next_run == thr)
cea2e8a9 2901 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
a1d180c4 2902
0f15f207 2903 New(666, cond, 1, struct perl_wait_queue);
12ca11f6
MB		 2904 cond->thread = thr;
2905 cond->next = *cp;
2906 *cp = cond;
c7848ba1 2907 thr->i.wait_queue = cond;
12ca11f6 2908 /* Remove ourselves from runnable queue */
c7848ba1
MB		 2909 thr->i.next_run->i.prev_run = thr->i.prev_run;
2910 thr->i.prev_run->i.next_run = thr->i.next_run;
12ca11f6
MB		 2911}
2912#endif /* FAKE_THREADS */
2913
f93b4edd 2914MAGIC *
864dbfa3 2915Perl_condpair_magic(pTHX_ SV *sv)
f93b4edd
MB		 2916{
2917 MAGIC *mg;
a1d180c4 2918
3e209e71 2919 (void)SvUPGRADE(sv, SVt_PVMG);
14befaf4 2920 mg = mg_find(sv, PERL_MAGIC_mutex);
f93b4edd
MB		 2921 if (!mg) {
2922 condpair_t *cp;
2923
2924 New(53, cp, 1, condpair_t);
2925 MUTEX_INIT(&cp->mutex);
2926 COND_INIT(&cp->owner_cond);
2927 COND_INIT(&cp->cond);
2928 cp->owner = 0;
1feb2720 2929 LOCK_CRED_MUTEX; /* XXX need separate mutex? */
14befaf4 2930 mg = mg_find(sv, PERL_MAGIC_mutex);
f93b4edd
MB		 2931 if (mg) {
2932 /* someone else beat us to initialising it */
1feb2720 2933 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
f93b4edd
MB		 2934 MUTEX_DESTROY(&cp->mutex);
2935 COND_DESTROY(&cp->owner_cond);
2936 COND_DESTROY(&cp->cond);
2937 Safefree(cp);
2938 }
2939 else {
14befaf4 2940 sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
f93b4edd
MB		 2941 mg = SvMAGIC(sv);
2942 mg->mg_ptr = (char *)cp;
565764a8 2943 mg->mg_len = sizeof(cp);
1feb2720 2944 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
bf49b057 2945 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
a674cc95 2946 "%p: condpair_magic %p\n", thr, sv)));
f93b4edd
MB		 2947 }
2948 }
2949 return mg;
2950}
a863c7d1 2951
3d35f11b 2952SV *
4755096e 2953Perl_sv_lock(pTHX_ SV *osv)
3d35f11b
GS		 2954{
2955 MAGIC *mg;
2956 SV *sv = osv;
2957
631cfb58 2958 LOCK_SV_LOCK_MUTEX;
3d35f11b
GS		 2959 if (SvROK(sv)) {
2960 sv = SvRV(sv);
3d35f11b
GS		 2961 }
2962
2963 mg = condpair_magic(sv);
2964 MUTEX_LOCK(MgMUTEXP(mg));
2965 if (MgOWNER(mg) == thr)
2966 MUTEX_UNLOCK(MgMUTEXP(mg));
4755096e 2967 else {
3d35f11b
GS		 2968 while (MgOWNER(mg))
2969 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2970 MgOWNER(mg) = thr;
4755096e
GS		 2971 DEBUG_S(PerlIO_printf(Perl_debug_log,
2972 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
a674cc95 2973 PTR2UV(thr), PTR2UV(sv)));
3d35f11b
GS		 2974 MUTEX_UNLOCK(MgMUTEXP(mg));
2975 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2976 }
631cfb58 2977 UNLOCK_SV_LOCK_MUTEX;
4755096e 2978 return sv;
3d35f11b
GS		 2979}
2980
a863c7d1 2981/*
199100c8
MB		 2982 * Make a new perl thread structure using t as a prototype. Some of the
2983 * fields for the new thread are copied from the prototype thread, t,
2984 * so t should not be running in perl at the time this function is
2985 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
2986 * thread calling new_struct_thread) clearly satisfies this constraint.
a863c7d1 2987 */
52e1cb5e 2988struct perl_thread *
864dbfa3 2989Perl_new_struct_thread(pTHX_ struct perl_thread *t)
a863c7d1 2990{
c5be433b 2991#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 2992 struct perl_thread *thr;
cea2e8a9 2993#endif
a863c7d1 2994 SV *sv;
199100c8
MB		 2995 SV **svp;
2996 I32 i;
2997
79cb57f6 2998 sv = newSVpvn("", 0);
52e1cb5e
JH		 2999 SvGROW(sv, sizeof(struct perl_thread) + 1);
3000 SvCUR_set(sv, sizeof(struct perl_thread));
199100c8 3001 thr = (Thread) SvPVX(sv);
949ced2d 3002#ifdef DEBUGGING
9965345d 3003 Poison(thr, 1, struct perl_thread);
533c011a
NIS		 3004 PL_markstack = 0;
3005 PL_scopestack = 0;
3006 PL_savestack = 0;
3007 PL_retstack = 0;
3008 PL_dirty = 0;
3009 PL_localizing = 0;
949ced2d 3010 Zero(&PL_hv_fetch_ent_mh, 1, HE);
d0e9ca0c
HS		 3011 PL_efloatbuf = (char*)NULL;
3012 PL_efloatsize = 0;
949ced2d
GS		 3013#else
3014 Zero(thr, 1, struct perl_thread);
3015#endif
199100c8
MB		 3016
3017 thr->oursv = sv;
cea2e8a9 3018 init_stacks();
a863c7d1 3019
533c011a 3020 PL_curcop = &PL_compiling;
c5be433b 3021 thr->interp = t->interp;
199100c8 3022 thr->cvcache = newHV();
54b9620d 3023 thr->threadsv = newAV();
a863c7d1 3024 thr->specific = newAV();
79cb57f6 3025 thr->errsv = newSVpvn("", 0);
a863c7d1 3026 thr->flags = THRf_R_JOINABLE;
8dcd6f7b 3027 thr->thr_done = 0;
a863c7d1 3028 MUTEX_INIT(&thr->mutex);
199100c8 3029
5c831c24 3030 JMPENV_BOOTSTRAP;
533c011a 3031
6dc8a9e4 3032 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
533c011a
NIS		 3033 PL_restartop = 0;
3034
b099ddc0 3035 PL_statname = NEWSV(66,0);
5a844595 3036 PL_errors = newSVpvn("", 0);
b099ddc0 3037 PL_maxscream = -1;
0b94c7bb
GS		 3038 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3039 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3040 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3041 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3042 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
b099ddc0
GS		 3043 PL_regindent = 0;
3044 PL_reginterp_cnt = 0;
3045 PL_lastscream = Nullsv;
3046 PL_screamfirst = 0;
3047 PL_screamnext = 0;
3048 PL_reg_start_tmp = 0;
3049 PL_reg_start_tmpl = 0;
14ed4b74 3050 PL_reg_poscache = Nullch;
b099ddc0 3051
a2efc822
SC		 3052 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3053
b099ddc0
GS		 3054 /* parent thread's data needs to be locked while we make copy */
3055 MUTEX_LOCK(&t->mutex);
3056
14dd3ad8 3057#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 3058 PL_protect = t->Tprotect;
14dd3ad8 3059#endif
312caa8e 3060
b099ddc0
GS		 3061 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3062 PL_defstash = t->Tdefstash; /* XXX maybe these should */
3063 PL_curstash = t->Tcurstash; /* always be set to main? */
3064
6b88bc9c 3065 PL_tainted = t->Ttainted;
3aed30dc 3066 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
8bfdd7d9 3067 PL_rs = newSVsv(t->Trs);
84fee439 3068 PL_last_in_gv = Nullgv;
7d3de3d5 3069 PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
84fee439
NIS		 3070 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3071 PL_chopset = t->Tchopset;
84fee439
NIS		 3072 PL_bodytarget = newSVsv(t->Tbodytarget);
3073 PL_toptarget = newSVsv(t->Ttoptarget);
5c831c24
GS		 3074 if (t->Tformtarget == t->Ttoptarget)
3075 PL_formtarget = PL_toptarget;
3076 else
3077 PL_formtarget = PL_bodytarget;
533c011a 3078
54b9620d
MB		 3079 /* Initialise all per-thread SVs that the template thread used */
3080 svp = AvARRAY(t->threadsv);
93965878 3081 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
533c011a 3082 if (*svp && *svp != &PL_sv_undef) {
199100c8 3083 SV *sv = newSVsv(*svp);
54b9620d 3084 av_store(thr->threadsv, i, sv);
14befaf4 3085 sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
bf49b057 3086 DEBUG_S(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 3087 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3088 (IV)i, t, thr));
199100c8 3089 }
a1d180c4 3090 }
940cb80d 3091 thr->threadsvp = AvARRAY(thr->threadsv);
199100c8 3092
533c011a
NIS		 3093 MUTEX_LOCK(&PL_threads_mutex);
3094 PL_nthreads++;
3095 thr->tid = ++PL_threadnum;
199100c8
MB		 3096 thr->next = t->next;
3097 thr->prev = t;
3098 t->next = thr;
3099 thr->next->prev = thr;
533c011a 3100 MUTEX_UNLOCK(&PL_threads_mutex);
a863c7d1 3101
b099ddc0
GS		 3102 /* done copying parent's state */
3103 MUTEX_UNLOCK(&t->mutex);
3104
a863c7d1 3105#ifdef HAVE_THREAD_INTERN
4f63d024 3106 Perl_init_thread_intern(thr);
a863c7d1 3107#endif /* HAVE_THREAD_INTERN */
a863c7d1
MB		 3108 return thr;
3109}
4d1ff10f 3110#endif /* USE_5005THREADS */
760ac839 3111
22239a37
NIS		 3112#ifdef PERL_GLOBAL_STRUCT
3113struct perl_vars *
864dbfa3 3114Perl_GetVars(pTHX)
22239a37 3115{
533c011a 3116 return &PL_Vars;
22239a37 3117}
31fb1209
NIS		 3118#endif
3119
3120char **
864dbfa3 3121Perl_get_op_names(pTHX)
31fb1209 3122{
22c35a8c 3123 return PL_op_name;
31fb1209
NIS		 3124}
3125
3126char **
864dbfa3 3127Perl_get_op_descs(pTHX)
31fb1209 3128{
22c35a8c 3129 return PL_op_desc;
31fb1209 3130}
9e6b2b00
GS		 3131
3132char *
864dbfa3 3133Perl_get_no_modify(pTHX)
9e6b2b00 3134{
22c35a8c 3135 return (char*)PL_no_modify;
9e6b2b00
GS		 3136}
3137
3138U32 *
864dbfa3 3139Perl_get_opargs(pTHX)
9e6b2b00 3140{
22c35a8c 3141 return PL_opargs;
9e6b2b00 3142}
51aa15f3 3143
0cb96387
GS		 3144PPADDR_t*
3145Perl_get_ppaddr(pTHX)
3146{
12ae5dfc 3147 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3148}
3149
a6c40364
GS		 3150#ifndef HAS_GETENV_LEN
3151char *
bf4acbe4 3152Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364
GS		 3153{
3154 char *env_trans = PerlEnv_getenv(env_elem);
3155 if (env_trans)
3156 *len = strlen(env_trans);
3157 return env_trans;
f675dbe5
CB		 3158}
3159#endif
3160
dc9e4912
GS		 3161
3162MGVTBL*
864dbfa3 3163Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912
GS		 3164{
3165 MGVTBL* result = Null(MGVTBL*);
3166
3167 switch(vtbl_id) {
3168 case want_vtbl_sv:
3169 result = &PL_vtbl_sv;
3170 break;
3171 case want_vtbl_env:
3172 result = &PL_vtbl_env;
3173 break;
3174 case want_vtbl_envelem:
3175 result = &PL_vtbl_envelem;
3176 break;
3177 case want_vtbl_sig:
3178 result = &PL_vtbl_sig;
3179 break;
3180 case want_vtbl_sigelem:
3181 result = &PL_vtbl_sigelem;
3182 break;
3183 case want_vtbl_pack:
3184 result = &PL_vtbl_pack;
3185 break;
3186 case want_vtbl_packelem:
3187 result = &PL_vtbl_packelem;
3188 break;
3189 case want_vtbl_dbline:
3190 result = &PL_vtbl_dbline;
3191 break;
3192 case want_vtbl_isa:
3193 result = &PL_vtbl_isa;
3194 break;
3195 case want_vtbl_isaelem:
3196 result = &PL_vtbl_isaelem;
3197 break;
3198 case want_vtbl_arylen:
3199 result = &PL_vtbl_arylen;
3200 break;
3201 case want_vtbl_glob:
3202 result = &PL_vtbl_glob;
3203 break;
3204 case want_vtbl_mglob:
3205 result = &PL_vtbl_mglob;
3206 break;
3207 case want_vtbl_nkeys:
3208 result = &PL_vtbl_nkeys;
3209 break;
3210 case want_vtbl_taint:
3211 result = &PL_vtbl_taint;
3212 break;
3213 case want_vtbl_substr:
3214 result = &PL_vtbl_substr;
3215 break;
3216 case want_vtbl_vec:
3217 result = &PL_vtbl_vec;
3218 break;
3219 case want_vtbl_pos:
3220 result = &PL_vtbl_pos;
3221 break;
3222 case want_vtbl_bm:
3223 result = &PL_vtbl_bm;
3224 break;
3225 case want_vtbl_fm:
3226 result = &PL_vtbl_fm;
3227 break;
3228 case want_vtbl_uvar:
3229 result = &PL_vtbl_uvar;
3230 break;
4d1ff10f 3231#ifdef USE_5005THREADS
dc9e4912
GS		 3232 case want_vtbl_mutex:
3233 result = &PL_vtbl_mutex;
3234 break;
3235#endif
3236 case want_vtbl_defelem:
3237 result = &PL_vtbl_defelem;
3238 break;
3239 case want_vtbl_regexp:
3240 result = &PL_vtbl_regexp;
3241 break;
3242 case want_vtbl_regdata:
3243 result = &PL_vtbl_regdata;
3244 break;
3245 case want_vtbl_regdatum:
3246 result = &PL_vtbl_regdatum;
3247 break;
3c90161d 3248#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3249 case want_vtbl_collxfrm:
3250 result = &PL_vtbl_collxfrm;
3251 break;
3c90161d 3252#endif
dc9e4912
GS		 3253 case want_vtbl_amagic:
3254 result = &PL_vtbl_amagic;
3255 break;
3256 case want_vtbl_amagicelem:
3257 result = &PL_vtbl_amagicelem;
3258 break;
810b8aa5
GS		 3259 case want_vtbl_backref:
3260 result = &PL_vtbl_backref;
3261 break;
dc9e4912
GS		 3262 }
3263 return result;
3264}
3265
767df6a1 3266I32
864dbfa3 3267Perl_my_fflush_all(pTHX)
767df6a1 3268{
8fbdfb7c 3269#if defined(FFLUSH_NULL)
ce720889 3270 return PerlIO_flush(NULL);
767df6a1 3271#else
8fbdfb7c 3272# if defined(HAS__FWALK)
f13a2bc0 3273 extern int fflush(FILE *);
74cac757
JH		 3274 /* undocumented, unprototyped, but very useful BSDism */
3275 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3276 _fwalk(&fflush);
74cac757 3277 return 0;
8fa7f367 3278# else
8fbdfb7c 3279# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3280 long open_max = -1;
8fbdfb7c 3281# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3282 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3283# else
8fa7f367 3284# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3285 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3286# else
3287# ifdef FOPEN_MAX
74cac757 3288 open_max = FOPEN_MAX;
8fa7f367
JH		 3289# else
3290# ifdef OPEN_MAX
74cac757 3291 open_max = OPEN_MAX;
8fa7f367
JH		 3292# else
3293# ifdef _NFILE
d2201af2 3294 open_max = _NFILE;
8fa7f367
JH		 3295# endif
3296# endif
74cac757 3297# endif
767df6a1
JH		 3298# endif
3299# endif
767df6a1
JH		 3300 if (open_max > 0) {
3301 long i;
3302 for (i = 0; i < open_max; i++)
d2201af2
AD		 3303 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3304 STDIO_STREAM_ARRAY[i]._file < open_max &&
3305 STDIO_STREAM_ARRAY[i]._flag)
3306 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3307 return 0;
3308 }
8fbdfb7c 3309# endif
93189314 3310 SETERRNO(EBADF,RMS_IFI);
767df6a1 3311 return EOF;
74cac757 3312# endif
767df6a1
JH		 3313#endif
3314}
097ee67d 3315
69282e91 3316void
bc37a18f
RG		 3317Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3318{
bc37a18f 3319 char *func =
66fc2fa5
JH		 3320 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3321 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
bc37a18f
RG		 3322 PL_op_desc[op];
3323 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3aed30dc
HS		 3324 char *type = OP_IS_SOCKET(op)
3325 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3326 ? "socket" : "filehandle";
9c0fcd4f 3327 char *name = NULL;
bc37a18f 3328
66fc2fa5 3329 if (gv && isGV(gv)) {
f62cb720 3330 name = GvENAME(gv);
66fc2fa5
JH		 3331 }
3332
4c80c0b2 3333 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3334 if (ckWARN(WARN_IO)) {
fd322ea4 3335 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3aed30dc
HS		 3336 if (name && *name)
3337 Perl_warner(aTHX_ packWARN(WARN_IO),
3338 "Filehandle %s opened only for %sput",
fd322ea4 3339 name, direction);
3aed30dc
HS		 3340 else
3341 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3342 "Filehandle opened only for %sput", direction);
3aed30dc 3343 }
2dd78f96
JH		 3344 }
3345 else {
3aed30dc
HS		 3346 char *vile;
3347 I32 warn_type;
3348
3349 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3350 vile = "closed";
3351 warn_type = WARN_CLOSED;
3352 }
3353 else {
3354 vile = "unopened";
3355 warn_type = WARN_UNOPENED;
3356 }
3357
3358 if (ckWARN(warn_type)) {
3359 if (name && *name) {
3360 Perl_warner(aTHX_ packWARN(warn_type),
3361 "%s%s on %s %s %s", func, pars, vile, type, name);
3362 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3363 Perl_warner(
3364 aTHX_ packWARN(warn_type),
3365 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3366 func, pars, name
3367 );
3368 }
3369 else {
3370 Perl_warner(aTHX_ packWARN(warn_type),
3371 "%s%s on %s %s", func, pars, vile, type);
3372 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3373 Perl_warner(
3374 aTHX_ packWARN(warn_type),
3375 "\t(Are you trying to call %s%s on dirhandle?)\n",
3376 func, pars
3377 );
3378 }
3379 }
bc37a18f 3380 }
69282e91 3381}
a926ef6b
JH		 3382
3383#ifdef EBCDIC
cbebf344
JH		 3384/* in ASCII order, not that it matters */
3385static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3386
a926ef6b
JH		 3387int
3388Perl_ebcdic_control(pTHX_ int ch)
3389{
3aed30dc
HS		 3390 if (ch > 'a') {
3391 char *ctlp;
3392
3393 if (islower(ch))
3394 ch = toupper(ch);
3395
3396 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3397 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3398 }
3aed30dc
HS		 3399
3400 if (ctlp == controllablechars)
3401 return('\177'); /* DEL */
3402 else
3403 return((unsigned char)(ctlp - controllablechars - 1));
3404 } else { /* Want uncontrol */
3405 if (ch == '\177' || ch == -1)
3406 return('?');
3407 else if (ch == '\157')
3408 return('\177');
3409 else if (ch == '\174')
3410 return('\000');
3411 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3412 return('\036');
3413 else if (ch == '\155')
3414 return('\037');
3415 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3416 return(controllablechars[ch+1]);
3417 else
3418 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3419 }
a926ef6b
JH		 3420}
3421#endif
e72cf795 3422
f6adc668 3423/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3424 * system to give us a reasonable struct to copy. This fix means that
3425 * strftime uses the tm_zone and tm_gmtoff values returned by
3426 * localtime(time()). That should give the desired result most of the
3427 * time. But probably not always!
3428 *
f6adc668
JH		 3429 * This does not address tzname aspects of NETaa14816.
3430 *
e72cf795 3431 */
f6adc668 3432
e72cf795
JH		 3433#ifdef HAS_GNULIBC
3434# ifndef STRUCT_TM_HASZONE
3435# define STRUCT_TM_HASZONE
3436# endif
3437#endif
3438
f6adc668
JH		 3439#ifdef STRUCT_TM_HASZONE /* Backward compat */
3440# ifndef HAS_TM_TM_ZONE
3441# define HAS_TM_TM_ZONE
3442# endif
3443#endif
3444
e72cf795 3445void
f1208910 3446Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3447{
f6adc668 3448#ifdef HAS_TM_TM_ZONE
e72cf795
JH		 3449 Time_t now;
3450 (void)time(&now);
3451 Copy(localtime(&now), ptm, 1, struct tm);
3452#endif
3453}
3454
3455/*
3456 * mini_mktime - normalise struct tm values without the localtime()
3457 * semantics (and overhead) of mktime().
3458 */
3459void
f1208910 3460Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3461{
3462 int yearday;
3463 int secs;
3464 int month, mday, year, jday;
3465 int odd_cent, odd_year;
3466
3467#define DAYS_PER_YEAR 365
3468#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3469#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3470#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3471#define SECS_PER_HOUR (60*60)
3472#define SECS_PER_DAY (24*SECS_PER_HOUR)
3473/* parentheses deliberately absent on these two, otherwise they don't work */
3474#define MONTH_TO_DAYS 153/5
3475#define DAYS_TO_MONTH 5/153
3476/* offset to bias by March (month 4) 1st between month/mday & year finding */
3477#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3478/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3479#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3480
3481/*
3482 * Year/day algorithm notes:
3483 *
3484 * With a suitable offset for numeric value of the month, one can find
3485 * an offset into the year by considering months to have 30.6 (153/5) days,
3486 * using integer arithmetic (i.e., with truncation). To avoid too much
3487 * messing about with leap days, we consider January and February to be
3488 * the 13th and 14th month of the previous year. After that transformation,
3489 * we need the month index we use to be high by 1 from 'normal human' usage,
3490 * so the month index values we use run from 4 through 15.
3491 *
3492 * Given that, and the rules for the Gregorian calendar (leap years are those
3493 * divisible by 4 unless also divisible by 100, when they must be divisible
3494 * by 400 instead), we can simply calculate the number of days since some
3495 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3496 * the days we derive from our month index, and adding in the day of the
3497 * month. The value used here is not adjusted for the actual origin which
3498 * it normally would use (1 January A.D. 1), since we're not exposing it.
3499 * We're only building the value so we can turn around and get the
3500 * normalised values for the year, month, day-of-month, and day-of-year.
3501 *
3502 * For going backward, we need to bias the value we're using so that we find
3503 * the right year value. (Basically, we don't want the contribution of
3504 * March 1st to the number to apply while deriving the year). Having done
3505 * that, we 'count up' the contribution to the year number by accounting for
3506 * full quadracenturies (400-year periods) with their extra leap days, plus
3507 * the contribution from full centuries (to avoid counting in the lost leap
3508 * days), plus the contribution from full quad-years (to count in the normal
3509 * leap days), plus the leftover contribution from any non-leap years.
3510 * At this point, if we were working with an actual leap day, we'll have 0
3511 * days left over. This is also true for March 1st, however. So, we have
3512 * to special-case that result, and (earlier) keep track of the 'odd'
3513 * century and year contributions. If we got 4 extra centuries in a qcent,
3514 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3515 * Otherwise, we add back in the earlier bias we removed (the 123 from
3516 * figuring in March 1st), find the month index (integer division by 30.6),
3517 * and the remainder is the day-of-month. We then have to convert back to
3518 * 'real' months (including fixing January and February from being 14/15 in
3519 * the previous year to being in the proper year). After that, to get
3520 * tm_yday, we work with the normalised year and get a new yearday value for
3521 * January 1st, which we subtract from the yearday value we had earlier,
3522 * representing the date we've re-built. This is done from January 1
3523 * because tm_yday is 0-origin.
3524 *
3525 * Since POSIX time routines are only guaranteed to work for times since the
3526 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3527 * applies Gregorian calendar rules even to dates before the 16th century
3528 * doesn't bother me. Besides, you'd need cultural context for a given
3529 * date to know whether it was Julian or Gregorian calendar, and that's
3530 * outside the scope for this routine. Since we convert back based on the
3531 * same rules we used to build the yearday, you'll only get strange results
3532 * for input which needed normalising, or for the 'odd' century years which
3533 * were leap years in the Julian calander but not in the Gregorian one.
3534 * I can live with that.
3535 *
3536 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3537 * that's still outside the scope for POSIX time manipulation, so I don't
3538 * care.
3539 */
3540
3541 year = 1900 + ptm->tm_year;
3542 month = ptm->tm_mon;
3543 mday = ptm->tm_mday;
3544 /* allow given yday with no month & mday to dominate the result */
3545 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3546 month = 0;
3547 mday = 0;
3548 jday = 1 + ptm->tm_yday;
3549 }
3550 else {
3551 jday = 0;
3552 }
3553 if (month >= 2)
3554 month+=2;
3555 else
3556 month+=14, year--;
3557 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3558 yearday += month*MONTH_TO_DAYS + mday + jday;
3559 /*
3560 * Note that we don't know when leap-seconds were or will be,
3561 * so we have to trust the user if we get something which looks
3562 * like a sensible leap-second. Wild values for seconds will
3563 * be rationalised, however.
3564 */
3565 if ((unsigned) ptm->tm_sec <= 60) {
3566 secs = 0;
3567 }
3568 else {
3569 secs = ptm->tm_sec;
3570 ptm->tm_sec = 0;
3571 }
3572 secs += 60 * ptm->tm_min;
3573 secs += SECS_PER_HOUR * ptm->tm_hour;
3574 if (secs < 0) {
3575 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3576 /* got negative remainder, but need positive time */
3577 /* back off an extra day to compensate */
3578 yearday += (secs/SECS_PER_DAY)-1;
3579 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3580 }
3581 else {
3582 yearday += (secs/SECS_PER_DAY);
3583 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3584 }
3585 }
3586 else if (secs >= SECS_PER_DAY) {
3587 yearday += (secs/SECS_PER_DAY);
3588 secs %= SECS_PER_DAY;
3589 }
3590 ptm->tm_hour = secs/SECS_PER_HOUR;
3591 secs %= SECS_PER_HOUR;
3592 ptm->tm_min = secs/60;
3593 secs %= 60;
3594 ptm->tm_sec += secs;
3595 /* done with time of day effects */
3596 /*
3597 * The algorithm for yearday has (so far) left it high by 428.
3598 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3599 * bias it by 123 while trying to figure out what year it
3600 * really represents. Even with this tweak, the reverse
3601 * translation fails for years before A.D. 0001.
3602 * It would still fail for Feb 29, but we catch that one below.
3603 */
3604 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3605 yearday -= YEAR_ADJUST;
3606 year = (yearday / DAYS_PER_QCENT) * 400;
3607 yearday %= DAYS_PER_QCENT;
3608 odd_cent = yearday / DAYS_PER_CENT;
3609 year += odd_cent * 100;
3610 yearday %= DAYS_PER_CENT;
3611 year += (yearday / DAYS_PER_QYEAR) * 4;
3612 yearday %= DAYS_PER_QYEAR;
3613 odd_year = yearday / DAYS_PER_YEAR;
3614 year += odd_year;
3615 yearday %= DAYS_PER_YEAR;
3616 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3617 month = 1;
3618 yearday = 29;
3619 }
3620 else {
3621 yearday += YEAR_ADJUST; /* recover March 1st crock */
3622 month = yearday*DAYS_TO_MONTH;
3623 yearday -= month*MONTH_TO_DAYS;
3624 /* recover other leap-year adjustment */
3625 if (month > 13) {
3626 month-=14;
3627 year++;
3628 }
3629 else {
3630 month-=2;
3631 }
3632 }
3633 ptm->tm_year = year - 1900;
3634 if (yearday) {
3635 ptm->tm_mday = yearday;
3636 ptm->tm_mon = month;
3637 }
3638 else {
3639 ptm->tm_mday = 31;
3640 ptm->tm_mon = month - 1;
3641 }
3642 /* re-build yearday based on Jan 1 to get tm_yday */
3643 year--;
3644 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3645 yearday += 14*MONTH_TO_DAYS + 1;
3646 ptm->tm_yday = jday - yearday;
3647 /* fix tm_wday if not overridden by caller */
3648 if ((unsigned)ptm->tm_wday > 6)
3649 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3650}
b3c85772
JH		 3651
3652char *
f1208910 3653Perl_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		 3654{
3655#ifdef HAS_STRFTIME
3656 char *buf;
3657 int buflen;
3658 struct tm mytm;
3659 int len;
3660
3661 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3662 mytm.tm_sec = sec;
3663 mytm.tm_min = min;
3664 mytm.tm_hour = hour;
3665 mytm.tm_mday = mday;
3666 mytm.tm_mon = mon;
3667 mytm.tm_year = year;
3668 mytm.tm_wday = wday;
3669 mytm.tm_yday = yday;
3670 mytm.tm_isdst = isdst;
3671 mini_mktime(&mytm);
3672 buflen = 64;
3673 New(0, buf, buflen, char);
3674 len = strftime(buf, buflen, fmt, &mytm);
3675 /*
877f6a72 3676 ** The following is needed to handle to the situation where
b3c85772
JH		 3677 ** tmpbuf overflows. Basically we want to allocate a buffer
3678 ** and try repeatedly. The reason why it is so complicated
3679 ** is that getting a return value of 0 from strftime can indicate
3680 ** one of the following:
3681 ** 1. buffer overflowed,
3682 ** 2. illegal conversion specifier, or
3683 ** 3. the format string specifies nothing to be returned(not
3684 ** an error). This could be because format is an empty string
3685 ** or it specifies %p that yields an empty string in some locale.
3686 ** If there is a better way to make it portable, go ahead by
3687 ** all means.
3688 */
3689 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3690 return buf;
3691 else {
3692 /* Possibly buf overflowed - try again with a bigger buf */
3693 int fmtlen = strlen(fmt);
3694 int bufsize = fmtlen + buflen;
877f6a72 3695
b3c85772
JH		 3696 New(0, buf, bufsize, char);
3697 while (buf) {
3698 buflen = strftime(buf, bufsize, fmt, &mytm);
3699 if (buflen > 0 && buflen < bufsize)
3700 break;
3701 /* heuristic to prevent out-of-memory errors */
3702 if (bufsize > 100*fmtlen) {
3703 Safefree(buf);
3704 buf = NULL;
3705 break;
3706 }
3707 bufsize *= 2;
3708 Renew(buf, bufsize, char);
3709 }
3710 return buf;
3711 }
3712#else
3713 Perl_croak(aTHX_ "panic: no strftime");
3714#endif
3715}
3716
877f6a72
NIS		 3717
3718#define SV_CWD_RETURN_UNDEF \
3719sv_setsv(sv, &PL_sv_undef); \
3720return FALSE
3721
3722#define SV_CWD_ISDOT(dp) \
3723 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3724 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3725
3726/*
ccfc67b7
JH		 3727=head1 Miscellaneous Functions
3728
89423764 3729=for apidoc getcwd_sv
877f6a72
NIS		 3730
3731Fill the sv with current working directory
3732
3733=cut
3734*/
3735
3736/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3737 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3738 * getcwd(3) if available
3739 * Comments from the orignal:
3740 * This is a faster version of getcwd. It's also more dangerous
3741 * because you might chdir out of a directory that you can't chdir
3742 * back into. */
3743
877f6a72 3744int
89423764 3745Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3746{
3747#ifndef PERL_MICRO
3748
ea715489
JH		 3749#ifndef INCOMPLETE_TAINTS
3750 SvTAINTED_on(sv);
3751#endif
3752
8f95b30d
JH		 3753#ifdef HAS_GETCWD
3754 {
60e110a8
DM		 3755 char buf[MAXPATHLEN];
3756
3aed30dc 3757 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3758 * size from the heap if they are given a NULL buffer pointer.
3759 * The problem is that this behaviour is not portable. */
3aed30dc
HS		 3760 if (getcwd(buf, sizeof(buf) - 1)) {
3761 STRLEN len = strlen(buf);
3762 sv_setpvn(sv, buf, len);
3763 return TRUE;
3764 }
3765 else {
3766 sv_setsv(sv, &PL_sv_undef);
3767 return FALSE;
3768 }
8f95b30d
JH		 3769 }
3770
3771#else
3772
c623ac67 3773 Stat_t statbuf;
877f6a72
NIS		 3774 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3775 int namelen, pathlen=0;
3776 DIR *dir;
3777 Direntry_t *dp;
877f6a72
NIS		 3778
3779 (void)SvUPGRADE(sv, SVt_PV);
3780
877f6a72 3781 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3782 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3783 }
3784
3785 orig_cdev = statbuf.st_dev;
3786 orig_cino = statbuf.st_ino;
3787 cdev = orig_cdev;
3788 cino = orig_cino;
3789
3790 for (;;) {
3aed30dc
HS		 3791 odev = cdev;
3792 oino = cino;
3793
3794 if (PerlDir_chdir("..") < 0) {
3795 SV_CWD_RETURN_UNDEF;
3796 }
3797 if (PerlLIO_stat(".", &statbuf) < 0) {
3798 SV_CWD_RETURN_UNDEF;
3799 }
3800
3801 cdev = statbuf.st_dev;
3802 cino = statbuf.st_ino;
3803
3804 if (odev == cdev && oino == cino) {
3805 break;
3806 }
3807 if (!(dir = PerlDir_open("."))) {
3808 SV_CWD_RETURN_UNDEF;
3809 }
3810
3811 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3812#ifdef DIRNAMLEN
3aed30dc 3813 namelen = dp->d_namlen;
877f6a72 3814#else
3aed30dc 3815 namelen = strlen(dp->d_name);
877f6a72 3816#endif
3aed30dc
HS		 3817 /* skip . and .. */
3818 if (SV_CWD_ISDOT(dp)) {
3819 continue;
3820 }
3821
3822 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3823 SV_CWD_RETURN_UNDEF;
3824 }
3825
3826 tdev = statbuf.st_dev;
3827 tino = statbuf.st_ino;
3828 if (tino == oino && tdev == odev) {
3829 break;
3830 }
cb5953d6
JH		 3831 }
3832
3aed30dc
HS		 3833 if (!dp) {
3834 SV_CWD_RETURN_UNDEF;
3835 }
3836
3837 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3838 SV_CWD_RETURN_UNDEF;
3839 }
877f6a72 3840
3aed30dc
HS		 3841 SvGROW(sv, pathlen + namelen + 1);
3842
3843 if (pathlen) {
3844 /* shift down */
3845 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3846 }
877f6a72 3847
3aed30dc
HS		 3848 /* prepend current directory to the front */
3849 *SvPVX(sv) = '/';
3850 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3851 pathlen += (namelen + 1);
877f6a72
NIS		 3852
3853#ifdef VOID_CLOSEDIR
3aed30dc 3854 PerlDir_close(dir);
877f6a72 3855#else
3aed30dc
HS		 3856 if (PerlDir_close(dir) < 0) {
3857 SV_CWD_RETURN_UNDEF;
3858 }
877f6a72
NIS		 3859#endif
3860 }
3861
60e110a8 3862 if (pathlen) {
3aed30dc
HS		 3863 SvCUR_set(sv, pathlen);
3864 *SvEND(sv) = '\0';
3865 SvPOK_only(sv);
877f6a72 3866
2a45baea 3867 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3aed30dc
HS		 3868 SV_CWD_RETURN_UNDEF;
3869 }
877f6a72
NIS		 3870 }
3871 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 3872 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3873 }
3874
3875 cdev = statbuf.st_dev;
3876 cino = statbuf.st_ino;
3877
3878 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 3879 Perl_croak(aTHX_ "Unstable directory path, "
3880 "current directory changed unexpectedly");
877f6a72 3881 }
877f6a72
NIS		 3882
3883 return TRUE;
793b8d8e
JH		 3884#endif
3885
877f6a72
NIS		 3886#else
3887 return FALSE;
3888#endif
3889}
3890
f4758303 3891/*
ccfc67b7
JH		 3892=head1 SV Manipulation Functions
3893
b0f01acb 3894=for apidoc scan_vstring
f4758303
JP		 3895
3896Returns a pointer to the next character after the parsed
3897vstring, as well as updating the passed in sv.
7207e29d 3898
cddd4526 3899Function must be called like
7207e29d 3900
b0f01acb
JP		 3901 sv = NEWSV(92,5);
3902 s = scan_vstring(s,sv);
f4758303 3903
b0f01acb
JP		 3904The sv should already be large enough to store the vstring
3905passed in, for performance reasons.
f4758303
JP		 3906
3907=cut
3908*/
3909
3910char *
b0f01acb 3911Perl_scan_vstring(pTHX_ char *s, SV *sv)
f4758303
JP		 3912{
3913 char *pos = s;
439cb1c4 3914 char *start = s;
f4758303
JP		 3915 if (*pos == 'v') pos++; /* get past 'v' */
3916 while (isDIGIT(*pos) || *pos == '_')
3917 pos++;
3918 if (!isALPHA(*pos)) {
3919 UV rev;
3920 U8 tmpbuf[UTF8_MAXLEN+1];
3921 U8 *tmpend;
3922
3923 if (*s == 'v') s++; /* get past 'v' */
3924
3925 sv_setpvn(sv, "", 0);
3926
3927 for (;;) {
3928 rev = 0;
3929 {
92f0c265
JP		 3930 /* this is atoi() that tolerates underscores */
3931 char *end = pos;
3932 UV mult = 1;
3933 while (--end >= s) {
3934 UV orev;
3935 if (*end == '_')
3936 continue;
3937 orev = rev;
3938 rev += (*end - '0') * mult;
3939 mult *= 10;
3940 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
3941 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
3942 "Integer overflow in decimal number");
3943 }
f4758303 3944 }
979699d9
JH		 3945#ifdef EBCDIC
3946 if (rev > 0x7FFFFFFF)
3947 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
3948#endif
f4758303
JP		 3949 /* Append native character for the rev point */
3950 tmpend = uvchr_to_utf8(tmpbuf, rev);
3951 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
3952 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
979699d9 3953 SvUTF8_on(sv);
92f0c265 3954 if (*pos == '.' && isDIGIT(pos[1]))
979699d9 3955 s = ++pos;
f4758303 3956 else {
979699d9
JH		 3957 s = pos;
3958 break;
f4758303 3959 }
92f0c265 3960 while (isDIGIT(*pos) || *pos == '_')
979699d9 3961 pos++;
f4758303
JP		 3962 }
3963 SvPOK_on(sv);
ece467f9 3964 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
439cb1c4 3965 SvRMAGICAL_on(sv);
f4758303
JP		 3966 }
3967 return s;
3968}
3969
b0f01acb
JP		 3970/*
3971=for apidoc scan_version
3972
3973Returns a pointer to the next character after the parsed
3974version string, as well as upgrading the passed in SV to
3975an RV.
3976
3977Function must be called with an already existing SV like
3978
3979 sv = NEWSV(92,0);
3980 s = scan_version(s,sv);
3981
3982Performs some preprocessing to the string to ensure that
3983it has the correct characteristics of a version. Flags the
3984object if it contains an underscore (which denotes this
3985is a beta version).
3986
3987=cut
3988*/
3989
3990char *
ad63d80f 3991Perl_scan_version(pTHX_ char *s, SV *rv)
b0f01acb 3992{
ad63d80f
JP		 3993 char *pos = s;
3994 I32 saw_period = 0;
3995 bool saw_under = 0;
be2ebcad 3996 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
ad63d80f
JP		 3997 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3998
3999 /* pre-scan the imput string to check for decimals */
4000 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4001 {
4002 if ( *pos == '.' )
4003 {
4004 if ( saw_under )
5f89c282 4005 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 4006 saw_period++ ;
46314c13 4007 }
ad63d80f
JP		 4008 else if ( *pos == '_' )
4009 {
4010 if ( saw_under )
5f89c282 4011 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
ad63d80f
JP		 4012 saw_under = 1;
4013 }
4014 pos++;
4015 }
4016 pos = s;
4017
4018 if (*pos == 'v') pos++; /* get past 'v' */
4019 while (isDIGIT(*pos))
46314c13 4020 pos++;
ad63d80f
JP		 4021 if (!isALPHA(*pos)) {
4022 I32 rev;
4023
4024 if (*s == 'v') s++; /* get past 'v' */
4025
4026 for (;;) {
4027 rev = 0;
4028 {
4029 /* this is atoi() that delimits on underscores */
4030 char *end = pos;
4031 I32 mult = 1;
4032 if ( s < pos && *(s-1) == '_' ) {
4033 if ( *s == '0' && *(s+1) != '0')
4034 mult = 10; /* perl-style */
4035 else
4036 mult = -1; /* beta version */
4037 }
4038 while (--end >= s) {
ad63d80f
JP		 4039 I32 orev;
4040 orev = rev;
4041 rev += (*end - '0') * mult;
4042 mult *= 10;
4043 if ( abs(orev) > abs(rev) )
5f89c282 4044 Perl_croak(aTHX_ "Integer overflow in version");
ad63d80f 4045 }
b0f01acb 4046 }
ad63d80f
JP		 4047
4048 /* Append revision */
4049 av_push((AV *)sv, newSViv(rev));
4050 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
4051 s = ++pos;
4052 else if ( isDIGIT(*pos) )
4053 s = pos;
b0f01acb 4054 else {
ad63d80f
JP		 4055 s = pos;
4056 break;
4057 }
4058 while ( isDIGIT(*pos) ) {
46314c13 4059 if ( !saw_under && saw_period == 1 && pos-s == 3 )
ad63d80f
JP		 4060 break;
4061 pos++;
b0f01acb
JP		 4062 }
4063 }
4064 }
ad63d80f 4065 return s;
b0f01acb
JP		 4066}
4067
4068/*
4069=for apidoc new_version
4070
4071Returns a new version object based on the passed in SV:
4072
4073 SV *sv = new_version(SV *ver);
4074
4075Does not alter the passed in ver SV. See "upg_version" if you
4076want to upgrade the SV.
4077
4078=cut
4079*/
4080
4081SV *
4082Perl_new_version(pTHX_ SV *ver)
4083{
4084 SV *rv = NEWSV(92,5);
ad63d80f 4085 char *version = (char *)SvPV(ver,PL_na);
b0f01acb 4086
ad63d80f
JP		 4087#ifdef SvVOK
4088 if ( SvVOK(ver) ) { /* already a v-string */
b0f01acb
JP		 4089 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4090 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4091 }
ad63d80f 4092#endif
b0f01acb
JP		 4093 version = scan_version(version,rv);
4094 return rv;
4095}
4096
4097/*
4098=for apidoc upg_version
4099
4100In-place upgrade of the supplied SV to a version object.
4101
4102 SV *sv = upg_version(SV *sv);
4103
4104Returns a pointer to the upgraded SV.
4105
4106=cut
4107*/
4108
4109SV *
ad63d80f 4110Perl_upg_version(pTHX_ SV *ver)
b0f01acb 4111{
ad63d80f
JP		 4112 char *version = savepvn(SvPVX(ver),SvCUR(ver));
4113#ifdef SvVOK
4114 if ( SvVOK(ver) ) { /* already a v-string */
4115 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4116 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
b0f01acb 4117 }
ad63d80f
JP		 4118#endif
4119 version = scan_version(version,ver);
4120 return ver;
b0f01acb
JP		 4121}
4122
4123
4124/*
4125=for apidoc vnumify
4126
ad63d80f
JP		 4127Accepts a version object and returns the normalized floating
4128point representation. Call like:
b0f01acb 4129
ad63d80f 4130 sv = vnumify(rv);
b0f01acb 4131
ad63d80f
JP		 4132NOTE: you can pass either the object directly or the SV
4133contained within the RV.
b0f01acb
JP		 4134
4135=cut
4136*/
4137
4138SV *
ad63d80f 4139Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4140{
ad63d80f
JP		 4141 I32 i, len, digit;
4142 SV *sv = NEWSV(92,0);
4143 if ( SvROK(vs) )
4144 vs = SvRV(vs);
4145 len = av_len((AV *)vs);
46314c13
JP		 4146 if ( len == -1 )
4147 {
4148 Perl_sv_catpv(aTHX_ sv,"0");
4149 return sv;
4150 }
ad63d80f
JP		 4151 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4152 Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit));
4153 for ( i = 1 ; i <= len ; i++ )
b0f01acb 4154 {
ad63d80f
JP		 4155 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4156 Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit));
b0f01acb 4157 }
ad63d80f
JP		 4158 if ( len == 0 )
4159 Perl_sv_catpv(aTHX_ sv,"000");
b0f01acb
JP		 4160 return sv;
4161}
4162
4163/*
4164=for apidoc vstringify
4165
ad63d80f
JP		 4166Accepts a version object and returns the normalized string
4167representation. Call like:
b0f01acb 4168
ad63d80f 4169 sv = vstringify(rv);
b0f01acb 4170
ad63d80f
JP		 4171NOTE: you can pass either the object directly or the SV
4172contained within the RV.
b0f01acb
JP		 4173
4174=cut
4175*/
4176
4177SV *
ad63d80f 4178Perl_vstringify(pTHX_ SV *vs)
b0f01acb 4179{
ad63d80f
JP		 4180 I32 i, len, digit;
4181 SV *sv = NEWSV(92,0);
4182 if ( SvROK(vs) )
4183 vs = SvRV(vs);
4184 len = av_len((AV *)vs);
46314c13
JP		 4185 if ( len == -1 )
4186 {
4187 Perl_sv_catpv(aTHX_ sv,"");
4188 return sv;
4189 }
ad63d80f
JP		 4190 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
4191 Perl_sv_setpvf(aTHX_ sv,"%d",digit);
4192 for ( i = 1 ; i <= len ; i++ )
46314c13 4193 {
ad63d80f
JP		 4194 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4195 if ( digit < 0 )
4196 Perl_sv_catpvf(aTHX_ sv,"_%d",-digit);
4197 else
4198 Perl_sv_catpvf(aTHX_ sv,".%d",digit);
b0f01acb 4199 }
ad63d80f
JP		 4200 if ( len == 0 )
4201 Perl_sv_catpv(aTHX_ sv,".0");
b0f01acb
JP		 4202 return sv;
4203}
4204
ad63d80f
JP		 4205/*
4206=for apidoc vcmp
4207
4208Version object aware cmp. Both operands must already have been
4209converted into version objects.
4210
4211=cut
4212*/
4213
4214int
4215Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4216{
4217 I32 i,l,m,r,retval;
4218 if ( SvROK(lsv) )
4219 lsv = SvRV(lsv);
4220 if ( SvROK(rsv) )
4221 rsv = SvRV(rsv);
4222 l = av_len((AV *)lsv);
4223 r = av_len((AV *)rsv);
4224 m = l < r ? l : r;
4225 retval = 0;
4226 i = 0;
4227 while ( i <= m && retval == 0 )
4228 {
4229 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4230 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
4231 bool lbeta = left < 0 ? 1 : 0;
4232 bool rbeta = right < 0 ? 1 : 0;
4233 left = abs(left);
4234 right = abs(right);
4235 if ( left < right || (left == right && lbeta && !rbeta) )
4236 retval = -1;
4237 if ( left > right || (left == right && rbeta && !lbeta) )
4238 retval = +1;
4239 i++;
4240 }
4241
4242 if ( l != r && retval == 0 )
4243 retval = l < r ? -1 : +1;
4244 return retval;
4245}
4246
c95c94b1 4247#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4248# define EMULATE_SOCKETPAIR_UDP
4249#endif
4250
4251#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4252static int
4253S_socketpair_udp (int fd[2]) {
e10bb1e9 4254 dTHX;
02fc2eee
NC		 4255 /* Fake a datagram socketpair using UDP to localhost. */
4256 int sockets[2] = {-1, -1};
4257 struct sockaddr_in addresses[2];
4258 int i;
3aed30dc 4259 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4260 unsigned short port;
02fc2eee
NC		 4261 int got;
4262
3aed30dc 4263 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4264 i = 1;
4265 do {
3aed30dc
HS		 4266 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4267 if (sockets[i] == -1)
4268 goto tidy_up_and_fail;
4269
4270 addresses[i].sin_family = AF_INET;
4271 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4272 addresses[i].sin_port = 0; /* kernel choses port. */
4273 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4274 sizeof(struct sockaddr_in)) == -1)
4275 goto tidy_up_and_fail;
02fc2eee
NC		 4276 } while (i--);
4277
4278 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4279 for each connect the other socket to it. */
4280 i = 1;
4281 do {
3aed30dc
HS		 4282 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4283 &size) == -1)
4284 goto tidy_up_and_fail;
4285 if (size != sizeof(struct sockaddr_in))
4286 goto abort_tidy_up_and_fail;
4287 /* !1 is 0, !0 is 1 */
4288 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4289 sizeof(struct sockaddr_in)) == -1)
4290 goto tidy_up_and_fail;
02fc2eee
NC		 4291 } while (i--);
4292
4293 /* Now we have 2 sockets connected to each other. I don't trust some other
4294 process not to have already sent a packet to us (by random) so send
4295 a packet from each to the other. */
4296 i = 1;
4297 do {
3aed30dc
HS		 4298 /* I'm going to send my own port number. As a short.
4299 (Who knows if someone somewhere has sin_port as a bitfield and needs
4300 this routine. (I'm assuming crays have socketpair)) */
4301 port = addresses[i].sin_port;
4302 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4303 if (got != sizeof(port)) {
4304 if (got == -1)
4305 goto tidy_up_and_fail;
4306 goto abort_tidy_up_and_fail;
4307 }
02fc2eee
NC		 4308 } while (i--);
4309
4310 /* Packets sent. I don't trust them to have arrived though.
4311 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4312 connect to localhost will use a second kernel thread. In 2.6 the
4313 first thread running the connect() returns before the second completes,
4314 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4315 returns 0. Poor programs have tripped up. One poor program's authors'
4316 had a 50-1 reverse stock split. Not sure how connected these were.)
4317 So I don't trust someone not to have an unpredictable UDP stack.
4318 */
4319
4320 {
3aed30dc
HS		 4321 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4322 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4323 fd_set rset;
4324
4325 FD_ZERO(&rset);
4326 FD_SET(sockets[0], &rset);
4327 FD_SET(sockets[1], &rset);
4328
4329 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4330 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4331 || !FD_ISSET(sockets[1], &rset)) {
4332 /* I hope this is portable and appropriate. */
4333 if (got == -1)
4334 goto tidy_up_and_fail;
4335 goto abort_tidy_up_and_fail;
4336 }
02fc2eee 4337 }
f4758303 4338
02fc2eee
NC		 4339 /* And the paranoia department even now doesn't trust it to have arrive
4340 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4341 {
3aed30dc
HS		 4342 struct sockaddr_in readfrom;
4343 unsigned short buffer[2];
02fc2eee 4344
3aed30dc
HS		 4345 i = 1;
4346 do {
02fc2eee 4347#ifdef MSG_DONTWAIT
3aed30dc
HS		 4348 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4349 sizeof(buffer), MSG_DONTWAIT,
4350 (struct sockaddr *) &readfrom, &size);
02fc2eee 4351#else
3aed30dc
HS		 4352 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4353 sizeof(buffer), 0,
4354 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4355#endif
02fc2eee 4356
3aed30dc
HS		 4357 if (got == -1)
4358 goto tidy_up_and_fail;
4359 if (got != sizeof(port)
4360 || size != sizeof(struct sockaddr_in)
4361 /* Check other socket sent us its port. */
4362 || buffer[0] != (unsigned short) addresses[!i].sin_port
4363 /* Check kernel says we got the datagram from that socket */
4364 || readfrom.sin_family != addresses[!i].sin_family
4365 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4366 || readfrom.sin_port != addresses[!i].sin_port)
4367 goto abort_tidy_up_and_fail;
4368 } while (i--);
02fc2eee
NC		 4369 }
4370 /* My caller (my_socketpair) has validated that this is non-NULL */
4371 fd[0] = sockets[0];
4372 fd[1] = sockets[1];
4373 /* I hereby declare this connection open. May God bless all who cross
4374 her. */
4375 return 0;
4376
4377 abort_tidy_up_and_fail:
4378 errno = ECONNABORTED;
4379 tidy_up_and_fail:
4380 {
3aed30dc
HS		 4381 int save_errno = errno;
4382 if (sockets[0] != -1)
4383 PerlLIO_close(sockets[0]);
4384 if (sockets[1] != -1)
4385 PerlLIO_close(sockets[1]);
4386 errno = save_errno;
4387 return -1;
02fc2eee
NC		 4388 }
4389}
85ca448a 4390#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4391
b5ac89c3 4392#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4393int
4394Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4395 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4396 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4397 dTHX;
02fc2eee
NC		 4398 int listener = -1;
4399 int connector = -1;
4400 int acceptor = -1;
4401 struct sockaddr_in listen_addr;
4402 struct sockaddr_in connect_addr;
4403 Sock_size_t size;
4404
50458334
JH		 4405 if (protocol
4406#ifdef AF_UNIX
4407 || family != AF_UNIX
4408#endif
3aed30dc
HS		 4409 ) {
4410 errno = EAFNOSUPPORT;
4411 return -1;
02fc2eee 4412 }
2948e0bd 4413 if (!fd) {
3aed30dc
HS		 4414 errno = EINVAL;
4415 return -1;
2948e0bd 4416 }
02fc2eee 4417
2bc69dc4 4418#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4419 if (type == SOCK_DGRAM)
3aed30dc 4420 return S_socketpair_udp(fd);
2bc69dc4 4421#endif
02fc2eee 4422
3aed30dc 4423 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4424 if (listener == -1)
3aed30dc
HS		 4425 return -1;
4426 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4427 listen_addr.sin_family = AF_INET;
3aed30dc 4428 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4429 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4430 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4431 sizeof(listen_addr)) == -1)
4432 goto tidy_up_and_fail;
e10bb1e9 4433 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4434 goto tidy_up_and_fail;
02fc2eee 4435
3aed30dc 4436 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4437 if (connector == -1)
3aed30dc 4438 goto tidy_up_and_fail;
02fc2eee 4439 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4440 size = sizeof(connect_addr);
4441 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4442 &size) == -1)
4443 goto tidy_up_and_fail;
4444 if (size != sizeof(connect_addr))
4445 goto abort_tidy_up_and_fail;
e10bb1e9 4446 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4447 sizeof(connect_addr)) == -1)
4448 goto tidy_up_and_fail;
02fc2eee 4449
3aed30dc
HS		 4450 size = sizeof(listen_addr);
4451 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4452 &size);
02fc2eee 4453 if (acceptor == -1)
3aed30dc
HS		 4454 goto tidy_up_and_fail;
4455 if (size != sizeof(listen_addr))
4456 goto abort_tidy_up_and_fail;
4457 PerlLIO_close(listener);
02fc2eee
NC		 4458 /* Now check we are talking to ourself by matching port and host on the
4459 two sockets. */
3aed30dc
HS		 4460 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4461 &size) == -1)
4462 goto tidy_up_and_fail;
4463 if (size != sizeof(connect_addr)
4464 || listen_addr.sin_family != connect_addr.sin_family
4465 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4466 || listen_addr.sin_port != connect_addr.sin_port) {
4467 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4468 }
4469 fd[0] = connector;
4470 fd[1] = acceptor;
4471 return 0;
4472
4473 abort_tidy_up_and_fail:
85ca448a 4474 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
02fc2eee
NC		 4475 tidy_up_and_fail:
4476 {
3aed30dc
HS		 4477 int save_errno = errno;
4478 if (listener != -1)
4479 PerlLIO_close(listener);
4480 if (connector != -1)
4481 PerlLIO_close(connector);
4482 if (acceptor != -1)
4483 PerlLIO_close(acceptor);
4484 errno = save_errno;
4485 return -1;
02fc2eee
NC		 4486 }
4487}
85ca448a 4488#else
48ea76d1
JH		 4489/* In any case have a stub so that there's code corresponding
4490 * to the my_socketpair in global.sym. */
4491int
4492Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4493#ifdef HAS_SOCKETPAIR
48ea76d1 4494 return socketpair(family, type, protocol, fd);
daf16542
JH		 4495#else
4496 return -1;
4497#endif
48ea76d1
JH		 4498}
4499#endif
4500
68795e93
NIS		 4501/*
4502
4503=for apidoc sv_nosharing
4504
4505Dummy routine which "shares" an SV when there is no sharing module present.
4506Exists to avoid test for a NULL function pointer and because it could potentially warn under
4507some level of strict-ness.
4508
4509=cut
4510*/
4511
4512void
4513Perl_sv_nosharing(pTHX_ SV *sv)
4514{
4515}
4516
4517/*
4518=for apidoc sv_nolocking
4519
4520Dummy routine which "locks" an SV when there is no locking module present.
4521Exists to avoid test for a NULL function pointer and because it could potentially warn under
4522some level of strict-ness.
4523
4524=cut
4525*/
4526
4527void
4528Perl_sv_nolocking(pTHX_ SV *sv)
4529{
4530}
4531
4532
4533/*
4534=for apidoc sv_nounlocking
4535
4536Dummy routine which "unlocks" an SV when there is no locking module present.
4537Exists to avoid test for a NULL function pointer and because it could potentially warn under
4538some level of strict-ness.
4539
4540=cut
4541*/
4542
4543void
4544Perl_sv_nounlocking(pTHX_ SV *sv)
4545{
4546}
4547
Unnamed repository; edit this file 'description' to name the repository.