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
threads - consolidate XS functions
[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;
d13b0d77 1459 if (ckDEAD(err)) {
a3b680e6 1460 SV * const msv = vmess(pat, args);
d13b0d77 1461 STRLEN msglen;
7452cf6a 1462 const char * const message = SvPV_const(msv, msglen);
a3b680e6 1463 const I32 utf8 = SvUTF8(msv);
599cee73 1464
3aed30dc 1465 if (PL_diehook) {
63315e18 1466 assert(message);
46d9c920 1467 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
3aed30dc
HS		 1468 }
1469 if (PL_in_eval) {
1470 PL_restartop = die_where(message, msglen);
ff882698 1471 SvFLAGS(ERRSV) |= utf8;
3aed30dc
HS		 1472 JMPENV_JUMP(3);
1473 }
7ff03255 1474 write_to_stderr(message, msglen);
3aed30dc 1475 my_failure_exit();
599cee73
PM		 1476 }
1477 else {
d13b0d77 1478 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 1479 }
1480}
1481
f54ba1c2
DM		 1482/* implements the ckWARN? macros */
1483
1484bool
1485Perl_ckwarn(pTHX_ U32 w)
1486{
97aff369 1487 dVAR;
f54ba1c2
DM		 1488 return
1489 (
1490 isLEXWARN_on
1491 && PL_curcop->cop_warnings != pWARN_NONE
1492 && (
1493 PL_curcop->cop_warnings == pWARN_ALL
1494 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1495 || (unpackWARN2(w) &&
1496 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1497 || (unpackWARN3(w) &&
1498 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1499 || (unpackWARN4(w) &&
1500 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1501 )
1502 )
1503 ||
1504 (
1505 isLEXWARN_off && PL_dowarn & G_WARN_ON
1506 )
1507 ;
1508}
1509
1510/* implements the ckWARN?_d macro */
1511
1512bool
1513Perl_ckwarn_d(pTHX_ U32 w)
1514{
97aff369 1515 dVAR;
f54ba1c2
DM		 1516 return
1517 isLEXWARN_off
1518 || PL_curcop->cop_warnings == pWARN_ALL
1519 || (
1520 PL_curcop->cop_warnings != pWARN_NONE
1521 && (
1522 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1523 || (unpackWARN2(w) &&
1524 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1525 || (unpackWARN3(w) &&
1526 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1527 || (unpackWARN4(w) &&
1528 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1529 )
1530 )
1531 ;
1532}
1533
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; \
79072805 1897 register I32 i; \
1109a392
MHM		 1898 register I32 s = 0; \
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; \
79072805 1913 register I32 i; \
1109a392 1914 register I32 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; \
1935 register I32 i; \
1936 register I32 s = 8*(sizeof(u.c)-1); \
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; \
1951 register I32 i; \
1952 register I32 s = 8*(sizeof(u.c)-1); \
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;
2227 int n = 0, n1;
2228
2229 while (n < sizeof(int)) {
2230 n1 = PerlLIO_read(pp[0],
2231 (void*)(((char*)&errkid)+n),
2232 (sizeof(int)) - n);
2233 if (n1 <= 0)
2234 break;
2235 n += n1;
2236 }
2237 PerlLIO_close(pp[0]);
2238 did_pipes = 0;
2239 if (n) { /* Error */
2240 int pid2, status;
8c51524e 2241 PerlLIO_close(p[This]);
1f852d0d
NIS		 2242 if (n != sizeof(int))
2243 Perl_croak(aTHX_ "panic: kid popen errno read");
2244 do {
2245 pid2 = wait4pid(pid, &status, 0);
2246 } while (pid2 == -1 && errno == EINTR);
2247 errno = errkid; /* Propagate errno from kid */
4608196e 2248 return NULL;
1f852d0d
NIS		 2249 }
2250 }
2251 if (did_pipes)
2252 PerlLIO_close(pp[0]);
2253 return PerlIO_fdopen(p[This], mode);
2254#else
4a7d1889
NIS		 2255 Perl_croak(aTHX_ "List form of piped open not implemented");
2256 return (PerlIO *) NULL;
1f852d0d 2257#endif
4a7d1889
NIS		 2258}
2259
5f05dabc 2260 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2261#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2262PerlIO *
3dd43144 2263Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2264{
97aff369 2265 dVAR;
a687059c 2266 int p[2];
8ac85365 2267 register I32 This, that;
d8a83dd3 2268 register Pid_t pid;
79072805 2269 SV *sv;
bfce84ec 2270 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2271 I32 did_pipes = 0;
2272 int pp[2];
a687059c 2273
45bc9206 2274 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2275#ifdef OS2
2276 if (doexec) {
23da6c43 2277 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2278 }
a1d180c4 2279#endif
8ac85365
NIS		 2280 This = (*mode == 'w');
2281 that = !This;
3280af22 2282 if (doexec && PL_tainting) {
bbce6d69 2283 taint_env();
2284 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2285 }
c2267164 2286 if (PerlProc_pipe(p) < 0)
4608196e 2287 return NULL;
e446cec8
IZ		 2288 if (doexec && PerlProc_pipe(pp) >= 0)
2289 did_pipes = 1;
52e18b1f 2290 while ((pid = PerlProc_fork()) < 0) {
a687059c 2291 if (errno != EAGAIN) {
6ad3d225 2292 PerlLIO_close(p[This]);
b5ac89c3 2293 PerlLIO_close(p[that]);
e446cec8
IZ		 2294 if (did_pipes) {
2295 PerlLIO_close(pp[0]);
2296 PerlLIO_close(pp[1]);
2297 }
a687059c 2298 if (!doexec)
cea2e8a9 2299 Perl_croak(aTHX_ "Can't fork");
4608196e 2300 return NULL;
a687059c
LW		 2301 }
2302 sleep(5);
2303 }
2304 if (pid == 0) {
79072805
LW		 2305 GV* tmpgv;
2306
30ac6d9b
GS		 2307#undef THIS
2308#undef THAT
a687059c 2309#define THIS that
8ac85365 2310#define THAT This
e446cec8
IZ		 2311 if (did_pipes) {
2312 PerlLIO_close(pp[0]);
2313#if defined(HAS_FCNTL) && defined(F_SETFD)
2314 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2315#endif
2316 }
a687059c 2317 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2318 PerlLIO_dup2(p[THIS], *mode == 'r');
2319 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2320 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2321 PerlLIO_close(p[THAT]);
a687059c 2322 }
b5ac89c3
NIS		 2323 else
2324 PerlLIO_close(p[THAT]);
4435c477 2325#ifndef OS2
a687059c 2326 if (doexec) {
a0d0e21e 2327#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2328#ifndef NOFILE
2329#define NOFILE 20
2330#endif
a080fe3d 2331 {
3aed30dc 2332 int fd;
a080fe3d
NIS		 2333
2334 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2335 if (fd != pp[1])
3aed30dc 2336 PerlLIO_close(fd);
a080fe3d 2337 }
ae986130 2338#endif
a080fe3d
NIS		 2339 /* may or may not use the shell */
2340 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2341 PerlProc__exit(1);
a687059c 2342 }
4435c477 2343#endif /* defined OS2 */
fafc274c 2344 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2345 SvREADONLY_off(GvSV(tmpgv));
7766f137 2346 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2347 SvREADONLY_on(GvSV(tmpgv));
2348 }
2349#ifdef THREADS_HAVE_PIDS
2350 PL_ppid = (IV)getppid();
2351#endif
3280af22 2352 PL_forkprocess = 0;
ca0c25f6 2353#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2354 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2355#endif
4608196e 2356 return NULL;
a687059c
LW		 2357#undef THIS
2358#undef THAT
2359 }
b5ac89c3 2360 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2361 if (did_pipes)
2362 PerlLIO_close(pp[1]);
8ac85365 2363 if (p[that] < p[This]) {
6ad3d225
GS		 2364 PerlLIO_dup2(p[This], p[that]);
2365 PerlLIO_close(p[This]);
8ac85365 2366 p[This] = p[that];
62b28dd9 2367 }
b5ac89c3
NIS		 2368 else
2369 PerlLIO_close(p[that]);
2370
4755096e 2371 LOCK_FDPID_MUTEX;
3280af22 2372 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2373 UNLOCK_FDPID_MUTEX;
862a34c6 2374 SvUPGRADE(sv,SVt_IV);
45977657 2375 SvIV_set(sv, pid);
3280af22 2376 PL_forkprocess = pid;
e446cec8
IZ		 2377 if (did_pipes && pid > 0) {
2378 int errkid;
2379 int n = 0, n1;
2380
2381 while (n < sizeof(int)) {
2382 n1 = PerlLIO_read(pp[0],
2383 (void*)(((char*)&errkid)+n),
2384 (sizeof(int)) - n);
2385 if (n1 <= 0)
2386 break;
2387 n += n1;
2388 }
2f96c702
IZ		 2389 PerlLIO_close(pp[0]);
2390 did_pipes = 0;
e446cec8 2391 if (n) { /* Error */
faa466a7 2392 int pid2, status;
8c51524e 2393 PerlLIO_close(p[This]);
e446cec8 2394 if (n != sizeof(int))
cea2e8a9 2395 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2396 do {
2397 pid2 = wait4pid(pid, &status, 0);
2398 } while (pid2 == -1 && errno == EINTR);
e446cec8 2399 errno = errkid; /* Propagate errno from kid */
4608196e 2400 return NULL;
e446cec8
IZ		 2401 }
2402 }
2403 if (did_pipes)
2404 PerlLIO_close(pp[0]);
8ac85365 2405 return PerlIO_fdopen(p[This], mode);
a687059c 2406}
7c0587c8 2407#else
85ca448a 2408#if defined(atarist) || defined(EPOC)
7c0587c8 2409FILE *popen();
760ac839 2410PerlIO *
864dbfa3 2411Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2412{
45bc9206 2413 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2414 /* Call system's popen() to get a FILE *, then import it.
2415 used 0 for 2nd parameter to PerlIO_importFILE;
2416 apparently not used
2417 */
2418 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2419}
2b96b0a5
JH		 2420#else
2421#if defined(DJGPP)
2422FILE *djgpp_popen();
2423PerlIO *
2424Perl_my_popen(pTHX_ char *cmd, char *mode)
2425{
2426 PERL_FLUSHALL_FOR_CHILD;
2427 /* Call system's popen() to get a FILE *, then import it.
2428 used 0 for 2nd parameter to PerlIO_importFILE;
2429 apparently not used
2430 */
2431 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2432}
2433#endif
7c0587c8
LW		 2434#endif
2435
2436#endif /* !DOSISH */
a687059c 2437
52e18b1f
GS		 2438/* this is called in parent before the fork() */
2439void
2440Perl_atfork_lock(void)
2441{
27da23d5 2442 dVAR;
3db8f154 2443#if defined(USE_ITHREADS)
52e18b1f
GS		 2444 /* locks must be held in locking order (if any) */
2445# ifdef MYMALLOC
2446 MUTEX_LOCK(&PL_malloc_mutex);
2447# endif
2448 OP_REFCNT_LOCK;
2449#endif
2450}
2451
2452/* this is called in both parent and child after the fork() */
2453void
2454Perl_atfork_unlock(void)
2455{
27da23d5 2456 dVAR;
3db8f154 2457#if defined(USE_ITHREADS)
52e18b1f
GS		 2458 /* locks must be released in same order as in atfork_lock() */
2459# ifdef MYMALLOC
2460 MUTEX_UNLOCK(&PL_malloc_mutex);
2461# endif
2462 OP_REFCNT_UNLOCK;
2463#endif
2464}
2465
2466Pid_t
2467Perl_my_fork(void)
2468{
2469#if defined(HAS_FORK)
2470 Pid_t pid;
3db8f154 2471#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2472 atfork_lock();
2473 pid = fork();
2474 atfork_unlock();
2475#else
2476 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2477 * handlers elsewhere in the code */
2478 pid = fork();
2479#endif
2480 return pid;
2481#else
2482 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2483 Perl_croak_nocontext("fork() not available");
b961a566 2484 return 0;
52e18b1f
GS		 2485#endif /* HAS_FORK */
2486}
2487
748a9306 2488#ifdef DUMP_FDS
35ff7856 2489void
864dbfa3 2490Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2491{
2492 int fd;
c623ac67 2493 Stat_t tmpstatbuf;
ae986130 2494
bf49b057 2495 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2496 for (fd = 0; fd < 32; fd++) {
6ad3d225 2497 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2498 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2499 }
bf49b057 2500 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2501 return;
ae986130 2502}
35ff7856 2503#endif /* DUMP_FDS */
ae986130 2504
fe14fcc3 2505#ifndef HAS_DUP2
fec02dd3 2506int
ba106d47 2507dup2(int oldfd, int newfd)
a687059c 2508{
a0d0e21e 2509#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2510 if (oldfd == newfd)
2511 return oldfd;
6ad3d225 2512 PerlLIO_close(newfd);
fec02dd3 2513 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2514#else
fc36a67e 2515#define DUP2_MAX_FDS 256
2516 int fdtmp[DUP2_MAX_FDS];
79072805 2517 I32 fdx = 0;
ae986130
LW		 2518 int fd;
2519
fe14fcc3 2520 if (oldfd == newfd)
fec02dd3 2521 return oldfd;
6ad3d225 2522 PerlLIO_close(newfd);
fc36a67e 2523 /* good enough for low fd's... */
6ad3d225 2524 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2525 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2526 PerlLIO_close(fd);
fc36a67e 2527 fd = -1;
2528 break;
2529 }
ae986130 2530 fdtmp[fdx++] = fd;
fc36a67e 2531 }
ae986130 2532 while (fdx > 0)
6ad3d225 2533 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2534 return fd;
62b28dd9 2535#endif
a687059c
LW		 2536}
2537#endif
2538
64ca3a65 2539#ifndef PERL_MICRO
ff68c719 2540#ifdef HAS_SIGACTION
2541
abea2c45
HS		 2542#ifdef MACOS_TRADITIONAL
2543/* We don't want restart behavior on MacOS */
2544#undef SA_RESTART
2545#endif
2546
ff68c719 2547Sighandler_t
864dbfa3 2548Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2549{
27da23d5 2550 dVAR;
ff68c719 2551 struct sigaction act, oact;
2552
a10b1e10
JH		 2553#ifdef USE_ITHREADS
2554 /* only "parent" interpreter can diddle signals */
2555 if (PL_curinterp != aTHX)
8aad04aa 2556 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2557#endif
2558
8aad04aa 2559 act.sa_handler = (void(*)(int))handler;
ff68c719 2560 sigemptyset(&act.sa_mask);
2561 act.sa_flags = 0;
2562#ifdef SA_RESTART
4ffa73a3
JH		 2563 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2564 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2565#endif
358837b8 2566#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2567 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2568 act.sa_flags |= SA_NOCLDWAIT;
2569#endif
ff68c719 2570 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2571 return (Sighandler_t) SIG_ERR;
ff68c719 2572 else
8aad04aa 2573 return (Sighandler_t) oact.sa_handler;
ff68c719 2574}
2575
2576Sighandler_t
864dbfa3 2577Perl_rsignal_state(pTHX_ int signo)
ff68c719 2578{
2579 struct sigaction oact;
96a5add6 2580 PERL_UNUSED_CONTEXT;
ff68c719 2581
2582 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2583 return (Sighandler_t) SIG_ERR;
ff68c719 2584 else
8aad04aa 2585 return (Sighandler_t) oact.sa_handler;
ff68c719 2586}
2587
2588int
864dbfa3 2589Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2590{
27da23d5 2591 dVAR;
ff68c719 2592 struct sigaction act;
2593
a10b1e10
JH		 2594#ifdef USE_ITHREADS
2595 /* only "parent" interpreter can diddle signals */
2596 if (PL_curinterp != aTHX)
2597 return -1;
2598#endif
2599
8aad04aa 2600 act.sa_handler = (void(*)(int))handler;
ff68c719 2601 sigemptyset(&act.sa_mask);
2602 act.sa_flags = 0;
2603#ifdef SA_RESTART
4ffa73a3
JH		 2604 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2605 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2606#endif
36b5d377 2607#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2608 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2609 act.sa_flags |= SA_NOCLDWAIT;
2610#endif
ff68c719 2611 return sigaction(signo, &act, save);
2612}
2613
2614int
864dbfa3 2615Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2616{
27da23d5 2617 dVAR;
a10b1e10
JH		 2618#ifdef USE_ITHREADS
2619 /* only "parent" interpreter can diddle signals */
2620 if (PL_curinterp != aTHX)
2621 return -1;
2622#endif
2623
ff68c719 2624 return sigaction(signo, save, (struct sigaction *)NULL);
2625}
2626
2627#else /* !HAS_SIGACTION */
2628
2629Sighandler_t
864dbfa3 2630Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2631{
39f1703b 2632#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2633 /* only "parent" interpreter can diddle signals */
2634 if (PL_curinterp != aTHX)
8aad04aa 2635 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2636#endif
2637
6ad3d225 2638 return PerlProc_signal(signo, handler);
ff68c719 2639}
2640
fabdb6c0 2641static Signal_t
4e35701f 2642sig_trap(int signo)
ff68c719 2643{
27da23d5
JH		 2644 dVAR;
2645 PL_sig_trapped++;
ff68c719 2646}
2647
2648Sighandler_t
864dbfa3 2649Perl_rsignal_state(pTHX_ int signo)
ff68c719 2650{
27da23d5 2651 dVAR;
ff68c719 2652 Sighandler_t oldsig;
2653
39f1703b 2654#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2655 /* only "parent" interpreter can diddle signals */
2656 if (PL_curinterp != aTHX)
8aad04aa 2657 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2658#endif
2659
27da23d5 2660 PL_sig_trapped = 0;
6ad3d225
GS		 2661 oldsig = PerlProc_signal(signo, sig_trap);
2662 PerlProc_signal(signo, oldsig);
27da23d5 2663 if (PL_sig_trapped)
3aed30dc 2664 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2665 return oldsig;
2666}
2667
2668int
864dbfa3 2669Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2670{
39f1703b 2671#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2672 /* only "parent" interpreter can diddle signals */
2673 if (PL_curinterp != aTHX)
2674 return -1;
2675#endif
6ad3d225 2676 *save = PerlProc_signal(signo, handler);
8aad04aa 2677 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2678}
2679
2680int
864dbfa3 2681Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2682{
39f1703b 2683#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2684 /* only "parent" interpreter can diddle signals */
2685 if (PL_curinterp != aTHX)
2686 return -1;
2687#endif
8aad04aa 2688 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2689}
2690
2691#endif /* !HAS_SIGACTION */
64ca3a65 2692#endif /* !PERL_MICRO */
ff68c719 2693
5f05dabc 2694 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2695#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2696I32
864dbfa3 2697Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2698{
97aff369 2699 dVAR;
ff68c719 2700 Sigsave_t hstat, istat, qstat;
a687059c 2701 int status;
a0d0e21e 2702 SV **svp;
d8a83dd3
JH		 2703 Pid_t pid;
2704 Pid_t pid2;
03136e13 2705 bool close_failed;
b7953727 2706 int saved_errno = 0;
22fae026
TM		 2707#ifdef WIN32
2708 int saved_win32_errno;
2709#endif
a687059c 2710
4755096e 2711 LOCK_FDPID_MUTEX;
3280af22 2712 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2713 UNLOCK_FDPID_MUTEX;
25d92023 2714 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2715 SvREFCNT_dec(*svp);
3280af22 2716 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2717#ifdef OS2
2718 if (pid == -1) { /* Opened by popen. */
2719 return my_syspclose(ptr);
2720 }
a1d180c4 2721#endif
03136e13
CS		 2722 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2723 saved_errno = errno;
22fae026
TM		 2724#ifdef WIN32
2725 saved_win32_errno = GetLastError();
2726#endif
03136e13 2727 }
7c0587c8 2728#ifdef UTS
6ad3d225 2729 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2730#endif
64ca3a65 2731#ifndef PERL_MICRO
8aad04aa
JH		 2732 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2733 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2734 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 2735#endif
748a9306 2736 do {
1d3434b8
GS		 2737 pid2 = wait4pid(pid, &status, 0);
2738 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2739#ifndef PERL_MICRO
ff68c719 2740 rsignal_restore(SIGHUP, &hstat);
2741 rsignal_restore(SIGINT, &istat);
2742 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2743#endif
03136e13 2744 if (close_failed) {
ce6e1103 2745 SETERRNO(saved_errno, 0);
03136e13
CS		 2746 return -1;
2747 }
1d3434b8 2748 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2749}
4633a7c4
LW		 2750#endif /* !DOSISH */
2751
2986a63f 2752#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2753I32
d8a83dd3 2754Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2755{
97aff369 2756 dVAR;
27da23d5 2757 I32 result = 0;
b7953727
JH		 2758 if (!pid)
2759 return -1;
ca0c25f6 2760#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2761 {
3aed30dc 2762 if (pid > 0) {
12072db5
NC		 2763 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2764 pid, rather than a string form. */
c4420975 2765 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 2766 if (svp && *svp != &PL_sv_undef) {
2767 *statusp = SvIVX(*svp);
12072db5
NC		 2768 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2769 G_DISCARD);
3aed30dc
HS		 2770 return pid;
2771 }
2772 }
2773 else {
2774 HE *entry;
2775
2776 hv_iterinit(PL_pidstatus);
2777 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2778 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2779 I32 len;
0bcc34c2 2780 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2781
12072db5
NC		 2782 assert (len == sizeof(Pid_t));
2783 memcpy((char *)&pid, spid, len);
3aed30dc 2784 *statusp = SvIVX(sv);
7b9a3241
NC		 2785 /* The hash iterator is currently on this entry, so simply
2786 calling hv_delete would trigger the lazy delete, which on
2787 aggregate does more work, beacuse next call to hv_iterinit()
2788 would spot the flag, and have to call the delete routine,
2789 while in the meantime any new entries can't re-use that
2790 memory. */
2791 hv_iterinit(PL_pidstatus);
7ea75b61 2792 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 2793 return pid;
2794 }
20188a90
LW		 2795 }
2796 }
68a29c53 2797#endif
79072805 2798#ifdef HAS_WAITPID
367f3c24
IZ		 2799# ifdef HAS_WAITPID_RUNTIME
2800 if (!HAS_WAITPID_RUNTIME)
2801 goto hard_way;
2802# endif
cddd4526 2803 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2804 goto finish;
367f3c24
IZ		 2805#endif
2806#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2807 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2808 goto finish;
367f3c24 2809#endif
ca0c25f6 2810#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2811#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2812 hard_way:
27da23d5 2813#endif
a0d0e21e 2814 {
a0d0e21e 2815 if (flags)
cea2e8a9 2816 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2817 else {
76e3520e 2818 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2819 pidgone(result,*statusp);
2820 if (result < 0)
2821 *statusp = -1;
2822 }
a687059c
LW		 2823 }
2824#endif
27da23d5 2825#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2826 finish:
27da23d5 2827#endif
cddd4526
NIS		 2828 if (result < 0 && errno == EINTR) {
2829 PERL_ASYNC_CHECK();
2830 }
2831 return result;
a687059c 2832}
2986a63f 2833#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2834
ca0c25f6 2835#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2836void
d8a83dd3 2837Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2838{
79072805 2839 register SV *sv;
a687059c 2840
12072db5 2841 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2842 SvUPGRADE(sv,SVt_IV);
45977657 2843 SvIV_set(sv, status);
20188a90 2844 return;
a687059c 2845}
ca0c25f6 2846#endif
a687059c 2847
85ca448a 2848#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2849int pclose();
ddcf38b7
IZ		 2850#ifdef HAS_FORK
2851int /* Cannot prototype with I32
2852 in os2ish.h. */
ba106d47 2853my_syspclose(PerlIO *ptr)
ddcf38b7 2854#else
79072805 2855I32
864dbfa3 2856Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2857#endif
a687059c 2858{
760ac839 2859 /* Needs work for PerlIO ! */
c4420975 2860 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 2861 const I32 result = pclose(f);
2b96b0a5
JH		 2862 PerlIO_releaseFILE(ptr,f);
2863 return result;
2864}
2865#endif
2866
933fea7f 2867#if defined(DJGPP)
2b96b0a5
JH		 2868int djgpp_pclose();
2869I32
2870Perl_my_pclose(pTHX_ PerlIO *ptr)
2871{
2872 /* Needs work for PerlIO ! */
c4420975 2873 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 2874 I32 result = djgpp_pclose(f);
933fea7f 2875 result = (result << 8) & 0xff00;
760ac839
LW		 2876 PerlIO_releaseFILE(ptr,f);
2877 return result;
a687059c 2878}
7c0587c8 2879#endif
9f68db38
LW		 2880
2881void
864dbfa3 2882Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2883{
79072805 2884 register I32 todo;
c4420975 2885 register const char * const frombase = from;
96a5add6 2886 PERL_UNUSED_CONTEXT;
9f68db38
LW		 2887
2888 if (len == 1) {
08105a92 2889 register const char c = *from;
9f68db38 2890 while (count-- > 0)
5926133d 2891 *to++ = c;
9f68db38
LW		 2892 return;
2893 }
2894 while (count-- > 0) {
2895 for (todo = len; todo > 0; todo--) {
2896 *to++ = *from++;
2897 }
2898 from = frombase;
2899 }
2900}
0f85fab0 2901
fe14fcc3 2902#ifndef HAS_RENAME
79072805 2903I32
4373e329 2904Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 2905{
93a17b20
LW		 2906 char *fa = strrchr(a,'/');
2907 char *fb = strrchr(b,'/');
c623ac67
GS		 2908 Stat_t tmpstatbuf1;
2909 Stat_t tmpstatbuf2;
c4420975 2910 SV * const tmpsv = sv_newmortal();
62b28dd9
LW		 2911
2912 if (fa)
2913 fa++;
2914 else
2915 fa = a;
2916 if (fb)
2917 fb++;
2918 else
2919 fb = b;
2920 if (strNE(a,b))
2921 return FALSE;
2922 if (fa == a)
616d8c9c 2923 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2924 else
46fc3d4c 2925 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 2926 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2927 return FALSE;
2928 if (fb == b)
616d8c9c 2929 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2930 else
46fc3d4c 2931 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 2932 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2933 return FALSE;
2934 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2935 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2936}
fe14fcc3
LW		 2937#endif /* !HAS_RENAME */
2938
491527d0 2939char*
7f315aed
NC		 2940Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2941 const char *const *const search_ext, I32 flags)
491527d0 2942{
97aff369 2943 dVAR;
bd61b366
SS		 2944 const char *xfound = NULL;
2945 char *xfailed = NULL;
0f31cffe 2946 char tmpbuf[MAXPATHLEN];
491527d0 2947 register char *s;
5f74f29c 2948 I32 len = 0;
491527d0
GS		 2949 int retval;
2950#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2951# define SEARCH_EXTS ".bat", ".cmd", NULL
2952# define MAX_EXT_LEN 4
2953#endif
2954#ifdef OS2
2955# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2956# define MAX_EXT_LEN 4
2957#endif
2958#ifdef VMS
2959# define SEARCH_EXTS ".pl", ".com", NULL
2960# define MAX_EXT_LEN 4
2961#endif
2962 /* additional extensions to try in each dir if scriptname not found */
2963#ifdef SEARCH_EXTS
0bcc34c2 2964 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 2965 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 2966 int extidx = 0, i = 0;
bd61b366 2967 const char *curext = NULL;
491527d0 2968#else
53c1dcc0 2969 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 2970# define MAX_EXT_LEN 0
2971#endif
2972
2973 /*
2974 * If dosearch is true and if scriptname does not contain path
2975 * delimiters, search the PATH for scriptname.
2976 *
2977 * If SEARCH_EXTS is also defined, will look for each
2978 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2979 * while searching the PATH.
2980 *
2981 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2982 * proceeds as follows:
2983 * If DOSISH or VMSISH:
2984 * + look for ./scriptname{,.foo,.bar}
2985 * + search the PATH for scriptname{,.foo,.bar}
2986 *
2987 * If !DOSISH:
2988 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2989 * this will not look in '.' if it's not in the PATH)
2990 */
84486fc6 2991 tmpbuf[0] = '\0';
491527d0
GS		 2992
2993#ifdef VMS
2994# ifdef ALWAYS_DEFTYPES
2995 len = strlen(scriptname);
2996 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 2997 int idx = 0, deftypes = 1;
491527d0
GS		 2998 bool seen_dot = 1;
2999
bd61b366 3000 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3001# else
3002 if (dosearch) {
c4420975 3003 int idx = 0, deftypes = 1;
491527d0
GS		 3004 bool seen_dot = 1;
3005
bd61b366 3006 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3007# endif
3008 /* The first time through, just add SEARCH_EXTS to whatever we
3009 * already have, so we can check for default file types. */
3010 while (deftypes ||
84486fc6 3011 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3012 {
3013 if (deftypes) {
3014 deftypes = 0;
84486fc6 3015 *tmpbuf = '\0';
491527d0 3016 }
84486fc6
GS		 3017 if ((strlen(tmpbuf) + strlen(scriptname)
3018 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3019 continue; /* don't search dir with too-long name */
84486fc6 3020 strcat(tmpbuf, scriptname);
491527d0
GS		 3021#else /* !VMS */
3022
3023#ifdef DOSISH
3024 if (strEQ(scriptname, "-"))
3025 dosearch = 0;
3026 if (dosearch) { /* Look in '.' first. */
fe2774ed 3027 const char *cur = scriptname;
491527d0
GS		 3028#ifdef SEARCH_EXTS
3029 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3030 while (ext[i])
3031 if (strEQ(ext[i++],curext)) {
3032 extidx = -1; /* already has an ext */
3033 break;
3034 }
3035 do {
3036#endif
3037 DEBUG_p(PerlIO_printf(Perl_debug_log,
3038 "Looking for %s\n",cur));
017f25f1
IZ		 3039 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3040 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3041 dosearch = 0;
3042 scriptname = cur;
3043#ifdef SEARCH_EXTS
3044 break;
3045#endif
3046 }
3047#ifdef SEARCH_EXTS
3048 if (cur == scriptname) {
3049 len = strlen(scriptname);
84486fc6 3050 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3051 break;
490a0e98 3052 /* FIXME? Convert to memcpy */
84486fc6 3053 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 3054 }
3055 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 3056 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 3057#endif
3058 }
3059#endif
3060
cd39f2b6
JH		 3061#ifdef MACOS_TRADITIONAL
3062 if (dosearch && !strchr(scriptname, ':') &&
3063 (s = PerlEnv_getenv("Commands")))
3064#else
491527d0
GS		 3065 if (dosearch && !strchr(scriptname, '/')
3066#ifdef DOSISH
3067 && !strchr(scriptname, '\\')
3068#endif
cd39f2b6
JH		 3069 && (s = PerlEnv_getenv("PATH")))
3070#endif
3071 {
491527d0 3072 bool seen_dot = 0;
92f0c265 3073
3280af22
NIS		 3074 PL_bufend = s + strlen(s);
3075 while (s < PL_bufend) {
cd39f2b6
JH		 3076#ifdef MACOS_TRADITIONAL
3077 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3078 ',',
3079 &len);
3080#else
491527d0
GS		 3081#if defined(atarist) || defined(DOSISH)
3082 for (len = 0; *s
3083# ifdef atarist
3084 && *s != ','
3085# endif
3086 && *s != ';'; len++, s++) {
84486fc6
GS		 3087 if (len < sizeof tmpbuf)
3088 tmpbuf[len] = *s;
491527d0 3089 }
84486fc6
GS		 3090 if (len < sizeof tmpbuf)
3091 tmpbuf[len] = '\0';
491527d0 3092#else /* ! (atarist || DOSISH) */
3280af22 3093 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 3094 ':',
3095 &len);
3096#endif /* ! (atarist || DOSISH) */
cd39f2b6 3097#endif /* MACOS_TRADITIONAL */
3280af22 3098 if (s < PL_bufend)
491527d0 3099 s++;
84486fc6 3100 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 3101 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 3102#ifdef MACOS_TRADITIONAL
3103 if (len && tmpbuf[len - 1] != ':')
3104 tmpbuf[len++] = ':';
3105#else
491527d0 3106 if (len
490a0e98 3107# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 3108 && tmpbuf[len - 1] != '/'
3109 && tmpbuf[len - 1] != '\\'
490a0e98 3110# endif
491527d0 3111 )
84486fc6
GS		 3112 tmpbuf[len++] = '/';
3113 if (len == 2 && tmpbuf[0] == '.')
491527d0 3114 seen_dot = 1;
cd39f2b6 3115#endif
490a0e98
NC		 3116 /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
3117 */
84486fc6 3118 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 3119#endif /* !VMS */
3120
3121#ifdef SEARCH_EXTS
84486fc6 3122 len = strlen(tmpbuf);
491527d0
GS		 3123 if (extidx > 0) /* reset after previous loop */
3124 extidx = 0;
3125 do {
3126#endif
84486fc6 3127 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3128 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3129 if (S_ISDIR(PL_statbuf.st_mode)) {
3130 retval = -1;
3131 }
491527d0
GS		 3132#ifdef SEARCH_EXTS
3133 } while ( retval < 0 /* not there */
3134 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 3135 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 3136 );
3137#endif
3138 if (retval < 0)
3139 continue;
3280af22
NIS		 3140 if (S_ISREG(PL_statbuf.st_mode)
3141 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 3142#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 3143 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3144#endif
3145 )
3146 {
3aed30dc 3147 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3148 break;
3149 }
3150 if (!xfailed)
84486fc6 3151 xfailed = savepv(tmpbuf);
491527d0
GS		 3152 }
3153#ifndef DOSISH
017f25f1 3154 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3155 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3156 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3157#endif
3158 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3159 if (!xfound) {
3160 if (flags & 1) { /* do or die? */
3aed30dc 3161 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3162 (xfailed ? "execute" : "find"),
3163 (xfailed ? xfailed : scriptname),
3164 (xfailed ? "" : " on PATH"),
3165 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3166 }
bd61b366 3167 scriptname = NULL;
9ccb31f9 3168 }
43c5f42d 3169 Safefree(xfailed);
491527d0
GS		 3170 scriptname = xfound;
3171 }
bd61b366 3172 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3173}
3174
ba869deb
GS		 3175#ifndef PERL_GET_CONTEXT_DEFINED
3176
3177void *
3178Perl_get_context(void)
3179{
27da23d5 3180 dVAR;
3db8f154 3181#if defined(USE_ITHREADS)
ba869deb
GS		 3182# ifdef OLD_PTHREADS_API
3183 pthread_addr_t t;
3184 if (pthread_getspecific(PL_thr_key, &t))
3185 Perl_croak_nocontext("panic: pthread_getspecific");
3186 return (void*)t;
3187# else
bce813aa 3188# ifdef I_MACH_CTHREADS
8b8b35ab 3189 return (void*)cthread_data(cthread_self());
bce813aa 3190# else
8b8b35ab
JH		 3191 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3192# endif
c44d3fdb 3193# endif
ba869deb
GS		 3194#else
3195 return (void*)NULL;
3196#endif
3197}
3198
3199void
3200Perl_set_context(void *t)
3201{
8772537c 3202 dVAR;
3db8f154 3203#if defined(USE_ITHREADS)
c44d3fdb
GS		 3204# ifdef I_MACH_CTHREADS
3205 cthread_set_data(cthread_self(), t);
3206# else
ba869deb
GS		 3207 if (pthread_setspecific(PL_thr_key, t))
3208 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3209# endif
b464bac0 3210#else
8772537c 3211 PERL_UNUSED_ARG(t);
ba869deb
GS		 3212#endif
3213}
3214
3215#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3216
27da23d5 3217#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3218struct perl_vars *
864dbfa3 3219Perl_GetVars(pTHX)
22239a37 3220{
533c011a 3221 return &PL_Vars;
22239a37 3222}
31fb1209
NIS		 3223#endif
3224
1cb0ed9b 3225char **
864dbfa3 3226Perl_get_op_names(pTHX)
31fb1209 3227{
96a5add6
AL		 3228 PERL_UNUSED_CONTEXT;
3229 return (char **)PL_op_name;
31fb1209
NIS		 3230}
3231
1cb0ed9b 3232char **
864dbfa3 3233Perl_get_op_descs(pTHX)
31fb1209 3234{
96a5add6
AL		 3235 PERL_UNUSED_CONTEXT;
3236 return (char **)PL_op_desc;
31fb1209 3237}
9e6b2b00 3238
e1ec3a88 3239const char *
864dbfa3 3240Perl_get_no_modify(pTHX)
9e6b2b00 3241{
96a5add6
AL		 3242 PERL_UNUSED_CONTEXT;
3243 return PL_no_modify;
9e6b2b00
GS		 3244}
3245
3246U32 *
864dbfa3 3247Perl_get_opargs(pTHX)
9e6b2b00 3248{
96a5add6
AL		 3249 PERL_UNUSED_CONTEXT;
3250 return (U32 *)PL_opargs;
9e6b2b00 3251}
51aa15f3 3252
0cb96387
GS		 3253PPADDR_t*
3254Perl_get_ppaddr(pTHX)
3255{
96a5add6
AL		 3256 dVAR;
3257 PERL_UNUSED_CONTEXT;
3258 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3259}
3260
a6c40364
GS		 3261#ifndef HAS_GETENV_LEN
3262char *
bf4acbe4 3263Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3264{
8772537c 3265 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3266 PERL_UNUSED_CONTEXT;
a6c40364
GS		 3267 if (env_trans)
3268 *len = strlen(env_trans);
3269 return env_trans;
f675dbe5
CB		 3270}
3271#endif
3272
dc9e4912
GS		 3273
3274MGVTBL*
864dbfa3 3275Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3276{
7452cf6a 3277 const MGVTBL* result;
96a5add6 3278 PERL_UNUSED_CONTEXT;
dc9e4912
GS		 3279
3280 switch(vtbl_id) {
3281 case want_vtbl_sv:
3282 result = &PL_vtbl_sv;
3283 break;
3284 case want_vtbl_env:
3285 result = &PL_vtbl_env;
3286 break;
3287 case want_vtbl_envelem:
3288 result = &PL_vtbl_envelem;
3289 break;
3290 case want_vtbl_sig:
3291 result = &PL_vtbl_sig;
3292 break;
3293 case want_vtbl_sigelem:
3294 result = &PL_vtbl_sigelem;
3295 break;
3296 case want_vtbl_pack:
3297 result = &PL_vtbl_pack;
3298 break;
3299 case want_vtbl_packelem:
3300 result = &PL_vtbl_packelem;
3301 break;
3302 case want_vtbl_dbline:
3303 result = &PL_vtbl_dbline;
3304 break;
3305 case want_vtbl_isa:
3306 result = &PL_vtbl_isa;
3307 break;
3308 case want_vtbl_isaelem:
3309 result = &PL_vtbl_isaelem;
3310 break;
3311 case want_vtbl_arylen:
3312 result = &PL_vtbl_arylen;
3313 break;
dc9e4912
GS		 3314 case want_vtbl_mglob:
3315 result = &PL_vtbl_mglob;
3316 break;
3317 case want_vtbl_nkeys:
3318 result = &PL_vtbl_nkeys;
3319 break;
3320 case want_vtbl_taint:
3321 result = &PL_vtbl_taint;
3322 break;
3323 case want_vtbl_substr:
3324 result = &PL_vtbl_substr;
3325 break;
3326 case want_vtbl_vec:
3327 result = &PL_vtbl_vec;
3328 break;
3329 case want_vtbl_pos:
3330 result = &PL_vtbl_pos;
3331 break;
3332 case want_vtbl_bm:
3333 result = &PL_vtbl_bm;
3334 break;
3335 case want_vtbl_fm:
3336 result = &PL_vtbl_fm;
3337 break;
3338 case want_vtbl_uvar:
3339 result = &PL_vtbl_uvar;
3340 break;
dc9e4912
GS		 3341 case want_vtbl_defelem:
3342 result = &PL_vtbl_defelem;
3343 break;
3344 case want_vtbl_regexp:
3345 result = &PL_vtbl_regexp;
3346 break;
3347 case want_vtbl_regdata:
3348 result = &PL_vtbl_regdata;
3349 break;
3350 case want_vtbl_regdatum:
3351 result = &PL_vtbl_regdatum;
3352 break;
3c90161d 3353#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3354 case want_vtbl_collxfrm:
3355 result = &PL_vtbl_collxfrm;
3356 break;
3c90161d 3357#endif
dc9e4912
GS		 3358 case want_vtbl_amagic:
3359 result = &PL_vtbl_amagic;
3360 break;
3361 case want_vtbl_amagicelem:
3362 result = &PL_vtbl_amagicelem;
3363 break;
810b8aa5
GS		 3364 case want_vtbl_backref:
3365 result = &PL_vtbl_backref;
3366 break;
7e8c5dac
HS		 3367 case want_vtbl_utf8:
3368 result = &PL_vtbl_utf8;
3369 break;
7452cf6a 3370 default:
4608196e 3371 result = NULL;
7452cf6a 3372 break;
dc9e4912 3373 }
27da23d5 3374 return (MGVTBL*)result;
dc9e4912
GS		 3375}
3376
767df6a1 3377I32
864dbfa3 3378Perl_my_fflush_all(pTHX)
767df6a1 3379{
f800e14d 3380#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3381 return PerlIO_flush(NULL);
767df6a1 3382#else
8fbdfb7c 3383# if defined(HAS__FWALK)
f13a2bc0 3384 extern int fflush(FILE *);
74cac757
JH		 3385 /* undocumented, unprototyped, but very useful BSDism */
3386 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3387 _fwalk(&fflush);
74cac757 3388 return 0;
8fa7f367 3389# else
8fbdfb7c 3390# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3391 long open_max = -1;
8fbdfb7c 3392# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3393 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3394# else
8fa7f367 3395# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3396 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3397# else
3398# ifdef FOPEN_MAX
74cac757 3399 open_max = FOPEN_MAX;
8fa7f367
JH		 3400# else
3401# ifdef OPEN_MAX
74cac757 3402 open_max = OPEN_MAX;
8fa7f367
JH		 3403# else
3404# ifdef _NFILE
d2201af2 3405 open_max = _NFILE;
8fa7f367
JH		 3406# endif
3407# endif
74cac757 3408# endif
767df6a1
JH		 3409# endif
3410# endif
767df6a1
JH		 3411 if (open_max > 0) {
3412 long i;
3413 for (i = 0; i < open_max; i++)
d2201af2
AD		 3414 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3415 STDIO_STREAM_ARRAY[i]._file < open_max &&
3416 STDIO_STREAM_ARRAY[i]._flag)
3417 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3418 return 0;
3419 }
8fbdfb7c 3420# endif
93189314 3421 SETERRNO(EBADF,RMS_IFI);
767df6a1 3422 return EOF;
74cac757 3423# endif
767df6a1
JH		 3424#endif
3425}
097ee67d 3426
69282e91 3427void
e1ec3a88 3428Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
bc37a18f 3429{
b64e5050 3430 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
66fc2fa5 3431
4c80c0b2 3432 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3433 if (ckWARN(WARN_IO)) {
b64e5050 3434 const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3aed30dc
HS		 3435 if (name && *name)
3436 Perl_warner(aTHX_ packWARN(WARN_IO),
3437 "Filehandle %s opened only for %sput",
fd322ea4 3438 name, direction);
3aed30dc
HS		 3439 else
3440 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3441 "Filehandle opened only for %sput", direction);
3aed30dc 3442 }
2dd78f96
JH		 3443 }
3444 else {
e1ec3a88 3445 const char *vile;
3aed30dc
HS		 3446 I32 warn_type;
3447
3448 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3449 vile = "closed";
3450 warn_type = WARN_CLOSED;
3451 }
3452 else {
3453 vile = "unopened";
3454 warn_type = WARN_UNOPENED;
3455 }
3456
3457 if (ckWARN(warn_type)) {
f0a09b71
AL		 3458 const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
3459 const char * const func =
3460 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3461 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3462 op < 0 ? "" : /* handle phoney cases */
3463 PL_op_desc[op];
3464 const char * const type = OP_IS_SOCKET(op)
3465 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3466 ? "socket" : "filehandle";
3aed30dc
HS		 3467 if (name && *name) {
3468 Perl_warner(aTHX_ packWARN(warn_type),
3469 "%s%s on %s %s %s", func, pars, vile, type, name);
3470 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3471 Perl_warner(
3472 aTHX_ packWARN(warn_type),
3473 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3474 func, pars, name
3475 );
3476 }
3477 else {
3478 Perl_warner(aTHX_ packWARN(warn_type),
3479 "%s%s on %s %s", func, pars, vile, type);
3480 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3481 Perl_warner(
3482 aTHX_ packWARN(warn_type),
3483 "\t(Are you trying to call %s%s on dirhandle?)\n",
3484 func, pars
3485 );
3486 }
3487 }
bc37a18f 3488 }
69282e91 3489}
a926ef6b
JH		 3490
3491#ifdef EBCDIC
cbebf344
JH		 3492/* in ASCII order, not that it matters */
3493static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3494
a926ef6b
JH		 3495int
3496Perl_ebcdic_control(pTHX_ int ch)
3497{
3aed30dc 3498 if (ch > 'a') {
e1ec3a88 3499 const char *ctlp;
3aed30dc
HS		 3500
3501 if (islower(ch))
3502 ch = toupper(ch);
3503
3504 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3505 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3506 }
3aed30dc
HS		 3507
3508 if (ctlp == controllablechars)
3509 return('\177'); /* DEL */
3510 else
3511 return((unsigned char)(ctlp - controllablechars - 1));
3512 } else { /* Want uncontrol */
3513 if (ch == '\177' || ch == -1)
3514 return('?');
3515 else if (ch == '\157')
3516 return('\177');
3517 else if (ch == '\174')
3518 return('\000');
3519 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3520 return('\036');
3521 else if (ch == '\155')
3522 return('\037');
3523 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3524 return(controllablechars[ch+1]);
3525 else
3526 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3527 }
a926ef6b
JH		 3528}
3529#endif
e72cf795 3530
f6adc668 3531/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3532 * system to give us a reasonable struct to copy. This fix means that
3533 * strftime uses the tm_zone and tm_gmtoff values returned by
3534 * localtime(time()). That should give the desired result most of the
3535 * time. But probably not always!
3536 *
f6adc668
JH		 3537 * This does not address tzname aspects of NETaa14816.
3538 *
e72cf795 3539 */
f6adc668 3540
e72cf795
JH		 3541#ifdef HAS_GNULIBC
3542# ifndef STRUCT_TM_HASZONE
3543# define STRUCT_TM_HASZONE
3544# endif
3545#endif
3546
f6adc668
JH		 3547#ifdef STRUCT_TM_HASZONE /* Backward compat */
3548# ifndef HAS_TM_TM_ZONE
3549# define HAS_TM_TM_ZONE
3550# endif
3551#endif
3552
e72cf795 3553void
f1208910 3554Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3555{
f6adc668 3556#ifdef HAS_TM_TM_ZONE
e72cf795 3557 Time_t now;
1b6737cc 3558 const struct tm* my_tm;
e72cf795 3559 (void)time(&now);
82c57498 3560 my_tm = localtime(&now);
ca46b8ee
SP		 3561 if (my_tm)
3562 Copy(my_tm, ptm, 1, struct tm);
1b6737cc
AL		 3563#else
3564 PERL_UNUSED_ARG(ptm);
e72cf795
JH		 3565#endif
3566}
3567
3568/*
3569 * mini_mktime - normalise struct tm values without the localtime()
3570 * semantics (and overhead) of mktime().
3571 */
3572void
f1208910 3573Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3574{
3575 int yearday;
3576 int secs;
3577 int month, mday, year, jday;
3578 int odd_cent, odd_year;
96a5add6 3579 PERL_UNUSED_CONTEXT;
e72cf795
JH		 3580
3581#define DAYS_PER_YEAR 365
3582#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3583#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3584#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3585#define SECS_PER_HOUR (60*60)
3586#define SECS_PER_DAY (24*SECS_PER_HOUR)
3587/* parentheses deliberately absent on these two, otherwise they don't work */
3588#define MONTH_TO_DAYS 153/5
3589#define DAYS_TO_MONTH 5/153
3590/* offset to bias by March (month 4) 1st between month/mday & year finding */
3591#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3592/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3593#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3594
3595/*
3596 * Year/day algorithm notes:
3597 *
3598 * With a suitable offset for numeric value of the month, one can find