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