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