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