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