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