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