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