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