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