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