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