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