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