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