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