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