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