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