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