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