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