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