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