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