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