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