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