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