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