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