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