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