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
Move all the cut&paste open TODO logic into OptreeCheck.pm, where it
[perl5.git] / util.c
CommitLineData
a0d0e21e 1/* util.c
a687059c 2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
7272f7c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
a687059c 5 *
d48672a2
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8d063cd8 8 *
8d063cd8 9 */
a0d0e21e
LW		 10
11/*
12 * "Very useful, no doubt, that was to Saruman; yet it seems that he was
13 * not content." --Gandalf
14 */
8d063cd8 15
166f8a29
DM		 16/* This file contains assorted utility routines.
17 * Which is a polite way of saying any stuff that people couldn't think of
18 * a better place for. Amongst other things, it includes the warning and
19 * dieing stuff, plus wrappers for malloc code.
20 */
21
8d063cd8 22#include "EXTERN.h"
864dbfa3 23#define PERL_IN_UTIL_C
8d063cd8 24#include "perl.h"
62b28dd9 25
64ca3a65 26#ifndef PERL_MICRO
a687059c 27#include <signal.h>
36477c24 28#ifndef SIG_ERR
29# define SIG_ERR ((Sighandler_t) -1)
30#endif
64ca3a65 31#endif
36477c24 32
172d2248
OS		 33#ifdef __Lynx__
34/* Missing protos on LynxOS */
35int putenv(char *);
36#endif
37
ff68c719 38#ifdef I_SYS_WAIT
39# include <sys/wait.h>
40#endif
41
868439a2
JH		 42#ifdef HAS_SELECT
43# ifdef I_SYS_SELECT
44# include <sys/select.h>
45# endif
46#endif
47
8d063cd8 48#define FLUSH
8d063cd8 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
ca8d8976
NC		 60static char *
61S_write_no_mem(pTHX)
62{
97aff369 63 dVAR;
ca8d8976
NC		 64 /* Can't use PerlIO to write as it allocates memory */
65 PerlLIO_write(PerlIO_fileno(Perl_error_log),
66 PL_no_mem, strlen(PL_no_mem));
67 my_exit(1);
1f440eb2 68 NORETURN_FUNCTION_END;
ca8d8976
NC		 69}
70
26fa51c3
AMS		 71/* paranoid version of system's malloc() */
72
bd4080b3 73Malloc_t
4f63d024 74Perl_safesysmalloc(MEM_SIZE size)
8d063cd8 75{
54aff467 76 dTHX;
bd4080b3 77 Malloc_t ptr;
55497cff 78#ifdef HAS_64K_LIMIT
62b28dd9 79 if (size > 0xffff) {
bf49b057 80 PerlIO_printf(Perl_error_log,
16cebae2 81 "Allocation too large: %lx\n", size) FLUSH;
54aff467 82 my_exit(1);
62b28dd9 83 }
55497cff 84#endif /* HAS_64K_LIMIT */
e8dda941
JD		 85#ifdef PERL_TRACK_MEMPOOL
86 size += sTHX;
87#endif
34de22dd
LW		 88#ifdef DEBUGGING
89 if ((long)size < 0)
4f63d024 90 Perl_croak_nocontext("panic: malloc");
34de22dd 91#endif
12ae5dfc 92 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 93 PERL_ALLOC_CHECK(ptr);
97835f67 94 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
bd61b366 95 if (ptr != NULL) {
e8dda941 96#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 97 struct perl_memory_debug_header *const header
98 = (struct perl_memory_debug_header *)ptr;
9a083ecf
NC		 99#endif
100
101#ifdef PERL_POISON
7e337ee0 102 PoisonNew(((char *)ptr), size, char);
9a083ecf 103#endif
7cb608b5 104
9a083ecf 105#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 106 header->interpreter = aTHX;
107 /* Link us into the list. */
108 header->prev = &PL_memory_debug_header;
109 header->next = PL_memory_debug_header.next;
110 PL_memory_debug_header.next = header;
111 header->next->prev = header;
cd1541b2 112# ifdef PERL_POISON
7cb608b5 113 header->size = size;
cd1541b2 114# endif
e8dda941
JD		 115 ptr = (Malloc_t)((char*)ptr+sTHX);
116#endif
8d063cd8 117 return ptr;
e8dda941 118}
3280af22 119 else if (PL_nomemok)
bd61b366 120 return NULL;
8d063cd8 121 else {
0bd48802 122 return write_no_mem();
8d063cd8
LW		 123 }
124 /*NOTREACHED*/
125}
126
f2517201 127/* paranoid version of system's realloc() */
8d063cd8 128
bd4080b3 129Malloc_t
4f63d024 130Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
8d063cd8 131{
54aff467 132 dTHX;
bd4080b3 133 Malloc_t ptr;
9a34ef1d 134#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
6ad3d225 135 Malloc_t PerlMem_realloc();
ecfc5424 136#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
8d063cd8 137
a1d180c4 138#ifdef HAS_64K_LIMIT
5f05dabc 139 if (size > 0xffff) {
bf49b057 140 PerlIO_printf(Perl_error_log,
5f05dabc 141 "Reallocation too large: %lx\n", size) FLUSH;
54aff467 142 my_exit(1);
5f05dabc 143 }
55497cff 144#endif /* HAS_64K_LIMIT */
7614df0c 145 if (!size) {
f2517201 146 safesysfree(where);
7614df0c
JD		 147 return NULL;
148 }
149
378cc40b 150 if (!where)
f2517201 151 return safesysmalloc(size);
e8dda941
JD		 152#ifdef PERL_TRACK_MEMPOOL
153 where = (Malloc_t)((char*)where-sTHX);
154 size += sTHX;
7cb608b5
NC		 155 {
156 struct perl_memory_debug_header *const header
157 = (struct perl_memory_debug_header *)where;
158
159 if (header->interpreter != aTHX) {
160 Perl_croak_nocontext("panic: realloc from wrong pool");
161 }
162 assert(header->next->prev == header);
163 assert(header->prev->next == header);
cd1541b2 164# ifdef PERL_POISON
7cb608b5
NC		 165 if (header->size > size) {
166 const MEM_SIZE freed_up = header->size - size;
167 char *start_of_freed = ((char *)where) + size;
7e337ee0 168 PoisonFree(start_of_freed, freed_up, char);
7cb608b5
NC		 169 }
170 header->size = size;
cd1541b2 171# endif
7cb608b5 172 }
e8dda941 173#endif
34de22dd
LW		 174#ifdef DEBUGGING
175 if ((long)size < 0)
4f63d024 176 Perl_croak_nocontext("panic: realloc");
34de22dd 177#endif
12ae5dfc 178 ptr = (Malloc_t)PerlMem_realloc(where,size);
da927450 179 PERL_ALLOC_CHECK(ptr);
a1d180c4 180
97835f67
JH		 181 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
182 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
79072805 183
bd61b366 184 if (ptr != NULL) {
e8dda941 185#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 186 struct perl_memory_debug_header *const header
187 = (struct perl_memory_debug_header *)ptr;
188
9a083ecf
NC		 189# ifdef PERL_POISON
190 if (header->size < size) {
191 const MEM_SIZE fresh = size - header->size;
192 char *start_of_fresh = ((char *)ptr) + size;
7e337ee0 193 PoisonNew(start_of_fresh, fresh, char);
9a083ecf
NC		 194 }
195# endif
196
7cb608b5
NC		 197 header->next->prev = header;
198 header->prev->next = header;
199
e8dda941
JD		 200 ptr = (Malloc_t)((char*)ptr+sTHX);
201#endif
8d063cd8 202 return ptr;
e8dda941 203 }
3280af22 204 else if (PL_nomemok)
bd61b366 205 return NULL;
8d063cd8 206 else {
0bd48802 207 return write_no_mem();
8d063cd8
LW		 208 }
209 /*NOTREACHED*/
210}
211
f2517201 212/* safe version of system's free() */
8d063cd8 213
54310121 214Free_t
4f63d024 215Perl_safesysfree(Malloc_t where)
8d063cd8 216{
e8dda941 217#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
54aff467 218 dTHX;
97aff369
JH		 219#else
220 dVAR;
155aba94 221#endif
97835f67 222 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
378cc40b 223 if (where) {
e8dda941
JD		 224#ifdef PERL_TRACK_MEMPOOL
225 where = (Malloc_t)((char*)where-sTHX);
cd1541b2 226 {
7cb608b5
NC		 227 struct perl_memory_debug_header *const header
228 = (struct perl_memory_debug_header *)where;
229
230 if (header->interpreter != aTHX) {
231 Perl_croak_nocontext("panic: free from wrong pool");
232 }
233 if (!header->prev) {
cd1541b2
NC		 234 Perl_croak_nocontext("panic: duplicate free");
235 }
7cb608b5
NC		 236 if (!(header->next) || header->next->prev != header
237 || header->prev->next != header) {
238 Perl_croak_nocontext("panic: bad free");
cd1541b2 239 }
7cb608b5
NC		 240 /* Unlink us from the chain. */
241 header->next->prev = header->prev;
242 header->prev->next = header->next;
243# ifdef PERL_POISON
7e337ee0 244 PoisonNew(where, header->size, char);
cd1541b2 245# endif
7cb608b5
NC		 246 /* Trigger the duplicate free warning. */
247 header->next = NULL;
248 }
e8dda941 249#endif
6ad3d225 250 PerlMem_free(where);
378cc40b 251 }
8d063cd8
LW		 252}
253
f2517201 254/* safe version of system's calloc() */
1050c9ca 255
bd4080b3 256Malloc_t
4f63d024 257Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
1050c9ca 258{
54aff467 259 dTHX;
bd4080b3 260 Malloc_t ptr;
1050c9ca 261
55497cff 262#ifdef HAS_64K_LIMIT
5f05dabc 263 if (size * count > 0xffff) {
bf49b057 264 PerlIO_printf(Perl_error_log,
5f05dabc 265 "Allocation too large: %lx\n", size * count) FLUSH;
54aff467 266 my_exit(1);
5f05dabc 267 }
55497cff 268#endif /* HAS_64K_LIMIT */
1050c9ca 269#ifdef DEBUGGING
270 if ((long)size < 0 || (long)count < 0)
4f63d024 271 Perl_croak_nocontext("panic: calloc");
1050c9ca 272#endif
0b7c1c42 273 size *= count;
e8dda941
JD		 274#ifdef PERL_TRACK_MEMPOOL
275 size += sTHX;
276#endif
12ae5dfc 277 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
da927450 278 PERL_ALLOC_CHECK(ptr);
97835f67 279 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));
bd61b366 280 if (ptr != NULL) {
1050c9ca 281 memset((void*)ptr, 0, size);
e8dda941 282#ifdef PERL_TRACK_MEMPOOL
7cb608b5
NC		 283 {
284 struct perl_memory_debug_header *const header
285 = (struct perl_memory_debug_header *)ptr;
286
287 header->interpreter = aTHX;
288 /* Link us into the list. */
289 header->prev = &PL_memory_debug_header;
290 header->next = PL_memory_debug_header.next;
291 PL_memory_debug_header.next = header;
292 header->next->prev = header;
cd1541b2 293# ifdef PERL_POISON
7cb608b5 294 header->size = size;
cd1541b2 295# endif
7cb608b5
NC		 296 ptr = (Malloc_t)((char*)ptr+sTHX);
297 }
e8dda941 298#endif
1050c9ca 299 return ptr;
300 }
3280af22 301 else if (PL_nomemok)
bd61b366 302 return NULL;
0bd48802 303 return write_no_mem();
1050c9ca 304}
305
cae6d0e5
GS		 306/* These must be defined when not using Perl's malloc for binary
307 * compatibility */
308
309#ifndef MYMALLOC
310
311Malloc_t Perl_malloc (MEM_SIZE nbytes)
312{
313 dTHXs;
077a72a9 314 return (Malloc_t)PerlMem_malloc(nbytes);
cae6d0e5
GS		 315}
316
317Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
318{
319 dTHXs;
077a72a9 320 return (Malloc_t)PerlMem_calloc(elements, size);
cae6d0e5
GS		 321}
322
323Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
324{
325 dTHXs;
077a72a9 326 return (Malloc_t)PerlMem_realloc(where, nbytes);
cae6d0e5
GS		 327}
328
329Free_t Perl_mfree (Malloc_t where)
330{
331 dTHXs;
332 PerlMem_free(where);
333}
334
335#endif
336
8d063cd8
LW		 337/* copy a string up to some (non-backslashed) delimiter, if any */
338
339char *
e1ec3a88 340Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen)
8d063cd8 341{
fc36a67e 342 register I32 tolen;
96a5add6 343 PERL_UNUSED_CONTEXT;
35da51f7 344
fc36a67e 345 for (tolen = 0; from < fromend; from++, tolen++) {
378cc40b 346 if (*from == '\\') {
35da51f7 347 if (from[1] != delim) {
fc36a67e 348 if (to < toend)
349 *to++ = *from;
350 tolen++;
fc36a67e 351 }
35da51f7 352 from++;
378cc40b 353 }
bedebaa5 354 else if (*from == delim)
8d063cd8 355 break;
fc36a67e 356 if (to < toend)
357 *to++ = *from;
8d063cd8 358 }
bedebaa5
CS		 359 if (to < toend)
360 *to = '\0';
fc36a67e 361 *retlen = tolen;
73d840c0 362 return (char *)from;
8d063cd8
LW		 363}
364
365/* return ptr to little string in big string, NULL if not found */
378cc40b 366/* This routine was donated by Corey Satten. */
8d063cd8
LW		 367
368char *
864dbfa3 369Perl_instr(pTHX_ register const char *big, register const char *little)
378cc40b 370{
79072805 371 register I32 first;
96a5add6 372 PERL_UNUSED_CONTEXT;
378cc40b 373
a687059c 374 if (!little)
08105a92 375 return (char*)big;
a687059c 376 first = *little++;
378cc40b 377 if (!first)
08105a92 378 return (char*)big;
378cc40b 379 while (*big) {
66a1b24b 380 register const char *s, *x;
378cc40b
LW		 381 if (*big++ != first)
382 continue;
383 for (x=big,s=little; *s; /**/ ) {
384 if (!*x)
bd61b366 385 return NULL;
4fc877ac 386 if (*s != *x)
378cc40b 387 break;
4fc877ac
AL		 388 else {
389 s++;
390 x++;
378cc40b
LW		 391 }
392 }
393 if (!*s)
08105a92 394 return (char*)(big-1);
378cc40b 395 }
bd61b366 396 return NULL;
378cc40b 397}
8d063cd8 398
a687059c
LW		 399/* same as instr but allow embedded nulls */
400
401char *
4c8626be 402Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend)
8d063cd8 403{
96a5add6 404 PERL_UNUSED_CONTEXT;
4c8626be
GA		 405 if (little >= lend)
406 return (char*)big;
407 {
408 char first = *little++;
409 const char *s, *x;
410 bigend -= lend - little;
411 OUTER:
412 while (big <= bigend) {
413 if (*big++ != first)
414 goto OUTER;
415 for (x=big,s=little; s < lend; x++,s++) {
416 if (*s != *x)
417 goto OUTER;
418 }
419 return (char*)(big-1);
420 }
378cc40b 421 }
bd61b366 422 return NULL;
a687059c
LW		 423}
424
425/* reverse of the above--find last substring */
426
427char *
864dbfa3 428Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
a687059c 429{
08105a92 430 register const char *bigbeg;
e1ec3a88 431 register const I32 first = *little;
7452cf6a 432 register const char * const littleend = lend;
96a5add6 433 PERL_UNUSED_CONTEXT;
a687059c 434
260d78c9 435 if (little >= littleend)
08105a92 436 return (char*)bigend;
a687059c
LW		 437 bigbeg = big;
438 big = bigend - (littleend - little++);
439 while (big >= bigbeg) {
66a1b24b 440 register const char *s, *x;
a687059c
LW		 441 if (*big-- != first)
442 continue;
443 for (x=big+2,s=little; s < littleend; /**/ ) {
4fc877ac 444 if (*s != *x)
a687059c 445 break;
4fc877ac
AL		 446 else {
447 x++;
448 s++;
a687059c
LW		 449 }
450 }
451 if (s >= littleend)
08105a92 452 return (char*)(big+1);
378cc40b 453 }
bd61b366 454 return NULL;
378cc40b 455}
a687059c 456
cf93c79d
IZ		 457/* As a space optimization, we do not compile tables for strings of length
458 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
459 special-cased in fbm_instr().
460
461 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
462
954c1994 463/*
ccfc67b7
JH		 464=head1 Miscellaneous Functions
465
954c1994
GS		 466=for apidoc fbm_compile
467
468Analyses the string in order to make fast searches on it using fbm_instr()
469-- the Boyer-Moore algorithm.
470
471=cut
472*/
473
378cc40b 474void
7506f9c3 475Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
378cc40b 476{
97aff369 477 dVAR;
0d46e09a 478 register const U8 *s;
79072805 479 register U32 i;
0b71040e 480 STRLEN len;
cb742848 481 U32 rarest = 0;
79072805
LW		 482 U32 frequency = 256;
483
c517dc2b 484 if (flags & FBMcf_TAIL) {
890ce7af 485 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
396482e1 486 sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
c517dc2b
JH		 487 if (mg && mg->mg_len >= 0)
488 mg->mg_len++;
489 }
9cbe880b 490 s = (U8*)SvPV_force_mutable(sv, len);
d1be9408 491 if (len == 0) /* TAIL might be on a zero-length string. */
cf93c79d 492 return;
cecf5685 493 SvUPGRADE(sv, SVt_PVGV);
78d0cf80 494 SvIOK_off(sv);
8eeaf79a
NC		 495 SvNOK_off(sv);
496 SvVALID_on(sv);
02128f11 497 if (len > 2) {
9cbe880b 498 const unsigned char *sb;
66a1b24b 499 const U8 mlen = (len>255) ? 255 : (U8)len;
890ce7af 500 register U8 *table;
cf93c79d 501
d8419e03
NC		 502 Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
503 table
504 = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
505 s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
7506f9c3 506 memset((void*)table, mlen, 256);
02128f11 507 i = 0;
7506f9c3 508 sb = s - mlen + 1; /* first char (maybe) */
cf93c79d
IZ		 509 while (s >= sb) {
510 if (table[*s] == mlen)
7506f9c3 511 table[*s] = (U8)i;
cf93c79d
IZ		 512 s--, i++;
513 }
d0688fc4
NC		 514 } else {
515 Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
378cc40b 516 }
a0714e2c 517 sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
378cc40b 518
9cbe880b 519 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
bbce6d69 520 for (i = 0; i < len; i++) {
22c35a8c 521 if (PL_freq[s[i]] < frequency) {
bbce6d69 522 rarest = i;
22c35a8c 523 frequency = PL_freq[s[i]];
378cc40b
LW		 524 }
525 }
610460f9 526 BmFLAGS(sv) = (U8)flags;
79072805 527 BmRARE(sv) = s[rarest];
44a10c71 528 BmPREVIOUS(sv) = rarest;
cf93c79d
IZ		 529 BmUSEFUL(sv) = 100; /* Initial value */
530 if (flags & FBMcf_TAIL)
531 SvTAIL_on(sv);
8eeaf79a
NC		 532 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
533 BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
378cc40b
LW		 534}
535
cf93c79d
IZ		 536/* If SvTAIL(littlestr), it has a fake '\n' at end. */
537/* If SvTAIL is actually due to \Z or \z, this gives false positives
538 if multiline */
539
954c1994
GS		 540/*
541=for apidoc fbm_instr
542
543Returns the location of the SV in the string delimited by C<str> and
bd61b366 544C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
954c1994
GS		 545does not have to be fbm_compiled, but the search will not be as fast
546then.
547
548=cut
549*/
550
378cc40b 551char *
864dbfa3 552Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
378cc40b 553{
a687059c 554 register unsigned char *s;
cf93c79d 555 STRLEN l;
9cbe880b
NC		 556 register const unsigned char *little
557 = (const unsigned char *)SvPV_const(littlestr,l);
cf93c79d 558 register STRLEN littlelen = l;
e1ec3a88 559 register const I32 multiline = flags & FBMrf_MULTILINE;
cf93c79d 560
eb160463 561 if ((STRLEN)(bigend - big) < littlelen) {
a1d180c4 562 if ( SvTAIL(littlestr)
eb160463 563 && ((STRLEN)(bigend - big) == littlelen - 1)
a1d180c4 564 && (littlelen == 1
12ae5dfc 565 || (*big == *little &&
27da23d5 566 memEQ((char *)big, (char *)little, littlelen - 1))))
cf93c79d 567 return (char*)big;
bd61b366 568 return NULL;
cf93c79d 569 }
378cc40b 570
cf93c79d 571 if (littlelen <= 2) { /* Special-cased */
cf93c79d
IZ		 572
573 if (littlelen == 1) {
574 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
575 /* Know that bigend != big. */
576 if (bigend[-1] == '\n')
577 return (char *)(bigend - 1);
578 return (char *) bigend;
579 }
580 s = big;
581 while (s < bigend) {
582 if (*s == *little)
583 return (char *)s;
584 s++;
585 }
586 if (SvTAIL(littlestr))
587 return (char *) bigend;
bd61b366 588 return NULL;
cf93c79d
IZ		 589 }
590 if (!littlelen)
591 return (char*)big; /* Cannot be SvTAIL! */
592
593 /* littlelen is 2 */
594 if (SvTAIL(littlestr) && !multiline) {
595 if (bigend[-1] == '\n' && bigend[-2] == *little)
596 return (char*)bigend - 2;
597 if (bigend[-1] == *little)
598 return (char*)bigend - 1;
bd61b366 599 return NULL;
cf93c79d
IZ		 600 }
601 {
602 /* This should be better than FBM if c1 == c2, and almost
603 as good otherwise: maybe better since we do less indirection.
604 And we save a lot of memory by caching no table. */
66a1b24b
AL		 605 const unsigned char c1 = little[0];
606 const unsigned char c2 = little[1];
cf93c79d
IZ		 607
608 s = big + 1;
609 bigend--;
610 if (c1 != c2) {
611 while (s <= bigend) {
612 if (s[0] == c2) {
613 if (s[-1] == c1)
614 return (char*)s - 1;
615 s += 2;
616 continue;
3fe6f2dc 617 }
cf93c79d
IZ		 618 next_chars:
619 if (s[0] == c1) {
620 if (s == bigend)
621 goto check_1char_anchor;
622 if (s[1] == c2)
623 return (char*)s;
624 else {
625 s++;
626 goto next_chars;
627 }
628 }
629 else
630 s += 2;
631 }
632 goto check_1char_anchor;
633 }
634 /* Now c1 == c2 */
635 while (s <= bigend) {
636 if (s[0] == c1) {
637 if (s[-1] == c1)
638 return (char*)s - 1;
639 if (s == bigend)
640 goto check_1char_anchor;
641 if (s[1] == c1)
642 return (char*)s;
643 s += 3;
02128f11 644 }
c277df42 645 else
cf93c79d 646 s += 2;
c277df42 647 }
c277df42 648 }
cf93c79d
IZ		 649 check_1char_anchor: /* One char and anchor! */
650 if (SvTAIL(littlestr) && (*bigend == *little))
651 return (char *)bigend; /* bigend is already decremented. */
bd61b366 652 return NULL;
d48672a2 653 }
cf93c79d 654 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
bbce6d69 655 s = bigend - littlelen;
a1d180c4 656 if (s >= big && bigend[-1] == '\n' && *s == *little
cf93c79d
IZ		 657 /* Automatically of length > 2 */
658 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
7506f9c3 659 {
bbce6d69 660 return (char*)s; /* how sweet it is */
7506f9c3
GS		 661 }
662 if (s[1] == *little
663 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
664 {
cf93c79d 665 return (char*)s + 1; /* how sweet it is */
7506f9c3 666 }
bd61b366 667 return NULL;
02128f11 668 }
cecf5685 669 if (!SvVALID(littlestr)) {
c4420975 670 char * const b = ninstr((char*)big,(char*)bigend,
cf93c79d
IZ		 671 (char*)little, (char*)little + littlelen);
672
673 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
674 /* Chop \n from littlestr: */
675 s = bigend - littlelen + 1;
7506f9c3
GS		 676 if (*s == *little
677 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
678 {
3fe6f2dc 679 return (char*)s;
7506f9c3 680 }
bd61b366 681 return NULL;
a687059c 682 }
cf93c79d 683 return b;
a687059c 684 }
a1d180c4 685
3566a07d
NC		 686 /* Do actual FBM. */
687 if (littlelen > (STRLEN)(bigend - big))
688 return NULL;
689
690 {
d8419e03
NC		 691 register const unsigned char * const table
692 = little + littlelen + PERL_FBM_TABLE_OFFSET;
0d46e09a 693 register const unsigned char *oldlittle;
cf93c79d 694
cf93c79d
IZ		 695 --littlelen; /* Last char found by table lookup */
696
697 s = big + littlelen;
698 little += littlelen; /* last char */
699 oldlittle = little;
700 if (s < bigend) {
701 register I32 tmp;
702
703 top2:
7506f9c3 704 if ((tmp = table[*s])) {
cf93c79d 705 if ((s += tmp) < bigend)
62b28dd9 706 goto top2;
cf93c79d
IZ		 707 goto check_end;
708 }
709 else { /* less expensive than calling strncmp() */
66a1b24b 710 register unsigned char * const olds = s;
cf93c79d
IZ		 711
712 tmp = littlelen;
713
714 while (tmp--) {
715 if (*--s == *--little)
716 continue;
cf93c79d
IZ		 717 s = olds + 1; /* here we pay the price for failure */
718 little = oldlittle;
719 if (s < bigend) /* fake up continue to outer loop */
720 goto top2;
721 goto check_end;
722 }
723 return (char *)s;
a687059c 724 }
378cc40b 725 }
cf93c79d 726 check_end:
c8029a41 727 if ( s == bigend
8eeaf79a 728 && (BmFLAGS(littlestr) & FBMcf_TAIL)
12ae5dfc
JH		 729 && memEQ((char *)(bigend - littlelen),
730 (char *)(oldlittle - littlelen), littlelen) )
cf93c79d 731 return (char*)bigend - littlelen;
bd61b366 732 return NULL;
378cc40b 733 }
378cc40b
LW		 734}
735
c277df42
IZ		 736/* start_shift, end_shift are positive quantities which give offsets
737 of ends of some substring of bigstr.
a0288114 738 If "last" we want the last occurrence.
c277df42 739 old_posp is the way of communication between consequent calls if
a1d180c4 740 the next call needs to find the .
c277df42 741 The initial *old_posp should be -1.
cf93c79d
IZ		 742
743 Note that we take into account SvTAIL, so one can get extra
744 optimizations if _ALL flag is set.
c277df42
IZ		 745 */
746
cf93c79d 747/* If SvTAIL is actually due to \Z or \z, this gives false positives
26fa51c3 748 if PL_multiline. In fact if !PL_multiline the authoritative answer
cf93c79d
IZ		 749 is not supported yet. */
750
378cc40b 751char *
864dbfa3 752Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
378cc40b 753{
97aff369 754 dVAR;
0d46e09a 755 register const unsigned char *big;
79072805
LW		 756 register I32 pos;
757 register I32 previous;
758 register I32 first;
0d46e09a 759 register const unsigned char *little;
c277df42 760 register I32 stop_pos;
0d46e09a 761 register const unsigned char *littleend;
c277df42 762 I32 found = 0;
378cc40b 763
cecf5685
NC		 764 assert(SvTYPE(littlestr) == SVt_PVGV);
765 assert(SvVALID(littlestr));
d372c834 766
c277df42 767 if (*old_posp == -1
3280af22 768 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
cf93c79d
IZ		 769 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
770 cant_find:
a1d180c4 771 if ( BmRARE(littlestr) == '\n'
85c508c3 772 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
cfd0369c 773 little = (const unsigned char *)(SvPVX_const(littlestr));
cf93c79d
IZ		 774 littleend = little + SvCUR(littlestr);
775 first = *little++;
776 goto check_tail;
777 }
bd61b366 778 return NULL;
cf93c79d
IZ		 779 }
780
cfd0369c 781 little = (const unsigned char *)(SvPVX_const(littlestr));
79072805 782 littleend = little + SvCUR(littlestr);
378cc40b 783 first = *little++;
c277df42 784 /* The value of pos we can start at: */
79072805 785 previous = BmPREVIOUS(littlestr);
cfd0369c 786 big = (const unsigned char *)(SvPVX_const(bigstr));
c277df42
IZ		 787 /* The value of pos we can stop at: */
788 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
cf93c79d 789 if (previous + start_shift > stop_pos) {
0fe87f7c
HS		 790/*
791 stop_pos does not include SvTAIL in the count, so this check is incorrect
792 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
793*/
794#if 0
cf93c79d
IZ		 795 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
796 goto check_tail;
0fe87f7c 797#endif
bd61b366 798 return NULL;
cf93c79d 799 }
c277df42 800 while (pos < previous + start_shift) {
3280af22 801 if (!(pos += PL_screamnext[pos]))
cf93c79d 802 goto cant_find;
378cc40b 803 }
de3bb511 804 big -= previous;
bbce6d69 805 do {
0d46e09a 806 register const unsigned char *s, *x;
ef64f398 807 if (pos >= stop_pos) break;
bbce6d69 808 if (big[pos] != first)
809 continue;
810 for (x=big+pos+1,s=little; s < littleend; /**/ ) {
bbce6d69 811 if (*s++ != *x++) {
812 s--;
813 break;
378cc40b 814 }
bbce6d69 815 }
c277df42
IZ		 816 if (s == littleend) {
817 *old_posp = pos;
818 if (!last) return (char *)(big+pos);
819 found = 1;
820 }
3280af22 821 } while ( pos += PL_screamnext[pos] );
a1d180c4 822 if (last && found)
cf93c79d 823 return (char *)(big+(*old_posp));
cf93c79d
IZ		 824 check_tail:
825 if (!SvTAIL(littlestr) || (end_shift > 0))
bd61b366 826 return NULL;
cf93c79d 827 /* Ignore the trailing "\n". This code is not microoptimized */
cfd0369c 828 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr));
cf93c79d
IZ		 829 stop_pos = littleend - little; /* Actual littlestr len */
830 if (stop_pos == 0)
831 return (char*)big;
832 big -= stop_pos;
833 if (*big == first
12ae5dfc
JH		 834 && ((stop_pos == 1) ||
835 memEQ((char *)(big + 1), (char *)little, stop_pos - 1)))
cf93c79d 836 return (char*)big;
bd61b366 837 return NULL;
8d063cd8
LW		 838}
839
79072805 840I32
864dbfa3 841Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
79072805 842{
e1ec3a88
AL		 843 register const U8 *a = (const U8 *)s1;
844 register const U8 *b = (const U8 *)s2;
96a5add6
AL		 845 PERL_UNUSED_CONTEXT;
846
79072805 847 while (len--) {
22c35a8c 848 if (*a != *b && *a != PL_fold[*b])
bbce6d69 849 return 1;
850 a++,b++;
851 }
852 return 0;
853}
854
855I32
864dbfa3 856Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
bbce6d69 857{
27da23d5 858 dVAR;
e1ec3a88
AL		 859 register const U8 *a = (const U8 *)s1;
860 register const U8 *b = (const U8 *)s2;
96a5add6
AL		 861 PERL_UNUSED_CONTEXT;
862
bbce6d69 863 while (len--) {
22c35a8c 864 if (*a != *b && *a != PL_fold_locale[*b])
bbce6d69 865 return 1;
866 a++,b++;
79072805
LW		 867 }
868 return 0;
869}
870
8d063cd8
LW		 871/* copy a string to a safe spot */
872
954c1994 873/*
ccfc67b7
JH		 874=head1 Memory Management
875
954c1994
GS		 876=for apidoc savepv
877
61a925ed
AMS		 878Perl's version of C<strdup()>. Returns a pointer to a newly allocated
879string which is a duplicate of C<pv>. The size of the string is
880determined by C<strlen()>. The memory allocated for the new string can
881be freed with the C<Safefree()> function.
954c1994
GS		 882
883=cut
884*/
885
8d063cd8 886char *
efdfce31 887Perl_savepv(pTHX_ const char *pv)
8d063cd8 888{
96a5add6 889 PERL_UNUSED_CONTEXT;
e90e2364 890 if (!pv)
bd61b366 891 return NULL;
66a1b24b
AL		 892 else {
893 char *newaddr;
894 const STRLEN pvlen = strlen(pv)+1;
10edeb5d
JH		 895 Newx(newaddr, pvlen, char);
896 return (char*)memcpy(newaddr, pv, pvlen);
66a1b24b 897 }
8d063cd8
LW		 898}
899
a687059c
LW		 900/* same thing but with a known length */
901
954c1994
GS		 902/*
903=for apidoc savepvn
904
61a925ed
AMS		 905Perl's version of what C<strndup()> would be if it existed. Returns a
906pointer to a newly allocated string which is a duplicate of the first
cbf82dd0
NC		 907C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
908the new string can be freed with the C<Safefree()> function.
954c1994
GS		 909
910=cut
911*/
912
a687059c 913char *
efdfce31 914Perl_savepvn(pTHX_ const char *pv, register I32 len)
a687059c
LW		 915{
916 register char *newaddr;
96a5add6 917 PERL_UNUSED_CONTEXT;
a687059c 918
a02a5408 919 Newx(newaddr,len+1,char);
92110913 920 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
efdfce31 921 if (pv) {
e90e2364
NC		 922 /* might not be null terminated */
923 newaddr[len] = '\0';
07409e01 924 return (char *) CopyD(pv,newaddr,len,char);
92110913
NIS		 925 }
926 else {
07409e01 927 return (char *) ZeroD(newaddr,len+1,char);
92110913 928 }
a687059c
LW		 929}
930
05ec9bb3
NIS		 931/*
932=for apidoc savesharedpv
933
61a925ed
AMS		 934A version of C<savepv()> which allocates the duplicate string in memory
935which is shared between threads.
05ec9bb3
NIS		 936
937=cut
938*/
939char *
efdfce31 940Perl_savesharedpv(pTHX_ const char *pv)
05ec9bb3 941{
e90e2364 942 register char *newaddr;
490a0e98 943 STRLEN pvlen;
e90e2364 944 if (!pv)
bd61b366 945 return NULL;
e90e2364 946
490a0e98
NC		 947 pvlen = strlen(pv)+1;
948 newaddr = (char*)PerlMemShared_malloc(pvlen);
e90e2364 949 if (!newaddr) {
0bd48802 950 return write_no_mem();
05ec9bb3 951 }
10edeb5d 952 return (char*)memcpy(newaddr, pv, pvlen);
05ec9bb3
NIS		 953}
954
2e0de35c 955/*
d9095cec
NC		 956=for apidoc savesharedpvn
957
958A version of C<savepvn()> which allocates the duplicate string in memory
959which is shared between threads. (With the specific difference that a NULL
960pointer is not acceptable)
961
962=cut
963*/
964char *
965Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len)
966{
967 char *const newaddr = (char*)PerlMemShared_malloc(len + 1);
968 assert(pv);
969 if (!newaddr) {
970 return write_no_mem();
971 }
972 newaddr[len] = '\0';
973 return (char*)memcpy(newaddr, pv, len);
974}
975
976/*
2e0de35c
NC		 977=for apidoc savesvpv
978
6832267f 979A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
2e0de35c
NC		 980the passed in SV using C<SvPV()>
981
982=cut
983*/
984
985char *
986Perl_savesvpv(pTHX_ SV *sv)
987{
988 STRLEN len;
7452cf6a 989 const char * const pv = SvPV_const(sv, len);
2e0de35c
NC		 990 register char *newaddr;
991
26866f99 992 ++len;
a02a5408 993 Newx(newaddr,len,char);
07409e01 994 return (char *) CopyD(pv,newaddr,len,char);
2e0de35c 995}
05ec9bb3
NIS		 996
997
cea2e8a9 998/* the SV for Perl_form() and mess() is not kept in an arena */
fc36a67e 999
76e3520e 1000STATIC SV *
cea2e8a9 1001S_mess_alloc(pTHX)
fc36a67e 1002{
97aff369 1003 dVAR;
fc36a67e 1004 SV *sv;
1005 XPVMG *any;
1006
e72dc28c 1007 if (!PL_dirty)
396482e1 1008 return sv_2mortal(newSVpvs(""));
e72dc28c 1009
0372dbb6
GS		 1010 if (PL_mess_sv)
1011 return PL_mess_sv;
1012
fc36a67e 1013 /* Create as PVMG now, to avoid any upgrading later */
a02a5408
JC		 1014 Newx(sv, 1, SV);
1015 Newxz(any, 1, XPVMG);
fc36a67e 1016 SvFLAGS(sv) = SVt_PVMG;
1017 SvANY(sv) = (void*)any;
6136c704 1018 SvPV_set(sv, NULL);
fc36a67e 1019 SvREFCNT(sv) = 1 << 30; /* practically infinite */
e72dc28c 1020 PL_mess_sv = sv;
fc36a67e 1021 return sv;
1022}
1023
c5be433b 1024#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1025char *
1026Perl_form_nocontext(const char* pat, ...)
1027{
1028 dTHX;
c5be433b 1029 char *retval;
cea2e8a9
GS		 1030 va_list args;
1031 va_start(args, pat);
c5be433b 1032 retval = vform(pat, &args);
cea2e8a9 1033 va_end(args);
c5be433b 1034 return retval;
cea2e8a9 1035}
c5be433b 1036#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9 1037
7c9e965c 1038/*
ccfc67b7 1039=head1 Miscellaneous Functions
7c9e965c
JP		 1040=for apidoc form
1041
1042Takes a sprintf-style format pattern and conventional
1043(non-SV) arguments and returns the formatted string.
1044
1045 (char *) Perl_form(pTHX_ const char* pat, ...)
1046
1047can be used any place a string (char *) is required:
1048
1049 char * s = Perl_form("%d.%d",major,minor);
1050
1051Uses a single private buffer so if you want to format several strings you
1052must explicitly copy the earlier strings away (and free the copies when you
1053are done).
1054
1055=cut
1056*/
1057
8990e307 1058char *
864dbfa3 1059Perl_form(pTHX_ const char* pat, ...)
8990e307 1060{
c5be433b 1061 char *retval;
46fc3d4c 1062 va_list args;
46fc3d4c 1063 va_start(args, pat);
c5be433b 1064 retval = vform(pat, &args);
46fc3d4c 1065 va_end(args);
c5be433b
GS		 1066 return retval;
1067}
1068
1069char *
1070Perl_vform(pTHX_ const char *pat, va_list *args)
1071{
2d03de9c 1072 SV * const sv = mess_alloc();
4608196e 1073 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
e72dc28c 1074 return SvPVX(sv);
46fc3d4c 1075}
a687059c 1076
5a844595
GS		 1077#if defined(PERL_IMPLICIT_CONTEXT)
1078SV *
1079Perl_mess_nocontext(const char *pat, ...)
1080{
1081 dTHX;
1082 SV *retval;
1083 va_list args;
1084 va_start(args, pat);
1085 retval = vmess(pat, &args);
1086 va_end(args);
1087 return retval;
1088}
1089#endif /* PERL_IMPLICIT_CONTEXT */
1090
06bf62c7 1091SV *
5a844595
GS		 1092Perl_mess(pTHX_ const char *pat, ...)
1093{
1094 SV *retval;
1095 va_list args;
1096 va_start(args, pat);
1097 retval = vmess(pat, &args);
1098 va_end(args);
1099 return retval;
1100}
1101
5f66b61c
AL		 1102STATIC const COP*
1103S_closest_cop(pTHX_ const COP *cop, const OP *o)
ae7d165c 1104{
97aff369 1105 dVAR;
ae7d165c
PJ		 1106 /* Look for PL_op starting from o. cop is the last COP we've seen. */
1107
fabdb6c0
AL		 1108 if (!o || o == PL_op)
1109 return cop;
ae7d165c
PJ		 1110
1111 if (o->op_flags & OPf_KIDS) {
5f66b61c 1112 const OP *kid;
fabdb6c0 1113 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
5f66b61c 1114 const COP *new_cop;
ae7d165c
PJ		 1115
1116 /* If the OP_NEXTSTATE has been optimised away we can still use it
1117 * the get the file and line number. */
1118
1119 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
5f66b61c 1120 cop = (const COP *)kid;
ae7d165c
PJ		 1121
1122 /* Keep searching, and return when we've found something. */
1123
1124 new_cop = closest_cop(cop, kid);
fabdb6c0
AL		 1125 if (new_cop)
1126 return new_cop;
ae7d165c
PJ		 1127 }
1128 }
1129
1130 /* Nothing found. */
1131
5f66b61c 1132 return NULL;
ae7d165c
PJ		 1133}
1134
5a844595
GS		 1135SV *
1136Perl_vmess(pTHX_ const char *pat, va_list *args)
46fc3d4c 1137{
97aff369 1138 dVAR;
c4420975 1139 SV * const sv = mess_alloc();
46fc3d4c 1140
5f66b61c 1141 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
46fc3d4c 1142 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
ae7d165c
PJ		 1143 /*
1144 * Try and find the file and line for PL_op. This will usually be
1145 * PL_curcop, but it might be a cop that has been optimised away. We
1146 * can try to find such a cop by searching through the optree starting
1147 * from the sibling of PL_curcop.
1148 */
1149
e1ec3a88 1150 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
5f66b61c
AL		 1151 if (!cop)
1152 cop = PL_curcop;
ae7d165c
PJ		 1153
1154 if (CopLINE(cop))
ed094faf 1155 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
3aed30dc 1156 OutCopFILE(cop), (IV)CopLINE(cop));
2035c5e8 1157 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
e1ec3a88 1158 const bool line_mode = (RsSIMPLE(PL_rs) &&
95a20fc0 1159 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
57def98f 1160 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
5f66b61c 1161 PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
edc2eac3
JH		 1162 line_mode ? "line" : "chunk",
1163 (IV)IoLINES(GvIOp(PL_last_in_gv)));
a687059c 1164 }
5f66b61c
AL		 1165 if (PL_dirty)
1166 sv_catpvs(sv, " during global destruction");
1167 sv_catpvs(sv, ".\n");
a687059c 1168 }
06bf62c7 1169 return sv;
a687059c
LW		 1170}
1171
7ff03255
SG		 1172void
1173Perl_write_to_stderr(pTHX_ const char* message, int msglen)
1174{
27da23d5 1175 dVAR;
7ff03255
SG		 1176 IO *io;
1177 MAGIC *mg;
1178
1179 if (PL_stderrgv && SvREFCNT(PL_stderrgv)
1180 && (io = GvIO(PL_stderrgv))
1181 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1182 {
1183 dSP;
1184 ENTER;
1185 SAVETMPS;
1186
1187 save_re_context();
1188 SAVESPTR(PL_stderrgv);
a0714e2c 1189 PL_stderrgv = NULL;
7ff03255
SG		 1190
1191 PUSHSTACKi(PERLSI_MAGIC);
1192
1193 PUSHMARK(SP);
1194 EXTEND(SP,2);
1195 PUSHs(SvTIED_obj((SV*)io, mg));
1196 PUSHs(sv_2mortal(newSVpvn(message, msglen)));
1197 PUTBACK;
1198 call_method("PRINT", G_SCALAR);
1199
1200 POPSTACK;
1201 FREETMPS;
1202 LEAVE;
1203 }
1204 else {
1205#ifdef USE_SFIO
1206 /* SFIO can really mess with your errno */
53c1dcc0 1207 const int e = errno;
7ff03255 1208#endif
53c1dcc0 1209 PerlIO * const serr = Perl_error_log;
7ff03255
SG		 1210
1211 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1212 (void)PerlIO_flush(serr);
1213#ifdef USE_SFIO
1214 errno = e;
1215#endif
1216 }
1217}
1218
46d9c920 1219/* Common code used by vcroak, vdie, vwarn and vwarner */
3ab1ac99 1220
46d9c920
NC		 1221STATIC bool
1222S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn)
63315e18 1223{
97aff369 1224 dVAR;
63315e18
NC		 1225 HV *stash;
1226 GV *gv;
1227 CV *cv;
46d9c920
NC		 1228 SV **const hook = warn ? &PL_warnhook : &PL_diehook;
1229 /* sv_2cv might call Perl_croak() or Perl_warner() */
1230 SV * const oldhook = *hook;
1231
1232 assert(oldhook);
63315e18 1233
63315e18 1234 ENTER;
46d9c920
NC		 1235 SAVESPTR(*hook);
1236 *hook = NULL;
1237 cv = sv_2cv(oldhook, &stash, &gv, 0);
63315e18
NC		 1238 LEAVE;
1239 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
1240 dSP;
1241 SV *msg;
1242
1243 ENTER;
1244 save_re_context();
46d9c920
NC		 1245 if (warn) {
1246 SAVESPTR(*hook);
1247 *hook = NULL;
1248 }
1249 if (warn || message) {
63315e18
NC		 1250 msg = newSVpvn(message, msglen);
1251 SvFLAGS(msg) |= utf8;
1252 SvREADONLY_on(msg);
1253 SAVEFREESV(msg);
1254 }
1255 else {
1256 msg = ERRSV;
1257 }
1258
46d9c920 1259 PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
63315e18
NC		 1260 PUSHMARK(SP);
1261 XPUSHs(msg);
1262 PUTBACK;
1263 call_sv((SV*)cv, G_DISCARD);
1264 POPSTACK;
1265 LEAVE;
46d9c920 1266 return TRUE;
63315e18 1267 }
46d9c920 1268 return FALSE;
63315e18
NC		 1269}
1270
cfd0369c 1271STATIC const char *
e07360fa
AT		 1272S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
1273 I32* utf8)
1274{
1275 dVAR;
cfd0369c 1276 const char *message;
e07360fa
AT		 1277
1278 if (pat) {
890ce7af 1279 SV * const msv = vmess(pat, args);
e07360fa
AT		 1280 if (PL_errors && SvCUR(PL_errors)) {
1281 sv_catsv(PL_errors, msv);
cfd0369c 1282 message = SvPV_const(PL_errors, *msglen);
e07360fa
AT		 1283 SvCUR_set(PL_errors, 0);
1284 }
1285 else
cfd0369c 1286 message = SvPV_const(msv,*msglen);
e07360fa
AT		 1287 *utf8 = SvUTF8(msv);
1288 }
1289 else {
bd61b366 1290 message = NULL;
e07360fa
AT		 1291 }
1292
1293 DEBUG_S(PerlIO_printf(Perl_debug_log,
1294 "%p: die/croak: message = %s\ndiehook = %p\n",
6c9570dc 1295 (void*)thr, message, (void*)PL_diehook));
e07360fa 1296 if (PL_diehook) {
46d9c920 1297 S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE);
e07360fa
AT		 1298 }
1299 return message;
1300}
1301
c5be433b
GS		 1302OP *
1303Perl_vdie(pTHX_ const char* pat, va_list *args)
36477c24 1304{
97aff369 1305 dVAR;
73d840c0 1306 const char *message;
e1ec3a88 1307 const int was_in_eval = PL_in_eval;
06bf62c7 1308 STRLEN msglen;
ff882698 1309 I32 utf8 = 0;
36477c24 1310
bf49b057 1311 DEBUG_S(PerlIO_printf(Perl_debug_log,
199100c8 1312 "%p: die: curstack = %p, mainstack = %p\n",
6c9570dc 1313 (void*)thr, (void*)PL_curstack, (void*)PL_mainstack));
36477c24 1314
890ce7af 1315 message = vdie_croak_common(pat, args, &msglen, &utf8);
36477c24 1316
06bf62c7 1317 PL_restartop = die_where(message, msglen);
ff882698 1318 SvFLAGS(ERRSV) |= utf8;
bf49b057 1319 DEBUG_S(PerlIO_printf(Perl_debug_log,
7c06b590 1320 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
6c9570dc 1321 (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env));
3280af22 1322 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
6224f72b 1323 JMPENV_JUMP(3);
3280af22 1324 return PL_restartop;
36477c24 1325}
1326
c5be433b 1327#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1328OP *
1329Perl_die_nocontext(const char* pat, ...)
a687059c 1330{
cea2e8a9
GS		 1331 dTHX;
1332 OP *o;
a687059c 1333 va_list args;
cea2e8a9 1334 va_start(args, pat);
c5be433b 1335 o = vdie(pat, &args);
cea2e8a9
GS		 1336 va_end(args);
1337 return o;
1338}
c5be433b 1339#endif /* PERL_IMPLICIT_CONTEXT */
cea2e8a9
GS		 1340
1341OP *
1342Perl_die(pTHX_ const char* pat, ...)
1343{
1344 OP *o;
1345 va_list args;
1346 va_start(args, pat);
c5be433b 1347 o = vdie(pat, &args);
cea2e8a9
GS		 1348 va_end(args);
1349 return o;
1350}
1351
c5be433b
GS		 1352void
1353Perl_vcroak(pTHX_ const char* pat, va_list *args)
cea2e8a9 1354{
97aff369 1355 dVAR;
73d840c0 1356 const char *message;
06bf62c7 1357 STRLEN msglen;
ff882698 1358 I32 utf8 = 0;
a687059c 1359
3ab1ac99 1360 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8);
5a844595 1361
3280af22 1362 if (PL_in_eval) {
06bf62c7 1363 PL_restartop = die_where(message, msglen);
ff882698 1364 SvFLAGS(ERRSV) |= utf8;
6224f72b 1365 JMPENV_JUMP(3);
a0d0e21e 1366 }
84414e3e 1367 else if (!message)
cfd0369c 1368 message = SvPVx_const(ERRSV, msglen);
84414e3e 1369
7ff03255 1370 write_to_stderr(message, msglen);
f86702cc 1371 my_failure_exit();
a687059c
LW		 1372}
1373
c5be433b 1374#if defined(PERL_IMPLICIT_CONTEXT)
8990e307 1375void
cea2e8a9 1376Perl_croak_nocontext(const char *pat, ...)
a687059c 1377{
cea2e8a9 1378 dTHX;
a687059c 1379 va_list args;
cea2e8a9 1380 va_start(args, pat);
c5be433b 1381 vcroak(pat, &args);
cea2e8a9
GS		 1382 /* NOTREACHED */
1383 va_end(args);
1384}
1385#endif /* PERL_IMPLICIT_CONTEXT */
1386
954c1994 1387/*
ccfc67b7
JH		 1388=head1 Warning and Dieing
1389
954c1994
GS		 1390=for apidoc croak
1391
9983fa3c 1392This is the XSUB-writer's interface to Perl's C<die> function.
966353fd
MF		 1393Normally call this function the same way you call the C C<printf>
1394function. Calling C<croak> returns control directly to Perl,
1395sidestepping the normal C order of execution. See C<warn>.
9983fa3c
GS		 1396
1397If you want to throw an exception object, assign the object to
bd61b366 1398C<$@> and then pass C<NULL> to croak():
9983fa3c
GS		 1399
1400 errsv = get_sv("@", TRUE);
1401 sv_setsv(errsv, exception_object);
bd61b366 1402 croak(NULL);
954c1994
GS		 1403
1404=cut
1405*/
1406
cea2e8a9
GS		 1407void
1408Perl_croak(pTHX_ const char *pat, ...)
1409{
1410 va_list args;
1411 va_start(args, pat);
c5be433b 1412 vcroak(pat, &args);
cea2e8a9
GS		 1413 /* NOTREACHED */
1414 va_end(args);
1415}
1416
c5be433b
GS		 1417void
1418Perl_vwarn(pTHX_ const char* pat, va_list *args)
cea2e8a9 1419{
27da23d5 1420 dVAR;
06bf62c7 1421 STRLEN msglen;
53c1dcc0
AL		 1422 SV * const msv = vmess(pat, args);
1423 const I32 utf8 = SvUTF8(msv);
1424 const char * const message = SvPV_const(msv, msglen);
a687059c 1425
3280af22 1426 if (PL_warnhook) {
46d9c920 1427 if (vdie_common(message, msglen, utf8, TRUE))
20cec16a 1428 return;
748a9306 1429 }
87582a92 1430
7ff03255 1431 write_to_stderr(message, msglen);
a687059c 1432}
8d063cd8 1433
c5be433b 1434#if defined(PERL_IMPLICIT_CONTEXT)
cea2e8a9
GS		 1435void
1436Perl_warn_nocontext(const char *pat, ...)
1437{
1438 dTHX;
1439 va_list args;
1440 va_start(args, pat);
c5be433b 1441 vwarn(pat, &args);
cea2e8a9
GS		 1442 va_end(args);
1443}
1444#endif /* PERL_IMPLICIT_CONTEXT */
1445
954c1994
GS		 1446/*
1447=for apidoc warn
1448
966353fd
MF		 1449This is the XSUB-writer's interface to Perl's C<warn> function. Call this
1450function the same way you call the C C<printf> function. See C<croak>.
954c1994
GS		 1451
1452=cut
1453*/
1454
cea2e8a9
GS		 1455void
1456Perl_warn(pTHX_ const char *pat, ...)
1457{
1458 va_list args;
1459 va_start(args, pat);
c5be433b 1460 vwarn(pat, &args);
cea2e8a9
GS		 1461 va_end(args);
1462}
1463
c5be433b
GS		 1464#if defined(PERL_IMPLICIT_CONTEXT)
1465void
1466Perl_warner_nocontext(U32 err, const char *pat, ...)
1467{
27da23d5 1468 dTHX;
c5be433b
GS		 1469 va_list args;
1470 va_start(args, pat);
1471 vwarner(err, pat, &args);
1472 va_end(args);
1473}
1474#endif /* PERL_IMPLICIT_CONTEXT */
1475
599cee73 1476void
864dbfa3 1477Perl_warner(pTHX_ U32 err, const char* pat,...)
599cee73
PM		 1478{
1479 va_list args;
c5be433b
GS		 1480 va_start(args, pat);
1481 vwarner(err, pat, &args);
1482 va_end(args);
1483}
1484
1485void
1486Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
1487{
27da23d5 1488 dVAR;
5f2d9966 1489 if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
a3b680e6 1490 SV * const msv = vmess(pat, args);
d13b0d77 1491 STRLEN msglen;
7452cf6a 1492 const char * const message = SvPV_const(msv, msglen);
a3b680e6 1493 const I32 utf8 = SvUTF8(msv);
599cee73 1494
3aed30dc 1495 if (PL_diehook) {
63315e18 1496 assert(message);
46d9c920 1497 S_vdie_common(aTHX_ message, msglen, utf8, FALSE);
3aed30dc
HS		 1498 }
1499 if (PL_in_eval) {
1500 PL_restartop = die_where(message, msglen);
ff882698 1501 SvFLAGS(ERRSV) |= utf8;
3aed30dc
HS		 1502 JMPENV_JUMP(3);
1503 }
7ff03255 1504 write_to_stderr(message, msglen);
3aed30dc 1505 my_failure_exit();
599cee73
PM		 1506 }
1507 else {
d13b0d77 1508 Perl_vwarn(aTHX_ pat, args);
599cee73
PM		 1509 }
1510}
1511
f54ba1c2
DM		 1512/* implements the ckWARN? macros */
1513
1514bool
1515Perl_ckwarn(pTHX_ U32 w)
1516{
97aff369 1517 dVAR;
f54ba1c2
DM		 1518 return
1519 (
1520 isLEXWARN_on
1521 && PL_curcop->cop_warnings != pWARN_NONE
1522 && (
1523 PL_curcop->cop_warnings == pWARN_ALL
1524 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1525 || (unpackWARN2(w) &&
1526 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1527 || (unpackWARN3(w) &&
1528 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1529 || (unpackWARN4(w) &&
1530 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1531 )
1532 )
1533 ||
1534 (
1535 isLEXWARN_off && PL_dowarn & G_WARN_ON
1536 )
1537 ;
1538}
1539
1540/* implements the ckWARN?_d macro */
1541
1542bool
1543Perl_ckwarn_d(pTHX_ U32 w)
1544{
97aff369 1545 dVAR;
f54ba1c2
DM		 1546 return
1547 isLEXWARN_off
1548 || PL_curcop->cop_warnings == pWARN_ALL
1549 || (
1550 PL_curcop->cop_warnings != pWARN_NONE
1551 && (
1552 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
1553 || (unpackWARN2(w) &&
1554 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
1555 || (unpackWARN3(w) &&
1556 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
1557 || (unpackWARN4(w) &&
1558 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
1559 )
1560 )
1561 ;
1562}
1563
72dc9ed5
NC		 1564/* Set buffer=NULL to get a new one. */
1565STRLEN *
8ee4cf24 1566Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
72dc9ed5
NC		 1567 STRLEN size) {
1568 const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
35da51f7 1569 PERL_UNUSED_CONTEXT;
72dc9ed5 1570
10edeb5d
JH		 1571 buffer = (STRLEN*)
1572 (specialWARN(buffer) ?
1573 PerlMemShared_malloc(len_wanted) :
1574 PerlMemShared_realloc(buffer, len_wanted));
72dc9ed5
NC		 1575 buffer[0] = size;
1576 Copy(bits, (buffer + 1), size, char);
1577 return buffer;
1578}
f54ba1c2 1579
e6587932
DM		 1580/* since we've already done strlen() for both nam and val
1581 * we can use that info to make things faster than
1582 * sprintf(s, "%s=%s", nam, val)
1583 */
1584#define my_setenv_format(s, nam, nlen, val, vlen) \
1585 Copy(nam, s, nlen, char); \
1586 *(s+nlen) = '='; \
1587 Copy(val, s+(nlen+1), vlen, char); \
1588 *(s+(nlen+1+vlen)) = '\0'
1589
c5d12488
JH		 1590#ifdef USE_ENVIRON_ARRAY
1591 /* VMS' my_setenv() is in vms.c */
1592#if !defined(WIN32) && !defined(NETWARE)
8d063cd8 1593void
e1ec3a88 1594Perl_my_setenv(pTHX_ const char *nam, const char *val)
8d063cd8 1595{
27da23d5 1596 dVAR;
4efc5df6
GS		 1597#ifdef USE_ITHREADS
1598 /* only parent thread can modify process environment */
1599 if (PL_curinterp == aTHX)
1600#endif
1601 {
f2517201 1602#ifndef PERL_USE_SAFE_PUTENV
50acdf95 1603 if (!PL_use_safe_putenv) {
c5d12488
JH		 1604 /* most putenv()s leak, so we manipulate environ directly */
1605 register I32 i=setenv_getix(nam); /* where does it go? */
1606 int nlen, vlen;
1607
1608 if (environ == PL_origenviron) { /* need we copy environment? */
1609 I32 j;
1610 I32 max;
1611 char **tmpenv;
1612
1613 max = i;
1614 while (environ[max])
1615 max++;
1616 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
1617 for (j=0; j<max; j++) { /* copy environment */
1618 const int len = strlen(environ[j]);
1619 tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
1620 Copy(environ[j], tmpenv[j], len+1, char);
1621 }
1622 tmpenv[max] = NULL;
1623 environ = tmpenv; /* tell exec where it is now */
1624 }
1625 if (!val) {
1626 safesysfree(environ[i]);
1627 while (environ[i]) {
1628 environ[i] = environ[i+1];
1629 i++;
a687059c 1630 }
c5d12488
JH		 1631 return;
1632 }
1633 if (!environ[i]) { /* does not exist yet */
1634 environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
1635 environ[i+1] = NULL; /* make sure it's null terminated */
1636 }
1637 else
1638 safesysfree(environ[i]);
1639 nlen = strlen(nam);
1640 vlen = strlen(val);
1641
1642 environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
1643 /* all that work just for this */
1644 my_setenv_format(environ[i], nam, nlen, val, vlen);
50acdf95 1645 } else {
c5d12488 1646# endif
7ee146b1 1647# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
88f5bc07
AB		 1648# if defined(HAS_UNSETENV)
1649 if (val == NULL) {
1650 (void)unsetenv(nam);
1651 } else {
1652 (void)setenv(nam, val, 1);
1653 }
1654# else /* ! HAS_UNSETENV */
1655 (void)setenv(nam, val, 1);
1656# endif /* HAS_UNSETENV */
47dafe4d 1657# else
88f5bc07
AB		 1658# if defined(HAS_UNSETENV)
1659 if (val == NULL) {
1660 (void)unsetenv(nam);
1661 } else {
c4420975
AL		 1662 const int nlen = strlen(nam);
1663 const int vlen = strlen(val);
1664 char * const new_env =
88f5bc07
AB		 1665 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1666 my_setenv_format(new_env, nam, nlen, val, vlen);
1667 (void)putenv(new_env);
1668 }
1669# else /* ! HAS_UNSETENV */
1670 char *new_env;
c4420975
AL		 1671 const int nlen = strlen(nam);
1672 int vlen;
88f5bc07
AB		 1673 if (!val) {
1674 val = "";
1675 }
1676 vlen = strlen(val);
1677 new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
1678 /* all that work just for this */
1679 my_setenv_format(new_env, nam, nlen, val, vlen);
1680 (void)putenv(new_env);
1681# endif /* HAS_UNSETENV */
47dafe4d 1682# endif /* __CYGWIN__ */
50acdf95
MS		 1683#ifndef PERL_USE_SAFE_PUTENV
1684 }
1685#endif
4efc5df6 1686 }
8d063cd8
LW		 1687}
1688
c5d12488 1689#else /* WIN32 || NETWARE */
68dc0745 1690
1691void
72229eff 1692Perl_my_setenv(pTHX_ const char *nam, const char *val)
68dc0745 1693{
27da23d5 1694 dVAR;
c5d12488
JH		 1695 register char *envstr;
1696 const int nlen = strlen(nam);
1697 int vlen;
e6587932 1698
c5d12488
JH		 1699 if (!val) {
1700 val = "";
ac5c734f 1701 }
c5d12488
JH		 1702 vlen = strlen(val);
1703 Newx(envstr, nlen+vlen+2, char);
1704 my_setenv_format(envstr, nam, nlen, val, vlen);
1705 (void)PerlEnv_putenv(envstr);
1706 Safefree(envstr);
3e3baf6d
TB		 1707}
1708
c5d12488 1709#endif /* WIN32 || NETWARE */
3e3baf6d 1710
c5d12488 1711#ifndef PERL_MICRO
3e3baf6d 1712I32
e1ec3a88 1713Perl_setenv_getix(pTHX_ const char *nam)
3e3baf6d 1714{
c5d12488 1715 register I32 i;
0d46e09a 1716 register const I32 len = strlen(nam);
96a5add6 1717 PERL_UNUSED_CONTEXT;
3e3baf6d
TB		 1718
1719 for (i = 0; environ[i]; i++) {
1720 if (
1721#ifdef WIN32
1722 strnicmp(environ[i],nam,len) == 0
1723#else
1724 strnEQ(environ[i],nam,len)
1725#endif
1726 && environ[i][len] == '=')
1727 break; /* strnEQ must come first to avoid */
1728 } /* potential SEGV's */
1729 return i;
68dc0745 1730}
c5d12488 1731#endif /* !PERL_MICRO */
68dc0745 1732
c5d12488 1733#endif /* !VMS && !EPOC*/
378cc40b 1734
16d20bd9 1735#ifdef UNLINK_ALL_VERSIONS
79072805 1736I32
6e732051 1737Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
378cc40b 1738{
35da51f7 1739 I32 retries = 0;
378cc40b 1740
35da51f7
AL		 1741 while (PerlLIO_unlink(f) >= 0)
1742 retries++;
1743 return retries ? 0 : -1;
378cc40b
LW		 1744}
1745#endif
1746
7a3f2258 1747/* this is a drop-in replacement for bcopy() */
2253333f 1748#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
378cc40b 1749char *
7a3f2258 1750Perl_my_bcopy(register const char *from,register char *to,register I32 len)
378cc40b 1751{
2d03de9c 1752 char * const retval = to;
378cc40b 1753
7c0587c8
LW		 1754 if (from - to >= 0) {
1755 while (len--)
1756 *to++ = *from++;
1757 }
1758 else {
1759 to += len;
1760 from += len;
1761 while (len--)
faf8582f 1762 *(--to) = *(--from);
7c0587c8 1763 }
378cc40b
LW		 1764 return retval;
1765}
ffed7fef 1766#endif
378cc40b 1767
7a3f2258 1768/* this is a drop-in replacement for memset() */
fc36a67e 1769#ifndef HAS_MEMSET
1770void *
7a3f2258 1771Perl_my_memset(register char *loc, register I32 ch, register I32 len)
fc36a67e 1772{
2d03de9c 1773 char * const retval = loc;
fc36a67e 1774
1775 while (len--)
1776 *loc++ = ch;
1777 return retval;
1778}
1779#endif
1780
7a3f2258 1781/* this is a drop-in replacement for bzero() */
7c0587c8 1782#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
378cc40b 1783char *
7a3f2258 1784Perl_my_bzero(register char *loc, register I32 len)
378cc40b 1785{
2d03de9c 1786 char * const retval = loc;
378cc40b
LW		 1787
1788 while (len--)
1789 *loc++ = 0;
1790 return retval;
1791}
1792#endif
7c0587c8 1793
7a3f2258 1794/* this is a drop-in replacement for memcmp() */
36477c24 1795#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
79072805 1796I32
7a3f2258 1797Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
7c0587c8 1798{
e1ec3a88
AL		 1799 register const U8 *a = (const U8 *)s1;
1800 register const U8 *b = (const U8 *)s2;
79072805 1801 register I32 tmp;
7c0587c8
LW		 1802
1803 while (len--) {
27da23d5 1804 if ((tmp = *a++ - *b++))
7c0587c8
LW		 1805 return tmp;
1806 }
1807 return 0;
1808}
36477c24 1809#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
a687059c 1810
fe14fcc3 1811#ifndef HAS_VPRINTF
a687059c 1812
85e6fe83 1813#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1814char *
1815#else
1816int
1817#endif
08105a92 1818vsprintf(char *dest, const char *pat, char *args)
a687059c
LW		 1819{
1820 FILE fakebuf;
1821
1822 fakebuf._ptr = dest;
1823 fakebuf._cnt = 32767;
35c8bce7
LW		 1824#ifndef _IOSTRG
1825#define _IOSTRG 0
1826#endif
a687059c
LW		 1827 fakebuf._flag = _IOWRT|_IOSTRG;
1828 _doprnt(pat, args, &fakebuf); /* what a kludge */
1829 (void)putc('\0', &fakebuf);
85e6fe83 1830#ifdef USE_CHAR_VSPRINTF
a687059c
LW		 1831 return(dest);
1832#else
1833 return 0; /* perl doesn't use return value */
1834#endif
1835}
1836
fe14fcc3 1837#endif /* HAS_VPRINTF */
a687059c
LW		 1838
1839#ifdef MYSWAP
ffed7fef 1840#if BYTEORDER != 0x4321
a687059c 1841short
864dbfa3 1842Perl_my_swap(pTHX_ short s)
a687059c
LW		 1843{
1844#if (BYTEORDER & 1) == 0
1845 short result;
1846
1847 result = ((s & 255) << 8) + ((s >> 8) & 255);
1848 return result;
1849#else
1850 return s;
1851#endif
1852}
1853
1854long
864dbfa3 1855Perl_my_htonl(pTHX_ long l)
a687059c
LW		 1856{
1857 union {
1858 long result;
ffed7fef 1859 char c[sizeof(long)];
a687059c
LW		 1860 } u;
1861
ffed7fef 1862#if BYTEORDER == 0x1234
a687059c
LW		 1863 u.c[0] = (l >> 24) & 255;
1864 u.c[1] = (l >> 16) & 255;
1865 u.c[2] = (l >> 8) & 255;
1866 u.c[3] = l & 255;
1867 return u.result;
1868#else
ffed7fef 1869#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1870 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1871#else
79072805
LW		 1872 register I32 o;
1873 register I32 s;
a687059c 1874
ffed7fef
LW		 1875 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1876 u.c[o & 0xf] = (l >> s) & 255;
a687059c
LW		 1877 }
1878 return u.result;
1879#endif
1880#endif
1881}
1882
1883long
864dbfa3 1884Perl_my_ntohl(pTHX_ long l)
a687059c
LW		 1885{
1886 union {
1887 long l;
ffed7fef 1888 char c[sizeof(long)];
a687059c
LW		 1889 } u;
1890
ffed7fef 1891#if BYTEORDER == 0x1234
a687059c
LW		 1892 u.c[0] = (l >> 24) & 255;
1893 u.c[1] = (l >> 16) & 255;
1894 u.c[2] = (l >> 8) & 255;
1895 u.c[3] = l & 255;
1896 return u.l;
1897#else
ffed7fef 1898#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
cea2e8a9 1899 Perl_croak(aTHX_ "Unknown BYTEORDER\n");
a687059c 1900#else
79072805
LW		 1901 register I32 o;
1902 register I32 s;
a687059c
LW		 1903
1904 u.l = l;
1905 l = 0;
ffed7fef
LW		 1906 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
1907 l |= (u.c[o & 0xf] & 255) << s;
a687059c
LW		 1908 }
1909 return l;
1910#endif
1911#endif
1912}
1913
ffed7fef 1914#endif /* BYTEORDER != 0x4321 */
988174c1
LW		 1915#endif /* MYSWAP */
1916
1917/*
1918 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
1919 * If these functions are defined,
1920 * the BYTEORDER is neither 0x1234 nor 0x4321.
1921 * However, this is not assumed.
1922 * -DWS
1923 */
1924
1109a392 1925#define HTOLE(name,type) \
988174c1 1926 type \
ba106d47 1927 name (register type n) \
988174c1
LW		 1928 { \
1929 union { \
1930 type value; \
1931 char c[sizeof(type)]; \
1932 } u; \
bb7a0f54
MHM		 1933 register U32 i; \
1934 register U32 s = 0; \
1109a392 1935 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
988174c1
LW		 1936 u.c[i] = (n >> s) & 0xFF; \
1937 } \
1938 return u.value; \
1939 }
1940
1109a392 1941#define LETOH(name,type) \
988174c1 1942 type \
ba106d47 1943 name (register type n) \
988174c1
LW		 1944 { \
1945 union { \
1946 type value; \
1947 char c[sizeof(type)]; \
1948 } u; \
bb7a0f54
MHM		 1949 register U32 i; \
1950 register U32 s = 0; \
988174c1
LW		 1951 u.value = n; \
1952 n = 0; \
1109a392
MHM		 1953 for (i = 0; i < sizeof(u.c); i++, s += 8) { \
1954 n |= ((type)(u.c[i] & 0xFF)) << s; \
988174c1
LW		 1955 } \
1956 return n; \
1957 }
1958
1109a392
MHM		 1959/*
1960 * Big-endian byte order functions.
1961 */
1962
1963#define HTOBE(name,type) \
1964 type \
1965 name (register type n) \
1966 { \
1967 union { \
1968 type value; \
1969 char c[sizeof(type)]; \
1970 } u; \
bb7a0f54
MHM		 1971 register U32 i; \
1972 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 1973 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1974 u.c[i] = (n >> s) & 0xFF; \
1975 } \
1976 return u.value; \
1977 }
1978
1979#define BETOH(name,type) \
1980 type \
1981 name (register type n) \
1982 { \
1983 union { \
1984 type value; \
1985 char c[sizeof(type)]; \
1986 } u; \
bb7a0f54
MHM		 1987 register U32 i; \
1988 register U32 s = 8*(sizeof(u.c)-1); \
1109a392
MHM		 1989 u.value = n; \
1990 n = 0; \
1991 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
1992 n |= ((type)(u.c[i] & 0xFF)) << s; \
1993 } \
1994 return n; \
1995 }
1996
1997/*
1998 * If we just can't do it...
1999 */
2000
2001#define NOT_AVAIL(name,type) \
2002 type \
2003 name (register type n) \
2004 { \
2005 Perl_croak_nocontext(#name "() not available"); \
2006 return n; /* not reached */ \
2007 }
2008
2009
988174c1 2010#if defined(HAS_HTOVS) && !defined(htovs)
1109a392 2011HTOLE(htovs,short)
988174c1
LW		 2012#endif
2013#if defined(HAS_HTOVL) && !defined(htovl)
1109a392 2014HTOLE(htovl,long)
988174c1
LW		 2015#endif
2016#if defined(HAS_VTOHS) && !defined(vtohs)
1109a392 2017LETOH(vtohs,short)
988174c1
LW		 2018#endif
2019#if defined(HAS_VTOHL) && !defined(vtohl)
1109a392
MHM		 2020LETOH(vtohl,long)
2021#endif
2022
2023#ifdef PERL_NEED_MY_HTOLE16
2024# if U16SIZE == 2
2025HTOLE(Perl_my_htole16,U16)
2026# else
2027NOT_AVAIL(Perl_my_htole16,U16)
2028# endif
2029#endif
2030#ifdef PERL_NEED_MY_LETOH16
2031# if U16SIZE == 2
2032LETOH(Perl_my_letoh16,U16)
2033# else
2034NOT_AVAIL(Perl_my_letoh16,U16)
2035# endif
2036#endif
2037#ifdef PERL_NEED_MY_HTOBE16
2038# if U16SIZE == 2
2039HTOBE(Perl_my_htobe16,U16)
2040# else
2041NOT_AVAIL(Perl_my_htobe16,U16)
2042# endif
2043#endif
2044#ifdef PERL_NEED_MY_BETOH16
2045# if U16SIZE == 2
2046BETOH(Perl_my_betoh16,U16)
2047# else
2048NOT_AVAIL(Perl_my_betoh16,U16)
2049# endif
2050#endif
2051
2052#ifdef PERL_NEED_MY_HTOLE32
2053# if U32SIZE == 4
2054HTOLE(Perl_my_htole32,U32)
2055# else
2056NOT_AVAIL(Perl_my_htole32,U32)
2057# endif
2058#endif
2059#ifdef PERL_NEED_MY_LETOH32
2060# if U32SIZE == 4
2061LETOH(Perl_my_letoh32,U32)
2062# else
2063NOT_AVAIL(Perl_my_letoh32,U32)
2064# endif
2065#endif
2066#ifdef PERL_NEED_MY_HTOBE32
2067# if U32SIZE == 4
2068HTOBE(Perl_my_htobe32,U32)
2069# else
2070NOT_AVAIL(Perl_my_htobe32,U32)
2071# endif
2072#endif
2073#ifdef PERL_NEED_MY_BETOH32
2074# if U32SIZE == 4
2075BETOH(Perl_my_betoh32,U32)
2076# else
2077NOT_AVAIL(Perl_my_betoh32,U32)
2078# endif
2079#endif
2080
2081#ifdef PERL_NEED_MY_HTOLE64
2082# if U64SIZE == 8
2083HTOLE(Perl_my_htole64,U64)
2084# else
2085NOT_AVAIL(Perl_my_htole64,U64)
2086# endif
2087#endif
2088#ifdef PERL_NEED_MY_LETOH64
2089# if U64SIZE == 8
2090LETOH(Perl_my_letoh64,U64)
2091# else
2092NOT_AVAIL(Perl_my_letoh64,U64)
2093# endif
2094#endif
2095#ifdef PERL_NEED_MY_HTOBE64
2096# if U64SIZE == 8
2097HTOBE(Perl_my_htobe64,U64)
2098# else
2099NOT_AVAIL(Perl_my_htobe64,U64)
2100# endif
2101#endif
2102#ifdef PERL_NEED_MY_BETOH64
2103# if U64SIZE == 8
2104BETOH(Perl_my_betoh64,U64)
2105# else
2106NOT_AVAIL(Perl_my_betoh64,U64)
2107# endif
988174c1 2108#endif
a687059c 2109
1109a392
MHM		 2110#ifdef PERL_NEED_MY_HTOLES
2111HTOLE(Perl_my_htoles,short)
2112#endif
2113#ifdef PERL_NEED_MY_LETOHS
2114LETOH(Perl_my_letohs,short)
2115#endif
2116#ifdef PERL_NEED_MY_HTOBES
2117HTOBE(Perl_my_htobes,short)
2118#endif
2119#ifdef PERL_NEED_MY_BETOHS
2120BETOH(Perl_my_betohs,short)
2121#endif
2122
2123#ifdef PERL_NEED_MY_HTOLEI
2124HTOLE(Perl_my_htolei,int)
2125#endif
2126#ifdef PERL_NEED_MY_LETOHI
2127LETOH(Perl_my_letohi,int)
2128#endif
2129#ifdef PERL_NEED_MY_HTOBEI
2130HTOBE(Perl_my_htobei,int)
2131#endif
2132#ifdef PERL_NEED_MY_BETOHI
2133BETOH(Perl_my_betohi,int)
2134#endif
2135
2136#ifdef PERL_NEED_MY_HTOLEL
2137HTOLE(Perl_my_htolel,long)
2138#endif
2139#ifdef PERL_NEED_MY_LETOHL
2140LETOH(Perl_my_letohl,long)
2141#endif
2142#ifdef PERL_NEED_MY_HTOBEL
2143HTOBE(Perl_my_htobel,long)
2144#endif
2145#ifdef PERL_NEED_MY_BETOHL
2146BETOH(Perl_my_betohl,long)
2147#endif
2148
2149void
2150Perl_my_swabn(void *ptr, int n)
2151{
2152 register char *s = (char *)ptr;
2153 register char *e = s + (n-1);
2154 register char tc;
2155
2156 for (n /= 2; n > 0; s++, e--, n--) {
2157 tc = *s;
2158 *s = *e;
2159 *e = tc;
2160 }
2161}
2162
4a7d1889
NIS		 2163PerlIO *
2164Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
2165{
2986a63f 2166#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
97aff369 2167 dVAR;
1f852d0d
NIS		 2168 int p[2];
2169 register I32 This, that;
2170 register Pid_t pid;
2171 SV *sv;
2172 I32 did_pipes = 0;
2173 int pp[2];
2174
2175 PERL_FLUSHALL_FOR_CHILD;
2176 This = (*mode == 'w');
2177 that = !This;
2178 if (PL_tainting) {
2179 taint_env();
2180 taint_proper("Insecure %s%s", "EXEC");
2181 }
2182 if (PerlProc_pipe(p) < 0)
4608196e 2183 return NULL;
1f852d0d
NIS		 2184 /* Try for another pipe pair for error return */
2185 if (PerlProc_pipe(pp) >= 0)
2186 did_pipes = 1;
52e18b1f 2187 while ((pid = PerlProc_fork()) < 0) {
1f852d0d
NIS		 2188 if (errno != EAGAIN) {
2189 PerlLIO_close(p[This]);
4e6dfe71 2190 PerlLIO_close(p[that]);
1f852d0d
NIS		 2191 if (did_pipes) {
2192 PerlLIO_close(pp[0]);
2193 PerlLIO_close(pp[1]);
2194 }
4608196e 2195 return NULL;
1f852d0d
NIS		 2196 }
2197 sleep(5);
2198 }
2199 if (pid == 0) {
2200 /* Child */
1f852d0d
NIS		 2201#undef THIS
2202#undef THAT
2203#define THIS that
2204#define THAT This
1f852d0d
NIS		 2205 /* Close parent's end of error status pipe (if any) */
2206 if (did_pipes) {
2207 PerlLIO_close(pp[0]);
2208#if defined(HAS_FCNTL) && defined(F_SETFD)
2209 /* Close error pipe automatically if exec works */
2210 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2211#endif
2212 }
2213 /* Now dup our end of _the_ pipe to right position */
2214 if (p[THIS] != (*mode == 'r')) {
2215 PerlLIO_dup2(p[THIS], *mode == 'r');
2216 PerlLIO_close(p[THIS]);
4e6dfe71
GS		 2217 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2218 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d 2219 }
4e6dfe71
GS		 2220 else
2221 PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
1f852d0d
NIS		 2222#if !defined(HAS_FCNTL) || !defined(F_SETFD)
2223 /* No automatic close - do it by hand */
b7953727
JH		 2224# ifndef NOFILE
2225# define NOFILE 20
2226# endif
a080fe3d
NIS		 2227 {
2228 int fd;
2229
2230 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
3aed30dc 2231 if (fd != pp[1])
a080fe3d
NIS		 2232 PerlLIO_close(fd);
2233 }
1f852d0d
NIS		 2234 }
2235#endif
a0714e2c 2236 do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
1f852d0d
NIS		 2237 PerlProc__exit(1);
2238#undef THIS
2239#undef THAT
2240 }
2241 /* Parent */
52e18b1f 2242 do_execfree(); /* free any memory malloced by child on fork */
1f852d0d
NIS		 2243 if (did_pipes)
2244 PerlLIO_close(pp[1]);
2245 /* Keep the lower of the two fd numbers */
2246 if (p[that] < p[This]) {
2247 PerlLIO_dup2(p[This], p[that]);
2248 PerlLIO_close(p[This]);
2249 p[This] = p[that];
2250 }
4e6dfe71
GS		 2251 else
2252 PerlLIO_close(p[that]); /* close child's end of pipe */
2253
1f852d0d
NIS		 2254 LOCK_FDPID_MUTEX;
2255 sv = *av_fetch(PL_fdpid,p[This],TRUE);
2256 UNLOCK_FDPID_MUTEX;
862a34c6 2257 SvUPGRADE(sv,SVt_IV);
45977657 2258 SvIV_set(sv, pid);
1f852d0d
NIS		 2259 PL_forkprocess = pid;
2260 /* If we managed to get status pipe check for exec fail */
2261 if (did_pipes && pid > 0) {
2262 int errkid;
bb7a0f54
MHM		 2263 unsigned n = 0;
2264 SSize_t n1;
1f852d0d
NIS		 2265
2266 while (n < sizeof(int)) {
2267 n1 = PerlLIO_read(pp[0],
2268 (void*)(((char*)&errkid)+n),
2269 (sizeof(int)) - n);
2270 if (n1 <= 0)
2271 break;
2272 n += n1;
2273 }
2274 PerlLIO_close(pp[0]);
2275 did_pipes = 0;
2276 if (n) { /* Error */
2277 int pid2, status;
8c51524e 2278 PerlLIO_close(p[This]);
1f852d0d
NIS		 2279 if (n != sizeof(int))
2280 Perl_croak(aTHX_ "panic: kid popen errno read");
2281 do {
2282 pid2 = wait4pid(pid, &status, 0);
2283 } while (pid2 == -1 && errno == EINTR);
2284 errno = errkid; /* Propagate errno from kid */
4608196e 2285 return NULL;
1f852d0d
NIS		 2286 }
2287 }
2288 if (did_pipes)
2289 PerlLIO_close(pp[0]);
2290 return PerlIO_fdopen(p[This], mode);
2291#else
9d419b5f
IZ		 2292# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
2293 return my_syspopen4(aTHX_ Nullch, mode, n, args);
2294# else
4a7d1889
NIS		 2295 Perl_croak(aTHX_ "List form of piped open not implemented");
2296 return (PerlIO *) NULL;
9d419b5f 2297# endif
1f852d0d 2298#endif
4a7d1889
NIS		 2299}
2300
5f05dabc 2301 /* VMS' my_popen() is in VMS.c, same with OS/2. */
cd39f2b6 2302#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
760ac839 2303PerlIO *
3dd43144 2304Perl_my_popen(pTHX_ const char *cmd, const char *mode)
a687059c 2305{
97aff369 2306 dVAR;
a687059c 2307 int p[2];
8ac85365 2308 register I32 This, that;
d8a83dd3 2309 register Pid_t pid;
79072805 2310 SV *sv;
bfce84ec 2311 const I32 doexec = !(*cmd == '-' && cmd[1] == '\0');
e446cec8
IZ		 2312 I32 did_pipes = 0;
2313 int pp[2];
a687059c 2314
45bc9206 2315 PERL_FLUSHALL_FOR_CHILD;
ddcf38b7
IZ		 2316#ifdef OS2
2317 if (doexec) {
23da6c43 2318 return my_syspopen(aTHX_ cmd,mode);
ddcf38b7 2319 }
a1d180c4 2320#endif
8ac85365
NIS		 2321 This = (*mode == 'w');
2322 that = !This;
3280af22 2323 if (doexec && PL_tainting) {
bbce6d69 2324 taint_env();
2325 taint_proper("Insecure %s%s", "EXEC");
d48672a2 2326 }
c2267164 2327 if (PerlProc_pipe(p) < 0)
4608196e 2328 return NULL;
e446cec8
IZ		 2329 if (doexec && PerlProc_pipe(pp) >= 0)
2330 did_pipes = 1;
52e18b1f 2331 while ((pid = PerlProc_fork()) < 0) {
a687059c 2332 if (errno != EAGAIN) {
6ad3d225 2333 PerlLIO_close(p[This]);
b5ac89c3 2334 PerlLIO_close(p[that]);
e446cec8
IZ		 2335 if (did_pipes) {
2336 PerlLIO_close(pp[0]);
2337 PerlLIO_close(pp[1]);
2338 }
a687059c 2339 if (!doexec)
cea2e8a9 2340 Perl_croak(aTHX_ "Can't fork");
4608196e 2341 return NULL;
a687059c
LW		 2342 }
2343 sleep(5);
2344 }
2345 if (pid == 0) {
79072805
LW		 2346 GV* tmpgv;
2347
30ac6d9b
GS		 2348#undef THIS
2349#undef THAT
a687059c 2350#define THIS that
8ac85365 2351#define THAT This
e446cec8
IZ		 2352 if (did_pipes) {
2353 PerlLIO_close(pp[0]);
2354#if defined(HAS_FCNTL) && defined(F_SETFD)
2355 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
2356#endif
2357 }
a687059c 2358 if (p[THIS] != (*mode == 'r')) {
6ad3d225
GS		 2359 PerlLIO_dup2(p[THIS], *mode == 'r');
2360 PerlLIO_close(p[THIS]);
b5ac89c3
NIS		 2361 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
2362 PerlLIO_close(p[THAT]);
a687059c 2363 }
b5ac89c3
NIS		 2364 else
2365 PerlLIO_close(p[THAT]);
4435c477 2366#ifndef OS2
a687059c 2367 if (doexec) {
a0d0e21e 2368#if !defined(HAS_FCNTL) || !defined(F_SETFD)
ae986130
LW		 2369#ifndef NOFILE
2370#define NOFILE 20
2371#endif
a080fe3d 2372 {
3aed30dc 2373 int fd;
a080fe3d
NIS		 2374
2375 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
2376 if (fd != pp[1])
3aed30dc 2377 PerlLIO_close(fd);
a080fe3d 2378 }
ae986130 2379#endif
a080fe3d
NIS		 2380 /* may or may not use the shell */
2381 do_exec3(cmd, pp[1], did_pipes);
6ad3d225 2382 PerlProc__exit(1);
a687059c 2383 }
4435c477 2384#endif /* defined OS2 */
713cef20
IZ		 2385
2386#ifdef PERLIO_USING_CRLF
2387 /* Since we circumvent IO layers when we manipulate low-level
2388 filedescriptors directly, need to manually switch to the
2389 default, binary, low-level mode; see PerlIOBuf_open(). */
2390 PerlLIO_setmode((*mode == 'r'), O_BINARY);
2391#endif
2392
fafc274c 2393 if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
4d76a344 2394 SvREADONLY_off(GvSV(tmpgv));
7766f137 2395 sv_setiv(GvSV(tmpgv), PerlProc_getpid());
4d76a344
RGS		 2396 SvREADONLY_on(GvSV(tmpgv));
2397 }
2398#ifdef THREADS_HAVE_PIDS
2399 PL_ppid = (IV)getppid();
2400#endif
3280af22 2401 PL_forkprocess = 0;
ca0c25f6 2402#ifdef PERL_USES_PL_PIDSTATUS
3280af22 2403 hv_clear(PL_pidstatus); /* we have no children */
ca0c25f6 2404#endif
4608196e 2405 return NULL;
a687059c
LW		 2406#undef THIS
2407#undef THAT
2408 }
b5ac89c3 2409 do_execfree(); /* free any memory malloced by child on vfork */
e446cec8
IZ		 2410 if (did_pipes)
2411 PerlLIO_close(pp[1]);
8ac85365 2412 if (p[that] < p[This]) {
6ad3d225
GS		 2413 PerlLIO_dup2(p[This], p[that]);
2414 PerlLIO_close(p[This]);
8ac85365 2415 p[This] = p[that];
62b28dd9 2416 }
b5ac89c3
NIS		 2417 else
2418 PerlLIO_close(p[that]);
2419
4755096e 2420 LOCK_FDPID_MUTEX;
3280af22 2421 sv = *av_fetch(PL_fdpid,p[This],TRUE);
4755096e 2422 UNLOCK_FDPID_MUTEX;
862a34c6 2423 SvUPGRADE(sv,SVt_IV);
45977657 2424 SvIV_set(sv, pid);
3280af22 2425 PL_forkprocess = pid;
e446cec8
IZ		 2426 if (did_pipes && pid > 0) {
2427 int errkid;
bb7a0f54
MHM		 2428 unsigned n = 0;
2429 SSize_t n1;
e446cec8
IZ		 2430
2431 while (n < sizeof(int)) {
2432 n1 = PerlLIO_read(pp[0],
2433 (void*)(((char*)&errkid)+n),
2434 (sizeof(int)) - n);
2435 if (n1 <= 0)
2436 break;
2437 n += n1;
2438 }
2f96c702
IZ		 2439 PerlLIO_close(pp[0]);
2440 did_pipes = 0;
e446cec8 2441 if (n) { /* Error */
faa466a7 2442 int pid2, status;
8c51524e 2443 PerlLIO_close(p[This]);
e446cec8 2444 if (n != sizeof(int))
cea2e8a9 2445 Perl_croak(aTHX_ "panic: kid popen errno read");
faa466a7
RG		 2446 do {
2447 pid2 = wait4pid(pid, &status, 0);
2448 } while (pid2 == -1 && errno == EINTR);
e446cec8 2449 errno = errkid; /* Propagate errno from kid */
4608196e 2450 return NULL;
e446cec8
IZ		 2451 }
2452 }
2453 if (did_pipes)
2454 PerlLIO_close(pp[0]);
8ac85365 2455 return PerlIO_fdopen(p[This], mode);
a687059c 2456}
7c0587c8 2457#else
85ca448a 2458#if defined(atarist) || defined(EPOC)
7c0587c8 2459FILE *popen();
760ac839 2460PerlIO *
7dc3a6bf 2461Perl_my_popen((pTHX_ const char *cmd, const char *mode)
7c0587c8 2462{
45bc9206 2463 PERL_FLUSHALL_FOR_CHILD;
a1d180c4
NIS		 2464 /* Call system's popen() to get a FILE *, then import it.
2465 used 0 for 2nd parameter to PerlIO_importFILE;
2466 apparently not used
2467 */
2468 return PerlIO_importFILE(popen(cmd, mode), 0);
7c0587c8 2469}
2b96b0a5
JH		 2470#else
2471#if defined(DJGPP)
2472FILE *djgpp_popen();
2473PerlIO *
7dc3a6bf 2474Perl_my_popen((pTHX_ const char *cmd, const char *mode)
2b96b0a5
JH		 2475{
2476 PERL_FLUSHALL_FOR_CHILD;
2477 /* Call system's popen() to get a FILE *, then import it.
2478 used 0 for 2nd parameter to PerlIO_importFILE;
2479 apparently not used
2480 */
2481 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
2482}
2483#endif
7c0587c8
LW		 2484#endif
2485
2486#endif /* !DOSISH */
a687059c 2487
52e18b1f
GS		 2488/* this is called in parent before the fork() */
2489void
2490Perl_atfork_lock(void)
2491{
27da23d5 2492 dVAR;
3db8f154 2493#if defined(USE_ITHREADS)
52e18b1f
GS		 2494 /* locks must be held in locking order (if any) */
2495# ifdef MYMALLOC
2496 MUTEX_LOCK(&PL_malloc_mutex);
2497# endif
2498 OP_REFCNT_LOCK;
2499#endif
2500}
2501
2502/* this is called in both parent and child after the fork() */
2503void
2504Perl_atfork_unlock(void)
2505{
27da23d5 2506 dVAR;
3db8f154 2507#if defined(USE_ITHREADS)
52e18b1f
GS		 2508 /* locks must be released in same order as in atfork_lock() */
2509# ifdef MYMALLOC
2510 MUTEX_UNLOCK(&PL_malloc_mutex);
2511# endif
2512 OP_REFCNT_UNLOCK;
2513#endif
2514}
2515
2516Pid_t
2517Perl_my_fork(void)
2518{
2519#if defined(HAS_FORK)
2520 Pid_t pid;
3db8f154 2521#if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
52e18b1f
GS		 2522 atfork_lock();
2523 pid = fork();
2524 atfork_unlock();
2525#else
2526 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
2527 * handlers elsewhere in the code */
2528 pid = fork();
2529#endif
2530 return pid;
2531#else
2532 /* this "canna happen" since nothing should be calling here if !HAS_FORK */
2533 Perl_croak_nocontext("fork() not available");
b961a566 2534 return 0;
52e18b1f
GS		 2535#endif /* HAS_FORK */
2536}
2537
748a9306 2538#ifdef DUMP_FDS
35ff7856 2539void
864dbfa3 2540Perl_dump_fds(pTHX_ char *s)
ae986130
LW		 2541{
2542 int fd;
c623ac67 2543 Stat_t tmpstatbuf;
ae986130 2544
bf49b057 2545 PerlIO_printf(Perl_debug_log,"%s", s);
ae986130 2546 for (fd = 0; fd < 32; fd++) {
6ad3d225 2547 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
bf49b057 2548 PerlIO_printf(Perl_debug_log," %d",fd);
ae986130 2549 }
bf49b057 2550 PerlIO_printf(Perl_debug_log,"\n");
27da23d5 2551 return;
ae986130 2552}
35ff7856 2553#endif /* DUMP_FDS */
ae986130 2554
fe14fcc3 2555#ifndef HAS_DUP2
fec02dd3 2556int
ba106d47 2557dup2(int oldfd, int newfd)
a687059c 2558{
a0d0e21e 2559#if defined(HAS_FCNTL) && defined(F_DUPFD)
fec02dd3
AD		 2560 if (oldfd == newfd)
2561 return oldfd;
6ad3d225 2562 PerlLIO_close(newfd);
fec02dd3 2563 return fcntl(oldfd, F_DUPFD, newfd);
62b28dd9 2564#else
fc36a67e 2565#define DUP2_MAX_FDS 256
2566 int fdtmp[DUP2_MAX_FDS];
79072805 2567 I32 fdx = 0;
ae986130
LW		 2568 int fd;
2569
fe14fcc3 2570 if (oldfd == newfd)
fec02dd3 2571 return oldfd;
6ad3d225 2572 PerlLIO_close(newfd);
fc36a67e 2573 /* good enough for low fd's... */
6ad3d225 2574 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
fc36a67e 2575 if (fdx >= DUP2_MAX_FDS) {
6ad3d225 2576 PerlLIO_close(fd);
fc36a67e 2577 fd = -1;
2578 break;
2579 }
ae986130 2580 fdtmp[fdx++] = fd;
fc36a67e 2581 }
ae986130 2582 while (fdx > 0)
6ad3d225 2583 PerlLIO_close(fdtmp[--fdx]);
fec02dd3 2584 return fd;
62b28dd9 2585#endif
a687059c
LW		 2586}
2587#endif
2588
64ca3a65 2589#ifndef PERL_MICRO
ff68c719 2590#ifdef HAS_SIGACTION
2591
abea2c45
HS		 2592#ifdef MACOS_TRADITIONAL
2593/* We don't want restart behavior on MacOS */
2594#undef SA_RESTART
2595#endif
2596
ff68c719 2597Sighandler_t
864dbfa3 2598Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2599{
27da23d5 2600 dVAR;
ff68c719 2601 struct sigaction act, oact;
2602
a10b1e10
JH		 2603#ifdef USE_ITHREADS
2604 /* only "parent" interpreter can diddle signals */
2605 if (PL_curinterp != aTHX)
8aad04aa 2606 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2607#endif
2608
8aad04aa 2609 act.sa_handler = (void(*)(int))handler;
ff68c719 2610 sigemptyset(&act.sa_mask);
2611 act.sa_flags = 0;
2612#ifdef SA_RESTART
4ffa73a3
JH		 2613 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2614 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2615#endif
358837b8 2616#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2617 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2618 act.sa_flags |= SA_NOCLDWAIT;
2619#endif
ff68c719 2620 if (sigaction(signo, &act, &oact) == -1)
8aad04aa 2621 return (Sighandler_t) SIG_ERR;
ff68c719 2622 else
8aad04aa 2623 return (Sighandler_t) oact.sa_handler;
ff68c719 2624}
2625
2626Sighandler_t
864dbfa3 2627Perl_rsignal_state(pTHX_ int signo)
ff68c719 2628{
2629 struct sigaction oact;
96a5add6 2630 PERL_UNUSED_CONTEXT;
ff68c719 2631
2632 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
8aad04aa 2633 return (Sighandler_t) SIG_ERR;
ff68c719 2634 else
8aad04aa 2635 return (Sighandler_t) oact.sa_handler;
ff68c719 2636}
2637
2638int
864dbfa3 2639Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2640{
27da23d5 2641 dVAR;
ff68c719 2642 struct sigaction act;
2643
a10b1e10
JH		 2644#ifdef USE_ITHREADS
2645 /* only "parent" interpreter can diddle signals */
2646 if (PL_curinterp != aTHX)
2647 return -1;
2648#endif
2649
8aad04aa 2650 act.sa_handler = (void(*)(int))handler;
ff68c719 2651 sigemptyset(&act.sa_mask);
2652 act.sa_flags = 0;
2653#ifdef SA_RESTART
4ffa73a3
JH		 2654 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
2655 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
0a8e0eff 2656#endif
36b5d377 2657#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
8aad04aa 2658 if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
85264bed
CS		 2659 act.sa_flags |= SA_NOCLDWAIT;
2660#endif
ff68c719 2661 return sigaction(signo, &act, save);
2662}
2663
2664int
864dbfa3 2665Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2666{
27da23d5 2667 dVAR;
a10b1e10
JH		 2668#ifdef USE_ITHREADS
2669 /* only "parent" interpreter can diddle signals */
2670 if (PL_curinterp != aTHX)
2671 return -1;
2672#endif
2673
ff68c719 2674 return sigaction(signo, save, (struct sigaction *)NULL);
2675}
2676
2677#else /* !HAS_SIGACTION */
2678
2679Sighandler_t
864dbfa3 2680Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
ff68c719 2681{
39f1703b 2682#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2683 /* only "parent" interpreter can diddle signals */
2684 if (PL_curinterp != aTHX)
8aad04aa 2685 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2686#endif
2687
6ad3d225 2688 return PerlProc_signal(signo, handler);
ff68c719 2689}
2690
fabdb6c0 2691static Signal_t
4e35701f 2692sig_trap(int signo)
ff68c719 2693{
27da23d5
JH		 2694 dVAR;
2695 PL_sig_trapped++;
ff68c719 2696}
2697
2698Sighandler_t
864dbfa3 2699Perl_rsignal_state(pTHX_ int signo)
ff68c719 2700{
27da23d5 2701 dVAR;
ff68c719 2702 Sighandler_t oldsig;
2703
39f1703b 2704#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2705 /* only "parent" interpreter can diddle signals */
2706 if (PL_curinterp != aTHX)
8aad04aa 2707 return (Sighandler_t) SIG_ERR;
a10b1e10
JH		 2708#endif
2709
27da23d5 2710 PL_sig_trapped = 0;
6ad3d225
GS		 2711 oldsig = PerlProc_signal(signo, sig_trap);
2712 PerlProc_signal(signo, oldsig);
27da23d5 2713 if (PL_sig_trapped)
3aed30dc 2714 PerlProc_kill(PerlProc_getpid(), signo);
ff68c719 2715 return oldsig;
2716}
2717
2718int
864dbfa3 2719Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
ff68c719 2720{
39f1703b 2721#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2722 /* only "parent" interpreter can diddle signals */
2723 if (PL_curinterp != aTHX)
2724 return -1;
2725#endif
6ad3d225 2726 *save = PerlProc_signal(signo, handler);
8aad04aa 2727 return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2728}
2729
2730int
864dbfa3 2731Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
ff68c719 2732{
39f1703b 2733#if defined(USE_ITHREADS) && !defined(WIN32)
a10b1e10
JH		 2734 /* only "parent" interpreter can diddle signals */
2735 if (PL_curinterp != aTHX)
2736 return -1;
2737#endif
8aad04aa 2738 return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
ff68c719 2739}
2740
2741#endif /* !HAS_SIGACTION */
64ca3a65 2742#endif /* !PERL_MICRO */
ff68c719 2743
5f05dabc 2744 /* VMS' my_pclose() is in VMS.c; same with OS/2 */
cd39f2b6 2745#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
79072805 2746I32
864dbfa3 2747Perl_my_pclose(pTHX_ PerlIO *ptr)
a687059c 2748{
97aff369 2749 dVAR;
ff68c719 2750 Sigsave_t hstat, istat, qstat;
a687059c 2751 int status;
a0d0e21e 2752 SV **svp;
d8a83dd3
JH		 2753 Pid_t pid;
2754 Pid_t pid2;
03136e13 2755 bool close_failed;
b7953727 2756 int saved_errno = 0;
22fae026
TM		 2757#ifdef WIN32
2758 int saved_win32_errno;
2759#endif
a687059c 2760
4755096e 2761 LOCK_FDPID_MUTEX;
3280af22 2762 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
4755096e 2763 UNLOCK_FDPID_MUTEX;
25d92023 2764 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
a0d0e21e 2765 SvREFCNT_dec(*svp);
3280af22 2766 *svp = &PL_sv_undef;
ddcf38b7
IZ		 2767#ifdef OS2
2768 if (pid == -1) { /* Opened by popen. */
2769 return my_syspclose(ptr);
2770 }
a1d180c4 2771#endif
03136e13
CS		 2772 if ((close_failed = (PerlIO_close(ptr) == EOF))) {
2773 saved_errno = errno;
22fae026
TM		 2774#ifdef WIN32
2775 saved_win32_errno = GetLastError();
2776#endif
03136e13 2777 }
7c0587c8 2778#ifdef UTS
6ad3d225 2779 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
7c0587c8 2780#endif
64ca3a65 2781#ifndef PERL_MICRO
8aad04aa
JH		 2782 rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
2783 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
2784 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
64ca3a65 2785#endif
748a9306 2786 do {
1d3434b8
GS		 2787 pid2 = wait4pid(pid, &status, 0);
2788 } while (pid2 == -1 && errno == EINTR);
64ca3a65 2789#ifndef PERL_MICRO
ff68c719 2790 rsignal_restore(SIGHUP, &hstat);
2791 rsignal_restore(SIGINT, &istat);
2792 rsignal_restore(SIGQUIT, &qstat);
64ca3a65 2793#endif
03136e13 2794 if (close_failed) {
ce6e1103 2795 SETERRNO(saved_errno, 0);
03136e13
CS		 2796 return -1;
2797 }
1d3434b8 2798 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
20188a90 2799}
4633a7c4
LW		 2800#endif /* !DOSISH */
2801
2986a63f 2802#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
79072805 2803I32
d8a83dd3 2804Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
20188a90 2805{
97aff369 2806 dVAR;
27da23d5 2807 I32 result = 0;
b7953727
JH		 2808 if (!pid)
2809 return -1;
ca0c25f6 2810#ifdef PERL_USES_PL_PIDSTATUS
b7953727 2811 {
3aed30dc 2812 if (pid > 0) {
12072db5
NC		 2813 /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
2814 pid, rather than a string form. */
c4420975 2815 SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
3aed30dc
HS		 2816 if (svp && *svp != &PL_sv_undef) {
2817 *statusp = SvIVX(*svp);
12072db5
NC		 2818 (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
2819 G_DISCARD);
3aed30dc
HS		 2820 return pid;
2821 }
2822 }
2823 else {
2824 HE *entry;
2825
2826 hv_iterinit(PL_pidstatus);
2827 if ((entry = hv_iternext(PL_pidstatus))) {
c4420975 2828 SV * const sv = hv_iterval(PL_pidstatus,entry);
7ea75b61 2829 I32 len;
0bcc34c2 2830 const char * const spid = hv_iterkey(entry,&len);
27da23d5 2831
12072db5
NC		 2832 assert (len == sizeof(Pid_t));
2833 memcpy((char *)&pid, spid, len);
3aed30dc 2834 *statusp = SvIVX(sv);
7b9a3241
NC		 2835 /* The hash iterator is currently on this entry, so simply
2836 calling hv_delete would trigger the lazy delete, which on
2837 aggregate does more work, beacuse next call to hv_iterinit()
2838 would spot the flag, and have to call the delete routine,
2839 while in the meantime any new entries can't re-use that
2840 memory. */
2841 hv_iterinit(PL_pidstatus);
7ea75b61 2842 (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
3aed30dc
HS		 2843 return pid;
2844 }
20188a90
LW		 2845 }
2846 }
68a29c53 2847#endif
79072805 2848#ifdef HAS_WAITPID
367f3c24
IZ		 2849# ifdef HAS_WAITPID_RUNTIME
2850 if (!HAS_WAITPID_RUNTIME)
2851 goto hard_way;
2852# endif
cddd4526 2853 result = PerlProc_waitpid(pid,statusp,flags);
dfcfdb64 2854 goto finish;
367f3c24
IZ		 2855#endif
2856#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
4608196e 2857 result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
dfcfdb64 2858 goto finish;
367f3c24 2859#endif
ca0c25f6 2860#ifdef PERL_USES_PL_PIDSTATUS
27da23d5 2861#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
367f3c24 2862 hard_way:
27da23d5 2863#endif
a0d0e21e 2864 {
a0d0e21e 2865 if (flags)
cea2e8a9 2866 Perl_croak(aTHX_ "Can't do waitpid with flags");
a0d0e21e 2867 else {
76e3520e 2868 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
a0d0e21e
LW		 2869 pidgone(result,*statusp);
2870 if (result < 0)
2871 *statusp = -1;
2872 }
a687059c
LW		 2873 }
2874#endif
27da23d5 2875#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
dfcfdb64 2876 finish:
27da23d5 2877#endif
cddd4526
NIS		 2878 if (result < 0 && errno == EINTR) {
2879 PERL_ASYNC_CHECK();
2880 }
2881 return result;
a687059c 2882}
2986a63f 2883#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
a687059c 2884
ca0c25f6 2885#ifdef PERL_USES_PL_PIDSTATUS
7c0587c8 2886void
d8a83dd3 2887Perl_pidgone(pTHX_ Pid_t pid, int status)
a687059c 2888{
79072805 2889 register SV *sv;
a687059c 2890
12072db5 2891 sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
862a34c6 2892 SvUPGRADE(sv,SVt_IV);
45977657 2893 SvIV_set(sv, status);
20188a90 2894 return;
a687059c 2895}
ca0c25f6 2896#endif
a687059c 2897
85ca448a 2898#if defined(atarist) || defined(OS2) || defined(EPOC)
7c0587c8 2899int pclose();
ddcf38b7
IZ		 2900#ifdef HAS_FORK
2901int /* Cannot prototype with I32
2902 in os2ish.h. */
ba106d47 2903my_syspclose(PerlIO *ptr)
ddcf38b7 2904#else
79072805 2905I32
864dbfa3 2906Perl_my_pclose(pTHX_ PerlIO *ptr)
a1d180c4 2907#endif
a687059c 2908{
760ac839 2909 /* Needs work for PerlIO ! */
c4420975 2910 FILE * const f = PerlIO_findFILE(ptr);
7452cf6a 2911 const I32 result = pclose(f);
2b96b0a5
JH		 2912 PerlIO_releaseFILE(ptr,f);
2913 return result;
2914}
2915#endif
2916
933fea7f 2917#if defined(DJGPP)
2b96b0a5
JH		 2918int djgpp_pclose();
2919I32
2920Perl_my_pclose(pTHX_ PerlIO *ptr)
2921{
2922 /* Needs work for PerlIO ! */
c4420975 2923 FILE * const f = PerlIO_findFILE(ptr);
2b96b0a5 2924 I32 result = djgpp_pclose(f);
933fea7f 2925 result = (result << 8) & 0xff00;
760ac839
LW		 2926 PerlIO_releaseFILE(ptr,f);
2927 return result;
a687059c 2928}
7c0587c8 2929#endif
9f68db38
LW		 2930
2931void
864dbfa3 2932Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
9f68db38 2933{
79072805 2934 register I32 todo;
c4420975 2935 register const char * const frombase = from;
96a5add6 2936 PERL_UNUSED_CONTEXT;
9f68db38
LW		 2937
2938 if (len == 1) {
08105a92 2939 register const char c = *from;
9f68db38 2940 while (count-- > 0)
5926133d 2941 *to++ = c;
9f68db38
LW		 2942 return;
2943 }
2944 while (count-- > 0) {
2945 for (todo = len; todo > 0; todo--) {
2946 *to++ = *from++;
2947 }
2948 from = frombase;
2949 }
2950}
0f85fab0 2951
fe14fcc3 2952#ifndef HAS_RENAME
79072805 2953I32
4373e329 2954Perl_same_dirent(pTHX_ const char *a, const char *b)
62b28dd9 2955{
93a17b20
LW		 2956 char *fa = strrchr(a,'/');
2957 char *fb = strrchr(b,'/');
c623ac67
GS		 2958 Stat_t tmpstatbuf1;
2959 Stat_t tmpstatbuf2;
c4420975 2960 SV * const tmpsv = sv_newmortal();
62b28dd9
LW		 2961
2962 if (fa)
2963 fa++;
2964 else
2965 fa = a;
2966 if (fb)
2967 fb++;
2968 else
2969 fb = b;
2970 if (strNE(a,b))
2971 return FALSE;
2972 if (fa == a)
616d8c9c 2973 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2974 else
46fc3d4c 2975 sv_setpvn(tmpsv, a, fa - a);
95a20fc0 2976 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
62b28dd9
LW		 2977 return FALSE;
2978 if (fb == b)
616d8c9c 2979 sv_setpvn(tmpsv, ".", 1);
62b28dd9 2980 else
46fc3d4c 2981 sv_setpvn(tmpsv, b, fb - b);
95a20fc0 2982 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
62b28dd9
LW		 2983 return FALSE;
2984 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
2985 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
2986}
fe14fcc3
LW		 2987#endif /* !HAS_RENAME */
2988
491527d0 2989char*
7f315aed
NC		 2990Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
2991 const char *const *const search_ext, I32 flags)
491527d0 2992{
97aff369 2993 dVAR;
bd61b366
SS		 2994 const char *xfound = NULL;
2995 char *xfailed = NULL;
0f31cffe 2996 char tmpbuf[MAXPATHLEN];
491527d0 2997 register char *s;
5f74f29c 2998 I32 len = 0;
491527d0
GS		 2999 int retval;
3000#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
3001# define SEARCH_EXTS ".bat", ".cmd", NULL
3002# define MAX_EXT_LEN 4
3003#endif
3004#ifdef OS2
3005# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
3006# define MAX_EXT_LEN 4
3007#endif
3008#ifdef VMS
3009# define SEARCH_EXTS ".pl", ".com", NULL
3010# define MAX_EXT_LEN 4
3011#endif
3012 /* additional extensions to try in each dir if scriptname not found */
3013#ifdef SEARCH_EXTS
0bcc34c2 3014 static const char *const exts[] = { SEARCH_EXTS };
7f315aed 3015 const char *const *const ext = search_ext ? search_ext : exts;
491527d0 3016 int extidx = 0, i = 0;
bd61b366 3017 const char *curext = NULL;
491527d0 3018#else
53c1dcc0 3019 PERL_UNUSED_ARG(search_ext);
491527d0
GS		 3020# define MAX_EXT_LEN 0
3021#endif
3022
3023 /*
3024 * If dosearch is true and if scriptname does not contain path
3025 * delimiters, search the PATH for scriptname.
3026 *
3027 * If SEARCH_EXTS is also defined, will look for each
3028 * scriptname{SEARCH_EXTS} whenever scriptname is not found
3029 * while searching the PATH.
3030 *
3031 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
3032 * proceeds as follows:
3033 * If DOSISH or VMSISH:
3034 * + look for ./scriptname{,.foo,.bar}
3035 * + search the PATH for scriptname{,.foo,.bar}
3036 *
3037 * If !DOSISH:
3038 * + look *only* in the PATH for scriptname{,.foo,.bar} (note
3039 * this will not look in '.' if it's not in the PATH)
3040 */
84486fc6 3041 tmpbuf[0] = '\0';
491527d0
GS		 3042
3043#ifdef VMS
3044# ifdef ALWAYS_DEFTYPES
3045 len = strlen(scriptname);
3046 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
c4420975 3047 int idx = 0, deftypes = 1;
491527d0
GS		 3048 bool seen_dot = 1;
3049
bd61b366 3050 const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3051# else
3052 if (dosearch) {
c4420975 3053 int idx = 0, deftypes = 1;
491527d0
GS		 3054 bool seen_dot = 1;
3055
bd61b366 3056 const int hasdir = (strpbrk(scriptname,":[</") != NULL);
491527d0
GS		 3057# endif
3058 /* The first time through, just add SEARCH_EXTS to whatever we
3059 * already have, so we can check for default file types. */
3060 while (deftypes ||
84486fc6 3061 (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
491527d0
GS		 3062 {
3063 if (deftypes) {
3064 deftypes = 0;
84486fc6 3065 *tmpbuf = '\0';
491527d0 3066 }
84486fc6
GS		 3067 if ((strlen(tmpbuf) + strlen(scriptname)
3068 + MAX_EXT_LEN) >= sizeof tmpbuf)
491527d0 3069 continue; /* don't search dir with too-long name */
6fca0082 3070 my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
491527d0
GS		 3071#else /* !VMS */
3072
3073#ifdef DOSISH
3074 if (strEQ(scriptname, "-"))
3075 dosearch = 0;
3076 if (dosearch) { /* Look in '.' first. */
fe2774ed 3077 const char *cur = scriptname;
491527d0
GS		 3078#ifdef SEARCH_EXTS
3079 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
3080 while (ext[i])
3081 if (strEQ(ext[i++],curext)) {
3082 extidx = -1; /* already has an ext */
3083 break;
3084 }
3085 do {
3086#endif
3087 DEBUG_p(PerlIO_printf(Perl_debug_log,
3088 "Looking for %s\n",cur));
017f25f1
IZ		 3089 if (PerlLIO_stat(cur,&PL_statbuf) >= 0
3090 && !S_ISDIR(PL_statbuf.st_mode)) {
491527d0
GS		 3091 dosearch = 0;
3092 scriptname = cur;
3093#ifdef SEARCH_EXTS
3094 break;
3095#endif
3096 }
3097#ifdef SEARCH_EXTS
3098 if (cur == scriptname) {
3099 len = strlen(scriptname);
84486fc6 3100 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
491527d0 3101 break;
9e4425f7
SH		 3102 my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
3103 cur = tmpbuf;
491527d0
GS		 3104 }
3105 } while (extidx >= 0 && ext[extidx] /* try an extension? */
6fca0082 3106 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
491527d0
GS		 3107#endif
3108 }
3109#endif
3110
cd39f2b6
JH		 3111#ifdef MACOS_TRADITIONAL
3112 if (dosearch && !strchr(scriptname, ':') &&
3113 (s = PerlEnv_getenv("Commands")))
3114#else
491527d0
GS		 3115 if (dosearch && !strchr(scriptname, '/')
3116#ifdef DOSISH
3117 && !strchr(scriptname, '\\')
3118#endif
cd39f2b6
JH		 3119 && (s = PerlEnv_getenv("PATH")))
3120#endif
3121 {
491527d0 3122 bool seen_dot = 0;
92f0c265 3123
3280af22
NIS		 3124 PL_bufend = s + strlen(s);
3125 while (s < PL_bufend) {
cd39f2b6
JH		 3126#ifdef MACOS_TRADITIONAL
3127 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
3128 ',',
3129 &len);
3130#else
491527d0
GS		 3131#if defined(atarist) || defined(DOSISH)
3132 for (len = 0; *s
3133# ifdef atarist
3134 && *s != ','
3135# endif
3136 && *s != ';'; len++, s++) {
84486fc6
GS		 3137 if (len < sizeof tmpbuf)
3138 tmpbuf[len] = *s;
491527d0 3139 }
84486fc6
GS		 3140 if (len < sizeof tmpbuf)
3141 tmpbuf[len] = '\0';
491527d0 3142#else /* ! (atarist || DOSISH) */
3280af22 3143 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
491527d0
GS		 3144 ':',
3145 &len);
3146#endif /* ! (atarist || DOSISH) */
cd39f2b6 3147#endif /* MACOS_TRADITIONAL */
3280af22 3148 if (s < PL_bufend)
491527d0 3149 s++;
84486fc6 3150 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
491527d0 3151 continue; /* don't search dir with too-long name */
cd39f2b6
JH		 3152#ifdef MACOS_TRADITIONAL
3153 if (len && tmpbuf[len - 1] != ':')
3154 tmpbuf[len++] = ':';
3155#else
491527d0 3156 if (len
490a0e98 3157# if defined(atarist) || defined(__MINT__) || defined(DOSISH)
84486fc6
GS		 3158 && tmpbuf[len - 1] != '/'
3159 && tmpbuf[len - 1] != '\\'
490a0e98 3160# endif
491527d0 3161 )
84486fc6
GS		 3162 tmpbuf[len++] = '/';
3163 if (len == 2 && tmpbuf[0] == '.')
491527d0 3164 seen_dot = 1;
cd39f2b6 3165#endif
28f0d0ec 3166 (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
491527d0
GS		 3167#endif /* !VMS */
3168
3169#ifdef SEARCH_EXTS
84486fc6 3170 len = strlen(tmpbuf);
491527d0
GS		 3171 if (extidx > 0) /* reset after previous loop */
3172 extidx = 0;
3173 do {
3174#endif
84486fc6 3175 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
3280af22 3176 retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
017f25f1
IZ		 3177 if (S_ISDIR(PL_statbuf.st_mode)) {
3178 retval = -1;
3179 }
491527d0
GS		 3180#ifdef SEARCH_EXTS
3181 } while ( retval < 0 /* not there */
3182 && extidx>=0 && ext[extidx] /* try an extension? */
6fca0082 3183 && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
491527d0
GS		 3184 );
3185#endif
3186 if (retval < 0)
3187 continue;
3280af22
NIS		 3188 if (S_ISREG(PL_statbuf.st_mode)
3189 && cando(S_IRUSR,TRUE,&PL_statbuf)
73811745 3190#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
3280af22 3191 && cando(S_IXUSR,TRUE,&PL_statbuf)
491527d0
GS		 3192#endif
3193 )
3194 {
3aed30dc 3195 xfound = tmpbuf; /* bingo! */
491527d0
GS		 3196 break;
3197 }
3198 if (!xfailed)
84486fc6 3199 xfailed = savepv(tmpbuf);
491527d0
GS		 3200 }
3201#ifndef DOSISH
017f25f1 3202 if (!xfound && !seen_dot && !xfailed &&
a1d180c4 3203 (PerlLIO_stat(scriptname,&PL_statbuf) < 0
017f25f1 3204 || S_ISDIR(PL_statbuf.st_mode)))
491527d0
GS		 3205#endif
3206 seen_dot = 1; /* Disable message. */
9ccb31f9
GS		 3207 if (!xfound) {
3208 if (flags & 1) { /* do or die? */
3aed30dc 3209 Perl_croak(aTHX_ "Can't %s %s%s%s",
9ccb31f9
GS		 3210 (xfailed ? "execute" : "find"),
3211 (xfailed ? xfailed : scriptname),
3212 (xfailed ? "" : " on PATH"),
3213 (xfailed || seen_dot) ? "" : ", '.' not in PATH");
3214 }
bd61b366 3215 scriptname = NULL;
9ccb31f9 3216 }
43c5f42d 3217 Safefree(xfailed);
491527d0
GS		 3218 scriptname = xfound;
3219 }
bd61b366 3220 return (scriptname ? savepv(scriptname) : NULL);
491527d0
GS		 3221}
3222
ba869deb
GS		 3223#ifndef PERL_GET_CONTEXT_DEFINED
3224
3225void *
3226Perl_get_context(void)
3227{
27da23d5 3228 dVAR;
3db8f154 3229#if defined(USE_ITHREADS)
ba869deb
GS		 3230# ifdef OLD_PTHREADS_API
3231 pthread_addr_t t;
3232 if (pthread_getspecific(PL_thr_key, &t))
3233 Perl_croak_nocontext("panic: pthread_getspecific");
3234 return (void*)t;
3235# else
bce813aa 3236# ifdef I_MACH_CTHREADS
8b8b35ab 3237 return (void*)cthread_data(cthread_self());
bce813aa 3238# else
8b8b35ab
JH		 3239 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
3240# endif
c44d3fdb 3241# endif
ba869deb
GS		 3242#else
3243 return (void*)NULL;
3244#endif
3245}
3246
3247void
3248Perl_set_context(void *t)
3249{
8772537c 3250 dVAR;
3db8f154 3251#if defined(USE_ITHREADS)
c44d3fdb
GS		 3252# ifdef I_MACH_CTHREADS
3253 cthread_set_data(cthread_self(), t);
3254# else
ba869deb
GS		 3255 if (pthread_setspecific(PL_thr_key, t))
3256 Perl_croak_nocontext("panic: pthread_setspecific");
c44d3fdb 3257# endif
b464bac0 3258#else
8772537c 3259 PERL_UNUSED_ARG(t);
ba869deb
GS		 3260#endif
3261}
3262
3263#endif /* !PERL_GET_CONTEXT_DEFINED */
491527d0 3264
27da23d5 3265#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
22239a37 3266struct perl_vars *
864dbfa3 3267Perl_GetVars(pTHX)
22239a37 3268{
533c011a 3269 return &PL_Vars;
22239a37 3270}
31fb1209
NIS		 3271#endif
3272
1cb0ed9b 3273char **
864dbfa3 3274Perl_get_op_names(pTHX)
31fb1209 3275{
96a5add6
AL		 3276 PERL_UNUSED_CONTEXT;
3277 return (char **)PL_op_name;
31fb1209
NIS		 3278}
3279
1cb0ed9b 3280char **
864dbfa3 3281Perl_get_op_descs(pTHX)
31fb1209 3282{
96a5add6
AL		 3283 PERL_UNUSED_CONTEXT;
3284 return (char **)PL_op_desc;
31fb1209 3285}
9e6b2b00 3286
e1ec3a88 3287const char *
864dbfa3 3288Perl_get_no_modify(pTHX)
9e6b2b00 3289{
96a5add6
AL		 3290 PERL_UNUSED_CONTEXT;
3291 return PL_no_modify;
9e6b2b00
GS		 3292}
3293
3294U32 *
864dbfa3 3295Perl_get_opargs(pTHX)
9e6b2b00 3296{
96a5add6
AL		 3297 PERL_UNUSED_CONTEXT;
3298 return (U32 *)PL_opargs;
9e6b2b00 3299}
51aa15f3 3300
0cb96387
GS		 3301PPADDR_t*
3302Perl_get_ppaddr(pTHX)
3303{
96a5add6
AL		 3304 dVAR;
3305 PERL_UNUSED_CONTEXT;
3306 return (PPADDR_t*)PL_ppaddr;
0cb96387
GS		 3307}
3308
a6c40364
GS		 3309#ifndef HAS_GETENV_LEN
3310char *
bf4acbe4 3311Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
a6c40364 3312{
8772537c 3313 char * const env_trans = PerlEnv_getenv(env_elem);
96a5add6 3314 PERL_UNUSED_CONTEXT;
a6c40364
GS		 3315 if (env_trans)
3316 *len = strlen(env_trans);
3317 return env_trans;
f675dbe5
CB		 3318}
3319#endif
3320
dc9e4912
GS		 3321
3322MGVTBL*
864dbfa3 3323Perl_get_vtbl(pTHX_ int vtbl_id)
dc9e4912 3324{
7452cf6a 3325 const MGVTBL* result;
96a5add6 3326 PERL_UNUSED_CONTEXT;
dc9e4912
GS		 3327
3328 switch(vtbl_id) {
3329 case want_vtbl_sv:
3330 result = &PL_vtbl_sv;
3331 break;
3332 case want_vtbl_env:
3333 result = &PL_vtbl_env;
3334 break;
3335 case want_vtbl_envelem:
3336 result = &PL_vtbl_envelem;
3337 break;
3338 case want_vtbl_sig:
3339 result = &PL_vtbl_sig;
3340 break;
3341 case want_vtbl_sigelem:
3342 result = &PL_vtbl_sigelem;
3343 break;
3344 case want_vtbl_pack:
3345 result = &PL_vtbl_pack;
3346 break;
3347 case want_vtbl_packelem:
3348 result = &PL_vtbl_packelem;
3349 break;
3350 case want_vtbl_dbline:
3351 result = &PL_vtbl_dbline;
3352 break;
3353 case want_vtbl_isa:
3354 result = &PL_vtbl_isa;
3355 break;
3356 case want_vtbl_isaelem:
3357 result = &PL_vtbl_isaelem;
3358 break;
3359 case want_vtbl_arylen:
3360 result = &PL_vtbl_arylen;
3361 break;
dc9e4912
GS		 3362 case want_vtbl_mglob:
3363 result = &PL_vtbl_mglob;
3364 break;
3365 case want_vtbl_nkeys:
3366 result = &PL_vtbl_nkeys;
3367 break;
3368 case want_vtbl_taint:
3369 result = &PL_vtbl_taint;
3370 break;
3371 case want_vtbl_substr:
3372 result = &PL_vtbl_substr;
3373 break;
3374 case want_vtbl_vec:
3375 result = &PL_vtbl_vec;
3376 break;
3377 case want_vtbl_pos:
3378 result = &PL_vtbl_pos;
3379 break;
3380 case want_vtbl_bm:
3381 result = &PL_vtbl_bm;
3382 break;
3383 case want_vtbl_fm:
3384 result = &PL_vtbl_fm;
3385 break;
3386 case want_vtbl_uvar:
3387 result = &PL_vtbl_uvar;
3388 break;
dc9e4912
GS		 3389 case want_vtbl_defelem:
3390 result = &PL_vtbl_defelem;
3391 break;
3392 case want_vtbl_regexp:
3393 result = &PL_vtbl_regexp;
3394 break;
3395 case want_vtbl_regdata:
3396 result = &PL_vtbl_regdata;
3397 break;
3398 case want_vtbl_regdatum:
3399 result = &PL_vtbl_regdatum;
3400 break;
3c90161d 3401#ifdef USE_LOCALE_COLLATE
dc9e4912
GS		 3402 case want_vtbl_collxfrm:
3403 result = &PL_vtbl_collxfrm;
3404 break;
3c90161d 3405#endif
dc9e4912
GS		 3406 case want_vtbl_amagic:
3407 result = &PL_vtbl_amagic;
3408 break;
3409 case want_vtbl_amagicelem:
3410 result = &PL_vtbl_amagicelem;
3411 break;
810b8aa5
GS		 3412 case want_vtbl_backref:
3413 result = &PL_vtbl_backref;
3414 break;
7e8c5dac
HS		 3415 case want_vtbl_utf8:
3416 result = &PL_vtbl_utf8;
3417 break;
7452cf6a 3418 default:
4608196e 3419 result = NULL;
7452cf6a 3420 break;
dc9e4912 3421 }
27da23d5 3422 return (MGVTBL*)result;
dc9e4912
GS		 3423}
3424
767df6a1 3425I32
864dbfa3 3426Perl_my_fflush_all(pTHX)
767df6a1 3427{
f800e14d 3428#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
ce720889 3429 return PerlIO_flush(NULL);
767df6a1 3430#else
8fbdfb7c 3431# if defined(HAS__FWALK)
f13a2bc0 3432 extern int fflush(FILE *);
74cac757
JH		 3433 /* undocumented, unprototyped, but very useful BSDism */
3434 extern void _fwalk(int (*)(FILE *));
8fbdfb7c 3435 _fwalk(&fflush);
74cac757 3436 return 0;
8fa7f367 3437# else
8fbdfb7c 3438# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
8fa7f367 3439 long open_max = -1;
8fbdfb7c 3440# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
d2201af2 3441 open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
8fbdfb7c 3442# else
8fa7f367 3443# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
767df6a1 3444 open_max = sysconf(_SC_OPEN_MAX);
8fa7f367
JH		 3445# else
3446# ifdef FOPEN_MAX
74cac757 3447 open_max = FOPEN_MAX;
8fa7f367
JH		 3448# else
3449# ifdef OPEN_MAX
74cac757 3450 open_max = OPEN_MAX;
8fa7f367
JH		 3451# else
3452# ifdef _NFILE
d2201af2 3453 open_max = _NFILE;
8fa7f367
JH		 3454# endif
3455# endif
74cac757 3456# endif
767df6a1
JH		 3457# endif
3458# endif
767df6a1
JH		 3459 if (open_max > 0) {
3460 long i;
3461 for (i = 0; i < open_max; i++)
d2201af2
AD		 3462 if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
3463 STDIO_STREAM_ARRAY[i]._file < open_max &&
3464 STDIO_STREAM_ARRAY[i]._flag)
3465 PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
767df6a1
JH		 3466 return 0;
3467 }
8fbdfb7c 3468# endif
93189314 3469 SETERRNO(EBADF,RMS_IFI);
767df6a1 3470 return EOF;
74cac757 3471# endif
767df6a1
JH		 3472#endif
3473}
097ee67d 3474
69282e91 3475void
e1ec3a88 3476Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
bc37a18f 3477{
b64e5050 3478 const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
66fc2fa5 3479
4c80c0b2 3480 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
3aed30dc 3481 if (ckWARN(WARN_IO)) {
10edeb5d
JH		 3482 const char * const direction =
3483 (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
3aed30dc
HS		 3484 if (name && *name)
3485 Perl_warner(aTHX_ packWARN(WARN_IO),
3486 "Filehandle %s opened only for %sput",
fd322ea4 3487 name, direction);
3aed30dc
HS		 3488 else
3489 Perl_warner(aTHX_ packWARN(WARN_IO),
fd322ea4 3490 "Filehandle opened only for %sput", direction);
3aed30dc 3491 }
2dd78f96
JH		 3492 }
3493 else {
e1ec3a88 3494 const char *vile;
3aed30dc
HS		 3495 I32 warn_type;
3496
3497 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
3498 vile = "closed";
3499 warn_type = WARN_CLOSED;
3500 }
3501 else {
3502 vile = "unopened";
3503 warn_type = WARN_UNOPENED;
3504 }
3505
3506 if (ckWARN(warn_type)) {
10edeb5d
JH		 3507 const char * const pars =
3508 (const char *)(OP_IS_FILETEST(op) ? "" : "()");
f0a09b71 3509 const char * const func =
10edeb5d
JH		 3510 (const char *)
3511 (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
3512 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
3513 op < 0 ? "" : /* handle phoney cases */
3514 PL_op_desc[op]);
3515 const char * const type =
3516 (const char *)
3517 (OP_IS_SOCKET(op) ||
3518 (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
3519 "socket" : "filehandle");
3aed30dc
HS		 3520 if (name && *name) {
3521 Perl_warner(aTHX_ packWARN(warn_type),
3522 "%s%s on %s %s %s", func, pars, vile, type, name);
3523 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3524 Perl_warner(
3525 aTHX_ packWARN(warn_type),
3526 "\t(Are you trying to call %s%s on dirhandle %s?)\n",
3527 func, pars, name
3528 );
3529 }
3530 else {
3531 Perl_warner(aTHX_ packWARN(warn_type),
3532 "%s%s on %s %s", func, pars, vile, type);
3533 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
3534 Perl_warner(
3535 aTHX_ packWARN(warn_type),
3536 "\t(Are you trying to call %s%s on dirhandle?)\n",
3537 func, pars
3538 );
3539 }
3540 }
bc37a18f 3541 }
69282e91 3542}
a926ef6b
JH		 3543
3544#ifdef EBCDIC
cbebf344
JH		 3545/* in ASCII order, not that it matters */
3546static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
3547
a926ef6b
JH		 3548int
3549Perl_ebcdic_control(pTHX_ int ch)
3550{
3aed30dc 3551 if (ch > 'a') {
e1ec3a88 3552 const char *ctlp;
3aed30dc
HS		 3553
3554 if (islower(ch))
3555 ch = toupper(ch);
3556
3557 if ((ctlp = strchr(controllablechars, ch)) == 0) {
3558 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
a926ef6b 3559 }
3aed30dc
HS		 3560
3561 if (ctlp == controllablechars)
3562 return('\177'); /* DEL */
3563 else
3564 return((unsigned char)(ctlp - controllablechars - 1));
3565 } else { /* Want uncontrol */
3566 if (ch == '\177' || ch == -1)
3567 return('?');
3568 else if (ch == '\157')
3569 return('\177');
3570 else if (ch == '\174')
3571 return('\000');
3572 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */
3573 return('\036');
3574 else if (ch == '\155')
3575 return('\037');
3576 else if (0 < ch && ch < (sizeof(controllablechars) - 1))
3577 return(controllablechars[ch+1]);
3578 else
3579 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF);
3580 }
a926ef6b
JH		 3581}
3582#endif
e72cf795 3583
f6adc668 3584/* To workaround core dumps from the uninitialised tm_zone we get the
e72cf795
JH		 3585 * system to give us a reasonable struct to copy. This fix means that
3586 * strftime uses the tm_zone and tm_gmtoff values returned by
3587 * localtime(time()). That should give the desired result most of the
3588 * time. But probably not always!
3589 *
f6adc668
JH		 3590 * This does not address tzname aspects of NETaa14816.
3591 *
e72cf795 3592 */
f6adc668 3593
e72cf795
JH		 3594#ifdef HAS_GNULIBC
3595# ifndef STRUCT_TM_HASZONE
3596# define STRUCT_TM_HASZONE
3597# endif
3598#endif
3599
f6adc668
JH		 3600#ifdef STRUCT_TM_HASZONE /* Backward compat */
3601# ifndef HAS_TM_TM_ZONE
3602# define HAS_TM_TM_ZONE
3603# endif
3604#endif
3605
e72cf795 3606void
f1208910 3607Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */
e72cf795 3608{
f6adc668 3609#ifdef HAS_TM_TM_ZONE
e72cf795 3610 Time_t now;
1b6737cc 3611 const struct tm* my_tm;
e72cf795 3612 (void)time(&now);
82c57498 3613 my_tm = localtime(&now);
ca46b8ee
SP		 3614 if (my_tm)
3615 Copy(my_tm, ptm, 1, struct tm);
1b6737cc
AL		 3616#else
3617 PERL_UNUSED_ARG(ptm);
e72cf795
JH		 3618#endif
3619}
3620
3621/*
3622 * mini_mktime - normalise struct tm values without the localtime()
3623 * semantics (and overhead) of mktime().
3624 */
3625void
f1208910 3626Perl_mini_mktime(pTHX_ struct tm *ptm)
e72cf795
JH		 3627{
3628 int yearday;
3629 int secs;
3630 int month, mday, year, jday;
3631 int odd_cent, odd_year;
96a5add6 3632 PERL_UNUSED_CONTEXT;
e72cf795
JH		 3633
3634#define DAYS_PER_YEAR 365
3635#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
3636#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
3637#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
3638#define SECS_PER_HOUR (60*60)
3639#define SECS_PER_DAY (24*SECS_PER_HOUR)
3640/* parentheses deliberately absent on these two, otherwise they don't work */
3641#define MONTH_TO_DAYS 153/5
3642#define DAYS_TO_MONTH 5/153
3643/* offset to bias by March (month 4) 1st between month/mday & year finding */
3644#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
3645/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
3646#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
3647
3648/*
3649 * Year/day algorithm notes:
3650 *
3651 * With a suitable offset for numeric value of the month, one can find
3652 * an offset into the year by considering months to have 30.6 (153/5) days,
3653 * using integer arithmetic (i.e., with truncation). To avoid too much
3654 * messing about with leap days, we consider January and February to be
3655 * the 13th and 14th month of the previous year. After that transformation,
3656 * we need the month index we use to be high by 1 from 'normal human' usage,
3657 * so the month index values we use run from 4 through 15.
3658 *
3659 * Given that, and the rules for the Gregorian calendar (leap years are those
3660 * divisible by 4 unless also divisible by 100, when they must be divisible
3661 * by 400 instead), we can simply calculate the number of days since some
3662 * arbitrary 'beginning of time' by futzing with the (adjusted) year number,
3663 * the days we derive from our month index, and adding in the day of the
3664 * month. The value used here is not adjusted for the actual origin which
3665 * it normally would use (1 January A.D. 1), since we're not exposing it.
3666 * We're only building the value so we can turn around and get the
3667 * normalised values for the year, month, day-of-month, and day-of-year.
3668 *
3669 * For going backward, we need to bias the value we're using so that we find
3670 * the right year value. (Basically, we don't want the contribution of
3671 * March 1st to the number to apply while deriving the year). Having done
3672 * that, we 'count up' the contribution to the year number by accounting for
3673 * full quadracenturies (400-year periods) with their extra leap days, plus
3674 * the contribution from full centuries (to avoid counting in the lost leap
3675 * days), plus the contribution from full quad-years (to count in the normal
3676 * leap days), plus the leftover contribution from any non-leap years.
3677 * At this point, if we were working with an actual leap day, we'll have 0
3678 * days left over. This is also true for March 1st, however. So, we have
3679 * to special-case that result, and (earlier) keep track of the 'odd'
3680 * century and year contributions. If we got 4 extra centuries in a qcent,
3681 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb.
3682 * Otherwise, we add back in the earlier bias we removed (the 123 from
3683 * figuring in March 1st), find the month index (integer division by 30.6),
3684 * and the remainder is the day-of-month. We then have to convert back to
3685 * 'real' months (including fixing January and February from being 14/15 in
3686 * the previous year to being in the proper year). After that, to get
3687 * tm_yday, we work with the normalised year and get a new yearday value for
3688 * January 1st, which we subtract from the yearday value we had earlier,
3689 * representing the date we've re-built. This is done from January 1
3690 * because tm_yday is 0-origin.
3691 *
3692 * Since POSIX time routines are only guaranteed to work for times since the
3693 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm
3694 * applies Gregorian calendar rules even to dates before the 16th century
3695 * doesn't bother me. Besides, you'd need cultural context for a given
3696 * date to know whether it was Julian or Gregorian calendar, and that's
3697 * outside the scope for this routine. Since we convert back based on the
3698 * same rules we used to build the yearday, you'll only get strange results
3699 * for input which needed normalising, or for the 'odd' century years which
3700 * were leap years in the Julian calander but not in the Gregorian one.
3701 * I can live with that.
3702 *
3703 * This algorithm also fails to handle years before A.D. 1 gracefully, but
3704 * that's still outside the scope for POSIX time manipulation, so I don't
3705 * care.
3706 */
3707
3708 year = 1900 + ptm->tm_year;
3709 month = ptm->tm_mon;
3710 mday = ptm->tm_mday;
3711 /* allow given yday with no month & mday to dominate the result */
3712 if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) {
3713 month = 0;
3714 mday = 0;
3715 jday = 1 + ptm->tm_yday;
3716 }
3717 else {
3718 jday = 0;
3719 }
3720 if (month >= 2)
3721 month+=2;
3722 else
3723 month+=14, year--;
3724 yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
3725 yearday += month*MONTH_TO_DAYS + mday + jday;
3726 /*
3727 * Note that we don't know when leap-seconds were or will be,
3728 * so we have to trust the user if we get something which looks
3729 * like a sensible leap-second. Wild values for seconds will
3730 * be rationalised, however.
3731 */
3732 if ((unsigned) ptm->tm_sec <= 60) {
3733 secs = 0;
3734 }
3735 else {
3736 secs = ptm->tm_sec;
3737 ptm->tm_sec = 0;
3738 }
3739 secs += 60 * ptm->tm_min;
3740 secs += SECS_PER_HOUR * ptm->tm_hour;
3741 if (secs < 0) {
3742 if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
3743 /* got negative remainder, but need positive time */
3744 /* back off an extra day to compensate */
3745 yearday += (secs/SECS_PER_DAY)-1;
3746 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
3747 }
3748 else {
3749 yearday += (secs/SECS_PER_DAY);
3750 secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
3751 }
3752 }
3753 else if (secs >= SECS_PER_DAY) {
3754 yearday += (secs/SECS_PER_DAY);
3755 secs %= SECS_PER_DAY;
3756 }
3757 ptm->tm_hour = secs/SECS_PER_HOUR;
3758 secs %= SECS_PER_HOUR;
3759 ptm->tm_min = secs/60;
3760 secs %= 60;
3761 ptm->tm_sec += secs;
3762 /* done with time of day effects */
3763 /*
3764 * The algorithm for yearday has (so far) left it high by 428.
3765 * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to
3766 * bias it by 123 while trying to figure out what year it
3767 * really represents. Even with this tweak, the reverse
3768 * translation fails for years before A.D. 0001.
3769 * It would still fail for Feb 29, but we catch that one below.
3770 */
3771 jday = yearday; /* save for later fixup vis-a-vis Jan 1 */
3772 yearday -= YEAR_ADJUST;
3773 year = (yearday / DAYS_PER_QCENT) * 400;
3774 yearday %= DAYS_PER_QCENT;
3775 odd_cent = yearday / DAYS_PER_CENT;
3776 year += odd_cent * 100;
3777 yearday %= DAYS_PER_CENT;
3778 year += (yearday / DAYS_PER_QYEAR) * 4;
3779 yearday %= DAYS_PER_QYEAR;
3780 odd_year = yearday / DAYS_PER_YEAR;
3781 year += odd_year;
3782 yearday %= DAYS_PER_YEAR;
3783 if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
3784 month = 1;
3785 yearday = 29;
3786 }
3787 else {
3788 yearday += YEAR_ADJUST; /* recover March 1st crock */
3789 month = yearday*DAYS_TO_MONTH;
3790 yearday -= month*MONTH_TO_DAYS;
3791 /* recover other leap-year adjustment */
3792 if (month > 13) {
3793 month-=14;
3794 year++;
3795 }
3796 else {
3797 month-=2;
3798 }
3799 }
3800 ptm->tm_year = year - 1900;
3801 if (yearday) {
3802 ptm->tm_mday = yearday;
3803 ptm->tm_mon = month;
3804 }
3805 else {
3806 ptm->tm_mday = 31;
3807 ptm->tm_mon = month - 1;
3808 }
3809 /* re-build yearday based on Jan 1 to get tm_yday */
3810 year--;
3811 yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400;
3812 yearday += 14*MONTH_TO_DAYS + 1;
3813 ptm->tm_yday = jday - yearday;
3814 /* fix tm_wday if not overridden by caller */
3815 if ((unsigned)ptm->tm_wday > 6)
3816 ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7;
3817}
b3c85772
JH		 3818
3819char *
e1ec3a88 3820Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst)
b3c85772
JH		 3821{
3822#ifdef HAS_STRFTIME
3823 char *buf;
3824 int buflen;
3825 struct tm mytm;
3826 int len;
3827
3828 init_tm(&mytm); /* XXX workaround - see init_tm() above */
3829 mytm.tm_sec = sec;
3830 mytm.tm_min = min;
3831 mytm.tm_hour = hour;
3832 mytm.tm_mday = mday;
3833 mytm.tm_mon = mon;
3834 mytm.tm_year = year;
3835 mytm.tm_wday = wday;
3836 mytm.tm_yday = yday;
3837 mytm.tm_isdst = isdst;
3838 mini_mktime(&mytm);
c473feec
SR		 3839 /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
3840#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
3841 STMT_START {
3842 struct tm mytm2;
3843 mytm2 = mytm;
3844 mktime(&mytm2);
3845#ifdef HAS_TM_TM_GMTOFF
3846 mytm.tm_gmtoff = mytm2.tm_gmtoff;
3847#endif
3848#ifdef HAS_TM_TM_ZONE
3849 mytm.tm_zone = mytm2.tm_zone;
3850#endif
3851 } STMT_END;
3852#endif
b3c85772 3853 buflen = 64;
a02a5408 3854 Newx(buf, buflen, char);
b3c85772
JH		 3855 len = strftime(buf, buflen, fmt, &mytm);
3856 /*
877f6a72 3857 ** The following is needed to handle to the situation where
b3c85772
JH		 3858 ** tmpbuf overflows. Basically we want to allocate a buffer
3859 ** and try repeatedly. The reason why it is so complicated
3860 ** is that getting a return value of 0 from strftime can indicate
3861 ** one of the following:
3862 ** 1. buffer overflowed,
3863 ** 2. illegal conversion specifier, or
3864 ** 3. the format string specifies nothing to be returned(not
3865 ** an error). This could be because format is an empty string
3866 ** or it specifies %p that yields an empty string in some locale.
3867 ** If there is a better way to make it portable, go ahead by
3868 ** all means.
3869 */
3870 if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
3871 return buf;
3872 else {
3873 /* Possibly buf overflowed - try again with a bigger buf */
e1ec3a88 3874 const int fmtlen = strlen(fmt);
7743c307 3875 int bufsize = fmtlen + buflen;
877f6a72 3876
a02a5408 3877 Newx(buf, bufsize, char);
b3c85772
JH		 3878 while (buf) {
3879 buflen = strftime(buf, bufsize, fmt, &mytm);
3880 if (buflen > 0 && buflen < bufsize)
3881 break;
3882 /* heuristic to prevent out-of-memory errors */
3883 if (bufsize > 100*fmtlen) {
3884 Safefree(buf);
3885 buf = NULL;
3886 break;
3887 }
7743c307
SH		 3888 bufsize *= 2;
3889 Renew(buf, bufsize, char);
b3c85772
JH		 3890 }
3891 return buf;
3892 }
3893#else
3894 Perl_croak(aTHX_ "panic: no strftime");
27da23d5 3895 return NULL;
b3c85772
JH		 3896#endif
3897}
3898
877f6a72
NIS		 3899
3900#define SV_CWD_RETURN_UNDEF \
3901sv_setsv(sv, &PL_sv_undef); \
3902return FALSE
3903
3904#define SV_CWD_ISDOT(dp) \
3905 (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
3aed30dc 3906 (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
877f6a72
NIS		 3907
3908/*
ccfc67b7
JH		 3909=head1 Miscellaneous Functions
3910
89423764 3911=for apidoc getcwd_sv
877f6a72
NIS		 3912
3913Fill the sv with current working directory
3914
3915=cut
3916*/
3917
3918/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
3919 * rewritten again by dougm, optimized for use with xs TARG, and to prefer
3920 * getcwd(3) if available
3921 * Comments from the orignal:
3922 * This is a faster version of getcwd. It's also more dangerous
3923 * because you might chdir out of a directory that you can't chdir
3924 * back into. */
3925
877f6a72 3926int
89423764 3927Perl_getcwd_sv(pTHX_ register SV *sv)
877f6a72
NIS		 3928{
3929#ifndef PERL_MICRO
97aff369 3930 dVAR;
ea715489
JH		 3931#ifndef INCOMPLETE_TAINTS
3932 SvTAINTED_on(sv);
3933#endif
3934
8f95b30d
JH		 3935#ifdef HAS_GETCWD
3936 {
60e110a8
DM		 3937 char buf[MAXPATHLEN];
3938
3aed30dc 3939 /* Some getcwd()s automatically allocate a buffer of the given
60e110a8
DM		 3940 * size from the heap if they are given a NULL buffer pointer.
3941 * The problem is that this behaviour is not portable. */
3aed30dc 3942 if (getcwd(buf, sizeof(buf) - 1)) {
42d9b98d 3943 sv_setpv(sv, buf);
3aed30dc
HS		 3944 return TRUE;
3945 }
3946 else {
3947 sv_setsv(sv, &PL_sv_undef);
3948 return FALSE;
3949 }
8f95b30d
JH		 3950 }
3951
3952#else
3953
c623ac67 3954 Stat_t statbuf;
877f6a72 3955 int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
4373e329 3956 int pathlen=0;
877f6a72 3957 Direntry_t *dp;
877f6a72 3958
862a34c6 3959 SvUPGRADE(sv, SVt_PV);
877f6a72 3960
877f6a72 3961 if (PerlLIO_lstat(".", &statbuf) < 0) {
3aed30dc 3962 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 3963 }
3964
3965 orig_cdev = statbuf.st_dev;
3966 orig_cino = statbuf.st_ino;
3967 cdev = orig_cdev;
3968 cino = orig_cino;
3969
3970 for (;;) {
4373e329 3971 DIR *dir;
3aed30dc
HS		 3972 odev = cdev;
3973 oino = cino;
3974
3975 if (PerlDir_chdir("..") < 0) {
3976 SV_CWD_RETURN_UNDEF;
3977 }
3978 if (PerlLIO_stat(".", &statbuf) < 0) {
3979 SV_CWD_RETURN_UNDEF;
3980 }
3981
3982 cdev = statbuf.st_dev;
3983 cino = statbuf.st_ino;
3984
3985 if (odev == cdev && oino == cino) {
3986 break;
3987 }
3988 if (!(dir = PerlDir_open("."))) {
3989 SV_CWD_RETURN_UNDEF;
3990 }
3991
3992 while ((dp = PerlDir_read(dir)) != NULL) {
877f6a72 3993#ifdef DIRNAMLEN
4373e329 3994 const int namelen = dp->d_namlen;
877f6a72 3995#else
4373e329 3996 const int namelen = strlen(dp->d_name);
877f6a72 3997#endif
3aed30dc
HS		 3998 /* skip . and .. */
3999 if (SV_CWD_ISDOT(dp)) {
4000 continue;
4001 }
4002
4003 if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
4004 SV_CWD_RETURN_UNDEF;
4005 }
4006
4007 tdev = statbuf.st_dev;
4008 tino = statbuf.st_ino;
4009 if (tino == oino && tdev == odev) {
4010 break;
4011 }
cb5953d6
JH		 4012 }
4013
3aed30dc
HS		 4014 if (!dp) {
4015 SV_CWD_RETURN_UNDEF;
4016 }
4017
4018 if (pathlen + namelen + 1 >= MAXPATHLEN) {
4019 SV_CWD_RETURN_UNDEF;
4020 }
877f6a72 4021
3aed30dc
HS		 4022 SvGROW(sv, pathlen + namelen + 1);
4023
4024 if (pathlen) {
4025 /* shift down */
95a20fc0 4026 Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
3aed30dc 4027 }
877f6a72 4028
3aed30dc
HS		 4029 /* prepend current directory to the front */
4030 *SvPVX(sv) = '/';
4031 Move(dp->d_name, SvPVX(sv)+1, namelen, char);
4032 pathlen += (namelen + 1);
877f6a72
NIS		 4033
4034#ifdef VOID_CLOSEDIR
3aed30dc 4035 PerlDir_close(dir);
877f6a72 4036#else
3aed30dc
HS		 4037 if (PerlDir_close(dir) < 0) {
4038 SV_CWD_RETURN_UNDEF;
4039 }
877f6a72
NIS		 4040#endif
4041 }
4042
60e110a8 4043 if (pathlen) {
3aed30dc
HS		 4044 SvCUR_set(sv, pathlen);
4045 *SvEND(sv) = '\0';
4046 SvPOK_only(sv);
877f6a72 4047
95a20fc0 4048 if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
3aed30dc
HS		 4049 SV_CWD_RETURN_UNDEF;
4050 }
877f6a72
NIS		 4051 }
4052 if (PerlLIO_stat(".", &statbuf) < 0) {
3aed30dc 4053 SV_CWD_RETURN_UNDEF;
877f6a72
NIS		 4054 }
4055
4056 cdev = statbuf.st_dev;
4057 cino = statbuf.st_ino;
4058
4059 if (cdev != orig_cdev || cino != orig_cino) {
3aed30dc
HS		 4060 Perl_croak(aTHX_ "Unstable directory path, "
4061 "current directory changed unexpectedly");
877f6a72 4062 }
877f6a72
NIS		 4063
4064 return TRUE;
793b8d8e
JH		 4065#endif
4066
877f6a72
NIS		 4067#else
4068 return FALSE;
4069#endif
4070}
4071
f4758303 4072/*
b0f01acb
JP		 4073=for apidoc scan_version
4074
4075Returns a pointer to the next character after the parsed
4076version string, as well as upgrading the passed in SV to
4077an RV.
4078
4079Function must be called with an already existing SV like
4080
137d6fc0
JP		 4081 sv = newSV(0);
4082 s = scan_version(s,SV *sv, bool qv);
b0f01acb
JP		 4083
4084Performs some preprocessing to the string to ensure that
4085it has the correct characteristics of a version. Flags the
4086object if it contains an underscore (which denotes this
137d6fc0
JP		 4087is a alpha version). The boolean qv denotes that the version
4088should be interpreted as if it had multiple decimals, even if
4089it doesn't.
b0f01acb
JP		 4090
4091=cut
4092*/
4093
9137345a 4094const char *
e1ec3a88 4095Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
b0f01acb 4096{
e0218a61 4097 const char *start;
9137345a
JP		 4098 const char *pos;
4099 const char *last;
4100 int saw_period = 0;
cb5772bb 4101 int alpha = 0;
9137345a 4102 int width = 3;
7452cf6a
AL		 4103 AV * const av = newAV();
4104 SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
9137345a 4105 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
cb5772bb 4106
3a242bf8
NC		 4107#ifndef NODEFAULT_SHAREKEYS
4108 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4109#endif
9137345a 4110
e0218a61
JP		 4111 while (isSPACE(*s)) /* leading whitespace is OK */
4112 s++;
4113
9137345a
JP		 4114 if (*s == 'v') {
4115 s++; /* get past 'v' */
4116 qv = 1; /* force quoted version processing */
4117 }
4118
e0218a61 4119 start = last = pos = s;
9137345a
JP		 4120
4121 /* pre-scan the input string to check for decimals/underbars */
ad63d80f
JP		 4122 while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) )
4123 {
4124 if ( *pos == '.' )
4125 {
cb5772bb 4126 if ( alpha )
5f89c282 4127 Perl_croak(aTHX_ "Invalid version format (underscores before decimal)");
ad63d80f 4128 saw_period++ ;
9137345a 4129 last = pos;
46314c13 4130 }
ad63d80f
JP		 4131 else if ( *pos == '_' )
4132 {
cb5772bb 4133 if ( alpha )
5f89c282 4134 Perl_croak(aTHX_ "Invalid version format (multiple underscores)");
cb5772bb 4135 alpha = 1;
9137345a 4136 width = pos - last - 1; /* natural width of sub-version */
ad63d80f
JP		 4137 }
4138 pos++;
4139 }
ad63d80f 4140
34ba6322
SP		 4141 if ( alpha && !saw_period )
4142 Perl_croak(aTHX_ "Invalid version format (alpha without decimal)");
4143
f34c6aaf
JP		 4144 if ( alpha && saw_period && width == 0 )
4145 Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)");
4146
e0218a61 4147 if ( saw_period > 1 )
137d6fc0 4148 qv = 1; /* force quoted version processing */
9137345a
JP		 4149
4150 pos = s;
4151
4152 if ( qv )
cb5772bb
RGS		 4153 hv_store((HV *)hv, "qv", 2, newSViv(qv), 0);
4154 if ( alpha )
4155 hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0);
9137345a
JP		 4156 if ( !qv && width < 3 )
4157 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
4158
ad63d80f 4159 while (isDIGIT(*pos))
46314c13 4160 pos++;
ad63d80f
JP		 4161 if (!isALPHA(*pos)) {
4162 I32 rev;
4163
ad63d80f
JP		 4164 for (;;) {
4165 rev = 0;
4166 {
129318bd 4167 /* this is atoi() that delimits on underscores */
9137345a 4168 const char *end = pos;
129318bd
JP		 4169 I32 mult = 1;
4170 I32 orev;
9137345a 4171
129318bd
JP		 4172 /* the following if() will only be true after the decimal
4173 * point of a version originally created with a bare
4174 * floating point number, i.e. not quoted in any way
4175 */
e0218a61 4176 if ( !qv && s > start && saw_period == 1 ) {
c76df65e 4177 mult *= 100;
129318bd
JP		 4178 while ( s < end ) {
4179 orev = rev;
4180 rev += (*s - '0') * mult;
4181 mult /= 10;
32fdb065 4182 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 4183 Perl_croak(aTHX_ "Integer overflow in version");
4184 s++;
9137345a
JP		 4185 if ( *s == '_' )
4186 s++;
129318bd
JP		 4187 }
4188 }
4189 else {
4190 while (--end >= s) {
4191 orev = rev;
4192 rev += (*end - '0') * mult;
4193 mult *= 10;
32fdb065 4194 if ( PERL_ABS(orev) > PERL_ABS(rev) )
129318bd
JP		 4195 Perl_croak(aTHX_ "Integer overflow in version");
4196 }
4197 }
4198 }
9137345a 4199
129318bd 4200 /* Append revision */
9137345a 4201 av_push(av, newSViv(rev));
c8a14fb6 4202 if ( *pos == '.' )
9137345a
JP		 4203 s = ++pos;
4204 else if ( *pos == '_' && isDIGIT(pos[1]) )
ad63d80f
JP		 4205 s = ++pos;
4206 else if ( isDIGIT(*pos) )
4207 s = pos;
b0f01acb 4208 else {
ad63d80f
JP		 4209 s = pos;
4210 break;
4211 }
9137345a
JP		 4212 if ( qv ) {
4213 while ( isDIGIT(*pos) )
4214 pos++;
4215 }
4216 else {
4217 int digits = 0;
4218 while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
4219 if ( *pos != '_' )
4220 digits++;
4221 pos++;
4222 }
b0f01acb
JP		 4223 }
4224 }
4225 }
9137345a
JP		 4226 if ( qv ) { /* quoted versions always get at least three terms*/
4227 I32 len = av_len(av);
4edfc503
NC		 4228 /* This for loop appears to trigger a compiler bug on OS X, as it
4229 loops infinitely. Yes, len is negative. No, it makes no sense.
4230 Compiler in question is:
4231 gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
4232 for ( len = 2 - len; len > 0; len-- )
4233 av_push((AV *)sv, newSViv(0));
4234 */
4235 len = 2 - len;
4236 while (len-- > 0)
9137345a 4237 av_push(av, newSViv(0));
b9381830 4238 }
9137345a
JP		 4239
4240 if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
4241 av_push(av, newSViv(0));
4242
92dcf8ce
JP		 4243 /* fix RT#19517 - special case 'undef' as string */
4244 if ( *s == 'u' && strEQ(s,"undef") ) {
4245 s += 5;
4246 }
4247
9137345a 4248 /* And finally, store the AV in the hash */
cb5772bb 4249 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
9137345a 4250 return s;
b0f01acb
JP		 4251}
4252
4253/*
4254=for apidoc new_version
4255
4256Returns a new version object based on the passed in SV:
4257
4258 SV *sv = new_version(SV *ver);
4259
4260Does not alter the passed in ver SV. See "upg_version" if you
4261want to upgrade the SV.
4262
4263=cut
4264*/
4265
4266SV *
4267Perl_new_version(pTHX_ SV *ver)
4268{
97aff369 4269 dVAR;
2d03de9c 4270 SV * const rv = newSV(0);
d7aa5382
JP		 4271 if ( sv_derived_from(ver,"version") ) /* can just copy directly */
4272 {
4273 I32 key;
53c1dcc0 4274 AV * const av = newAV();
9137345a
JP		 4275 AV *sav;
4276 /* This will get reblessed later if a derived class*/
e0218a61 4277 SV * const hv = newSVrv(rv, "version");
9137345a 4278 (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
3a242bf8
NC		 4279#ifndef NODEFAULT_SHAREKEYS
4280 HvSHAREKEYS_on(hv); /* key-sharing on by default */
4281#endif
9137345a
JP		 4282
4283 if ( SvROK(ver) )
4284 ver = SvRV(ver);
4285
4286 /* Begin copying all of the elements */
4287 if ( hv_exists((HV *)ver, "qv", 2) )
4288 hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0);
4289
4290 if ( hv_exists((HV *)ver, "alpha", 5) )
4291 hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0);
4292
4293 if ( hv_exists((HV*)ver, "width", 5 ) )
d7aa5382 4294 {
017a3ce5 4295 const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE));
9137345a 4296 hv_store((HV *)hv, "width", 5, newSViv(width), 0);
d7aa5382 4297 }
9137345a 4298
017a3ce5 4299 sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
9137345a
JP		 4300 /* This will get reblessed later if a derived class*/
4301 for ( key = 0; key <= av_len(sav); key++ )
4302 {
4303 const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
4304 av_push(av, newSViv(rev));
4305 }
4306
cb5772bb 4307 hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
d7aa5382
JP		 4308 return rv;
4309 }
ad63d80f 4310#ifdef SvVOK
4f2da183 4311 {
3c21775b 4312 const MAGIC* const mg = SvVSTRING_mg(ver);
4f2da183
NC		 4313 if ( mg ) { /* already a v-string */
4314 const STRLEN len = mg->mg_len;
4315 char * const version = savepvn( (const char*)mg->mg_ptr, len);
4316 sv_setpvn(rv,version,len);
4317 Safefree(version);
4318 }
4319 else {
ad63d80f 4320#endif
4f2da183 4321 sv_setsv(rv,ver); /* make a duplicate */
137d6fc0 4322#ifdef SvVOK
4f2da183 4323 }
26ec6fc3 4324 }
137d6fc0 4325#endif
2593c6c6 4326 return upg_version(rv);
b0f01acb
JP		 4327}
4328
4329/*
4330=for apidoc upg_version
4331
4332In-place upgrade of the supplied SV to a version object.
4333
4334 SV *sv = upg_version(SV *sv);
4335
4336Returns a pointer to the upgraded SV.
4337
4338=cut
4339*/
4340
4341SV *
ad63d80f 4342Perl_upg_version(pTHX_ SV *ver)
b0f01acb 4343{
cd57dc11 4344 const char *version, *s;
137d6fc0 4345 bool qv = 0;
4f2da183
NC		 4346#ifdef SvVOK
4347 const MAGIC *mg;
4348#endif
137d6fc0
JP		 4349
4350 if ( SvNOK(ver) ) /* may get too much accuracy */
4351 {
4352 char tbuf[64];
b5b5a8f0
RGS		 4353#ifdef USE_LOCALE_NUMERIC
4354 char *loc = setlocale(LC_NUMERIC, "C");
4355#endif
63e3af20 4356 STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
b5b5a8f0
RGS		 4357#ifdef USE_LOCALE_NUMERIC
4358 setlocale(LC_NUMERIC, loc);
4359#endif
c8a14fb6 4360 while (tbuf[len-1] == '0' && len > 0) len--;
86c11942 4361 version = savepvn(tbuf, len);
137d6fc0 4362 }
ad63d80f 4363#ifdef SvVOK
666cce26 4364 else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
ad63d80f 4365 version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
137d6fc0 4366 qv = 1;
b0f01acb 4367 }
ad63d80f 4368#endif
137d6fc0
JP		 4369 else /* must be a string or something like a string */
4370 {
9137345a 4371 version = savepv(SvPV_nolen(ver));
137d6fc0 4372 }
92dcf8ce 4373
cd57dc11 4374 s = scan_version(version, ver, qv);
808ee47e 4375 if ( *s != '\0' )
92dcf8ce 4376 if(ckWARN(WARN_MISC))
808ee47e 4377 Perl_warner(aTHX_ packWARN(WARN_MISC),
92dcf8ce
JP		 4378 "Version string '%s' contains invalid data; "
4379 "ignoring: '%s'", version, s);
137d6fc0 4380 Safefree(version);
ad63d80f 4381 return ver;
b0f01acb
JP		 4382}
4383
e0218a61
JP		 4384/*
4385=for apidoc vverify
4386
4387Validates that the SV contains a valid version object.
4388
4389 bool vverify(SV *vobj);
4390
4391Note that it only confirms the bare minimum structure (so as not to get
4392confused by derived classes which may contain additional hash entries):
4393
4394=over 4
4395
cb5772bb 4396=item * The SV contains a [reference to a] hash
e0218a61
JP		 4397
4398=item * The hash contains a "version" key
4399
cb5772bb 4400=item * The "version" key has [a reference to] an AV as its value
e0218a61
JP		 4401
4402=back
4403
4404=cut
4405*/
4406
4407bool
4408Perl_vverify(pTHX_ SV *vs)
4409{
4410 SV *sv;
4411 if ( SvROK(vs) )
4412 vs = SvRV(vs);
4413
4414 /* see if the appropriate elements exist */
4415 if ( SvTYPE(vs) == SVt_PVHV
4416 && hv_exists((HV*)vs, "version", 7)
017a3ce5 4417 && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE)))
e0218a61
JP		 4418 && SvTYPE(sv) == SVt_PVAV )
4419 return TRUE;
4420 else
4421 return FALSE;
4422}
b0f01acb
JP		 4423
4424/*
4425=for apidoc vnumify
4426
ad63d80f
JP		 4427Accepts a version object and returns the normalized floating
4428point representation. Call like:
b0f01acb 4429
ad63d80f 4430 sv = vnumify(rv);
b0f01acb 4431
ad63d80f
JP		 4432NOTE: you can pass either the object directly or the SV
4433contained within the RV.
b0f01acb
JP		 4434
4435=cut
4436*/
4437
4438SV *
ad63d80f 4439Perl_vnumify(pTHX_ SV *vs)
b0f01acb 4440{
ad63d80f 4441 I32 i, len, digit;
9137345a
JP		 4442 int width;
4443 bool alpha = FALSE;
53c1dcc0 4444 SV * const sv = newSV(0);
9137345a 4445 AV *av;
ad63d80f
JP		 4446 if ( SvROK(vs) )
4447 vs = SvRV(vs);
9137345a 4448
e0218a61
JP		 4449 if ( !vverify(vs) )
4450 Perl_croak(aTHX_ "Invalid version object");
4451
9137345a
JP		 4452 /* see if various flags exist */
4453 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4454 alpha = TRUE;
4455 if ( hv_exists((HV*)vs, "width", 5 ) )
017a3ce5 4456 width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE));
9137345a
JP		 4457 else
4458 width = 3;
4459
4460
4461 /* attempt to retrieve the version array */
017a3ce5 4462 if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) {
396482e1 4463 sv_catpvs(sv,"0");
9137345a
JP		 4464 return sv;
4465 }
4466
4467 len = av_len(av);
46314c13
JP		 4468 if ( len == -1 )
4469 {
396482e1 4470 sv_catpvs(sv,"0");
46314c13
JP		 4471 return sv;
4472 }
9137345a
JP		 4473
4474 digit = SvIV(*av_fetch(av, 0, 0));
261fcdab 4475 Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit));
13f8f398 4476 for ( i = 1 ; i < len ; i++ )
b0f01acb 4477 {
9137345a
JP		 4478 digit = SvIV(*av_fetch(av, i, 0));
4479 if ( width < 3 ) {
43eaf59d 4480 const int denom = (width == 2 ? 10 : 100);
53c1dcc0 4481 const div_t term = div((int)PERL_ABS(digit),denom);
261fcdab 4482 Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
9137345a
JP		 4483 }
4484 else {
261fcdab 4485 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
9137345a 4486 }
b0f01acb 4487 }
13f8f398
JP		 4488
4489 if ( len > 0 )
4490 {
9137345a
JP		 4491 digit = SvIV(*av_fetch(av, len, 0));
4492 if ( alpha && width == 3 ) /* alpha version */
396482e1 4493 sv_catpvs(sv,"_");
261fcdab 4494 Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
13f8f398 4495 }
e0218a61 4496 else /* len == 0 */
13f8f398 4497 {
396482e1 4498 sv_catpvs(sv, "000");
13f8f398 4499 }
b0f01acb
JP		 4500 return sv;
4501}
4502
4503/*
b9381830 4504=for apidoc vnormal
b0f01acb 4505
ad63d80f
JP		 4506Accepts a version object and returns the normalized string
4507representation. Call like:
b0f01acb 4508
b9381830 4509 sv = vnormal(rv);
b0f01acb 4510
ad63d80f
JP		 4511NOTE: you can pass either the object directly or the SV
4512contained within the RV.
b0f01acb
JP		 4513
4514=cut
4515*/
4516
4517SV *
b9381830 4518Perl_vnormal(pTHX_ SV *vs)
b0f01acb 4519{
ad63d80f 4520 I32 i, len, digit;
9137345a 4521 bool alpha = FALSE;
2d03de9c 4522 SV * const sv = newSV(0);
9137345a 4523 AV *av;
ad63d80f
JP		 4524 if ( SvROK(vs) )
4525 vs = SvRV(vs);
9137345a 4526
e0218a61
JP		 4527 if ( !vverify(vs) )
4528 Perl_croak(aTHX_ "Invalid version object");
4529
9137345a
JP		 4530 if ( hv_exists((HV*)vs, "alpha", 5 ) )
4531 alpha = TRUE;
017a3ce5 4532 av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE));
9137345a
JP		 4533
4534 len = av_len(av);
e0218a61
JP		 4535 if ( len == -1 )
4536 {
396482e1 4537 sv_catpvs(sv,"");
46314c13
JP		 4538 return sv;
4539 }
9137345a 4540 digit = SvIV(*av_fetch(av, 0, 0));
261fcdab 4541 Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit);
cb5772bb 4542 for ( i = 1 ; i < len ; i++ ) {
9137345a 4543 digit = SvIV(*av_fetch(av, i, 0));
261fcdab 4544 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
9137345a
JP		 4545 }
4546
e0218a61
JP		 4547 if ( len > 0 )
4548 {
9137345a
JP		 4549 /* handle last digit specially */
4550 digit = SvIV(*av_fetch(av, len, 0));
4551 if ( alpha )
261fcdab 4552 Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
ad63d80f 4553 else
261fcdab 4554 Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
b0f01acb 4555 }
9137345a 4556
137d6fc0
JP		 4557 if ( len <= 2 ) { /* short version, must be at least three */
4558 for ( len = 2 - len; len != 0; len-- )
396482e1 4559 sv_catpvs(sv,".0");
137d6fc0 4560 }
b0f01acb 4561 return sv;
9137345a 4562}
b0f01acb 4563
ad63d80f 4564/*
b9381830
JP		 4565=for apidoc vstringify
4566
4567In order to maintain maximum compatibility with earlier versions
4568of Perl, this function will return either the floating point
4569notation or the multiple dotted notation, depending on whether
4570the original version contained 1 or more dots, respectively
4571
4572=cut
4573*/
4574
4575SV *
4576Perl_vstringify(pTHX_ SV *vs)
4577{
b9381830
JP		 4578 if ( SvROK(vs) )
4579 vs = SvRV(vs);
e0218a61
JP		 4580
4581 if ( !vverify(vs) )
4582 Perl_croak(aTHX_ "Invalid version object");
4583
9137345a 4584 if ( hv_exists((HV *)vs, "qv", 2) )
cb5772bb 4585 return vnormal(vs);
9137345a 4586 else
cb5772bb 4587 return vnumify(vs);
b9381830
JP		 4588}
4589
4590/*
ad63d80f
JP		 4591=for apidoc vcmp
4592
4593Version object aware cmp. Both operands must already have been
4594converted into version objects.
4595
4596=cut
4597*/
4598
4599int
9137345a 4600Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
ad63d80f
JP		 4601{
4602 I32 i,l,m,r,retval;
9137345a
JP		 4603 bool lalpha = FALSE;
4604 bool ralpha = FALSE;
4605 I32 left = 0;
4606 I32 right = 0;
4607 AV *lav, *rav;
4608 if ( SvROK(lhv) )
4609 lhv = SvRV(lhv);
4610 if ( SvROK(rhv) )
4611 rhv = SvRV(rhv);
4612
e0218a61
JP		 4613 if ( !vverify(lhv) )
4614 Perl_croak(aTHX_ "Invalid version object");
4615
4616 if ( !vverify(rhv) )
4617 Perl_croak(aTHX_ "Invalid version object");
4618
9137345a 4619 /* get the left hand term */
017a3ce5 4620 lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE));
9137345a
JP		 4621 if ( hv_exists((HV*)lhv, "alpha", 5 ) )
4622 lalpha = TRUE;
4623
4624 /* and the right hand term */
017a3ce5 4625 rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE));
9137345a
JP		 4626 if ( hv_exists((HV*)rhv, "alpha", 5 ) )
4627 ralpha = TRUE;
4628
4629 l = av_len(lav);
4630 r = av_len(rav);
ad63d80f
JP		 4631 m = l < r ? l : r;
4632 retval = 0;
4633 i = 0;
4634 while ( i <= m && retval == 0 )
4635 {
9137345a
JP		 4636 left = SvIV(*av_fetch(lav,i,0));
4637 right = SvIV(*av_fetch(rav,i,0));
4638 if ( left < right )
ad63d80f 4639 retval = -1;
9137345a 4640 if ( left > right )
ad63d80f
JP		 4641 retval = +1;
4642 i++;
4643 }
4644
9137345a
JP		 4645 /* tiebreaker for alpha with identical terms */
4646 if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
4647 {
4648 if ( lalpha && !ralpha )
4649 {
4650 retval = -1;
4651 }
4652 else if ( ralpha && !lalpha)
4653 {
4654 retval = +1;
4655 }
4656 }
4657
137d6fc0 4658 if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
129318bd 4659 {
137d6fc0 4660 if ( l < r )
129318bd 4661 {
137d6fc0
JP		 4662 while ( i <= r && retval == 0 )
4663 {
9137345a 4664 if ( SvIV(*av_fetch(rav,i,0)) != 0 )
137d6fc0
JP		 4665 retval = -1; /* not a match after all */
4666 i++;
4667 }
4668 }
4669 else
4670 {
4671 while ( i <= l && retval == 0 )
4672 {
9137345a 4673 if ( SvIV(*av_fetch(lav,i,0)) != 0 )
137d6fc0
JP		 4674 retval = +1; /* not a match after all */
4675 i++;
4676 }
129318bd
JP		 4677 }
4678 }
ad63d80f
JP		 4679 return retval;
4680}
4681
c95c94b1 4682#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
2bc69dc4
NIS		 4683# define EMULATE_SOCKETPAIR_UDP
4684#endif
4685
4686#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee
NC		 4687static int
4688S_socketpair_udp (int fd[2]) {
e10bb1e9 4689 dTHX;
02fc2eee
NC		 4690 /* Fake a datagram socketpair using UDP to localhost. */
4691 int sockets[2] = {-1, -1};
4692 struct sockaddr_in addresses[2];
4693 int i;
3aed30dc 4694 Sock_size_t size = sizeof(struct sockaddr_in);
ae92b34e 4695 unsigned short port;
02fc2eee
NC		 4696 int got;
4697
3aed30dc 4698 memset(&addresses, 0, sizeof(addresses));
02fc2eee
NC		 4699 i = 1;
4700 do {
3aed30dc
HS		 4701 sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
4702 if (sockets[i] == -1)
4703 goto tidy_up_and_fail;
4704
4705 addresses[i].sin_family = AF_INET;
4706 addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
4707 addresses[i].sin_port = 0; /* kernel choses port. */
4708 if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
4709 sizeof(struct sockaddr_in)) == -1)
4710 goto tidy_up_and_fail;
02fc2eee
NC		 4711 } while (i--);
4712
4713 /* Now have 2 UDP sockets. Find out which port each is connected to, and
4714 for each connect the other socket to it. */
4715 i = 1;
4716 do {
3aed30dc
HS		 4717 if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
4718 &size) == -1)
4719 goto tidy_up_and_fail;
4720 if (size != sizeof(struct sockaddr_in))
4721 goto abort_tidy_up_and_fail;
4722 /* !1 is 0, !0 is 1 */
4723 if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
4724 sizeof(struct sockaddr_in)) == -1)
4725 goto tidy_up_and_fail;
02fc2eee
NC		 4726 } while (i--);
4727
4728 /* Now we have 2 sockets connected to each other. I don't trust some other
4729 process not to have already sent a packet to us (by random) so send
4730 a packet from each to the other. */
4731 i = 1;
4732 do {
3aed30dc
HS		 4733 /* I'm going to send my own port number. As a short.
4734 (Who knows if someone somewhere has sin_port as a bitfield and needs
4735 this routine. (I'm assuming crays have socketpair)) */
4736 port = addresses[i].sin_port;
4737 got = PerlLIO_write(sockets[i], &port, sizeof(port));
4738 if (got != sizeof(port)) {
4739 if (got == -1)
4740 goto tidy_up_and_fail;
4741 goto abort_tidy_up_and_fail;
4742 }
02fc2eee
NC		 4743 } while (i--);
4744
4745 /* Packets sent. I don't trust them to have arrived though.
4746 (As I understand it Solaris TCP stack is multithreaded. Non-blocking
4747 connect to localhost will use a second kernel thread. In 2.6 the
4748 first thread running the connect() returns before the second completes,
4749 so EINPROGRESS> In 2.7 the improved stack is faster and connect()
4750 returns 0. Poor programs have tripped up. One poor program's authors'
4751 had a 50-1 reverse stock split. Not sure how connected these were.)
4752 So I don't trust someone not to have an unpredictable UDP stack.
4753 */
4754
4755 {
3aed30dc
HS		 4756 struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
4757 int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
4758 fd_set rset;
4759
4760 FD_ZERO(&rset);
ea407a0c
NC		 4761 FD_SET((unsigned int)sockets[0], &rset);
4762 FD_SET((unsigned int)sockets[1], &rset);
3aed30dc
HS		 4763
4764 got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
4765 if (got != 2 || !FD_ISSET(sockets[0], &rset)
4766 || !FD_ISSET(sockets[1], &rset)) {
4767 /* I hope this is portable and appropriate. */
4768 if (got == -1)
4769 goto tidy_up_and_fail;
4770 goto abort_tidy_up_and_fail;
4771 }
02fc2eee 4772 }
f4758303 4773
02fc2eee
NC		 4774 /* And the paranoia department even now doesn't trust it to have arrive
4775 (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
4776 {
3aed30dc
HS		 4777 struct sockaddr_in readfrom;
4778 unsigned short buffer[2];
02fc2eee 4779
3aed30dc
HS		 4780 i = 1;
4781 do {
02fc2eee 4782#ifdef MSG_DONTWAIT
3aed30dc
HS		 4783 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4784 sizeof(buffer), MSG_DONTWAIT,
4785 (struct sockaddr *) &readfrom, &size);
02fc2eee 4786#else
3aed30dc
HS		 4787 got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
4788 sizeof(buffer), 0,
4789 (struct sockaddr *) &readfrom, &size);
e10bb1e9 4790#endif
02fc2eee 4791
3aed30dc
HS		 4792 if (got == -1)
4793 goto tidy_up_and_fail;
4794 if (got != sizeof(port)
4795 || size != sizeof(struct sockaddr_in)
4796 /* Check other socket sent us its port. */
4797 || buffer[0] != (unsigned short) addresses[!i].sin_port
4798 /* Check kernel says we got the datagram from that socket */
4799 || readfrom.sin_family != addresses[!i].sin_family
4800 || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
4801 || readfrom.sin_port != addresses[!i].sin_port)
4802 goto abort_tidy_up_and_fail;
4803 } while (i--);
02fc2eee
NC		 4804 }
4805 /* My caller (my_socketpair) has validated that this is non-NULL */
4806 fd[0] = sockets[0];
4807 fd[1] = sockets[1];
4808 /* I hereby declare this connection open. May God bless all who cross
4809 her. */
4810 return 0;
4811
4812 abort_tidy_up_and_fail:
4813 errno = ECONNABORTED;
4814 tidy_up_and_fail:
4815 {
4373e329 4816 const int save_errno = errno;
3aed30dc
HS		 4817 if (sockets[0] != -1)
4818 PerlLIO_close(sockets[0]);
4819 if (sockets[1] != -1)
4820 PerlLIO_close(sockets[1]);
4821 errno = save_errno;
4822 return -1;
02fc2eee
NC		 4823 }
4824}
85ca448a 4825#endif /* EMULATE_SOCKETPAIR_UDP */
02fc2eee 4826
b5ac89c3 4827#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
02fc2eee
NC		 4828int
4829Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
4830 /* Stevens says that family must be AF_LOCAL, protocol 0.
2948e0bd 4831 I'm going to enforce that, then ignore it, and use TCP (or UDP). */
e10bb1e9 4832 dTHX;
02fc2eee
NC		 4833 int listener = -1;
4834 int connector = -1;
4835 int acceptor = -1;
4836 struct sockaddr_in listen_addr;
4837 struct sockaddr_in connect_addr;
4838 Sock_size_t size;
4839
50458334
JH		 4840 if (protocol
4841#ifdef AF_UNIX
4842 || family != AF_UNIX
4843#endif
3aed30dc
HS		 4844 ) {
4845 errno = EAFNOSUPPORT;
4846 return -1;
02fc2eee 4847 }
2948e0bd 4848 if (!fd) {
3aed30dc
HS		 4849 errno = EINVAL;
4850 return -1;
2948e0bd 4851 }
02fc2eee 4852
2bc69dc4 4853#ifdef EMULATE_SOCKETPAIR_UDP
02fc2eee 4854 if (type == SOCK_DGRAM)
3aed30dc 4855 return S_socketpair_udp(fd);
2bc69dc4 4856#endif
02fc2eee 4857
3aed30dc 4858 listener = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4859 if (listener == -1)
3aed30dc
HS		 4860 return -1;
4861 memset(&listen_addr, 0, sizeof(listen_addr));
02fc2eee 4862 listen_addr.sin_family = AF_INET;
3aed30dc 4863 listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
02fc2eee 4864 listen_addr.sin_port = 0; /* kernel choses port. */
3aed30dc
HS		 4865 if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
4866 sizeof(listen_addr)) == -1)
4867 goto tidy_up_and_fail;
e10bb1e9 4868 if (PerlSock_listen(listener, 1) == -1)
3aed30dc 4869 goto tidy_up_and_fail;
02fc2eee 4870
3aed30dc 4871 connector = PerlSock_socket(AF_INET, type, 0);
02fc2eee 4872 if (connector == -1)
3aed30dc 4873 goto tidy_up_and_fail;
02fc2eee 4874 /* We want to find out the port number to connect to. */
3aed30dc
HS		 4875 size = sizeof(connect_addr);
4876 if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
4877 &size) == -1)
4878 goto tidy_up_and_fail;
4879 if (size != sizeof(connect_addr))
4880 goto abort_tidy_up_and_fail;
e10bb1e9 4881 if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
3aed30dc
HS		 4882 sizeof(connect_addr)) == -1)
4883 goto tidy_up_and_fail;
02fc2eee 4884
3aed30dc
HS		 4885 size = sizeof(listen_addr);
4886 acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
4887 &size);
02fc2eee 4888 if (acceptor == -1)
3aed30dc
HS		 4889 goto tidy_up_and_fail;
4890 if (size != sizeof(listen_addr))
4891 goto abort_tidy_up_and_fail;
4892 PerlLIO_close(listener);
02fc2eee
NC		 4893 /* Now check we are talking to ourself by matching port and host on the
4894 two sockets. */
3aed30dc
HS		 4895 if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
4896 &size) == -1)
4897 goto tidy_up_and_fail;
4898 if (size != sizeof(connect_addr)
4899 || listen_addr.sin_family != connect_addr.sin_family
4900 || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
4901 || listen_addr.sin_port != connect_addr.sin_port) {
4902 goto abort_tidy_up_and_fail;
02fc2eee
NC		 4903 }
4904 fd[0] = connector;
4905 fd[1] = acceptor;
4906 return 0;
4907
4908 abort_tidy_up_and_fail:
27da23d5
JH		 4909#ifdef ECONNABORTED
4910 errno = ECONNABORTED; /* This would be the standard thing to do. */
4911#else
4912# ifdef ECONNREFUSED
4913 errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
4914# else
4915 errno = ETIMEDOUT; /* Desperation time. */
4916# endif
4917#endif
02fc2eee
NC		 4918 tidy_up_and_fail:
4919 {
7452cf6a 4920 const int save_errno = errno;
3aed30dc
HS		 4921 if (listener != -1)
4922 PerlLIO_close(listener);
4923 if (connector != -1)
4924 PerlLIO_close(connector);
4925 if (acceptor != -1)
4926 PerlLIO_close(acceptor);
4927 errno = save_errno;
4928 return -1;
02fc2eee
NC		 4929 }
4930}
85ca448a 4931#else
48ea76d1
JH		 4932/* In any case have a stub so that there's code corresponding
4933 * to the my_socketpair in global.sym. */
4934int
4935Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
daf16542 4936#ifdef HAS_SOCKETPAIR
48ea76d1 4937 return socketpair(family, type, protocol, fd);
daf16542
JH		 4938#else
4939 return -1;
4940#endif
48ea76d1
JH		 4941}
4942#endif
4943
68795e93
NIS		 4944/*
4945
4946=for apidoc sv_nosharing
4947
4948Dummy routine which "shares" an SV when there is no sharing module present.
d5b2b27b
NC		 4949Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
4950Exists to avoid test for a NULL function pointer and because it could
4951potentially warn under some level of strict-ness.
68795e93
NIS		 4952
4953=cut
4954*/
4955
4956void
4957Perl_sv_nosharing(pTHX_ SV *sv)
4958{
96a5add6 4959 PERL_UNUSED_CONTEXT;
53c1dcc0 4960 PERL_UNUSED_ARG(sv);
68795e93
NIS		 4961}
4962
a05d7ebb 4963U32
e1ec3a88 4964Perl_parse_unicode_opts(pTHX_ const char **popt)
a05d7ebb 4965{
e1ec3a88 4966 const char *p = *popt;
a05d7ebb
JH		 4967 U32 opt = 0;
4968
4969 if (*p) {
4970 if (isDIGIT(*p)) {
4971 opt = (U32) atoi(p);
35da51f7
AL		 4972 while (isDIGIT(*p))
4973 p++;
7c91f477 4974 if (*p && *p != '\n' && *p != '\r')
a05d7ebb
JH		 4975 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
4976 }
4977 else {
4978 for (; *p; p++) {
4979 switch (*p) {
4980 case PERL_UNICODE_STDIN:
4981 opt |= PERL_UNICODE_STDIN_FLAG; break;
4982 case PERL_UNICODE_STDOUT:
4983 opt |= PERL_UNICODE_STDOUT_FLAG; break;
4984 case PERL_UNICODE_STDERR:
4985 opt |= PERL_UNICODE_STDERR_FLAG; break;
4986 case PERL_UNICODE_STD:
4987 opt |= PERL_UNICODE_STD_FLAG; break;
4988 case PERL_UNICODE_IN:
4989 opt |= PERL_UNICODE_IN_FLAG; break;
4990 case PERL_UNICODE_OUT:
4991 opt |= PERL_UNICODE_OUT_FLAG; break;
4992 case PERL_UNICODE_INOUT:
4993 opt |= PERL_UNICODE_INOUT_FLAG; break;
4994 case PERL_UNICODE_LOCALE:
4995 opt |= PERL_UNICODE_LOCALE_FLAG; break;
4996 case PERL_UNICODE_ARGV:
4997 opt |= PERL_UNICODE_ARGV_FLAG; break;
5a22a2bb
NC		 4998 case PERL_UNICODE_UTF8CACHEASSERT:
4999 opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
a05d7ebb 5000 default:
7c91f477
JH		 5001 if (*p != '\n' && *p != '\r')
5002 Perl_croak(aTHX_
5003 "Unknown Unicode option letter '%c'", *p);
a05d7ebb
JH		 5004 }
5005 }
5006 }
5007 }
5008 else
5009 opt = PERL_UNICODE_DEFAULT_FLAGS;
5010
5011 if (opt & ~PERL_UNICODE_ALL_FLAGS)
06e66572 5012 Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
a05d7ebb
JH		 5013 (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
5014
5015 *popt = p;
5016
5017 return opt;
5018}
5019
132efe8b
JH		 5020U32
5021Perl_seed(pTHX)
5022{
97aff369 5023 dVAR;
132efe8b
JH		 5024 /*
5025 * This is really just a quick hack which grabs various garbage
5026 * values. It really should be a real hash algorithm which
5027 * spreads the effect of every input bit onto every output bit,
5028 * if someone who knows about such things would bother to write it.
5029 * Might be a good idea to add that function to CORE as well.
5030 * No numbers below come from careful analysis or anything here,
5031 * except they are primes and SEED_C1 > 1E6 to get a full-width
5032 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
5033 * probably be bigger too.
5034 */
5035#if RANDBITS > 16
5036# define SEED_C1 1000003
5037#define SEED_C4 73819
5038#else
5039# define SEED_C1 25747
5040#define SEED_C4 20639
5041#endif
5042#define SEED_C2 3
5043#define SEED_C3 269
5044#define SEED_C5 26107
5045
5046#ifndef PERL_NO_DEV_RANDOM
5047 int fd;
5048#endif
5049 U32 u;
5050#ifdef VMS
5051# include <starlet.h>
5052 /* when[] = (low 32 bits, high 32 bits) of time since epoch
5053 * in 100-ns units, typically incremented ever 10 ms. */
5054 unsigned int when[2];
5055#else
5056# ifdef HAS_GETTIMEOFDAY
5057 struct timeval when;
5058# else
5059 Time_t when;
5060# endif
5061#endif
5062
5063/* This test is an escape hatch, this symbol isn't set by Configure. */
5064#ifndef PERL_NO_DEV_RANDOM
5065#ifndef PERL_RANDOM_DEVICE
5066 /* /dev/random isn't used by default because reads from it will block
5067 * if there isn't enough entropy available. You can compile with
5068 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
5069 * is enough real entropy to fill the seed. */
5070# define PERL_RANDOM_DEVICE "/dev/urandom"
5071#endif
5072 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
5073 if (fd != -1) {
27da23d5 5074 if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
132efe8b
JH		 5075 u = 0;
5076 PerlLIO_close(fd);
5077 if (u)
5078 return u;
5079 }
5080#endif
5081
5082#ifdef VMS
5083 _ckvmssts(sys$gettim(when));
5084 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
5085#else
5086# ifdef HAS_GETTIMEOFDAY
5087 PerlProc_gettimeofday(&when,NULL);
5088 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
5089# else
5090 (void)time(&when);
5091 u = (U32)SEED_C1 * when;
5092# endif
5093#endif
5094 u += SEED_C3 * (U32)PerlProc_getpid();
5095 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
5096#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
5097 u += SEED_C5 * (U32)PTR2UV(&when);
5098#endif
5099 return u;
5100}
5101
bed60192 5102UV
a783c5f4 5103Perl_get_hash_seed(pTHX)
bed60192 5104{
97aff369 5105 dVAR;
e1ec3a88 5106 const char *s = PerlEnv_getenv("PERL_HASH_SEED");
bed60192
JH		 5107 UV myseed = 0;
5108
5109 if (s)
35da51f7
AL		 5110 while (isSPACE(*s))
5111 s++;
bed60192
JH		 5112 if (s && isDIGIT(*s))
5113 myseed = (UV)Atoul(s);
5114 else
5115#ifdef USE_HASH_SEED_EXPLICIT
5116 if (s)
5117#endif
5118 {
5119 /* Compute a random seed */
5120 (void)seedDrand01((Rand_seed_t)seed());
bed60192
JH		 5121 myseed = (UV)(Drand01() * (NV)UV_MAX);
5122#if RANDBITS < (UVSIZE * 8)
5123 /* Since there are not enough randbits to to reach all
5124 * the bits of a UV, the low bits might need extra
5125 * help. Sum in another random number that will
5126 * fill in the low bits. */
5127 myseed +=
5128 (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1));
5129#endif /* RANDBITS < (UVSIZE * 8) */
6cfd5ea7
JH		 5130 if (myseed == 0) { /* Superparanoia. */
5131 myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */
5132 if (myseed == 0)
5133 Perl_croak(aTHX_ "Your random numbers are not that random");
5134 }
bed60192 5135 }
008fb0c0 5136 PL_rehash_seed_set = TRUE;
bed60192
JH		 5137
5138 return myseed;
5139}
27da23d5 5140
ed221c57
AL		 5141#ifdef USE_ITHREADS
5142bool
5143Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
5144{
5145 const char * const stashpv = CopSTASHPV(c);
5146 const char * const name = HvNAME_get(hv);
96a5add6 5147 PERL_UNUSED_CONTEXT;
ed221c57
AL		 5148
5149 if (stashpv == name)
5150 return TRUE;
5151 if (stashpv && name)
5152 if (strEQ(stashpv, name))
5153 return TRUE;
5154 return FALSE;
5155}
5156#endif
5157
5158
27da23d5
JH		 5159#ifdef PERL_GLOBAL_STRUCT
5160
5161struct perl_vars *
5162Perl_init_global_struct(pTHX)
5163{
5164 struct perl_vars *plvarsp = NULL;
5165#ifdef PERL_GLOBAL_STRUCT
5166# define PERL_GLOBAL_STRUCT_INIT
5167# include "opcode.h" /* the ppaddr and check */
7452cf6a
AL		 5168 const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
5169 const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t);
27da23d5
JH		 5170# ifdef PERL_GLOBAL_STRUCT_PRIVATE
5171 /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
5172 plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
5173 if (!plvarsp)
5174 exit(1);
5175# else
5176 plvarsp = PL_VarsPtr;
5177# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
aadb217d
JH		 5178# undef PERLVAR
5179# undef PERLVARA
5180# undef PERLVARI
5181# undef PERLVARIC
5182# undef PERLVARISC
27da23d5
JH		 5183# define PERLVAR(var,type) /**/
5184# define PERLVARA(var,n,type) /**/
5185# define PERLVARI(var,type,init) plvarsp->var = init;
5186# define PERLVARIC(var,type,init) plvarsp->var = init;
5187# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char);
5188# include "perlvars.h"
5189# undef PERLVAR
5190# undef PERLVARA
5191# undef PERLVARI
5192# undef PERLVARIC
5193# undef PERLVARISC
5194# ifdef PERL_GLOBAL_STRUCT
5195 plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
5196 if (!plvarsp->Gppaddr)
5197 exit(1);
5198 plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t));
5199 if (!plvarsp->Gcheck)
5200 exit(1);
5201 Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
5202 Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
5203# endif
5204# ifdef PERL_SET_VARS
5205 PERL_SET_VARS(plvarsp);
5206# endif
5207# undef PERL_GLOBAL_STRUCT_INIT
5208#endif
5209 return plvarsp;
5210}
5211
5212#endif /* PERL_GLOBAL_STRUCT */
5213
5214#ifdef PERL_GLOBAL_STRUCT
5215
5216void
5217Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
5218{
5219#ifdef PERL_GLOBAL_STRUCT
5220# ifdef PERL_UNSET_VARS
5221 PERL_UNSET_VARS(plvarsp);
5222# endif
5223 free(plvarsp->Gppaddr);
5224 free(plvarsp->Gcheck);
5225# ifdef PERL_GLOBAL_STRUCT_PRIVATE
5226 free(plvarsp);
5227# endif
5228#endif
5229}
5230
5231#endif /* PERL_GLOBAL_STRUCT */
5232
fe4f188c
JH		 5233#ifdef PERL_MEM_LOG
5234
65ceff02
JH		 5235/*
5236 * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled.
5237 *
5238 * PERL_MEM_LOG_ENV: if defined, during run time the environment
5239 * variable PERL_MEM_LOG will be consulted, and if the integer value
5240 * of that is true, the logging will happen. (The default is to
5241 * always log if the PERL_MEM_LOG define was in effect.)
5242 */
5243
5244/*
5245 * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer
5246 * the Perl_mem_log_...() will use (either via sprintf or snprintf).
5247 */
e352bcff
JH		 5248#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
5249
65ceff02
JH		 5250/*
5251 * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will
5252 * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD,
5253 * in which case the environment variable PERL_MEM_LOG_FD will be
5254 * consulted for the file descriptor number to use.
5255 */
5256#ifndef PERL_MEM_LOG_FD
5257# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */
5258#endif
5259
fe4f188c 5260Malloc_t
46c6c7e2 5261Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5262{
5263#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5264# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5265 char *s;
5266# endif
5267# ifdef PERL_MEM_LOG_ENV
5268 s = getenv("PERL_MEM_LOG");
5269 if (s ? atoi(s) : 0)
5270# endif
5271 {
5272 /* We can't use SVs or PerlIO for obvious reasons,
5273 * so we'll use stdio and low-level IO instead. */
5274 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5275# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02 5276 struct timeval tv;
5b692037 5277# ifdef HAS_GETTIMEOFDAY
65ceff02 5278 gettimeofday(&tv, 0);
5b692037
JH		 5279# endif
5280 /* If there are other OS specific ways of hires time than
5281 * gettimeofday() (see ext/Time/HiRes), the easiest way is
5282 * probably that they would be used to fill in the struct
5283 * timeval. */
5284# endif
65ceff02
JH		 5285 {
5286 const STRLEN len =
d9fad198 5287 my_snprintf(buf,
d1307786 5288 sizeof(buf),
5b692037
JH		 5289# ifdef PERL_MEM_LOG_TIMESTAMP
5290 "%10d.%06d: "
5291# endif
d9fad198
JH		 5292 "alloc: %s:%d:%s: %"IVdf" %"UVuf
5293 " %s = %"IVdf": %"UVxf"\n",
5b692037
JH		 5294# ifdef PERL_MEM_LOG_TIMESTAMP
5295 (int)tv.tv_sec, (int)tv.tv_usec,
5296# endif
d9fad198
JH		 5297 filename, linenumber, funcname, n, typesize,
5298 typename, n * typesize, PTR2UV(newalloc));
65ceff02
JH		 5299# ifdef PERL_MEM_LOG_ENV_FD
5300 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5301 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5302# else
5303 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5304#endif
5305 }
5306 }
fe4f188c
JH		 5307#endif
5308 return newalloc;
5309}
5310
5311Malloc_t
46c6c7e2 5312Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5313{
5314#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5315# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5316 char *s;
5317# endif
5318# ifdef PERL_MEM_LOG_ENV
5319 s = PerlEnv_getenv("PERL_MEM_LOG");
5320 if (s ? atoi(s) : 0)
5321# endif
5322 {
5323 /* We can't use SVs or PerlIO for obvious reasons,
5324 * so we'll use stdio and low-level IO instead. */
5325 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5326# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02
JH		 5327 struct timeval tv;
5328 gettimeofday(&tv, 0);
5b692037 5329# endif
65ceff02
JH		 5330 {
5331 const STRLEN len =
d9fad198 5332 my_snprintf(buf,
d1307786 5333 sizeof(buf),
5b692037
JH		 5334# ifdef PERL_MEM_LOG_TIMESTAMP
5335 "%10d.%06d: "
5336# endif
d9fad198
JH		 5337 "realloc: %s:%d:%s: %"IVdf" %"UVuf
5338 " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
5b692037
JH		 5339# ifdef PERL_MEM_LOG_TIMESTAMP
5340 (int)tv.tv_sec, (int)tv.tv_usec,
5341# endif
d9fad198
JH		 5342 filename, linenumber, funcname, n, typesize,
5343 typename, n * typesize, PTR2UV(oldalloc),
5344 PTR2UV(newalloc));
65ceff02
JH		 5345# ifdef PERL_MEM_LOG_ENV_FD
5346 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5347 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5348# else
5349 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5350# endif
5351 }
5352 }
fe4f188c
JH		 5353#endif
5354 return newalloc;
5355}
5356
5357Malloc_t
46c6c7e2 5358Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname)
fe4f188c
JH		 5359{
5360#ifdef PERL_MEM_LOG_STDERR
65ceff02
JH		 5361# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD)
5362 char *s;
5363# endif
5364# ifdef PERL_MEM_LOG_ENV
5365 s = PerlEnv_getenv("PERL_MEM_LOG");
5366 if (s ? atoi(s) : 0)
5367# endif
5368 {
5369 /* We can't use SVs or PerlIO for obvious reasons,
5370 * so we'll use stdio and low-level IO instead. */
5371 char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
5b692037 5372# ifdef PERL_MEM_LOG_TIMESTAMP
65ceff02
JH		 5373 struct timeval tv;
5374 gettimeofday(&tv, 0);
5b692037 5375# endif
65ceff02
JH		 5376 {
5377 const STRLEN len =
d9fad198 5378 my_snprintf(buf,
d1307786 5379 sizeof(buf),
5b692037
JH		 5380# ifdef PERL_MEM_LOG_TIMESTAMP
5381 "%10d.%06d: "
5382# endif
5383 "free: %s:%d:%s: %"UVxf"\n",
5384# ifdef PERL_MEM_LOG_TIMESTAMP
d9fad198 5385 (int)tv.tv_sec, (int)tv.tv_usec,
5b692037 5386# endif
d9fad198
JH		 5387 filename, linenumber, funcname,
5388 PTR2UV(oldalloc));
65ceff02
JH		 5389# ifdef PERL_MEM_LOG_ENV_FD
5390 s = PerlEnv_getenv("PERL_MEM_LOG_FD");
5391 PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len);
5392# else
5393 PerlLIO_write(PERL_MEM_LOG_FD, buf, len);
5394# endif
5395 }
5396 }
fe4f188c
JH		 5397#endif
5398 return oldalloc;
5399}
5400
5401#endif /* PERL_MEM_LOG */
5402
66610fdd 5403/*
ce582cee
NC		 5404=for apidoc my_sprintf
5405
5406The C library C<sprintf>, wrapped if necessary, to ensure that it will return
5407the length of the string written to the buffer. Only rare pre-ANSI systems
5408need the wrapper function - usually this is a direct call to C<sprintf>.
5409
5410=cut
5411*/
5412#ifndef SPRINTF_RETURNS_STRLEN
5413int
5414Perl_my_sprintf(char *buffer, const char* pat, ...)
5415{
5416 va_list args;
5417 va_start(args, pat);
5418 vsprintf(buffer, pat, args);
5419 va_end(args);
5420 return strlen(buffer);
5421}
5422#endif
5423
d9fad198
JH		 5424/*
5425=for apidoc my_snprintf
5426
5427The C library C<snprintf> functionality, if available and
5b692037 5428standards-compliant (uses C<vsnprintf>, actually). However, if the
d9fad198 5429C<vsnprintf> is not available, will unfortunately use the unsafe
5b692037
JH		 5430C<vsprintf> which can overrun the buffer (there is an overrun check,
5431but that may be too late). Consider using C<sv_vcatpvf> instead, or
5432getting C<vsnprintf>.
d9fad198
JH		 5433
5434=cut
5435*/
5436int
5437Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
d9fad198
JH		 5438{
5439 dTHX;
5440 int retval;
5441 va_list ap;
d9fad198 5442 va_start(ap, format);
5b692037 5443#ifdef HAS_VSNPRINTF
d9fad198
JH		 5444 retval = vsnprintf(buffer, len, format, ap);
5445#else
5446 retval = vsprintf(buffer, format, ap);
5447#endif
5448 va_end(ap);
1208b3dd 5449 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
625dac9d 5450 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5b692037 5451 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
d9fad198
JH		 5452 return retval;
5453}
5454
5455/*
5456=for apidoc my_vsnprintf
5457
5b692037
JH		 5458The C library C<vsnprintf> if available and standards-compliant.
5459However, if if the C<vsnprintf> is not available, will unfortunately
5460use the unsafe C<vsprintf> which can overrun the buffer (there is an
5461overrun check, but that may be too late). Consider using
5462C<sv_vcatpvf> instead, or getting C<vsnprintf>.
d9fad198
JH		 5463
5464=cut
5465*/
5466int
5467Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
d9fad198
JH		 5468{
5469 dTHX;
5470 int retval;
d9fad198
JH		 5471#ifdef NEED_VA_COPY
5472 va_list apc;
239fec62 5473 Perl_va_copy(ap, apc);
5b692037 5474# ifdef HAS_VSNPRINTF
d9fad198
JH		 5475 retval = vsnprintf(buffer, len, format, apc);
5476# else
5477 retval = vsprintf(buffer, format, apc);
5478# endif
5479#else
5b692037 5480# ifdef HAS_VSNPRINTF
d9fad198
JH		 5481 retval = vsnprintf(buffer, len, format, ap);
5482# else
5483 retval = vsprintf(buffer, format, ap);
5484# endif
5b692037 5485#endif /* #ifdef NEED_VA_COPY */
1208b3dd 5486 /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
625dac9d 5487 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
5b692037 5488 Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
d9fad198
JH		 5489 return retval;
5490}
5491
b0269e46
AB		 5492void
5493Perl_my_clearenv(pTHX)
5494{
5495 dVAR;
5496#if ! defined(PERL_MICRO)
5497# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
5498 PerlEnv_clearenv();
5499# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
5500# if defined(USE_ENVIRON_ARRAY)
5501# if defined(USE_ITHREADS)
5502 /* only the parent thread can clobber the process environment */
5503 if (PL_curinterp == aTHX)
5504# endif /* USE_ITHREADS */
5505 {
5506# if ! defined(PERL_USE_SAFE_PUTENV)
5507 if ( !PL_use_safe_putenv) {
5508 I32 i;
5509 if (environ == PL_origenviron)
5510 environ = (char**)safesysmalloc(sizeof(char*));
5511 else
5512 for (i = 0; environ[i]; i++)
5513 (void)safesysfree(environ[i]);
5514 }
5515 environ[0] = NULL;
5516# else /* PERL_USE_SAFE_PUTENV */
5517# if defined(HAS_CLEARENV)
5518 (void)clearenv();
5519# elif defined(HAS_UNSETENV)
5520 int bsiz = 80; /* Most envvar names will be shorter than this. */
d1307786
JH		 5521 int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
5522 char *buf = (char*)safesysmalloc(bufsiz);
b0269e46
AB		 5523 while (*environ != NULL) {
5524 char *e = strchr(*environ, '=');
b57a0404 5525 int l = e ? e - *environ : (int)strlen(*environ);
b0269e46
AB		 5526 if (bsiz < l + 1) {
5527 (void)safesysfree(buf);
1bdfa2de 5528 bsiz = l + 1; /* + 1 for the \0. */
d1307786 5529 buf = (char*)safesysmalloc(bufsiz);
b0269e46 5530 }
1bdfa2de 5531 my_strlcpy(buf, *environ, l + 1);
b0269e46
AB		 5532 (void)unsetenv(buf);
5533 }
5534 (void)safesysfree(buf);
5535# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
5536 /* Just null environ and accept the leakage. */
5537 *environ = NULL;
5538# endif /* HAS_CLEARENV || HAS_UNSETENV */
5539# endif /* ! PERL_USE_SAFE_PUTENV */
5540 }
5541# endif /* USE_ENVIRON_ARRAY */
5542# endif /* PERL_IMPLICIT_SYS || WIN32 */
5543#endif /* PERL_MICRO */
5544}
5545
f16dd614
DM		 5546#ifdef PERL_IMPLICIT_CONTEXT
5547
53d44271 5548/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
f16dd614
DM		 5549the global PL_my_cxt_index is incremented, and that value is assigned to
5550that module's static my_cxt_index (who's address is passed as an arg).
5551Then, for each interpreter this function is called for, it makes sure a
5552void* slot is available to hang the static data off, by allocating or
5553extending the interpreter's PL_my_cxt_list array */
5554
53d44271 5555#ifndef PERL_GLOBAL_STRUCT_PRIVATE
f16dd614
DM		 5556void *
5557Perl_my_cxt_init(pTHX_ int *index, size_t size)
5558{
97aff369 5559 dVAR;
f16dd614
DM		 5560 void *p;
5561 if (*index == -1) {
5562 /* this module hasn't been allocated an index yet */
5563 MUTEX_LOCK(&PL_my_ctx_mutex);
5564 *index = PL_my_cxt_index++;
5565 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5566 }
5567
5568 /* make sure the array is big enough */
4c901e72
DM		 5569 if (PL_my_cxt_size <= *index) {
5570 if (PL_my_cxt_size) {
5571 while (PL_my_cxt_size <= *index)
f16dd614
DM		 5572 PL_my_cxt_size *= 2;
5573 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5574 }
5575 else {
5576 PL_my_cxt_size = 16;
5577 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5578 }
5579 }
5580 /* newSV() allocates one more than needed */
5581 p = (void*)SvPVX(newSV(size-1));
5582 PL_my_cxt_list[*index] = p;
5583 Zero(p, size, char);
5584 return p;
5585}
53d44271
JH		 5586
5587#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5588
5589int
5590Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
5591{
5592 dVAR;
5593 int index;
5594
5595 for (index = 0; index < PL_my_cxt_index; index++) {
5596 const char *key = PL_my_cxt_keys[index];
5597 /* try direct pointer compare first - there are chances to success,
5598 * and it's much faster.
5599 */
5600 if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
5601 return index;
5602 }
5603 return -1;
5604}
5605
5606void *
5607Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
5608{
5609 dVAR;
5610 void *p;
5611 int index;
5612
5613 index = Perl_my_cxt_index(aTHX_ my_cxt_key);
5614 if (index == -1) {
5615 /* this module hasn't been allocated an index yet */
5616 MUTEX_LOCK(&PL_my_ctx_mutex);
5617 index = PL_my_cxt_index++;
5618 MUTEX_UNLOCK(&PL_my_ctx_mutex);
5619 }
5620
5621 /* make sure the array is big enough */
5622 if (PL_my_cxt_size <= index) {
5623 int old_size = PL_my_cxt_size;
5624 int i;
5625 if (PL_my_cxt_size) {
5626 while (PL_my_cxt_size <= index)
5627 PL_my_cxt_size *= 2;
5628 Renew(PL_my_cxt_list, PL_my_cxt_size, void *);
5629 Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5630 }
5631 else {
5632 PL_my_cxt_size = 16;
5633 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
5634 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
5635 }
5636 for (i = old_size; i < PL_my_cxt_size; i++) {
5637 PL_my_cxt_keys[i] = 0;
5638 PL_my_cxt_list[i] = 0;
5639 }
5640 }
5641 PL_my_cxt_keys[index] = my_cxt_key;
5642 /* newSV() allocates one more than needed */
5643 p = (void*)SvPVX(newSV(size-1));
5644 PL_my_cxt_list[index] = p;
5645 Zero(p, size, char);
5646 return p;
5647}
5648#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
5649#endif /* PERL_IMPLICIT_CONTEXT */
f16dd614 5650
a6cc4119
SP		 5651#ifndef HAS_STRLCAT
5652Size_t
5653Perl_my_strlcat(char *dst, const char *src, Size_t size)
5654{
5655 Size_t used, length, copy;
5656
5657 used = strlen(dst);
5658 length = strlen(src);
5659 if (size > 0 && used < size - 1) {
5660 copy = (length >= size - used) ? size - used - 1 : length;
5661 memcpy(dst + used, src, copy);
5662 dst[used + copy] = '\0';
5663 }
5664 return used + length;
5665}
5666#endif
5667
5668#ifndef HAS_STRLCPY
5669Size_t
5670Perl_my_strlcpy(char *dst, const char *src, Size_t size)
5671{
5672 Size_t length, copy;
5673
5674 length = strlen(src);
5675 if (size > 0) {
5676 copy = (length >= size) ? size - 1 : length;
5677 memcpy(dst, src, copy);
5678 dst[copy] = '\0';
5679 }
5680 return length;
5681}
5682#endif
5683
17dd9954
JH		 5684#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
5685/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
5686long _ftol( double ); /* Defined by VC6 C libs. */
5687long _ftol2( double dblSource ) { return _ftol( dblSource ); }
5688#endif
5689
c51f309c
NC		 5690void
5691Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
5692{
5693 dVAR;
5694 SV * const dbsv = GvSVn(PL_DBsub);
5695 /* We do not care about using sv to call CV;
5696 * it's for informational purposes only.
5697 */
5698
5699 save_item(dbsv);
5700 if (!PERLDB_SUB_NN) {
5701 GV * const gv = CvGV(cv);
5702
5703 if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
5704 || strEQ(GvNAME(gv), "END")
5705 || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
5706 !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
5707 /* Use GV from the stack as a fallback. */
5708 /* GV is potentially non-unique, or contain different CV. */
5709 SV * const tmp = newRV((SV*)cv);
5710 sv_setsv(dbsv, tmp);
5711 SvREFCNT_dec(tmp);
5712 }
5713 else {
5714 gv_efullname3(dbsv, gv, NULL);
5715 }
5716 }
5717 else {
5718 const int type = SvTYPE(dbsv);
5719 if (type < SVt_PVIV && type != SVt_IV)
5720 sv_upgrade(dbsv, SVt_PVIV);
5721 (void)SvIOK_on(dbsv);
5722 SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
5723 }
5724}
5725
ce582cee 5726/*
66610fdd
RGS		 5727 * Local variables:
5728 * c-indentation-style: bsd
5729 * c-basic-offset: 4
5730 * indent-tabs-mode: t
5731 * End:
5732 *
37442d52
RGS		 5733 * ex: set ts=8 sts=4 sw=4 noet:
5734 */
Unnamed repository; edit this file 'description' to name the repository.