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
integrate #18349 from maint-5.8:
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
eb1102fc 3 * Copyright (c) 1991-2002, Larry Wall
a687059c 4 *
d48672a2
LW		 5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
8d063cd8 7 *
8d063cd8 8 */
a0d0e21e
LW		 9
10/*
11 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
12 * not content." --Gandalf
13 */
8d063cd8 14
8d063cd8 15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_UTIL_C
8d063cd8 17#include "perl.h"
62b28dd9 18
64ca3a65 19#ifndef PERL_MICRO
e1dfb34b 20#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
a687059c 21#include <signal.h>
62b28dd9 22#endif
a687059c 23
36477c24 24#ifndef SIG_ERR
25# define SIG_ERR ((Sighandler_t) -1)
26#endif
64ca3a65 27#endif
36477c24 28
ff68c719 29#ifdef I_SYS_WAIT
30# include <sys/wait.h>
31#endif
32
868439a2
JH		 33#ifdef HAS_SELECT
34# ifdef I_SYS_SELECT
35# include <sys/select.h>
36# endif
37#endif
38
8d063cd8 39#define FLUSH
8d063cd8 40
16cebae2
GS		 41#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
42# define FD_CLOEXEC 1 /* NeXT needs this */
43#endif
44
a687059c
LW		 45/* NOTE: Do not call the next three routines directly. Use the macros
46 * in handy.h, so that we can easily redefine everything to do tracking of
47 * allocated hunks back to the original New to track down any memory leaks.
20cec16a 48 * XXX This advice seems to be widely ignored :-( --AD August 1996.
a687059c
LW		 49 */
50
26fa51c3
AMS		 51/* paranoid version of system's malloc() */
52
bd4080b3 53Malloc_t
4f63d024 54Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 55{
54aff467 56 dTHX;
bd4080b3 57 Malloc_t ptr;
55497cff 58#ifdef HAS_64K_LIMIT
62b28dd9 59 if (size > 0xffff) {
bf49b057 60 PerlIO_printf(Perl_error_log,
16cebae2 61 "Allocation too large: %lx\n", size) FLUSH;
54aff467 62 my_exit(1);
62b28dd9 63 }
55497cff 64#endif /* HAS_64K_LIMIT */
34de22dd
LW		 65#ifdef DEBUGGING
66 if ((long)size < 0)
4f63d024 67 Perl_croak_nocontext("panic: malloc");
34de22dd 68#endif
12ae5dfc 69 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 70 PERL_ALLOC_CHECK(ptr);
97835f67 71 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
8d063cd8
LW		 72 if (ptr != Nullch)
73 return ptr;
3280af22 74 else if (PL_nomemok)
7c0587c8 75 return Nullch;
8d063cd8 76 else {
bf49b057 77 PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
54aff467 78 my_exit(1);
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 }
515f54a1 970 sv_catpv(sv, PL_dirty ? dgd : ".\n");
a687059c 971 }
06bf62c7 972 return sv;
a687059c
LW		 973}
974
c5be433b
GS		 975OP *
976Perl_vdie(pTHX_ const char* pat, va_list *args)
36477c24 977{
36477c24 978 char *message;
3280af22 979 int was_in_eval = PL_in_eval;
36477c24 980 HV *stash;
981 GV *gv;
982 CV *cv;
06bf62c7
GS		 983 SV *msv;
984 STRLEN msglen;
36477c24 985
bf49b057 986 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 987 "%p: die: curstack = %p, mainstack = %p\n",
533c011a 988 thr, PL_curstack, PL_mainstack));
36477c24 989
06bf62c7 990 if (pat) {
5a844595
GS		 991 msv = vmess(pat, args);
992 if (PL_errors && SvCUR(PL_errors)) {
993 sv_catsv(PL_errors, msv);
994 message = SvPV(PL_errors, msglen);
995 SvCUR_set(PL_errors, 0);
996 }
997 else
998 message = SvPV(msv,msglen);
06bf62c7
GS		 999 }
1000 else {
1001 message = Nullch;
0f79a09d 1002 msglen = 0;
06bf62c7 1003 }
36477c24 1004
bf49b057 1005 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 1006 "%p: die: message = %s\ndiehook = %p\n",
533c011a 1007 thr, message, PL_diehook));
3280af22 1008 if (PL_diehook) {
cea2e8a9 1009 /* sv_2cv might call Perl_croak() */
3280af22 1010 SV *olddiehook = PL_diehook;
1738f5c4 1011 ENTER;
3280af22
NIS		 1012 SAVESPTR(PL_diehook);
1013 PL_diehook = Nullsv;
1738f5c4
CS		 1014 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1015 LEAVE;
1016 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1017 dSP;
774d564b 1018 SV *msg;
1019
1020 ENTER;
3a1f2dc9 1021 save_re_context();
79cb57f6 1022 if (message) {
06bf62c7 1023 msg = newSVpvn(message, msglen);
4e6ea2c3
GS		 1024 SvREADONLY_on(msg);
1025 SAVEFREESV(msg);
1026 }
1027 else {
1028 msg = ERRSV;
1029 }
1738f5c4 1030
e788e7d3 1031 PUSHSTACKi(PERLSI_DIEHOOK);
924508f0 1032 PUSHMARK(SP);
1738f5c4
CS		 1033 XPUSHs(msg);
1034 PUTBACK;
0cdb2077 1035 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1036 POPSTACK;
774d564b 1037 LEAVE;
1738f5c4 1038 }
36477c24 1039 }
1040
06bf62c7 1041 PL_restartop = die_where(message, msglen);
bf49b057 1042 DEBUG_S(PerlIO_printf(Perl_debug_log,
7c06b590 1043 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
533c011a 1044 thr, PL_restartop, was_in_eval, PL_top_env));
3280af22 1045 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
6224f72b 1046 JMPENV_JUMP(3);
3280af22 1047 return PL_restartop;
36477c24 1048}
1049
c5be433b 1050#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1051OP *
1052Perl_die_nocontext(const char* pat, ...)
a687059c 1053{
cea2e8a9
GS		 1054 dTHX;
1055 OP *o;
a687059c 1056 va_list args;
cea2e8a9 1057 va_start(args, pat);
c5be433b 1058 o = vdie(pat, &args);
cea2e8a9
GS		 1059 va_end(args);
1060 return o;
1061}
c5be433b 1062#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS		 1063
1064OP *
1065Perl_die(pTHX_ const char* pat, ...)
1066{
1067 OP *o;
1068 va_list args;
1069 va_start(args, pat);
c5be433b 1070 o = vdie(pat, &args);
cea2e8a9
GS		 1071 va_end(args);
1072 return o;
1073}
1074
c5be433b
GS		 1075void
1076Perl_vcroak(pTHX_ const char* pat, va_list *args)
cea2e8a9 1077{
de3bb511 1078 char *message;
748a9306
LW		 1079 HV *stash;
1080 GV *gv;
1081 CV *cv;
06bf62c7
GS		 1082 SV *msv;
1083 STRLEN msglen;
a687059c 1084
9983fa3c
GS		 1085 if (pat) {
1086 msv = vmess(pat, args);
1087 if (PL_errors && SvCUR(PL_errors)) {
1088 sv_catsv(PL_errors, msv);
1089 message = SvPV(PL_errors, msglen);
1090 SvCUR_set(PL_errors, 0);
1091 }
1092 else
1093 message = SvPV(msv,msglen);
1094 }
1095 else {
1096 message = Nullch;
1097 msglen = 0;
5a844595 1098 }
5a844595 1099
b900a521
JH		 1100 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1101 PTR2UV(thr), message));
5a844595 1102
3280af22 1103 if (PL_diehook) {
cea2e8a9 1104 /* sv_2cv might call Perl_croak() */
3280af22 1105 SV *olddiehook = PL_diehook;
1738f5c4 1106 ENTER;
3280af22
NIS		 1107 SAVESPTR(PL_diehook);
1108 PL_diehook = Nullsv;
20cec16a 1109 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1738f5c4
CS		 1110 LEAVE;
1111 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1112 dSP;
774d564b 1113 SV *msg;
1114
1115 ENTER;
3a1f2dc9 1116 save_re_context();
9983fa3c
GS		 1117 if (message) {
1118 msg = newSVpvn(message, msglen);
1119 SvREADONLY_on(msg);
1120 SAVEFREESV(msg);
1121 }
1122 else {
1123 msg = ERRSV;
1124 }
20cec16a 1125
e788e7d3 1126 PUSHSTACKi(PERLSI_DIEHOOK);
924508f0 1127 PUSHMARK(SP);
1738f5c4 1128 XPUSHs(msg);
20cec16a 1129 PUTBACK;
864dbfa3 1130 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1131 POPSTACK;
774d564b 1132 LEAVE;
20cec16a 1133 }
748a9306 1134 }
3280af22 1135 if (PL_in_eval) {
06bf62c7 1136 PL_restartop = die_where(message, msglen);
6224f72b 1137 JMPENV_JUMP(3);
a0d0e21e 1138 }
84414e3e
JH		 1139 else if (!message)
1140 message = SvPVx(ERRSV, msglen);
1141
d175a3f0
GS		 1142 {
1143#ifdef USE_SFIO
1144 /* SFIO can really mess with your errno */
1145 int e = errno;
1146#endif
bf49b057
GS		 1147 PerlIO *serr = Perl_error_log;
1148
be708cc0 1149 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
bf49b057 1150 (void)PerlIO_flush(serr);
d175a3f0
GS		 1151#ifdef USE_SFIO
1152 errno = e;
1153#endif
1154 }
f86702cc 1155 my_failure_exit();
a687059c
LW		 1156}
1157
c5be433b 1158#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1159void
cea2e8a9 1160Perl_croak_nocontext(const char *pat, ...)
a687059c 1161{
cea2e8a9 1162 dTHX;
a687059c 1163 va_list args;
cea2e8a9 1164 va_start(args, pat);
c5be433b 1165 vcroak(pat, &args);
cea2e8a9
GS		 1166 /* NOTREACHED */
1167 va_end(args);
1168}
1169#endif /* PERL_IMPLICIT_CONTEXT */
1170
954c1994 1171/*
ccfc67b7
JH		 1172=head1 Warning and Dieing
1173
954c1994
GS		 1174=for apidoc croak
1175
9983fa3c
GS		 1176This is the XSUB-writer's interface to Perl's C<die> function.
1177Normally use this function the same way you use the C C<printf>
1178function. See C<warn>.
1179
1180If you want to throw an exception object, assign the object to
1181C<$@> and then pass C<Nullch> to croak():
1182
1183 errsv = get_sv("@", TRUE);
1184 sv_setsv(errsv, exception_object);
1185 croak(Nullch);
954c1994
GS		 1186
1187=cut
1188*/
1189
cea2e8a9
GS		 1190void
1191Perl_croak(pTHX_ const char *pat, ...)
1192{
1193 va_list args;
1194 va_start(args, pat);
c5be433b 1195 vcroak(pat, &args);
cea2e8a9
GS		 1196 /* NOTREACHED */
1197 va_end(args);
1198}
1199
c5be433b
GS		 1200void
1201Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1202{
de3bb511 1203 char *message;
748a9306
LW		 1204 HV *stash;
1205 GV *gv;
1206 CV *cv;
06bf62c7
GS		 1207 SV *msv;
1208 STRLEN msglen;
87582a92
AT		 1209 IO *io;
1210 MAGIC *mg;
a687059c 1211
5a844595 1212 msv = vmess(pat, args);
06bf62c7 1213 message = SvPV(msv, msglen);
a687059c 1214
3280af22 1215 if (PL_warnhook) {
cea2e8a9 1216 /* sv_2cv might call Perl_warn() */
3280af22 1217 SV *oldwarnhook = PL_warnhook;
1738f5c4 1218 ENTER;
3280af22
NIS		 1219 SAVESPTR(PL_warnhook);
1220 PL_warnhook = Nullsv;
20cec16a 1221 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1738f5c4
CS		 1222 LEAVE;
1223 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1224 dSP;
774d564b 1225 SV *msg;
1226
1227 ENTER;
3a1f2dc9 1228 save_re_context();
06bf62c7 1229 msg = newSVpvn(message, msglen);
774d564b 1230 SvREADONLY_on(msg);
1231 SAVEFREESV(msg);
1232
e788e7d3 1233 PUSHSTACKi(PERLSI_WARNHOOK);
924508f0 1234 PUSHMARK(SP);
774d564b 1235 XPUSHs(msg);
20cec16a 1236 PUTBACK;
864dbfa3 1237 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1238 POPSTACK;
774d564b 1239 LEAVE;
20cec16a 1240 return;
1241 }
748a9306 1242 }
87582a92
AT		 1243
1244 /* if STDERR is tied, use it instead */
1245 if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1246 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1247 dSP; ENTER;
1248 PUSHMARK(SP);
1249 XPUSHs(SvTIED_obj((SV*)io, mg));
1250 XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1251 PUTBACK;
1252 call_method("PRINT", G_SCALAR);
1253 LEAVE;
1254 return;
1255 }
1256
bf49b057
GS		 1257 {
1258 PerlIO *serr = Perl_error_log;
1259
be708cc0 1260 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
bf49b057
GS		 1261 (void)PerlIO_flush(serr);
1262 }
a687059c 1263}
8d063cd8 1264
c5be433b 1265#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1266void
1267Perl_warn_nocontext(const char *pat, ...)
1268{
1269 dTHX;
1270 va_list args;
1271 va_start(args, pat);
c5be433b 1272 vwarn(pat, &args);
cea2e8a9
GS		 1273 va_end(args);
1274}
1275#endif /* PERL_IMPLICIT_CONTEXT */
1276
954c1994
GS		 1277/*
1278=for apidoc warn
1279
1280This is the XSUB-writer's interface to Perl's C<warn> function. Use this
1281function the same way you use the C C<printf> function. See
1282C<croak>.
1283
1284=cut
1285*/
1286
cea2e8a9
GS		 1287void
1288Perl_warn(pTHX_ const char *pat, ...)
1289{
1290 va_list args;
1291 va_start(args, pat);
c5be433b 1292 vwarn(pat, &args);
cea2e8a9
GS		 1293 va_end(args);
1294}
1295
c5be433b
GS		 1296#if defined(PERL_IMPLICIT_CONTEXT)
1297void
1298Perl_warner_nocontext(U32 err, const char *pat, ...)
1299{
1300 dTHX;
1301 va_list args;
1302 va_start(args, pat);
1303 vwarner(err, pat, &args);
1304 va_end(args);
1305}
1306#endif /* PERL_IMPLICIT_CONTEXT */
1307
599cee73 1308void
864dbfa3 1309Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1310{
1311 va_list args;
c5be433b
GS		 1312 va_start(args, pat);
1313 vwarner(err, pat, &args);
1314 va_end(args);
1315}
1316
1317void
1318Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1319{
599cee73
PM		 1320 char *message;
1321 HV *stash;
1322 GV *gv;
1323 CV *cv;
06bf62c7
GS		 1324 SV *msv;
1325 STRLEN msglen;
599cee73 1326
5a844595 1327 msv = vmess(pat, args);
06bf62c7 1328 message = SvPV(msv, msglen);
599cee73
PM		 1329
1330 if (ckDEAD(err)) {
3aed30dc
HS		 1331 if (PL_diehook) {
1332 /* sv_2cv might call Perl_croak() */
1333 SV *olddiehook = PL_diehook;
1334 ENTER;
1335 SAVESPTR(PL_diehook);
1336 PL_diehook = Nullsv;
1337 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1338 LEAVE;
1339 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1340 dSP;
1341 SV *msg;
1342
1343 ENTER;
3a1f2dc9 1344 save_re_context();
3aed30dc
HS		 1345 msg = newSVpvn(message, msglen);
1346 SvREADONLY_on(msg);
1347 SAVEFREESV(msg);
a1d180c4 1348
3a1f2dc9 1349 PUSHSTACKi(PERLSI_DIEHOOK);
3aed30dc
HS		 1350 PUSHMARK(sp);
1351 XPUSHs(msg);
1352 PUTBACK;
1353 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1354 POPSTACK;
3aed30dc
HS		 1355 LEAVE;
1356 }
1357 }
1358 if (PL_in_eval) {
1359 PL_restartop = die_where(message, msglen);
1360 JMPENV_JUMP(3);
1361 }
bf49b057
GS		 1362 {
1363 PerlIO *serr = Perl_error_log;
be708cc0 1364 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
bf49b057
GS		 1365 (void)PerlIO_flush(serr);
1366 }
3aed30dc 1367 my_failure_exit();
599cee73
PM		 1368 }
1369 else {
3aed30dc
HS		 1370 if (PL_warnhook) {
1371 /* sv_2cv might call Perl_warn() */
1372 SV *oldwarnhook = PL_warnhook;
1373 ENTER;
1374 SAVESPTR(PL_warnhook);
1375 PL_warnhook = Nullsv;
1376 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
3a1f2dc9 1377 LEAVE;
3aed30dc
HS		 1378 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1379 dSP;
1380 SV *msg;
a1d180c4 1381
3aed30dc 1382 ENTER;
3a1f2dc9 1383 save_re_context();
3aed30dc
HS		 1384 msg = newSVpvn(message, msglen);
1385 SvREADONLY_on(msg);
1386 SAVEFREESV(msg);
a1d180c4 1387
3a1f2dc9 1388 PUSHSTACKi(PERLSI_WARNHOOK);
3aed30dc
HS		 1389 PUSHMARK(sp);
1390 XPUSHs(msg);
1391 PUTBACK;
1392 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1393 POPSTACK;
3aed30dc
HS		 1394 LEAVE;
1395 return;
1396 }
1397 }
bf49b057
GS		 1398 {
1399 PerlIO *serr = Perl_error_log;
be708cc0 1400 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
bf49b057
GS		 1401 (void)PerlIO_flush(serr);
1402 }
599cee73
PM		 1403 }
1404}
1405
e6587932
DM		 1406/* since we've already done strlen() for both nam and val
1407 * we can use that info to make things faster than
1408 * sprintf(s, "%s=%s", nam, val)
1409 */
1410#define my_setenv_format(s, nam, nlen, val, vlen) \
1411 Copy(nam, s, nlen, char); \
1412 *(s+nlen) = '='; \
1413 Copy(val, s+(nlen+1), vlen, char); \
1414 *(s+(nlen+1+vlen)) = '\0'
1415
13b6e58c 1416#ifdef USE_ENVIRON_ARRAY
eccd403f 1417 /* VMS' my_setenv() is in vms.c */
2986a63f 1418#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1419void
864dbfa3 1420Perl_my_setenv(pTHX_ char *nam, char *val)
8d063cd8 1421{
4efc5df6
GS		 1422#ifdef USE_ITHREADS
1423 /* only parent thread can modify process environment */
1424 if (PL_curinterp == aTHX)
1425#endif
1426 {
f2517201
GS		 1427#ifndef PERL_USE_SAFE_PUTENV
1428 /* most putenv()s leak, so we manipulate environ directly */
79072805 1429 register I32 i=setenv_getix(nam); /* where does it go? */
e6587932 1430 int nlen, vlen;
8d063cd8 1431
3280af22 1432 if (environ == PL_origenviron) { /* need we copy environment? */
79072805
LW		 1433 I32 j;
1434 I32 max;
fe14fcc3
LW		 1435 char **tmpenv;
1436
de3bb511 1437 /*SUPPRESS 530*/
fe14fcc3 1438 for (max = i; environ[max]; max++) ;
f2517201
GS		 1439 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1440 for (j=0; j<max; j++) { /* copy environment */
3aed30dc
HS		 1441 int len = strlen(environ[j]);
1442 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1443 Copy(environ[j], tmpenv[j], len+1, char);
f2517201 1444 }
fe14fcc3
LW		 1445 tmpenv[max] = Nullch;
1446 environ = tmpenv; /* tell exec where it is now */
1447 }
a687059c 1448 if (!val) {
f2517201 1449 safesysfree(environ[i]);
a687059c
LW		 1450 while (environ[i]) {
1451 environ[i] = environ[i+1];
1452 i++;
1453 }
1454 return;
1455 }
8d063cd8 1456 if (!environ[i]) { /* does not exist yet */
f2517201 1457 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
8d063cd8
LW		 1458 environ[i+1] = Nullch; /* make sure it's null terminated */
1459 }
fe14fcc3 1460 else
f2517201 1461 safesysfree(environ[i]);
e6587932
DM		 1462 nlen = strlen(nam);
1463 vlen = strlen(val);
f2517201 1464
e6587932
DM		 1465 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1466 /* all that work just for this */
1467 my_setenv_format(environ[i], nam, nlen, val, vlen);
f2517201
GS		 1468
1469#else /* PERL_USE_SAFE_PUTENV */
eccd403f 1470# if defined(__CYGWIN__) || defined( EPOC)
47dafe4d
EF		 1471 setenv(nam, val, 1);
1472# else
f2517201 1473 char *new_env;
e6587932
DM		 1474 int nlen = strlen(nam), vlen;
1475 if (!val) {
3aed30dc 1476 val = "";
e6587932
DM		 1477 }
1478 vlen = strlen(val);
1479 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1480 /* all that work just for this */
1481 my_setenv_format(new_env, nam, nlen, val, vlen);
f2517201 1482 (void)putenv(new_env);
47dafe4d 1483# endif /* __CYGWIN__ */
f2517201 1484#endif /* PERL_USE_SAFE_PUTENV */
4efc5df6 1485 }
8d063cd8
LW		 1486}
1487
2986a63f 1488#else /* WIN32 || NETWARE */
68dc0745 1489
1490void
864dbfa3 1491Perl_my_setenv(pTHX_ char *nam,char *val)
68dc0745 1492{
ac5c734f 1493 register char *envstr;
e6587932
DM		 1494 int nlen = strlen(nam), vlen;
1495
ac5c734f
GS		 1496 if (!val) {
1497 val = "";
1498 }
e6587932
DM		 1499 vlen = strlen(val);
1500 New(904, envstr, nlen+vlen+2, char);
1501 my_setenv_format(envstr, nam, nlen, val, vlen);
ac5c734f
GS		 1502 (void)PerlEnv_putenv(envstr);
1503 Safefree(envstr);
3e3baf6d
TB		 1504}
1505
2986a63f 1506#endif /* WIN32 || NETWARE */
3e3baf6d
TB		 1507
1508I32
864dbfa3 1509Perl_setenv_getix(pTHX_ char *nam)
3e3baf6d
TB		 1510{
1511 register I32 i, len = strlen(nam);
1512
1513 for (i = 0; environ[i]; i++) {
1514 if (
1515#ifdef WIN32
1516 strnicmp(environ[i],nam,len) == 0
1517#else
1518 strnEQ(environ[i],nam,len)
1519#endif
1520 && environ[i][len] == '=')
1521 break; /* strnEQ must come first to avoid */
1522 } /* potential SEGV's */
1523 return i;
68dc0745 1524}
1525
ed79a026 1526#endif /* !VMS && !EPOC*/
378cc40b 1527
16d20bd9 1528#ifdef UNLINK_ALL_VERSIONS
79072805 1529I32
864dbfa3 1530Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
378cc40b 1531{
79072805 1532 I32 i;
378cc40b 1533
6ad3d225 1534 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
378cc40b
LW		 1535 return i ? 0 : -1;
1536}
1537#endif
1538
7a3f2258 1539/* this is a drop-in replacement for bcopy() */
2253333f 1540#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1541char *
7a3f2258 1542Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b
LW		 1543{
1544 char *retval = to;
1545
7c0587c8
LW		 1546 if (from - to >= 0) {
1547 while (len--)
1548 *to++ = *from++;
1549 }
1550 else {
1551 to += len;
1552 from += len;
1553 while (len--)
faf8582f 1554 *(--to) = *(--from);
7c0587c8 1555 }
378cc40b
LW		 1556 return retval;
1557}
ffed7fef 1558#endif
378cc40b 1559
7a3f2258 1560/* this is a drop-in replacement for memset() */
fc36a67e 1561#ifndef HAS_MEMSET
1562void *
7a3f2258 1563Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1564{
1565 char *retval = loc;
1566
1567 while (len--)
1568 *loc++ = ch;
1569 return retval;
1570}
1571#endif
1572
7a3f2258 1573/* this is a drop-in replacement for bzero() */
7c0587c8 1574#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1575char *
7a3f2258 1576Perl_my_bzero(register char *loc, register I32 len)
378cc40b
LW		 1577{
1578 char *retval = loc;
1579
1580 while (len--)
1581 *loc++ = 0;
1582 return retval;
1583}
1584#endif
7c0587c8 1585
7a3f2258 1586/* this is a drop-in replacement for memcmp() */
36477c24 1587#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1588I32
7a3f2258 1589Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1590{
36477c24 1591 register U8 *a = (U8 *)s1;
1592 register U8 *b = (U8 *)s2;
79072805 1593 register I32 tmp;
7c0587c8
LW		 1594
1595 while (len--) {
36477c24 1596 if (tmp = *a++ - *b++)
7c0587c8
LW		 1597 return tmp;
1598 }
1599 return 0;
1600}
36477c24 1601#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1602
fe14fcc3 1603#ifndef HAS_VPRINTF
a687059c 1604
85e6fe83 1605#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1606char *
1607#else
1608int
1609#endif
08105a92 1610vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 1611{
1612 FILE fakebuf;
1613
1614 fakebuf._ptr = dest;
1615 fakebuf._cnt = 32767;
35c8bce7
LW		 1616#ifndef _IOSTRG
1617#define _IOSTRG 0
1618#endif
a687059c
LW		 1619 fakebuf._flag = _IOWRT|_IOSTRG;
1620 _doprnt(pat, args, &fakebuf); /* what a kludge */
1621 (void)putc('\0', &fakebuf);
85e6fe83 1622#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1623 return(dest);
1624#else
1625 return 0; /* perl doesn't use return value */
1626#endif
1627}
1628
fe14fcc3 1629#endif /* HAS_VPRINTF */
a687059c
LW		 1630
1631#ifdef MYSWAP
ffed7fef 1632#if BYTEORDER != 0x4321
a687059c 1633short
864dbfa3 1634Perl_my_swap(pTHX_ short s)
a687059c
LW		 1635{
1636#if (BYTEORDER & 1) == 0
1637 short result;
1638
1639 result = ((s & 255) << 8) + ((s >> 8) & 255);
1640 return result;
1641#else
1642 return s;
1643#endif
1644}
1645
1646long
864dbfa3 1647Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1648{
1649 union {
1650 long result;
ffed7fef 1651 char c[sizeof(long)];
a687059c
LW		 1652 } u;
1653
ffed7fef 1654#if BYTEORDER == 0x1234
a687059c
LW		 1655 u.c[0] = (l >> 24) & 255;
1656 u.c[1] = (l >> 16) & 255;
1657 u.c[2] = (l >> 8) & 255;
1658 u.c[3] = l & 255;
1659 return u.result;
1660#else
ffed7fef 1661#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1662 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1663#else
79072805
LW		 1664 register I32 o;
1665 register I32 s;
a687059c 1666
ffed7fef
LW		 1667 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1668 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1669 }
1670 return u.result;
1671#endif
1672#endif
1673}
1674
1675long
864dbfa3 1676Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1677{
1678 union {
1679 long l;
ffed7fef 1680 char c[sizeof(long)];
a687059c
LW		 1681 } u;
1682
ffed7fef 1683#if BYTEORDER == 0x1234
a687059c
LW		 1684 u.c[0] = (l >> 24) & 255;
1685 u.c[1] = (l >> 16) & 255;
1686 u.c[2] = (l >> 8) & 255;
1687 u.c[3] = l & 255;
1688 return u.l;
1689#else
ffed7fef 1690#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1691 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1692#else
79072805
LW		 1693 register I32 o;
1694 register I32 s;
a687059c
LW		 1695
1696 u.l = l;
1697 l = 0;
ffed7fef
LW		 1698 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1699 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1700 }
1701 return l;
1702#endif
1703#endif
1704}
1705
ffed7fef 1706#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1707#endif /* MYSWAP */
1708
1709/*
1710 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1711 * If these functions are defined,
1712 * the BYTEORDER is neither 0x1234 nor 0x4321.
1713 * However, this is not assumed.
1714 * -DWS
1715 */
1716
1717#define HTOV(name,type) \
1718 type \
ba106d47 1719 name (register type n) \
988174c1
LW		 1720 { \
1721 union { \
1722 type value; \
1723 char c[sizeof(type)]; \
1724 } u; \
79072805
LW		 1725 register I32 i; \
1726 register I32 s; \
988174c1
LW		 1727 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1728 u.c[i] = (n >> s) & 0xFF; \
1729 } \
1730 return u.value; \
1731 }
1732
1733#define VTOH(name,type) \
1734 type \
ba106d47 1735 name (register type n) \
988174c1
LW		 1736 { \
1737 union { \
1738 type value; \
1739 char c[sizeof(type)]; \
1740 } u; \
79072805
LW		 1741 register I32 i; \
1742 register I32 s; \
988174c1
LW		 1743 u.value = n; \
1744 n = 0; \
1745 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1746 n += (u.c[i] & 0xFF) << s; \
1747 } \
1748 return n; \
1749 }
1750
1751#if defined(HAS_HTOVS) && !defined(htovs)
1752HTOV(htovs,short)
1753#endif
1754#if defined(HAS_HTOVL) && !defined(htovl)
1755HTOV(htovl,long)
1756#endif
1757#if defined(HAS_VTOHS) && !defined(vtohs)
1758VTOH(vtohs,short)
1759#endif
1760#if defined(HAS_VTOHL) && !defined(vtohl)
1761VTOH(vtohl,long)
1762#endif
a687059c 1763
4a7d1889
NIS		 1764PerlIO *
1765Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1766{
2986a63f 1767#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1f852d0d
NIS		 1768 int p[2];
1769 register I32 This, that;
1770 register Pid_t pid;
1771 SV *sv;
1772 I32 did_pipes = 0;
1773 int pp[2];
1774
1775 PERL_FLUSHALL_FOR_CHILD;
1776 This = (*mode == 'w');
1777 that = !This;
1778 if (PL_tainting) {
1779 taint_env();
1780 taint_proper("Insecure %s%s", "EXEC");
1781 }
1782 if (PerlProc_pipe(p) < 0)
1783 return Nullfp;
1784 /* Try for another pipe pair for error return */
1785 if (PerlProc_pipe(pp) >= 0)
1786 did_pipes = 1;
52e18b1f 1787 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 1788 if (errno != EAGAIN) {
1789 PerlLIO_close(p[This]);
4e6dfe71 1790 PerlLIO_close(p[that]);
1f852d0d
NIS		 1791 if (did_pipes) {
1792 PerlLIO_close(pp[0]);
1793 PerlLIO_close(pp[1]);
1794 }
1795 return Nullfp;
1796 }
1797 sleep(5);
1798 }
1799 if (pid == 0) {
1800 /* Child */
1f852d0d
NIS		 1801#undef THIS
1802#undef THAT
1803#define THIS that
1804#define THAT This
1f852d0d
NIS		 1805 /* Close parent's end of error status pipe (if any) */
1806 if (did_pipes) {
1807 PerlLIO_close(pp[0]);
1808#if defined(HAS_FCNTL) && defined(F_SETFD)
1809 /* Close error pipe automatically if exec works */
1810 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1811#endif
1812 }
1813 /* Now dup our end of _the_ pipe to right position */
1814 if (p[THIS] != (*mode == 'r')) {
1815 PerlLIO_dup2(p[THIS], *mode == 'r');
1816 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 1817 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1818 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 1819 }
4e6dfe71
GS		 1820 else
1821 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 1822#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1823 /* No automatic close - do it by hand */
b7953727
JH		 1824# ifndef NOFILE
1825# define NOFILE 20
1826# endif
a080fe3d
NIS		 1827 {
1828 int fd;
1829
1830 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 1831 if (fd != pp[1])
a080fe3d
NIS		 1832 PerlLIO_close(fd);
1833 }
1f852d0d
NIS		 1834 }
1835#endif
1836 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1837 PerlProc__exit(1);
1838#undef THIS
1839#undef THAT
1840 }
1841 /* Parent */
52e18b1f 1842 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 1843 if (did_pipes)
1844 PerlLIO_close(pp[1]);
1845 /* Keep the lower of the two fd numbers */
1846 if (p[that] < p[This]) {
1847 PerlLIO_dup2(p[This], p[that]);
1848 PerlLIO_close(p[This]);
1849 p[This] = p[that];
1850 }
4e6dfe71
GS		 1851 else
1852 PerlLIO_close(p[that]); /* close child's end of pipe */
1853
1f852d0d
NIS		 1854 LOCK_FDPID_MUTEX;
1855 sv = *av_fetch(PL_fdpid,p[This],TRUE);
1856 UNLOCK_FDPID_MUTEX;
1857 (void)SvUPGRADE(sv,SVt_IV);
1858 SvIVX(sv) = pid;
1859 PL_forkprocess = pid;
1860 /* If we managed to get status pipe check for exec fail */
1861 if (did_pipes && pid > 0) {
1862 int errkid;
1863 int n = 0, n1;
1864
1865 while (n < sizeof(int)) {
1866 n1 = PerlLIO_read(pp[0],
1867 (void*)(((char*)&errkid)+n),
1868 (sizeof(int)) - n);
1869 if (n1 <= 0)
1870 break;
1871 n += n1;
1872 }
1873 PerlLIO_close(pp[0]);
1874 did_pipes = 0;
1875 if (n) { /* Error */
1876 int pid2, status;
8c51524e 1877 PerlLIO_close(p[This]);
1f852d0d
NIS		 1878 if (n != sizeof(int))
1879 Perl_croak(aTHX_ "panic: kid popen errno read");
1880 do {
1881 pid2 = wait4pid(pid, &status, 0);
1882 } while (pid2 == -1 && errno == EINTR);
1883 errno = errkid; /* Propagate errno from kid */
1884 return Nullfp;
1885 }
1886 }
1887 if (did_pipes)
1888 PerlLIO_close(pp[0]);
1889 return PerlIO_fdopen(p[This], mode);
1890#else
4a7d1889
NIS		 1891 Perl_croak(aTHX_ "List form of piped open not implemented");
1892 return (PerlIO *) NULL;
1f852d0d 1893#endif
4a7d1889
NIS		 1894}
1895
5f05dabc 1896 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 1897#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 1898PerlIO *
864dbfa3 1899Perl_my_popen(pTHX_ char *cmd, char *mode)
a687059c
LW		 1900{
1901 int p[2];
8ac85365 1902 register I32 This, that;
d8a83dd3 1903 register Pid_t pid;
79072805 1904 SV *sv;
1738f5c4 1905 I32 doexec = strNE(cmd,"-");
e446cec8
IZ		 1906 I32 did_pipes = 0;
1907 int pp[2];
a687059c 1908
45bc9206 1909 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 1910#ifdef OS2
1911 if (doexec) {
23da6c43 1912 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 1913 }
a1d180c4 1914#endif
8ac85365
NIS		 1915 This = (*mode == 'w');
1916 that = !This;
3280af22 1917 if (doexec && PL_tainting) {
bbce6d69 1918 taint_env();
1919 taint_proper("Insecure %s%s", "EXEC");
d48672a2 1920 }
c2267164
IZ		 1921 if (PerlProc_pipe(p) < 0)
1922 return Nullfp;
e446cec8
IZ		 1923 if (doexec && PerlProc_pipe(pp) >= 0)
1924 did_pipes = 1;
52e18b1f 1925 while ((pid = PerlProc_fork()) < 0) {
a687059c 1926 if (errno != EAGAIN) {
6ad3d225 1927 PerlLIO_close(p[This]);
b5ac89c3 1928 PerlLIO_close(p[that]);
e446cec8
IZ		 1929 if (did_pipes) {
1930 PerlLIO_close(pp[0]);
1931 PerlLIO_close(pp[1]);
1932 }
a687059c 1933 if (!doexec)
cea2e8a9 1934 Perl_croak(aTHX_ "Can't fork");
a687059c
LW		 1935 return Nullfp;
1936 }
1937 sleep(5);
1938 }
1939 if (pid == 0) {
79072805
LW		 1940 GV* tmpgv;
1941
30ac6d9b
GS		 1942#undef THIS
1943#undef THAT
a687059c 1944#define THIS that
8ac85365 1945#define THAT This
e446cec8
IZ		 1946 if (did_pipes) {
1947 PerlLIO_close(pp[0]);
1948#if defined(HAS_FCNTL) && defined(F_SETFD)
1949 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1950#endif
1951 }
a687059c 1952 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 1953 PerlLIO_dup2(p[THIS], *mode == 'r');
1954 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 1955 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1956 PerlLIO_close(p[THAT]);
a687059c 1957 }
b5ac89c3
NIS		 1958 else
1959 PerlLIO_close(p[THAT]);
4435c477 1960#ifndef OS2
a687059c 1961 if (doexec) {
a0d0e21e 1962#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 1963 int fd;
1964
1965#ifndef NOFILE
1966#define NOFILE 20
1967#endif
a080fe3d 1968 {
3aed30dc 1969 int fd;
a080fe3d
NIS		 1970
1971 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
1972 if (fd != pp[1])
3aed30dc 1973 PerlLIO_close(fd);
a080fe3d 1974 }
ae986130 1975#endif
a080fe3d
NIS		 1976 /* may or may not use the shell */
1977 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 1978 PerlProc__exit(1);
a687059c 1979 }
4435c477 1980#endif /* defined OS2 */
de3bb511 1981 /*SUPPRESS 560*/
306196c3 1982 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4d76a344 1983 SvREADONLY_off(GvSV(tmpgv));
7766f137 1984 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 1985 SvREADONLY_on(GvSV(tmpgv));
1986 }
1987#ifdef THREADS_HAVE_PIDS
1988 PL_ppid = (IV)getppid();
1989#endif
3280af22
NIS		 1990 PL_forkprocess = 0;
1991 hv_clear(PL_pidstatus); /* we have no children */
a687059c
LW		 1992 return Nullfp;
1993#undef THIS
1994#undef THAT
1995 }
b5ac89c3 1996 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 1997 if (did_pipes)
1998 PerlLIO_close(pp[1]);
8ac85365 1999 if (p[that] < p[This]) {
6ad3d225
GS		 2000 PerlLIO_dup2(p[This], p[that]);
2001 PerlLIO_close(p[This]);
8ac85365 2002 p[This] = p[that];
62b28dd9 2003 }
b5ac89c3
NIS		 2004 else
2005 PerlLIO_close(p[that]);
2006
4755096e 2007 LOCK_FDPID_MUTEX;
3280af22 2008 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2009 UNLOCK_FDPID_MUTEX;
a0d0e21e 2010 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2011 SvIVX(sv) = pid;
3280af22 2012 PL_forkprocess = pid;
e446cec8
IZ		 2013 if (did_pipes && pid > 0) {
2014 int errkid;
2015 int n = 0, n1;
2016
2017 while (n < sizeof(int)) {
2018 n1 = PerlLIO_read(pp[0],
2019 (void*)(((char*)&errkid)+n),
2020 (sizeof(int)) - n);
2021 if (n1 <= 0)
2022 break;
2023 n += n1;
2024 }
2f96c702
IZ		 2025 PerlLIO_close(pp[0]);
2026 did_pipes = 0;
e446cec8 2027 if (n) { /* Error */
faa466a7 2028 int pid2, status;
8c51524e 2029 PerlLIO_close(p[This]);
e446cec8 2030 if (n != sizeof(int))
cea2e8a9 2031 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2032 do {
2033 pid2 = wait4pid(pid, &status, 0);
2034 } while (pid2 == -1 && errno == EINTR);
e446cec8
IZ		 2035 errno = errkid; /* Propagate errno from kid */
2036 return Nullfp;
2037 }
2038 }
2039 if (did_pipes)
2040 PerlLIO_close(pp[0]);
8ac85365 2041 return PerlIO_fdopen(p[This], mode);
a687059c 2042}
7c0587c8 2043#else
85ca448a 2044#if defined(atarist) || defined(EPOC)
7c0587c8 2045FILE *popen();
760ac839 2046PerlIO *
864dbfa3 2047Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2048{
45bc9206 2049 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2050 /* Call system's popen() to get a FILE *, then import it.
2051 used 0 for 2nd parameter to PerlIO_importFILE;
2052 apparently not used
2053 */
2054 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2055}
2b96b0a5
JH		 2056#else
2057#if defined(DJGPP)
2058FILE *djgpp_popen();
2059PerlIO *
2060Perl_my_popen(pTHX_ char *cmd, char *mode)
2061{
2062 PERL_FLUSHALL_FOR_CHILD;
2063 /* Call system's popen() to get a FILE *, then import it.
2064 used 0 for 2nd parameter to PerlIO_importFILE;
2065 apparently not used
2066 */
2067 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2068}
2069#endif
7c0587c8
LW		 2070#endif
2071
2072#endif /* !DOSISH */
a687059c 2073
52e18b1f
GS		 2074/* this is called in parent before the fork() */
2075void
2076Perl_atfork_lock(void)
2077{
3db8f154 2078#if defined(USE_ITHREADS)
52e18b1f
GS		 2079 /* locks must be held in locking order (if any) */
2080# ifdef MYMALLOC
2081 MUTEX_LOCK(&PL_malloc_mutex);
2082# endif
2083 OP_REFCNT_LOCK;
2084#endif
2085}
2086
2087/* this is called in both parent and child after the fork() */
2088void
2089Perl_atfork_unlock(void)
2090{
3db8f154 2091#if defined(USE_ITHREADS)
52e18b1f
GS		 2092 /* locks must be released in same order as in atfork_lock() */
2093# ifdef MYMALLOC
2094 MUTEX_UNLOCK(&PL_malloc_mutex);
2095# endif
2096 OP_REFCNT_UNLOCK;
2097#endif
2098}
2099
2100Pid_t
2101Perl_my_fork(void)
2102{
2103#if defined(HAS_FORK)
2104 Pid_t pid;
3db8f154 2105#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2106 atfork_lock();
2107 pid = fork();
2108 atfork_unlock();
2109#else
2110 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2111 * handlers elsewhere in the code */
2112 pid = fork();
2113#endif
2114 return pid;
2115#else
2116 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2117 Perl_croak_nocontext("fork() not available");
b961a566 2118 return 0;
52e18b1f
GS		 2119#endif /* HAS_FORK */
2120}
2121
748a9306 2122#ifdef DUMP_FDS
35ff7856 2123void
864dbfa3 2124Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2125{
2126 int fd;
c623ac67 2127 Stat_t tmpstatbuf;
ae986130 2128
bf49b057 2129 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2130 for (fd = 0; fd < 32; fd++) {
6ad3d225 2131 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2132 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2133 }
bf49b057 2134 PerlIO_printf(Perl_debug_log,"\n");
ae986130 2135}
35ff7856 2136#endif /* DUMP_FDS */
ae986130 2137
fe14fcc3 2138#ifndef HAS_DUP2
fec02dd3 2139int
ba106d47 2140dup2(int oldfd, int newfd)
a687059c 2141{
a0d0e21e 2142#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2143 if (oldfd == newfd)
2144 return oldfd;
6ad3d225 2145 PerlLIO_close(newfd);
fec02dd3 2146 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2147#else
fc36a67e 2148#define DUP2_MAX_FDS 256
2149 int fdtmp[DUP2_MAX_FDS];
79072805 2150 I32 fdx = 0;
ae986130
LW		 2151 int fd;
2152
fe14fcc3 2153 if (oldfd == newfd)
fec02dd3 2154 return oldfd;
6ad3d225 2155 PerlLIO_close(newfd);
fc36a67e 2156 /* good enough for low fd's... */
6ad3d225 2157 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2158 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2159 PerlLIO_close(fd);
fc36a67e 2160 fd = -1;
2161 break;
2162 }
ae986130 2163 fdtmp[fdx++] = fd;
fc36a67e 2164 }
ae986130 2165 while (fdx > 0)
6ad3d225 2166 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2167 return fd;
62b28dd9 2168#endif
a687059c
LW		 2169}
2170#endif
2171
64ca3a65 2172#ifndef PERL_MICRO
ff68c719 2173#ifdef HAS_SIGACTION
2174
abea2c45
HS		 2175#ifdef MACOS_TRADITIONAL
2176/* We don't want restart behavior on MacOS */
2177#undef SA_RESTART
2178#endif
2179
ff68c719 2180Sighandler_t
864dbfa3 2181Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2182{
2183 struct sigaction act, oact;
2184
a10b1e10
JH		 2185#ifdef USE_ITHREADS
2186 /* only "parent" interpreter can diddle signals */
2187 if (PL_curinterp != aTHX)
2188 return SIG_ERR;
2189#endif
2190
ff68c719 2191 act.sa_handler = handler;
2192 sigemptyset(&act.sa_mask);
2193 act.sa_flags = 0;
2194#ifdef SA_RESTART
0dd95eb2 2195#if defined(PERL_OLD_SIGNALS)
ff68c719 2196 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2197#endif
0a8e0eff 2198#endif
85264bed
CS		 2199#ifdef SA_NOCLDWAIT
2200 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2201 act.sa_flags |= SA_NOCLDWAIT;
2202#endif
ff68c719 2203 if (sigaction(signo, &act, &oact) == -1)
36477c24 2204 return SIG_ERR;
ff68c719 2205 else
36477c24 2206 return oact.sa_handler;
ff68c719 2207}
2208
2209Sighandler_t
864dbfa3 2210Perl_rsignal_state(pTHX_ int signo)
ff68c719 2211{
2212 struct sigaction oact;
2213
2214 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3aed30dc 2215 return SIG_ERR;
ff68c719 2216 else
3aed30dc 2217 return oact.sa_handler;
ff68c719 2218}
2219
2220int
864dbfa3 2221Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2222{
2223 struct sigaction act;
2224
a10b1e10
JH		 2225#ifdef USE_ITHREADS
2226 /* only "parent" interpreter can diddle signals */
2227 if (PL_curinterp != aTHX)
2228 return -1;
2229#endif
2230
ff68c719 2231 act.sa_handler = handler;
2232 sigemptyset(&act.sa_mask);
2233 act.sa_flags = 0;
2234#ifdef SA_RESTART
0dd95eb2 2235#if defined(PERL_OLD_SIGNALS)
ff68c719 2236 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2237#endif
0a8e0eff 2238#endif
85264bed
CS		 2239#ifdef SA_NOCLDWAIT
2240 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2241 act.sa_flags |= SA_NOCLDWAIT;
2242#endif
ff68c719 2243 return sigaction(signo, &act, save);
2244}
2245
2246int
864dbfa3 2247Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2248{
a10b1e10
JH		 2249#ifdef USE_ITHREADS
2250 /* only "parent" interpreter can diddle signals */
2251 if (PL_curinterp != aTHX)
2252 return -1;
2253#endif
2254
ff68c719 2255 return sigaction(signo, save, (struct sigaction *)NULL);
2256}
2257
2258#else /* !HAS_SIGACTION */
2259
2260Sighandler_t
864dbfa3 2261Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2262{
39f1703b 2263#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2264 /* only "parent" interpreter can diddle signals */
2265 if (PL_curinterp != aTHX)
2266 return SIG_ERR;
2267#endif
2268
6ad3d225 2269 return PerlProc_signal(signo, handler);
ff68c719 2270}
2271
df3728a2
JH		 2272static int sig_trapped; /* XXX signals are process-wide anyway, so we
2273 ignore the implications of this for threading */
ff68c719 2274
2275static
2276Signal_t
4e35701f 2277sig_trap(int signo)
ff68c719 2278{
2279 sig_trapped++;
2280}
2281
2282Sighandler_t
864dbfa3 2283Perl_rsignal_state(pTHX_ int signo)
ff68c719 2284{
2285 Sighandler_t oldsig;
2286
39f1703b 2287#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2288 /* only "parent" interpreter can diddle signals */
2289 if (PL_curinterp != aTHX)
2290 return SIG_ERR;
2291#endif
2292
ff68c719 2293 sig_trapped = 0;
6ad3d225
GS		 2294 oldsig = PerlProc_signal(signo, sig_trap);
2295 PerlProc_signal(signo, oldsig);
ff68c719 2296 if (sig_trapped)
3aed30dc 2297 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2298 return oldsig;
2299}
2300
2301int
864dbfa3 2302Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2303{
39f1703b 2304#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2305 /* only "parent" interpreter can diddle signals */
2306 if (PL_curinterp != aTHX)
2307 return -1;
2308#endif
6ad3d225 2309 *save = PerlProc_signal(signo, handler);
ff68c719 2310 return (*save == SIG_ERR) ? -1 : 0;
2311}
2312
2313int
864dbfa3 2314Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2315{
39f1703b 2316#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2317 /* only "parent" interpreter can diddle signals */
2318 if (PL_curinterp != aTHX)
2319 return -1;
2320#endif
6ad3d225 2321 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2322}
2323
2324#endif /* !HAS_SIGACTION */
64ca3a65 2325#endif /* !PERL_MICRO */
ff68c719 2326
5f05dabc 2327 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2328#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2329I32
864dbfa3 2330Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2331{
ff68c719 2332 Sigsave_t hstat, istat, qstat;
a687059c 2333 int status;
a0d0e21e 2334 SV **svp;
d8a83dd3
JH		 2335 Pid_t pid;
2336 Pid_t pid2;
03136e13 2337 bool close_failed;
b7953727 2338 int saved_errno = 0;
03136e13
CS		 2339#ifdef VMS
2340 int saved_vaxc_errno;
2341#endif
22fae026
TM		 2342#ifdef WIN32
2343 int saved_win32_errno;
2344#endif
a687059c 2345
4755096e 2346 LOCK_FDPID_MUTEX;
3280af22 2347 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2348 UNLOCK_FDPID_MUTEX;
25d92023 2349 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2350 SvREFCNT_dec(*svp);
3280af22 2351 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2352#ifdef OS2
2353 if (pid == -1) { /* Opened by popen. */
2354 return my_syspclose(ptr);
2355 }
a1d180c4 2356#endif
03136e13
CS		 2357 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2358 saved_errno = errno;
2359#ifdef VMS
2360 saved_vaxc_errno = vaxc$errno;
2361#endif
22fae026
TM		 2362#ifdef WIN32
2363 saved_win32_errno = GetLastError();
2364#endif
03136e13 2365 }
7c0587c8 2366#ifdef UTS
6ad3d225 2367 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2368#endif
64ca3a65 2369#ifndef PERL_MICRO
ff68c719 2370 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2371 rsignal_save(SIGINT, SIG_IGN, &istat);
2372 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2373#endif
748a9306 2374 do {
1d3434b8
GS		 2375 pid2 = wait4pid(pid, &status, 0);
2376 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2377#ifndef PERL_MICRO
ff68c719 2378 rsignal_restore(SIGHUP, &hstat);
2379 rsignal_restore(SIGINT, &istat);
2380 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2381#endif
03136e13
CS		 2382 if (close_failed) {
2383 SETERRNO(saved_errno, saved_vaxc_errno);
2384 return -1;
2385 }
1d3434b8 2386 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2387}
4633a7c4
LW		 2388#endif /* !DOSISH */
2389
2986a63f 2390#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2391I32
d8a83dd3 2392Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2393{
cddd4526 2394 I32 result;
b7953727
JH		 2395 if (!pid)
2396 return -1;
2397#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2398 {
3aed30dc
HS		 2399 SV *sv;
2400 SV** svp;
2401 char spid[TYPE_CHARS(int)];
20188a90 2402
3aed30dc 2403 if (pid > 0) {
7b0972df 2404 sprintf(spid, "%"IVdf, (IV)pid);
3aed30dc
HS		 2405 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2406 if (svp && *svp != &PL_sv_undef) {
2407 *statusp = SvIVX(*svp);
2408 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2409 return pid;
2410 }
2411 }
2412 else {
2413 HE *entry;
2414
2415 hv_iterinit(PL_pidstatus);
2416 if ((entry = hv_iternext(PL_pidstatus))) {
2417 SV *sv;
2418 char spid[TYPE_CHARS(int)];
2419
2420 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2421 sv = hv_iterval(PL_pidstatus,entry);
2422 *statusp = SvIVX(sv);
2423 sprintf(spid, "%"IVdf, (IV)pid);
2424 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2425 return pid;
2426 }
20188a90
LW		 2427 }
2428 }
68a29c53 2429#endif
79072805 2430#ifdef HAS_WAITPID
367f3c24
IZ		 2431# ifdef HAS_WAITPID_RUNTIME
2432 if (!HAS_WAITPID_RUNTIME)
2433 goto hard_way;
2434# endif
cddd4526 2435 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2436 goto finish;
367f3c24
IZ		 2437#endif
2438#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
cddd4526 2439 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
dfcfdb64 2440 goto finish;
367f3c24
IZ		 2441#endif
2442#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2443 hard_way:
a0d0e21e 2444 {
a0d0e21e 2445 if (flags)
cea2e8a9 2446 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2447 else {
76e3520e 2448 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2449 pidgone(result,*statusp);
2450 if (result < 0)
2451 *statusp = -1;
2452 }
a687059c
LW		 2453 }
2454#endif
dfcfdb64 2455 finish:
cddd4526
NIS		 2456 if (result < 0 && errno == EINTR) {
2457 PERL_ASYNC_CHECK();
2458 }
2459 return result;
a687059c 2460}
2986a63f 2461#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2462
7c0587c8 2463void
de3bb511 2464/*SUPPRESS 590*/
d8a83dd3 2465Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2466{
79072805 2467 register SV *sv;
fc36a67e 2468 char spid[TYPE_CHARS(int)];
a687059c 2469
7b0972df 2470 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2471 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2472 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2473 SvIVX(sv) = status;
20188a90 2474 return;
a687059c
LW		 2475}
2476
85ca448a 2477#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2478int pclose();
ddcf38b7
IZ		 2479#ifdef HAS_FORK
2480int /* Cannot prototype with I32
2481 in os2ish.h. */
ba106d47 2482my_syspclose(PerlIO *ptr)
ddcf38b7 2483#else
79072805 2484I32
864dbfa3 2485Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2486#endif
a687059c 2487{
760ac839
LW		 2488 /* Needs work for PerlIO ! */
2489 FILE *f = PerlIO_findFILE(ptr);
2490 I32 result = pclose(f);
2b96b0a5
JH		 2491 PerlIO_releaseFILE(ptr,f);
2492 return result;
2493}
2494#endif
2495
933fea7f 2496#if defined(DJGPP)
2b96b0a5
JH		 2497int djgpp_pclose();
2498I32
2499Perl_my_pclose(pTHX_ PerlIO *ptr)
2500{
2501 /* Needs work for PerlIO ! */
2502 FILE *f = PerlIO_findFILE(ptr);
2503 I32 result = djgpp_pclose(f);
933fea7f 2504 result = (result << 8) & 0xff00;
760ac839
LW		 2505 PerlIO_releaseFILE(ptr,f);
2506 return result;
a687059c 2507}
7c0587c8 2508#endif
9f68db38
LW		 2509
2510void
864dbfa3 2511Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2512{
79072805 2513 register I32 todo;
08105a92 2514 register const char *frombase = from;
9f68db38
LW		 2515
2516 if (len == 1) {
08105a92 2517 register const char c = *from;
9f68db38 2518 while (count-- > 0)
5926133d 2519 *to++ = c;
9f68db38
LW		 2520 return;
2521 }
2522 while (count-- > 0) {
2523 for (todo = len; todo > 0; todo--) {
2524 *to++ = *from++;
2525 }
2526 from = frombase;
2527 }
2528}
0f85fab0 2529
fe14fcc3 2530#ifndef HAS_RENAME
79072805 2531I32
864dbfa3 2532Perl_same_dirent(pTHX_ char *a, char *b)
62b28dd9 2533{
93a17b20
LW		 2534 char *fa = strrchr(a,'/');
2535 char *fb = strrchr(b,'/');
c623ac67
GS		 2536 Stat_t tmpstatbuf1;
2537 Stat_t tmpstatbuf2;
46fc3d4c 2538 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2539
2540 if (fa)
2541 fa++;
2542 else
2543 fa = a;
2544 if (fb)
2545 fb++;
2546 else
2547 fb = b;
2548 if (strNE(a,b))
2549 return FALSE;
2550 if (fa == a)
46fc3d4c 2551 sv_setpv(tmpsv, ".");
62b28dd9 2552 else
46fc3d4c 2553 sv_setpvn(tmpsv, a, fa - a);
c6ed36e1 2554 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2555 return FALSE;
2556 if (fb == b)
46fc3d4c 2557 sv_setpv(tmpsv, ".");
62b28dd9 2558 else
46fc3d4c 2559 sv_setpvn(tmpsv, b, fb - b);
c6ed36e1 2560 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2561 return FALSE;
2562 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2563 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2564}
fe14fcc3
LW		 2565#endif /* !HAS_RENAME */
2566
491527d0 2567char*
864dbfa3 2568Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
491527d0 2569{
491527d0
GS		 2570 char *xfound = Nullch;
2571 char *xfailed = Nullch;
0f31cffe 2572 char tmpbuf[MAXPATHLEN];
491527d0 2573 register char *s;
5f74f29c 2574 I32 len = 0;
491527d0
GS		 2575 int retval;
2576#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2577# define SEARCH_EXTS ".bat", ".cmd", NULL
2578# define MAX_EXT_LEN 4
2579#endif
2580#ifdef OS2
2581# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2582# define MAX_EXT_LEN 4
2583#endif
2584#ifdef VMS
2585# define SEARCH_EXTS ".pl", ".com", NULL
2586# define MAX_EXT_LEN 4
2587#endif
2588 /* additional extensions to try in each dir if scriptname not found */
2589#ifdef SEARCH_EXTS
2590 char *exts[] = { SEARCH_EXTS };
2591 char **ext = search_ext ? search_ext : exts;
2592 int extidx = 0, i = 0;
2593 char *curext = Nullch;
2594#else
2595# define MAX_EXT_LEN 0
2596#endif
2597
2598 /*
2599 * If dosearch is true and if scriptname does not contain path
2600 * delimiters, search the PATH for scriptname.
2601 *
2602 * If SEARCH_EXTS is also defined, will look for each
2603 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2604 * while searching the PATH.
2605 *
2606 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2607 * proceeds as follows:
2608 * If DOSISH or VMSISH:
2609 * + look for ./scriptname{,.foo,.bar}
2610 * + search the PATH for scriptname{,.foo,.bar}
2611 *
2612 * If !DOSISH:
2613 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2614 * this will not look in '.' if it's not in the PATH)
2615 */
84486fc6 2616 tmpbuf[0] = '\0';
491527d0
GS		 2617
2618#ifdef VMS
2619# ifdef ALWAYS_DEFTYPES
2620 len = strlen(scriptname);
2621 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2622 int hasdir, idx = 0, deftypes = 1;
2623 bool seen_dot = 1;
2624
2625 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2626# else
2627 if (dosearch) {
2628 int hasdir, idx = 0, deftypes = 1;
2629 bool seen_dot = 1;
2630
2631 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2632# endif
2633 /* The first time through, just add SEARCH_EXTS to whatever we
2634 * already have, so we can check for default file types. */
2635 while (deftypes ||
84486fc6 2636 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 2637 {
2638 if (deftypes) {
2639 deftypes = 0;
84486fc6 2640 *tmpbuf = '\0';
491527d0 2641 }
84486fc6
GS		 2642 if ((strlen(tmpbuf) + strlen(scriptname)
2643 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 2644 continue; /* don't search dir with too-long name */
84486fc6 2645 strcat(tmpbuf, scriptname);
491527d0
GS		 2646#else /* !VMS */
2647
2648#ifdef DOSISH
2649 if (strEQ(scriptname, "-"))
2650 dosearch = 0;
2651 if (dosearch) { /* Look in '.' first. */
2652 char *cur = scriptname;
2653#ifdef SEARCH_EXTS
2654 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2655 while (ext[i])
2656 if (strEQ(ext[i++],curext)) {
2657 extidx = -1; /* already has an ext */
2658 break;
2659 }
2660 do {
2661#endif
2662 DEBUG_p(PerlIO_printf(Perl_debug_log,
2663 "Looking for %s\n",cur));
017f25f1
IZ		 2664 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2665 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 2666 dosearch = 0;
2667 scriptname = cur;
2668#ifdef SEARCH_EXTS
2669 break;
2670#endif
2671 }
2672#ifdef SEARCH_EXTS
2673 if (cur == scriptname) {
2674 len = strlen(scriptname);
84486fc6 2675 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 2676 break;
84486fc6 2677 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 2678 }
2679 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 2680 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 2681#endif
2682 }
2683#endif
2684
cd39f2b6
JH		 2685#ifdef MACOS_TRADITIONAL
2686 if (dosearch && !strchr(scriptname, ':') &&
2687 (s = PerlEnv_getenv("Commands")))
2688#else
491527d0
GS		 2689 if (dosearch && !strchr(scriptname, '/')
2690#ifdef DOSISH
2691 && !strchr(scriptname, '\\')
2692#endif
cd39f2b6
JH		 2693 && (s = PerlEnv_getenv("PATH")))
2694#endif
2695 {
491527d0 2696 bool seen_dot = 0;
92f0c265 2697
3280af22
NIS		 2698 PL_bufend = s + strlen(s);
2699 while (s < PL_bufend) {
cd39f2b6
JH		 2700#ifdef MACOS_TRADITIONAL
2701 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2702 ',',
2703 &len);
2704#else
491527d0
GS		 2705#if defined(atarist) || defined(DOSISH)
2706 for (len = 0; *s
2707# ifdef atarist
2708 && *s != ','
2709# endif
2710 && *s != ';'; len++, s++) {
84486fc6
GS		 2711 if (len < sizeof tmpbuf)
2712 tmpbuf[len] = *s;
491527d0 2713 }
84486fc6
GS		 2714 if (len < sizeof tmpbuf)
2715 tmpbuf[len] = '\0';
491527d0 2716#else /* ! (atarist || DOSISH) */
3280af22 2717 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 2718 ':',
2719 &len);
2720#endif /* ! (atarist || DOSISH) */
cd39f2b6 2721#endif /* MACOS_TRADITIONAL */
3280af22 2722 if (s < PL_bufend)
491527d0 2723 s++;
84486fc6 2724 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 2725 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 2726#ifdef MACOS_TRADITIONAL
2727 if (len && tmpbuf[len - 1] != ':')
2728 tmpbuf[len++] = ':';
2729#else
491527d0 2730 if (len
61ae2fbf 2731#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 2732 && tmpbuf[len - 1] != '/'
2733 && tmpbuf[len - 1] != '\\'
491527d0
GS		 2734#endif
2735 )
84486fc6
GS		 2736 tmpbuf[len++] = '/';
2737 if (len == 2 && tmpbuf[0] == '.')
491527d0 2738 seen_dot = 1;
cd39f2b6 2739#endif
84486fc6 2740 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 2741#endif /* !VMS */
2742
2743#ifdef SEARCH_EXTS
84486fc6 2744 len = strlen(tmpbuf);
491527d0
GS		 2745 if (extidx > 0) /* reset after previous loop */
2746 extidx = 0;
2747 do {
2748#endif
84486fc6 2749 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 2750 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 2751 if (S_ISDIR(PL_statbuf.st_mode)) {
2752 retval = -1;
2753 }
491527d0
GS		 2754#ifdef SEARCH_EXTS
2755 } while ( retval < 0 /* not there */
2756 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 2757 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 2758 );
2759#endif
2760 if (retval < 0)
2761 continue;
3280af22
NIS		 2762 if (S_ISREG(PL_statbuf.st_mode)
2763 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 2764#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 2765 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 2766#endif
2767 )
2768 {
3aed30dc 2769 xfound = tmpbuf; /* bingo! */
491527d0
GS		 2770 break;
2771 }
2772 if (!xfailed)
84486fc6 2773 xfailed = savepv(tmpbuf);
491527d0
GS		 2774 }
2775#ifndef DOSISH
017f25f1 2776 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 2777 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 2778 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 2779#endif
2780 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 2781 if (!xfound) {
2782 if (flags & 1) { /* do or die? */
3aed30dc 2783 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 2784 (xfailed ? "execute" : "find"),
2785 (xfailed ? xfailed : scriptname),
2786 (xfailed ? "" : " on PATH"),
2787 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2788 }
2789 scriptname = Nullch;
2790 }
491527d0
GS		 2791 if (xfailed)
2792 Safefree(xfailed);
2793 scriptname = xfound;
2794 }
9ccb31f9 2795 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 2796}
2797
ba869deb
GS		 2798#ifndef PERL_GET_CONTEXT_DEFINED
2799
2800void *
2801Perl_get_context(void)
2802{
3db8f154 2803#if defined(USE_ITHREADS)
ba869deb
GS		 2804# ifdef OLD_PTHREADS_API
2805 pthread_addr_t t;
2806 if (pthread_getspecific(PL_thr_key, &t))
2807 Perl_croak_nocontext("panic: pthread_getspecific");
2808 return (void*)t;
2809# else
bce813aa 2810# ifdef I_MACH_CTHREADS
8b8b35ab 2811 return (void*)cthread_data(cthread_self());
bce813aa 2812# else
8b8b35ab
JH		 2813 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2814# endif
c44d3fdb 2815# endif
ba869deb
GS		 2816#else
2817 return (void*)NULL;
2818#endif
2819}
2820
2821void
2822Perl_set_context(void *t)
2823{
3db8f154 2824#if defined(USE_ITHREADS)
c44d3fdb
GS		 2825# ifdef I_MACH_CTHREADS
2826 cthread_set_data(cthread_self(), t);
2827# else
ba869deb
GS		 2828 if (pthread_setspecific(PL_thr_key, t))
2829 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 2830# endif
ba869deb
GS		 2831#endif
2832}
2833
2834#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 2835
22239a37
NIS		 2836#ifdef PERL_GLOBAL_STRUCT
2837struct perl_vars *
864dbfa3 2838Perl_GetVars(pTHX)
22239a37 2839{
533c011a 2840 return &PL_Vars;
22239a37 2841}
31fb1209
NIS		 2842#endif
2843
2844char **
864dbfa3 2845Perl_get_op_names(pTHX)
31fb1209 2846{
22c35a8c 2847 return PL_op_name;
31fb1209
NIS		 2848}
2849
2850char **
864dbfa3 2851Perl_get_op_descs(pTHX)
31fb1209 2852{
22c35a8c 2853 return PL_op_desc;
31fb1209 2854}
9e6b2b00
GS		 2855
2856char *
864dbfa3 2857Perl_get_no_modify(pTHX)
9e6b2b00 2858{
22c35a8c 2859 return (char*)PL_no_modify;
9e6b2b00
GS		 2860}
2861
2862U32 *
864dbfa3 2863Perl_get_opargs(pTHX)
9e6b2b00 2864{
22c35a8c 2865 return PL_opargs;
9e6b2b00 2866}
51aa15f3 2867
0cb96387
GS		 2868PPADDR_t*
2869Perl_get_ppaddr(pTHX)
2870{
12ae5dfc 2871 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 2872}
2873
a6c40364
GS		 2874#ifndef HAS_GETENV_LEN
2875char *
bf4acbe4 2876Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364
GS		 2877{
2878 char *env_trans = PerlEnv_getenv(env_elem);
2879 if (env_trans)
2880 *len = strlen(env_trans);
2881 return env_trans;
f675dbe5
CB		 2882}
2883#endif
2884
dc9e4912
GS		 2885
2886MGVTBL*
864dbfa3 2887Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912
GS		 2888{
2889 MGVTBL* result = Null(MGVTBL*);
2890
2891 switch(vtbl_id) {
2892 case want_vtbl_sv:
2893 result = &PL_vtbl_sv;
2894 break;
2895 case want_vtbl_env:
2896 result = &PL_vtbl_env;
2897 break;
2898 case want_vtbl_envelem:
2899 result = &PL_vtbl_envelem;
2900 break;
2901 case want_vtbl_sig:
2902 result = &PL_vtbl_sig;
2903 break;
2904 case want_vtbl_sigelem:
2905 result = &PL_vtbl_sigelem;
2906 break;
2907 case want_vtbl_pack:
2908 result = &PL_vtbl_pack;
2909 break;
2910 case want_vtbl_packelem:
2911 result = &PL_vtbl_packelem;
2912 break;
2913 case want_vtbl_dbline:
2914 result = &PL_vtbl_dbline;
2915 break;
2916 case want_vtbl_isa:
2917 result = &PL_vtbl_isa;
2918 break;
2919 case want_vtbl_isaelem:
2920 result = &PL_vtbl_isaelem;
2921 break;
2922 case want_vtbl_arylen:
2923 result = &PL_vtbl_arylen;
2924 break;
2925 case want_vtbl_glob:
2926 result = &PL_vtbl_glob;
2927 break;
2928 case want_vtbl_mglob:
2929 result = &PL_vtbl_mglob;
2930 break;
2931 case want_vtbl_nkeys:
2932 result = &PL_vtbl_nkeys;
2933 break;
2934 case want_vtbl_taint:
2935 result = &PL_vtbl_taint;
2936 break;
2937 case want_vtbl_substr:
2938 result = &PL_vtbl_substr;
2939 break;
2940 case want_vtbl_vec:
2941 result = &PL_vtbl_vec;
2942 break;
2943 case want_vtbl_pos:
2944 result = &PL_vtbl_pos;
2945 break;
2946 case want_vtbl_bm:
2947 result = &PL_vtbl_bm;
2948 break;
2949 case want_vtbl_fm:
2950 result = &PL_vtbl_fm;
2951 break;
2952 case want_vtbl_uvar:
2953 result = &PL_vtbl_uvar;
2954 break;
dc9e4912
GS		 2955 case want_vtbl_defelem:
2956 result = &PL_vtbl_defelem;
2957 break;
2958 case want_vtbl_regexp:
2959 result = &PL_vtbl_regexp;
2960 break;
2961 case want_vtbl_regdata:
2962 result = &PL_vtbl_regdata;
2963 break;
2964 case want_vtbl_regdatum:
2965 result = &PL_vtbl_regdatum;
2966 break;
3c90161d 2967#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 2968 case want_vtbl_collxfrm:
2969 result = &PL_vtbl_collxfrm;
2970 break;
3c90161d 2971#endif
dc9e4912
GS		 2972 case want_vtbl_amagic:
2973 result = &PL_vtbl_amagic;
2974 break;
2975 case want_vtbl_amagicelem:
2976 result = &PL_vtbl_amagicelem;
2977 break;
810b8aa5
GS		 2978 case want_vtbl_backref:
2979 result = &PL_vtbl_backref;
2980 break;
dc9e4912
GS		 2981 }
2982 return result;
2983}
2984
767df6a1 2985I32
864dbfa3 2986Perl_my_fflush_all(pTHX)
767df6a1 2987{
f800e14d 2988#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 2989 return PerlIO_flush(NULL);
767df6a1 2990#else
8fbdfb7c 2991# if defined(HAS__FWALK)
f13a2bc0 2992 extern int fflush(FILE *);
74cac757
JH		 2993 /* undocumented, unprototyped, but very useful BSDism */
2994 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 2995 _fwalk(&fflush);
74cac757 2996 return 0;
8fa7f367 2997# else
8fbdfb7c 2998# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 2999 long open_max = -1;
8fbdfb7c 3000# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3001 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3002# else
8fa7f367 3003# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3004 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3005# else
3006# ifdef FOPEN_MAX
74cac757 3007 open_max = FOPEN_MAX;
8fa7f367
JH		 3008# else
3009# ifdef OPEN_MAX
74cac757 3010 open_max = OPEN_MAX;
8fa7f367
JH		 3011# else
3012# ifdef _NFILE
d2201af2 3013 open_max = _NFILE;
8fa7f367
JH		 3014# endif
3015# endif
74cac757 3016# endif
767df6a1
JH		 3017# endif
3018# endif
767df6a1
JH		 3019 if (open_max > 0) {
3020 long i;
3021 for (i = 0; i < open_max; i++)
d2201af2
AD		 3022 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3023 STDIO_STREAM_ARRAY[i]._file < open_max &&
3024 STDIO_STREAM_ARRAY[i]._flag)
3025 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3026 return 0;
3027 }
8fbdfb7c 3028# endif
93189314 3029 SETERRNO(EBADF,RMS_IFI);
767df6a1 3030 return EOF;
74cac757 3031# endif
767df6a1
JH		 3032#endif
3033}
097ee67d 3034
69282e91 3035void
bc37a18f
RG		 3036Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3037{
bc37a18f 3038 char *func =
66fc2fa5
JH		 3039 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3040 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
bc37a18f
RG		 3041 PL_op_desc[op];
3042 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3aed30dc
HS		 3043 char *type = OP_IS_SOCKET(op)
3044 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3045 ? "socket" : "filehandle";
9c0fcd4f 3046 char *name = NULL;
bc37a18f 3047
66fc2fa5 3048 if (gv && isGV(gv)) {
f62cb720 3049 name = GvENAME(gv);
66fc2fa5
JH		 3050 }
3051
4c80c0b2 3052 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3053 if (ckWARN(WARN_IO)) {
fd322ea4 3054 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3aed30dc
HS		 3055 if (name && *name)
3056 Perl_warner(aTHX_ packWARN(WARN_IO),
3057 "Filehandle %s opened only for %sput",
fd322ea4 3058 name, direction);
3aed30dc
HS		 3059 else
3060 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3061 "Filehandle opened only for %sput", direction);
3aed30dc 3062 }
2dd78f96
JH		 3063 }
3064 else {
3aed30dc
HS		 3065 char *vile;
3066 I32 warn_type;
3067
3068 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3069 vile = "closed";
3070 warn_type = WARN_CLOSED;
3071 }
3072 else {
3073 vile = "unopened";
3074 warn_type = WARN_UNOPENED;
3075 }
3076
3077 if (ckWARN(warn_type)) {
3078 if (name && *name) {
3079 Perl_warner(aTHX_ packWARN(warn_type),
3080 "%s%s on %s %s %s", func, pars, vile, type, name);
3081 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3082 Perl_warner(
3083 aTHX_ packWARN(warn_type),
3084 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3085 func, pars, name
3086 );
3087 }
3088 else {
3089 Perl_warner(aTHX_ packWARN(warn_type),
3090 "%s%s on %s %s", func, pars, vile, type);
3091 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3092 Perl_warner(
3093 aTHX_ packWARN(warn_type),
3094 "\t(Are you trying to call %s%s on dirhandle?)\n",
3095 func, pars
3096 );
3097 }
3098 }
bc37a18f 3099 }
69282e91 3100}
a926ef6b
JH		 3101
3102#ifdef EBCDIC
cbebf344
JH		 3103/* in ASCII order, not that it matters */
3104static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3105
a926ef6b
JH		 3106int
3107Perl_ebcdic_control(pTHX_ int ch)
3108{
3aed30dc
HS		 3109 if (ch > 'a') {
3110 char *ctlp;
3111
3112 if (islower(ch))
3113 ch = toupper(ch);
3114
3115 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3116 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3117 }
3aed30dc
HS		 3118
3119 if (ctlp == controllablechars)
3120 return('\177'); /* DEL */
3121 else
3122 return((unsigned char)(ctlp - controllablechars - 1));
3123 } else { /* Want uncontrol */
3124 if (ch == '\177' || ch == -1)
3125 return('?');
3126 else if (ch == '\157')
3127 return('\177');
3128 else if (ch == '\174')
3129 return('\000');
3130 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3131 return('\036');
3132 else if (ch == '\155')
3133 return('\037');
3134 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3135 return(controllablechars[ch+1]);
3136 else
3137 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3138 }
a926ef6b
JH		 3139}
3140#endif
e72cf795 3141
f6adc668 3142/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3143 * system to give us a reasonable struct to copy. This fix means that
3144 * strftime uses the tm_zone and tm_gmtoff values returned by
3145 * localtime(time()). That should give the desired result most of the
3146 * time. But probably not always!
3147 *
f6adc668
JH		 3148 * This does not address tzname aspects of NETaa14816.
3149 *
e72cf795 3150 */
f6adc668 3151
e72cf795
JH		 3152#ifdef HAS_GNULIBC
3153# ifndef STRUCT_TM_HASZONE
3154# define STRUCT_TM_HASZONE
3155# endif
3156#endif
3157
f6adc668
JH		 3158#ifdef STRUCT_TM_HASZONE /* Backward compat */
3159# ifndef HAS_TM_TM_ZONE
3160# define HAS_TM_TM_ZONE
3161# endif
3162#endif
3163
e72cf795 3164void
f1208910 3165Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3166{
f6adc668 3167#ifdef HAS_TM_TM_ZONE
e72cf795
JH		 3168 Time_t now;
3169 (void)time(&now);
3170 Copy(localtime(&now), ptm, 1, struct tm);
3171#endif
3172}
3173
3174/*
3175 * mini_mktime - normalise struct tm values without the localtime()
3176 * semantics (and overhead) of mktime().
3177 */
3178void
f1208910 3179Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3180{
3181 int yearday;
3182 int secs;
3183 int month, mday, year, jday;
3184 int odd_cent, odd_year;
3185
3186#define DAYS_PER_YEAR 365
3187#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3188#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3189#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3190#define SECS_PER_HOUR (60*60)
3191#define SECS_PER_DAY (24*SECS_PER_HOUR)
3192/* parentheses deliberately absent on these two, otherwise they don't work */
3193#define MONTH_TO_DAYS 153/5
3194#define DAYS_TO_MONTH 5/153
3195/* offset to bias by March (month 4) 1st between month/mday & year finding */
3196#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3197/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3198#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3199
3200/*
3201 * Year/day algorithm notes:
3202 *
3203 * With a suitable offset for numeric value of the month, one can find
3204 * an offset into the year by considering months to have 30.6 (153/5) days,
3205 * using integer arithmetic (i.e., with truncation). To avoid too much
3206 * messing about with leap days, we consider January and February to be
3207 * the 13th and 14th month of the previous year. After that transformation,
3208 * we need the month index we use to be high by 1 from 'normal human' usage,
3209 * so the month index values we use run from 4 through 15.
3210 *
3211 * Given that, and the rules for the Gregorian calendar (leap years are those
3212 * divisible by 4 unless also divisible by 100, when they must be divisible
3213 * by 400 instead), we can simply calculate the number of days since some
3214 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3215 * the days we derive from our month index, and adding in the day of the
3216 * month. The value used here is not adjusted for the actual origin which
3217 * it normally would use (1 January A.D. 1), since we're not exposing it.
3218 * We're only building the value so we can turn around and get the
3219 * normalised values for the year, month, day-of-month, and day-of-year.
3220 *
3221 * For going backward, we need to bias the value we're using so that we find
3222 * the right year value. (Basically, we don't want the contribution of
3223 * March 1st to the number to apply while deriving the year). Having done
3224 * that, we 'count up' the contribution to the year number by accounting for
3225 * full quadracenturies (400-year periods) with their extra leap days, plus
3226 * the contribution from full centuries (to avoid counting in the lost leap
3227 * days), plus the contribution from full quad-years (to count in the normal
3228 * leap days), plus the leftover contribution from any non-leap years.
3229 * At this point, if we were working with an actual leap day, we'll have 0
3230 * days left over. This is also true for March 1st, however. So, we have
3231 * to special-case that result, and (earlier) keep track of the 'odd'
3232 * century and year contributions. If we got 4 extra centuries in a qcent,
3233 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3234 * Otherwise, we add back in the earlier bias we removed (the 123 from
3235 * figuring in March 1st), find the month index (integer division by 30.6),
3236 * and the remainder is the day-of-month. We then have to convert back to
3237 * 'real' months (including fixing January and February from being 14/15 in
3238 * the previous year to being in the proper year). After that, to get
3239 * tm_yday, we work with the normalised year and get a new yearday value for
3240 * January 1st, which we subtract from the yearday value we had earlier,
3241 * representing the date we've re-built. This is done from January 1
3242 * because tm_yday is 0-origin.
3243 *
3244 * Since POSIX time routines are only guaranteed to work for times since the
3245 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3246 * applies Gregorian calendar rules even to dates before the 16th century
3247 * doesn't bother me. Besides, you'd need cultural context for a given
3248 * date to know whether it was Julian or Gregorian calendar, and that's
3249 * outside the scope for this routine. Since we convert back based on the
3250 * same rules we used to build the yearday, you'll only get strange results
3251 * for input which needed normalising, or for the 'odd' century years which
3252 * were leap years in the Julian calander but not in the Gregorian one.
3253 * I can live with that.
3254 *
3255 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3256 * that's still outside the scope for POSIX time manipulation, so I don't
3257 * care.
3258 */
3259
3260 year = 1900 + ptm->tm_year;
3261 month = ptm->tm_mon;
3262 mday = ptm->tm_mday;
3263 /* allow given yday with no month & mday to dominate the result */
3264 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3265 month = 0;
3266 mday = 0;
3267 jday = 1 + ptm->tm_yday;
3268 }
3269 else {
3270 jday = 0;
3271 }
3272 if (month >= 2)
3273 month+=2;
3274 else
3275 month+=14, year--;
3276 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3277 yearday += month*MONTH_TO_DAYS + mday + jday;
3278 /*
3279 * Note that we don't know when leap-seconds were or will be,
3280 * so we have to trust the user if we get something which looks
3281 * like a sensible leap-second. Wild values for seconds will
3282 * be rationalised, however.
3283 */
3284 if ((unsigned) ptm->tm_sec <= 60) {
3285 secs = 0;
3286 }
3287 else {
3288 secs = ptm->tm_sec;
3289 ptm->tm_sec = 0;
3290 }
3291 secs += 60 * ptm->tm_min;
3292 secs += SECS_PER_HOUR * ptm->tm_hour;
3293 if (secs < 0) {
3294 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3295 /* got negative remainder, but need positive time */
3296 /* back off an extra day to compensate */
3297 yearday += (secs/SECS_PER_DAY)-1;
3298 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3299 }
3300 else {
3301 yearday += (secs/SECS_PER_DAY);
3302 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3303 }
3304 }
3305 else if (secs >= SECS_PER_DAY) {
3306 yearday += (secs/SECS_PER_DAY);
3307 secs %= SECS_PER_DAY;
3308 }
3309 ptm->tm_hour = secs/SECS_PER_HOUR;
3310 secs %= SECS_PER_HOUR;
3311 ptm->tm_min = secs/60;
3312 secs %= 60;
3313 ptm->tm_sec += secs;
3314 /* done with time of day effects */
3315 /*
3316 * The algorithm for yearday has (so far) left it high by 428.
3317 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3318 * bias it by 123 while trying to figure out what year it
3319 * really represents. Even with this tweak, the reverse
3320 * translation fails for years before A.D. 0001.
3321 * It would still fail for Feb 29, but we catch that one below.
3322 */
3323 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3324 yearday -= YEAR_ADJUST;
3325 year = (yearday / DAYS_PER_QCENT) * 400;
3326 yearday %= DAYS_PER_QCENT;
3327 odd_cent = yearday / DAYS_PER_CENT;
3328 year += odd_cent * 100;
3329 yearday %= DAYS_PER_CENT;
3330 year += (yearday / DAYS_PER_QYEAR) * 4;
3331 yearday %= DAYS_PER_QYEAR;
3332 odd_year = yearday / DAYS_PER_YEAR;
3333 year += odd_year;
3334 yearday %= DAYS_PER_YEAR;
3335 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3336 month = 1;
3337 yearday = 29;
3338 }
3339 else {
3340 yearday += YEAR_ADJUST; /* recover March 1st crock */
3341 month = yearday*DAYS_TO_MONTH;
3342 yearday -= month*MONTH_TO_DAYS;
3343 /* recover other leap-year adjustment */
3344 if (month > 13) {
3345 month-=14;
3346 year++;
3347 }
3348 else {
3349 month-=2;
3350 }
3351 }
3352 ptm->tm_year = year - 1900;
3353 if (yearday) {
3354 ptm->tm_mday = yearday;
3355 ptm->tm_mon = month;
3356 }
3357 else {
3358 ptm->tm_mday = 31;
3359 ptm->tm_mon = month - 1;
3360 }
3361 /* re-build yearday based on Jan 1 to get tm_yday */
3362 year--;
3363 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3364 yearday += 14*MONTH_TO_DAYS + 1;
3365 ptm->tm_yday = jday - yearday;
3366 /* fix tm_wday if not overridden by caller */
3367 if ((unsigned)ptm->tm_wday > 6)
3368 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3369}
b3c85772
JH		 3370
3371char *
f1208910 3372Perl_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		 3373{
3374#ifdef HAS_STRFTIME
3375 char *buf;
3376 int buflen;
3377 struct tm mytm;
3378 int len;
3379
3380 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3381 mytm.tm_sec = sec;
3382 mytm.tm_min = min;
3383 mytm.tm_hour = hour;
3384 mytm.tm_mday = mday;
3385 mytm.tm_mon = mon;
3386 mytm.tm_year = year;
3387 mytm.tm_wday = wday;
3388 mytm.tm_yday = yday;
3389 mytm.tm_isdst = isdst;
3390 mini_mktime(&mytm);
c473feec
SR		 3391 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3392#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3393 STMT_START {
3394 struct tm mytm2;
3395 mytm2 = mytm;
3396 mktime(&mytm2);
3397#ifdef HAS_TM_TM_GMTOFF
3398 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3399#endif
3400#ifdef HAS_TM_TM_ZONE
3401 mytm.tm_zone = mytm2.tm_zone;
3402#endif
3403 } STMT_END;
3404#endif
b3c85772
JH		 3405 buflen = 64;
3406 New(0, buf, buflen, char);
3407 len = strftime(buf, buflen, fmt, &mytm);
3408 /*
877f6a72 3409 ** The following is needed to handle to the situation where
b3c85772
JH		 3410 ** tmpbuf overflows. Basically we want to allocate a buffer
3411 ** and try repeatedly. The reason why it is so complicated
3412 ** is that getting a return value of 0 from strftime can indicate
3413 ** one of the following:
3414 ** 1. buffer overflowed,
3415 ** 2. illegal conversion specifier, or
3416 ** 3. the format string specifies nothing to be returned(not
3417 ** an error). This could be because format is an empty string
3418 ** or it specifies %p that yields an empty string in some locale.
3419 ** If there is a better way to make it portable, go ahead by
3420 ** all means.
3421 */
3422 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3423 return buf;
3424 else {
3425 /* Possibly buf overflowed - try again with a bigger buf */
3426 int fmtlen = strlen(fmt);
3427 int bufsize = fmtlen + buflen;
877f6a72 3428
b3c85772
JH		 3429 New(0, buf, bufsize, char);
3430 while (buf) {
3431 buflen = strftime(buf, bufsize, fmt, &mytm);
3432 if (buflen > 0 && buflen < bufsize)
3433 break;
3434 /* heuristic to prevent out-of-memory errors */
3435 if (bufsize > 100*fmtlen) {
3436 Safefree(buf);
3437 buf = NULL;
3438 break;
3439 }
3440 bufsize *= 2;
3441 Renew(buf, bufsize, char);
3442 }
3443 return buf;
3444 }
3445#else
3446 Perl_croak(aTHX_ "panic: no strftime");
3447#endif
3448}
3449
877f6a72
NIS		 3450
3451#define SV_CWD_RETURN_UNDEF \
3452sv_setsv(sv, &PL_sv_undef); \
3453return FALSE
3454
3455#define SV_CWD_ISDOT(dp) \
3456 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3457 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3458
3459/*
ccfc67b7
JH		 3460=head1 Miscellaneous Functions
3461
89423764 3462=for apidoc getcwd_sv
877f6a72
NIS		 3463
3464Fill the sv with current working directory
3465
3466=cut
3467*/
3468
3469/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3470 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3471 * getcwd(3) if available
3472 * Comments from the orignal:
3473 * This is a faster version of getcwd. It's also more dangerous
3474 * because you might chdir out of a directory that you can't chdir
3475 * back into. */
3476
877f6a72 3477int
89423764 3478Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3479{
3480#ifndef PERL_MICRO
3481
ea715489
JH		 3482#ifndef INCOMPLETE_TAINTS
3483 SvTAINTED_on(sv);
3484#endif
3485
8f95b30d
JH		 3486#ifdef HAS_GETCWD
3487 {
60e110a8
DM		 3488 char buf[MAXPATHLEN];
3489
3aed30dc 3490 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3491 * size from the heap if they are given a NULL buffer pointer.
3492 * The problem is that this behaviour is not portable. */
3aed30dc
HS		 3493 if (getcwd(buf, sizeof(buf) - 1)) {
3494 STRLEN len = strlen(buf);
3495 sv_setpvn(sv, buf, len);
3496 return TRUE;
3497 }
3498 else {
3499 sv_setsv(sv, &PL_sv_undef);
3500 return FALSE;
3501 }
8f95b30d
JH		 3502 }
3503
3504#else
3505
c623ac67 3506 Stat_t statbuf;
877f6a72
NIS		 3507 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3508 int namelen, pathlen=0;
3509 DIR *dir;
3510 Direntry_t *dp;
877f6a72
NIS		 3511
3512 (void)SvUPGRADE(sv, SVt_PV);
3513
877f6a72 3514 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3515 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3516 }
3517
3518 orig_cdev = statbuf.st_dev;
3519 orig_cino = statbuf.st_ino;
3520 cdev = orig_cdev;
3521 cino = orig_cino;
3522
3523 for (;;) {
3aed30dc
HS		 3524 odev = cdev;
3525 oino = cino;
3526
3527 if (PerlDir_chdir("..") < 0) {
3528 SV_CWD_RETURN_UNDEF;
3529 }
3530 if (PerlLIO_stat(".", &statbuf) < 0) {
3531 SV_CWD_RETURN_UNDEF;
3532 }
3533
3534 cdev = statbuf.st_dev;
3535 cino = statbuf.st_ino;
3536
3537 if (odev == cdev && oino == cino) {
3538 break;
3539 }
3540 if (!(dir = PerlDir_open("."))) {
3541 SV_CWD_RETURN_UNDEF;
3542 }
3543
3544 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3545#ifdef DIRNAMLEN
3aed30dc 3546 namelen = dp->d_namlen;
877f6a72 3547#else
3aed30dc 3548 namelen = strlen(dp->d_name);
877f6a72 3549#endif
3aed30dc
HS		 3550 /* skip . and .. */
3551 if (SV_CWD_ISDOT(dp)) {
3552 continue;
3553 }
3554
3555 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3556 SV_CWD_RETURN_UNDEF;
3557 }
3558
3559 tdev = statbuf.st_dev;
3560 tino = statbuf.st_ino;
3561 if (tino == oino && tdev == odev) {
3562 break;
3563 }
cb5953d6
JH		 3564 }
3565
3aed30dc
HS		 3566 if (!dp) {
3567 SV_CWD_RETURN_UNDEF;
3568 }
3569
3570 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3571 SV_CWD_RETURN_UNDEF;
3572 }
877f6a72 3573
3aed30dc
HS		 3574 SvGROW(sv, pathlen + namelen + 1);
3575
3576 if (pathlen) {
3577 /* shift down */
3578 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3579 }
877f6a72 3580
3aed30dc
HS		 3581 /* prepend current directory to the front */
3582 *SvPVX(sv) = '/';
3583 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3584 pathlen += (namelen + 1);
877f6a72
NIS		 3585
3586#ifdef VOID_CLOSEDIR
3aed30dc 3587 PerlDir_close(dir);
877f6a72 3588#else
3aed30dc
HS		 3589 if (PerlDir_close(dir) < 0) {
3590 SV_CWD_RETURN_UNDEF;
3591 }
877f6a72
NIS		 3592#endif
3593 }
3594
60e110a8 3595 if (pathlen) {
3aed30dc
HS		 3596 SvCUR_set(sv, pathlen);
3597 *SvEND(sv) = '\0';
3598 SvPOK_only(sv);
877f6a72 3599
2a45baea 3600 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3aed30dc
HS		 3601 SV_CWD_RETURN_UNDEF;
3602 }
877f6a72
NIS		 3603 }
3604 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 3605 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3606 }
3607
3608 cdev = statbuf.st_dev;
3609 cino = statbuf.st_ino;
3610
3611 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 3612 Perl_croak(aTHX_ "Unstable directory path, "
3613 "current directory changed unexpectedly");
877f6a72 3614 }
877f6a72
NIS		 3615
3616 return TRUE;
793b8d8e
JH		 3617#endif
3618
877f6a72
NIS		 3619#else
3620 return FALSE;
3621#endif
3622}
3623
f4758303 3624/*
ccfc67b7
JH		 3625=head1 SV Manipulation Functions
3626
b0f01acb 3627=for apidoc scan_vstring
f4758303
JP		 3628
3629Returns a pointer to the next character after the parsed
3630vstring, as well as updating the passed in sv.
7207e29d 3631
cddd4526 3632Function must be called like
7207e29d 3633
b0f01acb
JP		 3634 sv = NEWSV(92,5);
3635 s = scan_vstring(s,sv);
f4758303 3636
b0f01acb
JP		 3637The sv should already be large enough to store the vstring
3638passed in, for performance reasons.
f4758303
JP		 3639
3640=cut
3641*/
3642
3643char *
b0f01acb 3644Perl_scan_vstring(pTHX_ char *s, SV *sv)
f4758303
JP		 3645{
3646 char *pos = s;
439cb1c4 3647 char *start = s;
f4758303
JP		 3648 if (*pos == 'v') pos++; /* get past 'v' */
3649 while (isDIGIT(*pos) || *pos == '_')
3650 pos++;
3651 if (!isALPHA(*pos)) {
3652 UV rev;
3653 U8 tmpbuf[UTF8_MAXLEN+1];
3654 U8 *tmpend;
3655
3656 if (*s == 'v') s++; /* get past 'v' */
3657
3658 sv_setpvn(sv, "", 0);
3659
3660 for (;;) {
3661 rev = 0;
3662 {
92f0c265
JP		 3663 /* this is atoi() that tolerates underscores */
3664 char *end = pos;
3665 UV mult = 1;
3666 while (--end >= s) {
3667 UV orev;
3668 if (*end == '_')
3669 continue;
3670 orev = rev;
3671 rev += (*end - '0') * mult;
3672 mult *= 10;
3673 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
3674 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
3675 "Integer overflow in decimal number");
3676 }
f4758303 3677 }
979699d9
JH		 3678#ifdef EBCDIC
3679 if (rev > 0x7FFFFFFF)
3680 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
3681#endif
f4758303
JP		 3682 /* Append native character for the rev point */
3683 tmpend = uvchr_to_utf8(tmpbuf, rev);
3684 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
3685 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
979699d9 3686 SvUTF8_on(sv);
92f0c265 3687 if (*pos == '.' && isDIGIT(pos[1]))
979699d9 3688 s = ++pos;
f4758303 3689 else {
979699d9
JH		 3690 s = pos;
3691 break;
f4758303 3692 }
92f0c265 3693 while (isDIGIT(*pos) || *pos == '_')
979699d9 3694 pos++;
f4758303
JP		 3695 }
3696 SvPOK_on(sv);
ece467f9 3697 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
439cb1c4 3698 SvRMAGICAL_on(sv);
f4758303
JP		 3699 }
3700 return s;
3701}
3702
b0f01acb
JP		 3703/*
3704=for apidoc scan_version
3705
3706Returns a pointer to the next character after the parsed
3707version string, as well as upgrading the passed in SV to
3708an RV.
3709
3710Function must be called with an already existing SV like
3711
3712 sv = NEWSV(92,0);
3713 s = scan_version(s,sv);
3714
3715Performs some preprocessing to the string to ensure that
3716it has the correct characteristics of a version. Flags the
3717object if it contains an underscore (which denotes this
3718is a beta version).
3719
3720=cut
3721*/
3722
3723char *
ad63d80f 3724Perl_scan_version(pTHX_ char *s, SV *rv)
b0f01acb 3725{
e568f1a0 3726 const char *start = s;
ad63d80f
JP		 3727 char *pos = s;
3728 I32 saw_period = 0;
3729 bool saw_under = 0;
be2ebcad 3730 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
ad63d80f
JP		 3731 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3732
3733 /* pre-scan the imput string to check for decimals */
3734 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3735 {
3736 if ( *pos == '.' )
3737 {
3738 if ( saw_under )
5f89c282 3739 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 3740 saw_period++ ;
46314c13 3741 }
ad63d80f
JP		 3742 else if ( *pos == '_' )
3743 {
3744 if ( saw_under )
5f89c282 3745 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
ad63d80f
JP		 3746 saw_under = 1;
3747 }
3748 pos++;
3749 }
3750 pos = s;
3751
3752 if (*pos == 'v') pos++; /* get past 'v' */
3753 while (isDIGIT(*pos))
46314c13 3754 pos++;
ad63d80f
JP		 3755 if (!isALPHA(*pos)) {
3756 I32 rev;
3757
3758 if (*s == 'v') s++; /* get past 'v' */
3759
3760 for (;;) {
3761 rev = 0;
3762 {
3763 /* this is atoi() that delimits on underscores */
3764 char *end = pos;
3765 I32 mult = 1;
e568f1a0 3766 if ( s < pos && s > start && *(s-1) == '_' ) {
ad63d80f
JP		 3767 if ( *s == '0' && *(s+1) != '0')
3768 mult = 10; /* perl-style */
3769 else
3770 mult = -1; /* beta version */
3771 }
3772 while (--end >= s) {
ad63d80f
JP		 3773 I32 orev;
3774 orev = rev;
3775 rev += (*end - '0') * mult;
3776 mult *= 10;
3777 if ( abs(orev) > abs(rev) )
5f89c282 3778 Perl_croak(aTHX_ "Integer overflow in version");
ad63d80f 3779 }
b0f01acb 3780 }
ad63d80f
JP		 3781
3782 /* Append revision */
3783 av_push((AV *)sv, newSViv(rev));
3784 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3785 s = ++pos;
3786 else if ( isDIGIT(*pos) )
3787 s = pos;
b0f01acb 3788 else {
ad63d80f
JP		 3789 s = pos;
3790 break;
3791 }
3792 while ( isDIGIT(*pos) ) {
46314c13 3793 if ( !saw_under && saw_period == 1 && pos-s == 3 )
ad63d80f
JP		 3794 break;
3795 pos++;
b0f01acb
JP		 3796 }
3797 }
3798 }
ad63d80f 3799 return s;
b0f01acb
JP		 3800}
3801
3802/*
3803=for apidoc new_version
3804
3805Returns a new version object based on the passed in SV:
3806
3807 SV *sv = new_version(SV *ver);
3808
3809Does not alter the passed in ver SV. See "upg_version" if you
3810want to upgrade the SV.
3811
3812=cut
3813*/
3814
3815SV *
3816Perl_new_version(pTHX_ SV *ver)
3817{
3818 SV *rv = NEWSV(92,5);
26ec6fc3
JP		 3819 char *version;
3820 if ( SvNOK(ver) ) /* may get too much accuracy */
3821 {
3822 char tbuf[64];
3823 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
3824 version = savepv(tbuf);
3825 }
ad63d80f 3826#ifdef SvVOK
26ec6fc3 3827 else if ( SvVOK(ver) ) { /* already a v-string */
b0f01acb
JP		 3828 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3829 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3830 }
ad63d80f 3831#endif
26ec6fc3
JP		 3832 else
3833 {
3834 version = (char *)SvPV(ver,PL_na);
3835 }
b0f01acb
JP		 3836 version = scan_version(version,rv);
3837 return rv;
3838}
3839
3840/*
3841=for apidoc upg_version
3842
3843In-place upgrade of the supplied SV to a version object.
3844
3845 SV *sv = upg_version(SV *sv);
3846
3847Returns a pointer to the upgraded SV.
3848
3849=cut
3850*/
3851
3852SV *
ad63d80f 3853Perl_upg_version(pTHX_ SV *ver)
b0f01acb 3854{
ad63d80f
JP		 3855 char *version = savepvn(SvPVX(ver),SvCUR(ver));
3856#ifdef SvVOK
3857 if ( SvVOK(ver) ) { /* already a v-string */
3858 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3859 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
b0f01acb 3860 }
ad63d80f
JP		 3861#endif
3862 version = scan_version(version,ver);
3863 return ver;
b0f01acb
JP		 3864}
3865
3866
3867/*
3868=for apidoc vnumify
3869
ad63d80f
JP		 3870Accepts a version object and returns the normalized floating
3871point representation. Call like:
b0f01acb 3872
ad63d80f 3873 sv = vnumify(rv);
b0f01acb 3874
ad63d80f
JP		 3875NOTE: you can pass either the object directly or the SV
3876contained within the RV.
b0f01acb
JP		 3877
3878=cut
3879*/
3880
3881SV *
ad63d80f 3882Perl_vnumify(pTHX_ SV *vs)
b0f01acb 3883{
ad63d80f
JP		 3884 I32 i, len, digit;
3885 SV *sv = NEWSV(92,0);
3886 if ( SvROK(vs) )
3887 vs = SvRV(vs);
3888 len = av_len((AV *)vs);
46314c13
JP		 3889 if ( len == -1 )
3890 {
3891 Perl_sv_catpv(aTHX_ sv,"0");
3892 return sv;
3893 }
ad63d80f
JP		 3894 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3895 Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit));
3896 for ( i = 1 ; i <= len ; i++ )
b0f01acb 3897 {
ad63d80f
JP		 3898 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3899 Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit));
b0f01acb 3900 }
ad63d80f
JP		 3901 if ( len == 0 )
3902 Perl_sv_catpv(aTHX_ sv,"000");
b0f01acb
JP		 3903 return sv;
3904}
3905
3906/*
3907=for apidoc vstringify
3908
ad63d80f
JP		 3909Accepts a version object and returns the normalized string
3910representation. Call like:
b0f01acb 3911
ad63d80f 3912 sv = vstringify(rv);
b0f01acb 3913
ad63d80f
JP		 3914NOTE: you can pass either the object directly or the SV
3915contained within the RV.
b0f01acb
JP		 3916
3917=cut
3918*/
3919
3920SV *
ad63d80f 3921Perl_vstringify(pTHX_ SV *vs)
b0f01acb 3922{
ad63d80f
JP		 3923 I32 i, len, digit;
3924 SV *sv = NEWSV(92,0);
3925 if ( SvROK(vs) )
3926 vs = SvRV(vs);
3927 len = av_len((AV *)vs);
46314c13
JP		 3928 if ( len == -1 )
3929 {
3930 Perl_sv_catpv(aTHX_ sv,"");
3931 return sv;
3932 }
ad63d80f
JP		 3933 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
3934 Perl_sv_setpvf(aTHX_ sv,"%d",digit);
3935 for ( i = 1 ; i <= len ; i++ )
46314c13 3936 {
ad63d80f
JP		 3937 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3938 if ( digit < 0 )
3939 Perl_sv_catpvf(aTHX_ sv,"_%d",-digit);
3940 else
3941 Perl_sv_catpvf(aTHX_ sv,".%d",digit);
b0f01acb 3942 }
ad63d80f
JP		 3943 if ( len == 0 )
3944 Perl_sv_catpv(aTHX_ sv,".0");
b0f01acb
JP		 3945 return sv;
3946}
3947
ad63d80f
JP		 3948/*
3949=for apidoc vcmp
3950
3951Version object aware cmp. Both operands must already have been
3952converted into version objects.
3953
3954=cut
3955*/
3956
3957int
3958Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
3959{
3960 I32 i,l,m,r,retval;
3961 if ( SvROK(lsv) )
3962 lsv = SvRV(lsv);
3963 if ( SvROK(rsv) )
3964 rsv = SvRV(rsv);
3965 l = av_len((AV *)lsv);
3966 r = av_len((AV *)rsv);
3967 m = l < r ? l : r;
3968 retval = 0;
3969 i = 0;
3970 while ( i <= m && retval == 0 )
3971 {
3972 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
3973 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
3974 bool lbeta = left < 0 ? 1 : 0;
3975 bool rbeta = right < 0 ? 1 : 0;
3976 left = abs(left);
3977 right = abs(right);
3978 if ( left < right || (left == right && lbeta && !rbeta) )
3979 retval = -1;
3980 if ( left > right || (left == right && rbeta && !lbeta) )
3981 retval = +1;
3982 i++;
3983 }
3984
3985 if ( l != r && retval == 0 )
3986 retval = l < r ? -1 : +1;
3987 return retval;
3988}
3989
c95c94b1 3990#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 3991# define EMULATE_SOCKETPAIR_UDP
3992#endif
3993
3994#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 3995static int
3996S_socketpair_udp (int fd[2]) {
e10bb1e9 3997 dTHX;
02fc2eee
NC		 3998 /* Fake a datagram socketpair using UDP to localhost. */
3999 int sockets[2] = {-1, -1};
4000 struct sockaddr_in addresses[2];
4001 int i;
3aed30dc 4002 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4003 unsigned short port;
02fc2eee
NC		 4004 int got;
4005
3aed30dc 4006 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4007 i = 1;
4008 do {
3aed30dc
HS		 4009 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4010 if (sockets[i] == -1)
4011 goto tidy_up_and_fail;
4012
4013 addresses[i].sin_family = AF_INET;
4014 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4015 addresses[i].sin_port = 0; /* kernel choses port. */
4016 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4017 sizeof(struct sockaddr_in)) == -1)
4018 goto tidy_up_and_fail;
02fc2eee
NC		 4019 } while (i--);
4020
4021 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4022 for each connect the other socket to it. */
4023 i = 1;
4024 do {
3aed30dc
HS		 4025 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4026 &size) == -1)
4027 goto tidy_up_and_fail;
4028 if (size != sizeof(struct sockaddr_in))
4029 goto abort_tidy_up_and_fail;
4030 /* !1 is 0, !0 is 1 */
4031 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4032 sizeof(struct sockaddr_in)) == -1)
4033 goto tidy_up_and_fail;
02fc2eee
NC		 4034 } while (i--);
4035
4036 /* Now we have 2 sockets connected to each other. I don't trust some other
4037 process not to have already sent a packet to us (by random) so send
4038 a packet from each to the other. */
4039 i = 1;
4040 do {
3aed30dc
HS		 4041 /* I'm going to send my own port number. As a short.
4042 (Who knows if someone somewhere has sin_port as a bitfield and needs
4043 this routine. (I'm assuming crays have socketpair)) */
4044 port = addresses[i].sin_port;
4045 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4046 if (got != sizeof(port)) {
4047 if (got == -1)
4048 goto tidy_up_and_fail;
4049 goto abort_tidy_up_and_fail;
4050 }
02fc2eee
NC		 4051 } while (i--);
4052
4053 /* Packets sent. I don't trust them to have arrived though.
4054 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4055 connect to localhost will use a second kernel thread. In 2.6 the
4056 first thread running the connect() returns before the second completes,
4057 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4058 returns 0. Poor programs have tripped up. One poor program's authors'
4059 had a 50-1 reverse stock split. Not sure how connected these were.)
4060 So I don't trust someone not to have an unpredictable UDP stack.
4061 */
4062
4063 {
3aed30dc
HS		 4064 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4065 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4066 fd_set rset;
4067
4068 FD_ZERO(&rset);
4069 FD_SET(sockets[0], &rset);
4070 FD_SET(sockets[1], &rset);
4071
4072 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4073 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4074 || !FD_ISSET(sockets[1], &rset)) {
4075 /* I hope this is portable and appropriate. */
4076 if (got == -1)
4077 goto tidy_up_and_fail;
4078 goto abort_tidy_up_and_fail;
4079 }
02fc2eee 4080 }
f4758303 4081
02fc2eee
NC		 4082 /* And the paranoia department even now doesn't trust it to have arrive
4083 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4084 {
3aed30dc
HS		 4085 struct sockaddr_in readfrom;
4086 unsigned short buffer[2];
02fc2eee 4087
3aed30dc
HS		 4088 i = 1;
4089 do {
02fc2eee 4090#ifdef MSG_DONTWAIT
3aed30dc
HS		 4091 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4092 sizeof(buffer), MSG_DONTWAIT,
4093 (struct sockaddr *) &readfrom, &size);
02fc2eee 4094#else
3aed30dc
HS		 4095 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4096 sizeof(buffer), 0,
4097 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4098#endif
02fc2eee 4099
3aed30dc
HS		 4100 if (got == -1)
4101 goto tidy_up_and_fail;
4102 if (got != sizeof(port)
4103 || size != sizeof(struct sockaddr_in)
4104 /* Check other socket sent us its port. */
4105 || buffer[0] != (unsigned short) addresses[!i].sin_port
4106 /* Check kernel says we got the datagram from that socket */
4107 || readfrom.sin_family != addresses[!i].sin_family
4108 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4109 || readfrom.sin_port != addresses[!i].sin_port)
4110 goto abort_tidy_up_and_fail;
4111 } while (i--);
02fc2eee
NC		 4112 }
4113 /* My caller (my_socketpair) has validated that this is non-NULL */
4114 fd[0] = sockets[0];
4115 fd[1] = sockets[1];
4116 /* I hereby declare this connection open. May God bless all who cross
4117 her. */
4118 return 0;
4119
4120 abort_tidy_up_and_fail:
4121 errno = ECONNABORTED;
4122 tidy_up_and_fail:
4123 {
3aed30dc
HS		 4124 int save_errno = errno;
4125 if (sockets[0] != -1)
4126 PerlLIO_close(sockets[0]);
4127 if (sockets[1] != -1)
4128 PerlLIO_close(sockets[1]);
4129 errno = save_errno;
4130 return -1;
02fc2eee
NC		 4131 }
4132}
85ca448a 4133#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4134
b5ac89c3 4135#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4136int
4137Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4138 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4139 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4140 dTHX;
02fc2eee
NC		 4141 int listener = -1;
4142 int connector = -1;
4143 int acceptor = -1;
4144 struct sockaddr_in listen_addr;
4145 struct sockaddr_in connect_addr;
4146 Sock_size_t size;
4147
50458334
JH		 4148 if (protocol
4149#ifdef AF_UNIX
4150 || family != AF_UNIX
4151#endif
3aed30dc
HS		 4152 ) {
4153 errno = EAFNOSUPPORT;
4154 return -1;
02fc2eee 4155 }
2948e0bd 4156 if (!fd) {
3aed30dc
HS		 4157 errno = EINVAL;
4158 return -1;
2948e0bd 4159 }
02fc2eee 4160
2bc69dc4 4161#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4162 if (type == SOCK_DGRAM)
3aed30dc 4163 return S_socketpair_udp(fd);
2bc69dc4 4164#endif
02fc2eee 4165
3aed30dc 4166 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4167 if (listener == -1)
3aed30dc
HS		 4168 return -1;
4169 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4170 listen_addr.sin_family = AF_INET;
3aed30dc 4171 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4172 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4173 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4174 sizeof(listen_addr)) == -1)
4175 goto tidy_up_and_fail;
e10bb1e9 4176 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4177 goto tidy_up_and_fail;
02fc2eee 4178
3aed30dc 4179 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4180 if (connector == -1)
3aed30dc 4181 goto tidy_up_and_fail;
02fc2eee 4182 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4183 size = sizeof(connect_addr);
4184 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4185 &size) == -1)
4186 goto tidy_up_and_fail;
4187 if (size != sizeof(connect_addr))
4188 goto abort_tidy_up_and_fail;
e10bb1e9 4189 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4190 sizeof(connect_addr)) == -1)
4191 goto tidy_up_and_fail;
02fc2eee 4192
3aed30dc
HS		 4193 size = sizeof(listen_addr);
4194 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4195 &size);
02fc2eee 4196 if (acceptor == -1)
3aed30dc
HS		 4197 goto tidy_up_and_fail;
4198 if (size != sizeof(listen_addr))
4199 goto abort_tidy_up_and_fail;
4200 PerlLIO_close(listener);
02fc2eee
NC		 4201 /* Now check we are talking to ourself by matching port and host on the
4202 two sockets. */
3aed30dc
HS		 4203 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4204 &size) == -1)
4205 goto tidy_up_and_fail;
4206 if (size != sizeof(connect_addr)
4207 || listen_addr.sin_family != connect_addr.sin_family
4208 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4209 || listen_addr.sin_port != connect_addr.sin_port) {
4210 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4211 }
4212 fd[0] = connector;
4213 fd[1] = acceptor;
4214 return 0;
4215
4216 abort_tidy_up_and_fail:
85ca448a 4217 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
02fc2eee
NC		 4218 tidy_up_and_fail:
4219 {
3aed30dc
HS		 4220 int save_errno = errno;
4221 if (listener != -1)
4222 PerlLIO_close(listener);
4223 if (connector != -1)
4224 PerlLIO_close(connector);
4225 if (acceptor != -1)
4226 PerlLIO_close(acceptor);
4227 errno = save_errno;
4228 return -1;
02fc2eee
NC		 4229 }
4230}
85ca448a 4231#else
48ea76d1
JH		 4232/* In any case have a stub so that there's code corresponding
4233 * to the my_socketpair in global.sym. */
4234int
4235Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4236#ifdef HAS_SOCKETPAIR
48ea76d1 4237 return socketpair(family, type, protocol, fd);
daf16542
JH		 4238#else
4239 return -1;
4240#endif
48ea76d1
JH		 4241}
4242#endif
4243
68795e93
NIS		 4244/*
4245
4246=for apidoc sv_nosharing
4247
4248Dummy routine which "shares" an SV when there is no sharing module present.
4249Exists to avoid test for a NULL function pointer and because it could potentially warn under
4250some level of strict-ness.
4251
4252=cut
4253*/
4254
4255void
4256Perl_sv_nosharing(pTHX_ SV *sv)
4257{
4258}
4259
4260/*
4261=for apidoc sv_nolocking
4262
4263Dummy routine which "locks" an SV when there is no locking module present.
4264Exists to avoid test for a NULL function pointer and because it could potentially warn under
4265some level of strict-ness.
4266
4267=cut
4268*/
4269
4270void
4271Perl_sv_nolocking(pTHX_ SV *sv)
4272{
4273}
4274
4275
4276/*
4277=for apidoc sv_nounlocking
4278
4279Dummy routine which "unlocks" an SV when there is no locking module present.
4280Exists to avoid test for a NULL function pointer and because it could potentially warn under
4281some level of strict-ness.
4282
4283=cut
4284*/
4285
4286void
4287Perl_sv_nounlocking(pTHX_ SV *sv)
4288{
4289}
4290
Unnamed repository; edit this file 'description' to name the repository.