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