This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge the common code from Perl_vdie and Perl_vwarner into a
[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 28#ifndef SIG_ERR
29# define SIG_ERR ((Sighandler_t) -1)
30#endif
64ca3a65 31#endif
36477c24 32
ff68c719 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 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 177 if (ptr != Nullch) {
178 memset((void*)ptr, 0, size);
179 return ptr;
180 }
3280af22 181 else if (PL_nomemok)
1050c9ca 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 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 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 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 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 684 if (big[pos] != first)
685 continue;
686 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69 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 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 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 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 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 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 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 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
63315e18
NC		 1040void
1041S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
1042{
1043 HV *stash;
1044 GV *gv;
1045 CV *cv;
1046 /* sv_2cv might call Perl_croak() */
1047 SV *olddiehook = PL_diehook;
1048
1049 assert(PL_diehook);
1050 ENTER;
1051 SAVESPTR(PL_diehook);
1052 PL_diehook = Nullsv;
1053 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1054 LEAVE;
1055 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1056 dSP;
1057 SV *msg;
1058
1059 ENTER;
1060 save_re_context();
1061 if (message) {
1062 msg = newSVpvn(message, msglen);
1063 SvFLAGS(msg) |= utf8;
1064 SvREADONLY_on(msg);
1065 SAVEFREESV(msg);
1066 }
1067 else {
1068 msg = ERRSV;
1069 }
1070
1071 PUSHSTACKi(PERLSI_DIEHOOK);
1072 PUSHMARK(SP);
1073 XPUSHs(msg);
1074 PUTBACK;
1075 call_sv((SV*)cv, G_DISCARD);
1076 POPSTACK;
1077 LEAVE;
1078 }
1079}
1080
c5be433b
GS		 1081OP *
1082Perl_vdie(pTHX_ const char* pat, va_list *args)
36477c24 1083{
36477c24 1084 char *message;
3280af22 1085 int was_in_eval = PL_in_eval;
06bf62c7
GS		 1086 SV *msv;
1087 STRLEN msglen;
ff882698 1088 I32 utf8 = 0;
36477c24 1089
bf49b057 1090 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 1091 "%p: die: curstack = %p, mainstack = %p\n",
533c011a 1092 thr, PL_curstack, PL_mainstack));
36477c24 1093
06bf62c7 1094 if (pat) {
5a844595
GS		 1095 msv = vmess(pat, args);
1096 if (PL_errors && SvCUR(PL_errors)) {
1097 sv_catsv(PL_errors, msv);
1098 message = SvPV(PL_errors, msglen);
1099 SvCUR_set(PL_errors, 0);
1100 }
1101 else
1102 message = SvPV(msv,msglen);
ff882698 1103 utf8 = SvUTF8(msv);
06bf62c7
GS		 1104 }
1105 else {
1106 message = Nullch;
0f79a09d 1107 msglen = 0;
06bf62c7 1108 }
36477c24 1109
bf49b057 1110 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 1111 "%p: die: message = %s\ndiehook = %p\n",
533c011a 1112 thr, message, PL_diehook));
3280af22 1113 if (PL_diehook) {
63315e18 1114 S_vdie_common(aTHX_ message, msglen, utf8);
36477c24 1115 }
1116
06bf62c7 1117 PL_restartop = die_where(message, msglen);
ff882698 1118 SvFLAGS(ERRSV) |= utf8;
bf49b057 1119 DEBUG_S(PerlIO_printf(Perl_debug_log,
7c06b590 1120 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
533c011a 1121 thr, PL_restartop, was_in_eval, PL_top_env));
3280af22 1122 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
6224f72b 1123 JMPENV_JUMP(3);
3280af22 1124 return PL_restartop;
36477c24 1125}
1126
c5be433b 1127#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1128OP *
1129Perl_die_nocontext(const char* pat, ...)
a687059c 1130{
cea2e8a9
GS		 1131 dTHX;
1132 OP *o;
a687059c 1133 va_list args;
cea2e8a9 1134 va_start(args, pat);
c5be433b 1135 o = vdie(pat, &args);
cea2e8a9
GS		 1136 va_end(args);
1137 return o;
1138}
c5be433b 1139#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS		 1140
1141OP *
1142Perl_die(pTHX_ const char* pat, ...)
1143{
1144 OP *o;
1145 va_list args;
1146 va_start(args, pat);
c5be433b 1147 o = vdie(pat, &args);
cea2e8a9
GS		 1148 va_end(args);
1149 return o;
1150}
1151
c5be433b
GS		 1152void
1153Perl_vcroak(pTHX_ const char* pat, va_list *args)
cea2e8a9 1154{
de3bb511 1155 char *message;
748a9306
LW		 1156 HV *stash;
1157 GV *gv;
1158 CV *cv;
06bf62c7
GS		 1159 SV *msv;
1160 STRLEN msglen;
ff882698 1161 I32 utf8 = 0;
a687059c 1162
9983fa3c
GS		 1163 if (pat) {
1164 msv = vmess(pat, args);
1165 if (PL_errors && SvCUR(PL_errors)) {
1166 sv_catsv(PL_errors, msv);
1167 message = SvPV(PL_errors, msglen);
1168 SvCUR_set(PL_errors, 0);
1169 }
1170 else
1171 message = SvPV(msv,msglen);
ff882698 1172 utf8 = SvUTF8(msv);
9983fa3c
GS		 1173 }
1174 else {
1175 message = Nullch;
1176 msglen = 0;
5a844595 1177 }
5a844595 1178
b900a521
JH		 1179 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
1180 PTR2UV(thr), message));
5a844595 1181
3280af22 1182 if (PL_diehook) {
cea2e8a9 1183 /* sv_2cv might call Perl_croak() */
3280af22 1184 SV *olddiehook = PL_diehook;
1738f5c4 1185 ENTER;
3280af22
NIS		 1186 SAVESPTR(PL_diehook);
1187 PL_diehook = Nullsv;
20cec16a 1188 cv = sv_2cv(olddiehook, &stash, &gv, 0);
1738f5c4
CS		 1189 LEAVE;
1190 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1191 dSP;
774d564b 1192 SV *msg;
1193
1194 ENTER;
3a1f2dc9 1195 save_re_context();
9983fa3c
GS		 1196 if (message) {
1197 msg = newSVpvn(message, msglen);
ff882698 1198 SvFLAGS(msg) |= utf8;
9983fa3c
GS		 1199 SvREADONLY_on(msg);
1200 SAVEFREESV(msg);
1201 }
1202 else {
1203 msg = ERRSV;
1204 }
20cec16a 1205
e788e7d3 1206 PUSHSTACKi(PERLSI_DIEHOOK);
924508f0 1207 PUSHMARK(SP);
1738f5c4 1208 XPUSHs(msg);
20cec16a 1209 PUTBACK;
864dbfa3 1210 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1211 POPSTACK;
774d564b 1212 LEAVE;
20cec16a 1213 }
748a9306 1214 }
3280af22 1215 if (PL_in_eval) {
06bf62c7 1216 PL_restartop = die_where(message, msglen);
ff882698 1217 SvFLAGS(ERRSV) |= utf8;
6224f72b 1218 JMPENV_JUMP(3);
a0d0e21e 1219 }
84414e3e
JH		 1220 else if (!message)
1221 message = SvPVx(ERRSV, msglen);
1222
7ff03255 1223 write_to_stderr(message, msglen);
f86702cc 1224 my_failure_exit();
a687059c
LW		 1225}
1226
c5be433b 1227#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1228void
cea2e8a9 1229Perl_croak_nocontext(const char *pat, ...)
a687059c 1230{
cea2e8a9 1231 dTHX;
a687059c 1232 va_list args;
cea2e8a9 1233 va_start(args, pat);
c5be433b 1234 vcroak(pat, &args);
cea2e8a9
GS		 1235 /* NOTREACHED */
1236 va_end(args);
1237}
1238#endif /* PERL_IMPLICIT_CONTEXT */
1239
954c1994 1240/*
ccfc67b7
JH		 1241=head1 Warning and Dieing
1242
954c1994
GS		 1243=for apidoc croak
1244
9983fa3c 1245This is the XSUB-writer's interface to Perl's C<die> function.
966353fd
MF		 1246Normally call this function the same way you call the C C<printf>
1247function. Calling C<croak> returns control directly to Perl,
1248sidestepping the normal C order of execution. See C<warn>.
9983fa3c
GS		 1249
1250If you want to throw an exception object, assign the object to
1251C<$@> and then pass C<Nullch> to croak():
1252
1253 errsv = get_sv("@", TRUE);
1254 sv_setsv(errsv, exception_object);
1255 croak(Nullch);
954c1994
GS		 1256
1257=cut
1258*/
1259
cea2e8a9
GS		 1260void
1261Perl_croak(pTHX_ const char *pat, ...)
1262{
1263 va_list args;
1264 va_start(args, pat);
c5be433b 1265 vcroak(pat, &args);
cea2e8a9
GS		 1266 /* NOTREACHED */
1267 va_end(args);
1268}
1269
c5be433b
GS		 1270void
1271Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1272{
de3bb511 1273 char *message;
748a9306
LW		 1274 HV *stash;
1275 GV *gv;
1276 CV *cv;
06bf62c7
GS		 1277 SV *msv;
1278 STRLEN msglen;
ff882698 1279 I32 utf8 = 0;
a687059c 1280
5a844595 1281 msv = vmess(pat, args);
ff882698 1282 utf8 = SvUTF8(msv);
06bf62c7 1283 message = SvPV(msv, msglen);
a687059c 1284
3280af22 1285 if (PL_warnhook) {
cea2e8a9 1286 /* sv_2cv might call Perl_warn() */
3280af22 1287 SV *oldwarnhook = PL_warnhook;
1738f5c4 1288 ENTER;
3280af22
NIS		 1289 SAVESPTR(PL_warnhook);
1290 PL_warnhook = Nullsv;
20cec16a 1291 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
1738f5c4
CS		 1292 LEAVE;
1293 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
20cec16a 1294 dSP;
774d564b 1295 SV *msg;
1296
1297 ENTER;
3a1f2dc9 1298 save_re_context();
06bf62c7 1299 msg = newSVpvn(message, msglen);
ff882698 1300 SvFLAGS(msg) |= utf8;
774d564b 1301 SvREADONLY_on(msg);
1302 SAVEFREESV(msg);
1303
e788e7d3 1304 PUSHSTACKi(PERLSI_WARNHOOK);
924508f0 1305 PUSHMARK(SP);
774d564b 1306 XPUSHs(msg);
20cec16a 1307 PUTBACK;
864dbfa3 1308 call_sv((SV*)cv, G_DISCARD);
d3acc0f7 1309 POPSTACK;
774d564b 1310 LEAVE;
20cec16a 1311 return;
1312 }
748a9306 1313 }
87582a92 1314
7ff03255 1315 write_to_stderr(message, msglen);
a687059c 1316}
8d063cd8 1317
c5be433b 1318#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1319void
1320Perl_warn_nocontext(const char *pat, ...)
1321{
1322 dTHX;
1323 va_list args;
1324 va_start(args, pat);
c5be433b 1325 vwarn(pat, &args);
cea2e8a9
GS		 1326 va_end(args);
1327}
1328#endif /* PERL_IMPLICIT_CONTEXT */
1329
954c1994
GS		 1330/*
1331=for apidoc warn
1332
966353fd
MF		 1333This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1334function the same way you call the C C<printf> function. See C<croak>.
954c1994
GS		 1335
1336=cut
1337*/
1338
cea2e8a9
GS		 1339void
1340Perl_warn(pTHX_ const char *pat, ...)
1341{
1342 va_list args;
1343 va_start(args, pat);
c5be433b 1344 vwarn(pat, &args);
cea2e8a9
GS		 1345 va_end(args);
1346}
1347
c5be433b
GS		 1348#if defined(PERL_IMPLICIT_CONTEXT)
1349void
1350Perl_warner_nocontext(U32 err, const char *pat, ...)
1351{
1352 dTHX;
1353 va_list args;
1354 va_start(args, pat);
1355 vwarner(err, pat, &args);
1356 va_end(args);
1357}
1358#endif /* PERL_IMPLICIT_CONTEXT */
1359
599cee73 1360void
864dbfa3 1361Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1362{
1363 va_list args;
c5be433b
GS		 1364 va_start(args, pat);
1365 vwarner(err, pat, &args);
1366 va_end(args);
1367}
1368
1369void
1370Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1371{
d13b0d77 1372 if (ckDEAD(err)) {
63315e18 1373 SV *msv = vmess(pat, args);
d13b0d77 1374 STRLEN msglen;
63315e18
NC		 1375 char *message = SvPV(msv, msglen);
1376 I32 utf8 = SvUTF8(msv);
599cee73 1377
3aed30dc 1378 if (PL_diehook) {
63315e18
NC		 1379 assert(message);
1380 S_vdie_common(aTHX_ message, msglen, utf8);
3aed30dc
HS		 1381 }
1382 if (PL_in_eval) {
1383 PL_restartop = die_where(message, msglen);
ff882698 1384 SvFLAGS(ERRSV) |= utf8;
3aed30dc
HS		 1385 JMPENV_JUMP(3);
1386 }
7ff03255 1387 write_to_stderr(message, msglen);
3aed30dc 1388 my_failure_exit();
599cee73
PM		 1389 }
1390 else {
d13b0d77 1391 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 1392 }
1393}
1394
e6587932
DM		 1395/* since we've already done strlen() for both nam and val
1396 * we can use that info to make things faster than
1397 * sprintf(s, "%s=%s", nam, val)
1398 */
1399#define my_setenv_format(s, nam, nlen, val, vlen) \
1400 Copy(nam, s, nlen, char); \
1401 *(s+nlen) = '='; \
1402 Copy(val, s+(nlen+1), vlen, char); \
1403 *(s+(nlen+1+vlen)) = '\0'
1404
13b6e58c 1405#ifdef USE_ENVIRON_ARRAY
eccd403f 1406 /* VMS' my_setenv() is in vms.c */
2986a63f 1407#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1408void
864dbfa3 1409Perl_my_setenv(pTHX_ char *nam, char *val)
8d063cd8 1410{
4efc5df6
GS		 1411#ifdef USE_ITHREADS
1412 /* only parent thread can modify process environment */
1413 if (PL_curinterp == aTHX)
1414#endif
1415 {
f2517201
GS		 1416#ifndef PERL_USE_SAFE_PUTENV
1417 /* most putenv()s leak, so we manipulate environ directly */
79072805 1418 register I32 i=setenv_getix(nam); /* where does it go? */
e6587932 1419 int nlen, vlen;
8d063cd8 1420
3280af22 1421 if (environ == PL_origenviron) { /* need we copy environment? */
79072805
LW		 1422 I32 j;
1423 I32 max;
fe14fcc3
LW		 1424 char **tmpenv;
1425
de3bb511 1426 /*SUPPRESS 530*/
fe14fcc3 1427 for (max = i; environ[max]; max++) ;
f2517201
GS		 1428 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1429 for (j=0; j<max; j++) { /* copy environment */
3aed30dc
HS		 1430 int len = strlen(environ[j]);
1431 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1432 Copy(environ[j], tmpenv[j], len+1, char);
f2517201 1433 }
fe14fcc3
LW		 1434 tmpenv[max] = Nullch;
1435 environ = tmpenv; /* tell exec where it is now */
1436 }
a687059c 1437 if (!val) {
f2517201 1438 safesysfree(environ[i]);
a687059c
LW		 1439 while (environ[i]) {
1440 environ[i] = environ[i+1];
1441 i++;
1442 }
1443 return;
1444 }
8d063cd8 1445 if (!environ[i]) { /* does not exist yet */
f2517201 1446 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
8d063cd8
LW		 1447 environ[i+1] = Nullch; /* make sure it's null terminated */
1448 }
fe14fcc3 1449 else
f2517201 1450 safesysfree(environ[i]);
e6587932
DM		 1451 nlen = strlen(nam);
1452 vlen = strlen(val);
f2517201 1453
e6587932
DM		 1454 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1455 /* all that work just for this */
1456 my_setenv_format(environ[i], nam, nlen, val, vlen);
f2517201
GS		 1457
1458#else /* PERL_USE_SAFE_PUTENV */
eccd403f 1459# if defined(__CYGWIN__) || defined( EPOC)
47dafe4d
EF		 1460 setenv(nam, val, 1);
1461# else
f2517201 1462 char *new_env;
e6587932
DM		 1463 int nlen = strlen(nam), vlen;
1464 if (!val) {
3aed30dc 1465 val = "";
e6587932
DM		 1466 }
1467 vlen = strlen(val);
1468 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1469 /* all that work just for this */
1470 my_setenv_format(new_env, nam, nlen, val, vlen);
f2517201 1471 (void)putenv(new_env);
47dafe4d 1472# endif /* __CYGWIN__ */
f2517201 1473#endif /* PERL_USE_SAFE_PUTENV */
4efc5df6 1474 }
8d063cd8
LW		 1475}
1476
2986a63f 1477#else /* WIN32 || NETWARE */
68dc0745 1478
1479void
864dbfa3 1480Perl_my_setenv(pTHX_ char *nam,char *val)
68dc0745 1481{
ac5c734f 1482 register char *envstr;
e6587932
DM		 1483 int nlen = strlen(nam), vlen;
1484
ac5c734f
GS		 1485 if (!val) {
1486 val = "";
1487 }
e6587932
DM		 1488 vlen = strlen(val);
1489 New(904, envstr, nlen+vlen+2, char);
1490 my_setenv_format(envstr, nam, nlen, val, vlen);
ac5c734f
GS		 1491 (void)PerlEnv_putenv(envstr);
1492 Safefree(envstr);
3e3baf6d
TB		 1493}
1494
2986a63f 1495#endif /* WIN32 || NETWARE */
3e3baf6d 1496
2f42fcb0 1497#ifndef PERL_MICRO
3e3baf6d 1498I32
864dbfa3 1499Perl_setenv_getix(pTHX_ char *nam)
3e3baf6d
TB		 1500{
1501 register I32 i, len = strlen(nam);
1502
1503 for (i = 0; environ[i]; i++) {
1504 if (
1505#ifdef WIN32
1506 strnicmp(environ[i],nam,len) == 0
1507#else
1508 strnEQ(environ[i],nam,len)
1509#endif
1510 && environ[i][len] == '=')
1511 break; /* strnEQ must come first to avoid */
1512 } /* potential SEGV's */
1513 return i;
68dc0745 1514}
2f42fcb0 1515#endif /* !PERL_MICRO */
68dc0745 1516
ed79a026 1517#endif /* !VMS && !EPOC*/
378cc40b 1518
16d20bd9 1519#ifdef UNLINK_ALL_VERSIONS
79072805 1520I32
864dbfa3 1521Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
378cc40b 1522{
79072805 1523 I32 i;
378cc40b 1524
6ad3d225 1525 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
378cc40b
LW		 1526 return i ? 0 : -1;
1527}
1528#endif
1529
7a3f2258 1530/* this is a drop-in replacement for bcopy() */
2253333f 1531#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1532char *
7a3f2258 1533Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b
LW		 1534{
1535 char *retval = to;
1536
7c0587c8
LW		 1537 if (from - to >= 0) {
1538 while (len--)
1539 *to++ = *from++;
1540 }
1541 else {
1542 to += len;
1543 from += len;
1544 while (len--)
faf8582f 1545 *(--to) = *(--from);
7c0587c8 1546 }
378cc40b
LW		 1547 return retval;
1548}
ffed7fef 1549#endif
378cc40b 1550
7a3f2258 1551/* this is a drop-in replacement for memset() */
fc36a67e 1552#ifndef HAS_MEMSET
1553void *
7a3f2258 1554Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1555{
1556 char *retval = loc;
1557
1558 while (len--)
1559 *loc++ = ch;
1560 return retval;
1561}
1562#endif
1563
7a3f2258 1564/* this is a drop-in replacement for bzero() */
7c0587c8 1565#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1566char *
7a3f2258 1567Perl_my_bzero(register char *loc, register I32 len)
378cc40b
LW		 1568{
1569 char *retval = loc;
1570
1571 while (len--)
1572 *loc++ = 0;
1573 return retval;
1574}
1575#endif
7c0587c8 1576
7a3f2258 1577/* this is a drop-in replacement for memcmp() */
36477c24 1578#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1579I32
7a3f2258 1580Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1581{
36477c24 1582 register U8 *a = (U8 *)s1;
1583 register U8 *b = (U8 *)s2;
79072805 1584 register I32 tmp;
7c0587c8
LW		 1585
1586 while (len--) {
36477c24 1587 if (tmp = *a++ - *b++)
7c0587c8
LW		 1588 return tmp;
1589 }
1590 return 0;
1591}
36477c24 1592#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1593
fe14fcc3 1594#ifndef HAS_VPRINTF
a687059c 1595
85e6fe83 1596#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1597char *
1598#else
1599int
1600#endif
08105a92 1601vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 1602{
1603 FILE fakebuf;
1604
1605 fakebuf._ptr = dest;
1606 fakebuf._cnt = 32767;
35c8bce7
LW		 1607#ifndef _IOSTRG
1608#define _IOSTRG 0
1609#endif
a687059c
LW		 1610 fakebuf._flag = _IOWRT|_IOSTRG;
1611 _doprnt(pat, args, &fakebuf); /* what a kludge */
1612 (void)putc('\0', &fakebuf);
85e6fe83 1613#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1614 return(dest);
1615#else
1616 return 0; /* perl doesn't use return value */
1617#endif
1618}
1619
fe14fcc3 1620#endif /* HAS_VPRINTF */
a687059c
LW		 1621
1622#ifdef MYSWAP
ffed7fef 1623#if BYTEORDER != 0x4321
a687059c 1624short
864dbfa3 1625Perl_my_swap(pTHX_ short s)
a687059c
LW		 1626{
1627#if (BYTEORDER & 1) == 0
1628 short result;
1629
1630 result = ((s & 255) << 8) + ((s >> 8) & 255);
1631 return result;
1632#else
1633 return s;
1634#endif
1635}
1636
1637long
864dbfa3 1638Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1639{
1640 union {
1641 long result;
ffed7fef 1642 char c[sizeof(long)];
a687059c
LW		 1643 } u;
1644
ffed7fef 1645#if BYTEORDER == 0x1234
a687059c
LW		 1646 u.c[0] = (l >> 24) & 255;
1647 u.c[1] = (l >> 16) & 255;
1648 u.c[2] = (l >> 8) & 255;
1649 u.c[3] = l & 255;
1650 return u.result;
1651#else
ffed7fef 1652#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1653 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1654#else
79072805
LW		 1655 register I32 o;
1656 register I32 s;
a687059c 1657
ffed7fef
LW		 1658 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1659 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1660 }
1661 return u.result;
1662#endif
1663#endif
1664}
1665
1666long
864dbfa3 1667Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1668{
1669 union {
1670 long l;
ffed7fef 1671 char c[sizeof(long)];
a687059c
LW		 1672 } u;
1673
ffed7fef 1674#if BYTEORDER == 0x1234
a687059c
LW		 1675 u.c[0] = (l >> 24) & 255;
1676 u.c[1] = (l >> 16) & 255;
1677 u.c[2] = (l >> 8) & 255;
1678 u.c[3] = l & 255;
1679 return u.l;
1680#else
ffed7fef 1681#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1682 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1683#else
79072805
LW		 1684 register I32 o;
1685 register I32 s;
a687059c
LW		 1686
1687 u.l = l;
1688 l = 0;
ffed7fef
LW		 1689 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1690 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1691 }
1692 return l;
1693#endif
1694#endif
1695}
1696
ffed7fef 1697#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1698#endif /* MYSWAP */
1699
1700/*
1701 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1702 * If these functions are defined,
1703 * the BYTEORDER is neither 0x1234 nor 0x4321.
1704 * However, this is not assumed.
1705 * -DWS
1706 */
1707
1109a392 1708#define HTOLE(name,type) \
988174c1 1709 type \
ba106d47 1710 name (register type n) \
988174c1
LW		 1711 { \
1712 union { \
1713 type value; \
1714 char c[sizeof(type)]; \
1715 } u; \
79072805 1716 register I32 i; \
1109a392
MHM		 1717 register I32 s = 0; \
1718 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW		 1719 u.c[i] = (n >> s) & 0xFF; \
1720 } \
1721 return u.value; \
1722 }
1723
1109a392 1724#define LETOH(name,type) \
988174c1 1725 type \
ba106d47 1726 name (register type n) \
988174c1
LW		 1727 { \
1728 union { \
1729 type value; \
1730 char c[sizeof(type)]; \
1731 } u; \
79072805 1732 register I32 i; \
1109a392 1733 register I32 s = 0; \
988174c1
LW		 1734 u.value = n; \
1735 n = 0; \
1109a392
MHM		 1736 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1737 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW		 1738 } \
1739 return n; \
1740 }
1741
1109a392
MHM		 1742/*
1743 * Big-endian byte order functions.
1744 */
1745
1746#define HTOBE(name,type) \
1747 type \
1748 name (register type n) \
1749 { \
1750 union { \
1751 type value; \
1752 char c[sizeof(type)]; \
1753 } u; \
1754 register I32 i; \
1755 register I32 s = 8*(sizeof(u.c)-1); \
1756 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1757 u.c[i] = (n >> s) & 0xFF; \
1758 } \
1759 return u.value; \
1760 }
1761
1762#define BETOH(name,type) \
1763 type \
1764 name (register type n) \
1765 { \
1766 union { \
1767 type value; \
1768 char c[sizeof(type)]; \
1769 } u; \
1770 register I32 i; \
1771 register I32 s = 8*(sizeof(u.c)-1); \
1772 u.value = n; \
1773 n = 0; \
1774 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1775 n |= ((type)(u.c[i] & 0xFF)) << s; \
1776 } \
1777 return n; \
1778 }
1779
1780/*
1781 * If we just can't do it...
1782 */
1783
1784#define NOT_AVAIL(name,type) \
1785 type \
1786 name (register type n) \
1787 { \
1788 Perl_croak_nocontext(#name "() not available"); \
1789 return n; /* not reached */ \
1790 }
1791
1792
988174c1 1793#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 1794HTOLE(htovs,short)
988174c1
LW		 1795#endif
1796#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 1797HTOLE(htovl,long)
988174c1
LW		 1798#endif
1799#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 1800LETOH(vtohs,short)
988174c1
LW		 1801#endif
1802#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM		 1803LETOH(vtohl,long)
1804#endif
1805
1806#ifdef PERL_NEED_MY_HTOLE16
1807# if U16SIZE == 2
1808HTOLE(Perl_my_htole16,U16)
1809# else
1810NOT_AVAIL(Perl_my_htole16,U16)
1811# endif
1812#endif
1813#ifdef PERL_NEED_MY_LETOH16
1814# if U16SIZE == 2
1815LETOH(Perl_my_letoh16,U16)
1816# else
1817NOT_AVAIL(Perl_my_letoh16,U16)
1818# endif
1819#endif
1820#ifdef PERL_NEED_MY_HTOBE16
1821# if U16SIZE == 2
1822HTOBE(Perl_my_htobe16,U16)
1823# else
1824NOT_AVAIL(Perl_my_htobe16,U16)
1825# endif
1826#endif
1827#ifdef PERL_NEED_MY_BETOH16
1828# if U16SIZE == 2
1829BETOH(Perl_my_betoh16,U16)
1830# else
1831NOT_AVAIL(Perl_my_betoh16,U16)
1832# endif
1833#endif
1834
1835#ifdef PERL_NEED_MY_HTOLE32
1836# if U32SIZE == 4
1837HTOLE(Perl_my_htole32,U32)
1838# else
1839NOT_AVAIL(Perl_my_htole32,U32)
1840# endif
1841#endif
1842#ifdef PERL_NEED_MY_LETOH32
1843# if U32SIZE == 4
1844LETOH(Perl_my_letoh32,U32)
1845# else
1846NOT_AVAIL(Perl_my_letoh32,U32)
1847# endif
1848#endif
1849#ifdef PERL_NEED_MY_HTOBE32
1850# if U32SIZE == 4
1851HTOBE(Perl_my_htobe32,U32)
1852# else
1853NOT_AVAIL(Perl_my_htobe32,U32)
1854# endif
1855#endif
1856#ifdef PERL_NEED_MY_BETOH32
1857# if U32SIZE == 4
1858BETOH(Perl_my_betoh32,U32)
1859# else
1860NOT_AVAIL(Perl_my_betoh32,U32)
1861# endif
1862#endif
1863
1864#ifdef PERL_NEED_MY_HTOLE64
1865# if U64SIZE == 8
1866HTOLE(Perl_my_htole64,U64)
1867# else
1868NOT_AVAIL(Perl_my_htole64,U64)
1869# endif
1870#endif
1871#ifdef PERL_NEED_MY_LETOH64
1872# if U64SIZE == 8
1873LETOH(Perl_my_letoh64,U64)
1874# else
1875NOT_AVAIL(Perl_my_letoh64,U64)
1876# endif
1877#endif
1878#ifdef PERL_NEED_MY_HTOBE64
1879# if U64SIZE == 8
1880HTOBE(Perl_my_htobe64,U64)
1881# else
1882NOT_AVAIL(Perl_my_htobe64,U64)
1883# endif
1884#endif
1885#ifdef PERL_NEED_MY_BETOH64
1886# if U64SIZE == 8
1887BETOH(Perl_my_betoh64,U64)
1888# else
1889NOT_AVAIL(Perl_my_betoh64,U64)
1890# endif
988174c1 1891#endif
a687059c 1892
1109a392
MHM		 1893#ifdef PERL_NEED_MY_HTOLES
1894HTOLE(Perl_my_htoles,short)
1895#endif
1896#ifdef PERL_NEED_MY_LETOHS
1897LETOH(Perl_my_letohs,short)
1898#endif
1899#ifdef PERL_NEED_MY_HTOBES
1900HTOBE(Perl_my_htobes,short)
1901#endif
1902#ifdef PERL_NEED_MY_BETOHS
1903BETOH(Perl_my_betohs,short)
1904#endif
1905
1906#ifdef PERL_NEED_MY_HTOLEI
1907HTOLE(Perl_my_htolei,int)
1908#endif
1909#ifdef PERL_NEED_MY_LETOHI
1910LETOH(Perl_my_letohi,int)
1911#endif
1912#ifdef PERL_NEED_MY_HTOBEI
1913HTOBE(Perl_my_htobei,int)
1914#endif
1915#ifdef PERL_NEED_MY_BETOHI
1916BETOH(Perl_my_betohi,int)
1917#endif
1918
1919#ifdef PERL_NEED_MY_HTOLEL
1920HTOLE(Perl_my_htolel,long)
1921#endif
1922#ifdef PERL_NEED_MY_LETOHL
1923LETOH(Perl_my_letohl,long)
1924#endif
1925#ifdef PERL_NEED_MY_HTOBEL
1926HTOBE(Perl_my_htobel,long)
1927#endif
1928#ifdef PERL_NEED_MY_BETOHL
1929BETOH(Perl_my_betohl,long)
1930#endif
1931
1932void
1933Perl_my_swabn(void *ptr, int n)
1934{
1935 register char *s = (char *)ptr;
1936 register char *e = s + (n-1);
1937 register char tc;
1938
1939 for (n /= 2; n > 0; s++, e--, n--) {
1940 tc = *s;
1941 *s = *e;
1942 *e = tc;
1943 }
1944}
1945
4a7d1889
NIS		 1946PerlIO *
1947Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1948{
2986a63f 1949#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1f852d0d
NIS		 1950 int p[2];
1951 register I32 This, that;
1952 register Pid_t pid;
1953 SV *sv;
1954 I32 did_pipes = 0;
1955 int pp[2];
1956
1957 PERL_FLUSHALL_FOR_CHILD;
1958 This = (*mode == 'w');
1959 that = !This;
1960 if (PL_tainting) {
1961 taint_env();
1962 taint_proper("Insecure %s%s", "EXEC");
1963 }
1964 if (PerlProc_pipe(p) < 0)
1965 return Nullfp;
1966 /* Try for another pipe pair for error return */
1967 if (PerlProc_pipe(pp) >= 0)
1968 did_pipes = 1;
52e18b1f 1969 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 1970 if (errno != EAGAIN) {
1971 PerlLIO_close(p[This]);
4e6dfe71 1972 PerlLIO_close(p[that]);
1f852d0d
NIS		 1973 if (did_pipes) {
1974 PerlLIO_close(pp[0]);
1975 PerlLIO_close(pp[1]);
1976 }
1977 return Nullfp;
1978 }
1979 sleep(5);
1980 }
1981 if (pid == 0) {
1982 /* Child */
1f852d0d
NIS		 1983#undef THIS
1984#undef THAT
1985#define THIS that
1986#define THAT This
1f852d0d
NIS		 1987 /* Close parent's end of error status pipe (if any) */
1988 if (did_pipes) {
1989 PerlLIO_close(pp[0]);
1990#if defined(HAS_FCNTL) && defined(F_SETFD)
1991 /* Close error pipe automatically if exec works */
1992 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1993#endif
1994 }
1995 /* Now dup our end of _the_ pipe to right position */
1996 if (p[THIS] != (*mode == 'r')) {
1997 PerlLIO_dup2(p[THIS], *mode == 'r');
1998 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 1999 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2000 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2001 }
4e6dfe71
GS		 2002 else
2003 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2004#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2005 /* No automatic close - do it by hand */
b7953727
JH		 2006# ifndef NOFILE
2007# define NOFILE 20
2008# endif
a080fe3d
NIS		 2009 {
2010 int fd;
2011
2012 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2013 if (fd != pp[1])
a080fe3d
NIS		 2014 PerlLIO_close(fd);
2015 }
1f852d0d
NIS		 2016 }
2017#endif
2018 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2019 PerlProc__exit(1);
2020#undef THIS
2021#undef THAT
2022 }
2023 /* Parent */
52e18b1f 2024 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2025 if (did_pipes)
2026 PerlLIO_close(pp[1]);
2027 /* Keep the lower of the two fd numbers */
2028 if (p[that] < p[This]) {
2029 PerlLIO_dup2(p[This], p[that]);
2030 PerlLIO_close(p[This]);
2031 p[This] = p[that];
2032 }
4e6dfe71
GS		 2033 else
2034 PerlLIO_close(p[that]); /* close child's end of pipe */
2035
1f852d0d
NIS		 2036 LOCK_FDPID_MUTEX;
2037 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2038 UNLOCK_FDPID_MUTEX;
2039 (void)SvUPGRADE(sv,SVt_IV);
2040 SvIVX(sv) = pid;
2041 PL_forkprocess = pid;
2042 /* If we managed to get status pipe check for exec fail */
2043 if (did_pipes && pid > 0) {
2044 int errkid;
2045 int n = 0, n1;
2046
2047 while (n < sizeof(int)) {
2048 n1 = PerlLIO_read(pp[0],
2049 (void*)(((char*)&errkid)+n),
2050 (sizeof(int)) - n);
2051 if (n1 <= 0)
2052 break;
2053 n += n1;
2054 }
2055 PerlLIO_close(pp[0]);
2056 did_pipes = 0;
2057 if (n) { /* Error */
2058 int pid2, status;
8c51524e 2059 PerlLIO_close(p[This]);
1f852d0d
NIS		 2060 if (n != sizeof(int))
2061 Perl_croak(aTHX_ "panic: kid popen errno read");
2062 do {
2063 pid2 = wait4pid(pid, &status, 0);
2064 } while (pid2 == -1 && errno == EINTR);
2065 errno = errkid; /* Propagate errno from kid */
2066 return Nullfp;
2067 }
2068 }
2069 if (did_pipes)
2070 PerlLIO_close(pp[0]);
2071 return PerlIO_fdopen(p[This], mode);
2072#else
4a7d1889
NIS		 2073 Perl_croak(aTHX_ "List form of piped open not implemented");
2074 return (PerlIO *) NULL;
1f852d0d 2075#endif
4a7d1889
NIS		 2076}
2077
5f05dabc 2078 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2079#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2080PerlIO *
864dbfa3 2081Perl_my_popen(pTHX_ char *cmd, char *mode)
a687059c
LW		 2082{
2083 int p[2];
8ac85365 2084 register I32 This, that;
d8a83dd3 2085 register Pid_t pid;
79072805 2086 SV *sv;
1738f5c4 2087 I32 doexec = strNE(cmd,"-");
e446cec8
IZ		 2088 I32 did_pipes = 0;
2089 int pp[2];
a687059c 2090
45bc9206 2091 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2092#ifdef OS2
2093 if (doexec) {
23da6c43 2094 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2095 }
a1d180c4 2096#endif
8ac85365
NIS		 2097 This = (*mode == 'w');
2098 that = !This;
3280af22 2099 if (doexec && PL_tainting) {
bbce6d69 2100 taint_env();
2101 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2102 }
c2267164
IZ		 2103 if (PerlProc_pipe(p) < 0)
2104 return Nullfp;
e446cec8
IZ		 2105 if (doexec && PerlProc_pipe(pp) >= 0)
2106 did_pipes = 1;
52e18b1f 2107 while ((pid = PerlProc_fork()) < 0) {
a687059c 2108 if (errno != EAGAIN) {
6ad3d225 2109 PerlLIO_close(p[This]);
b5ac89c3 2110 PerlLIO_close(p[that]);
e446cec8
IZ		 2111 if (did_pipes) {
2112 PerlLIO_close(pp[0]);
2113 PerlLIO_close(pp[1]);
2114 }
a687059c 2115 if (!doexec)
cea2e8a9 2116 Perl_croak(aTHX_ "Can't fork");
a687059c
LW		 2117 return Nullfp;
2118 }
2119 sleep(5);
2120 }
2121 if (pid == 0) {
79072805
LW		 2122 GV* tmpgv;
2123
30ac6d9b
GS		 2124#undef THIS
2125#undef THAT
a687059c 2126#define THIS that
8ac85365 2127#define THAT This
e446cec8
IZ		 2128 if (did_pipes) {
2129 PerlLIO_close(pp[0]);
2130#if defined(HAS_FCNTL) && defined(F_SETFD)
2131 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2132#endif
2133 }
a687059c 2134 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2135 PerlLIO_dup2(p[THIS], *mode == 'r');
2136 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2137 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2138 PerlLIO_close(p[THAT]);
a687059c 2139 }
b5ac89c3
NIS		 2140 else
2141 PerlLIO_close(p[THAT]);
4435c477 2142#ifndef OS2
a687059c 2143 if (doexec) {
a0d0e21e 2144#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2145 int fd;
2146
2147#ifndef NOFILE
2148#define NOFILE 20
2149#endif
a080fe3d 2150 {
3aed30dc 2151 int fd;
a080fe3d
NIS		 2152
2153 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2154 if (fd != pp[1])
3aed30dc 2155 PerlLIO_close(fd);
a080fe3d 2156 }
ae986130 2157#endif
a080fe3d
NIS		 2158 /* may or may not use the shell */
2159 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2160 PerlProc__exit(1);
a687059c 2161 }
4435c477 2162#endif /* defined OS2 */
de3bb511 2163 /*SUPPRESS 560*/
306196c3 2164 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4d76a344 2165 SvREADONLY_off(GvSV(tmpgv));
7766f137 2166 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2167 SvREADONLY_on(GvSV(tmpgv));
2168 }
2169#ifdef THREADS_HAVE_PIDS
2170 PL_ppid = (IV)getppid();
2171#endif
3280af22
NIS		 2172 PL_forkprocess = 0;
2173 hv_clear(PL_pidstatus); /* we have no children */
a687059c
LW		 2174 return Nullfp;
2175#undef THIS
2176#undef THAT
2177 }
b5ac89c3 2178 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2179 if (did_pipes)
2180 PerlLIO_close(pp[1]);
8ac85365 2181 if (p[that] < p[This]) {
6ad3d225
GS		 2182 PerlLIO_dup2(p[This], p[that]);
2183 PerlLIO_close(p[This]);
8ac85365 2184 p[This] = p[that];
62b28dd9 2185 }
b5ac89c3
NIS		 2186 else
2187 PerlLIO_close(p[that]);
2188
4755096e 2189 LOCK_FDPID_MUTEX;
3280af22 2190 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2191 UNLOCK_FDPID_MUTEX;
a0d0e21e 2192 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2193 SvIVX(sv) = pid;
3280af22 2194 PL_forkprocess = pid;
e446cec8
IZ		 2195 if (did_pipes && pid > 0) {
2196 int errkid;
2197 int n = 0, n1;
2198
2199 while (n < sizeof(int)) {
2200 n1 = PerlLIO_read(pp[0],
2201 (void*)(((char*)&errkid)+n),
2202 (sizeof(int)) - n);
2203 if (n1 <= 0)
2204 break;
2205 n += n1;
2206 }
2f96c702
IZ		 2207 PerlLIO_close(pp[0]);
2208 did_pipes = 0;
e446cec8 2209 if (n) { /* Error */
faa466a7 2210 int pid2, status;
8c51524e 2211 PerlLIO_close(p[This]);
e446cec8 2212 if (n != sizeof(int))
cea2e8a9 2213 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2214 do {
2215 pid2 = wait4pid(pid, &status, 0);
2216 } while (pid2 == -1 && errno == EINTR);
e446cec8
IZ		 2217 errno = errkid; /* Propagate errno from kid */
2218 return Nullfp;
2219 }
2220 }
2221 if (did_pipes)
2222 PerlLIO_close(pp[0]);
8ac85365 2223 return PerlIO_fdopen(p[This], mode);
a687059c 2224}
7c0587c8 2225#else
85ca448a 2226#if defined(atarist) || defined(EPOC)
7c0587c8 2227FILE *popen();
760ac839 2228PerlIO *
864dbfa3 2229Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2230{
45bc9206 2231 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2232 /* Call system's popen() to get a FILE *, then import it.
2233 used 0 for 2nd parameter to PerlIO_importFILE;
2234 apparently not used
2235 */
2236 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2237}
2b96b0a5
JH		 2238#else
2239#if defined(DJGPP)
2240FILE *djgpp_popen();
2241PerlIO *
2242Perl_my_popen(pTHX_ char *cmd, char *mode)
2243{
2244 PERL_FLUSHALL_FOR_CHILD;
2245 /* Call system's popen() to get a FILE *, then import it.
2246 used 0 for 2nd parameter to PerlIO_importFILE;
2247 apparently not used
2248 */
2249 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2250}
2251#endif
7c0587c8
LW		 2252#endif
2253
2254#endif /* !DOSISH */
a687059c 2255
52e18b1f
GS		 2256/* this is called in parent before the fork() */
2257void
2258Perl_atfork_lock(void)
2259{
3db8f154 2260#if defined(USE_ITHREADS)
52e18b1f
GS		 2261 /* locks must be held in locking order (if any) */
2262# ifdef MYMALLOC
2263 MUTEX_LOCK(&PL_malloc_mutex);
2264# endif
2265 OP_REFCNT_LOCK;
2266#endif
2267}
2268
2269/* this is called in both parent and child after the fork() */
2270void
2271Perl_atfork_unlock(void)
2272{
3db8f154 2273#if defined(USE_ITHREADS)
52e18b1f
GS		 2274 /* locks must be released in same order as in atfork_lock() */
2275# ifdef MYMALLOC
2276 MUTEX_UNLOCK(&PL_malloc_mutex);
2277# endif
2278 OP_REFCNT_UNLOCK;
2279#endif
2280}
2281
2282Pid_t
2283Perl_my_fork(void)
2284{
2285#if defined(HAS_FORK)
2286 Pid_t pid;
3db8f154 2287#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2288 atfork_lock();
2289 pid = fork();
2290 atfork_unlock();
2291#else
2292 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2293 * handlers elsewhere in the code */
2294 pid = fork();
2295#endif
2296 return pid;
2297#else
2298 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2299 Perl_croak_nocontext("fork() not available");
b961a566 2300 return 0;
52e18b1f
GS		 2301#endif /* HAS_FORK */
2302}
2303
748a9306 2304#ifdef DUMP_FDS
35ff7856 2305void
864dbfa3 2306Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2307{
2308 int fd;
c623ac67 2309 Stat_t tmpstatbuf;
ae986130 2310
bf49b057 2311 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2312 for (fd = 0; fd < 32; fd++) {
6ad3d225 2313 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2314 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2315 }
bf49b057 2316 PerlIO_printf(Perl_debug_log,"\n");
ae986130 2317}
35ff7856 2318#endif /* DUMP_FDS */
ae986130 2319
fe14fcc3 2320#ifndef HAS_DUP2
fec02dd3 2321int
ba106d47 2322dup2(int oldfd, int newfd)
a687059c 2323{
a0d0e21e 2324#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2325 if (oldfd == newfd)
2326 return oldfd;
6ad3d225 2327 PerlLIO_close(newfd);
fec02dd3 2328 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2329#else
fc36a67e 2330#define DUP2_MAX_FDS 256
2331 int fdtmp[DUP2_MAX_FDS];
79072805 2332 I32 fdx = 0;
ae986130
LW		 2333 int fd;
2334
fe14fcc3 2335 if (oldfd == newfd)
fec02dd3 2336 return oldfd;
6ad3d225 2337 PerlLIO_close(newfd);
fc36a67e 2338 /* good enough for low fd's... */
6ad3d225 2339 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2340 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2341 PerlLIO_close(fd);
fc36a67e 2342 fd = -1;
2343 break;
2344 }
ae986130 2345 fdtmp[fdx++] = fd;
fc36a67e 2346 }
ae986130 2347 while (fdx > 0)
6ad3d225 2348 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2349 return fd;
62b28dd9 2350#endif
a687059c
LW		 2351}
2352#endif
2353
64ca3a65 2354#ifndef PERL_MICRO
ff68c719 2355#ifdef HAS_SIGACTION
2356
abea2c45
HS		 2357#ifdef MACOS_TRADITIONAL
2358/* We don't want restart behavior on MacOS */
2359#undef SA_RESTART
2360#endif
2361
ff68c719 2362Sighandler_t
864dbfa3 2363Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2364{
2365 struct sigaction act, oact;
2366
a10b1e10
JH		 2367#ifdef USE_ITHREADS
2368 /* only "parent" interpreter can diddle signals */
2369 if (PL_curinterp != aTHX)
2370 return SIG_ERR;
2371#endif
2372
ff68c719 2373 act.sa_handler = handler;
2374 sigemptyset(&act.sa_mask);
2375 act.sa_flags = 0;
2376#ifdef SA_RESTART
4ffa73a3
JH		 2377 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2378 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2379#endif
358837b8 2380#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
85264bed
CS		 2381 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2382 act.sa_flags |= SA_NOCLDWAIT;
2383#endif
ff68c719 2384 if (sigaction(signo, &act, &oact) == -1)
36477c24 2385 return SIG_ERR;
ff68c719 2386 else
36477c24 2387 return oact.sa_handler;
ff68c719 2388}
2389
2390Sighandler_t
864dbfa3 2391Perl_rsignal_state(pTHX_ int signo)
ff68c719 2392{
2393 struct sigaction oact;
2394
2395 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3aed30dc 2396 return SIG_ERR;
ff68c719 2397 else
3aed30dc 2398 return oact.sa_handler;
ff68c719 2399}
2400
2401int
864dbfa3 2402Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2403{
2404 struct sigaction act;
2405
a10b1e10
JH		 2406#ifdef USE_ITHREADS
2407 /* only "parent" interpreter can diddle signals */
2408 if (PL_curinterp != aTHX)
2409 return -1;
2410#endif
2411
ff68c719 2412 act.sa_handler = handler;
2413 sigemptyset(&act.sa_mask);
2414 act.sa_flags = 0;
2415#ifdef SA_RESTART
4ffa73a3
JH		 2416 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2417 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2418#endif
36b5d377 2419#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
85264bed
CS		 2420 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2421 act.sa_flags |= SA_NOCLDWAIT;
2422#endif
ff68c719 2423 return sigaction(signo, &act, save);
2424}
2425
2426int
864dbfa3 2427Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2428{
a10b1e10
JH		 2429#ifdef USE_ITHREADS
2430 /* only "parent" interpreter can diddle signals */
2431 if (PL_curinterp != aTHX)
2432 return -1;
2433#endif
2434
ff68c719 2435 return sigaction(signo, save, (struct sigaction *)NULL);
2436}
2437
2438#else /* !HAS_SIGACTION */
2439
2440Sighandler_t
864dbfa3 2441Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2442{
39f1703b 2443#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2444 /* only "parent" interpreter can diddle signals */
2445 if (PL_curinterp != aTHX)
2446 return SIG_ERR;
2447#endif
2448
6ad3d225 2449 return PerlProc_signal(signo, handler);
ff68c719 2450}
2451
df3728a2
JH		 2452static int sig_trapped; /* XXX signals are process-wide anyway, so we
2453 ignore the implications of this for threading */
ff68c719 2454
2455static
2456Signal_t
4e35701f 2457sig_trap(int signo)
ff68c719 2458{
2459 sig_trapped++;
2460}
2461
2462Sighandler_t
864dbfa3 2463Perl_rsignal_state(pTHX_ int signo)
ff68c719 2464{
2465 Sighandler_t oldsig;
2466
39f1703b 2467#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2468 /* only "parent" interpreter can diddle signals */
2469 if (PL_curinterp != aTHX)
2470 return SIG_ERR;
2471#endif
2472
ff68c719 2473 sig_trapped = 0;
6ad3d225
GS		 2474 oldsig = PerlProc_signal(signo, sig_trap);
2475 PerlProc_signal(signo, oldsig);
ff68c719 2476 if (sig_trapped)
3aed30dc 2477 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2478 return oldsig;
2479}
2480
2481int
864dbfa3 2482Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2483{
39f1703b 2484#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2485 /* only "parent" interpreter can diddle signals */
2486 if (PL_curinterp != aTHX)
2487 return -1;
2488#endif
6ad3d225 2489 *save = PerlProc_signal(signo, handler);
ff68c719 2490 return (*save == SIG_ERR) ? -1 : 0;
2491}
2492
2493int
864dbfa3 2494Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2495{
39f1703b 2496#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2497 /* only "parent" interpreter can diddle signals */
2498 if (PL_curinterp != aTHX)
2499 return -1;
2500#endif
6ad3d225 2501 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2502}
2503
2504#endif /* !HAS_SIGACTION */
64ca3a65 2505#endif /* !PERL_MICRO */
ff68c719 2506
5f05dabc 2507 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2508#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2509I32
864dbfa3 2510Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2511{
ff68c719 2512 Sigsave_t hstat, istat, qstat;
a687059c 2513 int status;
a0d0e21e 2514 SV **svp;
d8a83dd3
JH		 2515 Pid_t pid;
2516 Pid_t pid2;
03136e13 2517 bool close_failed;
b7953727 2518 int saved_errno = 0;
03136e13
CS		 2519#ifdef VMS
2520 int saved_vaxc_errno;
2521#endif
22fae026
TM		 2522#ifdef WIN32
2523 int saved_win32_errno;
2524#endif
a687059c 2525
4755096e 2526 LOCK_FDPID_MUTEX;
3280af22 2527 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2528 UNLOCK_FDPID_MUTEX;
25d92023 2529 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2530 SvREFCNT_dec(*svp);
3280af22 2531 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2532#ifdef OS2
2533 if (pid == -1) { /* Opened by popen. */
2534 return my_syspclose(ptr);
2535 }
a1d180c4 2536#endif
03136e13
CS		 2537 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2538 saved_errno = errno;
2539#ifdef VMS
2540 saved_vaxc_errno = vaxc$errno;
2541#endif
22fae026
TM		 2542#ifdef WIN32
2543 saved_win32_errno = GetLastError();
2544#endif
03136e13 2545 }
7c0587c8 2546#ifdef UTS
6ad3d225 2547 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2548#endif
64ca3a65 2549#ifndef PERL_MICRO
ff68c719 2550 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2551 rsignal_save(SIGINT, SIG_IGN, &istat);
2552 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2553#endif
748a9306 2554 do {
1d3434b8
GS		 2555 pid2 = wait4pid(pid, &status, 0);
2556 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2557#ifndef PERL_MICRO
ff68c719 2558 rsignal_restore(SIGHUP, &hstat);
2559 rsignal_restore(SIGINT, &istat);
2560 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2561#endif
03136e13
CS		 2562 if (close_failed) {
2563 SETERRNO(saved_errno, saved_vaxc_errno);
2564 return -1;
2565 }
1d3434b8 2566 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2567}
4633a7c4
LW		 2568#endif /* !DOSISH */
2569
2986a63f 2570#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2571I32
d8a83dd3 2572Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2573{
cddd4526 2574 I32 result;
b7953727
JH		 2575 if (!pid)
2576 return -1;
2577#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2578 {
3aed30dc
HS		 2579 SV *sv;
2580 SV** svp;
2581 char spid[TYPE_CHARS(int)];
20188a90 2582
3aed30dc 2583 if (pid > 0) {
7b0972df 2584 sprintf(spid, "%"IVdf, (IV)pid);
3aed30dc
HS		 2585 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2586 if (svp && *svp != &PL_sv_undef) {
2587 *statusp = SvIVX(*svp);
2588 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2589 return pid;
2590 }
2591 }
2592 else {
2593 HE *entry;
2594
2595 hv_iterinit(PL_pidstatus);
2596 if ((entry = hv_iternext(PL_pidstatus))) {
2597 SV *sv;
2598 char spid[TYPE_CHARS(int)];
2599
2600 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2601 sv = hv_iterval(PL_pidstatus,entry);
2602 *statusp = SvIVX(sv);
2603 sprintf(spid, "%"IVdf, (IV)pid);
2604 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2605 return pid;
2606 }
20188a90
LW		 2607 }
2608 }
68a29c53 2609#endif
79072805 2610#ifdef HAS_WAITPID
367f3c24
IZ		 2611# ifdef HAS_WAITPID_RUNTIME
2612 if (!HAS_WAITPID_RUNTIME)
2613 goto hard_way;
2614# endif
cddd4526 2615 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2616 goto finish;
367f3c24
IZ		 2617#endif
2618#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
cddd4526 2619 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
dfcfdb64 2620 goto finish;
367f3c24
IZ		 2621#endif
2622#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2623 hard_way:
a0d0e21e 2624 {
a0d0e21e 2625 if (flags)
cea2e8a9 2626 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2627 else {
76e3520e 2628 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2629 pidgone(result,*statusp);
2630 if (result < 0)
2631 *statusp = -1;
2632 }
a687059c
LW		 2633 }
2634#endif
dfcfdb64 2635 finish:
cddd4526
NIS		 2636 if (result < 0 && errno == EINTR) {
2637 PERL_ASYNC_CHECK();
2638 }
2639 return result;
a687059c 2640}
2986a63f 2641#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2642
7c0587c8 2643void
de3bb511 2644/*SUPPRESS 590*/
d8a83dd3 2645Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2646{
79072805 2647 register SV *sv;
fc36a67e 2648 char spid[TYPE_CHARS(int)];
a687059c 2649
7b0972df 2650 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2651 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2652 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2653 SvIVX(sv) = status;
20188a90 2654 return;
a687059c
LW		 2655}
2656
85ca448a 2657#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2658int pclose();
ddcf38b7
IZ		 2659#ifdef HAS_FORK
2660int /* Cannot prototype with I32
2661 in os2ish.h. */
ba106d47 2662my_syspclose(PerlIO *ptr)
ddcf38b7 2663#else
79072805 2664I32
864dbfa3 2665Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2666#endif
a687059c 2667{
760ac839
LW		 2668 /* Needs work for PerlIO ! */
2669 FILE *f = PerlIO_findFILE(ptr);
2670 I32 result = pclose(f);
2b96b0a5
JH		 2671 PerlIO_releaseFILE(ptr,f);
2672 return result;
2673}
2674#endif
2675
933fea7f 2676#if defined(DJGPP)
2b96b0a5
JH		 2677int djgpp_pclose();
2678I32
2679Perl_my_pclose(pTHX_ PerlIO *ptr)
2680{
2681 /* Needs work for PerlIO ! */
2682 FILE *f = PerlIO_findFILE(ptr);
2683 I32 result = djgpp_pclose(f);
933fea7f 2684 result = (result << 8) & 0xff00;
760ac839
LW		 2685 PerlIO_releaseFILE(ptr,f);
2686 return result;
a687059c 2687}
7c0587c8 2688#endif
9f68db38
LW		 2689
2690void
864dbfa3 2691Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2692{
79072805 2693 register I32 todo;
08105a92 2694 register const char *frombase = from;
9f68db38
LW		 2695
2696 if (len == 1) {
08105a92 2697 register const char c = *from;
9f68db38 2698 while (count-- > 0)
5926133d 2699 *to++ = c;
9f68db38
LW		 2700 return;
2701 }
2702 while (count-- > 0) {
2703 for (todo = len; todo > 0; todo--) {
2704 *to++ = *from++;
2705 }
2706 from = frombase;
2707 }
2708}
0f85fab0 2709
fe14fcc3 2710#ifndef HAS_RENAME
79072805 2711I32
864dbfa3 2712Perl_same_dirent(pTHX_ char *a, char *b)
62b28dd9 2713{
93a17b20
LW		 2714 char *fa = strrchr(a,'/');
2715 char *fb = strrchr(b,'/');
c623ac67
GS		 2716 Stat_t tmpstatbuf1;
2717 Stat_t tmpstatbuf2;
46fc3d4c 2718 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2719
2720 if (fa)
2721 fa++;
2722 else
2723 fa = a;
2724 if (fb)
2725 fb++;
2726 else
2727 fb = b;
2728 if (strNE(a,b))
2729 return FALSE;
2730 if (fa == a)
46fc3d4c 2731 sv_setpv(tmpsv, ".");
62b28dd9 2732 else
46fc3d4c 2733 sv_setpvn(tmpsv, a, fa - a);
c6ed36e1 2734 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2735 return FALSE;
2736 if (fb == b)
46fc3d4c 2737 sv_setpv(tmpsv, ".");
62b28dd9 2738 else
46fc3d4c 2739 sv_setpvn(tmpsv, b, fb - b);
c6ed36e1 2740 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2741 return FALSE;
2742 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2743 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2744}
fe14fcc3
LW		 2745#endif /* !HAS_RENAME */
2746
491527d0 2747char*
864dbfa3 2748Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
491527d0 2749{
491527d0
GS		 2750 char *xfound = Nullch;
2751 char *xfailed = Nullch;
0f31cffe 2752 char tmpbuf[MAXPATHLEN];
491527d0 2753 register char *s;
5f74f29c 2754 I32 len = 0;
491527d0
GS		 2755 int retval;
2756#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2757# define SEARCH_EXTS ".bat", ".cmd", NULL
2758# define MAX_EXT_LEN 4
2759#endif
2760#ifdef OS2
2761# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2762# define MAX_EXT_LEN 4
2763#endif
2764#ifdef VMS
2765# define SEARCH_EXTS ".pl", ".com", NULL
2766# define MAX_EXT_LEN 4
2767#endif
2768 /* additional extensions to try in each dir if scriptname not found */
2769#ifdef SEARCH_EXTS
2770 char *exts[] = { SEARCH_EXTS };
2771 char **ext = search_ext ? search_ext : exts;
2772 int extidx = 0, i = 0;
2773 char *curext = Nullch;
2774#else
2775# define MAX_EXT_LEN 0
2776#endif
2777
2778 /*
2779 * If dosearch is true and if scriptname does not contain path
2780 * delimiters, search the PATH for scriptname.
2781 *
2782 * If SEARCH_EXTS is also defined, will look for each
2783 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2784 * while searching the PATH.
2785 *
2786 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2787 * proceeds as follows:
2788 * If DOSISH or VMSISH:
2789 * + look for ./scriptname{,.foo,.bar}
2790 * + search the PATH for scriptname{,.foo,.bar}
2791 *
2792 * If !DOSISH:
2793 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2794 * this will not look in '.' if it's not in the PATH)
2795 */
84486fc6 2796 tmpbuf[0] = '\0';
491527d0
GS		 2797
2798#ifdef VMS
2799# ifdef ALWAYS_DEFTYPES
2800 len = strlen(scriptname);
2801 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2802 int hasdir, idx = 0, deftypes = 1;
2803 bool seen_dot = 1;
2804
2805 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2806# else
2807 if (dosearch) {
2808 int hasdir, idx = 0, deftypes = 1;
2809 bool seen_dot = 1;
2810
2811 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2812# endif
2813 /* The first time through, just add SEARCH_EXTS to whatever we
2814 * already have, so we can check for default file types. */
2815 while (deftypes ||
84486fc6 2816 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 2817 {
2818 if (deftypes) {
2819 deftypes = 0;
84486fc6 2820 *tmpbuf = '\0';
491527d0 2821 }
84486fc6
GS		 2822 if ((strlen(tmpbuf) + strlen(scriptname)
2823 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 2824 continue; /* don't search dir with too-long name */
84486fc6 2825 strcat(tmpbuf, scriptname);
491527d0
GS		 2826#else /* !VMS */
2827
2828#ifdef DOSISH
2829 if (strEQ(scriptname, "-"))
2830 dosearch = 0;
2831 if (dosearch) { /* Look in '.' first. */
2832 char *cur = scriptname;
2833#ifdef SEARCH_EXTS
2834 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2835 while (ext[i])
2836 if (strEQ(ext[i++],curext)) {
2837 extidx = -1; /* already has an ext */
2838 break;
2839 }
2840 do {
2841#endif
2842 DEBUG_p(PerlIO_printf(Perl_debug_log,
2843 "Looking for %s\n",cur));
017f25f1
IZ		 2844 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2845 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 2846 dosearch = 0;
2847 scriptname = cur;
2848#ifdef SEARCH_EXTS
2849 break;
2850#endif
2851 }
2852#ifdef SEARCH_EXTS
2853 if (cur == scriptname) {
2854 len = strlen(scriptname);
84486fc6 2855 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 2856 break;
84486fc6 2857 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 2858 }
2859 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 2860 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 2861#endif
2862 }
2863#endif
2864
cd39f2b6
JH		 2865#ifdef MACOS_TRADITIONAL
2866 if (dosearch && !strchr(scriptname, ':') &&
2867 (s = PerlEnv_getenv("Commands")))
2868#else
491527d0
GS		 2869 if (dosearch && !strchr(scriptname, '/')
2870#ifdef DOSISH
2871 && !strchr(scriptname, '\\')
2872#endif
cd39f2b6
JH		 2873 && (s = PerlEnv_getenv("PATH")))
2874#endif
2875 {
491527d0 2876 bool seen_dot = 0;
92f0c265 2877
3280af22
NIS		 2878 PL_bufend = s + strlen(s);
2879 while (s < PL_bufend) {
cd39f2b6
JH		 2880#ifdef MACOS_TRADITIONAL
2881 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2882 ',',
2883 &len);
2884#else
491527d0
GS		 2885#if defined(atarist) || defined(DOSISH)
2886 for (len = 0; *s
2887# ifdef atarist
2888 && *s != ','
2889# endif
2890 && *s != ';'; len++, s++) {
84486fc6
GS		 2891 if (len < sizeof tmpbuf)
2892 tmpbuf[len] = *s;
491527d0 2893 }
84486fc6
GS		 2894 if (len < sizeof tmpbuf)
2895 tmpbuf[len] = '\0';
491527d0 2896#else /* ! (atarist || DOSISH) */
3280af22 2897 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 2898 ':',
2899 &len);
2900#endif /* ! (atarist || DOSISH) */
cd39f2b6 2901#endif /* MACOS_TRADITIONAL */
3280af22 2902 if (s < PL_bufend)
491527d0 2903 s++;
84486fc6 2904 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 2905 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 2906#ifdef MACOS_TRADITIONAL
2907 if (len && tmpbuf[len - 1] != ':')
2908 tmpbuf[len++] = ':';
2909#else
491527d0 2910 if (len
61ae2fbf 2911#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 2912 && tmpbuf[len - 1] != '/'
2913 && tmpbuf[len - 1] != '\\'
491527d0
GS		 2914#endif
2915 )
84486fc6
GS		 2916 tmpbuf[len++] = '/';
2917 if (len == 2 && tmpbuf[0] == '.')
491527d0 2918 seen_dot = 1;
cd39f2b6 2919#endif
84486fc6 2920 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 2921#endif /* !VMS */
2922
2923#ifdef SEARCH_EXTS
84486fc6 2924 len = strlen(tmpbuf);
491527d0
GS		 2925 if (extidx > 0) /* reset after previous loop */
2926 extidx = 0;
2927 do {
2928#endif
84486fc6 2929 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 2930 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 2931 if (S_ISDIR(PL_statbuf.st_mode)) {
2932 retval = -1;
2933 }
491527d0
GS		 2934#ifdef SEARCH_EXTS
2935 } while ( retval < 0 /* not there */
2936 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 2937 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 2938 );
2939#endif
2940 if (retval < 0)
2941 continue;
3280af22
NIS		 2942 if (S_ISREG(PL_statbuf.st_mode)
2943 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 2944#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 2945 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 2946#endif
2947 )
2948 {
3aed30dc 2949 xfound = tmpbuf; /* bingo! */
491527d0
GS		 2950 break;
2951 }
2952 if (!xfailed)
84486fc6 2953 xfailed = savepv(tmpbuf);
491527d0
GS		 2954 }
2955#ifndef DOSISH
017f25f1 2956 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 2957 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 2958 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 2959#endif
2960 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 2961 if (!xfound) {
2962 if (flags & 1) { /* do or die? */
3aed30dc 2963 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 2964 (xfailed ? "execute" : "find"),
2965 (xfailed ? xfailed : scriptname),
2966 (xfailed ? "" : " on PATH"),
2967 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2968 }
2969 scriptname = Nullch;
2970 }
491527d0
GS		 2971 if (xfailed)
2972 Safefree(xfailed);
2973 scriptname = xfound;
2974 }
9ccb31f9 2975 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 2976}
2977
ba869deb
GS		 2978#ifndef PERL_GET_CONTEXT_DEFINED
2979
2980void *
2981Perl_get_context(void)
2982{
3db8f154 2983#if defined(USE_ITHREADS)
ba869deb
GS		 2984# ifdef OLD_PTHREADS_API
2985 pthread_addr_t t;
2986 if (pthread_getspecific(PL_thr_key, &t))
2987 Perl_croak_nocontext("panic: pthread_getspecific");
2988 return (void*)t;
2989# else
bce813aa 2990# ifdef I_MACH_CTHREADS
8b8b35ab 2991 return (void*)cthread_data(cthread_self());
bce813aa 2992# else
8b8b35ab
JH		 2993 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2994# endif
c44d3fdb 2995# endif
ba869deb
GS		 2996#else
2997 return (void*)NULL;
2998#endif
2999}
3000
3001void
3002Perl_set_context(void *t)
3003{
3db8f154 3004#if defined(USE_ITHREADS)
c44d3fdb
GS		 3005# ifdef I_MACH_CTHREADS
3006 cthread_set_data(cthread_self(), t);
3007# else
ba869deb
GS		 3008 if (pthread_setspecific(PL_thr_key, t))
3009 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3010# endif
ba869deb
GS		 3011#endif
3012}
3013
3014#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3015
22239a37
NIS		 3016#ifdef PERL_GLOBAL_STRUCT
3017struct perl_vars *
864dbfa3 3018Perl_GetVars(pTHX)
22239a37 3019{
533c011a 3020 return &PL_Vars;
22239a37 3021}
31fb1209
NIS		 3022#endif
3023
3024char **
864dbfa3 3025Perl_get_op_names(pTHX)
31fb1209 3026{
22c35a8c 3027 return PL_op_name;
31fb1209
NIS		 3028}
3029
3030char **
864dbfa3 3031Perl_get_op_descs(pTHX)
31fb1209 3032{
22c35a8c 3033 return PL_op_desc;
31fb1209 3034}
9e6b2b00
GS		 3035
3036char *
864dbfa3 3037Perl_get_no_modify(pTHX)
9e6b2b00 3038{
22c35a8c 3039 return (char*)PL_no_modify;
9e6b2b00
GS		 3040}
3041
3042U32 *
864dbfa3 3043Perl_get_opargs(pTHX)
9e6b2b00 3044{
22c35a8c 3045 return PL_opargs;
9e6b2b00 3046}
51aa15f3 3047
0cb96387
GS		 3048PPADDR_t*
3049Perl_get_ppaddr(pTHX)
3050{
12ae5dfc 3051 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3052}
3053
a6c40364
GS		 3054#ifndef HAS_GETENV_LEN
3055char *
bf4acbe4 3056Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364
GS		 3057{
3058 char *env_trans = PerlEnv_getenv(env_elem);
3059 if (env_trans)
3060 *len = strlen(env_trans);
3061 return env_trans;
f675dbe5
CB		 3062}
3063#endif
3064
dc9e4912
GS		 3065
3066MGVTBL*
864dbfa3 3067Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912
GS		 3068{
3069 MGVTBL* result = Null(MGVTBL*);
3070
3071 switch(vtbl_id) {
3072 case want_vtbl_sv:
3073 result = &PL_vtbl_sv;
3074 break;
3075 case want_vtbl_env:
3076 result = &PL_vtbl_env;
3077 break;
3078 case want_vtbl_envelem:
3079 result = &PL_vtbl_envelem;
3080 break;
3081 case want_vtbl_sig:
3082 result = &PL_vtbl_sig;
3083 break;
3084 case want_vtbl_sigelem:
3085 result = &PL_vtbl_sigelem;
3086 break;
3087 case want_vtbl_pack:
3088 result = &PL_vtbl_pack;
3089 break;
3090 case want_vtbl_packelem:
3091 result = &PL_vtbl_packelem;
3092 break;
3093 case want_vtbl_dbline:
3094 result = &PL_vtbl_dbline;
3095 break;
3096 case want_vtbl_isa:
3097 result = &PL_vtbl_isa;
3098 break;
3099 case want_vtbl_isaelem:
3100 result = &PL_vtbl_isaelem;
3101 break;
3102 case want_vtbl_arylen:
3103 result = &PL_vtbl_arylen;
3104 break;
3105 case want_vtbl_glob:
3106 result = &PL_vtbl_glob;
3107 break;
3108 case want_vtbl_mglob:
3109 result = &PL_vtbl_mglob;
3110 break;
3111 case want_vtbl_nkeys:
3112 result = &PL_vtbl_nkeys;
3113 break;
3114 case want_vtbl_taint:
3115 result = &PL_vtbl_taint;
3116 break;
3117 case want_vtbl_substr:
3118 result = &PL_vtbl_substr;
3119 break;
3120 case want_vtbl_vec:
3121 result = &PL_vtbl_vec;
3122 break;
3123 case want_vtbl_pos:
3124 result = &PL_vtbl_pos;
3125 break;
3126 case want_vtbl_bm:
3127 result = &PL_vtbl_bm;
3128 break;
3129 case want_vtbl_fm:
3130 result = &PL_vtbl_fm;
3131 break;
3132 case want_vtbl_uvar:
3133 result = &PL_vtbl_uvar;
3134 break;
dc9e4912
GS		 3135 case want_vtbl_defelem:
3136 result = &PL_vtbl_defelem;
3137 break;
3138 case want_vtbl_regexp:
3139 result = &PL_vtbl_regexp;
3140 break;
3141 case want_vtbl_regdata:
3142 result = &PL_vtbl_regdata;
3143 break;
3144 case want_vtbl_regdatum:
3145 result = &PL_vtbl_regdatum;
3146 break;
3c90161d 3147#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3148 case want_vtbl_collxfrm:
3149 result = &PL_vtbl_collxfrm;
3150 break;
3c90161d 3151#endif
dc9e4912
GS		 3152 case want_vtbl_amagic:
3153 result = &PL_vtbl_amagic;
3154 break;
3155 case want_vtbl_amagicelem:
3156 result = &PL_vtbl_amagicelem;
3157 break;
810b8aa5
GS		 3158 case want_vtbl_backref:
3159 result = &PL_vtbl_backref;
3160 break;
7e8c5dac
HS		 3161 case want_vtbl_utf8:
3162 result = &PL_vtbl_utf8;
3163 break;
dc9e4912
GS		 3164 }
3165 return result;
3166}
3167
767df6a1 3168I32
864dbfa3 3169Perl_my_fflush_all(pTHX)
767df6a1 3170{
f800e14d 3171#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3172 return PerlIO_flush(NULL);
767df6a1 3173#else
8fbdfb7c 3174# if defined(HAS__FWALK)
f13a2bc0 3175 extern int fflush(FILE *);
74cac757
JH		 3176 /* undocumented, unprototyped, but very useful BSDism */
3177 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3178 _fwalk(&fflush);
74cac757 3179 return 0;
8fa7f367 3180# else
8fbdfb7c 3181# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3182 long open_max = -1;
8fbdfb7c 3183# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3184 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3185# else
8fa7f367 3186# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3187 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3188# else
3189# ifdef FOPEN_MAX
74cac757 3190 open_max = FOPEN_MAX;
8fa7f367
JH		 3191# else
3192# ifdef OPEN_MAX
74cac757 3193 open_max = OPEN_MAX;
8fa7f367
JH		 3194# else
3195# ifdef _NFILE
d2201af2 3196 open_max = _NFILE;
8fa7f367
JH		 3197# endif
3198# endif
74cac757 3199# endif
767df6a1
JH		 3200# endif
3201# endif
767df6a1
JH		 3202 if (open_max > 0) {
3203 long i;
3204 for (i = 0; i < open_max; i++)
d2201af2
AD		 3205 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3206 STDIO_STREAM_ARRAY[i]._file < open_max &&
3207 STDIO_STREAM_ARRAY[i]._flag)
3208 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3209 return 0;
3210 }
8fbdfb7c 3211# endif
93189314 3212 SETERRNO(EBADF,RMS_IFI);
767df6a1 3213 return EOF;
74cac757 3214# endif
767df6a1
JH		 3215#endif
3216}
097ee67d 3217
69282e91 3218void
bc37a18f
RG		 3219Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3220{
bc37a18f 3221 char *func =
66fc2fa5
JH		 3222 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3223 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
bc37a18f
RG		 3224 PL_op_desc[op];
3225 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3aed30dc
HS		 3226 char *type = OP_IS_SOCKET(op)
3227 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3228 ? "socket" : "filehandle";
9c0fcd4f 3229 char *name = NULL;
bc37a18f 3230
66fc2fa5 3231 if (gv && isGV(gv)) {
f62cb720 3232 name = GvENAME(gv);
66fc2fa5
JH		 3233 }
3234
4c80c0b2 3235 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3236 if (ckWARN(WARN_IO)) {
fd322ea4 3237 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
3aed30dc
HS		 3238 if (name && *name)
3239 Perl_warner(aTHX_ packWARN(WARN_IO),
3240 "Filehandle %s opened only for %sput",
fd322ea4 3241 name, direction);
3aed30dc
HS		 3242 else
3243 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3244 "Filehandle opened only for %sput", direction);
3aed30dc 3245 }
2dd78f96
JH		 3246 }
3247 else {
3aed30dc
HS		 3248 char *vile;
3249 I32 warn_type;
3250
3251 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3252 vile = "closed";
3253 warn_type = WARN_CLOSED;
3254 }
3255 else {
3256 vile = "unopened";
3257 warn_type = WARN_UNOPENED;
3258 }
3259
3260 if (ckWARN(warn_type)) {
3261 if (name && *name) {
3262 Perl_warner(aTHX_ packWARN(warn_type),
3263 "%s%s on %s %s %s", func, pars, vile, type, name);
3264 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3265 Perl_warner(
3266 aTHX_ packWARN(warn_type),
3267 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3268 func, pars, name
3269 );
3270 }
3271 else {
3272 Perl_warner(aTHX_ packWARN(warn_type),
3273 "%s%s on %s %s", func, pars, vile, type);
3274 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3275 Perl_warner(
3276 aTHX_ packWARN(warn_type),
3277 "\t(Are you trying to call %s%s on dirhandle?)\n",
3278 func, pars
3279 );
3280 }
3281 }
bc37a18f 3282 }
69282e91 3283}
a926ef6b
JH		 3284
3285#ifdef EBCDIC
cbebf344
JH		 3286/* in ASCII order, not that it matters */
3287static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3288
a926ef6b
JH		 3289int
3290Perl_ebcdic_control(pTHX_ int ch)
3291{
3aed30dc
HS		 3292 if (ch > 'a') {
3293 char *ctlp;
3294
3295 if (islower(ch))
3296 ch = toupper(ch);
3297
3298 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3299 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3300 }
3aed30dc
HS		 3301
3302 if (ctlp == controllablechars)
3303 return('\177'); /* DEL */
3304 else
3305 return((unsigned char)(ctlp - controllablechars - 1));
3306 } else { /* Want uncontrol */
3307 if (ch == '\177' || ch == -1)
3308 return('?');
3309 else if (ch == '\157')
3310 return('\177');
3311 else if (ch == '\174')
3312 return('\000');
3313 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3314 return('\036');
3315 else if (ch == '\155')
3316 return('\037');
3317 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3318 return(controllablechars[ch+1]);
3319 else
3320 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3321 }
a926ef6b
JH		 3322}
3323#endif
e72cf795 3324
f6adc668 3325/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3326 * system to give us a reasonable struct to copy. This fix means that
3327 * strftime uses the tm_zone and tm_gmtoff values returned by
3328 * localtime(time()). That should give the desired result most of the
3329 * time. But probably not always!
3330 *
f6adc668
JH		 3331 * This does not address tzname aspects of NETaa14816.
3332 *
e72cf795 3333 */
f6adc668 3334
e72cf795
JH		 3335#ifdef HAS_GNULIBC
3336# ifndef STRUCT_TM_HASZONE
3337# define STRUCT_TM_HASZONE
3338# endif
3339#endif
3340
f6adc668
JH		 3341#ifdef STRUCT_TM_HASZONE /* Backward compat */
3342# ifndef HAS_TM_TM_ZONE
3343# define HAS_TM_TM_ZONE
3344# endif
3345#endif
3346
e72cf795 3347void
f1208910 3348Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3349{
f6adc668 3350#ifdef HAS_TM_TM_ZONE
e72cf795
JH		 3351 Time_t now;
3352 (void)time(&now);
3353 Copy(localtime(&now), ptm, 1, struct tm);
3354#endif
3355}
3356
3357/*
3358 * mini_mktime - normalise struct tm values without the localtime()
3359 * semantics (and overhead) of mktime().
3360 */
3361void
f1208910 3362Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3363{
3364 int yearday;
3365 int secs;
3366 int month, mday, year, jday;
3367 int odd_cent, odd_year;
3368
3369#define DAYS_PER_YEAR 365
3370#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3371#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3372#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3373#define SECS_PER_HOUR (60*60)
3374#define SECS_PER_DAY (24*SECS_PER_HOUR)
3375/* parentheses deliberately absent on these two, otherwise they don't work */
3376#define MONTH_TO_DAYS 153/5
3377#define DAYS_TO_MONTH 5/153
3378/* offset to bias by March (month 4) 1st between month/mday & year finding */
3379#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3380/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3381#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3382
3383/*
3384 * Year/day algorithm notes:
3385 *
3386 * With a suitable offset for numeric value of the month, one can find
3387 * an offset into the year by considering months to have 30.6 (153/5) days,
3388 * using integer arithmetic (i.e., with truncation). To avoid too much
3389 * messing about with leap days, we consider January and February to be
3390 * the 13th and 14th month of the previous year. After that transformation,
3391 * we need the month index we use to be high by 1 from 'normal human' usage,
3392 * so the month index values we use run from 4 through 15.
3393 *
3394 * Given that, and the rules for the Gregorian calendar (leap years are those
3395 * divisible by 4 unless also divisible by 100, when they must be divisible
3396 * by 400 instead), we can simply calculate the number of days since some
3397 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3398 * the days we derive from our month index, and adding in the day of the
3399 * month. The value used here is not adjusted for the actual origin which
3400 * it normally would use (1 January A.D. 1), since we're not exposing it.
3401 * We're only building the value so we can turn around and get the
3402 * normalised values for the year, month, day-of-month, and day-of-year.
3403 *
3404 * For going backward, we need to bias the value we're using so that we find
3405 * the right year value. (Basically, we don't want the contribution of
3406 * March 1st to the number to apply while deriving the year). Having done
3407 * that, we 'count up' the contribution to the year number by accounting for
3408 * full quadracenturies (400-year periods) with their extra leap days, plus
3409 * the contribution from full centuries (to avoid counting in the lost leap
3410 * days), plus the contribution from full quad-years (to count in the normal
3411 * leap days), plus the leftover contribution from any non-leap years.
3412 * At this point, if we were working with an actual leap day, we'll have 0
3413 * days left over. This is also true for March 1st, however. So, we have
3414 * to special-case that result, and (earlier) keep track of the 'odd'
3415 * century and year contributions. If we got 4 extra centuries in a qcent,
3416 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3417 * Otherwise, we add back in the earlier bias we removed (the 123 from
3418 * figuring in March 1st), find the month index (integer division by 30.6),
3419 * and the remainder is the day-of-month. We then have to convert back to
3420 * 'real' months (including fixing January and February from being 14/15 in
3421 * the previous year to being in the proper year). After that, to get
3422 * tm_yday, we work with the normalised year and get a new yearday value for
3423 * January 1st, which we subtract from the yearday value we had earlier,
3424 * representing the date we've re-built. This is done from January 1
3425 * because tm_yday is 0-origin.
3426 *
3427 * Since POSIX time routines are only guaranteed to work for times since the
3428 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3429 * applies Gregorian calendar rules even to dates before the 16th century
3430 * doesn't bother me. Besides, you'd need cultural context for a given
3431 * date to know whether it was Julian or Gregorian calendar, and that's
3432 * outside the scope for this routine. Since we convert back based on the
3433 * same rules we used to build the yearday, you'll only get strange results
3434 * for input which needed normalising, or for the 'odd' century years which
3435 * were leap years in the Julian calander but not in the Gregorian one.
3436 * I can live with that.
3437 *
3438 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3439 * that's still outside the scope for POSIX time manipulation, so I don't
3440 * care.
3441 */
3442
3443 year = 1900 + ptm->tm_year;
3444 month = ptm->tm_mon;
3445 mday = ptm->tm_mday;
3446 /* allow given yday with no month & mday to dominate the result */
3447 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3448 month = 0;
3449 mday = 0;
3450 jday = 1 + ptm->tm_yday;
3451 }
3452 else {
3453 jday = 0;
3454 }
3455 if (month >= 2)
3456 month+=2;
3457 else
3458 month+=14, year--;
3459 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3460 yearday += month*MONTH_TO_DAYS + mday + jday;
3461 /*
3462 * Note that we don't know when leap-seconds were or will be,
3463 * so we have to trust the user if we get something which looks
3464 * like a sensible leap-second. Wild values for seconds will
3465 * be rationalised, however.
3466 */
3467 if ((unsigned) ptm->tm_sec <= 60) {
3468 secs = 0;
3469 }
3470 else {
3471 secs = ptm->tm_sec;
3472 ptm->tm_sec = 0;
3473 }
3474 secs += 60 * ptm->tm_min;
3475 secs += SECS_PER_HOUR * ptm->tm_hour;
3476 if (secs < 0) {
3477 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3478 /* got negative remainder, but need positive time */
3479 /* back off an extra day to compensate */
3480 yearday += (secs/SECS_PER_DAY)-1;
3481 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3482 }
3483 else {
3484 yearday += (secs/SECS_PER_DAY);
3485 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3486 }
3487 }
3488 else if (secs >= SECS_PER_DAY) {
3489 yearday += (secs/SECS_PER_DAY);
3490 secs %= SECS_PER_DAY;
3491 }
3492 ptm->tm_hour = secs/SECS_PER_HOUR;
3493 secs %= SECS_PER_HOUR;
3494 ptm->tm_min = secs/60;
3495 secs %= 60;
3496 ptm->tm_sec += secs;
3497 /* done with time of day effects */
3498 /*
3499 * The algorithm for yearday has (so far) left it high by 428.
3500 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3501 * bias it by 123 while trying to figure out what year it
3502 * really represents. Even with this tweak, the reverse
3503 * translation fails for years before A.D. 0001.
3504 * It would still fail for Feb 29, but we catch that one below.
3505 */
3506 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3507 yearday -= YEAR_ADJUST;
3508 year = (yearday / DAYS_PER_QCENT) * 400;
3509 yearday %= DAYS_PER_QCENT;
3510 odd_cent = yearday / DAYS_PER_CENT;
3511 year += odd_cent * 100;
3512 yearday %= DAYS_PER_CENT;
3513 year += (yearday / DAYS_PER_QYEAR) * 4;
3514 yearday %= DAYS_PER_QYEAR;
3515 odd_year = yearday / DAYS_PER_YEAR;
3516 year += odd_year;
3517 yearday %= DAYS_PER_YEAR;
3518 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3519 month = 1;
3520 yearday = 29;
3521 }
3522 else {
3523 yearday += YEAR_ADJUST; /* recover March 1st crock */
3524 month = yearday*DAYS_TO_MONTH;
3525 yearday -= month*MONTH_TO_DAYS;
3526 /* recover other leap-year adjustment */
3527 if (month > 13) {
3528 month-=14;
3529 year++;
3530 }
3531 else {
3532 month-=2;
3533 }
3534 }
3535 ptm->tm_year = year - 1900;
3536 if (yearday) {
3537 ptm->tm_mday = yearday;
3538 ptm->tm_mon = month;
3539 }
3540 else {
3541 ptm->tm_mday = 31;
3542 ptm->tm_mon = month - 1;
3543 }
3544 /* re-build yearday based on Jan 1 to get tm_yday */
3545 year--;
3546 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3547 yearday += 14*MONTH_TO_DAYS + 1;
3548 ptm->tm_yday = jday - yearday;
3549 /* fix tm_wday if not overridden by caller */
3550 if ((unsigned)ptm->tm_wday > 6)
3551 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3552}
b3c85772
JH		 3553
3554char *
f1208910 3555Perl_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		 3556{
3557#ifdef HAS_STRFTIME
3558 char *buf;
3559 int buflen;
3560 struct tm mytm;
3561 int len;
3562
3563 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3564 mytm.tm_sec = sec;
3565 mytm.tm_min = min;
3566 mytm.tm_hour = hour;
3567 mytm.tm_mday = mday;
3568 mytm.tm_mon = mon;
3569 mytm.tm_year = year;
3570 mytm.tm_wday = wday;
3571 mytm.tm_yday = yday;
3572 mytm.tm_isdst = isdst;
3573 mini_mktime(&mytm);
c473feec
SR		 3574 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3575#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3576 STMT_START {
3577 struct tm mytm2;
3578 mytm2 = mytm;
3579 mktime(&mytm2);
3580#ifdef HAS_TM_TM_GMTOFF
3581 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3582#endif
3583#ifdef HAS_TM_TM_ZONE
3584 mytm.tm_zone = mytm2.tm_zone;
3585#endif
3586 } STMT_END;
3587#endif
b3c85772
JH		 3588 buflen = 64;
3589 New(0, buf, buflen, char);
3590 len = strftime(buf, buflen, fmt, &mytm);
3591 /*
877f6a72 3592 ** The following is needed to handle to the situation where
b3c85772
JH		 3593 ** tmpbuf overflows. Basically we want to allocate a buffer
3594 ** and try repeatedly. The reason why it is so complicated
3595 ** is that getting a return value of 0 from strftime can indicate
3596 ** one of the following:
3597 ** 1. buffer overflowed,
3598 ** 2. illegal conversion specifier, or
3599 ** 3. the format string specifies nothing to be returned(not
3600 ** an error). This could be because format is an empty string
3601 ** or it specifies %p that yields an empty string in some locale.
3602 ** If there is a better way to make it portable, go ahead by
3603 ** all means.
3604 */
3605 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3606 return buf;
3607 else {
3608 /* Possibly buf overflowed - try again with a bigger buf */
3609 int fmtlen = strlen(fmt);
3610 int bufsize = fmtlen + buflen;
877f6a72 3611
b3c85772
JH		 3612 New(0, buf, bufsize, char);
3613 while (buf) {
3614 buflen = strftime(buf, bufsize, fmt, &mytm);
3615 if (buflen > 0 && buflen < bufsize)
3616 break;
3617 /* heuristic to prevent out-of-memory errors */
3618 if (bufsize > 100*fmtlen) {
3619 Safefree(buf);
3620 buf = NULL;
3621 break;
3622 }
3623 bufsize *= 2;
3624 Renew(buf, bufsize, char);
3625 }
3626 return buf;
3627 }
3628#else
3629 Perl_croak(aTHX_ "panic: no strftime");
3630#endif
3631}
3632
877f6a72
NIS		 3633
3634#define SV_CWD_RETURN_UNDEF \
3635sv_setsv(sv, &PL_sv_undef); \
3636return FALSE
3637
3638#define SV_CWD_ISDOT(dp) \
3639 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3640 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3641
3642/*
ccfc67b7
JH		 3643=head1 Miscellaneous Functions
3644
89423764 3645=for apidoc getcwd_sv
877f6a72
NIS		 3646
3647Fill the sv with current working directory
3648
3649=cut
3650*/
3651
3652/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3653 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3654 * getcwd(3) if available
3655 * Comments from the orignal:
3656 * This is a faster version of getcwd. It's also more dangerous
3657 * because you might chdir out of a directory that you can't chdir
3658 * back into. */
3659
877f6a72 3660int
89423764 3661Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3662{
3663#ifndef PERL_MICRO
3664
ea715489
JH		 3665#ifndef INCOMPLETE_TAINTS
3666 SvTAINTED_on(sv);
3667#endif
3668
8f95b30d
JH		 3669#ifdef HAS_GETCWD
3670 {
60e110a8
DM		 3671 char buf[MAXPATHLEN];
3672
3aed30dc 3673 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3674 * size from the heap if they are given a NULL buffer pointer.
3675 * The problem is that this behaviour is not portable. */
3aed30dc
HS		 3676 if (getcwd(buf, sizeof(buf) - 1)) {
3677 STRLEN len = strlen(buf);
3678 sv_setpvn(sv, buf, len);
3679 return TRUE;
3680 }
3681 else {
3682 sv_setsv(sv, &PL_sv_undef);
3683 return FALSE;
3684 }
8f95b30d
JH		 3685 }
3686
3687#else
3688
c623ac67 3689 Stat_t statbuf;
877f6a72
NIS		 3690 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3691 int namelen, pathlen=0;
3692 DIR *dir;
3693 Direntry_t *dp;
877f6a72
NIS		 3694
3695 (void)SvUPGRADE(sv, SVt_PV);
3696
877f6a72 3697 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3698 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3699 }
3700
3701 orig_cdev = statbuf.st_dev;
3702 orig_cino = statbuf.st_ino;
3703 cdev = orig_cdev;
3704 cino = orig_cino;
3705
3706 for (;;) {
3aed30dc
HS		 3707 odev = cdev;
3708 oino = cino;
3709
3710 if (PerlDir_chdir("..") < 0) {
3711 SV_CWD_RETURN_UNDEF;
3712 }
3713 if (PerlLIO_stat(".", &statbuf) < 0) {
3714 SV_CWD_RETURN_UNDEF;
3715 }
3716
3717 cdev = statbuf.st_dev;
3718 cino = statbuf.st_ino;
3719
3720 if (odev == cdev && oino == cino) {
3721 break;
3722 }
3723 if (!(dir = PerlDir_open("."))) {
3724 SV_CWD_RETURN_UNDEF;
3725 }
3726
3727 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3728#ifdef DIRNAMLEN
3aed30dc 3729 namelen = dp->d_namlen;
877f6a72 3730#else
3aed30dc 3731 namelen = strlen(dp->d_name);
877f6a72 3732#endif
3aed30dc
HS		 3733 /* skip . and .. */
3734 if (SV_CWD_ISDOT(dp)) {
3735 continue;
3736 }
3737
3738 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3739 SV_CWD_RETURN_UNDEF;
3740 }
3741
3742 tdev = statbuf.st_dev;
3743 tino = statbuf.st_ino;
3744 if (tino == oino && tdev == odev) {
3745 break;
3746 }
cb5953d6
JH		 3747 }
3748
3aed30dc
HS		 3749 if (!dp) {
3750 SV_CWD_RETURN_UNDEF;
3751 }
3752
3753 if (pathlen + namelen + 1 >= MAXPATHLEN) {
3754 SV_CWD_RETURN_UNDEF;
3755 }
877f6a72 3756
3aed30dc
HS		 3757 SvGROW(sv, pathlen + namelen + 1);
3758
3759 if (pathlen) {
3760 /* shift down */
3761 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3762 }
877f6a72 3763
3aed30dc
HS		 3764 /* prepend current directory to the front */
3765 *SvPVX(sv) = '/';
3766 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
3767 pathlen += (namelen + 1);
877f6a72
NIS		 3768
3769#ifdef VOID_CLOSEDIR
3aed30dc 3770 PerlDir_close(dir);
877f6a72 3771#else
3aed30dc
HS		 3772 if (PerlDir_close(dir) < 0) {
3773 SV_CWD_RETURN_UNDEF;
3774 }
877f6a72
NIS		 3775#endif
3776 }
3777
60e110a8 3778 if (pathlen) {
3aed30dc
HS		 3779 SvCUR_set(sv, pathlen);
3780 *SvEND(sv) = '\0';
3781 SvPOK_only(sv);
877f6a72 3782
2a45baea 3783 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3aed30dc
HS		 3784 SV_CWD_RETURN_UNDEF;
3785 }
877f6a72
NIS		 3786 }
3787 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 3788 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3789 }
3790
3791 cdev = statbuf.st_dev;
3792 cino = statbuf.st_ino;
3793
3794 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 3795 Perl_croak(aTHX_ "Unstable directory path, "
3796 "current directory changed unexpectedly");
877f6a72 3797 }
877f6a72
NIS		 3798
3799 return TRUE;
793b8d8e
JH		 3800#endif
3801
877f6a72
NIS		 3802#else
3803 return FALSE;
3804#endif
3805}
3806
f4758303 3807/*
b0f01acb
JP		 3808=for apidoc scan_version
3809
3810Returns a pointer to the next character after the parsed
3811version string, as well as upgrading the passed in SV to
3812an RV.
3813
3814Function must be called with an already existing SV like
3815
137d6fc0
JP		 3816 sv = newSV(0);
3817 s = scan_version(s,SV *sv, bool qv);
b0f01acb
JP		 3818
3819Performs some preprocessing to the string to ensure that
3820it has the correct characteristics of a version. Flags the
3821object if it contains an underscore (which denotes this
137d6fc0
JP		 3822is a alpha version). The boolean qv denotes that the version
3823should be interpreted as if it had multiple decimals, even if
3824it doesn't.
b0f01acb
JP		 3825
3826=cut
3827*/
3828
3829char *
137d6fc0 3830Perl_scan_version(pTHX_ char *s, SV *rv, bool qv)
b0f01acb 3831{
e568f1a0 3832 const char *start = s;
ad63d80f
JP		 3833 char *pos = s;
3834 I32 saw_period = 0;
3835 bool saw_under = 0;
be2ebcad 3836 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
ad63d80f 3837 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
f9be5ac8 3838 AvREAL_on((AV*)sv);
ad63d80f
JP		 3839
3840 /* pre-scan the imput string to check for decimals */
3841 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
3842 {
3843 if ( *pos == '.' )
3844 {
3845 if ( saw_under )
5f89c282 3846 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 3847 saw_period++ ;
46314c13 3848 }
ad63d80f
JP		 3849 else if ( *pos == '_' )
3850 {
3851 if ( saw_under )
5f89c282 3852 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
ad63d80f
JP		 3853 saw_under = 1;
3854 }
3855 pos++;
3856 }
3857 pos = s;
3858
137d6fc0
JP		 3859 if (*pos == 'v') {
3860 pos++; /* get past 'v' */
3861 qv = 1; /* force quoted version processing */
3862 }
ad63d80f 3863 while (isDIGIT(*pos))
46314c13 3864 pos++;
ad63d80f
JP		 3865 if (!isALPHA(*pos)) {
3866 I32 rev;
3867
3868 if (*s == 'v') s++; /* get past 'v' */
3869
3870 for (;;) {
3871 rev = 0;
3872 {
129318bd
JP		 3873 /* this is atoi() that delimits on underscores */
3874 char *end = pos;
3875 I32 mult = 1;
3876 I32 orev;
3877 if ( s < pos && s > start && *(s-1) == '_' ) {
137d6fc0 3878 mult *= -1; /* alpha version */
129318bd
JP		 3879 }
3880 /* the following if() will only be true after the decimal
3881 * point of a version originally created with a bare
3882 * floating point number, i.e. not quoted in any way
3883 */
13f8f398 3884 if ( !qv && s > start+1 && saw_period == 1 ) {
c76df65e 3885 mult *= 100;
129318bd
JP		 3886 while ( s < end ) {
3887 orev = rev;
3888 rev += (*s - '0') * mult;
3889 mult /= 10;
32fdb065 3890 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3891 Perl_croak(aTHX_ "Integer overflow in version");
3892 s++;
3893 }
3894 }
3895 else {
3896 while (--end >= s) {
3897 orev = rev;
3898 rev += (*end - '0') * mult;
3899 mult *= 10;
32fdb065 3900 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 3901 Perl_croak(aTHX_ "Integer overflow in version");
3902 }
3903 }
3904 }
3905
3906 /* Append revision */
ad63d80f
JP		 3907 av_push((AV *)sv, newSViv(rev));
3908 if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
3909 s = ++pos;
3910 else if ( isDIGIT(*pos) )
3911 s = pos;
b0f01acb 3912 else {
ad63d80f
JP		 3913 s = pos;
3914 break;
3915 }
3916 while ( isDIGIT(*pos) ) {
13f8f398 3917 if ( saw_period == 1 && pos-s == 3 )
ad63d80f
JP		 3918 break;
3919 pos++;
b0f01acb
JP		 3920 }
3921 }
3922 }
b9381830
JP		 3923 if ( qv ) { /* quoted versions always become full version objects */
3924 I32 len = av_len((AV *)sv);
4edfc503
NC		 3925 /* This for loop appears to trigger a compiler bug on OS X, as it
3926 loops infinitely. Yes, len is negative. No, it makes no sense.
3927 Compiler in question is:
3928 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
3929 for ( len = 2 - len; len > 0; len-- )
3930 av_push((AV *)sv, newSViv(0));
3931 */
3932 len = 2 - len;
3933 while (len-- > 0)
c76df65e 3934 av_push((AV *)sv, newSViv(0));
b9381830 3935 }
ad63d80f 3936 return s;
b0f01acb
JP		 3937}
3938
3939/*
3940=for apidoc new_version
3941
3942Returns a new version object based on the passed in SV:
3943
3944 SV *sv = new_version(SV *ver);
3945
3946Does not alter the passed in ver SV. See "upg_version" if you
3947want to upgrade the SV.
3948
3949=cut
3950*/
3951
3952SV *
3953Perl_new_version(pTHX_ SV *ver)
3954{
129318bd 3955 SV *rv = newSV(0);
d7aa5382
JP		 3956 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
3957 {
3958 I32 key;
3959 AV *av = (AV *)SvRV(ver);
3960 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
3961 (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */
f9be5ac8 3962 AvREAL_on((AV*)sv);
d7aa5382
JP		 3963 for ( key = 0; key <= av_len(av); key++ )
3964 {
3965 I32 rev = SvIV(*av_fetch(av, key, FALSE));
3966 av_push((AV *)sv, newSViv(rev));
3967 }
3968 return rv;
3969 }
ad63d80f 3970#ifdef SvVOK
137d6fc0
JP		 3971 if ( SvVOK(ver) ) { /* already a v-string */
3972 char *version;
b0f01acb
JP		 3973 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
3974 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0
JP		 3975 sv_setpv(rv,version);
3976 Safefree(version);
b0f01acb 3977 }
137d6fc0 3978 else {
ad63d80f 3979#endif
137d6fc0
JP		 3980 sv_setsv(rv,ver); /* make a duplicate */
3981#ifdef SvVOK
26ec6fc3 3982 }
137d6fc0
JP		 3983#endif
3984 upg_version(rv);
b0f01acb
JP		 3985 return rv;
3986}
3987
3988/*
3989=for apidoc upg_version
3990
3991In-place upgrade of the supplied SV to a version object.
3992
3993 SV *sv = upg_version(SV *sv);
3994
3995Returns a pointer to the upgraded SV.
3996
3997=cut
3998*/
3999
4000SV *
ad63d80f 4001Perl_upg_version(pTHX_ SV *ver)
b0f01acb 4002{
137d6fc0
JP		 4003 char *version;
4004 bool qv = 0;
4005
4006 if ( SvNOK(ver) ) /* may get too much accuracy */
4007 {
4008 char tbuf[64];
4009 sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
4010 version = savepv(tbuf);
4011 }
ad63d80f 4012#ifdef SvVOK
137d6fc0 4013 else if ( SvVOK(ver) ) { /* already a v-string */
ad63d80f
JP		 4014 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4015 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0 4016 qv = 1;
b0f01acb 4017 }
ad63d80f 4018#endif
137d6fc0
JP		 4019 else /* must be a string or something like a string */
4020 {
4021 STRLEN n_a;
4022 version = savepv(SvPV(ver,n_a));
4023 }
4024 (void)scan_version(version, ver, qv);
4025 Safefree(version);
ad63d80f 4026 return ver;
b0f01acb
JP		 4027}
4028
4029
4030/*
4031=for apidoc vnumify
4032
ad63d80f
JP		 4033Accepts a version object and returns the normalized floating
4034point representation. Call like:
b0f01acb 4035
ad63d80f 4036 sv = vnumify(rv);
b0f01acb 4037
ad63d80f
JP		 4038NOTE: you can pass either the object directly or the SV
4039contained within the RV.
b0f01acb
JP		 4040
4041=cut
4042*/
4043
4044SV *
ad63d80f 4045Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4046{
ad63d80f 4047 I32 i, len, digit;
137d6fc0 4048 SV *sv = newSV(0);
ad63d80f
JP		 4049 if ( SvROK(vs) )
4050 vs = SvRV(vs);
4051 len = av_len((AV *)vs);
46314c13
JP		 4052 if ( len == -1 )
4053 {
4054 Perl_sv_catpv(aTHX_ sv,"0");
4055 return sv;
4056 }
ad63d80f 4057 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
c0fd1b42 4058 Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit));
13f8f398 4059 for ( i = 1 ; i < len ; i++ )
b0f01acb 4060 {
ad63d80f 4061 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
c0fd1b42 4062 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
b0f01acb 4063 }
13f8f398
JP		 4064
4065 if ( len > 0 )
4066 {
4067 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
13f8f398
JP		 4068 if ( (int)PERL_ABS(digit) != 0 || len == 1 )
4069 {
c76df65e
RGS		 4070 if ( digit < 0 ) /* alpha version */
4071 Perl_sv_catpv(aTHX_ sv,"_");
4072 /* Don't display additional trailing zeros */
13f8f398
JP		 4073 Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
4074 }
4075 }
4076 else /* len == 0 */
4077 {
ad63d80f 4078 Perl_sv_catpv(aTHX_ sv,"000");
13f8f398 4079 }
b0f01acb
JP		 4080 return sv;
4081}
4082
4083/*
b9381830 4084=for apidoc vnormal
b0f01acb 4085
ad63d80f
JP		 4086Accepts a version object and returns the normalized string
4087representation. Call like:
b0f01acb 4088
b9381830 4089 sv = vnormal(rv);
b0f01acb 4090
ad63d80f
JP		 4091NOTE: you can pass either the object directly or the SV
4092contained within the RV.
b0f01acb
JP		 4093
4094=cut
4095*/
4096
4097SV *
b9381830 4098Perl_vnormal(pTHX_ SV *vs)
b0f01acb 4099{
ad63d80f 4100 I32 i, len, digit;
137d6fc0 4101 SV *sv = newSV(0);
ad63d80f
JP		 4102 if ( SvROK(vs) )
4103 vs = SvRV(vs);
4104 len = av_len((AV *)vs);
46314c13
JP		 4105 if ( len == -1 )
4106 {
4107 Perl_sv_catpv(aTHX_ sv,"");
4108 return sv;
4109 }
ad63d80f 4110 digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
e3feee4e 4111 Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
ad63d80f 4112 for ( i = 1 ; i <= len ; i++ )
46314c13 4113 {
ad63d80f
JP		 4114 digit = SvIVX(*av_fetch((AV *)vs, i, 0));
4115 if ( digit < 0 )
e3feee4e 4116 Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
ad63d80f 4117 else
e3feee4e 4118 Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
b0f01acb 4119 }
137d6fc0
JP		 4120
4121 if ( len <= 2 ) { /* short version, must be at least three */
4122 for ( len = 2 - len; len != 0; len-- )
4123 Perl_sv_catpv(aTHX_ sv,".0");
4124 }
4125
b0f01acb 4126 return sv;
129318bd 4127}
b0f01acb 4128
ad63d80f 4129/*
b9381830
JP		 4130=for apidoc vstringify
4131
4132In order to maintain maximum compatibility with earlier versions
4133of Perl, this function will return either the floating point
4134notation or the multiple dotted notation, depending on whether
4135the original version contained 1 or more dots, respectively
4136
4137=cut
4138*/
4139
4140SV *
4141Perl_vstringify(pTHX_ SV *vs)
4142{
c76df65e 4143 I32 len, digit;
b9381830
JP		 4144 if ( SvROK(vs) )
4145 vs = SvRV(vs);
4146 len = av_len((AV *)vs);
c76df65e 4147 digit = SvIVX(*av_fetch((AV *)vs, len, 0));
b9381830 4148
c76df65e 4149 if ( len < 2 || ( len == 2 && digit < 0 ) )
b9381830
JP		 4150 return vnumify(vs);
4151 else
4152 return vnormal(vs);
4153}
4154
4155/*
ad63d80f
JP		 4156=for apidoc vcmp
4157
4158Version object aware cmp. Both operands must already have been
4159converted into version objects.
4160
4161=cut
4162*/
4163
4164int
4165Perl_vcmp(pTHX_ SV *lsv, SV *rsv)
4166{
4167 I32 i,l,m,r,retval;
4168 if ( SvROK(lsv) )
4169 lsv = SvRV(lsv);
4170 if ( SvROK(rsv) )
4171 rsv = SvRV(rsv);
4172 l = av_len((AV *)lsv);
4173 r = av_len((AV *)rsv);
4174 m = l < r ? l : r;
4175 retval = 0;
4176 i = 0;
4177 while ( i <= m && retval == 0 )
4178 {
4179 I32 left = SvIV(*av_fetch((AV *)lsv,i,0));
4180 I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
137d6fc0
JP		 4181 bool lalpha = left < 0 ? 1 : 0;
4182 bool ralpha = right < 0 ? 1 : 0;
4183 left = abs(left);
4184 right = abs(right);
4185 if ( left < right || (left == right && lalpha && !ralpha) )
ad63d80f 4186 retval = -1;
137d6fc0 4187 if ( left > right || (left == right && ralpha && !lalpha) )
ad63d80f
JP		 4188 retval = +1;
4189 i++;
4190 }
4191
137d6fc0 4192 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
129318bd 4193 {
137d6fc0 4194 if ( l < r )
129318bd 4195 {
137d6fc0
JP		 4196 while ( i <= r && retval == 0 )
4197 {
4198 if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 )
4199 retval = -1; /* not a match after all */
4200 i++;
4201 }
4202 }
4203 else
4204 {
4205 while ( i <= l && retval == 0 )
4206 {
4207 if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 )
4208 retval = +1; /* not a match after all */
4209 i++;
4210 }
129318bd
JP		 4211 }
4212 }
ad63d80f
JP		 4213 return retval;
4214}
4215
c95c94b1 4216#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4217# define EMULATE_SOCKETPAIR_UDP
4218#endif
4219
4220#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4221static int
4222S_socketpair_udp (int fd[2]) {
e10bb1e9 4223 dTHX;
02fc2eee
NC		 4224 /* Fake a datagram socketpair using UDP to localhost. */
4225 int sockets[2] = {-1, -1};
4226 struct sockaddr_in addresses[2];
4227 int i;
3aed30dc 4228 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4229 unsigned short port;
02fc2eee
NC		 4230 int got;
4231
3aed30dc 4232 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4233 i = 1;
4234 do {
3aed30dc
HS		 4235 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4236 if (sockets[i] == -1)
4237 goto tidy_up_and_fail;
4238
4239 addresses[i].sin_family = AF_INET;
4240 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4241 addresses[i].sin_port = 0; /* kernel choses port. */
4242 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4243 sizeof(struct sockaddr_in)) == -1)
4244 goto tidy_up_and_fail;
02fc2eee
NC		 4245 } while (i--);
4246
4247 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4248 for each connect the other socket to it. */
4249 i = 1;
4250 do {
3aed30dc
HS		 4251 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4252 &size) == -1)
4253 goto tidy_up_and_fail;
4254 if (size != sizeof(struct sockaddr_in))
4255 goto abort_tidy_up_and_fail;
4256 /* !1 is 0, !0 is 1 */
4257 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4258 sizeof(struct sockaddr_in)) == -1)
4259 goto tidy_up_and_fail;
02fc2eee
NC		 4260 } while (i--);
4261
4262 /* Now we have 2 sockets connected to each other. I don't trust some other
4263 process not to have already sent a packet to us (by random) so send
4264 a packet from each to the other. */
4265 i = 1;
4266 do {
3aed30dc
HS		 4267 /* I'm going to send my own port number. As a short.
4268 (Who knows if someone somewhere has sin_port as a bitfield and needs
4269 this routine. (I'm assuming crays have socketpair)) */
4270 port = addresses[i].sin_port;
4271 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4272 if (got != sizeof(port)) {
4273 if (got == -1)
4274 goto tidy_up_and_fail;
4275 goto abort_tidy_up_and_fail;
4276 }
02fc2eee
NC		 4277 } while (i--);
4278
4279 /* Packets sent. I don't trust them to have arrived though.
4280 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4281 connect to localhost will use a second kernel thread. In 2.6 the
4282 first thread running the connect() returns before the second completes,
4283 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4284 returns 0. Poor programs have tripped up. One poor program's authors'
4285 had a 50-1 reverse stock split. Not sure how connected these were.)
4286 So I don't trust someone not to have an unpredictable UDP stack.
4287 */
4288
4289 {
3aed30dc
HS		 4290 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4291 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4292 fd_set rset;
4293
4294 FD_ZERO(&rset);
4295 FD_SET(sockets[0], &rset);
4296 FD_SET(sockets[1], &rset);
4297
4298 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4299 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4300 || !FD_ISSET(sockets[1], &rset)) {
4301 /* I hope this is portable and appropriate. */
4302 if (got == -1)
4303 goto tidy_up_and_fail;
4304 goto abort_tidy_up_and_fail;
4305 }
02fc2eee 4306 }
f4758303 4307
02fc2eee
NC		 4308 /* And the paranoia department even now doesn't trust it to have arrive
4309 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4310 {
3aed30dc
HS		 4311 struct sockaddr_in readfrom;
4312 unsigned short buffer[2];
02fc2eee 4313
3aed30dc
HS		 4314 i = 1;
4315 do {
02fc2eee 4316#ifdef MSG_DONTWAIT
3aed30dc
HS		 4317 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4318 sizeof(buffer), MSG_DONTWAIT,
4319 (struct sockaddr *) &readfrom, &size);
02fc2eee 4320#else
3aed30dc
HS		 4321 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4322 sizeof(buffer), 0,
4323 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4324#endif
02fc2eee 4325
3aed30dc
HS		 4326 if (got == -1)
4327 goto tidy_up_and_fail;
4328 if (got != sizeof(port)
4329 || size != sizeof(struct sockaddr_in)
4330 /* Check other socket sent us its port. */
4331 || buffer[0] != (unsigned short) addresses[!i].sin_port
4332 /* Check kernel says we got the datagram from that socket */
4333 || readfrom.sin_family != addresses[!i].sin_family
4334 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4335 || readfrom.sin_port != addresses[!i].sin_port)
4336 goto abort_tidy_up_and_fail;
4337 } while (i--);
02fc2eee
NC		 4338 }
4339 /* My caller (my_socketpair) has validated that this is non-NULL */
4340 fd[0] = sockets[0];
4341 fd[1] = sockets[1];
4342 /* I hereby declare this connection open. May God bless all who cross
4343 her. */
4344 return 0;
4345
4346 abort_tidy_up_and_fail:
4347 errno = ECONNABORTED;
4348 tidy_up_and_fail:
4349 {
3aed30dc
HS		 4350 int save_errno = errno;
4351 if (sockets[0] != -1)
4352 PerlLIO_close(sockets[0]);
4353 if (sockets[1] != -1)
4354 PerlLIO_close(sockets[1]);
4355 errno = save_errno;
4356 return -1;
02fc2eee
NC		 4357 }
4358}
85ca448a 4359#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4360
b5ac89c3 4361#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4362int
4363Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4364 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4365 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4366 dTHX;
02fc2eee
NC		 4367 int listener = -1;
4368 int connector = -1;
4369 int acceptor = -1;
4370 struct sockaddr_in listen_addr;
4371 struct sockaddr_in connect_addr;
4372 Sock_size_t size;
4373
50458334
JH		 4374 if (protocol
4375#ifdef AF_UNIX
4376 || family != AF_UNIX
4377#endif
3aed30dc
HS		 4378 ) {
4379 errno = EAFNOSUPPORT;
4380 return -1;
02fc2eee 4381 }
2948e0bd 4382 if (!fd) {
3aed30dc
HS		 4383 errno = EINVAL;
4384 return -1;
2948e0bd 4385 }
02fc2eee 4386
2bc69dc4 4387#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4388 if (type == SOCK_DGRAM)
3aed30dc 4389 return S_socketpair_udp(fd);
2bc69dc4 4390#endif
02fc2eee 4391
3aed30dc 4392 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4393 if (listener == -1)
3aed30dc
HS		 4394 return -1;
4395 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4396 listen_addr.sin_family = AF_INET;
3aed30dc 4397 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4398 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4399 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4400 sizeof(listen_addr)) == -1)
4401 goto tidy_up_and_fail;
e10bb1e9 4402 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4403 goto tidy_up_and_fail;
02fc2eee 4404
3aed30dc 4405 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4406 if (connector == -1)
3aed30dc 4407 goto tidy_up_and_fail;
02fc2eee 4408 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4409 size = sizeof(connect_addr);
4410 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4411 &size) == -1)
4412 goto tidy_up_and_fail;
4413 if (size != sizeof(connect_addr))
4414 goto abort_tidy_up_and_fail;
e10bb1e9 4415 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4416 sizeof(connect_addr)) == -1)
4417 goto tidy_up_and_fail;
02fc2eee 4418
3aed30dc
HS		 4419 size = sizeof(listen_addr);
4420 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4421 &size);
02fc2eee 4422 if (acceptor == -1)
3aed30dc
HS		 4423 goto tidy_up_and_fail;
4424 if (size != sizeof(listen_addr))
4425 goto abort_tidy_up_and_fail;
4426 PerlLIO_close(listener);
02fc2eee
NC		 4427 /* Now check we are talking to ourself by matching port and host on the
4428 two sockets. */
3aed30dc
HS		 4429 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4430 &size) == -1)
4431 goto tidy_up_and_fail;
4432 if (size != sizeof(connect_addr)
4433 || listen_addr.sin_family != connect_addr.sin_family
4434 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4435 || listen_addr.sin_port != connect_addr.sin_port) {
4436 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4437 }
4438 fd[0] = connector;
4439 fd[1] = acceptor;
4440 return 0;
4441
4442 abort_tidy_up_and_fail:
85ca448a 4443 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
02fc2eee
NC		 4444 tidy_up_and_fail:
4445 {
3aed30dc
HS		 4446 int save_errno = errno;
4447 if (listener != -1)
4448 PerlLIO_close(listener);
4449 if (connector != -1)
4450 PerlLIO_close(connector);
4451 if (acceptor != -1)
4452 PerlLIO_close(acceptor);
4453 errno = save_errno;
4454 return -1;
02fc2eee
NC		 4455 }
4456}
85ca448a 4457#else
48ea76d1
JH		 4458/* In any case have a stub so that there's code corresponding
4459 * to the my_socketpair in global.sym. */
4460int
4461Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4462#ifdef HAS_SOCKETPAIR
48ea76d1 4463 return socketpair(family, type, protocol, fd);
daf16542
JH		 4464#else
4465 return -1;
4466#endif
48ea76d1
JH		 4467}
4468#endif
4469
68795e93
NIS		 4470/*
4471
4472=for apidoc sv_nosharing
4473
4474Dummy routine which "shares" an SV when there is no sharing module present.
4475Exists to avoid test for a NULL function pointer and because it could potentially warn under
4476some level of strict-ness.
4477
4478=cut
4479*/
4480
4481void
4482Perl_sv_nosharing(pTHX_ SV *sv)
4483{
4484}
4485
4486/*
4487=for apidoc sv_nolocking
4488
4489Dummy routine which "locks" an SV when there is no locking module present.
4490Exists to avoid test for a NULL function pointer and because it could potentially warn under
4491some level of strict-ness.
4492
4493=cut
4494*/
4495
4496void
4497Perl_sv_nolocking(pTHX_ SV *sv)
4498{
4499}
4500
4501
4502/*
4503=for apidoc sv_nounlocking
4504
4505Dummy routine which "unlocks" an SV when there is no locking module present.
4506Exists to avoid test for a NULL function pointer and because it could potentially warn under
4507some level of strict-ness.
4508
4509=cut
4510*/
4511
4512void
4513Perl_sv_nounlocking(pTHX_ SV *sv)
4514{
4515}
4516
a05d7ebb
JH		 4517U32
4518Perl_parse_unicode_opts(pTHX_ char **popt)
4519{
4520 char *p = *popt;
4521 U32 opt = 0;
4522
4523 if (*p) {
4524 if (isDIGIT(*p)) {
4525 opt = (U32) atoi(p);
4526 while (isDIGIT(*p)) p++;
7c91f477 4527 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 4528 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4529 }
4530 else {
4531 for (; *p; p++) {
4532 switch (*p) {
4533 case PERL_UNICODE_STDIN:
4534 opt |= PERL_UNICODE_STDIN_FLAG; break;
4535 case PERL_UNICODE_STDOUT:
4536 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4537 case PERL_UNICODE_STDERR:
4538 opt |= PERL_UNICODE_STDERR_FLAG; break;
4539 case PERL_UNICODE_STD:
4540 opt |= PERL_UNICODE_STD_FLAG; break;
4541 case PERL_UNICODE_IN:
4542 opt |= PERL_UNICODE_IN_FLAG; break;
4543 case PERL_UNICODE_OUT:
4544 opt |= PERL_UNICODE_OUT_FLAG; break;
4545 case PERL_UNICODE_INOUT:
4546 opt |= PERL_UNICODE_INOUT_FLAG; break;
4547 case PERL_UNICODE_LOCALE:
4548 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4549 case PERL_UNICODE_ARGV:
4550 opt |= PERL_UNICODE_ARGV_FLAG; break;
4551 default:
7c91f477
JH		 4552 if (*p != '\n' && *p != '\r')
4553 Perl_croak(aTHX_
4554 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 4555 }
4556 }
4557 }
4558 }
4559 else
4560 opt = PERL_UNICODE_DEFAULT_FLAGS;
4561
4562 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 4563 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 4564 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
4565
4566 *popt = p;
4567
4568 return opt;
4569}
4570
132efe8b
JH		 4571U32
4572Perl_seed(pTHX)
4573{
4574 /*
4575 * This is really just a quick hack which grabs various garbage
4576 * values. It really should be a real hash algorithm which
4577 * spreads the effect of every input bit onto every output bit,
4578 * if someone who knows about such things would bother to write it.
4579 * Might be a good idea to add that function to CORE as well.
4580 * No numbers below come from careful analysis or anything here,
4581 * except they are primes and SEED_C1 > 1E6 to get a full-width
4582 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
4583 * probably be bigger too.
4584 */
4585#if RANDBITS > 16
4586# define SEED_C1 1000003
4587#define SEED_C4 73819
4588#else
4589# define SEED_C1 25747
4590#define SEED_C4 20639
4591#endif
4592#define SEED_C2 3
4593#define SEED_C3 269
4594#define SEED_C5 26107
4595
4596#ifndef PERL_NO_DEV_RANDOM
4597 int fd;
4598#endif
4599 U32 u;
4600#ifdef VMS
4601# include <starlet.h>
4602 /* when[] = (low 32 bits, high 32 bits) of time since epoch
4603 * in 100-ns units, typically incremented ever 10 ms. */
4604 unsigned int when[2];
4605#else
4606# ifdef HAS_GETTIMEOFDAY
4607 struct timeval when;
4608# else
4609 Time_t when;
4610# endif
4611#endif
4612
4613/* This test is an escape hatch, this symbol isn't set by Configure. */
4614#ifndef PERL_NO_DEV_RANDOM
4615#ifndef PERL_RANDOM_DEVICE
4616 /* /dev/random isn't used by default because reads from it will block
4617 * if there isn't enough entropy available. You can compile with
4618 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
4619 * is enough real entropy to fill the seed. */
4620# define PERL_RANDOM_DEVICE "/dev/urandom"
4621#endif
4622 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
4623 if (fd != -1) {
4624 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
4625 u = 0;
4626 PerlLIO_close(fd);
4627 if (u)
4628 return u;
4629 }
4630#endif
4631
4632#ifdef VMS
4633 _ckvmssts(sys$gettim(when));
4634 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
4635#else
4636# ifdef HAS_GETTIMEOFDAY
4637 PerlProc_gettimeofday(&when,NULL);
4638 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
4639# else
4640 (void)time(&when);
4641 u = (U32)SEED_C1 * when;
4642# endif
4643#endif
4644 u += SEED_C3 * (U32)PerlProc_getpid();
4645 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
4646#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
4647 u += SEED_C5 * (U32)PTR2UV(&when);
4648#endif
4649 return u;
4650}
4651
bed60192 4652UV
a783c5f4 4653Perl_get_hash_seed(pTHX)
bed60192
JH		 4654{
4655 char *s = PerlEnv_getenv("PERL_HASH_SEED");
4656 UV myseed = 0;
4657
4658 if (s)
4659 while (isSPACE(*s)) s++;
4660 if (s && isDIGIT(*s))
4661 myseed = (UV)Atoul(s);
4662 else
4663#ifdef USE_HASH_SEED_EXPLICIT
4664 if (s)
4665#endif
4666 {
4667 /* Compute a random seed */
4668 (void)seedDrand01((Rand_seed_t)seed());
bed60192
JH		 4669 myseed = (UV)(Drand01() * (NV)UV_MAX);
4670#if RANDBITS < (UVSIZE * 8)
4671 /* Since there are not enough randbits to to reach all
4672 * the bits of a UV, the low bits might need extra
4673 * help. Sum in another random number that will
4674 * fill in the low bits. */
4675 myseed +=
4676 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
4677#endif /* RANDBITS < (UVSIZE * 8) */
6cfd5ea7
JH		 4678 if (myseed == 0) { /* Superparanoia. */
4679 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
4680 if (myseed == 0)
4681 Perl_croak(aTHX_ "Your random numbers are not that random");
4682 }
bed60192 4683 }
008fb0c0 4684 PL_rehash_seed_set = TRUE;
bed60192
JH		 4685
4686 return myseed;
4687}
Unnamed repository; edit this file 'description' to name the repository.