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