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