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