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