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