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