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