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