This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Re: MakeMaker doesn't pasthru DEFINE command-line args to subdirs on Win32
[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);
1822#endif
1823 }
1824 /* Now dup our end of _the_ pipe to right position */
1825 if (p[THIS] != (*mode == 'r')) {
1826 PerlLIO_dup2(p[THIS], *mode == 'r');
1827 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 1828 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1829 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 1830 }
4e6dfe71
GS		 1831 else
1832 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 1833#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1834 /* No automatic close - do it by hand */
b7953727
JH		 1835# ifndef NOFILE
1836# define NOFILE 20
1837# endif
a080fe3d
NIS		 1838 {
1839 int fd;
1840
1841 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 1842 if (fd != pp[1])
a080fe3d
NIS		 1843 PerlLIO_close(fd);
1844 }
1f852d0d
NIS		 1845 }
1846#endif
1847 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
1848 PerlProc__exit(1);
1849#undef THIS
1850#undef THAT
1851 }
1852 /* Parent */
52e18b1f 1853 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 1854 if (did_pipes)
1855 PerlLIO_close(pp[1]);
1856 /* Keep the lower of the two fd numbers */
1857 if (p[that] < p[This]) {
1858 PerlLIO_dup2(p[This], p[that]);
1859 PerlLIO_close(p[This]);
1860 p[This] = p[that];
1861 }
4e6dfe71
GS		 1862 else
1863 PerlLIO_close(p[that]); /* close child's end of pipe */
1864
1f852d0d
NIS		 1865 LOCK_FDPID_MUTEX;
1866 sv = *av_fetch(PL_fdpid,p[This],TRUE);
1867 UNLOCK_FDPID_MUTEX;
1868 (void)SvUPGRADE(sv,SVt_IV);
1869 SvIVX(sv) = pid;
1870 PL_forkprocess = pid;
1871 /* If we managed to get status pipe check for exec fail */
1872 if (did_pipes && pid > 0) {
1873 int errkid;
1874 int n = 0, n1;
1875
1876 while (n < sizeof(int)) {
1877 n1 = PerlLIO_read(pp[0],
1878 (void*)(((char*)&errkid)+n),
1879 (sizeof(int)) - n);
1880 if (n1 <= 0)
1881 break;
1882 n += n1;
1883 }
1884 PerlLIO_close(pp[0]);
1885 did_pipes = 0;
1886 if (n) { /* Error */
1887 int pid2, status;
8c51524e 1888 PerlLIO_close(p[This]);
1f852d0d
NIS		 1889 if (n != sizeof(int))
1890 Perl_croak(aTHX_ "panic: kid popen errno read");
1891 do {
1892 pid2 = wait4pid(pid, &status, 0);
1893 } while (pid2 == -1 && errno == EINTR);
1894 errno = errkid; /* Propagate errno from kid */
1895 return Nullfp;
1896 }
1897 }
1898 if (did_pipes)
1899 PerlLIO_close(pp[0]);
1900 return PerlIO_fdopen(p[This], mode);
1901#else
4a7d1889
NIS		 1902 Perl_croak(aTHX_ "List form of piped open not implemented");
1903 return (PerlIO *) NULL;
1f852d0d 1904#endif
4a7d1889
NIS		 1905}
1906
5f05dabc 1907 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 1908#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 1909PerlIO *
864dbfa3 1910Perl_my_popen(pTHX_ char *cmd, char *mode)
a687059c
LW		 1911{
1912 int p[2];
8ac85365 1913 register I32 This, that;
d8a83dd3 1914 register Pid_t pid;
79072805 1915 SV *sv;
1738f5c4 1916 I32 doexec = strNE(cmd,"-");
e446cec8
IZ		 1917 I32 did_pipes = 0;
1918 int pp[2];
a687059c 1919
45bc9206 1920 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 1921#ifdef OS2
1922 if (doexec) {
23da6c43 1923 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 1924 }
a1d180c4 1925#endif
8ac85365
NIS		 1926 This = (*mode == 'w');
1927 that = !This;
3280af22 1928 if (doexec && PL_tainting) {
bbce6d69 1929 taint_env();
1930 taint_proper("Insecure %s%s", "EXEC");
d48672a2 1931 }
c2267164
IZ		 1932 if (PerlProc_pipe(p) < 0)
1933 return Nullfp;
e446cec8
IZ		 1934 if (doexec && PerlProc_pipe(pp) >= 0)
1935 did_pipes = 1;
52e18b1f 1936 while ((pid = PerlProc_fork()) < 0) {
a687059c 1937 if (errno != EAGAIN) {
6ad3d225 1938 PerlLIO_close(p[This]);
b5ac89c3 1939 PerlLIO_close(p[that]);
e446cec8
IZ		 1940 if (did_pipes) {
1941 PerlLIO_close(pp[0]);
1942 PerlLIO_close(pp[1]);
1943 }
a687059c 1944 if (!doexec)
cea2e8a9 1945 Perl_croak(aTHX_ "Can't fork");
a687059c
LW		 1946 return Nullfp;
1947 }
1948 sleep(5);
1949 }
1950 if (pid == 0) {
79072805
LW		 1951 GV* tmpgv;
1952
30ac6d9b
GS		 1953#undef THIS
1954#undef THAT
a687059c 1955#define THIS that
8ac85365 1956#define THAT This
e446cec8
IZ		 1957 if (did_pipes) {
1958 PerlLIO_close(pp[0]);
1959#if defined(HAS_FCNTL) && defined(F_SETFD)
1960 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1961#endif
1962 }
a687059c 1963 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 1964 PerlLIO_dup2(p[THIS], *mode == 'r');
1965 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 1966 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1967 PerlLIO_close(p[THAT]);
a687059c 1968 }
b5ac89c3
NIS		 1969 else
1970 PerlLIO_close(p[THAT]);
4435c477 1971#ifndef OS2
a687059c 1972 if (doexec) {
a0d0e21e 1973#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 1974 int fd;
1975
1976#ifndef NOFILE
1977#define NOFILE 20
1978#endif
a080fe3d 1979 {
3aed30dc 1980 int fd;
a080fe3d
NIS		 1981
1982 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
1983 if (fd != pp[1])
3aed30dc 1984 PerlLIO_close(fd);
a080fe3d 1985 }
ae986130 1986#endif
a080fe3d
NIS		 1987 /* may or may not use the shell */
1988 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 1989 PerlProc__exit(1);
a687059c 1990 }
4435c477 1991#endif /* defined OS2 */
de3bb511 1992 /*SUPPRESS 560*/
306196c3 1993 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4d76a344 1994 SvREADONLY_off(GvSV(tmpgv));
7766f137 1995 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 1996 SvREADONLY_on(GvSV(tmpgv));
1997 }
1998#ifdef THREADS_HAVE_PIDS
1999 PL_ppid = (IV)getppid();
2000#endif
3280af22
NIS		 2001 PL_forkprocess = 0;
2002 hv_clear(PL_pidstatus); /* we have no children */
a687059c
LW		 2003 return Nullfp;
2004#undef THIS
2005#undef THAT
2006 }
b5ac89c3 2007 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2008 if (did_pipes)
2009 PerlLIO_close(pp[1]);
8ac85365 2010 if (p[that] < p[This]) {
6ad3d225
GS		 2011 PerlLIO_dup2(p[This], p[that]);
2012 PerlLIO_close(p[This]);
8ac85365 2013 p[This] = p[that];
62b28dd9 2014 }
b5ac89c3
NIS		 2015 else
2016 PerlLIO_close(p[that]);
2017
4755096e 2018 LOCK_FDPID_MUTEX;
3280af22 2019 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2020 UNLOCK_FDPID_MUTEX;
a0d0e21e 2021 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2022 SvIVX(sv) = pid;
3280af22 2023 PL_forkprocess = pid;
e446cec8
IZ		 2024 if (did_pipes && pid > 0) {
2025 int errkid;
2026 int n = 0, n1;
2027
2028 while (n < sizeof(int)) {
2029 n1 = PerlLIO_read(pp[0],
2030 (void*)(((char*)&errkid)+n),
2031 (sizeof(int)) - n);
2032 if (n1 <= 0)
2033 break;
2034 n += n1;
2035 }
2f96c702
IZ		 2036 PerlLIO_close(pp[0]);
2037 did_pipes = 0;
e446cec8 2038 if (n) { /* Error */
faa466a7 2039 int pid2, status;
8c51524e 2040 PerlLIO_close(p[This]);
e446cec8 2041 if (n != sizeof(int))
cea2e8a9 2042 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2043 do {
2044 pid2 = wait4pid(pid, &status, 0);
2045 } while (pid2 == -1 && errno == EINTR);
e446cec8
IZ		 2046 errno = errkid; /* Propagate errno from kid */
2047 return Nullfp;
2048 }
2049 }
2050 if (did_pipes)
2051 PerlLIO_close(pp[0]);
8ac85365 2052 return PerlIO_fdopen(p[This], mode);
a687059c 2053}
7c0587c8 2054#else
85ca448a 2055#if defined(atarist) || defined(EPOC)
7c0587c8 2056FILE *popen();
760ac839 2057PerlIO *
864dbfa3 2058Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2059{
45bc9206 2060 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2061 /* Call system's popen() to get a FILE *, then import it.
2062 used 0 for 2nd parameter to PerlIO_importFILE;
2063 apparently not used
2064 */
2065 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2066}
2b96b0a5
JH		 2067#else
2068#if defined(DJGPP)
2069FILE *djgpp_popen();
2070PerlIO *
2071Perl_my_popen(pTHX_ char *cmd, char *mode)
2072{
2073 PERL_FLUSHALL_FOR_CHILD;
2074 /* Call system's popen() to get a FILE *, then import it.
2075 used 0 for 2nd parameter to PerlIO_importFILE;
2076 apparently not used
2077 */
2078 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2079}
2080#endif
7c0587c8
LW		 2081#endif
2082
2083#endif /* !DOSISH */
a687059c 2084
52e18b1f
GS		 2085/* this is called in parent before the fork() */
2086void
2087Perl_atfork_lock(void)
2088{
3db8f154 2089#if defined(USE_ITHREADS)
52e18b1f
GS		 2090 /* locks must be held in locking order (if any) */
2091# ifdef MYMALLOC
2092 MUTEX_LOCK(&PL_malloc_mutex);
2093# endif
2094 OP_REFCNT_LOCK;
2095#endif
2096}
2097
2098/* this is called in both parent and child after the fork() */
2099void
2100Perl_atfork_unlock(void)
2101{
3db8f154 2102#if defined(USE_ITHREADS)
52e18b1f
GS		 2103 /* locks must be released in same order as in atfork_lock() */
2104# ifdef MYMALLOC
2105 MUTEX_UNLOCK(&PL_malloc_mutex);
2106# endif
2107 OP_REFCNT_UNLOCK;
2108#endif
2109}
2110
2111Pid_t
2112Perl_my_fork(void)
2113{
2114#if defined(HAS_FORK)
2115 Pid_t pid;
3db8f154 2116#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2117 atfork_lock();
2118 pid = fork();
2119 atfork_unlock();
2120#else
2121 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2122 * handlers elsewhere in the code */
2123 pid = fork();
2124#endif
2125 return pid;
2126#else
2127 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2128 Perl_croak_nocontext("fork() not available");
b961a566 2129 return 0;
52e18b1f
GS		 2130#endif /* HAS_FORK */
2131}
2132
748a9306 2133#ifdef DUMP_FDS
35ff7856 2134void
864dbfa3 2135Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2136{
2137 int fd;
c623ac67 2138 Stat_t tmpstatbuf;
ae986130 2139
bf49b057 2140 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2141 for (fd = 0; fd < 32; fd++) {
6ad3d225 2142 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2143 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2144 }
bf49b057 2145 PerlIO_printf(Perl_debug_log,"\n");
ae986130 2146}
35ff7856 2147#endif /* DUMP_FDS */
ae986130 2148
fe14fcc3 2149#ifndef HAS_DUP2
fec02dd3 2150int
ba106d47 2151dup2(int oldfd, int newfd)
a687059c 2152{
a0d0e21e 2153#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2154 if (oldfd == newfd)
2155 return oldfd;
6ad3d225 2156 PerlLIO_close(newfd);
fec02dd3 2157 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2158#else
fc36a67e 2159#define DUP2_MAX_FDS 256
2160 int fdtmp[DUP2_MAX_FDS];
79072805 2161 I32 fdx = 0;
ae986130
LW		 2162 int fd;
2163
fe14fcc3 2164 if (oldfd == newfd)
fec02dd3 2165 return oldfd;
6ad3d225 2166 PerlLIO_close(newfd);
fc36a67e 2167 /* good enough for low fd's... */
6ad3d225 2168 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2169 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2170 PerlLIO_close(fd);
fc36a67e 2171 fd = -1;
2172 break;
2173 }
ae986130 2174 fdtmp[fdx++] = fd;
fc36a67e 2175 }
ae986130 2176 while (fdx > 0)
6ad3d225 2177 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2178 return fd;
62b28dd9 2179#endif
a687059c
LW		 2180}
2181#endif
2182
64ca3a65 2183#ifndef PERL_MICRO
ff68c719 2184#ifdef HAS_SIGACTION
2185
abea2c45
HS		 2186#ifdef MACOS_TRADITIONAL
2187/* We don't want restart behavior on MacOS */
2188#undef SA_RESTART
2189#endif
2190
ff68c719 2191Sighandler_t
864dbfa3 2192Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2193{
2194 struct sigaction act, oact;
2195
a10b1e10
JH		 2196#ifdef USE_ITHREADS
2197 /* only "parent" interpreter can diddle signals */
2198 if (PL_curinterp != aTHX)
2199 return SIG_ERR;
2200#endif
2201
ff68c719 2202 act.sa_handler = handler;
2203 sigemptyset(&act.sa_mask);
2204 act.sa_flags = 0;
2205#ifdef SA_RESTART
4ffa73a3
JH		 2206 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2207 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2208#endif
358837b8 2209#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
85264bed
CS		 2210 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2211 act.sa_flags |= SA_NOCLDWAIT;
2212#endif
ff68c719 2213 if (sigaction(signo, &act, &oact) == -1)
36477c24 2214 return SIG_ERR;
ff68c719 2215 else
36477c24 2216 return oact.sa_handler;
ff68c719 2217}
2218
2219Sighandler_t
864dbfa3 2220Perl_rsignal_state(pTHX_ int signo)
ff68c719 2221{
2222 struct sigaction oact;
2223
2224 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3aed30dc 2225 return SIG_ERR;
ff68c719 2226 else
3aed30dc 2227 return oact.sa_handler;
ff68c719 2228}
2229
2230int
864dbfa3 2231Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2232{
2233 struct sigaction act;
2234
a10b1e10
JH		 2235#ifdef USE_ITHREADS
2236 /* only "parent" interpreter can diddle signals */
2237 if (PL_curinterp != aTHX)
2238 return -1;
2239#endif
2240
ff68c719 2241 act.sa_handler = handler;
2242 sigemptyset(&act.sa_mask);
2243 act.sa_flags = 0;
2244#ifdef SA_RESTART
4ffa73a3
JH		 2245 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2246 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2247#endif
36b5d377 2248#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
85264bed
CS		 2249 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2250 act.sa_flags |= SA_NOCLDWAIT;
2251#endif
ff68c719 2252 return sigaction(signo, &act, save);
2253}
2254
2255int
864dbfa3 2256Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2257{
a10b1e10
JH		 2258#ifdef USE_ITHREADS
2259 /* only "parent" interpreter can diddle signals */
2260 if (PL_curinterp != aTHX)
2261 return -1;
2262#endif
2263
ff68c719 2264 return sigaction(signo, save, (struct sigaction *)NULL);
2265}
2266
2267#else /* !HAS_SIGACTION */
2268
2269Sighandler_t
864dbfa3 2270Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2271{
39f1703b 2272#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2273 /* only "parent" interpreter can diddle signals */
2274 if (PL_curinterp != aTHX)
2275 return SIG_ERR;
2276#endif
2277
6ad3d225 2278 return PerlProc_signal(signo, handler);
ff68c719 2279}
2280
df3728a2
JH		 2281static int sig_trapped; /* XXX signals are process-wide anyway, so we
2282 ignore the implications of this for threading */
ff68c719 2283
2284static
2285Signal_t
4e35701f 2286sig_trap(int signo)
ff68c719 2287{
2288 sig_trapped++;
2289}
2290
2291Sighandler_t
864dbfa3 2292Perl_rsignal_state(pTHX_ int signo)
ff68c719 2293{
2294 Sighandler_t oldsig;
2295
39f1703b 2296#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2297 /* only "parent" interpreter can diddle signals */
2298 if (PL_curinterp != aTHX)
2299 return SIG_ERR;
2300#endif
2301
ff68c719 2302 sig_trapped = 0;
6ad3d225
GS		 2303 oldsig = PerlProc_signal(signo, sig_trap);
2304 PerlProc_signal(signo, oldsig);
ff68c719 2305 if (sig_trapped)
3aed30dc 2306 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2307 return oldsig;
2308}
2309
2310int
864dbfa3 2311Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2312{
39f1703b 2313#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2314 /* only "parent" interpreter can diddle signals */
2315 if (PL_curinterp != aTHX)
2316 return -1;
2317#endif
6ad3d225 2318 *save = PerlProc_signal(signo, handler);
ff68c719 2319 return (*save == SIG_ERR) ? -1 : 0;
2320}
2321
2322int
864dbfa3 2323Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2324{
39f1703b 2325#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2326 /* only "parent" interpreter can diddle signals */
2327 if (PL_curinterp != aTHX)
2328 return -1;
2329#endif
6ad3d225 2330 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2331}
2332
2333#endif /* !HAS_SIGACTION */
64ca3a65 2334#endif /* !PERL_MICRO */
ff68c719 2335
5f05dabc 2336 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2337#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2338I32
864dbfa3 2339Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2340{
ff68c719 2341 Sigsave_t hstat, istat, qstat;
a687059c 2342 int status;
a0d0e21e 2343 SV **svp;
d8a83dd3
JH		 2344 Pid_t pid;
2345 Pid_t pid2;
03136e13 2346 bool close_failed;
b7953727 2347 int saved_errno = 0;
03136e13
CS		 2348#ifdef VMS
2349 int saved_vaxc_errno;
2350#endif
22fae026
TM		 2351#ifdef WIN32
2352 int saved_win32_errno;
2353#endif
a687059c 2354
4755096e 2355 LOCK_FDPID_MUTEX;
3280af22 2356 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2357 UNLOCK_FDPID_MUTEX;
25d92023 2358 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2359 SvREFCNT_dec(*svp);
3280af22 2360 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2361#ifdef OS2
2362 if (pid == -1) { /* Opened by popen. */
2363 return my_syspclose(ptr);
2364 }
a1d180c4 2365#endif
03136e13
CS		 2366 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2367 saved_errno = errno;
2368#ifdef VMS
2369 saved_vaxc_errno = vaxc$errno;
2370#endif
22fae026
TM		 2371#ifdef WIN32
2372 saved_win32_errno = GetLastError();
2373#endif
03136e13 2374 }
7c0587c8 2375#ifdef UTS
6ad3d225 2376 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2377#endif
64ca3a65 2378#ifndef PERL_MICRO
ff68c719 2379 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2380 rsignal_save(SIGINT, SIG_IGN, &istat);
2381 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2382#endif
748a9306 2383 do {
1d3434b8
GS		 2384 pid2 = wait4pid(pid, &status, 0);
2385 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2386#ifndef PERL_MICRO
ff68c719 2387 rsignal_restore(SIGHUP, &hstat);
2388 rsignal_restore(SIGINT, &istat);
2389 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2390#endif
03136e13
CS		 2391 if (close_failed) {
2392 SETERRNO(saved_errno, saved_vaxc_errno);
2393 return -1;
2394 }
1d3434b8 2395 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2396}
4633a7c4
LW		 2397#endif /* !DOSISH */
2398
2986a63f 2399#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2400I32
d8a83dd3 2401Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2402{
cddd4526 2403 I32 result;
b7953727
JH		 2404 if (!pid)
2405 return -1;
2406#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2407 {
3aed30dc
HS		 2408 SV *sv;
2409 SV** svp;
2410 char spid[TYPE_CHARS(int)];
20188a90 2411
3aed30dc 2412 if (pid > 0) {
7b0972df 2413 sprintf(spid, "%"IVdf, (IV)pid);
3aed30dc
HS		 2414 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2415 if (svp && *svp != &PL_sv_undef) {
2416 *statusp = SvIVX(*svp);
2417 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2418 return pid;
2419 }
2420 }
2421 else {
2422 HE *entry;
2423
2424 hv_iterinit(PL_pidstatus);
2425 if ((entry = hv_iternext(PL_pidstatus))) {
2426 SV *sv;
2427 char spid[TYPE_CHARS(int)];
2428
2429 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2430 sv = hv_iterval(PL_pidstatus,entry);
2431 *statusp = SvIVX(sv);
2432 sprintf(spid, "%"IVdf, (IV)pid);
2433 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2434 return pid;
2435 }
20188a90
LW		 2436 }
2437 }
68a29c53 2438#endif
79072805 2439#ifdef HAS_WAITPID
367f3c24
IZ		 2440# ifdef HAS_WAITPID_RUNTIME
2441 if (!HAS_WAITPID_RUNTIME)
2442 goto hard_way;
2443# endif
cddd4526 2444 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2445 goto finish;
367f3c24
IZ		 2446#endif
2447#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
cddd4526 2448 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
dfcfdb64 2449 goto finish;
367f3c24
IZ		 2450#endif
2451#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2452 hard_way:
a0d0e21e 2453 {
a0d0e21e 2454 if (flags)
cea2e8a9 2455 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2456 else {
76e3520e 2457 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2458 pidgone(result,*statusp);
2459 if (result < 0)
2460 *statusp = -1;
2461 }
a687059c
LW		 2462 }
2463#endif
dfcfdb64 2464 finish:
cddd4526
NIS		 2465 if (result < 0 && errno == EINTR) {
2466 PERL_ASYNC_CHECK();
2467 }
2468 return result;
a687059c 2469}
2986a63f 2470#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2471
7c0587c8 2472void
de3bb511 2473/*SUPPRESS 590*/
d8a83dd3 2474Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2475{
79072805 2476 register SV *sv;
fc36a67e 2477 char spid[TYPE_CHARS(int)];
a687059c 2478
7b0972df 2479 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2480 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2481 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2482 SvIVX(sv) = status;
20188a90 2483 return;
a687059c
LW		 2484}
2485
85ca448a 2486#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2487int pclose();
ddcf38b7
IZ		 2488#ifdef HAS_FORK
2489int /* Cannot prototype with I32
2490 in os2ish.h. */
ba106d47 2491my_syspclose(PerlIO *ptr)
ddcf38b7 2492#else
79072805 2493I32
864dbfa3 2494Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2495#endif
a687059c 2496{
760ac839
LW		 2497 /* Needs work for PerlIO ! */
2498 FILE *f = PerlIO_findFILE(ptr);
2499 I32 result = pclose(f);
2b96b0a5
JH		 2500 PerlIO_releaseFILE(ptr,f);
2501 return result;
2502}
2503#endif
2504
933fea7f 2505#if defined(DJGPP)
2b96b0a5
JH		 2506int djgpp_pclose();
2507I32
2508Perl_my_pclose(pTHX_ PerlIO *ptr)
2509{
2510 /* Needs work for PerlIO ! */
2511 FILE *f = PerlIO_findFILE(ptr);
2512 I32 result = djgpp_pclose(f);
933fea7f 2513 result = (result << 8) & 0xff00;
760ac839
LW		 2514 PerlIO_releaseFILE(ptr,f);
2515 return result;
a687059c 2516}
7c0587c8 2517#endif
9f68db38
LW		 2518
2519void
864dbfa3 2520Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2521{
79072805 2522 register I32 todo;
08105a92 2523 register const char *frombase = from;
9f68db38
LW		 2524
2525 if (len == 1) {
08105a92 2526 register const char c = *from;
9f68db38 2527 while (count-- > 0)
5926133d 2528 *to++ = c;
9f68db38
LW		 2529 return;
2530 }
2531 while (count-- > 0) {
2532 for (todo = len; todo > 0; todo--) {
2533 *to++ = *from++;
2534 }
2535 from = frombase;
2536 }
2537}
0f85fab0 2538
fe14fcc3 2539#ifndef HAS_RENAME
79072805 2540I32
864dbfa3 2541Perl_same_dirent(pTHX_ char *a, char *b)
62b28dd9 2542{
93a17b20
LW		 2543 char *fa = strrchr(a,'/');
2544 char *fb = strrchr(b,'/');
c623ac67
GS		 2545 Stat_t tmpstatbuf1;
2546 Stat_t tmpstatbuf2;
46fc3d4c 2547 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2548
2549 if (fa)
2550 fa++;
2551 else
2552 fa = a;
2553 if (fb)
2554 fb++;
2555 else
2556 fb = b;
2557 if (strNE(a,b))
2558 return FALSE;
2559 if (fa == a)
46fc3d4c 2560 sv_setpv(tmpsv, ".");
62b28dd9 2561 else
46fc3d4c 2562 sv_setpvn(tmpsv, a, fa - a);
c6ed36e1 2563 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2564 return FALSE;
2565 if (fb == b)
46fc3d4c 2566 sv_setpv(tmpsv, ".");
62b28dd9 2567 else
46fc3d4c 2568 sv_setpvn(tmpsv, b, fb - b);
c6ed36e1 2569 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2570 return FALSE;
2571 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2572 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2573}
fe14fcc3
LW		 2574#endif /* !HAS_RENAME */
2575
491527d0 2576char*
864dbfa3 2577Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
491527d0 2578{
491527d0
GS		 2579 char *xfound = Nullch;
2580 char *xfailed = Nullch;
0f31cffe 2581 char tmpbuf[MAXPATHLEN];
491527d0 2582 register char *s;
5f74f29c 2583 I32 len = 0;
491527d0
GS		 2584 int retval;
2585#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2586# define SEARCH_EXTS ".bat", ".cmd", NULL
2587# define MAX_EXT_LEN 4
2588#endif
2589#ifdef OS2
2590# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2591# define MAX_EXT_LEN 4
2592#endif
2593#ifdef VMS
2594# define SEARCH_EXTS ".pl", ".com", NULL
2595# define MAX_EXT_LEN 4
2596#endif
2597 /* additional extensions to try in each dir if scriptname not found */
2598#ifdef SEARCH_EXTS
2599 char *exts[] = { SEARCH_EXTS };
2600 char **ext = search_ext ? search_ext : exts;
2601 int extidx = 0, i = 0;
2602 char *curext = Nullch;
2603#else
2604# define MAX_EXT_LEN 0
2605#endif
2606
2607 /*
2608 * If dosearch is true and if scriptname does not contain path
2609 * delimiters, search the PATH for scriptname.
2610 *
2611 * If SEARCH_EXTS is also defined, will look for each
2612 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2613 * while searching the PATH.
2614 *
2615 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2616 * proceeds as follows:
2617 * If DOSISH or VMSISH:
2618 * + look for ./scriptname{,.foo,.bar}
2619 * + search the PATH for scriptname{,.foo,.bar}
2620 *
2621 * If !DOSISH:
2622 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2623 * this will not look in '.' if it's not in the PATH)
2624 */
84486fc6 2625 tmpbuf[0] = '\0';
491527d0
GS		 2626
2627#ifdef VMS
2628# ifdef ALWAYS_DEFTYPES
2629 len = strlen(scriptname);
2630 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2631 int hasdir, idx = 0, deftypes = 1;
2632 bool seen_dot = 1;
2633
2634 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2635# else
2636 if (dosearch) {
2637 int hasdir, idx = 0, deftypes = 1;
2638 bool seen_dot = 1;
2639
2640 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2641# endif
2642 /* The first time through, just add SEARCH_EXTS to whatever we
2643 * already have, so we can check for default file types. */
2644 while (deftypes ||
84486fc6 2645 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 2646 {
2647 if (deftypes) {
2648 deftypes = 0;
84486fc6 2649 *tmpbuf = '\0';
491527d0 2650 }
84486fc6
GS		 2651 if ((strlen(tmpbuf) + strlen(scriptname)
2652 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 2653 continue; /* don't search dir with too-long name */
84486fc6 2654 strcat(tmpbuf, scriptname);
491527d0
GS		 2655#else /* !VMS */
2656
2657#ifdef DOSISH
2658 if (strEQ(scriptname, "-"))
2659 dosearch = 0;
2660 if (dosearch) { /* Look in '.' first. */
2661 char *cur = scriptname;
2662#ifdef SEARCH_EXTS
2663 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2664 while (ext[i])
2665 if (strEQ(ext[i++],curext)) {
2666 extidx = -1; /* already has an ext */
2667 break;
2668 }
2669 do {
2670#endif
2671 DEBUG_p(PerlIO_printf(Perl_debug_log,
2672 "Looking for %s\n",cur));
017f25f1
IZ		 2673 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2674 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 2675 dosearch = 0;
2676 scriptname = cur;
2677#ifdef SEARCH_EXTS
2678 break;
2679#endif
2680 }
2681#ifdef SEARCH_EXTS
2682 if (cur == scriptname) {
2683 len = strlen(scriptname);
84486fc6 2684 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 2685 break;
84486fc6 2686 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 2687 }
2688 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 2689 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 2690#endif
2691 }
2692#endif
2693
cd39f2b6
JH		 2694#ifdef MACOS_TRADITIONAL
2695 if (dosearch && !strchr(scriptname, ':') &&
2696 (s = PerlEnv_getenv("Commands")))
2697#else
491527d0
GS		 2698 if (dosearch && !strchr(scriptname, '/')
2699#ifdef DOSISH
2700 && !strchr(scriptname, '\\')
2701#endif
cd39f2b6
JH		 2702 && (s = PerlEnv_getenv("PATH")))
2703#endif
2704 {
491527d0 2705 bool seen_dot = 0;
92f0c265 2706
3280af22
NIS		 2707 PL_bufend = s + strlen(s);
2708 while (s < PL_bufend) {
cd39f2b6
JH		 2709#ifdef MACOS_TRADITIONAL
2710 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2711 ',',
2712 &len);
2713#else
491527d0
GS		 2714#if defined(atarist) || defined(DOSISH)
2715 for (len = 0; *s
2716# ifdef atarist
2717 && *s != ','
2718# endif
2719 && *s != ';'; len++, s++) {
84486fc6
GS		 2720 if (len < sizeof tmpbuf)
2721 tmpbuf[len] = *s;
491527d0 2722 }
84486fc6
GS		 2723 if (len < sizeof tmpbuf)
2724 tmpbuf[len] = '\0';
491527d0 2725#else /* ! (atarist || DOSISH) */
3280af22 2726 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 2727 ':',
2728 &len);
2729#endif /* ! (atarist || DOSISH) */
cd39f2b6 2730#endif /* MACOS_TRADITIONAL */
3280af22 2731 if (s < PL_bufend)
491527d0 2732 s++;
84486fc6 2733 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 2734 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 2735#ifdef MACOS_TRADITIONAL
2736 if (len && tmpbuf[len - 1] != ':')
2737 tmpbuf[len++] = ':';
2738#else
491527d0 2739 if (len
61ae2fbf 2740#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 2741 && tmpbuf[len - 1] != '/'
2742 && tmpbuf[len - 1] != '\\'
491527d0
GS		 2743#endif
2744 )
84486fc6
GS		 2745 tmpbuf[len++] = '/';
2746 if (len == 2 && tmpbuf[0] == '.')
491527d0 2747 seen_dot = 1;
cd39f2b6 2748#endif
84486fc6 2749 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 2750#endif /* !VMS */
2751
2752#ifdef SEARCH_EXTS
84486fc6 2753 len = strlen(tmpbuf);
491527d0
GS		 2754 if (extidx > 0) /* reset after previous loop */
2755 extidx = 0;
2756 do {
2757#endif
84486fc6 2758 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 2759 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 2760 if (S_ISDIR(PL_statbuf.st_mode)) {
2761 retval = -1;
2762 }
491527d0
GS		 2763#ifdef SEARCH_EXTS
2764 } while ( retval < 0 /* not there */
2765 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 2766 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 2767 );
2768#endif
2769 if (retval < 0)
2770 continue;
3280af22
NIS		 2771 if (S_ISREG(PL_statbuf.st_mode)
2772 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 2773#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 2774 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 2775#endif
2776 )
2777 {
3aed30dc 2778 xfound = tmpbuf; /* bingo! */
491527d0
GS		 2779 break;
2780 }
2781 if (!xfailed)
84486fc6 2782 xfailed = savepv(tmpbuf);
491527d0
GS		 2783 }
2784#ifndef DOSISH
017f25f1 2785 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 2786 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 2787 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 2788#endif
2789 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 2790 if (!xfound) {
2791 if (flags & 1) { /* do or die? */
3aed30dc 2792 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 2793 (xfailed ? "execute" : "find"),
2794 (xfailed ? xfailed : scriptname),
2795 (xfailed ? "" : " on PATH"),
2796 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2797 }
2798 scriptname = Nullch;
2799 }
491527d0
GS		 2800 if (xfailed)
2801 Safefree(xfailed);
2802 scriptname = xfound;
2803 }
9ccb31f9 2804 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 2805}
2806
ba869deb
GS		 2807#ifndef PERL_GET_CONTEXT_DEFINED
2808
2809void *
2810Perl_get_context(void)
2811{
3db8f154 2812#if defined(USE_ITHREADS)
ba869deb
GS		 2813# ifdef OLD_PTHREADS_API
2814 pthread_addr_t t;
2815 if (pthread_getspecific(PL_thr_key, &t))
2816 Perl_croak_nocontext("panic: pthread_getspecific");
2817 return (void*)t;
2818# else
bce813aa 2819# ifdef I_MACH_CTHREADS
8b8b35ab 2820 return (void*)cthread_data(cthread_self());
bce813aa 2821# else
8b8b35ab
JH		 2822 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2823# endif
c44d3fdb 2824# endif
ba869deb
GS		 2825#else
2826 return (void*)NULL;
2827#endif
2828}
2829
2830void
2831Perl_set_context(void *t)
2832{
3db8f154 2833#if defined(USE_ITHREADS)
c44d3fdb
GS		 2834# ifdef I_MACH_CTHREADS
2835 cthread_set_data(cthread_self(), t);
2836# else
ba869deb
GS		 2837 if (pthread_setspecific(PL_thr_key, t))
2838 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 2839# endif
ba869deb
GS		 2840#endif
2841}
2842
2843#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 2844
22239a37
NIS		 2845#ifdef PERL_GLOBAL_STRUCT
2846struct perl_vars *
864dbfa3 2847Perl_GetVars(pTHX)
22239a37 2848{
533c011a 2849 return &PL_Vars;
22239a37 2850}
31fb1209
NIS		 2851#endif
2852
2853char **
864dbfa3 2854Perl_get_op_names(pTHX)
31fb1209 2855{
22c35a8c 2856 return PL_op_name;
31fb1209
NIS		 2857}
2858
2859char **
864dbfa3 2860Perl_get_op_descs(pTHX)
31fb1209 2861{
22c35a8c 2862 return PL_op_desc;
31fb1209 2863}
9e6b2b00
GS		 2864
2865char *
864dbfa3 2866Perl_get_no_modify(pTHX)
9e6b2b00 2867{
22c35a8c 2868 return (char*)PL_no_modify;
9e6b2b00
GS		 2869}
2870
2871U32 *
864dbfa3 2872Perl_get_opargs(pTHX)
9e6b2b00 2873{
22c35a8c 2874 return PL_opargs;
9e6b2b00 2875}
51aa15f3 2876
0cb96387
GS		 2877PPADDR_t*
2878Perl_get_ppaddr(pTHX)
2879{
12ae5dfc 2880 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 2881}
2882
a6c40364
GS		 2883#ifndef HAS_GETENV_LEN
2884char *
bf4acbe4 2885Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364
GS		 2886{
2887 char *env_trans = PerlEnv_getenv(env_elem);
2888 if (env_trans)
2889 *len = strlen(env_trans);
2890 return env_trans;
f675dbe5
CB		 2891}
2892#endif
2893
dc9e4912
GS		 2894
2895MGVTBL*
864dbfa3 2896Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912
GS		 2897{
2898 MGVTBL* result = Null(MGVTBL*);
2899
2900 switch(vtbl_id) {
2901 case want_vtbl_sv:
2902 result = &PL_vtbl_sv;
2903 break;
2904 case want_vtbl_env:
2905 result = &PL_vtbl_env;
2906 break;
2907 case want_vtbl_envelem:
2908 result = &PL_vtbl_envelem;
2909 break;
2910 case want_vtbl_sig:
2911 result = &PL_vtbl_sig;
2912 break;
2913 case want_vtbl_sigelem:
2914 result = &PL_vtbl_sigelem;
2915 break;
2916 case want_vtbl_pack:
2917 result = &PL_vtbl_pack;
2918 break;
2919 case want_vtbl_packelem:
2920 result = &PL_vtbl_packelem;
2921 break;
2922 case want_vtbl_dbline:
2923 result = &PL_vtbl_dbline;
2924 break;
2925 case want_vtbl_isa:
2926 result = &PL_vtbl_isa;
2927 break;
2928 case want_vtbl_isaelem:
2929 result = &PL_vtbl_isaelem;
2930 break;
2931 case want_vtbl_arylen:
2932 result = &PL_vtbl_arylen;
2933 break;
2934 case want_vtbl_glob:
2935 result = &PL_vtbl_glob;
2936 break;
2937 case want_vtbl_mglob:
2938 result = &PL_vtbl_mglob;
2939 break;
2940 case want_vtbl_nkeys:
2941 result = &PL_vtbl_nkeys;
2942 break;
2943 case want_vtbl_taint:
2944 result = &PL_vtbl_taint;
2945 break;
2946 case want_vtbl_substr:
2947 result = &PL_vtbl_substr;
2948 break;
2949 case want_vtbl_vec:
2950 result = &PL_vtbl_vec;
2951 break;
2952 case want_vtbl_pos:
2953 result = &PL_vtbl_pos;
2954 break;
2955 case want_vtbl_bm:
2956 result = &PL_vtbl_bm;
2957 break;
2958 case want_vtbl_fm:
2959 result = &PL_vtbl_fm;
2960 break;
2961 case want_vtbl_uvar:
2962 result = &PL_vtbl_uvar;
2963 break;
dc9e4912
GS		 2964 case want_vtbl_defelem:
2965 result = &PL_vtbl_defelem;
2966 break;
2967 case want_vtbl_regexp:
2968 result = &PL_vtbl_regexp;
2969 break;
2970 case want_vtbl_regdata:
2971 result = &PL_vtbl_regdata;
2972 break;
2973 case want_vtbl_regdatum:
2974 result = &PL_vtbl_regdatum;
2975 break;
3c90161d 2976#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 2977 case want_vtbl_collxfrm:
2978 result = &PL_vtbl_collxfrm;
2979 break;
3c90161d 2980#endif
dc9e4912
GS		 2981 case want_vtbl_amagic:
2982 result = &PL_vtbl_amagic;
2983 break;
2984 case want_vtbl_amagicelem:
2985 result = &PL_vtbl_amagicelem;
2986 break;
810b8aa5
GS		 2987 case want_vtbl_backref:
2988 result = &PL_vtbl_backref;
2989 break;
7e8c5dac
HS		 2990 case want_vtbl_utf8:
2991 result = &PL_vtbl_utf8;
2992 break;
dc9e4912
GS		 2993 }
2994 return result;
2995}
2996
767df6a1 2997I32
864dbfa3 2998Perl_my_fflush_all(pTHX)
767df6a1 2999{
f800e14d 3000#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3001 return PerlIO_flush(NULL);
767df6a1 3002#else
8fbdfb7c 3003# if defined(HAS__FWALK)
f13a2bc0 3004 extern int fflush(FILE *);
74cac757
JH		 3005 /* undocumented, unprototyped, but very useful BSDism */
3006 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3007 _fwalk(&fflush);
74cac757 3008 return 0;
8fa7f367 3009# else
8fbdfb7c 3010# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3011 long open_max = -1;
8fbdfb7c 3012# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3013 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3014# else
8fa7f367 3015# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3016 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3017# else
3018# ifdef FOPEN_MAX
74cac757 3019 open_max = FOPEN_MAX;
8fa7f367
JH		 3020# else
3021# ifdef OPEN_MAX
74cac757 3022 open_max = OPEN_MAX;
8fa7f367
JH		 3023# else
3024# ifdef _NFILE
d2201af2 3025 open_max = _NFILE;
8fa7f367
JH		 3026# endif
3027# endif
74cac757 3028# endif
767df6a1
JH		 3029# endif
3030# endif
767df6a1
JH		 3031 if (open_max > 0) {
3032 long i;
3033 for (i = 0; i < open_max; i++)
d2201af2
AD		 3034 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3035 STDIO_STREAM_ARRAY[i]._file < open_max &&
3036 STDIO_STREAM_ARRAY[i]._flag)
3037 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3038 return 0;
3039 }
8fbdfb7c 3040# endif
93189314 3041 SETERRNO(EBADF,RMS_IFI);
767df6a1 3042 return EOF;
74cac757 3043# endif
767df6a1
JH		 3044#endif
3045}
097ee67d 3046
69282e91 3047void
bc37a18f
RG		 3048Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3049{
bc37a18f 3050 char *func =
66fc2fa5
JH		 3051 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3052 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
bc37a18f
RG		 3053 PL_op_desc[op];
3054 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3aed30dc
HS		 3055 char *type = OP_IS_SOCKET(op)
3056 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3057 ? "socket" : "filehandle";
9c0fcd4f 3058 char *name = NULL;
bc37a18f 3059
66fc2fa5 3060 if (gv && isGV(gv)) {
f62cb720 3061 name = GvENAME(gv);
66fc2fa5
JH		 3062 }
3063
4c80c0b2 3064 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3065 if (ckWARN(WARN_IO)) {
fd322ea4 3066 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3aed30dc
HS		 3067 if (name && *name)
3068 Perl_warner(aTHX_ packWARN(WARN_IO),
3069 "Filehandle %s opened only for %sput",
fd322ea4 3070 name, direction);
3aed30dc
HS		 3071 else
3072 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3073 "Filehandle opened only for %sput", direction);
3aed30dc 3074 }
2dd78f96
JH		 3075 }
3076 else {
3aed30dc
HS		 3077 char *vile;
3078 I32 warn_type;
3079
3080 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3081 vile = "closed";
3082 warn_type = WARN_CLOSED;
3083 }
3084 else {
3085 vile = "unopened";
3086 warn_type = WARN_UNOPENED;
3087 }
3088
3089 if (ckWARN(warn_type)) {
3090 if (name && *name) {
3091 Perl_warner(aTHX_ packWARN(warn_type),
3092 "%s%s on %s %s %s", func, pars, vile, type, name);
3093 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3094 Perl_warner(
3095 aTHX_ packWARN(warn_type),
3096 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3097 func, pars, name
3098 );
3099 }
3100 else {
3101 Perl_warner(aTHX_ packWARN(warn_type),
3102 "%s%s on %s %s", func, pars, vile, type);
3103 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3104 Perl_warner(
3105 aTHX_ packWARN(warn_type),
3106 "\t(Are you trying to call %s%s on dirhandle?)\n",
3107 func, pars
3108 );
3109 }
3110 }
bc37a18f 3111 }
69282e91 3112}
a926ef6b
JH		 3113
3114#ifdef EBCDIC
cbebf344
JH		 3115/* in ASCII order, not that it matters */
3116static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3117
a926ef6b
JH		 3118int
3119Perl_ebcdic_control(pTHX_ int ch)
3120{
3aed30dc
HS		 3121 if (ch > 'a') {
3122 char *ctlp;
3123
3124 if (islower(ch))
3125 ch = toupper(ch);
3126
3127 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3128 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3129 }
3aed30dc
HS		 3130
3131 if (ctlp == controllablechars)
3132 return('\177'); /* DEL */
3133 else
3134 return((unsigned char)(ctlp - controllablechars - 1));
3135 } else { /* Want uncontrol */
3136 if (ch == '\177' || ch == -1)
3137 return('?');
3138 else if (ch == '\157')
3139 return('\177');
3140 else if (ch == '\174')
3141 return('\000');
3142 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3143 return('\036');
3144 else if (ch == '\155')
3145 return('\037');
3146 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3147 return(controllablechars[ch+1]);
3148 else
3149 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3150 }
a926ef6b
JH		 3151}
3152#endif
e72cf795 3153
f6adc668 3154/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3155 * system to give us a reasonable struct to copy. This fix means that
3156 * strftime uses the tm_zone and tm_gmtoff values returned by
3157 * localtime(time()). That should give the desired result most of the
3158 * time. But probably not always!
3159 *
f6adc668
JH		 3160 * This does not address tzname aspects of NETaa14816.
3161 *
e72cf795 3162 */
f6adc668 3163
e72cf795
JH		 3164#ifdef HAS_GNULIBC
3165# ifndef STRUCT_TM_HASZONE
3166# define STRUCT_TM_HASZONE
3167# endif
3168#endif
3169
f6adc668
JH		 3170#ifdef STRUCT_TM_HASZONE /* Backward compat */
3171# ifndef HAS_TM_TM_ZONE
3172# define HAS_TM_TM_ZONE
3173# endif
3174#endif
3175
e72cf795 3176void
f1208910 3177Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3178{
f6adc668 3179#ifdef HAS_TM_TM_ZONE
e72cf795
JH		 3180 Time_t now;
3181 (void)time(&now);
3182 Copy(localtime(&now), ptm, 1, struct tm);
3183#endif
3184}
3185
3186/*
3187 * mini_mktime - normalise struct tm values without the localtime()
3188 * semantics (and overhead) of mktime().
3189 */
3190void
f1208910 3191Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3192{
3193 int yearday;
3194 int secs;
3195 int month, mday, year, jday;
3196 int odd_cent, odd_year;
3197
3198#define DAYS_PER_YEAR 365
3199#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3200#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3201#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3202#define SECS_PER_HOUR (60*60)
3203#define SECS_PER_DAY (24*SECS_PER_HOUR)
3204/* parentheses deliberately absent on these two, otherwise they don't work */
3205#define MONTH_TO_DAYS 153/5
3206#define DAYS_TO_MONTH 5/153
3207/* offset to bias by March (month 4) 1st between month/mday & year finding */
3208#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3209/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3210#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3211
3212/*
3213 * Year/day algorithm notes:
3214 *
3215 * With a suitable offset for numeric value of the month, one can find
3216 * an offset into the year by considering months to have 30.6 (153/5) days,
3217 * using integer arithmetic (i.e., with truncation). To avoid too much
3218 * messing about with leap days, we consider January and February to be
3219 * the 13th and 14th month of the previous year. After that transformation,
3220 * we need the month index we use to be high by 1 from 'normal human' usage,
3221 * so the month index values we use run from 4 through 15.
3222 *
3223 * Given that, and the rules for the Gregorian calendar (leap years are those
3224 * divisible by 4 unless also divisible by 100, when they must be divisible
3225 * by 400 instead), we can simply calculate the number of days since some
3226 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3227 * the days we derive from our month index, and adding in the day of the
3228 * month. The value used here is not adjusted for the actual origin which
3229 * it normally would use (1 January A.D. 1), since we're not exposing it.
3230 * We're only building the value so we can turn around and get the
3231 * normalised values for the year, month, day-of-month, and day-of-year.
3232 *
3233 * For going backward, we need to bias the value we're using so that we find
3234 * the right year value. (Basically, we don't want the contribution of
3235 * March 1st to the number to apply while deriving the year). Having done
3236 * that, we 'count up' the contribution to the year number by accounting for
3237 * full quadracenturies (400-year periods) with their extra leap days, plus
3238 * the contribution from full centuries (to avoid counting in the lost leap
3239 * days), plus the contribution from full quad-years (to count in the normal
3240 * leap days), plus the leftover contribution from any non-leap years.
3241 * At this point, if we were working with an actual leap day, we'll have 0
3242 * days left over. This is also true for March 1st, however. So, we have
3243 * to special-case that result, and (earlier) keep track of the 'odd'
3244 * century and year contributions. If we got 4 extra centuries in a qcent,
3245 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3246 * Otherwise, we add back in the earlier bias we removed (the 123 from
3247 * figuring in March 1st), find the month index (integer division by 30.6),
3248 * and the remainder is the day-of-month. We then have to convert back to
3249 * 'real' months (including fixing January and February from being 14/15 in
3250 * the previous year to being in the proper year). After that, to get
3251 * tm_yday, we work with the normalised year and get a new yearday value for
3252 * January 1st, which we subtract from the yearday value we had earlier,
3253 * representing the date we've re-built. This is done from January 1
3254 * because tm_yday is 0-origin.
3255 *
3256 * Since POSIX time routines are only guaranteed to work for times since the
3257 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3258 * applies Gregorian calendar rules even to dates before the 16th century
3259 * doesn't bother me. Besides, you'd need cultural context for a given
3260 * date to know whether it was Julian or Gregorian calendar, and that's
3261 * outside the scope for this routine. Since we convert back based on the
3262 * same rules we used to build the yearday, you'll only get strange results
3263 * for input which needed normalising, or for the 'odd' century years which
3264 * were leap years in the Julian calander but not in the Gregorian one.
3265 * I can live with that.
3266 *
3267 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3268 * that's still outside the scope for POSIX time manipulation, so I don't
3269 * care.
3270 */
3271
3272 year = 1900 + ptm->tm_year;
3273 month = ptm->tm_mon;
3274 mday = ptm->tm_mday;
3275 /* allow given yday with no month & mday to dominate the result */
3276 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3277 month = 0;
3278 mday = 0;
3279 jday = 1 + ptm->tm_yday;
3280 }
3281 else {
3282 jday = 0;
3283 }
3284 if (month >= 2)
3285 month+=2;
3286 else
3287 month+=14, year--;
3288 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3289 yearday += month*MONTH_TO_DAYS + mday + jday;
3290 /*
3291 * Note that we don't know when leap-seconds were or will be,
3292 * so we have to trust the user if we get something which looks
3293 * like a sensible leap-second. Wild values for seconds will
3294 * be rationalised, however.
3295 */
3296 if ((unsigned) ptm->tm_sec <= 60) {
3297 secs = 0;
3298 }
3299 else {
3300 secs = ptm->tm_sec;
3301 ptm->tm_sec = 0;
3302 }
3303 secs += 60 * ptm->tm_min;
3304 secs += SECS_PER_HOUR * ptm->tm_hour;
3305 if (secs < 0) {
3306 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3307 /* got negative remainder, but need positive time */
3308 /* back off an extra day to compensate */
3309 yearday += (secs/SECS_PER_DAY)-1;
3310 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3311 }
3312 else {
3313 yearday += (secs/SECS_PER_DAY);
3314 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3315 }
3316 }
3317 else if (secs >= SECS_PER_DAY) {
3318 yearday += (secs/SECS_PER_DAY);
3319 secs %= SECS_PER_DAY;
3320 }
3321 ptm->tm_hour = secs/SECS_PER_HOUR;
3322 secs %= SECS_PER_HOUR;
3323 ptm->tm_min = secs/60;
3324 secs %= 60;
3325 ptm->tm_sec += secs;
3326 /* done with time of day effects */
3327 /*
3328 * The algorithm for yearday has (so far) left it high by 428.
3329 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3330 * bias it by 123 while trying to figure out what year it
3331 * really represents. Even with this tweak, the reverse
3332 * translation fails for years before A.D. 0001.
3333 * It would still fail for Feb 29, but we catch that one below.
3334 */
3335 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3336 yearday -= YEAR_ADJUST;
3337 year = (yearday / DAYS_PER_QCENT) * 400;
3338 yearday %= DAYS_PER_QCENT;
3339 odd_cent = yearday / DAYS_PER_CENT;
3340 year += odd_cent * 100;
3341 yearday %= DAYS_PER_CENT;
3342 year += (yearday / DAYS_PER_QYEAR) * 4;
3343 yearday %= DAYS_PER_QYEAR;
3344 odd_year = yearday / DAYS_PER_YEAR;
3345 year += odd_year;
3346 yearday %= DAYS_PER_YEAR;
3347 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3348 month = 1;
3349 yearday = 29;
3350 }
3351 else {
3352 yearday += YEAR_ADJUST; /* recover March 1st crock */
3353 month = yearday*DAYS_TO_MONTH;
3354 yearday -= month*MONTH_TO_DAYS;
3355 /* recover other leap-year adjustment */
3356 if (month > 13) {
3357 month-=14;
3358 year++;
3359 }
3360 else {
3361 month-=2;
3362 }
3363 }
3364 ptm->tm_year = year - 1900;
3365 if (yearday) {
3366 ptm->tm_mday = yearday;
3367 ptm->tm_mon = month;
3368 }
3369 else {
3370 ptm->tm_mday = 31;
3371 ptm->tm_mon = month - 1;
3372 }
3373 /* re-build yearday based on Jan 1 to get tm_yday */
3374 year--;
3375 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3376 yearday += 14*MONTH_TO_DAYS + 1;
3377 ptm->tm_yday = jday - yearday;
3378 /* fix tm_wday if not overridden by caller */
3379 if ((unsigned)ptm->tm_wday > 6)
3380 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3381}
b3c85772
JH		 3382
3383char *
f1208910 3384Perl_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		 3385{
3386#ifdef HAS_STRFTIME
3387 char *buf;
3388 int buflen;
3389 struct tm mytm;
3390 int len;
3391
3392 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3393 mytm.tm_sec = sec;
3394 mytm.tm_min = min;
3395 mytm.tm_hour = hour;
3396 mytm.tm_mday = mday;
3397 mytm.tm_mon = mon;
3398 mytm.tm_year = year;
3399 mytm.tm_wday = wday;
3400 mytm.tm_yday = yday;
3401 mytm.tm_isdst = isdst;
3402 mini_mktime(&mytm);
c473feec
SR		 3403 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3404#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3405 STMT_START {
3406 struct tm mytm2;
3407 mytm2 = mytm;
3408 mktime(&mytm2);
3409#ifdef HAS_TM_TM_GMTOFF
3410 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3411#endif
3412#ifdef HAS_TM_TM_ZONE
3413 mytm.tm_zone = mytm2.tm_zone;
3414#endif
3415 } STMT_END;
3416#endif
b3c85772
JH		 3417 buflen = 64;
3418 New(0, buf, buflen, char);
3419 len = strftime(buf, buflen, fmt, &mytm);
3420 /*
877f6a72 3421 ** The following is needed to handle to the situation where
b3c85772
JH		 3422 ** tmpbuf overflows. Basically we want to allocate a buffer
3423 ** and try repeatedly. The reason why it is so complicated
3424 ** is that getting a return value of 0 from strftime can indicate
3425 ** one of the following:
3426 ** 1. buffer overflowed,
3427 ** 2. illegal conversion specifier, or
3428 ** 3. the format string specifies nothing to be returned(not
3429 ** an error). This could be because format is an empty string
3430 ** or it specifies %p that yields an empty string in some locale.
3431 ** If there is a better way to make it portable, go ahead by
3432 ** all means.
3433 */
3434 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3435 return buf;
3436 else {
3437 /* Possibly buf overflowed - try again with a bigger buf */
3438 int fmtlen = strlen(fmt);
3439 int bufsize = fmtlen + buflen;
877f6a72 3440
b3c85772
JH		 3441 New(0, buf, bufsize, char);
3442 while (buf) {
3443 buflen = strftime(buf, bufsize, fmt, &mytm);
3444 if (buflen > 0 && buflen < bufsize)
3445 break;
3446 /* heuristic to prevent out-of-memory errors */
3447 if (bufsize > 100*fmtlen) {
3448 Safefree(buf);
3449 buf = NULL;
3450 break;
3451 }
3452 bufsize *= 2;
3453 Renew(buf, bufsize, char);
3454 }
3455 return buf;
3456 }
3457#else
3458 Perl_croak(aTHX_ "panic: no strftime");
3459#endif
3460}
3461
877f6a72
NIS		 3462
3463#define SV_CWD_RETURN_UNDEF \
3464sv_setsv(sv, &PL_sv_undef); \
3465return FALSE
3466
3467#define SV_CWD_ISDOT(dp) \
3468 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3469 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3470
3471/*
ccfc67b7
JH		 3472=head1 Miscellaneous Functions
3473
89423764 3474=for apidoc getcwd_sv
877f6a72
NIS		 3475
3476Fill the sv with current working directory
3477
3478=cut
3479*/
3480
3481/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3482 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3483 * getcwd(3) if available
3484 * Comments from the orignal:
3485 * This is a faster version of getcwd. It's also more dangerous
3486 * because you might chdir out of a directory that you can't chdir
3487 * back into. */
3488
877f6a72 3489int
89423764 3490Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3491{
3492#ifndef PERL_MICRO
3493
ea715489
JH		 3494#ifndef INCOMPLETE_TAINTS
3495 SvTAINTED_on(sv);
3496#endif
3497
8f95b30d
JH		 3498#ifdef HAS_GETCWD
3499 {
60e110a8
DM		 3500 char buf[MAXPATHLEN];
3501
3aed30dc 3502 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3503 * size from the heap if they are given a NULL buffer pointer.
3504 * The problem is that this behaviour is not portable. */
3aed30dc
HS		 3505 if (getcwd(buf, sizeof(buf) - 1)) {
3506 STRLEN len = strlen(buf);
3507 sv_setpvn(sv, buf, len);
3508 return TRUE;
3509 }
3510 else {
3511 sv_setsv(sv, &PL_sv_undef);
3512 return FALSE;
3513 }
8f95b30d
JH		 3514 }
3515
3516#else
3517
c623ac67 3518 Stat_t statbuf;
877f6a72
NIS		 3519 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3520 int namelen, pathlen=0;
3521 DIR *dir;
3522 Direntry_t *dp;
877f6a72
NIS		 3523
3524 (void)SvUPGRADE(sv, SVt_PV);
3525
877f6a72 3526 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3527 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3528 }
3529
3530 orig_cdev = statbuf.st_dev;
3531 orig_cino = statbuf.st_ino;
3532 cdev = orig_cdev;
3533 cino = orig_cino;
3534
3535 for (;;) {
3aed30dc
HS		 3536 odev = cdev;
3537 oino = cino;
3538
3539 if (PerlDir_chdir("..") < 0) {
3540 SV_CWD_RETURN_UNDEF;
3541 }
3542 if (PerlLIO_stat(".", &statbuf) < 0) {
3543 SV_CWD_RETURN_UNDEF;
3544 }
3545
3546 cdev = statbuf.st_dev;
3547 cino = statbuf.st_ino;
3548
3549 if (odev == cdev && oino == cino) {
3550 break;
3551 }
3552 if (!(dir = PerlDir_open("."))) {
3553 SV_CWD_RETURN_UNDEF;
3554 }
3555
3556 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3557#ifdef DIRNAMLEN
3aed30dc 3558 namelen = dp->d_namlen;
877f6a72 3559#else
3aed30dc 3560 namelen = strlen(dp->d_name);
877f6a72 3561#endif
3aed30dc
HS		 3562 /* skip . and .. */
3563 if (SV_CWD_ISDOT(dp)) {
3564 continue;
3565 }
3566
3567 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3568 SV_CWD_RETURN_UNDEF;
3569 }
3570
3571 tdev = statbuf.st_dev;
3572 tino = statbuf.st_ino;
3573 if (tino == oino && tdev == odev) {
3574 break;
3575 }
cb5953d6
JH		 3576 }
3577
3aed30dc
HS		 3578 if (!dp) {
3579 SV_CWD_RETURN_UNDEF;
3580 }
3581
3582 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3583 SV_CWD_RETURN_UNDEF;
3584 }
877f6a72 3585
3aed30dc
HS		 3586 SvGROW(sv, pathlen + namelen + 1);
3587
3588 if (pathlen) {
3589 /* shift down */
3590 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3591 }
877f6a72 3592
3aed30dc
HS		 3593 /* prepend current directory to the front */
3594 *SvPVX(sv) = '/';
3595 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3596 pathlen += (namelen + 1);
877f6a72
NIS		 3597
3598#ifdef VOID_CLOSEDIR
3aed30dc 3599 PerlDir_close(dir);
877f6a72 3600#else
3aed30dc
HS		 3601 if (PerlDir_close(dir) < 0) {
3602 SV_CWD_RETURN_UNDEF;
3603 }
877f6a72
NIS		 3604#endif
3605 }
3606
60e110a8 3607 if (pathlen) {
3aed30dc
HS		 3608 SvCUR_set(sv, pathlen);
3609 *SvEND(sv) = '\0';
3610 SvPOK_only(sv);
877f6a72 3611
2a45baea 3612 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3aed30dc
HS		 3613 SV_CWD_RETURN_UNDEF;
3614 }
877f6a72
NIS		 3615 }
3616 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 3617 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3618 }
3619
3620 cdev = statbuf.st_dev;
3621 cino = statbuf.st_ino;
3622
3623 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 3624 Perl_croak(aTHX_ "Unstable directory path, "
3625 "current directory changed unexpectedly");
877f6a72 3626 }
877f6a72
NIS		 3627
3628 return TRUE;
793b8d8e
JH		 3629#endif
3630
877f6a72
NIS		 3631#else
3632 return FALSE;
3633#endif
3634}
3635
f4758303 3636/*
b0f01acb
JP		 3637=for apidoc scan_version
3638
3639Returns a pointer to the next character after the parsed
3640version string, as well as upgrading the passed in SV to
3641an RV.
3642
3643Function must be called with an already existing SV like
3644
3645 sv = NEWSV(92,0);
3646 s = scan_version(s,sv);
3647
3648Performs some preprocessing to the string to ensure that
3649it has the correct characteristics of a version. Flags the
3650object if it contains an underscore (which denotes this
3651is a beta version).
3652
3653=cut
3654*/
3655
3656char *
ad63d80f 3657Perl_scan_version(pTHX_ char *s, SV *rv)
b0f01acb 3658{
e568f1a0 3659 const char *start = s;
ad63d80f
JP		 3660 char *pos = s;
3661 I32 saw_period = 0;
3662 bool saw_under = 0;
be2ebcad 3663 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
ad63d80f
JP		 3664 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
3665
3666 /* pre-scan the imput string to check for decimals */
3667 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3668 {
3669 if ( *pos == '.' )
3670 {
3671 if ( saw_under )
5f89c282 3672 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 3673 saw_period++ ;
46314c13 3674 }
ad63d80f
JP		 3675 else if ( *pos == '_' )
3676 {
3677 if ( saw_under )
5f89c282 3678 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
ad63d80f
JP		 3679 saw_under = 1;
3680 }
3681 pos++;
3682 }
3683 pos = s;
3684
3685 if (*pos == 'v') pos++; /* get past 'v' */
3686 while (isDIGIT(*pos))
46314c13 3687 pos++;
ad63d80f
JP		 3688 if (!isALPHA(*pos)) {
3689 I32 rev;
3690
3691 if (*s == 'v') s++; /* get past 'v' */
3692
3693 for (;;) {
3694 rev = 0;
3695 {
129318bd
JP		 3696 /* this is atoi() that delimits on underscores */
3697 char *end = pos;
3698 I32 mult = 1;
3699 I32 orev;
3700 if ( s < pos && s > start && *(s-1) == '_' ) {
3701 mult *= -1; /* beta version */
3702 }
3703 /* the following if() will only be true after the decimal
3704 * point of a version originally created with a bare
3705 * floating point number, i.e. not quoted in any way
3706 */
3707 if ( s > start+1 && saw_period == 1 && !saw_under ) {
3708 mult = 100;
3709 while ( s < end ) {
3710 orev = rev;
3711 rev += (*s - '0') * mult;
3712 mult /= 10;
32fdb065 3713 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3714 Perl_croak(aTHX_ "Integer overflow in version");
3715 s++;
3716 }
3717 }
3718 else {
3719 while (--end >= s) {
3720 orev = rev;
3721 rev += (*end - '0') * mult;
3722 mult *= 10;
32fdb065 3723 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3724 Perl_croak(aTHX_ "Integer overflow in version");
3725 }
3726 }
3727 }
3728
3729 /* Append revision */
ad63d80f
JP		 3730 av_push((AV *)sv, newSViv(rev));
3731 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3732 s = ++pos;
3733 else if ( isDIGIT(*pos) )
3734 s = pos;
b0f01acb 3735 else {
ad63d80f
JP		 3736 s = pos;
3737 break;
3738 }
3739 while ( isDIGIT(*pos) ) {
46314c13 3740 if ( !saw_under && saw_period == 1 && pos-s == 3 )
ad63d80f
JP		 3741 break;
3742 pos++;
b0f01acb
JP		 3743 }
3744 }
3745 }
ad63d80f 3746 return s;
b0f01acb
JP		 3747}
3748
3749/*
3750=for apidoc new_version
3751
3752Returns a new version object based on the passed in SV:
3753
3754 SV *sv = new_version(SV *ver);
3755
3756Does not alter the passed in ver SV. See "upg_version" if you
3757want to upgrade the SV.
3758
3759=cut
3760*/
3761
3762SV *
3763Perl_new_version(pTHX_ SV *ver)
3764{
129318bd 3765 SV *rv = newSV(0);
26ec6fc3
JP		 3766 char *version;
3767 if ( SvNOK(ver) ) /* may get too much accuracy */
3768 {
3769 char tbuf[64];
3770 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
3771 version = savepv(tbuf);
3772 }
ad63d80f 3773#ifdef SvVOK
26ec6fc3 3774 else if ( SvVOK(ver) ) { /* already a v-string */
b0f01acb
JP		 3775 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3776 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
3777 }
ad63d80f 3778#endif
129318bd 3779 else /* must be a string or something like a string */
26ec6fc3
JP		 3780 {
3781 version = (char *)SvPV(ver,PL_na);
3782 }
b0f01acb
JP		 3783 version = scan_version(version,rv);
3784 return rv;
3785}
3786
3787/*
3788=for apidoc upg_version
3789
3790In-place upgrade of the supplied SV to a version object.
3791
3792 SV *sv = upg_version(SV *sv);
3793
3794Returns a pointer to the upgraded SV.
3795
3796=cut
3797*/
3798
3799SV *
ad63d80f 3800Perl_upg_version(pTHX_ SV *ver)
b0f01acb 3801{
ad63d80f
JP		 3802 char *version = savepvn(SvPVX(ver),SvCUR(ver));
3803#ifdef SvVOK
3804 if ( SvVOK(ver) ) { /* already a v-string */
3805 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3806 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
b0f01acb 3807 }
ad63d80f
JP		 3808#endif
3809 version = scan_version(version,ver);
3810 return ver;
b0f01acb
JP		 3811}
3812
3813
3814/*
3815=for apidoc vnumify
3816
ad63d80f
JP		 3817Accepts a version object and returns the normalized floating
3818point representation. Call like:
b0f01acb 3819
ad63d80f 3820 sv = vnumify(rv);
b0f01acb 3821
ad63d80f
JP		 3822NOTE: you can pass either the object directly or the SV
3823contained within the RV.
b0f01acb
JP		 3824
3825=cut
3826*/
3827
3828SV *
ad63d80f 3829Perl_vnumify(pTHX_ SV *vs)
b0f01acb 3830{
ad63d80f
JP		 3831 I32 i, len, digit;
3832 SV *sv = NEWSV(92,0);
3833 if ( SvROK(vs) )
3834 vs = SvRV(vs);
3835 len = av_len((AV *)vs);
46314c13
JP		 3836 if ( len == -1 )
3837 {
3838 Perl_sv_catpv(aTHX_ sv,"0");
3839 return sv;
3840 }
ad63d80f 3841 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
32fdb065 3842 Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit));
ad63d80f 3843 for ( i = 1 ; i <= len ; i++ )
b0f01acb 3844 {
ad63d80f 3845 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
32fdb065 3846 Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit));
b0f01acb 3847 }
ad63d80f
JP		 3848 if ( len == 0 )
3849 Perl_sv_catpv(aTHX_ sv,"000");
129318bd 3850 sv_setnv(sv, SvNV(sv));
b0f01acb
JP		 3851 return sv;
3852}
3853
3854/*
3855=for apidoc vstringify
3856
ad63d80f
JP		 3857Accepts a version object and returns the normalized string
3858representation. Call like:
b0f01acb 3859
ad63d80f 3860 sv = vstringify(rv);
b0f01acb 3861
ad63d80f
JP		 3862NOTE: you can pass either the object directly or the SV
3863contained within the RV.
b0f01acb
JP		 3864
3865=cut
3866*/
3867
3868SV *
ad63d80f 3869Perl_vstringify(pTHX_ SV *vs)
b0f01acb 3870{
ad63d80f
JP		 3871 I32 i, len, digit;
3872 SV *sv = NEWSV(92,0);
3873 if ( SvROK(vs) )
3874 vs = SvRV(vs);
3875 len = av_len((AV *)vs);
46314c13
JP		 3876 if ( len == -1 )
3877 {
3878 Perl_sv_catpv(aTHX_ sv,"");
3879 return sv;
3880 }
ad63d80f 3881 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
e3feee4e 3882 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
ad63d80f 3883 for ( i = 1 ; i <= len ; i++ )
46314c13 3884 {
ad63d80f
JP		 3885 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
3886 if ( digit < 0 )
e3feee4e 3887 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
ad63d80f 3888 else
e3feee4e 3889 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
b0f01acb 3890 }
ad63d80f
JP		 3891 if ( len == 0 )
3892 Perl_sv_catpv(aTHX_ sv,".0");
b0f01acb 3893 return sv;
129318bd 3894}
b0f01acb 3895
ad63d80f
JP		 3896/*
3897=for apidoc vcmp
3898
3899Version object aware cmp. Both operands must already have been
3900converted into version objects.
3901
3902=cut
3903*/
3904
3905int
3906Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
3907{
3908 I32 i,l,m,r,retval;
3909 if ( SvROK(lsv) )
3910 lsv = SvRV(lsv);
3911 if ( SvROK(rsv) )
3912 rsv = SvRV(rsv);
3913 l = av_len((AV *)lsv);
3914 r = av_len((AV *)rsv);
3915 m = l < r ? l : r;
3916 retval = 0;
3917 i = 0;
3918 while ( i <= m && retval == 0 )
3919 {
3920 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
3921 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
3922 bool lbeta = left < 0 ? 1 : 0;
3923 bool rbeta = right < 0 ? 1 : 0;
32fdb065
JH		 3924 left = PERL_ABS(left);
3925 right = PERL_ABS(right);
ad63d80f
JP		 3926 if ( left < right || (left == right && lbeta && !rbeta) )
3927 retval = -1;
3928 if ( left > right || (left == right && rbeta && !lbeta) )
3929 retval = +1;
3930 i++;
3931 }
3932
129318bd
JP		 3933 if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
3934 {
3935 if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
3936 !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
3937 {
3938 retval = l < r ? -1 : +1; /* not a match after all */
3939 }
3940 }
ad63d80f
JP		 3941 return retval;
3942}
3943
c95c94b1 3944#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 3945# define EMULATE_SOCKETPAIR_UDP
3946#endif
3947
3948#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 3949static int
3950S_socketpair_udp (int fd[2]) {
e10bb1e9 3951 dTHX;
02fc2eee
NC		 3952 /* Fake a datagram socketpair using UDP to localhost. */
3953 int sockets[2] = {-1, -1};
3954 struct sockaddr_in addresses[2];
3955 int i;
3aed30dc 3956 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 3957 unsigned short port;
02fc2eee
NC		 3958 int got;
3959
3aed30dc 3960 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 3961 i = 1;
3962 do {
3aed30dc
HS		 3963 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
3964 if (sockets[i] == -1)
3965 goto tidy_up_and_fail;
3966
3967 addresses[i].sin_family = AF_INET;
3968 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
3969 addresses[i].sin_port = 0; /* kernel choses port. */
3970 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
3971 sizeof(struct sockaddr_in)) == -1)
3972 goto tidy_up_and_fail;
02fc2eee
NC		 3973 } while (i--);
3974
3975 /* Now have 2 UDP sockets. Find out which port each is connected to, and
3976 for each connect the other socket to it. */
3977 i = 1;
3978 do {
3aed30dc
HS		 3979 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
3980 &size) == -1)
3981 goto tidy_up_and_fail;
3982 if (size != sizeof(struct sockaddr_in))
3983 goto abort_tidy_up_and_fail;
3984 /* !1 is 0, !0 is 1 */
3985 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
3986 sizeof(struct sockaddr_in)) == -1)
3987 goto tidy_up_and_fail;
02fc2eee
NC		 3988 } while (i--);
3989
3990 /* Now we have 2 sockets connected to each other. I don't trust some other
3991 process not to have already sent a packet to us (by random) so send
3992 a packet from each to the other. */
3993 i = 1;
3994 do {
3aed30dc
HS		 3995 /* I'm going to send my own port number. As a short.
3996 (Who knows if someone somewhere has sin_port as a bitfield and needs
3997 this routine. (I'm assuming crays have socketpair)) */
3998 port = addresses[i].sin_port;
3999 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4000 if (got != sizeof(port)) {
4001 if (got == -1)
4002 goto tidy_up_and_fail;
4003 goto abort_tidy_up_and_fail;
4004 }
02fc2eee
NC		 4005 } while (i--);
4006
4007 /* Packets sent. I don't trust them to have arrived though.
4008 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4009 connect to localhost will use a second kernel thread. In 2.6 the
4010 first thread running the connect() returns before the second completes,
4011 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4012 returns 0. Poor programs have tripped up. One poor program's authors'
4013 had a 50-1 reverse stock split. Not sure how connected these were.)
4014 So I don't trust someone not to have an unpredictable UDP stack.
4015 */
4016
4017 {
3aed30dc
HS		 4018 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4019 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4020 fd_set rset;
4021
4022 FD_ZERO(&rset);
4023 FD_SET(sockets[0], &rset);
4024 FD_SET(sockets[1], &rset);
4025
4026 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4027 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4028 || !FD_ISSET(sockets[1], &rset)) {
4029 /* I hope this is portable and appropriate. */
4030 if (got == -1)
4031 goto tidy_up_and_fail;
4032 goto abort_tidy_up_and_fail;
4033 }
02fc2eee 4034 }
f4758303 4035
02fc2eee
NC		 4036 /* And the paranoia department even now doesn't trust it to have arrive
4037 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4038 {
3aed30dc
HS		 4039 struct sockaddr_in readfrom;
4040 unsigned short buffer[2];
02fc2eee 4041
3aed30dc
HS		 4042 i = 1;
4043 do {
02fc2eee 4044#ifdef MSG_DONTWAIT
3aed30dc
HS		 4045 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4046 sizeof(buffer), MSG_DONTWAIT,
4047 (struct sockaddr *) &readfrom, &size);
02fc2eee 4048#else
3aed30dc
HS		 4049 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4050 sizeof(buffer), 0,
4051 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4052#endif
02fc2eee 4053
3aed30dc
HS		 4054 if (got == -1)
4055 goto tidy_up_and_fail;
4056 if (got != sizeof(port)
4057 || size != sizeof(struct sockaddr_in)
4058 /* Check other socket sent us its port. */
4059 || buffer[0] != (unsigned short) addresses[!i].sin_port
4060 /* Check kernel says we got the datagram from that socket */
4061 || readfrom.sin_family != addresses[!i].sin_family
4062 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4063 || readfrom.sin_port != addresses[!i].sin_port)
4064 goto abort_tidy_up_and_fail;
4065 } while (i--);
02fc2eee
NC		 4066 }
4067 /* My caller (my_socketpair) has validated that this is non-NULL */
4068 fd[0] = sockets[0];
4069 fd[1] = sockets[1];
4070 /* I hereby declare this connection open. May God bless all who cross
4071 her. */
4072 return 0;
4073
4074 abort_tidy_up_and_fail:
4075 errno = ECONNABORTED;
4076 tidy_up_and_fail:
4077 {
3aed30dc
HS		 4078 int save_errno = errno;
4079 if (sockets[0] != -1)
4080 PerlLIO_close(sockets[0]);
4081 if (sockets[1] != -1)
4082 PerlLIO_close(sockets[1]);
4083 errno = save_errno;
4084 return -1;
02fc2eee
NC		 4085 }
4086}
85ca448a 4087#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4088
b5ac89c3 4089#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4090int
4091Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4092 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4093 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4094 dTHX;
02fc2eee
NC		 4095 int listener = -1;
4096 int connector = -1;
4097 int acceptor = -1;
4098 struct sockaddr_in listen_addr;
4099 struct sockaddr_in connect_addr;
4100 Sock_size_t size;
4101
50458334
JH		 4102 if (protocol
4103#ifdef AF_UNIX
4104 || family != AF_UNIX
4105#endif
3aed30dc
HS		 4106 ) {
4107 errno = EAFNOSUPPORT;
4108 return -1;
02fc2eee 4109 }
2948e0bd 4110 if (!fd) {
3aed30dc
HS		 4111 errno = EINVAL;
4112 return -1;
2948e0bd 4113 }
02fc2eee 4114
2bc69dc4 4115#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4116 if (type == SOCK_DGRAM)
3aed30dc 4117 return S_socketpair_udp(fd);
2bc69dc4 4118#endif
02fc2eee 4119
3aed30dc 4120 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4121 if (listener == -1)
3aed30dc
HS		 4122 return -1;
4123 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4124 listen_addr.sin_family = AF_INET;
3aed30dc 4125 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4126 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4127 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4128 sizeof(listen_addr)) == -1)
4129 goto tidy_up_and_fail;
e10bb1e9 4130 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4131 goto tidy_up_and_fail;
02fc2eee 4132
3aed30dc 4133 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4134 if (connector == -1)
3aed30dc 4135 goto tidy_up_and_fail;
02fc2eee 4136 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4137 size = sizeof(connect_addr);
4138 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4139 &size) == -1)
4140 goto tidy_up_and_fail;
4141 if (size != sizeof(connect_addr))
4142 goto abort_tidy_up_and_fail;
e10bb1e9 4143 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4144 sizeof(connect_addr)) == -1)
4145 goto tidy_up_and_fail;
02fc2eee 4146
3aed30dc
HS		 4147 size = sizeof(listen_addr);
4148 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4149 &size);
02fc2eee 4150 if (acceptor == -1)
3aed30dc
HS		 4151 goto tidy_up_and_fail;
4152 if (size != sizeof(listen_addr))
4153 goto abort_tidy_up_and_fail;
4154 PerlLIO_close(listener);
02fc2eee
NC		 4155 /* Now check we are talking to ourself by matching port and host on the
4156 two sockets. */
3aed30dc
HS		 4157 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4158 &size) == -1)
4159 goto tidy_up_and_fail;
4160 if (size != sizeof(connect_addr)
4161 || listen_addr.sin_family != connect_addr.sin_family
4162 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4163 || listen_addr.sin_port != connect_addr.sin_port) {
4164 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4165 }
4166 fd[0] = connector;
4167 fd[1] = acceptor;
4168 return 0;
4169
4170 abort_tidy_up_and_fail:
85ca448a 4171 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
02fc2eee
NC		 4172 tidy_up_and_fail:
4173 {
3aed30dc
HS		 4174 int save_errno = errno;
4175 if (listener != -1)
4176 PerlLIO_close(listener);
4177 if (connector != -1)
4178 PerlLIO_close(connector);
4179 if (acceptor != -1)
4180 PerlLIO_close(acceptor);
4181 errno = save_errno;
4182 return -1;
02fc2eee
NC		 4183 }
4184}
85ca448a 4185#else
48ea76d1
JH		 4186/* In any case have a stub so that there's code corresponding
4187 * to the my_socketpair in global.sym. */
4188int
4189Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4190#ifdef HAS_SOCKETPAIR
48ea76d1 4191 return socketpair(family, type, protocol, fd);
daf16542
JH		 4192#else
4193 return -1;
4194#endif
48ea76d1
JH		 4195}
4196#endif
4197
68795e93
NIS		 4198/*
4199
4200=for apidoc sv_nosharing
4201
4202Dummy routine which "shares" an SV when there is no sharing module present.
4203Exists to avoid test for a NULL function pointer and because it could potentially warn under
4204some level of strict-ness.
4205
4206=cut
4207*/
4208
4209void
4210Perl_sv_nosharing(pTHX_ SV *sv)
4211{
4212}
4213
4214/*
4215=for apidoc sv_nolocking
4216
4217Dummy routine which "locks" an SV when there is no locking module present.
4218Exists to avoid test for a NULL function pointer and because it could potentially warn under
4219some level of strict-ness.
4220
4221=cut
4222*/
4223
4224void
4225Perl_sv_nolocking(pTHX_ SV *sv)
4226{
4227}
4228
4229
4230/*
4231=for apidoc sv_nounlocking
4232
4233Dummy routine which "unlocks" an SV when there is no locking module present.
4234Exists to avoid test for a NULL function pointer and because it could potentially warn under
4235some level of strict-ness.
4236
4237=cut
4238*/
4239
4240void
4241Perl_sv_nounlocking(pTHX_ SV *sv)
4242{
4243}
4244
a05d7ebb
JH		 4245U32
4246Perl_parse_unicode_opts(pTHX_ char **popt)
4247{
4248 char *p = *popt;
4249 U32 opt = 0;
4250
4251 if (*p) {
4252 if (isDIGIT(*p)) {
4253 opt = (U32) atoi(p);
4254 while (isDIGIT(*p)) p++;
7c91f477 4255 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 4256 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4257 }
4258 else {
4259 for (; *p; p++) {
4260 switch (*p) {
4261 case PERL_UNICODE_STDIN:
4262 opt |= PERL_UNICODE_STDIN_FLAG; break;
4263 case PERL_UNICODE_STDOUT:
4264 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4265 case PERL_UNICODE_STDERR:
4266 opt |= PERL_UNICODE_STDERR_FLAG; break;
4267 case PERL_UNICODE_STD:
4268 opt |= PERL_UNICODE_STD_FLAG; break;
4269 case PERL_UNICODE_IN:
4270 opt |= PERL_UNICODE_IN_FLAG; break;
4271 case PERL_UNICODE_OUT:
4272 opt |= PERL_UNICODE_OUT_FLAG; break;
4273 case PERL_UNICODE_INOUT:
4274 opt |= PERL_UNICODE_INOUT_FLAG; break;
4275 case PERL_UNICODE_LOCALE:
4276 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4277 case PERL_UNICODE_ARGV:
4278 opt |= PERL_UNICODE_ARGV_FLAG; break;
4279 default:
7c91f477
JH		 4280 if (*p != '\n' && *p != '\r')
4281 Perl_croak(aTHX_
4282 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 4283 }
4284 }
4285 }
4286 }
4287 else
4288 opt = PERL_UNICODE_DEFAULT_FLAGS;
4289
4290 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 4291 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 4292 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4293
4294 *popt = p;
4295
4296 return opt;
4297}
4298
132efe8b
JH		 4299U32
4300Perl_seed(pTHX)
4301{
4302 /*
4303 * This is really just a quick hack which grabs various garbage
4304 * values. It really should be a real hash algorithm which
4305 * spreads the effect of every input bit onto every output bit,
4306 * if someone who knows about such things would bother to write it.
4307 * Might be a good idea to add that function to CORE as well.
4308 * No numbers below come from careful analysis or anything here,
4309 * except they are primes and SEED_C1 > 1E6 to get a full-width
4310 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4311 * probably be bigger too.
4312 */
4313#if RANDBITS > 16
4314# define SEED_C1 1000003
4315#define SEED_C4 73819
4316#else
4317# define SEED_C1 25747
4318#define SEED_C4 20639
4319#endif
4320#define SEED_C2 3
4321#define SEED_C3 269
4322#define SEED_C5 26107
4323
4324#ifndef PERL_NO_DEV_RANDOM
4325 int fd;
4326#endif
4327 U32 u;
4328#ifdef VMS
4329# include <starlet.h>
4330 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4331 * in 100-ns units, typically incremented ever 10 ms. */
4332 unsigned int when[2];
4333#else
4334# ifdef HAS_GETTIMEOFDAY
4335 struct timeval when;
4336# else
4337 Time_t when;
4338# endif
4339#endif
4340
4341/* This test is an escape hatch, this symbol isn't set by Configure. */
4342#ifndef PERL_NO_DEV_RANDOM
4343#ifndef PERL_RANDOM_DEVICE
4344 /* /dev/random isn't used by default because reads from it will block
4345 * if there isn't enough entropy available. You can compile with
4346 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4347 * is enough real entropy to fill the seed. */
4348# define PERL_RANDOM_DEVICE "/dev/urandom"
4349#endif
4350 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4351 if (fd != -1) {
4352 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4353 u = 0;
4354 PerlLIO_close(fd);
4355 if (u)
4356 return u;
4357 }
4358#endif
4359
4360#ifdef VMS
4361 _ckvmssts(sys$gettim(when));
4362 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4363#else
4364# ifdef HAS_GETTIMEOFDAY
4365 PerlProc_gettimeofday(&when,NULL);
4366 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4367# else
4368 (void)time(&when);
4369 u = (U32)SEED_C1 * when;
4370# endif
4371#endif
4372 u += SEED_C3 * (U32)PerlProc_getpid();
4373 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4374#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4375 u += SEED_C5 * (U32)PTR2UV(&when);
4376#endif
4377 return u;
4378}
4379
bed60192 4380UV
a783c5f4 4381Perl_get_hash_seed(pTHX)
bed60192
JH		 4382{
4383 char *s = PerlEnv_getenv("PERL_HASH_SEED");
4384 UV myseed = 0;
4385
4386 if (s)
4387 while (isSPACE(*s)) s++;
4388 if (s && isDIGIT(*s))
4389 myseed = (UV)Atoul(s);
4390 else
4391#ifdef USE_HASH_SEED_EXPLICIT
4392 if (s)
4393#endif
4394 {
4395 /* Compute a random seed */
4396 (void)seedDrand01((Rand_seed_t)seed());
4397 PL_srand_called = TRUE;
4398 myseed = (UV)(Drand01() * (NV)UV_MAX);
4399#if RANDBITS < (UVSIZE * 8)
4400 /* Since there are not enough randbits to to reach all
4401 * the bits of a UV, the low bits might need extra
4402 * help. Sum in another random number that will
4403 * fill in the low bits. */
4404 myseed +=
4405 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4406#endif /* RANDBITS < (UVSIZE * 8) */
4407 }
4408 PL_hash_seed_set = TRUE;
4409
4410 return myseed;
4411}
Unnamed repository; edit this file 'description' to name the repository.