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