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
regularise whitespace and formatting in util.c
[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);
3aed30dc 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,
3aed30dc 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
3aed30dc 1495 DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
4d1ff10f 1496#endif /* USE_5005THREADS */
3aed30dc
HS		 1497 if (PL_diehook) {
1498 /* sv_2cv might call Perl_croak() */
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;
1508
1509 ENTER;
3a1f2dc9 1510 save_re_context();
3aed30dc
HS		 1511 msg = newSVpvn(message, msglen);
1512 SvREADONLY_on(msg);
1513 SAVEFREESV(msg);
a1d180c4 1514
3a1f2dc9 1515 PUSHSTACKi(PERLSI_DIEHOOK);
3aed30dc
HS		 1516 PUSHMARK(sp);
1517 XPUSHs(msg);
1518 PUTBACK;
1519 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1520 POPSTACK;
3aed30dc
HS		 1521 LEAVE;
1522 }
1523 }
1524 if (PL_in_eval) {
1525 PL_restartop = die_where(message, msglen);
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 }
3aed30dc 1533 my_failure_exit();
599cee73
PM		 1534 }
1535 else {
3aed30dc
HS		 1536 if (PL_warnhook) {
1537 /* sv_2cv might call Perl_warn() */
1538 SV *oldwarnhook = PL_warnhook;
1539 ENTER;
1540 SAVESPTR(PL_warnhook);
1541 PL_warnhook = Nullsv;
1542 cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
3a1f2dc9 1543 LEAVE;
3aed30dc
HS		 1544 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1545 dSP;
1546 SV *msg;
a1d180c4 1547
3aed30dc 1548 ENTER;
3a1f2dc9 1549 save_re_context();
3aed30dc
HS		 1550 msg = newSVpvn(message, msglen);
1551 SvREADONLY_on(msg);
1552 SAVEFREESV(msg);
a1d180c4 1553
3a1f2dc9 1554 PUSHSTACKi(PERLSI_WARNHOOK);
3aed30dc
HS		 1555 PUSHMARK(sp);
1556 XPUSHs(msg);
1557 PUTBACK;
1558 call_sv((SV*)cv, G_DISCARD);
3a1f2dc9 1559 POPSTACK;
3aed30dc
HS		 1560 LEAVE;
1561 return;
1562 }
1563 }
bf49b057
GS		 1564 {
1565 PerlIO *serr = Perl_error_log;
be708cc0 1566 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
599cee73 1567#ifdef LEAKTEST
a1d180c4 1568 DEBUG_L(*message == '!'
06247ec9 1569 ? (xstat(message[1]=='!'
3aed30dc
HS		 1570 ? (message[2]=='!' ? 2 : 1)
1571 : 0)
1572 , 0)
06247ec9 1573 : 0);
599cee73 1574#endif
bf49b057
GS		 1575 (void)PerlIO_flush(serr);
1576 }
599cee73
PM		 1577 }
1578}
1579
e6587932
DM		 1580/* since we've already done strlen() for both nam and val
1581 * we can use that info to make things faster than
1582 * sprintf(s, "%s=%s", nam, val)
1583 */
1584#define my_setenv_format(s, nam, nlen, val, vlen) \
1585 Copy(nam, s, nlen, char); \
1586 *(s+nlen) = '='; \
1587 Copy(val, s+(nlen+1), vlen, char); \
1588 *(s+(nlen+1+vlen)) = '\0'
1589
13b6e58c 1590#ifdef USE_ENVIRON_ARRAY
eccd403f 1591 /* VMS' my_setenv() is in vms.c */
2986a63f 1592#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1593void
864dbfa3 1594Perl_my_setenv(pTHX_ char *nam, char *val)
8d063cd8 1595{
4efc5df6
GS		 1596#ifdef USE_ITHREADS
1597 /* only parent thread can modify process environment */
1598 if (PL_curinterp == aTHX)
1599#endif
1600 {
f2517201
GS		 1601#ifndef PERL_USE_SAFE_PUTENV
1602 /* most putenv()s leak, so we manipulate environ directly */
79072805 1603 register I32 i=setenv_getix(nam); /* where does it go? */
e6587932 1604 int nlen, vlen;
8d063cd8 1605
3280af22 1606 if (environ == PL_origenviron) { /* need we copy environment? */
79072805
LW		 1607 I32 j;
1608 I32 max;
fe14fcc3
LW		 1609 char **tmpenv;
1610
de3bb511 1611 /*SUPPRESS 530*/
fe14fcc3 1612 for (max = i; environ[max]; max++) ;
f2517201
GS		 1613 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1614 for (j=0; j<max; j++) { /* copy environment */
3aed30dc
HS		 1615 int len = strlen(environ[j]);
1616 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1617 Copy(environ[j], tmpenv[j], len+1, char);
f2517201 1618 }
fe14fcc3
LW		 1619 tmpenv[max] = Nullch;
1620 environ = tmpenv; /* tell exec where it is now */
1621 }
a687059c 1622 if (!val) {
f2517201 1623 safesysfree(environ[i]);
a687059c
LW		 1624 while (environ[i]) {
1625 environ[i] = environ[i+1];
1626 i++;
1627 }
1628 return;
1629 }
8d063cd8 1630 if (!environ[i]) { /* does not exist yet */
f2517201 1631 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
8d063cd8
LW		 1632 environ[i+1] = Nullch; /* make sure it's null terminated */
1633 }
fe14fcc3 1634 else
f2517201 1635 safesysfree(environ[i]);
e6587932
DM		 1636 nlen = strlen(nam);
1637 vlen = strlen(val);
f2517201 1638
e6587932
DM		 1639 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1640 /* all that work just for this */
1641 my_setenv_format(environ[i], nam, nlen, val, vlen);
f2517201
GS		 1642
1643#else /* PERL_USE_SAFE_PUTENV */
eccd403f 1644# if defined(__CYGWIN__) || defined( EPOC)
47dafe4d
EF		 1645 setenv(nam, val, 1);
1646# else
f2517201 1647 char *new_env;
e6587932
DM		 1648 int nlen = strlen(nam), vlen;
1649 if (!val) {
3aed30dc 1650 val = "";
e6587932
DM		 1651 }
1652 vlen = strlen(val);
1653 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1654 /* all that work just for this */
1655 my_setenv_format(new_env, nam, nlen, val, vlen);
f2517201 1656 (void)putenv(new_env);
47dafe4d 1657# endif /* __CYGWIN__ */
f2517201 1658#endif /* PERL_USE_SAFE_PUTENV */
4efc5df6 1659 }
8d063cd8
LW		 1660}
1661
2986a63f 1662#else /* WIN32 || NETWARE */
68dc0745 1663
1664void
864dbfa3 1665Perl_my_setenv(pTHX_ char *nam,char *val)
68dc0745 1666{
ac5c734f 1667 register char *envstr;
e6587932
DM		 1668 int nlen = strlen(nam), vlen;
1669
ac5c734f
GS		 1670 if (!val) {
1671 val = "";
1672 }
e6587932
DM		 1673 vlen = strlen(val);
1674 New(904, envstr, nlen+vlen+2, char);
1675 my_setenv_format(envstr, nam, nlen, val, vlen);
ac5c734f
GS		 1676 (void)PerlEnv_putenv(envstr);
1677 Safefree(envstr);
3e3baf6d
TB		 1678}
1679
2986a63f 1680#endif /* WIN32 || NETWARE */
3e3baf6d
TB		 1681
1682I32
864dbfa3 1683Perl_setenv_getix(pTHX_ char *nam)
3e3baf6d
TB		 1684{
1685 register I32 i, len = strlen(nam);
1686
1687 for (i = 0; environ[i]; i++) {
1688 if (
1689#ifdef WIN32
1690 strnicmp(environ[i],nam,len) == 0
1691#else
1692 strnEQ(environ[i],nam,len)
1693#endif
1694 && environ[i][len] == '=')
1695 break; /* strnEQ must come first to avoid */
1696 } /* potential SEGV's */
1697 return i;
68dc0745 1698}
1699
ed79a026 1700#endif /* !VMS && !EPOC*/
378cc40b 1701
16d20bd9 1702#ifdef UNLINK_ALL_VERSIONS
79072805 1703I32
864dbfa3 1704Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */
378cc40b 1705{
79072805 1706 I32 i;
378cc40b 1707
6ad3d225 1708 for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
378cc40b
LW		 1709 return i ? 0 : -1;
1710}
1711#endif
1712
7a3f2258 1713/* this is a drop-in replacement for bcopy() */
2253333f 1714#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1715char *
7a3f2258 1716Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b
LW		 1717{
1718 char *retval = to;
1719
7c0587c8
LW		 1720 if (from - to >= 0) {
1721 while (len--)
1722 *to++ = *from++;
1723 }
1724 else {
1725 to += len;
1726 from += len;
1727 while (len--)
faf8582f 1728 *(--to) = *(--from);
7c0587c8 1729 }
378cc40b
LW		 1730 return retval;
1731}
ffed7fef 1732#endif
378cc40b 1733
7a3f2258 1734/* this is a drop-in replacement for memset() */
fc36a67e 1735#ifndef HAS_MEMSET
1736void *
7a3f2258 1737Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1738{
1739 char *retval = loc;
1740
1741 while (len--)
1742 *loc++ = ch;
1743 return retval;
1744}
1745#endif
1746
7a3f2258 1747/* this is a drop-in replacement for bzero() */
7c0587c8 1748#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1749char *
7a3f2258 1750Perl_my_bzero(register char *loc, register I32 len)
378cc40b
LW		 1751{
1752 char *retval = loc;
1753
1754 while (len--)
1755 *loc++ = 0;
1756 return retval;
1757}
1758#endif
7c0587c8 1759
7a3f2258 1760/* this is a drop-in replacement for memcmp() */
36477c24 1761#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1762I32
7a3f2258 1763Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1764{
36477c24 1765 register U8 *a = (U8 *)s1;
1766 register U8 *b = (U8 *)s2;
79072805 1767 register I32 tmp;
7c0587c8
LW		 1768
1769 while (len--) {
36477c24 1770 if (tmp = *a++ - *b++)
7c0587c8
LW		 1771 return tmp;
1772 }
1773 return 0;
1774}
36477c24 1775#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1776
fe14fcc3 1777#ifndef HAS_VPRINTF
a687059c 1778
85e6fe83 1779#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1780char *
1781#else
1782int
1783#endif
08105a92 1784vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 1785{
1786 FILE fakebuf;
1787
1788 fakebuf._ptr = dest;
1789 fakebuf._cnt = 32767;
35c8bce7
LW		 1790#ifndef _IOSTRG
1791#define _IOSTRG 0
1792#endif
a687059c
LW		 1793 fakebuf._flag = _IOWRT|_IOSTRG;
1794 _doprnt(pat, args, &fakebuf); /* what a kludge */
1795 (void)putc('\0', &fakebuf);
85e6fe83 1796#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1797 return(dest);
1798#else
1799 return 0; /* perl doesn't use return value */
1800#endif
1801}
1802
fe14fcc3 1803#endif /* HAS_VPRINTF */
a687059c
LW		 1804
1805#ifdef MYSWAP
ffed7fef 1806#if BYTEORDER != 0x4321
a687059c 1807short
864dbfa3 1808Perl_my_swap(pTHX_ short s)
a687059c
LW		 1809{
1810#if (BYTEORDER & 1) == 0
1811 short result;
1812
1813 result = ((s & 255) << 8) + ((s >> 8) & 255);
1814 return result;
1815#else
1816 return s;
1817#endif
1818}
1819
1820long
864dbfa3 1821Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1822{
1823 union {
1824 long result;
ffed7fef 1825 char c[sizeof(long)];
a687059c
LW		 1826 } u;
1827
ffed7fef 1828#if BYTEORDER == 0x1234
a687059c
LW		 1829 u.c[0] = (l >> 24) & 255;
1830 u.c[1] = (l >> 16) & 255;
1831 u.c[2] = (l >> 8) & 255;
1832 u.c[3] = l & 255;
1833 return u.result;
1834#else
ffed7fef 1835#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1836 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1837#else
79072805
LW		 1838 register I32 o;
1839 register I32 s;
a687059c 1840
ffed7fef
LW		 1841 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1842 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1843 }
1844 return u.result;
1845#endif
1846#endif
1847}
1848
1849long
864dbfa3 1850Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1851{
1852 union {
1853 long l;
ffed7fef 1854 char c[sizeof(long)];
a687059c
LW		 1855 } u;
1856
ffed7fef 1857#if BYTEORDER == 0x1234
a687059c
LW		 1858 u.c[0] = (l >> 24) & 255;
1859 u.c[1] = (l >> 16) & 255;
1860 u.c[2] = (l >> 8) & 255;
1861 u.c[3] = l & 255;
1862 return u.l;
1863#else
ffed7fef 1864#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1865 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1866#else
79072805
LW		 1867 register I32 o;
1868 register I32 s;
a687059c
LW		 1869
1870 u.l = l;
1871 l = 0;
ffed7fef
LW		 1872 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1873 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1874 }
1875 return l;
1876#endif
1877#endif
1878}
1879
ffed7fef 1880#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1881#endif /* MYSWAP */
1882
1883/*
1884 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1885 * If these functions are defined,
1886 * the BYTEORDER is neither 0x1234 nor 0x4321.
1887 * However, this is not assumed.
1888 * -DWS
1889 */
1890
1891#define HTOV(name,type) \
1892 type \
ba106d47 1893 name (register type n) \
988174c1
LW		 1894 { \
1895 union { \
1896 type value; \
1897 char c[sizeof(type)]; \
1898 } u; \
79072805
LW		 1899 register I32 i; \
1900 register I32 s; \
988174c1
LW		 1901 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1902 u.c[i] = (n >> s) & 0xFF; \
1903 } \
1904 return u.value; \
1905 }
1906
1907#define VTOH(name,type) \
1908 type \
ba106d47 1909 name (register type n) \
988174c1
LW		 1910 { \
1911 union { \
1912 type value; \
1913 char c[sizeof(type)]; \
1914 } u; \
79072805
LW		 1915 register I32 i; \
1916 register I32 s; \
988174c1
LW		 1917 u.value = n; \
1918 n = 0; \
1919 for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
1920 n += (u.c[i] & 0xFF) << s; \
1921 } \
1922 return n; \
1923 }
1924
1925#if defined(HAS_HTOVS) && !defined(htovs)
1926HTOV(htovs,short)
1927#endif
1928#if defined(HAS_HTOVL) && !defined(htovl)
1929HTOV(htovl,long)
1930#endif
1931#if defined(HAS_VTOHS) && !defined(vtohs)
1932VTOH(vtohs,short)
1933#endif
1934#if defined(HAS_VTOHL) && !defined(vtohl)
1935VTOH(vtohl,long)
1936#endif
a687059c 1937
4a7d1889
NIS		 1938PerlIO *
1939Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
1940{
2986a63f 1941#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
1f852d0d
NIS		 1942 int p[2];
1943 register I32 This, that;
1944 register Pid_t pid;
1945 SV *sv;
1946 I32 did_pipes = 0;
1947 int pp[2];
1948
1949 PERL_FLUSHALL_FOR_CHILD;
1950 This = (*mode == 'w');
1951 that = !This;
1952 if (PL_tainting) {
1953 taint_env();
1954 taint_proper("Insecure %s%s", "EXEC");
1955 }
1956 if (PerlProc_pipe(p) < 0)
1957 return Nullfp;
1958 /* Try for another pipe pair for error return */
1959 if (PerlProc_pipe(pp) >= 0)
1960 did_pipes = 1;
52e18b1f 1961 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 1962 if (errno != EAGAIN) {
1963 PerlLIO_close(p[This]);
4e6dfe71 1964 PerlLIO_close(p[that]);
1f852d0d
NIS		 1965 if (did_pipes) {
1966 PerlLIO_close(pp[0]);
1967 PerlLIO_close(pp[1]);
1968 }
1969 return Nullfp;
1970 }
1971 sleep(5);
1972 }
1973 if (pid == 0) {
1974 /* Child */
1f852d0d
NIS		 1975#undef THIS
1976#undef THAT
1977#define THIS that
1978#define THAT This
1f852d0d
NIS		 1979 /* Close parent's end of error status pipe (if any) */
1980 if (did_pipes) {
1981 PerlLIO_close(pp[0]);
1982#if defined(HAS_FCNTL) && defined(F_SETFD)
1983 /* Close error pipe automatically if exec works */
1984 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
1985#endif
1986 }
1987 /* Now dup our end of _the_ pipe to right position */
1988 if (p[THIS] != (*mode == 'r')) {
1989 PerlLIO_dup2(p[THIS], *mode == 'r');
1990 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 1991 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
1992 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 1993 }
4e6dfe71
GS		 1994 else
1995 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 1996#if !defined(HAS_FCNTL) || !defined(F_SETFD)
1997 /* No automatic close - do it by hand */
b7953727
JH		 1998# ifndef NOFILE
1999# define NOFILE 20
2000# endif
a080fe3d
NIS		 2001 {
2002 int fd;
2003
2004 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2005 if (fd != pp[1])
a080fe3d
NIS		 2006 PerlLIO_close(fd);
2007 }
1f852d0d
NIS		 2008 }
2009#endif
2010 do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
2011 PerlProc__exit(1);
2012#undef THIS
2013#undef THAT
2014 }
2015 /* Parent */
52e18b1f 2016 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2017 if (did_pipes)
2018 PerlLIO_close(pp[1]);
2019 /* Keep the lower of the two fd numbers */
2020 if (p[that] < p[This]) {
2021 PerlLIO_dup2(p[This], p[that]);
2022 PerlLIO_close(p[This]);
2023 p[This] = p[that];
2024 }
4e6dfe71
GS		 2025 else
2026 PerlLIO_close(p[that]); /* close child's end of pipe */
2027
1f852d0d
NIS		 2028 LOCK_FDPID_MUTEX;
2029 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2030 UNLOCK_FDPID_MUTEX;
2031 (void)SvUPGRADE(sv,SVt_IV);
2032 SvIVX(sv) = pid;
2033 PL_forkprocess = pid;
2034 /* If we managed to get status pipe check for exec fail */
2035 if (did_pipes && pid > 0) {
2036 int errkid;
2037 int n = 0, n1;
2038
2039 while (n < sizeof(int)) {
2040 n1 = PerlLIO_read(pp[0],
2041 (void*)(((char*)&errkid)+n),
2042 (sizeof(int)) - n);
2043 if (n1 <= 0)
2044 break;
2045 n += n1;
2046 }
2047 PerlLIO_close(pp[0]);
2048 did_pipes = 0;
2049 if (n) { /* Error */
2050 int pid2, status;
8c51524e 2051 PerlLIO_close(p[This]);
1f852d0d
NIS		 2052 if (n != sizeof(int))
2053 Perl_croak(aTHX_ "panic: kid popen errno read");
2054 do {
2055 pid2 = wait4pid(pid, &status, 0);
2056 } while (pid2 == -1 && errno == EINTR);
2057 errno = errkid; /* Propagate errno from kid */
2058 return Nullfp;
2059 }
2060 }
2061 if (did_pipes)
2062 PerlLIO_close(pp[0]);
2063 return PerlIO_fdopen(p[This], mode);
2064#else
4a7d1889
NIS		 2065 Perl_croak(aTHX_ "List form of piped open not implemented");
2066 return (PerlIO *) NULL;
1f852d0d 2067#endif
4a7d1889
NIS		 2068}
2069
5f05dabc 2070 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2071#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2072PerlIO *
864dbfa3 2073Perl_my_popen(pTHX_ char *cmd, char *mode)
a687059c
LW		 2074{
2075 int p[2];
8ac85365 2076 register I32 This, that;
d8a83dd3 2077 register Pid_t pid;
79072805 2078 SV *sv;
1738f5c4 2079 I32 doexec = strNE(cmd,"-");
e446cec8
IZ		 2080 I32 did_pipes = 0;
2081 int pp[2];
a687059c 2082
45bc9206 2083 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2084#ifdef OS2
2085 if (doexec) {
23da6c43 2086 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2087 }
a1d180c4 2088#endif
8ac85365
NIS		 2089 This = (*mode == 'w');
2090 that = !This;
3280af22 2091 if (doexec && PL_tainting) {
bbce6d69 2092 taint_env();
2093 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2094 }
c2267164
IZ		 2095 if (PerlProc_pipe(p) < 0)
2096 return Nullfp;
e446cec8
IZ		 2097 if (doexec && PerlProc_pipe(pp) >= 0)
2098 did_pipes = 1;
52e18b1f 2099 while ((pid = PerlProc_fork()) < 0) {
a687059c 2100 if (errno != EAGAIN) {
6ad3d225 2101 PerlLIO_close(p[This]);
b5ac89c3 2102 PerlLIO_close(p[that]);
e446cec8
IZ		 2103 if (did_pipes) {
2104 PerlLIO_close(pp[0]);
2105 PerlLIO_close(pp[1]);
2106 }
a687059c 2107 if (!doexec)
cea2e8a9 2108 Perl_croak(aTHX_ "Can't fork");
a687059c
LW		 2109 return Nullfp;
2110 }
2111 sleep(5);
2112 }
2113 if (pid == 0) {
79072805
LW		 2114 GV* tmpgv;
2115
30ac6d9b
GS		 2116#undef THIS
2117#undef THAT
a687059c 2118#define THIS that
8ac85365 2119#define THAT This
e446cec8
IZ		 2120 if (did_pipes) {
2121 PerlLIO_close(pp[0]);
2122#if defined(HAS_FCNTL) && defined(F_SETFD)
2123 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2124#endif
2125 }
a687059c 2126 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2127 PerlLIO_dup2(p[THIS], *mode == 'r');
2128 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2129 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2130 PerlLIO_close(p[THAT]);
a687059c 2131 }
b5ac89c3
NIS		 2132 else
2133 PerlLIO_close(p[THAT]);
4435c477 2134#ifndef OS2
a687059c 2135 if (doexec) {
a0d0e21e 2136#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2137 int fd;
2138
2139#ifndef NOFILE
2140#define NOFILE 20
2141#endif
a080fe3d 2142 {
3aed30dc 2143 int fd;
a080fe3d
NIS		 2144
2145 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2146 if (fd != pp[1])
3aed30dc 2147 PerlLIO_close(fd);
a080fe3d 2148 }
ae986130 2149#endif
a080fe3d
NIS		 2150 /* may or may not use the shell */
2151 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2152 PerlProc__exit(1);
a687059c 2153 }
4435c477 2154#endif /* defined OS2 */
de3bb511 2155 /*SUPPRESS 560*/
306196c3 2156 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4d76a344 2157 SvREADONLY_off(GvSV(tmpgv));
7766f137 2158 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2159 SvREADONLY_on(GvSV(tmpgv));
2160 }
2161#ifdef THREADS_HAVE_PIDS
2162 PL_ppid = (IV)getppid();
2163#endif
3280af22
NIS		 2164 PL_forkprocess = 0;
2165 hv_clear(PL_pidstatus); /* we have no children */
a687059c
LW		 2166 return Nullfp;
2167#undef THIS
2168#undef THAT
2169 }
b5ac89c3 2170 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2171 if (did_pipes)
2172 PerlLIO_close(pp[1]);
8ac85365 2173 if (p[that] < p[This]) {
6ad3d225
GS		 2174 PerlLIO_dup2(p[This], p[that]);
2175 PerlLIO_close(p[This]);
8ac85365 2176 p[This] = p[that];
62b28dd9 2177 }
b5ac89c3
NIS		 2178 else
2179 PerlLIO_close(p[that]);
2180
4755096e 2181 LOCK_FDPID_MUTEX;
3280af22 2182 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2183 UNLOCK_FDPID_MUTEX;
a0d0e21e 2184 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2185 SvIVX(sv) = pid;
3280af22 2186 PL_forkprocess = pid;
e446cec8
IZ		 2187 if (did_pipes && pid > 0) {
2188 int errkid;
2189 int n = 0, n1;
2190
2191 while (n < sizeof(int)) {
2192 n1 = PerlLIO_read(pp[0],
2193 (void*)(((char*)&errkid)+n),
2194 (sizeof(int)) - n);
2195 if (n1 <= 0)
2196 break;
2197 n += n1;
2198 }
2f96c702
IZ		 2199 PerlLIO_close(pp[0]);
2200 did_pipes = 0;
e446cec8 2201 if (n) { /* Error */
faa466a7 2202 int pid2, status;
8c51524e 2203 PerlLIO_close(p[This]);
e446cec8 2204 if (n != sizeof(int))
cea2e8a9 2205 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2206 do {
2207 pid2 = wait4pid(pid, &status, 0);
2208 } while (pid2 == -1 && errno == EINTR);
e446cec8
IZ		 2209 errno = errkid; /* Propagate errno from kid */
2210 return Nullfp;
2211 }
2212 }
2213 if (did_pipes)
2214 PerlLIO_close(pp[0]);
8ac85365 2215 return PerlIO_fdopen(p[This], mode);
a687059c 2216}
7c0587c8 2217#else
85ca448a 2218#if defined(atarist) || defined(EPOC)
7c0587c8 2219FILE *popen();
760ac839 2220PerlIO *
864dbfa3 2221Perl_my_popen(pTHX_ char *cmd, char *mode)
7c0587c8 2222{
45bc9206 2223 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2224 /* Call system's popen() to get a FILE *, then import it.
2225 used 0 for 2nd parameter to PerlIO_importFILE;
2226 apparently not used
2227 */
2228 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2229}
2b96b0a5
JH		 2230#else
2231#if defined(DJGPP)
2232FILE *djgpp_popen();
2233PerlIO *
2234Perl_my_popen(pTHX_ char *cmd, char *mode)
2235{
2236 PERL_FLUSHALL_FOR_CHILD;
2237 /* Call system's popen() to get a FILE *, then import it.
2238 used 0 for 2nd parameter to PerlIO_importFILE;
2239 apparently not used
2240 */
2241 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2242}
2243#endif
7c0587c8
LW		 2244#endif
2245
2246#endif /* !DOSISH */
a687059c 2247
52e18b1f
GS		 2248/* this is called in parent before the fork() */
2249void
2250Perl_atfork_lock(void)
2251{
4d1ff10f 2252#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
52e18b1f
GS		 2253 /* locks must be held in locking order (if any) */
2254# ifdef MYMALLOC
2255 MUTEX_LOCK(&PL_malloc_mutex);
2256# endif
2257 OP_REFCNT_LOCK;
2258#endif
2259}
2260
2261/* this is called in both parent and child after the fork() */
2262void
2263Perl_atfork_unlock(void)
2264{
4d1ff10f 2265#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
52e18b1f
GS		 2266 /* locks must be released in same order as in atfork_lock() */
2267# ifdef MYMALLOC
2268 MUTEX_UNLOCK(&PL_malloc_mutex);
2269# endif
2270 OP_REFCNT_UNLOCK;
2271#endif
2272}
2273
2274Pid_t
2275Perl_my_fork(void)
2276{
2277#if defined(HAS_FORK)
2278 Pid_t pid;
4d1ff10f 2279#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2280 atfork_lock();
2281 pid = fork();
2282 atfork_unlock();
2283#else
2284 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2285 * handlers elsewhere in the code */
2286 pid = fork();
2287#endif
2288 return pid;
2289#else
2290 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2291 Perl_croak_nocontext("fork() not available");
b961a566 2292 return 0;
52e18b1f
GS		 2293#endif /* HAS_FORK */
2294}
2295
748a9306 2296#ifdef DUMP_FDS
35ff7856 2297void
864dbfa3 2298Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2299{
2300 int fd;
c623ac67 2301 Stat_t tmpstatbuf;
ae986130 2302
bf49b057 2303 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2304 for (fd = 0; fd < 32; fd++) {
6ad3d225 2305 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2306 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2307 }
bf49b057 2308 PerlIO_printf(Perl_debug_log,"\n");
ae986130 2309}
35ff7856 2310#endif /* DUMP_FDS */
ae986130 2311
fe14fcc3 2312#ifndef HAS_DUP2
fec02dd3 2313int
ba106d47 2314dup2(int oldfd, int newfd)
a687059c 2315{
a0d0e21e 2316#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2317 if (oldfd == newfd)
2318 return oldfd;
6ad3d225 2319 PerlLIO_close(newfd);
fec02dd3 2320 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2321#else
fc36a67e 2322#define DUP2_MAX_FDS 256
2323 int fdtmp[DUP2_MAX_FDS];
79072805 2324 I32 fdx = 0;
ae986130
LW		 2325 int fd;
2326
fe14fcc3 2327 if (oldfd == newfd)
fec02dd3 2328 return oldfd;
6ad3d225 2329 PerlLIO_close(newfd);
fc36a67e 2330 /* good enough for low fd's... */
6ad3d225 2331 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2332 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2333 PerlLIO_close(fd);
fc36a67e 2334 fd = -1;
2335 break;
2336 }
ae986130 2337 fdtmp[fdx++] = fd;
fc36a67e 2338 }
ae986130 2339 while (fdx > 0)
6ad3d225 2340 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2341 return fd;
62b28dd9 2342#endif
a687059c
LW		 2343}
2344#endif
2345
64ca3a65 2346#ifndef PERL_MICRO
ff68c719 2347#ifdef HAS_SIGACTION
2348
2349Sighandler_t
864dbfa3 2350Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2351{
2352 struct sigaction act, oact;
2353
a10b1e10
JH		 2354#ifdef USE_ITHREADS
2355 /* only "parent" interpreter can diddle signals */
2356 if (PL_curinterp != aTHX)
2357 return SIG_ERR;
2358#endif
2359
ff68c719 2360 act.sa_handler = handler;
2361 sigemptyset(&act.sa_mask);
2362 act.sa_flags = 0;
2363#ifdef SA_RESTART
0dd95eb2 2364#if defined(PERL_OLD_SIGNALS)
ff68c719 2365 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2366#endif
0a8e0eff 2367#endif
85264bed
CS		 2368#ifdef SA_NOCLDWAIT
2369 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2370 act.sa_flags |= SA_NOCLDWAIT;
2371#endif
ff68c719 2372 if (sigaction(signo, &act, &oact) == -1)
36477c24 2373 return SIG_ERR;
ff68c719 2374 else
36477c24 2375 return oact.sa_handler;
ff68c719 2376}
2377
2378Sighandler_t
864dbfa3 2379Perl_rsignal_state(pTHX_ int signo)
ff68c719 2380{
2381 struct sigaction oact;
2382
2383 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
3aed30dc 2384 return SIG_ERR;
ff68c719 2385 else
3aed30dc 2386 return oact.sa_handler;
ff68c719 2387}
2388
2389int
864dbfa3 2390Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2391{
2392 struct sigaction act;
2393
a10b1e10
JH		 2394#ifdef USE_ITHREADS
2395 /* only "parent" interpreter can diddle signals */
2396 if (PL_curinterp != aTHX)
2397 return -1;
2398#endif
2399
ff68c719 2400 act.sa_handler = handler;
2401 sigemptyset(&act.sa_mask);
2402 act.sa_flags = 0;
2403#ifdef SA_RESTART
0dd95eb2 2404#if defined(PERL_OLD_SIGNALS)
ff68c719 2405 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
2406#endif
0a8e0eff 2407#endif
85264bed
CS		 2408#ifdef SA_NOCLDWAIT
2409 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
2410 act.sa_flags |= SA_NOCLDWAIT;
2411#endif
ff68c719 2412 return sigaction(signo, &act, save);
2413}
2414
2415int
864dbfa3 2416Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2417{
a10b1e10
JH		 2418#ifdef USE_ITHREADS
2419 /* only "parent" interpreter can diddle signals */
2420 if (PL_curinterp != aTHX)
2421 return -1;
2422#endif
2423
ff68c719 2424 return sigaction(signo, save, (struct sigaction *)NULL);
2425}
2426
2427#else /* !HAS_SIGACTION */
2428
2429Sighandler_t
864dbfa3 2430Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2431{
39f1703b 2432#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2433 /* only "parent" interpreter can diddle signals */
2434 if (PL_curinterp != aTHX)
2435 return SIG_ERR;
2436#endif
2437
6ad3d225 2438 return PerlProc_signal(signo, handler);
ff68c719 2439}
2440
df3728a2
JH		 2441static int sig_trapped; /* XXX signals are process-wide anyway, so we
2442 ignore the implications of this for threading */
ff68c719 2443
2444static
2445Signal_t
4e35701f 2446sig_trap(int signo)
ff68c719 2447{
2448 sig_trapped++;
2449}
2450
2451Sighandler_t
864dbfa3 2452Perl_rsignal_state(pTHX_ int signo)
ff68c719 2453{
2454 Sighandler_t oldsig;
2455
39f1703b 2456#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2457 /* only "parent" interpreter can diddle signals */
2458 if (PL_curinterp != aTHX)
2459 return SIG_ERR;
2460#endif
2461
ff68c719 2462 sig_trapped = 0;
6ad3d225
GS		 2463 oldsig = PerlProc_signal(signo, sig_trap);
2464 PerlProc_signal(signo, oldsig);
ff68c719 2465 if (sig_trapped)
3aed30dc 2466 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2467 return oldsig;
2468}
2469
2470int
864dbfa3 2471Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2472{
39f1703b 2473#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2474 /* only "parent" interpreter can diddle signals */
2475 if (PL_curinterp != aTHX)
2476 return -1;
2477#endif
6ad3d225 2478 *save = PerlProc_signal(signo, handler);
ff68c719 2479 return (*save == SIG_ERR) ? -1 : 0;
2480}
2481
2482int
864dbfa3 2483Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2484{
39f1703b 2485#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2486 /* only "parent" interpreter can diddle signals */
2487 if (PL_curinterp != aTHX)
2488 return -1;
2489#endif
6ad3d225 2490 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
ff68c719 2491}
2492
2493#endif /* !HAS_SIGACTION */
64ca3a65 2494#endif /* !PERL_MICRO */
ff68c719 2495
5f05dabc 2496 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2497#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2498I32
864dbfa3 2499Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2500{
ff68c719 2501 Sigsave_t hstat, istat, qstat;
a687059c 2502 int status;
a0d0e21e 2503 SV **svp;
d8a83dd3
JH		 2504 Pid_t pid;
2505 Pid_t pid2;
03136e13 2506 bool close_failed;
b7953727 2507 int saved_errno = 0;
03136e13
CS		 2508#ifdef VMS
2509 int saved_vaxc_errno;
2510#endif
22fae026
TM		 2511#ifdef WIN32
2512 int saved_win32_errno;
2513#endif
a687059c 2514
4755096e 2515 LOCK_FDPID_MUTEX;
3280af22 2516 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2517 UNLOCK_FDPID_MUTEX;
25d92023 2518 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2519 SvREFCNT_dec(*svp);
3280af22 2520 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2521#ifdef OS2
2522 if (pid == -1) { /* Opened by popen. */
2523 return my_syspclose(ptr);
2524 }
a1d180c4 2525#endif
03136e13
CS		 2526 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2527 saved_errno = errno;
2528#ifdef VMS
2529 saved_vaxc_errno = vaxc$errno;
2530#endif
22fae026
TM		 2531#ifdef WIN32
2532 saved_win32_errno = GetLastError();
2533#endif
03136e13 2534 }
7c0587c8 2535#ifdef UTS
6ad3d225 2536 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2537#endif
64ca3a65 2538#ifndef PERL_MICRO
ff68c719 2539 rsignal_save(SIGHUP, SIG_IGN, &hstat);
2540 rsignal_save(SIGINT, SIG_IGN, &istat);
2541 rsignal_save(SIGQUIT, SIG_IGN, &qstat);
64ca3a65 2542#endif
748a9306 2543 do {
1d3434b8
GS		 2544 pid2 = wait4pid(pid, &status, 0);
2545 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2546#ifndef PERL_MICRO
ff68c719 2547 rsignal_restore(SIGHUP, &hstat);
2548 rsignal_restore(SIGINT, &istat);
2549 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2550#endif
03136e13
CS		 2551 if (close_failed) {
2552 SETERRNO(saved_errno, saved_vaxc_errno);
2553 return -1;
2554 }
1d3434b8 2555 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2556}
4633a7c4
LW		 2557#endif /* !DOSISH */
2558
2986a63f 2559#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2560I32
d8a83dd3 2561Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2562{
cddd4526 2563 I32 result;
b7953727
JH		 2564 if (!pid)
2565 return -1;
2566#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2567 {
3aed30dc
HS		 2568 SV *sv;
2569 SV** svp;
2570 char spid[TYPE_CHARS(int)];
20188a90 2571
3aed30dc 2572 if (pid > 0) {
7b0972df 2573 sprintf(spid, "%"IVdf, (IV)pid);
3aed30dc
HS		 2574 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
2575 if (svp && *svp != &PL_sv_undef) {
2576 *statusp = SvIVX(*svp);
2577 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2578 return pid;
2579 }
2580 }
2581 else {
2582 HE *entry;
2583
2584 hv_iterinit(PL_pidstatus);
2585 if ((entry = hv_iternext(PL_pidstatus))) {
2586 SV *sv;
2587 char spid[TYPE_CHARS(int)];
2588
2589 pid = atoi(hv_iterkey(entry,(I32*)statusp));
2590 sv = hv_iterval(PL_pidstatus,entry);
2591 *statusp = SvIVX(sv);
2592 sprintf(spid, "%"IVdf, (IV)pid);
2593 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
2594 return pid;
2595 }
20188a90
LW		 2596 }
2597 }
68a29c53 2598#endif
79072805 2599#ifdef HAS_WAITPID
367f3c24
IZ		 2600# ifdef HAS_WAITPID_RUNTIME
2601 if (!HAS_WAITPID_RUNTIME)
2602 goto hard_way;
2603# endif
cddd4526 2604 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2605 goto finish;
367f3c24
IZ		 2606#endif
2607#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
cddd4526 2608 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
dfcfdb64 2609 goto finish;
367f3c24
IZ		 2610#endif
2611#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
2612 hard_way:
a0d0e21e 2613 {
a0d0e21e 2614 if (flags)
cea2e8a9 2615 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2616 else {
76e3520e 2617 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2618 pidgone(result,*statusp);
2619 if (result < 0)
2620 *statusp = -1;
2621 }
a687059c
LW		 2622 }
2623#endif
dfcfdb64 2624 finish:
cddd4526
NIS		 2625 if (result < 0 && errno == EINTR) {
2626 PERL_ASYNC_CHECK();
2627 }
2628 return result;
a687059c 2629}
2986a63f 2630#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2631
7c0587c8 2632void
de3bb511 2633/*SUPPRESS 590*/
d8a83dd3 2634Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2635{
79072805 2636 register SV *sv;
fc36a67e 2637 char spid[TYPE_CHARS(int)];
a687059c 2638
7b0972df 2639 sprintf(spid, "%"IVdf, (IV)pid);
3280af22 2640 sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
a0d0e21e 2641 (void)SvUPGRADE(sv,SVt_IV);
463ee0b2 2642 SvIVX(sv) = status;
20188a90 2643 return;
a687059c
LW		 2644}
2645
85ca448a 2646#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2647int pclose();
ddcf38b7
IZ		 2648#ifdef HAS_FORK
2649int /* Cannot prototype with I32
2650 in os2ish.h. */
ba106d47 2651my_syspclose(PerlIO *ptr)
ddcf38b7 2652#else
79072805 2653I32
864dbfa3 2654Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2655#endif
a687059c 2656{
760ac839
LW		 2657 /* Needs work for PerlIO ! */
2658 FILE *f = PerlIO_findFILE(ptr);
2659 I32 result = pclose(f);
2b96b0a5
JH		 2660 PerlIO_releaseFILE(ptr,f);
2661 return result;
2662}
2663#endif
2664
933fea7f 2665#if defined(DJGPP)
2b96b0a5
JH		 2666int djgpp_pclose();
2667I32
2668Perl_my_pclose(pTHX_ PerlIO *ptr)
2669{
2670 /* Needs work for PerlIO ! */
2671 FILE *f = PerlIO_findFILE(ptr);
2672 I32 result = djgpp_pclose(f);
933fea7f 2673 result = (result << 8) & 0xff00;
760ac839
LW		 2674 PerlIO_releaseFILE(ptr,f);
2675 return result;
a687059c 2676}
7c0587c8 2677#endif
9f68db38
LW		 2678
2679void
864dbfa3 2680Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2681{
79072805 2682 register I32 todo;
08105a92 2683 register const char *frombase = from;
9f68db38
LW		 2684
2685 if (len == 1) {
08105a92 2686 register const char c = *from;
9f68db38 2687 while (count-- > 0)
5926133d 2688 *to++ = c;
9f68db38
LW		 2689 return;
2690 }
2691 while (count-- > 0) {
2692 for (todo = len; todo > 0; todo--) {
2693 *to++ = *from++;
2694 }
2695 from = frombase;
2696 }
2697}
0f85fab0 2698
fe14fcc3 2699#ifndef HAS_RENAME
79072805 2700I32
864dbfa3 2701Perl_same_dirent(pTHX_ char *a, char *b)
62b28dd9 2702{
93a17b20
LW		 2703 char *fa = strrchr(a,'/');
2704 char *fb = strrchr(b,'/');
c623ac67
GS		 2705 Stat_t tmpstatbuf1;
2706 Stat_t tmpstatbuf2;
46fc3d4c 2707 SV *tmpsv = sv_newmortal();
62b28dd9
LW		 2708
2709 if (fa)
2710 fa++;
2711 else
2712 fa = a;
2713 if (fb)
2714 fb++;
2715 else
2716 fb = b;
2717 if (strNE(a,b))
2718 return FALSE;
2719 if (fa == a)
46fc3d4c 2720 sv_setpv(tmpsv, ".");
62b28dd9 2721 else
46fc3d4c 2722 sv_setpvn(tmpsv, a, fa - a);
c6ed36e1 2723 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2724 return FALSE;
2725 if (fb == b)
46fc3d4c 2726 sv_setpv(tmpsv, ".");
62b28dd9 2727 else
46fc3d4c 2728 sv_setpvn(tmpsv, b, fb - b);
c6ed36e1 2729 if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2730 return FALSE;
2731 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2732 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2733}
fe14fcc3
LW		 2734#endif /* !HAS_RENAME */
2735
491527d0 2736char*
864dbfa3 2737Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
491527d0 2738{
491527d0
GS		 2739 char *xfound = Nullch;
2740 char *xfailed = Nullch;
0f31cffe 2741 char tmpbuf[MAXPATHLEN];
491527d0 2742 register char *s;
5f74f29c 2743 I32 len = 0;
491527d0
GS		 2744 int retval;
2745#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
2746# define SEARCH_EXTS ".bat", ".cmd", NULL
2747# define MAX_EXT_LEN 4
2748#endif
2749#ifdef OS2
2750# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
2751# define MAX_EXT_LEN 4
2752#endif
2753#ifdef VMS
2754# define SEARCH_EXTS ".pl", ".com", NULL
2755# define MAX_EXT_LEN 4
2756#endif
2757 /* additional extensions to try in each dir if scriptname not found */
2758#ifdef SEARCH_EXTS
2759 char *exts[] = { SEARCH_EXTS };
2760 char **ext = search_ext ? search_ext : exts;
2761 int extidx = 0, i = 0;
2762 char *curext = Nullch;
2763#else
2764# define MAX_EXT_LEN 0
2765#endif
2766
2767 /*
2768 * If dosearch is true and if scriptname does not contain path
2769 * delimiters, search the PATH for scriptname.
2770 *
2771 * If SEARCH_EXTS is also defined, will look for each
2772 * scriptname{SEARCH_EXTS} whenever scriptname is not found
2773 * while searching the PATH.
2774 *
2775 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
2776 * proceeds as follows:
2777 * If DOSISH or VMSISH:
2778 * + look for ./scriptname{,.foo,.bar}
2779 * + search the PATH for scriptname{,.foo,.bar}
2780 *
2781 * If !DOSISH:
2782 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
2783 * this will not look in '.' if it's not in the PATH)
2784 */
84486fc6 2785 tmpbuf[0] = '\0';
491527d0
GS		 2786
2787#ifdef VMS
2788# ifdef ALWAYS_DEFTYPES
2789 len = strlen(scriptname);
2790 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
2791 int hasdir, idx = 0, deftypes = 1;
2792 bool seen_dot = 1;
2793
2794 hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
2795# else
2796 if (dosearch) {
2797 int hasdir, idx = 0, deftypes = 1;
2798 bool seen_dot = 1;
2799
2800 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
2801# endif
2802 /* The first time through, just add SEARCH_EXTS to whatever we
2803 * already have, so we can check for default file types. */
2804 while (deftypes ||
84486fc6 2805 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 2806 {
2807 if (deftypes) {
2808 deftypes = 0;
84486fc6 2809 *tmpbuf = '\0';
491527d0 2810 }
84486fc6
GS		 2811 if ((strlen(tmpbuf) + strlen(scriptname)
2812 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 2813 continue; /* don't search dir with too-long name */
84486fc6 2814 strcat(tmpbuf, scriptname);
491527d0
GS		 2815#else /* !VMS */
2816
2817#ifdef DOSISH
2818 if (strEQ(scriptname, "-"))
2819 dosearch = 0;
2820 if (dosearch) { /* Look in '.' first. */
2821 char *cur = scriptname;
2822#ifdef SEARCH_EXTS
2823 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
2824 while (ext[i])
2825 if (strEQ(ext[i++],curext)) {
2826 extidx = -1; /* already has an ext */
2827 break;
2828 }
2829 do {
2830#endif
2831 DEBUG_p(PerlIO_printf(Perl_debug_log,
2832 "Looking for %s\n",cur));
017f25f1
IZ		 2833 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
2834 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 2835 dosearch = 0;
2836 scriptname = cur;
2837#ifdef SEARCH_EXTS
2838 break;
2839#endif
2840 }
2841#ifdef SEARCH_EXTS
2842 if (cur == scriptname) {
2843 len = strlen(scriptname);
84486fc6 2844 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 2845 break;
84486fc6 2846 cur = strcpy(tmpbuf, scriptname);
491527d0
GS		 2847 }
2848 } while (extidx >= 0 && ext[extidx] /* try an extension? */
84486fc6 2849 && strcpy(tmpbuf+len, ext[extidx++]));
491527d0
GS		 2850#endif
2851 }
2852#endif
2853
cd39f2b6
JH		 2854#ifdef MACOS_TRADITIONAL
2855 if (dosearch && !strchr(scriptname, ':') &&
2856 (s = PerlEnv_getenv("Commands")))
2857#else
491527d0
GS		 2858 if (dosearch && !strchr(scriptname, '/')
2859#ifdef DOSISH
2860 && !strchr(scriptname, '\\')
2861#endif
cd39f2b6
JH		 2862 && (s = PerlEnv_getenv("PATH")))
2863#endif
2864 {
491527d0 2865 bool seen_dot = 0;
92f0c265 2866
3280af22
NIS		 2867 PL_bufend = s + strlen(s);
2868 while (s < PL_bufend) {
cd39f2b6
JH		 2869#ifdef MACOS_TRADITIONAL
2870 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
2871 ',',
2872 &len);
2873#else
491527d0
GS		 2874#if defined(atarist) || defined(DOSISH)
2875 for (len = 0; *s
2876# ifdef atarist
2877 && *s != ','
2878# endif
2879 && *s != ';'; len++, s++) {
84486fc6
GS		 2880 if (len < sizeof tmpbuf)
2881 tmpbuf[len] = *s;
491527d0 2882 }
84486fc6
GS		 2883 if (len < sizeof tmpbuf)
2884 tmpbuf[len] = '\0';
491527d0 2885#else /* ! (atarist || DOSISH) */
3280af22 2886 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 2887 ':',
2888 &len);
2889#endif /* ! (atarist || DOSISH) */
cd39f2b6 2890#endif /* MACOS_TRADITIONAL */
3280af22 2891 if (s < PL_bufend)
491527d0 2892 s++;
84486fc6 2893 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 2894 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 2895#ifdef MACOS_TRADITIONAL
2896 if (len && tmpbuf[len - 1] != ':')
2897 tmpbuf[len++] = ':';
2898#else
491527d0 2899 if (len
61ae2fbf 2900#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 2901 && tmpbuf[len - 1] != '/'
2902 && tmpbuf[len - 1] != '\\'
491527d0
GS		 2903#endif
2904 )
84486fc6
GS		 2905 tmpbuf[len++] = '/';
2906 if (len == 2 && tmpbuf[0] == '.')
491527d0 2907 seen_dot = 1;
cd39f2b6 2908#endif
84486fc6 2909 (void)strcpy(tmpbuf + len, scriptname);
491527d0
GS		 2910#endif /* !VMS */
2911
2912#ifdef SEARCH_EXTS
84486fc6 2913 len = strlen(tmpbuf);
491527d0
GS		 2914 if (extidx > 0) /* reset after previous loop */
2915 extidx = 0;
2916 do {
2917#endif
84486fc6 2918 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 2919 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 2920 if (S_ISDIR(PL_statbuf.st_mode)) {
2921 retval = -1;
2922 }
491527d0
GS		 2923#ifdef SEARCH_EXTS
2924 } while ( retval < 0 /* not there */
2925 && extidx>=0 && ext[extidx] /* try an extension? */
84486fc6 2926 && strcpy(tmpbuf+len, ext[extidx++])
491527d0
GS		 2927 );
2928#endif
2929 if (retval < 0)
2930 continue;
3280af22
NIS		 2931 if (S_ISREG(PL_statbuf.st_mode)
2932 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 2933#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 2934 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 2935#endif
2936 )
2937 {
3aed30dc 2938 xfound = tmpbuf; /* bingo! */
491527d0
GS		 2939 break;
2940 }
2941 if (!xfailed)
84486fc6 2942 xfailed = savepv(tmpbuf);
491527d0
GS		 2943 }
2944#ifndef DOSISH
017f25f1 2945 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 2946 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 2947 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 2948#endif
2949 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 2950 if (!xfound) {
2951 if (flags & 1) { /* do or die? */
3aed30dc 2952 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 2953 (xfailed ? "execute" : "find"),
2954 (xfailed ? xfailed : scriptname),
2955 (xfailed ? "" : " on PATH"),
2956 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
2957 }
2958 scriptname = Nullch;
2959 }
491527d0
GS		 2960 if (xfailed)
2961 Safefree(xfailed);
2962 scriptname = xfound;
2963 }
9ccb31f9 2964 return (scriptname ? savepv(scriptname) : Nullch);
491527d0
GS		 2965}
2966
ba869deb
GS		 2967#ifndef PERL_GET_CONTEXT_DEFINED
2968
2969void *
2970Perl_get_context(void)
2971{
4d1ff10f 2972#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
ba869deb
GS		 2973# ifdef OLD_PTHREADS_API
2974 pthread_addr_t t;
2975 if (pthread_getspecific(PL_thr_key, &t))
2976 Perl_croak_nocontext("panic: pthread_getspecific");
2977 return (void*)t;
2978# else
bce813aa 2979# ifdef I_MACH_CTHREADS
8b8b35ab 2980 return (void*)cthread_data(cthread_self());
bce813aa 2981# else
8b8b35ab
JH		 2982 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
2983# endif
c44d3fdb 2984# endif
ba869deb
GS		 2985#else
2986 return (void*)NULL;
2987#endif
2988}
2989
2990void
2991Perl_set_context(void *t)
2992{
4d1ff10f 2993#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
c44d3fdb
GS		 2994# ifdef I_MACH_CTHREADS
2995 cthread_set_data(cthread_self(), t);
2996# else
ba869deb
GS		 2997 if (pthread_setspecific(PL_thr_key, t))
2998 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 2999# endif
ba869deb
GS		 3000#endif
3001}
3002
3003#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3004
4d1ff10f 3005#ifdef USE_5005THREADS
ba869deb 3006
12ca11f6
MB		 3007#ifdef FAKE_THREADS
3008/* Very simplistic scheduler for now */
3009void
3010schedule(void)
3011{
c7848ba1 3012 thr = thr->i.next_run;
12ca11f6
MB		 3013}
3014
3015void
864dbfa3 3016Perl_cond_init(pTHX_ perl_cond *cp)
12ca11f6
MB		 3017{
3018 *cp = 0;
3019}
3020
3021void
864dbfa3 3022Perl_cond_signal(pTHX_ perl_cond *cp)
12ca11f6 3023{
51dd5992 3024 perl_os_thread t;
12ca11f6 3025 perl_cond cond = *cp;
a1d180c4 3026
12ca11f6
MB		 3027 if (!cond)
3028 return;
3029 t = cond->thread;
3030 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB		 3031 t->i.next_run = thr->i.next_run;
3032 thr->i.next_run->i.prev_run = t;
3033 t->i.prev_run = thr;
3034 thr->i.next_run = t;
3035 thr->i.wait_queue = 0;
12ca11f6
MB		 3036 /* Remove from the wait queue */
3037 *cp = cond->next;
3038 Safefree(cond);
3039}
3040
3041void
864dbfa3 3042Perl_cond_broadcast(pTHX_ perl_cond *cp)
12ca11f6 3043{
51dd5992 3044 perl_os_thread t;
12ca11f6 3045 perl_cond cond, cond_next;
a1d180c4 3046
12ca11f6
MB		 3047 for (cond = *cp; cond; cond = cond_next) {
3048 t = cond->thread;
3049 /* Insert t in the runnable queue just ahead of us */
c7848ba1
MB		 3050 t->i.next_run = thr->i.next_run;
3051 thr->i.next_run->i.prev_run = t;
3052 t->i.prev_run = thr;
3053 thr->i.next_run = t;
3054 thr->i.wait_queue = 0;
12ca11f6
MB		 3055 /* Remove from the wait queue */
3056 cond_next = cond->next;
3057 Safefree(cond);
3058 }
3059 *cp = 0;
3060}
3061
3062void
864dbfa3 3063Perl_cond_wait(pTHX_ perl_cond *cp)
12ca11f6
MB		 3064{
3065 perl_cond cond;
3066
c7848ba1 3067 if (thr->i.next_run == thr)
cea2e8a9 3068 Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
a1d180c4 3069
0f15f207 3070 New(666, cond, 1, struct perl_wait_queue);
12ca11f6
MB		 3071 cond->thread = thr;
3072 cond->next = *cp;
3073 *cp = cond;
c7848ba1 3074 thr->i.wait_queue = cond;
12ca11f6 3075 /* Remove ourselves from runnable queue */
c7848ba1
MB		 3076 thr->i.next_run->i.prev_run = thr->i.prev_run;
3077 thr->i.prev_run->i.next_run = thr->i.next_run;
12ca11f6
MB		 3078}
3079#endif /* FAKE_THREADS */
3080
f93b4edd 3081MAGIC *
864dbfa3 3082Perl_condpair_magic(pTHX_ SV *sv)
f93b4edd
MB		 3083{
3084 MAGIC *mg;
a1d180c4 3085
3e209e71 3086 (void)SvUPGRADE(sv, SVt_PVMG);
14befaf4 3087 mg = mg_find(sv, PERL_MAGIC_mutex);
f93b4edd
MB		 3088 if (!mg) {
3089 condpair_t *cp;
3090
3091 New(53, cp, 1, condpair_t);
3092 MUTEX_INIT(&cp->mutex);
3093 COND_INIT(&cp->owner_cond);
3094 COND_INIT(&cp->cond);
3095 cp->owner = 0;
1feb2720 3096 LOCK_CRED_MUTEX; /* XXX need separate mutex? */
14befaf4 3097 mg = mg_find(sv, PERL_MAGIC_mutex);
f93b4edd
MB		 3098 if (mg) {
3099 /* someone else beat us to initialising it */
1feb2720 3100 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
f93b4edd
MB		 3101 MUTEX_DESTROY(&cp->mutex);
3102 COND_DESTROY(&cp->owner_cond);
3103 COND_DESTROY(&cp->cond);
3104 Safefree(cp);
3105 }
3106 else {
14befaf4 3107 sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
f93b4edd
MB		 3108 mg = SvMAGIC(sv);
3109 mg->mg_ptr = (char *)cp;
565764a8 3110 mg->mg_len = sizeof(cp);
1feb2720 3111 UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
bf49b057 3112 DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
a674cc95 3113 "%p: condpair_magic %p\n", thr, sv)));
f93b4edd
MB		 3114 }
3115 }
3116 return mg;
3117}
a863c7d1 3118
3d35f11b 3119SV *
4755096e 3120Perl_sv_lock(pTHX_ SV *osv)
3d35f11b
GS		 3121{
3122 MAGIC *mg;
3123 SV *sv = osv;
3124
631cfb58 3125 LOCK_SV_LOCK_MUTEX;
3d35f11b
GS		 3126 if (SvROK(sv)) {
3127 sv = SvRV(sv);
3d35f11b
GS		 3128 }
3129
3130 mg = condpair_magic(sv);
3131 MUTEX_LOCK(MgMUTEXP(mg));
3132 if (MgOWNER(mg) == thr)
3133 MUTEX_UNLOCK(MgMUTEXP(mg));
4755096e 3134 else {
3d35f11b
GS		 3135 while (MgOWNER(mg))
3136 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
3137 MgOWNER(mg) = thr;
4755096e
GS		 3138 DEBUG_S(PerlIO_printf(Perl_debug_log,
3139 "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
a674cc95 3140 PTR2UV(thr), PTR2UV(sv)));
3d35f11b
GS		 3141 MUTEX_UNLOCK(MgMUTEXP(mg));
3142 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
3143 }
631cfb58 3144 UNLOCK_SV_LOCK_MUTEX;
4755096e 3145 return sv;
3d35f11b
GS		 3146}
3147
a863c7d1 3148/*
199100c8
MB		 3149 * Make a new perl thread structure using t as a prototype. Some of the
3150 * fields for the new thread are copied from the prototype thread, t,
3151 * so t should not be running in perl at the time this function is
3152 * called. The use by ext/Thread/Thread.xs in core perl (where t is the
3153 * thread calling new_struct_thread) clearly satisfies this constraint.
a863c7d1 3154 */
52e1cb5e 3155struct perl_thread *
864dbfa3 3156Perl_new_struct_thread(pTHX_ struct perl_thread *t)
a863c7d1 3157{
c5be433b 3158#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3159 struct perl_thread *thr;
cea2e8a9 3160#endif
a863c7d1 3161 SV *sv;
199100c8
MB		 3162 SV **svp;
3163 I32 i;
3164
79cb57f6 3165 sv = newSVpvn("", 0);
52e1cb5e
JH		 3166 SvGROW(sv, sizeof(struct perl_thread) + 1);
3167 SvCUR_set(sv, sizeof(struct perl_thread));
199100c8 3168 thr = (Thread) SvPVX(sv);
949ced2d 3169#ifdef DEBUGGING
9965345d 3170 Poison(thr, 1, struct perl_thread);
533c011a
NIS		 3171 PL_markstack = 0;
3172 PL_scopestack = 0;
3173 PL_savestack = 0;
3174 PL_retstack = 0;
3175 PL_dirty = 0;
3176 PL_localizing = 0;
949ced2d 3177 Zero(&PL_hv_fetch_ent_mh, 1, HE);
d0e9ca0c
HS		 3178 PL_efloatbuf = (char*)NULL;
3179 PL_efloatsize = 0;
949ced2d
GS		 3180#else
3181 Zero(thr, 1, struct perl_thread);
3182#endif
199100c8
MB		 3183
3184 thr->oursv = sv;
cea2e8a9 3185 init_stacks();
a863c7d1 3186
533c011a 3187 PL_curcop = &PL_compiling;
c5be433b 3188 thr->interp = t->interp;
199100c8 3189 thr->cvcache = newHV();
54b9620d 3190 thr->threadsv = newAV();
a863c7d1 3191 thr->specific = newAV();
79cb57f6 3192 thr->errsv = newSVpvn("", 0);
a863c7d1 3193 thr->flags = THRf_R_JOINABLE;
8dcd6f7b 3194 thr->thr_done = 0;
a863c7d1 3195 MUTEX_INIT(&thr->mutex);
199100c8 3196
5c831c24 3197 JMPENV_BOOTSTRAP;
533c011a 3198
6dc8a9e4 3199 PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
533c011a
NIS		 3200 PL_restartop = 0;
3201
b099ddc0 3202 PL_statname = NEWSV(66,0);
5a844595 3203 PL_errors = newSVpvn("", 0);
b099ddc0 3204 PL_maxscream = -1;
0b94c7bb
GS		 3205 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3206 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3207 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3208 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3209 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
b099ddc0
GS		 3210 PL_regindent = 0;
3211 PL_reginterp_cnt = 0;
3212 PL_lastscream = Nullsv;
3213 PL_screamfirst = 0;
3214 PL_screamnext = 0;
3215 PL_reg_start_tmp = 0;
3216 PL_reg_start_tmpl = 0;
14ed4b74 3217 PL_reg_poscache = Nullch;
b099ddc0 3218
a2efc822
SC		 3219 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
3220
b099ddc0
GS		 3221 /* parent thread's data needs to be locked while we make copy */
3222 MUTEX_LOCK(&t->mutex);
3223
14dd3ad8 3224#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 3225 PL_protect = t->Tprotect;
14dd3ad8 3226#endif
312caa8e 3227
b099ddc0
GS		 3228 PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
3229 PL_defstash = t->Tdefstash; /* XXX maybe these should */
3230 PL_curstash = t->Tcurstash; /* always be set to main? */
3231
6b88bc9c 3232 PL_tainted = t->Ttainted;
3aed30dc 3233 PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
8bfdd7d9 3234 PL_rs = newSVsv(t->Trs);
84fee439 3235 PL_last_in_gv = Nullgv;
7d3de3d5 3236 PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
84fee439
NIS		 3237 PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
3238 PL_chopset = t->Tchopset;
84fee439
NIS		 3239 PL_bodytarget = newSVsv(t->Tbodytarget);
3240 PL_toptarget = newSVsv(t->Ttoptarget);
5c831c24
GS		 3241 if (t->Tformtarget == t->Ttoptarget)
3242 PL_formtarget = PL_toptarget;
3243 else
3244 PL_formtarget = PL_bodytarget;
533c011a 3245
54b9620d
MB		 3246 /* Initialise all per-thread SVs that the template thread used */
3247 svp = AvARRAY(t->threadsv);
93965878 3248 for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
533c011a 3249 if (*svp && *svp != &PL_sv_undef) {
199100c8 3250 SV *sv = newSVsv(*svp);
54b9620d 3251 av_store(thr->threadsv, i, sv);
14befaf4 3252 sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
bf49b057 3253 DEBUG_S(PerlIO_printf(Perl_debug_log,
f1dbda3d
JH		 3254 "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
3255 (IV)i, t, thr));
199100c8 3256 }
a1d180c4 3257 }
940cb80d 3258 thr->threadsvp = AvARRAY(thr->threadsv);
199100c8 3259
533c011a
NIS		 3260 MUTEX_LOCK(&PL_threads_mutex);
3261 PL_nthreads++;
3262 thr->tid = ++PL_threadnum;
199100c8
MB		 3263 thr->next = t->next;
3264 thr->prev = t;
3265 t->next = thr;
3266 thr->next->prev = thr;
533c011a 3267 MUTEX_UNLOCK(&PL_threads_mutex);
a863c7d1 3268
b099ddc0
GS		 3269 /* done copying parent's state */
3270 MUTEX_UNLOCK(&t->mutex);
3271
a863c7d1 3272#ifdef HAVE_THREAD_INTERN
4f63d024 3273 Perl_init_thread_intern(thr);
a863c7d1 3274#endif /* HAVE_THREAD_INTERN */
a863c7d1
MB		 3275 return thr;
3276}
4d1ff10f 3277#endif /* USE_5005THREADS */
760ac839 3278
22239a37
NIS		 3279#ifdef PERL_GLOBAL_STRUCT
3280struct perl_vars *
864dbfa3 3281Perl_GetVars(pTHX)
22239a37 3282{
533c011a 3283 return &PL_Vars;
22239a37 3284}
31fb1209
NIS		 3285#endif
3286
3287char **
864dbfa3 3288Perl_get_op_names(pTHX)
31fb1209 3289{
22c35a8c 3290 return PL_op_name;
31fb1209
NIS		 3291}
3292
3293char **
864dbfa3 3294Perl_get_op_descs(pTHX)
31fb1209 3295{
22c35a8c 3296 return PL_op_desc;
31fb1209 3297}
9e6b2b00
GS		 3298
3299char *
864dbfa3 3300Perl_get_no_modify(pTHX)
9e6b2b00 3301{
22c35a8c 3302 return (char*)PL_no_modify;
9e6b2b00
GS		 3303}
3304
3305U32 *
864dbfa3 3306Perl_get_opargs(pTHX)
9e6b2b00 3307{
22c35a8c 3308 return PL_opargs;
9e6b2b00 3309}
51aa15f3 3310
0cb96387
GS		 3311PPADDR_t*
3312Perl_get_ppaddr(pTHX)
3313{
12ae5dfc 3314 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3315}
3316
a6c40364
GS		 3317#ifndef HAS_GETENV_LEN
3318char *
bf4acbe4 3319Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364
GS		 3320{
3321 char *env_trans = PerlEnv_getenv(env_elem);
3322 if (env_trans)
3323 *len = strlen(env_trans);
3324 return env_trans;
f675dbe5
CB		 3325}
3326#endif
3327
dc9e4912
GS		 3328
3329MGVTBL*
864dbfa3 3330Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912
GS		 3331{
3332 MGVTBL* result = Null(MGVTBL*);
3333
3334 switch(vtbl_id) {
3335 case want_vtbl_sv:
3336 result = &PL_vtbl_sv;
3337 break;
3338 case want_vtbl_env:
3339 result = &PL_vtbl_env;
3340 break;
3341 case want_vtbl_envelem:
3342 result = &PL_vtbl_envelem;
3343 break;
3344 case want_vtbl_sig:
3345 result = &PL_vtbl_sig;
3346 break;
3347 case want_vtbl_sigelem:
3348 result = &PL_vtbl_sigelem;
3349 break;
3350 case want_vtbl_pack:
3351 result = &PL_vtbl_pack;
3352 break;
3353 case want_vtbl_packelem:
3354 result = &PL_vtbl_packelem;
3355 break;
3356 case want_vtbl_dbline:
3357 result = &PL_vtbl_dbline;
3358 break;
3359 case want_vtbl_isa:
3360 result = &PL_vtbl_isa;
3361 break;
3362 case want_vtbl_isaelem:
3363 result = &PL_vtbl_isaelem;
3364 break;
3365 case want_vtbl_arylen:
3366 result = &PL_vtbl_arylen;
3367 break;
3368 case want_vtbl_glob:
3369 result = &PL_vtbl_glob;
3370 break;
3371 case want_vtbl_mglob:
3372 result = &PL_vtbl_mglob;
3373 break;
3374 case want_vtbl_nkeys:
3375 result = &PL_vtbl_nkeys;
3376 break;
3377 case want_vtbl_taint:
3378 result = &PL_vtbl_taint;
3379 break;
3380 case want_vtbl_substr:
3381 result = &PL_vtbl_substr;
3382 break;
3383 case want_vtbl_vec:
3384 result = &PL_vtbl_vec;
3385 break;
3386 case want_vtbl_pos:
3387 result = &PL_vtbl_pos;
3388 break;
3389 case want_vtbl_bm:
3390 result = &PL_vtbl_bm;
3391 break;
3392 case want_vtbl_fm:
3393 result = &PL_vtbl_fm;
3394 break;
3395 case want_vtbl_uvar:
3396 result = &PL_vtbl_uvar;
3397 break;
4d1ff10f 3398#ifdef USE_5005THREADS
dc9e4912
GS		 3399 case want_vtbl_mutex:
3400 result = &PL_vtbl_mutex;
3401 break;
3402#endif
3403 case want_vtbl_defelem:
3404 result = &PL_vtbl_defelem;
3405 break;
3406 case want_vtbl_regexp:
3407 result = &PL_vtbl_regexp;
3408 break;
3409 case want_vtbl_regdata:
3410 result = &PL_vtbl_regdata;
3411 break;
3412 case want_vtbl_regdatum:
3413 result = &PL_vtbl_regdatum;
3414 break;
3c90161d 3415#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3416 case want_vtbl_collxfrm:
3417 result = &PL_vtbl_collxfrm;
3418 break;
3c90161d 3419#endif
dc9e4912
GS		 3420 case want_vtbl_amagic:
3421 result = &PL_vtbl_amagic;
3422 break;
3423 case want_vtbl_amagicelem:
3424 result = &PL_vtbl_amagicelem;
3425 break;
810b8aa5
GS		 3426 case want_vtbl_backref:
3427 result = &PL_vtbl_backref;
3428 break;
dc9e4912
GS		 3429 }
3430 return result;
3431}
3432
767df6a1 3433I32
864dbfa3 3434Perl_my_fflush_all(pTHX)
767df6a1 3435{
8fbdfb7c 3436#if defined(FFLUSH_NULL)
ce720889 3437 return PerlIO_flush(NULL);
767df6a1 3438#else
8fbdfb7c 3439# if defined(HAS__FWALK)
f13a2bc0 3440 extern int fflush(FILE *);
74cac757
JH		 3441 /* undocumented, unprototyped, but very useful BSDism */
3442 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3443 _fwalk(&fflush);
74cac757 3444 return 0;
8fa7f367 3445# else
8fbdfb7c 3446# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3447 long open_max = -1;
8fbdfb7c 3448# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3449 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3450# else
8fa7f367 3451# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3452 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3453# else
3454# ifdef FOPEN_MAX
74cac757 3455 open_max = FOPEN_MAX;
8fa7f367
JH		 3456# else
3457# ifdef OPEN_MAX
74cac757 3458 open_max = OPEN_MAX;
8fa7f367
JH		 3459# else
3460# ifdef _NFILE
d2201af2 3461 open_max = _NFILE;
8fa7f367
JH		 3462# endif
3463# endif
74cac757 3464# endif
767df6a1
JH		 3465# endif
3466# endif
767df6a1
JH		 3467 if (open_max > 0) {
3468 long i;
3469 for (i = 0; i < open_max; i++)
d2201af2
AD		 3470 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3471 STDIO_STREAM_ARRAY[i]._file < open_max &&
3472 STDIO_STREAM_ARRAY[i]._flag)
3473 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3474 return 0;
3475 }
8fbdfb7c 3476# endif
767df6a1
JH		 3477 SETERRNO(EBADF,RMS$_IFI);
3478 return EOF;
74cac757 3479# endif
767df6a1
JH		 3480#endif
3481}
097ee67d 3482
69282e91 3483void
bc37a18f
RG		 3484Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
3485{
bc37a18f 3486 char *func =
66fc2fa5
JH		 3487 op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3488 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
bc37a18f
RG		 3489 PL_op_desc[op];
3490 char *pars = OP_IS_FILETEST(op) ? "" : "()";
3aed30dc
HS		 3491 char *type = OP_IS_SOCKET(op)
3492 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
3493 ? "socket" : "filehandle";
9c0fcd4f 3494 char *name = NULL;
bc37a18f 3495
66fc2fa5 3496 if (gv && isGV(gv)) {
f62cb720 3497 name = GvENAME(gv);
66fc2fa5
JH		 3498 }
3499
4c80c0b2 3500 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc
HS		 3501 if (ckWARN(WARN_IO)) {
3502 if (name && *name)
3503 Perl_warner(aTHX_ packWARN(WARN_IO),
3504 "Filehandle %s opened only for %sput",
3505 name, (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3506 else
3507 Perl_warner(aTHX_ packWARN(WARN_IO),
3508 "Filehandle opened only for %sput",
3509 (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
3510 }
2dd78f96
JH		 3511 }
3512 else {
3aed30dc
HS		 3513 char *vile;
3514 I32 warn_type;
3515
3516 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3517 vile = "closed";
3518 warn_type = WARN_CLOSED;
3519 }
3520 else {
3521 vile = "unopened";
3522 warn_type = WARN_UNOPENED;
3523 }
3524
3525 if (ckWARN(warn_type)) {
3526 if (name && *name) {
3527 Perl_warner(aTHX_ packWARN(warn_type),
3528 "%s%s on %s %s %s", func, pars, vile, type, name);
3529 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3530 Perl_warner(
3531 aTHX_ packWARN(warn_type),
3532 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3533 func, pars, name
3534 );
3535 }
3536 else {
3537 Perl_warner(aTHX_ packWARN(warn_type),
3538 "%s%s on %s %s", func, pars, vile, type);
3539 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3540 Perl_warner(
3541 aTHX_ packWARN(warn_type),
3542 "\t(Are you trying to call %s%s on dirhandle?)\n",
3543 func, pars
3544 );
3545 }
3546 }
bc37a18f 3547 }
69282e91 3548}
a926ef6b
JH		 3549
3550#ifdef EBCDIC
cbebf344
JH		 3551/* in ASCII order, not that it matters */
3552static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3553
a926ef6b
JH		 3554int
3555Perl_ebcdic_control(pTHX_ int ch)
3556{
3aed30dc
HS		 3557 if (ch > 'a') {
3558 char *ctlp;
3559
3560 if (islower(ch))
3561 ch = toupper(ch);
3562
3563 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3564 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3565 }
3aed30dc
HS		 3566
3567 if (ctlp == controllablechars)
3568 return('\177'); /* DEL */
3569 else
3570 return((unsigned char)(ctlp - controllablechars - 1));
3571 } else { /* Want uncontrol */
3572 if (ch == '\177' || ch == -1)
3573 return('?');
3574 else if (ch == '\157')
3575 return('\177');
3576 else if (ch == '\174')
3577 return('\000');
3578 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3579 return('\036');
3580 else if (ch == '\155')
3581 return('\037');
3582 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3583 return(controllablechars[ch+1]);
3584 else
3585 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3586 }
a926ef6b
JH		 3587}
3588#endif
e72cf795 3589
f6adc668 3590/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3591 * system to give us a reasonable struct to copy. This fix means that
3592 * strftime uses the tm_zone and tm_gmtoff values returned by
3593 * localtime(time()). That should give the desired result most of the
3594 * time. But probably not always!
3595 *
f6adc668
JH		 3596 * This does not address tzname aspects of NETaa14816.
3597 *
e72cf795 3598 */
f6adc668 3599
e72cf795
JH		 3600#ifdef HAS_GNULIBC
3601# ifndef STRUCT_TM_HASZONE
3602# define STRUCT_TM_HASZONE
3603# endif
3604#endif
3605
f6adc668
JH		 3606#ifdef STRUCT_TM_HASZONE /* Backward compat */
3607# ifndef HAS_TM_TM_ZONE
3608# define HAS_TM_TM_ZONE
3609# endif
3610#endif
3611
e72cf795 3612void
f1208910 3613Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3614{
f6adc668 3615#ifdef HAS_TM_TM_ZONE
e72cf795
JH		 3616 Time_t now;
3617 (void)time(&now);
3618 Copy(localtime(&now), ptm, 1, struct tm);
3619#endif
3620}
3621
3622/*
3623 * mini_mktime - normalise struct tm values without the localtime()
3624 * semantics (and overhead) of mktime().
3625 */
3626void
f1208910 3627Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3628{
3629 int yearday;
3630 int secs;
3631 int month, mday, year, jday;
3632 int odd_cent, odd_year;
3633
3634#define DAYS_PER_YEAR 365
3635#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3636#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3637#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3638#define SECS_PER_HOUR (60*60)
3639#define SECS_PER_DAY (24*SECS_PER_HOUR)
3640/* parentheses deliberately absent on these two, otherwise they don't work */
3641#define MONTH_TO_DAYS 153/5
3642#define DAYS_TO_MONTH 5/153
3643/* offset to bias by March (month 4) 1st between month/mday & year finding */
3644#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3645/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3646#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3647
3648/*
3649 * Year/day algorithm notes:
3650 *
3651 * With a suitable offset for numeric value of the month, one can find
3652 * an offset into the year by considering months to have 30.6 (153/5) days,
3653 * using integer arithmetic (i.e., with truncation). To avoid too much
3654 * messing about with leap days, we consider January and February to be
3655 * the 13th and 14th month of the previous year. After that transformation,
3656 * we need the month index we use to be high by 1 from 'normal human' usage,
3657 * so the month index values we use run from 4 through 15.
3658 *
3659 * Given that, and the rules for the Gregorian calendar (leap years are those
3660 * divisible by 4 unless also divisible by 100, when they must be divisible
3661 * by 400 instead), we can simply calculate the number of days since some
3662 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3663 * the days we derive from our month index, and adding in the day of the
3664 * month. The value used here is not adjusted for the actual origin which
3665 * it normally would use (1 January A.D. 1), since we're not exposing it.
3666 * We're only building the value so we can turn around and get the
3667 * normalised values for the year, month, day-of-month, and day-of-year.
3668 *
3669 * For going backward, we need to bias the value we're using so that we find
3670 * the right year value. (Basically, we don't want the contribution of
3671 * March 1st to the number to apply while deriving the year). Having done
3672 * that, we 'count up' the contribution to the year number by accounting for
3673 * full quadracenturies (400-year periods) with their extra leap days, plus
3674 * the contribution from full centuries (to avoid counting in the lost leap
3675 * days), plus the contribution from full quad-years (to count in the normal
3676 * leap days), plus the leftover contribution from any non-leap years.
3677 * At this point, if we were working with an actual leap day, we'll have 0
3678 * days left over. This is also true for March 1st, however. So, we have
3679 * to special-case that result, and (earlier) keep track of the 'odd'
3680 * century and year contributions. If we got 4 extra centuries in a qcent,
3681 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3682 * Otherwise, we add back in the earlier bias we removed (the 123 from
3683 * figuring in March 1st), find the month index (integer division by 30.6),
3684 * and the remainder is the day-of-month. We then have to convert back to
3685 * 'real' months (including fixing January and February from being 14/15 in
3686 * the previous year to being in the proper year). After that, to get
3687 * tm_yday, we work with the normalised year and get a new yearday value for
3688 * January 1st, which we subtract from the yearday value we had earlier,
3689 * representing the date we've re-built. This is done from January 1
3690 * because tm_yday is 0-origin.
3691 *
3692 * Since POSIX time routines are only guaranteed to work for times since the
3693 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3694 * applies Gregorian calendar rules even to dates before the 16th century
3695 * doesn't bother me. Besides, you'd need cultural context for a given
3696 * date to know whether it was Julian or Gregorian calendar, and that's
3697 * outside the scope for this routine. Since we convert back based on the
3698 * same rules we used to build the yearday, you'll only get strange results
3699 * for input which needed normalising, or for the 'odd' century years which
3700 * were leap years in the Julian calander but not in the Gregorian one.
3701 * I can live with that.
3702 *
3703 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3704 * that's still outside the scope for POSIX time manipulation, so I don't
3705 * care.
3706 */
3707
3708 year = 1900 + ptm->tm_year;
3709 month = ptm->tm_mon;
3710 mday = ptm->tm_mday;
3711 /* allow given yday with no month & mday to dominate the result */
3712 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3713 month = 0;
3714 mday = 0;
3715 jday = 1 + ptm->tm_yday;
3716 }
3717 else {
3718 jday = 0;
3719 }
3720 if (month >= 2)
3721 month+=2;
3722 else
3723 month+=14, year--;
3724 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3725 yearday += month*MONTH_TO_DAYS + mday + jday;
3726 /*
3727 * Note that we don't know when leap-seconds were or will be,
3728 * so we have to trust the user if we get something which looks
3729 * like a sensible leap-second. Wild values for seconds will
3730 * be rationalised, however.
3731 */
3732 if ((unsigned) ptm->tm_sec <= 60) {
3733 secs = 0;
3734 }
3735 else {
3736 secs = ptm->tm_sec;
3737 ptm->tm_sec = 0;
3738 }
3739 secs += 60 * ptm->tm_min;
3740 secs += SECS_PER_HOUR * ptm->tm_hour;
3741 if (secs < 0) {
3742 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3743 /* got negative remainder, but need positive time */
3744 /* back off an extra day to compensate */
3745 yearday += (secs/SECS_PER_DAY)-1;
3746 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3747 }
3748 else {
3749 yearday += (secs/SECS_PER_DAY);
3750 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3751 }
3752 }
3753 else if (secs >= SECS_PER_DAY) {
3754 yearday += (secs/SECS_PER_DAY);
3755 secs %= SECS_PER_DAY;
3756 }
3757 ptm->tm_hour = secs/SECS_PER_HOUR;
3758 secs %= SECS_PER_HOUR;
3759 ptm->tm_min = secs/60;
3760 secs %= 60;
3761 ptm->tm_sec += secs;
3762 /* done with time of day effects */
3763 /*
3764 * The algorithm for yearday has (so far) left it high by 428.
3765 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3766 * bias it by 123 while trying to figure out what year it
3767 * really represents. Even with this tweak, the reverse
3768 * translation fails for years before A.D. 0001.
3769 * It would still fail for Feb 29, but we catch that one below.
3770 */
3771 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3772 yearday -= YEAR_ADJUST;
3773 year = (yearday / DAYS_PER_QCENT) * 400;
3774 yearday %= DAYS_PER_QCENT;
3775 odd_cent = yearday / DAYS_PER_CENT;
3776 year += odd_cent * 100;
3777 yearday %= DAYS_PER_CENT;
3778 year += (yearday / DAYS_PER_QYEAR) * 4;
3779 yearday %= DAYS_PER_QYEAR;
3780 odd_year = yearday / DAYS_PER_YEAR;
3781 year += odd_year;
3782 yearday %= DAYS_PER_YEAR;
3783 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3784 month = 1;
3785 yearday = 29;
3786 }
3787 else {
3788 yearday += YEAR_ADJUST; /* recover March 1st crock */
3789 month = yearday*DAYS_TO_MONTH;
3790 yearday -= month*MONTH_TO_DAYS;
3791 /* recover other leap-year adjustment */
3792 if (month > 13) {
3793 month-=14;
3794 year++;
3795 }
3796 else {
3797 month-=2;
3798 }
3799 }
3800 ptm->tm_year = year - 1900;
3801 if (yearday) {
3802 ptm->tm_mday = yearday;
3803 ptm->tm_mon = month;
3804 }
3805 else {
3806 ptm->tm_mday = 31;
3807 ptm->tm_mon = month - 1;
3808 }
3809 /* re-build yearday based on Jan 1 to get tm_yday */
3810 year--;
3811 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3812 yearday += 14*MONTH_TO_DAYS + 1;
3813 ptm->tm_yday = jday - yearday;
3814 /* fix tm_wday if not overridden by caller */
3815 if ((unsigned)ptm->tm_wday > 6)
3816 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3817}
b3c85772
JH		 3818
3819char *
f1208910 3820Perl_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		 3821{
3822#ifdef HAS_STRFTIME
3823 char *buf;
3824 int buflen;
3825 struct tm mytm;
3826 int len;
3827
3828 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3829 mytm.tm_sec = sec;
3830 mytm.tm_min = min;
3831 mytm.tm_hour = hour;
3832 mytm.tm_mday = mday;
3833 mytm.tm_mon = mon;
3834 mytm.tm_year = year;
3835 mytm.tm_wday = wday;
3836 mytm.tm_yday = yday;
3837 mytm.tm_isdst = isdst;
3838 mini_mktime(&mytm);
3839 buflen = 64;
3840 New(0, buf, buflen, char);
3841 len = strftime(buf, buflen, fmt, &mytm);
3842 /*
877f6a72 3843 ** The following is needed to handle to the situation where
b3c85772
JH		 3844 ** tmpbuf overflows. Basically we want to allocate a buffer
3845 ** and try repeatedly. The reason why it is so complicated
3846 ** is that getting a return value of 0 from strftime can indicate
3847 ** one of the following:
3848 ** 1. buffer overflowed,
3849 ** 2. illegal conversion specifier, or
3850 ** 3. the format string specifies nothing to be returned(not
3851 ** an error). This could be because format is an empty string
3852 ** or it specifies %p that yields an empty string in some locale.
3853 ** If there is a better way to make it portable, go ahead by
3854 ** all means.
3855 */
3856 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3857 return buf;
3858 else {
3859 /* Possibly buf overflowed - try again with a bigger buf */
3860 int fmtlen = strlen(fmt);
3861 int bufsize = fmtlen + buflen;
877f6a72 3862
b3c85772
JH		 3863 New(0, buf, bufsize, char);
3864 while (buf) {
3865 buflen = strftime(buf, bufsize, fmt, &mytm);
3866 if (buflen > 0 && buflen < bufsize)
3867 break;
3868 /* heuristic to prevent out-of-memory errors */
3869 if (bufsize > 100*fmtlen) {
3870 Safefree(buf);
3871 buf = NULL;
3872 break;
3873 }
3874 bufsize *= 2;
3875 Renew(buf, bufsize, char);
3876 }
3877 return buf;
3878 }
3879#else
3880 Perl_croak(aTHX_ "panic: no strftime");
3881#endif
3882}
3883
877f6a72
NIS		 3884
3885#define SV_CWD_RETURN_UNDEF \
3886sv_setsv(sv, &PL_sv_undef); \
3887return FALSE
3888
3889#define SV_CWD_ISDOT(dp) \
3890 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3891 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3892
3893/*
ccfc67b7
JH		 3894=head1 Miscellaneous Functions
3895
89423764 3896=for apidoc getcwd_sv
877f6a72
NIS		 3897
3898Fill the sv with current working directory
3899
3900=cut
3901*/
3902
3903/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3904 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3905 * getcwd(3) if available
3906 * Comments from the orignal:
3907 * This is a faster version of getcwd. It's also more dangerous
3908 * because you might chdir out of a directory that you can't chdir
3909 * back into. */
3910
877f6a72 3911int
89423764 3912Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3913{
3914#ifndef PERL_MICRO
3915
ea715489
JH		 3916#ifndef INCOMPLETE_TAINTS
3917 SvTAINTED_on(sv);
3918#endif
3919
8f95b30d
JH		 3920#ifdef HAS_GETCWD
3921 {
60e110a8
DM		 3922 char buf[MAXPATHLEN];
3923
3aed30dc 3924 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3925 * size from the heap if they are given a NULL buffer pointer.
3926 * The problem is that this behaviour is not portable. */
3aed30dc
HS		 3927 if (getcwd(buf, sizeof(buf) - 1)) {
3928 STRLEN len = strlen(buf);
3929 sv_setpvn(sv, buf, len);
3930 return TRUE;
3931 }
3932 else {
3933 sv_setsv(sv, &PL_sv_undef);
3934 return FALSE;
3935 }
8f95b30d
JH		 3936 }
3937
3938#else
3939
c623ac67 3940 Stat_t statbuf;
877f6a72
NIS		 3941 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
3942 int namelen, pathlen=0;
3943 DIR *dir;
3944 Direntry_t *dp;
877f6a72
NIS		 3945
3946 (void)SvUPGRADE(sv, SVt_PV);
3947
877f6a72 3948 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3949 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3950 }
3951
3952 orig_cdev = statbuf.st_dev;
3953 orig_cino = statbuf.st_ino;
3954 cdev = orig_cdev;
3955 cino = orig_cino;
3956
3957 for (;;) {
3aed30dc
HS		 3958 odev = cdev;
3959 oino = cino;
3960
3961 if (PerlDir_chdir("..") < 0) {
3962 SV_CWD_RETURN_UNDEF;
3963 }
3964 if (PerlLIO_stat(".", &statbuf) < 0) {
3965 SV_CWD_RETURN_UNDEF;
3966 }
3967
3968 cdev = statbuf.st_dev;
3969 cino = statbuf.st_ino;
3970
3971 if (odev == cdev && oino == cino) {
3972 break;
3973 }
3974 if (!(dir = PerlDir_open("."))) {
3975 SV_CWD_RETURN_UNDEF;
3976 }
3977
3978 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3979#ifdef DIRNAMLEN
3aed30dc 3980 namelen = dp->d_namlen;
877f6a72 3981#else
3aed30dc 3982 namelen = strlen(dp->d_name);
877f6a72 3983#endif
3aed30dc
HS		 3984 /* skip . and .. */
3985 if (SV_CWD_ISDOT(dp)) {
3986 continue;
3987 }
3988
3989 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
3990 SV_CWD_RETURN_UNDEF;
3991 }
3992
3993 tdev = statbuf.st_dev;
3994 tino = statbuf.st_ino;
3995 if (tino == oino && tdev == odev) {
3996 break;
3997 }
cb5953d6
JH		 3998 }
3999
3aed30dc
HS		 4000 if (!dp) {
4001 SV_CWD_RETURN_UNDEF;
4002 }
4003
4004 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4005 SV_CWD_RETURN_UNDEF;
4006 }
877f6a72 4007
3aed30dc
HS		 4008 SvGROW(sv, pathlen + namelen + 1);
4009
4010 if (pathlen) {
4011 /* shift down */
4012 Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
4013 }
877f6a72 4014
3aed30dc
HS		 4015 /* prepend current directory to the front */
4016 *SvPVX(sv) = '/';
4017 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4018 pathlen += (namelen + 1);
877f6a72
NIS		 4019
4020#ifdef VOID_CLOSEDIR
3aed30dc 4021 PerlDir_close(dir);
877f6a72 4022#else
3aed30dc
HS		 4023 if (PerlDir_close(dir) < 0) {
4024 SV_CWD_RETURN_UNDEF;
4025 }
877f6a72
NIS		 4026#endif
4027 }
4028
60e110a8 4029 if (pathlen) {
3aed30dc
HS		 4030 SvCUR_set(sv, pathlen);
4031 *SvEND(sv) = '\0';
4032 SvPOK_only(sv);
877f6a72 4033
2a45baea 4034 if (PerlDir_chdir(SvPVX(sv)) < 0) {
3aed30dc
HS		 4035 SV_CWD_RETURN_UNDEF;
4036 }
877f6a72
NIS		 4037 }
4038 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 4039 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4040 }
4041
4042 cdev = statbuf.st_dev;
4043 cino = statbuf.st_ino;
4044
4045 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 4046 Perl_croak(aTHX_ "Unstable directory path, "
4047 "current directory changed unexpectedly");
877f6a72 4048 }
877f6a72
NIS		 4049
4050 return TRUE;
793b8d8e
JH		 4051#endif
4052
877f6a72
NIS		 4053#else
4054 return FALSE;
4055#endif
4056}
4057
f4758303 4058/*
ccfc67b7
JH		 4059=head1 SV Manipulation Functions
4060
b0f01acb 4061=for apidoc scan_vstring
f4758303
JP		 4062
4063Returns a pointer to the next character after the parsed
4064vstring, as well as updating the passed in sv.
7207e29d 4065
cddd4526 4066Function must be called like
7207e29d 4067
b0f01acb
JP		 4068 sv = NEWSV(92,5);
4069 s = scan_vstring(s,sv);
f4758303 4070
b0f01acb
JP		 4071The sv should already be large enough to store the vstring
4072passed in, for performance reasons.
f4758303
JP		 4073
4074=cut
4075*/
4076
4077char *
b0f01acb 4078Perl_scan_vstring(pTHX_ char *s, SV *sv)
f4758303
JP		 4079{
4080 char *pos = s;
439cb1c4 4081 char *start = s;
f4758303
JP		 4082 if (*pos == 'v') pos++; /* get past 'v' */
4083 while (isDIGIT(*pos) || *pos == '_')
4084 pos++;
4085 if (!isALPHA(*pos)) {
4086 UV rev;
4087 U8 tmpbuf[UTF8_MAXLEN+1];
4088 U8 *tmpend;
4089
4090 if (*s == 'v') s++; /* get past 'v' */
4091
4092 sv_setpvn(sv, "", 0);
4093
4094 for (;;) {
4095 rev = 0;
4096 {
92f0c265
JP		 4097 /* this is atoi() that tolerates underscores */
4098 char *end = pos;
4099 UV mult = 1;
4100 while (--end >= s) {
4101 UV orev;
4102 if (*end == '_')
4103 continue;
4104 orev = rev;
4105 rev += (*end - '0') * mult;
4106 mult *= 10;
4107 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
4108 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4109 "Integer overflow in decimal number");
4110 }
f4758303 4111 }
979699d9
JH		 4112#ifdef EBCDIC
4113 if (rev > 0x7FFFFFFF)
4114 Perl_croak(aTHX "In EBCDIC the v-string components cannot exceed 2147483647");
4115#endif
f4758303
JP		 4116 /* Append native character for the rev point */
4117 tmpend = uvchr_to_utf8(tmpbuf, rev);
4118 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
4119 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
979699d9 4120 SvUTF8_on(sv);
92f0c265 4121 if (*pos == '.' && isDIGIT(pos[1]))
979699d9 4122 s = ++pos;
f4758303 4123 else {
979699d9
JH		 4124 s = pos;
4125 break;
f4758303 4126 }
92f0c265 4127 while (isDIGIT(*pos) || *pos == '_')
979699d9 4128 pos++;
f4758303
JP		 4129 }
4130 SvPOK_on(sv);
439cb1c4
JP		 4131 sv_magicext(sv,NULL,PERL_MAGIC_vstring,NULL,(const char*)start, pos-start);
4132 SvRMAGICAL_on(sv);
f4758303
JP		 4133 }
4134 return s;
4135}
4136
b0f01acb
JP		 4137
4138/*
4139=for apidoc scan_version
4140
4141Returns a pointer to the next character after the parsed
4142version string, as well as upgrading the passed in SV to
4143an RV.
4144
4145Function must be called with an already existing SV like
4146
4147 sv = NEWSV(92,0);
4148 s = scan_version(s,sv);
4149
4150Performs some preprocessing to the string to ensure that
4151it has the correct characteristics of a version. Flags the
4152object if it contains an underscore (which denotes this
4153is a beta version).
4154
4155=cut
4156*/
4157
4158char *
4159Perl_scan_version(pTHX_ char *version, SV *rv)
4160{
be2ebcad 4161 char* d;
b0f01acb 4162 int beta = 0;
be2ebcad 4163 SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
b0f01acb
JP		 4164 d = version;
4165 if (*d == 'v')
4166 d++;
4167 if (isDIGIT(*d)) {
be2ebcad 4168 while (isDIGIT(*d) || *d == '.' || *d == '\0')
b0f01acb 4169 d++;
be2ebcad 4170 if (*d == '_') {
b0f01acb 4171 *d = '.';
be2ebcad 4172 if (*(d+1) == '0' && *(d+2) != '0') { /* perl-style version */
b0f01acb
JP		 4173 *(d+1) = *(d+2);
4174 *(d+2) = '0';
be2ebcad
JP		 4175 if (ckWARN(WARN_PORTABLE))
4176 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
4177 "perl-style version not portable");
b0f01acb
JP		 4178 }
4179 else {
4180 beta = -1;
4181 }
4182 }
be2ebcad
JP		 4183 while (isDIGIT(*d) || *d == '.' || *d == '\0')
4184 d++;
4185 if (*d == '_')
4186 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
b0f01acb 4187 }
be2ebcad 4188 version = scan_vstring(version, sv); /* store the v-string in the object */
b0f01acb
JP		 4189 SvIVX(sv) = beta;
4190 return version;
4191}
4192
4193/*
4194=for apidoc new_version
4195
4196Returns a new version object based on the passed in SV:
4197
4198 SV *sv = new_version(SV *ver);
4199
4200Does not alter the passed in ver SV. See "upg_version" if you
4201want to upgrade the SV.
4202
4203=cut
4204*/
4205
4206SV *
4207Perl_new_version(pTHX_ SV *ver)
4208{
4209 SV *rv = NEWSV(92,5);
4210 char *version;
4211
4212 if ( SvMAGICAL(ver) ) { /* already a v-string */
4213 MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
4214 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
4215 }
4216 else {
4217 version = (char *)SvPV_nolen(ver);
4218 }
4219 version = scan_version(version,rv);
4220 return rv;
4221}
4222
4223/*
4224=for apidoc upg_version
4225
4226In-place upgrade of the supplied SV to a version object.
4227
4228 SV *sv = upg_version(SV *sv);
4229
4230Returns a pointer to the upgraded SV.
4231
4232=cut
4233*/
4234
4235SV *
4236Perl_upg_version(pTHX_ SV *sv)
4237{
4238 char *version = (char *)SvPV_nolen(sv_mortalcopy(sv));
4239 bool utf8 = SvUTF8(sv);
4240 if ( SvVOK(sv) ) { /* already a v-string */
4241 SV * ver = newSVrv(sv, "version");
4242 sv_setpv(ver,version);
4243 if ( utf8 )
4244 SvUTF8_on(ver);
4245 }
4246 else {
4247 version = scan_version(version,sv);
4248 }
4249 return sv;
4250}
4251
4252
4253/*
4254=for apidoc vnumify
4255
4256Accepts a version (or vstring) object and returns the
4257normalized floating point representation. Call like:
4258
4259 sv = vnumify(sv,SvRV(rv));
4260
4261NOTE: no checking is done to see if the object is of the
4262correct type (for speed).
4263
4264=cut
4265*/
4266
4267SV *
ba329e04 4268Perl_vnumify(pTHX_ SV *sv, SV *vs)
b0f01acb
JP		 4269{
4270 U8* pv = (U8*)SvPVX(vs);
4271 STRLEN len = SvCUR(vs);
4272 STRLEN retlen;
4273 UV digit = utf8_to_uvchr(pv,&retlen);
ba329e04 4274 Perl_sv_setpvf(aTHX_ sv,"%"UVf".",digit);
b0f01acb
JP		 4275 for (pv += retlen, len -= retlen;
4276 len > 0;
4277 pv += retlen, len -= retlen)
4278 {
4279 digit = utf8_to_uvchr(pv,&retlen);
ba329e04 4280 Perl_sv_catpvf(aTHX_ sv,"%03"UVf,digit);
b0f01acb
JP		 4281 }
4282 return sv;
4283}
4284
4285/*
4286=for apidoc vstringify
4287
4288Accepts a version (or vstring) object and returns the
4289normalized representation. Call like:
4290
4291 sv = vstringify(sv,SvRV(rv));
4292
4293NOTE: no checking is done to see if the object is of the
4294correct type (for speed).
4295
4296=cut
4297*/
4298
4299SV *
ba329e04 4300Perl_vstringify(pTHX_ SV *sv, SV *vs)
b0f01acb
JP		 4301{
4302 U8* pv = (U8*)SvPVX(vs);
4303 STRLEN len = SvCUR(vs);
4304 STRLEN retlen;
4305 UV digit = utf8_to_uvchr(pv,&retlen);
ba329e04 4306 Perl_sv_setpvf(aTHX_ sv,"%"UVf,digit);
b0f01acb
JP		 4307 for (pv += retlen, len -= retlen;
4308 len > 0;
4309 pv += retlen, len -= retlen)
4310 {
4311 digit = utf8_to_uvchr(pv,&retlen);
be2ebcad
JP		 4312 Perl_sv_catpvf(aTHX_ sv,".%"UVf,digit);
4313 }
4314 if (SvIVX(vs) < 0) {
4315 char* pv = SvPVX(sv);
4316 for (pv += SvCUR(sv); *pv != '.'; pv--)
4317 ;
4318 *pv = '_';
b0f01acb 4319 }
b0f01acb
JP		 4320 return sv;
4321}
4322
c95c94b1 4323#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4324# define EMULATE_SOCKETPAIR_UDP
4325#endif
4326
4327#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4328static int
4329S_socketpair_udp (int fd[2]) {
e10bb1e9 4330 dTHX;
02fc2eee
NC		 4331 /* Fake a datagram socketpair using UDP to localhost. */
4332 int sockets[2] = {-1, -1};
4333 struct sockaddr_in addresses[2];
4334 int i;
3aed30dc 4335 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4336 unsigned short port;
02fc2eee
NC		 4337 int got;
4338
3aed30dc 4339 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4340 i = 1;
4341 do {
3aed30dc
HS		 4342 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4343 if (sockets[i] == -1)
4344 goto tidy_up_and_fail;
4345
4346 addresses[i].sin_family = AF_INET;
4347 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4348 addresses[i].sin_port = 0; /* kernel choses port. */
4349 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4350 sizeof(struct sockaddr_in)) == -1)
4351 goto tidy_up_and_fail;
02fc2eee
NC		 4352 } while (i--);
4353
4354 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4355 for each connect the other socket to it. */
4356 i = 1;
4357 do {
3aed30dc
HS		 4358 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4359 &size) == -1)
4360 goto tidy_up_and_fail;
4361 if (size != sizeof(struct sockaddr_in))
4362 goto abort_tidy_up_and_fail;
4363 /* !1 is 0, !0 is 1 */
4364 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4365 sizeof(struct sockaddr_in)) == -1)
4366 goto tidy_up_and_fail;
02fc2eee
NC		 4367 } while (i--);
4368
4369 /* Now we have 2 sockets connected to each other. I don't trust some other
4370 process not to have already sent a packet to us (by random) so send
4371 a packet from each to the other. */
4372 i = 1;
4373 do {
3aed30dc
HS		 4374 /* I'm going to send my own port number. As a short.
4375 (Who knows if someone somewhere has sin_port as a bitfield and needs
4376 this routine. (I'm assuming crays have socketpair)) */
4377 port = addresses[i].sin_port;
4378 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4379 if (got != sizeof(port)) {
4380 if (got == -1)
4381 goto tidy_up_and_fail;
4382 goto abort_tidy_up_and_fail;
4383 }
02fc2eee
NC		 4384 } while (i--);
4385
4386 /* Packets sent. I don't trust them to have arrived though.
4387 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4388 connect to localhost will use a second kernel thread. In 2.6 the
4389 first thread running the connect() returns before the second completes,
4390 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4391 returns 0. Poor programs have tripped up. One poor program's authors'
4392 had a 50-1 reverse stock split. Not sure how connected these were.)
4393 So I don't trust someone not to have an unpredictable UDP stack.
4394 */
4395
4396 {
3aed30dc
HS		 4397 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4398 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4399 fd_set rset;
4400
4401 FD_ZERO(&rset);
4402 FD_SET(sockets[0], &rset);
4403 FD_SET(sockets[1], &rset);
4404
4405 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4406 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4407 || !FD_ISSET(sockets[1], &rset)) {
4408 /* I hope this is portable and appropriate. */
4409 if (got == -1)
4410 goto tidy_up_and_fail;
4411 goto abort_tidy_up_and_fail;
4412 }
02fc2eee 4413 }
f4758303 4414
02fc2eee
NC		 4415 /* And the paranoia department even now doesn't trust it to have arrive
4416 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4417 {
3aed30dc
HS		 4418 struct sockaddr_in readfrom;
4419 unsigned short buffer[2];
02fc2eee 4420
3aed30dc
HS		 4421 i = 1;
4422 do {
02fc2eee 4423#ifdef MSG_DONTWAIT
3aed30dc
HS		 4424 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4425 sizeof(buffer), MSG_DONTWAIT,
4426 (struct sockaddr *) &readfrom, &size);
02fc2eee 4427#else
3aed30dc
HS		 4428 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4429 sizeof(buffer), 0,
4430 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4431#endif
02fc2eee 4432
3aed30dc
HS		 4433 if (got == -1)
4434 goto tidy_up_and_fail;
4435 if (got != sizeof(port)
4436 || size != sizeof(struct sockaddr_in)
4437 /* Check other socket sent us its port. */
4438 || buffer[0] != (unsigned short) addresses[!i].sin_port
4439 /* Check kernel says we got the datagram from that socket */
4440 || readfrom.sin_family != addresses[!i].sin_family
4441 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4442 || readfrom.sin_port != addresses[!i].sin_port)
4443 goto abort_tidy_up_and_fail;
4444 } while (i--);
02fc2eee
NC		 4445 }
4446 /* My caller (my_socketpair) has validated that this is non-NULL */
4447 fd[0] = sockets[0];
4448 fd[1] = sockets[1];
4449 /* I hereby declare this connection open. May God bless all who cross
4450 her. */
4451 return 0;
4452
4453 abort_tidy_up_and_fail:
4454 errno = ECONNABORTED;
4455 tidy_up_and_fail:
4456 {
3aed30dc
HS		 4457 int save_errno = errno;
4458 if (sockets[0] != -1)
4459 PerlLIO_close(sockets[0]);
4460 if (sockets[1] != -1)
4461 PerlLIO_close(sockets[1]);
4462 errno = save_errno;
4463 return -1;
02fc2eee
NC		 4464 }
4465}
85ca448a 4466#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4467
b5ac89c3 4468#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4469int
4470Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4471 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4472 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4473 dTHX;
02fc2eee
NC		 4474 int listener = -1;
4475 int connector = -1;
4476 int acceptor = -1;
4477 struct sockaddr_in listen_addr;
4478 struct sockaddr_in connect_addr;
4479 Sock_size_t size;
4480
50458334
JH		 4481 if (protocol
4482#ifdef AF_UNIX
4483 || family != AF_UNIX
4484#endif
3aed30dc
HS		 4485 ) {
4486 errno = EAFNOSUPPORT;
4487 return -1;
02fc2eee 4488 }
2948e0bd 4489 if (!fd) {
3aed30dc
HS		 4490 errno = EINVAL;
4491 return -1;
2948e0bd 4492 }
02fc2eee 4493
2bc69dc4 4494#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4495 if (type == SOCK_DGRAM)
3aed30dc 4496 return S_socketpair_udp(fd);
2bc69dc4 4497#endif
02fc2eee 4498
3aed30dc 4499 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4500 if (listener == -1)
3aed30dc
HS		 4501 return -1;
4502 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4503 listen_addr.sin_family = AF_INET;
3aed30dc 4504 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4505 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4506 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4507 sizeof(listen_addr)) == -1)
4508 goto tidy_up_and_fail;
e10bb1e9 4509 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4510 goto tidy_up_and_fail;
02fc2eee 4511
3aed30dc 4512 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4513 if (connector == -1)
3aed30dc 4514 goto tidy_up_and_fail;
02fc2eee 4515 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4516 size = sizeof(connect_addr);
4517 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4518 &size) == -1)
4519 goto tidy_up_and_fail;
4520 if (size != sizeof(connect_addr))
4521 goto abort_tidy_up_and_fail;
e10bb1e9 4522 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4523 sizeof(connect_addr)) == -1)
4524 goto tidy_up_and_fail;
02fc2eee 4525
3aed30dc
HS		 4526 size = sizeof(listen_addr);
4527 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4528 &size);
02fc2eee 4529 if (acceptor == -1)
3aed30dc
HS		 4530 goto tidy_up_and_fail;
4531 if (size != sizeof(listen_addr))
4532 goto abort_tidy_up_and_fail;
4533 PerlLIO_close(listener);
02fc2eee
NC		 4534 /* Now check we are talking to ourself by matching port and host on the
4535 two sockets. */
3aed30dc
HS		 4536 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4537 &size) == -1)
4538 goto tidy_up_and_fail;
4539 if (size != sizeof(connect_addr)
4540 || listen_addr.sin_family != connect_addr.sin_family
4541 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4542 || listen_addr.sin_port != connect_addr.sin_port) {
4543 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4544 }
4545 fd[0] = connector;
4546 fd[1] = acceptor;
4547 return 0;
4548
4549 abort_tidy_up_and_fail:
85ca448a 4550 errno = ECONNABORTED; /* I hope this is portable and appropriate. */
02fc2eee
NC		 4551 tidy_up_and_fail:
4552 {
3aed30dc
HS		 4553 int save_errno = errno;
4554 if (listener != -1)
4555 PerlLIO_close(listener);
4556 if (connector != -1)
4557 PerlLIO_close(connector);
4558 if (acceptor != -1)
4559 PerlLIO_close(acceptor);
4560 errno = save_errno;
4561 return -1;
02fc2eee
NC		 4562 }
4563}
85ca448a 4564#else
48ea76d1
JH		 4565/* In any case have a stub so that there's code corresponding
4566 * to the my_socketpair in global.sym. */
4567int
4568Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4569#ifdef HAS_SOCKETPAIR
48ea76d1 4570 return socketpair(family, type, protocol, fd);
daf16542
JH		 4571#else
4572 return -1;
4573#endif
48ea76d1
JH		 4574}
4575#endif
4576
68795e93
NIS		 4577/*
4578
4579=for apidoc sv_nosharing
4580
4581Dummy routine which "shares" an SV when there is no sharing module present.
4582Exists to avoid test for a NULL function pointer and because it could potentially warn under
4583some level of strict-ness.
4584
4585=cut
4586*/
4587
4588void
4589Perl_sv_nosharing(pTHX_ SV *sv)
4590{
4591}
4592
4593/*
4594=for apidoc sv_nolocking
4595
4596Dummy routine which "locks" an SV when there is no locking module present.
4597Exists to avoid test for a NULL function pointer and because it could potentially warn under
4598some level of strict-ness.
4599
4600=cut
4601*/
4602
4603void
4604Perl_sv_nolocking(pTHX_ SV *sv)
4605{
4606}
4607
4608
4609/*
4610=for apidoc sv_nounlocking
4611
4612Dummy routine which "unlocks" an SV when there is no locking module present.
4613Exists to avoid test for a NULL function pointer and because it could potentially warn under
4614some level of strict-ness.
4615
4616=cut
4617*/
4618
4619void
4620Perl_sv_nounlocking(pTHX_ SV *sv)
4621{
4622}
4623
Unnamed repository; edit this file 'description' to name the repository.