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