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