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