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