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