1 /* util.c 2 * 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 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 40 #endif 41 42 #ifdef HAS_SELECT 43 # ifdef I_SYS_SELECT 44 # include 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 113590711 { 65 dTHX; 66 113590711 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 113590711 if ((long)size < 0) 76 ###### Perl_croak_nocontext("panic: malloc"); 77 #endif 78 113590711 ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 79 113590711 PERL_ALLOC_CHECK(ptr); 80 113590711 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 81 113590711 if (ptr != Nullch) 82 113590711 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 113590711 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 10328774 { 100 dTHX; 101 10328774 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 10328774 if (!size) { 114 ###### safesysfree(where); 115 ###### return NULL; 116 } 117 118 10328774 if (!where) 119 58 return safesysmalloc(size); 120 #ifdef DEBUGGING 121 10328716 if ((long)size < 0) 122 ###### Perl_croak_nocontext("panic: realloc"); 123 #endif 124 10328716 ptr = (Malloc_t)PerlMem_realloc(where,size); 125 10328716 PERL_ALLOC_CHECK(ptr); 126 127 10328716 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); 128 10328716 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); 129 130 10328716 if (ptr != Nullch) 131 10328716 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 10328774 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 114722347 { 149 dVAR; 150 #ifdef PERL_IMPLICIT_SYS 151 dTHX; 152 #endif 153 114722347 DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); 154 114722347 if (where) { 155 109660816 PerlMem_free(where); 156 } 157 } 158 159 /* safe version of system's calloc() */ 160 161 Malloc_t 162 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) 163 ###### { 164 dTHX; 165 ###### Malloc_t ptr; 166 167 #ifdef HAS_64K_LIMIT 168 if (size * count > 0xffff) { 169 PerlIO_printf(Perl_error_log, 170 "Allocation too large: %lx\n", size * count) FLUSH; 171 my_exit(1); 172 } 173 #endif /* HAS_64K_LIMIT */ 174 #ifdef DEBUGGING 175 ###### if ((long)size < 0 || (long)count < 0) 176 ###### Perl_croak_nocontext("panic: calloc"); 177 #endif 178 ###### size *= count; 179 ###### ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ 180 ###### PERL_ALLOC_CHECK(ptr); 181 ###### 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)); 182 ###### if (ptr != Nullch) { 183 ###### memset((void*)ptr, 0, size); 184 ###### return ptr; 185 } 186 ###### else if (PL_nomemok) 187 ###### return Nullch; 188 else { 189 /* Can't use PerlIO to write as it allocates memory */ 190 PerlLIO_write(PerlIO_fileno(Perl_error_log), 191 ###### PL_no_mem, strlen(PL_no_mem)); 192 ###### my_exit(1); 193 ###### return Nullch; 194 } 195 /*NOTREACHED*/ 196 } 197 198 /* These must be defined when not using Perl's malloc for binary 199 * compatibility */ 200 201 #ifndef MYMALLOC 202 203 Malloc_t Perl_malloc (MEM_SIZE nbytes) 204 ###### { 205 dTHXs; 206 ###### return (Malloc_t)PerlMem_malloc(nbytes); 207 } 208 209 Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) 210 ###### { 211 dTHXs; 212 ###### return (Malloc_t)PerlMem_calloc(elements, size); 213 } 214 215 Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) 216 ###### { 217 dTHXs; 218 ###### return (Malloc_t)PerlMem_realloc(where, nbytes); 219 } 220 221 Free_t Perl_mfree (Malloc_t where) 222 ###### { 223 dTHXs; 224 ###### PerlMem_free(where); 225 } 226 227 #endif 228 229 /* copy a string up to some (non-backslashed) delimiter, if any */ 230 231 char * 232 Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) 233 26893 { 234 26893 register I32 tolen; 235 158241 for (tolen = 0; from < fromend; from++, tolen++) { 236 158189 if (*from == '\\') { 237 ###### if (from[1] == delim) 238 ###### from++; 239 else { 240 ###### if (to < toend) 241 ###### *to++ = *from; 242 ###### tolen++; 243 ###### from++; 244 } 245 } 246 158189 else if (*from == delim) 247 26841 break; 248 131348 if (to < toend) 249 131348 *to++ = *from; 250 } 251 26893 if (to < toend) 252 26893 *to = '\0'; 253 26893 *retlen = tolen; 254 26893 return (char *)from; 255 } 256 257 /* return ptr to little string in big string, NULL if not found */ 258 /* This routine was donated by Corey Satten. */ 259 260 char * 261 Perl_instr(pTHX_ register const char *big, register const char *little) 262 2307 { 263 2307 register I32 first; 264 265 2307 if (!little) 266 ###### return (char*)big; 267 2307 first = *little++; 268 2307 if (!first) 269 ###### return (char*)big; 270 37078 while (*big) { 271 35841 register const char *s, *x; 272 35841 if (*big++ != first) 273 33317 continue; 274 5048 for (x=big,s=little; *s; /**/ ) { 275 7730 if (!*x) 276 ###### return Nullch; 277 7730 if (*s++ != *x++) { 278 1454 s--; 279 break; 280 } 281 } 282 2524 if (!*s) 283 1070 return (char*)(big-1); 284 } 285 1237 return Nullch; 286 } 287 288 /* same as instr but allow embedded nulls */ 289 290 char * 291 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) 292 148758 { 293 148758 register const I32 first = *little; 294 148758 register const char *littleend = lend; 295 296 148758 if (!first && little >= littleend) 297 ###### return (char*)big; 298 148758 if (bigend - big < littleend - little) 299 ###### return Nullch; 300 148758 bigend -= littleend - little++; 301 3423820142 while (big <= bigend) { 302 3423776005 register const char *s, *x; 303 3423776005 if (*big++ != first) 304 3335145925 continue; 305 177260160 for (x=big,s=little; s < littleend; /**/ ) { 306 112026090 if (*s++ != *x++) { 307 88525459 s--; 308 break; 309 } 310 } 311 88630080 if (s >= littleend) 312 104621 return (char*)(big-1); 313 } 314 44137 return Nullch; 315 } 316 317 /* reverse of the above--find last substring */ 318 319 char * 320 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) 321 64624 { 322 64624 register const char *bigbeg; 323 64624 register const I32 first = *little; 324 64624 register const char *littleend = lend; 325 326 64624 if (!first && little >= littleend) 327 2 return (char*)bigend; 328 64622 bigbeg = big; 329 64622 big = bigend - (littleend - little++); 330 356953 while (big >= bigbeg) { 331 356923 register const char *s, *x; 332 356923 if (*big-- != first) 333 291118 continue; 334 131610 for (x=big+2,s=little; s < littleend; /**/ ) { 335 28115 if (*s++ != *x++) { 336 1213 s--; 337 break; 338 } 339 } 340 65805 if (s >= littleend) 341 64592 return (char*)(big+1); 342 } 343 30 return Nullch; 344 } 345 346 #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ 347 348 /* As a space optimization, we do not compile tables for strings of length 349 0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are 350 special-cased in fbm_instr(). 351 352 If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ 353 354 /* 355 =head1 Miscellaneous Functions 356 357 =for apidoc fbm_compile 358 359 Analyses the string in order to make fast searches on it using fbm_instr() 360 -- the Boyer-Moore algorithm. 361 362 =cut 363 */ 364 365 void 366 Perl_fbm_compile(pTHX_ SV *sv, U32 flags) 367 232514 { 368 232514 const register U8 *s; 369 232514 register U8 *table; 370 232514 register U32 i; 371 232514 STRLEN len; 372 232514 I32 rarest = 0; 373 232514 U32 frequency = 256; 374 375 232514 if (flags & FBMcf_TAIL) { 376 60846 MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; 377 60846 sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ 378 60846 if (mg && mg->mg_len >= 0) 379 9 mg->mg_len++; 380 } 381 232514 s = (U8*)SvPV_force_mutable(sv, len); 382 232514 SvUPGRADE(sv, SVt_PVBM); 383 232514 if (len == 0) /* TAIL might be on a zero-length string. */ 384 ###### return; 385 232514 if (len > 2) { 386 93318 const unsigned char *sb; 387 93318 const U8 mlen = (len>255) ? 255 : (U8)len; 388 389 93318 Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); 390 93318 table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); 391 93318 s = table - 1 - FBM_TABLE_OFFSET; /* last char */ 392 93318 memset((void*)table, mlen, 256); 393 93318 table[-1] = (U8)flags; 394 93318 i = 0; 395 93318 sb = s - mlen + 1; /* first char (maybe) */ 396 990920 while (s >= sb) { 397 897602 if (table[*s] == mlen) 398 679390 table[*s] = (U8)i; 399 897602 s--, i++; 400 } 401 } 402 232514 sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ 403 232514 SvVALID_on(sv); 404 405 232514 s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ 406 1998142 for (i = 0; i < len; i++) { 407 1765628 if (PL_freq[s[i]] < frequency) { 408 360880 rarest = i; 409 360880 frequency = PL_freq[s[i]]; 410 } 411 } 412 232514 BmRARE(sv) = s[rarest]; 413 232514 BmPREVIOUS(sv) = (U16)rarest; 414 232514 BmUSEFUL(sv) = 100; /* Initial value */ 415 232514 if (flags & FBMcf_TAIL) 416 60846 SvTAIL_on(sv); 417 DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", 418 232514 BmRARE(sv),BmPREVIOUS(sv))); 419 } 420 421 /* If SvTAIL(littlestr), it has a fake '\n' at end. */ 422 /* If SvTAIL is actually due to \Z or \z, this gives false positives 423 if multiline */ 424 425 /* 426 =for apidoc fbm_instr 427 428 Returns the location of the SV in the string delimited by C and 429 C. It returns C if the string can't be found. The C 430 does not have to be fbm_compiled, but the search will not be as fast 431 then. 432 433 =cut 434 */ 435 436 char * 437 Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) 438 5428343 { 439 5428343 register unsigned char *s; 440 5428343 STRLEN l; 441 register const unsigned char *little 442 5428343 = (const unsigned char *)SvPV_const(littlestr,l); 443 5428343 register STRLEN littlelen = l; 444 5428343 register const I32 multiline = flags & FBMrf_MULTILINE; 445 446 5428343 if ((STRLEN)(bigend - big) < littlelen) { 447 157944 if ( SvTAIL(littlestr) 448 && ((STRLEN)(bigend - big) == littlelen - 1) 449 && (littlelen == 1 450 || (*big == *little && 451 memEQ((char *)big, (char *)little, littlelen - 1)))) 452 69667 return (char*)big; 453 88277 return Nullch; 454 } 455 456 5270399 if (littlelen <= 2) { /* Special-cased */ 457 458 3963925 if (littlelen == 1) { 459 3299503 if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ 460 /* Know that bigend != big. */ 461 674826 if (bigend[-1] == '\n') 462 526766 return (char *)(bigend - 1); 463 148060 return (char *) bigend; 464 } 465 2624677 s = big; 466 32933610 while (s < bigend) { 467 32406701 if (*s == *little) 468 2097768 return (char *)s; 469 30308933 s++; 470 } 471 526909 if (SvTAIL(littlestr)) 472 218 return (char *) bigend; 473 526691 return Nullch; 474 } 475 664422 if (!littlelen) 476 2 return (char*)big; /* Cannot be SvTAIL! */ 477 478 /* littlelen is 2 */ 479 664420 if (SvTAIL(littlestr) && !multiline) { 480 66865 if (bigend[-1] == '\n' && bigend[-2] == *little) 481 1847 return (char*)bigend - 2; 482 65018 if (bigend[-1] == *little) 483 29301 return (char*)bigend - 1; 484 35717 return Nullch; 485 } 486 { 487 /* This should be better than FBM if c1 == c2, and almost 488 as good otherwise: maybe better since we do less indirection. 489 And we save a lot of memory by caching no table. */ 490 597555 const unsigned char c1 = little[0]; 491 597555 const unsigned char c2 = little[1]; 492 493 597555 s = big + 1; 494 597555 bigend--; 495 597555 if (c1 != c2) { 496 991773616 while (s <= bigend) { 497 991660653 if (s[0] == c2) { 498 4586650 if (s[-1] == c1) 499 256257 return (char*)s - 1; 500 4330393 s += 2; 501 4330393 continue; 502 } 503 next_chars: 504 994820892 if (s[0] == c1) { 505 7877332 if (s == bigend) 506 6698 goto check_1char_anchor; 507 7870634 if (s[1] == c2) 508 123745 return (char*)s; 509 else { 510 7746889 s++; 511 7746889 goto next_chars; 512 } 513 } 514 else 515 986943560 s += 2; 516 } 517 97892 goto check_1char_anchor; 518 } 519 /* Now c1 == c2 */ 520 8309541 while (s <= bigend) { 521 8240953 if (s[0] == c1) { 522 82407 if (s[-1] == c1) 523 20259 return (char*)s - 1; 524 62148 if (s == bigend) 525 343 goto check_1char_anchor; 526 61805 if (s[1] == c1) 527 8702 return (char*)s; 528 53103 s += 3; 529 } 530 else 531 8158546 s += 2; 532 } 533 } 534 check_1char_anchor: /* One char and anchor! */ 535 188592 if (SvTAIL(littlestr) && (*bigend == *little)) 536 31 return (char *)bigend; /* bigend is already decremented. */ 537 188561 return Nullch; 538 } 539 1306474 if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ 540 18470 s = bigend - littlelen; 541 18470 if (s >= big && bigend[-1] == '\n' && *s == *little 542 /* Automatically of length > 2 */ 543 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 544 { 545 175 return (char*)s; /* how sweet it is */ 546 } 547 18295 if (s[1] == *little 548 && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) 549 { 550 6352 return (char*)s + 1; /* how sweet it is */ 551 } 552 11943 return Nullch; 553 } 554 1288004 if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { 555 147021 char *b = ninstr((char*)big,(char*)bigend, 556 147021 (char*)little, (char*)little + littlelen); 557 558 147021 if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ 559 /* Chop \n from littlestr: */ 560 ###### s = bigend - littlelen + 1; 561 ###### if (*s == *little 562 && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) 563 { 564 ###### return (char*)s; 565 } 566 ###### return Nullch; 567 } 568 147021 return b; 569 } 570 571 { /* Do actual FBM. */ 572 1140983 register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; 573 1140983 const register unsigned char *oldlittle; 574 575 1140983 if (littlelen > (STRLEN)(bigend - big)) 576 ###### return Nullch; 577 1140983 --littlelen; /* Last char found by table lookup */ 578 579 1140983 s = big + littlelen; 580 1140983 little += littlelen; /* last char */ 581 1140983 oldlittle = little; 582 1140983 if (s < bigend) { 583 92550937 register I32 tmp; 584 585 top2: 586 92550937 if ((tmp = table[*s])) { 587 89713210 if ((s += tmp) < bigend) 588 89092353 goto top2; 589 2837727 goto check_end; 590 } 591 else { /* less expensive than calling strncmp() */ 592 2837727 register unsigned char * const olds = s; 593 594 2837727 tmp = littlelen; 595 596 5209300 while (tmp--) { 597 4695531 if (*--s == *--little) 598 2371573 continue; 599 2323958 s = olds + 1; /* here we pay the price for failure */ 600 2323958 little = oldlittle; 601 2323958 if (s < bigend) /* fake up continue to outer loop */ 602 2317601 goto top2; 603 513769 goto check_end; 604 } 605 513769 return (char *)s; 606 } 607 } 608 check_end: 609 627214 if ( s == bigend && (table[-1] & FBMcf_TAIL) 610 && memEQ((char *)(bigend - littlelen), 611 (char *)(oldlittle - littlelen), littlelen) ) 612 120 return (char*)bigend - littlelen; 613 627094 return Nullch; 614 } 615 } 616 617 /* start_shift, end_shift are positive quantities which give offsets 618 of ends of some substring of bigstr. 619 If "last" we want the last occurrence. 620 old_posp is the way of communication between consequent calls if 621 the next call needs to find the . 622 The initial *old_posp should be -1. 623 624 Note that we take into account SvTAIL, so one can get extra 625 optimizations if _ALL flag is set. 626 */ 627 628 /* If SvTAIL is actually due to \Z or \z, this gives false positives 629 if PL_multiline. In fact if !PL_multiline the authoritative answer 630 is not supported yet. */ 631 632 char * 633 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) 634 27 { 635 27 const register unsigned char *big; 636 27 register I32 pos; 637 27 register I32 previous; 638 27 register I32 first; 639 27 const register unsigned char *little; 640 27 register I32 stop_pos; 641 27 const register unsigned char *littleend; 642 27 I32 found = 0; 643 644 27 if (*old_posp == -1 645 ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 646 : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { 647 cant_find: 648 3 if ( BmRARE(littlestr) == '\n' 649 && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { 650 ###### little = (const unsigned char *)(SvPVX_const(littlestr)); 651 ###### littleend = little + SvCUR(littlestr); 652 ###### first = *little++; 653 ###### goto check_tail; 654 } 655 3 return Nullch; 656 } 657 658 25 little = (const unsigned char *)(SvPVX_const(littlestr)); 659 25 littleend = little + SvCUR(littlestr); 660 25 first = *little++; 661 /* The value of pos we can start at: */ 662 25 previous = BmPREVIOUS(littlestr); 663 25 big = (const unsigned char *)(SvPVX_const(bigstr)); 664 /* The value of pos we can stop at: */ 665 25 stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); 666 25 if (previous + start_shift > stop_pos) { 667 /* 668 stop_pos does not include SvTAIL in the count, so this check is incorrect 669 (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 670 */ 671 #if 0 672 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ 673 goto check_tail; 674 #endif 675 1 return Nullch; 676 } 677 40 while (pos < previous + start_shift) { 678 17 if (!(pos += PL_screamnext[pos])) 679 1 goto cant_find; 680 } 681 23 big -= previous; 682 23 do { 683 23 const register unsigned char *s, *x; 684 23 if (pos >= stop_pos) break; 685 22 if (big[pos] != first) 686 ###### continue; 687 44 for (x=big+pos+1,s=little; s < littleend; /**/ ) { 688 16 if (*s++ != *x++) { 689 ###### s--; 690 break; 691 } 692 } 693 22 if (s == littleend) { 694 22 *old_posp = pos; 695 22 if (!last) return (char *)(big+pos); 696 ###### found = 1; 697 } 698 ###### } while ( pos += PL_screamnext[pos] ); 699 1 if (last && found) 700 ###### return (char *)(big+(*old_posp)); 701 check_tail: 702 1 if (!SvTAIL(littlestr) || (end_shift > 0)) 703 ###### return Nullch; 704 /* Ignore the trailing "\n". This code is not microoptimized */ 705 1 big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); 706 1 stop_pos = littleend - little; /* Actual littlestr len */ 707 1 if (stop_pos == 0) 708 ###### return (char*)big; 709 1 big -= stop_pos; 710 1 if (*big == first 711 && ((stop_pos == 1) || 712 memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) 713 1 return (char*)big; 714 ###### return Nullch; 715 } 716 717 I32 718 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) 719 18427 { 720 18427 register const U8 *a = (const U8 *)s1; 721 18427 register const U8 *b = (const U8 *)s2; 722 48929 while (len--) { 723 43366 if (*a != *b && *a != PL_fold[*b]) 724 12864 return 1; 725 30502 a++,b++; 726 } 727 5563 return 0; 728 } 729 730 I32 731 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) 732 170 { 733 dVAR; 734 170 register const U8 *a = (const U8 *)s1; 735 170 register const U8 *b = (const U8 *)s2; 736 367 while (len--) { 737 362 if (*a != *b && *a != PL_fold_locale[*b]) 738 165 return 1; 739 197 a++,b++; 740 } 741 5 return 0; 742 } 743 744 /* copy a string to a safe spot */ 745 746 /* 747 =head1 Memory Management 748 749 =for apidoc savepv 750 751 Perl's version of C. Returns a pointer to a newly allocated 752 string which is a duplicate of C. The size of the string is 753 determined by C. The memory allocated for the new string can 754 be freed with the C function. 755 756 =cut 757 */ 758 759 char * 760 Perl_savepv(pTHX_ const char *pv) 761 172190 { 762 172190 if (!pv) 763 ###### return Nullch; 764 else { 765 172190 char *newaddr; 766 172190 const STRLEN pvlen = strlen(pv)+1; 767 172190 New(902,newaddr,pvlen,char); 768 172190 return memcpy(newaddr,pv,pvlen); 769 } 770 771 } 772 773 /* same thing but with a known length */ 774 775 /* 776 =for apidoc savepvn 777 778 Perl's version of what C would be if it existed. Returns a 779 pointer to a newly allocated string which is a duplicate of the first 780 C bytes from C. The memory allocated for the new string can be 781 freed with the C function. 782 783 =cut 784 */ 785 786 char * 787 Perl_savepvn(pTHX_ const char *pv, register I32 len) 788 7387794 { 789 7387794 register char *newaddr; 790 791 7387794 New(903,newaddr,len+1,char); 792 /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ 793 7387794 if (pv) { 794 /* might not be null terminated */ 795 7387794 newaddr[len] = '\0'; 796 7387794 return (char *) CopyD(pv,newaddr,len,char); 797 } 798 else { 799 ###### return (char *) ZeroD(newaddr,len+1,char); 800 } 801 } 802 803 /* 804 =for apidoc savesharedpv 805 806 A version of C which allocates the duplicate string in memory 807 which is shared between threads. 808 809 =cut 810 */ 811 char * 812 Perl_savesharedpv(pTHX_ const char *pv) 813 ###### { 814 ###### register char *newaddr; 815 ###### STRLEN pvlen; 816 ###### if (!pv) 817 ###### return Nullch; 818 819 ###### pvlen = strlen(pv)+1; 820 ###### newaddr = (char*)PerlMemShared_malloc(pvlen); 821 ###### if (!newaddr) { 822 PerlLIO_write(PerlIO_fileno(Perl_error_log), 823 ###### PL_no_mem, strlen(PL_no_mem)); 824 ###### my_exit(1); 825 } 826 ###### return memcpy(newaddr,pv,pvlen); 827 } 828 829 /* 830 =for apidoc savesvpv 831 832 A version of C/C which gets the string to duplicate from 833 the passed in SV using C 834 835 =cut 836 */ 837 838 char * 839 Perl_savesvpv(pTHX_ SV *sv) 840 1351 { 841 1351 STRLEN len; 842 1351 const char *pv = SvPV_const(sv, len); 843 1351 register char *newaddr; 844 845 1351 ++len; 846 1351 New(903,newaddr,len,char); 847 1351 return (char *) CopyD(pv,newaddr,len,char); 848 } 849 850 851 /* the SV for Perl_form() and mess() is not kept in an arena */ 852 853 STATIC SV * 854 S_mess_alloc(pTHX) 855 16625 { 856 16625 SV *sv; 857 16625 XPVMG *any; 858 859 16625 if (!PL_dirty) 860 16618 return sv_2mortal(newSVpvn("",0)); 861 862 7 if (PL_mess_sv) 863 4 return PL_mess_sv; 864 865 /* Create as PVMG now, to avoid any upgrading later */ 866 3 New(905, sv, 1, SV); 867 3 Newz(905, any, 1, XPVMG); 868 3 SvFLAGS(sv) = SVt_PVMG; 869 3 SvANY(sv) = (void*)any; 870 3 SvPV_set(sv, 0); 871 3 SvREFCNT(sv) = 1 << 30; /* practically infinite */ 872 3 PL_mess_sv = sv; 873 3 return sv; 874 } 875 876 #if defined(PERL_IMPLICIT_CONTEXT) 877 char * 878 Perl_form_nocontext(const char* pat, ...) 879 { 880 dTHX; 881 char *retval; 882 va_list args; 883 va_start(args, pat); 884 retval = vform(pat, &args); 885 va_end(args); 886 return retval; 887 } 888 #endif /* PERL_IMPLICIT_CONTEXT */ 889 890 /* 891 =head1 Miscellaneous Functions 892 =for apidoc form 893 894 Takes a sprintf-style format pattern and conventional 895 (non-SV) arguments and returns the formatted string. 896 897 (char *) Perl_form(pTHX_ const char* pat, ...) 898 899 can be used any place a string (char *) is required: 900 901 char * s = Perl_form("%d.%d",major,minor); 902 903 Uses a single private buffer so if you want to format several strings you 904 must explicitly copy the earlier strings away (and free the copies when you 905 are done). 906 907 =cut 908 */ 909 910 char * 911 Perl_form(pTHX_ const char* pat, ...) 912 7598 { 913 7598 char *retval; 914 7598 va_list args; 915 7598 va_start(args, pat); 916 7598 retval = vform(pat, &args); 917 7598 va_end(args); 918 7598 return retval; 919 } 920 921 char * 922 Perl_vform(pTHX_ const char *pat, va_list *args) 923 7598 { 924 7598 SV *sv = mess_alloc(); 925 7598 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 926 7598 return SvPVX(sv); 927 } 928 929 #if defined(PERL_IMPLICIT_CONTEXT) 930 SV * 931 Perl_mess_nocontext(const char *pat, ...) 932 { 933 dTHX; 934 SV *retval; 935 va_list args; 936 va_start(args, pat); 937 retval = vmess(pat, &args); 938 va_end(args); 939 return retval; 940 } 941 #endif /* PERL_IMPLICIT_CONTEXT */ 942 943 SV * 944 Perl_mess(pTHX_ const char *pat, ...) 945 106 { 946 106 SV *retval; 947 106 va_list args; 948 106 va_start(args, pat); 949 106 retval = vmess(pat, &args); 950 106 va_end(args); 951 106 return retval; 952 } 953 954 STATIC COP* 955 S_closest_cop(pTHX_ COP *cop, const OP *o) 956 25885 { 957 /* Look for PL_op starting from o. cop is the last COP we've seen. */ 958 959 25885 if (!o || o == PL_op) return cop; 960 961 18239 if (o->op_flags & OPf_KIDS) { 962 11107 OP *kid; 963 19606 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 964 { 965 18095 COP *new_cop; 966 967 /* If the OP_NEXTSTATE has been optimised away we can still use it 968 * the get the file and line number. */ 969 970 18095 if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) 971 29 cop = (COP *)kid; 972 973 /* Keep searching, and return when we've found something. */ 974 975 18095 new_cop = closest_cop(cop, kid); 976 18095 if (new_cop) return new_cop; 977 } 978 } 979 980 /* Nothing found. */ 981 982 8643 return Null(COP *); 983 } 984 985 SV * 986 Perl_vmess(pTHX_ const char *pat, va_list *args) 987 9027 { 988 9027 SV *sv = mess_alloc(); 989 9027 static const char dgd[] = " during global destruction.\n"; 990 991 9027 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); 992 9027 if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { 993 994 /* 995 * Try and find the file and line for PL_op. This will usually be 996 * PL_curcop, but it might be a cop that has been optimised away. We 997 * can try to find such a cop by searching through the optree starting 998 * from the sibling of PL_curcop. 999 */ 1000 1001 7790 const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); 1002 7790 if (!cop) cop = PL_curcop; 1003 1004 7790 if (CopLINE(cop)) 1005 7788 Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, 1006 OutCopFILE(cop), (IV)CopLINE(cop)); 1007 7790 if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { 1008 639 const bool line_mode = (RsSIMPLE(PL_rs) && 1009 639 SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); 1010 639 Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, 1011 PL_last_in_gv == PL_argvgv ? 1012 "" : GvNAME(PL_last_in_gv), 1013 line_mode ? "line" : "chunk", 1014 (IV)IoLINES(GvIOp(PL_last_in_gv))); 1015 } 1016 7790 sv_catpv(sv, PL_dirty ? dgd : ".\n"); 1017 } 1018 9027 return sv; 1019 } 1020 1021 void 1022 Perl_write_to_stderr(pTHX_ const char* message, int msglen) 1023 1618 { 1024 dVAR; 1025 1618 IO *io; 1026 1618 MAGIC *mg; 1027 1028 1618 if (PL_stderrgv && SvREFCNT(PL_stderrgv) 1029 && (io = GvIO(PL_stderrgv)) 1030 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) 1031 { 1032 5 dSP; 1033 5 ENTER; 1034 5 SAVETMPS; 1035 1036 5 save_re_context(); 1037 5 SAVESPTR(PL_stderrgv); 1038 5 PL_stderrgv = Nullgv; 1039 1040 5 PUSHSTACKi(PERLSI_MAGIC); 1041 1042 5 PUSHMARK(SP); 1043 5 EXTEND(SP,2); 1044 5 PUSHs(SvTIED_obj((SV*)io, mg)); 1045 5 PUSHs(sv_2mortal(newSVpvn(message, msglen))); 1046 5 PUTBACK; 1047 5 call_method("PRINT", G_SCALAR); 1048 1049 4 POPSTACK; 1050 4 FREETMPS; 1051 4 LEAVE; 1052 } 1053 else { 1054 #ifdef USE_SFIO 1055 /* SFIO can really mess with your errno */ 1056 const int e = errno; 1057 #endif 1058 1613 PerlIO * const serr = Perl_error_log; 1059 1060 1613 PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); 1061 1613 (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 STATIC void 1071 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) 1072 1124 { 1073 1124 HV *stash; 1074 1124 GV *gv; 1075 1124 CV *cv; 1076 /* sv_2cv might call Perl_croak() */ 1077 1124 SV *olddiehook = PL_diehook; 1078 1079 1124 assert(PL_diehook); 1080 1124 ENTER; 1081 1124 SAVESPTR(PL_diehook); 1082 1124 PL_diehook = Nullsv; 1083 1124 cv = sv_2cv(olddiehook, &stash, &gv, 0); 1084 1124 LEAVE; 1085 1124 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1086 1120 dSP; 1087 1120 SV *msg; 1088 1089 1120 ENTER; 1090 1120 save_re_context(); 1091 1120 if (message) { 1092 1115 msg = newSVpvn(message, msglen); 1093 1115 SvFLAGS(msg) |= utf8; 1094 1115 SvREADONLY_on(msg); 1095 1115 SAVEFREESV(msg); 1096 } 1097 else { 1098 5 msg = ERRSV; 1099 } 1100 1101 1120 PUSHSTACKi(PERLSI_DIEHOOK); 1102 1120 PUSHMARK(SP); 1103 1120 XPUSHs(msg); 1104 1120 PUTBACK; 1105 1120 call_sv((SV*)cv, G_DISCARD); 1106 1115 POPSTACK; 1107 1115 LEAVE; 1108 } 1109 } 1110 1111 STATIC const char * 1112 S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, 1113 I32* utf8) 1114 4492 { 1115 dVAR; 1116 4492 const char *message; 1117 1118 4492 if (pat) { 1119 4482 SV *msv = vmess(pat, args); 1120 4482 if (PL_errors && SvCUR(PL_errors)) { 1121 44 sv_catsv(PL_errors, msv); 1122 44 message = SvPV_const(PL_errors, *msglen); 1123 44 SvCUR_set(PL_errors, 0); 1124 } 1125 else 1126 4438 message = SvPV_const(msv,*msglen); 1127 4482 *utf8 = SvUTF8(msv); 1128 } 1129 else { 1130 10 message = Nullch; 1131 } 1132 1133 DEBUG_S(PerlIO_printf(Perl_debug_log, 1134 "%p: die/croak: message = %s\ndiehook = %p\n", 1135 thr, message, PL_diehook)); 1136 4492 if (PL_diehook) { 1137 1123 S_vdie_common(aTHX_ message, *msglen, *utf8); 1138 } 1139 4487 return message; 1140 } 1141 1142 OP * 1143 Perl_vdie(pTHX_ const char* pat, va_list *args) 1144 1697 { 1145 1697 const char *message; 1146 1697 const int was_in_eval = PL_in_eval; 1147 1697 STRLEN msglen; 1148 1697 I32 utf8 = 0; 1149 1150 DEBUG_S(PerlIO_printf(Perl_debug_log, 1151 "%p: die: curstack = %p, mainstack = %p\n", 1152 thr, PL_curstack, PL_mainstack)); 1153 1154 1697 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); 1155 1156 1692 PL_restartop = die_where(message, msglen); 1157 1606 SvFLAGS(ERRSV) |= utf8; 1158 DEBUG_S(PerlIO_printf(Perl_debug_log, 1159 "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", 1160 thr, PL_restartop, was_in_eval, PL_top_env)); 1161 1606 if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) 1162 1606 JMPENV_JUMP(3); 1163 ###### return PL_restartop; 1164 } 1165 1166 #if defined(PERL_IMPLICIT_CONTEXT) 1167 OP * 1168 Perl_die_nocontext(const char* pat, ...) 1169 { 1170 dTHX; 1171 OP *o; 1172 va_list args; 1173 va_start(args, pat); 1174 o = vdie(pat, &args); 1175 va_end(args); 1176 return o; 1177 } 1178 #endif /* PERL_IMPLICIT_CONTEXT */ 1179 1180 OP * 1181 Perl_die(pTHX_ const char* pat, ...) 1182 1687 { 1183 1687 OP *o; 1184 1687 va_list args; 1185 1687 va_start(args, pat); 1186 1687 o = vdie(pat, &args); 1187 ###### va_end(args); 1188 ###### return o; 1189 } 1190 1191 void 1192 Perl_vcroak(pTHX_ const char* pat, va_list *args) 1193 2795 { 1194 2795 const char *message; 1195 2795 STRLEN msglen; 1196 2795 I32 utf8 = 0; 1197 1198 2795 message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); 1199 1200 2795 if (PL_in_eval) { 1201 2713 PL_restartop = die_where(message, msglen); 1202 2708 SvFLAGS(ERRSV) |= utf8; 1203 2708 JMPENV_JUMP(3); 1204 } 1205 82 else if (!message) 1206 ###### message = SvPVx_const(ERRSV, msglen); 1207 1208 82 write_to_stderr(message, msglen); 1209 81 my_failure_exit(); 1210 } 1211 1212 #if defined(PERL_IMPLICIT_CONTEXT) 1213 void 1214 Perl_croak_nocontext(const char *pat, ...) 1215 { 1216 dTHX; 1217 va_list args; 1218 va_start(args, pat); 1219 vcroak(pat, &args); 1220 /* NOTREACHED */ 1221 va_end(args); 1222 } 1223 #endif /* PERL_IMPLICIT_CONTEXT */ 1224 1225 /* 1226 =head1 Warning and Dieing 1227 1228 =for apidoc croak 1229 1230 This is the XSUB-writer's interface to Perl's C function. 1231 Normally call this function the same way you call the C C 1232 function. Calling C returns control directly to Perl, 1233 sidestepping the normal C order of execution. See C. 1234 1235 If you want to throw an exception object, assign the object to 1236 C<$@> and then pass C to croak(): 1237 1238 errsv = get_sv("@", TRUE); 1239 sv_setsv(errsv, exception_object); 1240 croak(Nullch); 1241 1242 =cut 1243 */ 1244 1245 void 1246 Perl_croak(pTHX_ const char *pat, ...) 1247 2795 { 1248 2795 va_list args; 1249 2795 va_start(args, pat); 1250 2795 vcroak(pat, &args); 1251 /* NOTREACHED */ 1252 va_end(args); 1253 } 1254 1255 void 1256 Perl_vwarn(pTHX_ const char* pat, va_list *args) 1257 4353 { 1258 dVAR; 1259 4353 STRLEN msglen; 1260 4353 SV * const msv = vmess(pat, args); 1261 4353 const I32 utf8 = SvUTF8(msv); 1262 4353 const char * const message = SvPV_const(msv, msglen); 1263 1264 4353 if (PL_warnhook) { 1265 /* sv_2cv might call Perl_warn() */ 1266 2909 SV * const oldwarnhook = PL_warnhook; 1267 2909 CV * cv; 1268 2909 HV * stash; 1269 2909 GV * gv; 1270 1271 2909 ENTER; 1272 2909 SAVESPTR(PL_warnhook); 1273 2909 PL_warnhook = Nullsv; 1274 2909 cv = sv_2cv(oldwarnhook, &stash, &gv, 0); 1275 2909 LEAVE; 1276 2909 if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { 1277 2909 dSP; 1278 2909 SV *msg; 1279 1280 2909 ENTER; 1281 2909 save_re_context(); 1282 2909 msg = newSVpvn(message, msglen); 1283 2909 SvFLAGS(msg) |= utf8; 1284 2909 SvREADONLY_on(msg); 1285 2909 SAVEFREESV(msg); 1286 1287 2909 PUSHSTACKi(PERLSI_WARNHOOK); 1288 2909 PUSHMARK(SP); 1289 2909 XPUSHs(msg); 1290 2909 PUTBACK; 1291 2909 call_sv((SV*)cv, G_DISCARD); 1292 2877 POPSTACK; 1293 2877 LEAVE; 1294 2877 return; 1295 } 1296 } 1297 1298 1444 write_to_stderr(message, msglen); 1299 } 1300 1301 #if defined(PERL_IMPLICIT_CONTEXT) 1302 void 1303 Perl_warn_nocontext(const char *pat, ...) 1304 { 1305 dTHX; 1306 va_list args; 1307 va_start(args, pat); 1308 vwarn(pat, &args); 1309 va_end(args); 1310 } 1311 #endif /* PERL_IMPLICIT_CONTEXT */ 1312 1313 /* 1314 =for apidoc warn 1315 1316 This is the XSUB-writer's interface to Perl's C function. Call this 1317 function the same way you call the C C function. See C. 1318 1319 =cut 1320 */ 1321 1322 void 1323 Perl_warn(pTHX_ const char *pat, ...) 1324 317 { 1325 317 va_list args; 1326 317 va_start(args, pat); 1327 317 vwarn(pat, &args); 1328 va_end(args); 1329 } 1330 1331 #if defined(PERL_IMPLICIT_CONTEXT) 1332 void 1333 Perl_warner_nocontext(U32 err, const char *pat, ...) 1334 { 1335 dTHX; 1336 va_list args; 1337 va_start(args, pat); 1338 vwarner(err, pat, &args); 1339 va_end(args); 1340 } 1341 #endif /* PERL_IMPLICIT_CONTEXT */ 1342 1343 void 1344 Perl_warner(pTHX_ U32 err, const char* pat,...) 1345 4068 { 1346 4068 va_list args; 1347 4068 va_start(args, pat); 1348 4068 vwarner(err, pat, &args); 1349 va_end(args); 1350 } 1351 1352 void 1353 Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) 1354 4068 { 1355 dVAR; 1356 4068 if (ckDEAD(err)) { 1357 32 SV * const msv = vmess(pat, args); 1358 32 STRLEN msglen; 1359 32 const char *message = SvPV_const(msv, msglen); 1360 32 const I32 utf8 = SvUTF8(msv); 1361 1362 32 if (PL_diehook) { 1363 1 assert(message); 1364 1 S_vdie_common(aTHX_ message, msglen, utf8); 1365 } 1366 32 if (PL_in_eval) { 1367 6 PL_restartop = die_where(message, msglen); 1368 6 SvFLAGS(ERRSV) |= utf8; 1369 6 JMPENV_JUMP(3); 1370 } 1371 26 write_to_stderr(message, msglen); 1372 26 my_failure_exit(); 1373 } 1374 else { 1375 4036 Perl_vwarn(aTHX_ pat, args); 1376 } 1377 } 1378 1379 /* implements the ckWARN? macros */ 1380 1381 bool 1382 Perl_ckwarn(pTHX_ U32 w) 1383 16022512 { 1384 16022512 return 1385 ( 1386 isLEXWARN_on 1387 && PL_curcop->cop_warnings != pWARN_NONE 1388 && ( 1389 PL_curcop->cop_warnings == pWARN_ALL 1390 || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) 1391 || (unpackWARN2(w) && 1392 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) 1393 || (unpackWARN3(w) && 1394 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) 1395 || (unpackWARN4(w) && 1396 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) 1397 ) 1398 ) 1399 || 1400 ( 1401 isLEXWARN_off && PL_dowarn & G_WARN_ON 1402 ) 1403 ; 1404 } 1405 1406 /* implements the ckWARN?_d macro */ 1407 1408 bool 1409 Perl_ckwarn_d(pTHX_ U32 w) 1410 4972019 { 1411 4972019 return 1412 isLEXWARN_off 1413 || PL_curcop->cop_warnings == pWARN_ALL 1414 || ( 1415 PL_curcop->cop_warnings != pWARN_NONE 1416 && ( 1417 isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) 1418 || (unpackWARN2(w) && 1419 isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) 1420 || (unpackWARN3(w) && 1421 isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) 1422 || (unpackWARN4(w) && 1423 isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) 1424 ) 1425 ) 1426 ; 1427 } 1428 1429 1430 1431 /* since we've already done strlen() for both nam and val 1432 * we can use that info to make things faster than 1433 * sprintf(s, "%s=%s", nam, val) 1434 */ 1435 #define my_setenv_format(s, nam, nlen, val, vlen) \ 1436 Copy(nam, s, nlen, char); \ 1437 *(s+nlen) = '='; \ 1438 Copy(val, s+(nlen+1), vlen, char); \ 1439 *(s+(nlen+1+vlen)) = '\0' 1440 1441 #ifdef USE_ENVIRON_ARRAY 1442 /* VMS' my_setenv() is in vms.c */ 1443 #if !defined(WIN32) && !defined(NETWARE) 1444 void 1445 Perl_my_setenv(pTHX_ const char *nam, const char *val) 1446 223970 { 1447 dVAR; 1448 #ifdef USE_ITHREADS 1449 /* only parent thread can modify process environment */ 1450 if (PL_curinterp == aTHX) 1451 #endif 1452 { 1453 #ifndef PERL_USE_SAFE_PUTENV 1454 223970 if (!PL_use_safe_putenv) { 1455 /* most putenv()s leak, so we manipulate environ directly */ 1456 223922 register I32 i=setenv_getix(nam); /* where does it go? */ 1457 223922 int nlen, vlen; 1458 1459 223922 if (environ == PL_origenviron) { /* need we copy environment? */ 1460 4502 I32 j; 1461 4502 I32 max; 1462 4502 char **tmpenv; 1463 1464 4502 for (max = i; environ[max]; max++) ; 1465 4502 tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); 1466 219272 for (j=0; j= 0; i++) ; 1569 return i ? 0 : -1; 1570 } 1571 #endif 1572 1573 /* this is a drop-in replacement for bcopy() */ 1574 #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) 1575 char * 1576 Perl_my_bcopy(register const char *from,register char *to,register I32 len) 1577 { 1578 char *retval = to; 1579 1580 if (from - to >= 0) { 1581 while (len--) 1582 *to++ = *from++; 1583 } 1584 else { 1585 to += len; 1586 from += len; 1587 while (len--) 1588 *(--to) = *(--from); 1589 } 1590 return retval; 1591 } 1592 #endif 1593 1594 /* this is a drop-in replacement for memset() */ 1595 #ifndef HAS_MEMSET 1596 void * 1597 Perl_my_memset(register char *loc, register I32 ch, register I32 len) 1598 { 1599 char *retval = loc; 1600 1601 while (len--) 1602 *loc++ = ch; 1603 return retval; 1604 } 1605 #endif 1606 1607 /* this is a drop-in replacement for bzero() */ 1608 #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) 1609 char * 1610 Perl_my_bzero(register char *loc, register I32 len) 1611 { 1612 char *retval = loc; 1613 1614 while (len--) 1615 *loc++ = 0; 1616 return retval; 1617 } 1618 #endif 1619 1620 /* this is a drop-in replacement for memcmp() */ 1621 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) 1622 I32 1623 Perl_my_memcmp(const char *s1, const char *s2, register I32 len) 1624 { 1625 register const U8 *a = (const U8 *)s1; 1626 register const U8 *b = (const U8 *)s2; 1627 register I32 tmp; 1628 1629 while (len--) { 1630 if ((tmp = *a++ - *b++)) 1631 return tmp; 1632 } 1633 return 0; 1634 } 1635 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ 1636 1637 #ifndef HAS_VPRINTF 1638 1639 #ifdef USE_CHAR_VSPRINTF 1640 char * 1641 #else 1642 int 1643 #endif 1644 vsprintf(char *dest, const char *pat, char *args) 1645 { 1646 FILE fakebuf; 1647 1648 fakebuf._ptr = dest; 1649 fakebuf._cnt = 32767; 1650 #ifndef _IOSTRG 1651 #define _IOSTRG 0 1652 #endif 1653 fakebuf._flag = _IOWRT|_IOSTRG; 1654 _doprnt(pat, args, &fakebuf); /* what a kludge */ 1655 (void)putc('\0', &fakebuf); 1656 #ifdef USE_CHAR_VSPRINTF 1657 return(dest); 1658 #else 1659 return 0; /* perl doesn't use return value */ 1660 #endif 1661 } 1662 1663 #endif /* HAS_VPRINTF */ 1664 1665 #ifdef MYSWAP 1666 #if BYTEORDER != 0x4321 1667 short 1668 Perl_my_swap(pTHX_ short s) 1669 { 1670 #if (BYTEORDER & 1) == 0 1671 short result; 1672 1673 result = ((s & 255) << 8) + ((s >> 8) & 255); 1674 return result; 1675 #else 1676 return s; 1677 #endif 1678 } 1679 1680 long 1681 Perl_my_htonl(pTHX_ long l) 1682 { 1683 union { 1684 long result; 1685 char c[sizeof(long)]; 1686 } u; 1687 1688 #if BYTEORDER == 0x1234 1689 u.c[0] = (l >> 24) & 255; 1690 u.c[1] = (l >> 16) & 255; 1691 u.c[2] = (l >> 8) & 255; 1692 u.c[3] = l & 255; 1693 return u.result; 1694 #else 1695 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 1696 Perl_croak(aTHX_ "Unknown BYTEORDER\n"); 1697 #else 1698 register I32 o; 1699 register I32 s; 1700 1701 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 1702 u.c[o & 0xf] = (l >> s) & 255; 1703 } 1704 return u.result; 1705 #endif 1706 #endif 1707 } 1708 1709 long 1710 Perl_my_ntohl(pTHX_ long l) 1711 { 1712 union { 1713 long l; 1714 char c[sizeof(long)]; 1715 } u; 1716 1717 #if BYTEORDER == 0x1234 1718 u.c[0] = (l >> 24) & 255; 1719 u.c[1] = (l >> 16) & 255; 1720 u.c[2] = (l >> 8) & 255; 1721 u.c[3] = l & 255; 1722 return u.l; 1723 #else 1724 #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) 1725 Perl_croak(aTHX_ "Unknown BYTEORDER\n"); 1726 #else 1727 register I32 o; 1728 register I32 s; 1729 1730 u.l = l; 1731 l = 0; 1732 for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { 1733 l |= (u.c[o & 0xf] & 255) << s; 1734 } 1735 return l; 1736 #endif 1737 #endif 1738 } 1739 1740 #endif /* BYTEORDER != 0x4321 */ 1741 #endif /* MYSWAP */ 1742 1743 /* 1744 * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. 1745 * If these functions are defined, 1746 * the BYTEORDER is neither 0x1234 nor 0x4321. 1747 * However, this is not assumed. 1748 * -DWS 1749 */ 1750 1751 #define HTOLE(name,type) \ 1752 type \ 1753 name (register type n) \ 1754 { \ 1755 union { \ 1756 type value; \ 1757 char c[sizeof(type)]; \ 1758 } u; \ 1759 register I32 i; \ 1760 register I32 s = 0; \ 1761 for (i = 0; i < sizeof(u.c); i++, s += 8) { \ 1762 u.c[i] = (n >> s) & 0xFF; \ 1763 } \ 1764 return u.value; \ 1765 } 1766 1767 #define LETOH(name,type) \ 1768 type \ 1769 name (register type n) \ 1770 { \ 1771 union { \ 1772 type value; \ 1773 char c[sizeof(type)]; \ 1774 } u; \ 1775 register I32 i; \ 1776 register I32 s = 0; \ 1777 u.value = n; \ 1778 n = 0; \ 1779 for (i = 0; i < sizeof(u.c); i++, s += 8) { \ 1780 n |= ((type)(u.c[i] & 0xFF)) << s; \ 1781 } \ 1782 return n; \ 1783 } 1784 1785 /* 1786 * Big-endian byte order functions. 1787 */ 1788 1789 #define HTOBE(name,type) \ 1790 type \ 1791 name (register type n) \ 1792 { \ 1793 union { \ 1794 type value; \ 1795 char c[sizeof(type)]; \ 1796 } u; \ 1797 register I32 i; \ 1798 register I32 s = 8*(sizeof(u.c)-1); \ 1799 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ 1800 u.c[i] = (n >> s) & 0xFF; \ 1801 } \ 1802 return u.value; \ 1803 } 1804 1805 #define BETOH(name,type) \ 1806 type \ 1807 name (register type n) \ 1808 { \ 1809 union { \ 1810 type value; \ 1811 char c[sizeof(type)]; \ 1812 } u; \ 1813 register I32 i; \ 1814 register I32 s = 8*(sizeof(u.c)-1); \ 1815 u.value = n; \ 1816 n = 0; \ 1817 for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ 1818 n |= ((type)(u.c[i] & 0xFF)) << s; \ 1819 } \ 1820 return n; \ 1821 } 1822 1823 /* 1824 * If we just can't do it... 1825 */ 1826 1827 #define NOT_AVAIL(name,type) \ 1828 type \ 1829 name (register type n) \ 1830 { \ 1831 Perl_croak_nocontext(#name "() not available"); \ 1832 return n; /* not reached */ \ 1833 } 1834 1835 1836 #if defined(HAS_HTOVS) && !defined(htovs) 1837 HTOLE(htovs,short) 1838 #endif 1839 #if defined(HAS_HTOVL) && !defined(htovl) 1840 HTOLE(htovl,long) 1841 #endif 1842 #if defined(HAS_VTOHS) && !defined(vtohs) 1843 LETOH(vtohs,short) 1844 #endif 1845 #if defined(HAS_VTOHL) && !defined(vtohl) 1846 LETOH(vtohl,long) 1847 #endif 1848 1849 #ifdef PERL_NEED_MY_HTOLE16 1850 # if U16SIZE == 2 1851 HTOLE(Perl_my_htole16,U16) 1852 # else 1853 NOT_AVAIL(Perl_my_htole16,U16) 1854 # endif 1855 #endif 1856 #ifdef PERL_NEED_MY_LETOH16 1857 # if U16SIZE == 2 1858 LETOH(Perl_my_letoh16,U16) 1859 # else 1860 NOT_AVAIL(Perl_my_letoh16,U16) 1861 # endif 1862 #endif 1863 #ifdef PERL_NEED_MY_HTOBE16 1864 # if U16SIZE == 2 1865 HTOBE(Perl_my_htobe16,U16) 1866 # else 1867 NOT_AVAIL(Perl_my_htobe16,U16) 1868 # endif 1869 #endif 1870 #ifdef PERL_NEED_MY_BETOH16 1871 # if U16SIZE == 2 1872 BETOH(Perl_my_betoh16,U16) 1873 # else 1874 NOT_AVAIL(Perl_my_betoh16,U16) 1875 # endif 1876 #endif 1877 1878 #ifdef PERL_NEED_MY_HTOLE32 1879 # if U32SIZE == 4 1880 HTOLE(Perl_my_htole32,U32) 1881 # else 1882 NOT_AVAIL(Perl_my_htole32,U32) 1883 # endif 1884 #endif 1885 #ifdef PERL_NEED_MY_LETOH32 1886 # if U32SIZE == 4 1887 LETOH(Perl_my_letoh32,U32) 1888 # else 1889 NOT_AVAIL(Perl_my_letoh32,U32) 1890 # endif 1891 #endif 1892 #ifdef PERL_NEED_MY_HTOBE32 1893 # if U32SIZE == 4 1894 HTOBE(Perl_my_htobe32,U32) 1895 # else 1896 NOT_AVAIL(Perl_my_htobe32,U32) 1897 # endif 1898 #endif 1899 #ifdef PERL_NEED_MY_BETOH32 1900 # if U32SIZE == 4 1901 BETOH(Perl_my_betoh32,U32) 1902 # else 1903 NOT_AVAIL(Perl_my_betoh32,U32) 1904 # endif 1905 #endif 1906 1907 #ifdef PERL_NEED_MY_HTOLE64 1908 # if U64SIZE == 8 1909 HTOLE(Perl_my_htole64,U64) 1910 # else 1911 NOT_AVAIL(Perl_my_htole64,U64) 1912 # endif 1913 #endif 1914 #ifdef PERL_NEED_MY_LETOH64 1915 # if U64SIZE == 8 1916 LETOH(Perl_my_letoh64,U64) 1917 # else 1918 NOT_AVAIL(Perl_my_letoh64,U64) 1919 # endif 1920 #endif 1921 #ifdef PERL_NEED_MY_HTOBE64 1922 # if U64SIZE == 8 1923 HTOBE(Perl_my_htobe64,U64) 1924 # else 1925 NOT_AVAIL(Perl_my_htobe64,U64) 1926 # endif 1927 #endif 1928 #ifdef PERL_NEED_MY_BETOH64 1929 # if U64SIZE == 8 1930 BETOH(Perl_my_betoh64,U64) 1931 # else 1932 NOT_AVAIL(Perl_my_betoh64,U64) 1933 # endif 1934 #endif 1935 1936 #ifdef PERL_NEED_MY_HTOLES 1937 HTOLE(Perl_my_htoles,short) 1938 #endif 1939 #ifdef PERL_NEED_MY_LETOHS 1940 LETOH(Perl_my_letohs,short) 1941 #endif 1942 #ifdef PERL_NEED_MY_HTOBES 1943 HTOBE(Perl_my_htobes,short) 1944 #endif 1945 #ifdef PERL_NEED_MY_BETOHS 1946 BETOH(Perl_my_betohs,short) 1947 #endif 1948 1949 #ifdef PERL_NEED_MY_HTOLEI 1950 HTOLE(Perl_my_htolei,int) 1951 #endif 1952 #ifdef PERL_NEED_MY_LETOHI 1953 LETOH(Perl_my_letohi,int) 1954 #endif 1955 #ifdef PERL_NEED_MY_HTOBEI 1956 HTOBE(Perl_my_htobei,int) 1957 #endif 1958 #ifdef PERL_NEED_MY_BETOHI 1959 BETOH(Perl_my_betohi,int) 1960 #endif 1961 1962 #ifdef PERL_NEED_MY_HTOLEL 1963 HTOLE(Perl_my_htolel,long) 1964 #endif 1965 #ifdef PERL_NEED_MY_LETOHL 1966 LETOH(Perl_my_letohl,long) 1967 #endif 1968 #ifdef PERL_NEED_MY_HTOBEL 1969 HTOBE(Perl_my_htobel,long) 1970 #endif 1971 #ifdef PERL_NEED_MY_BETOHL 1972 BETOH(Perl_my_betohl,long) 1973 #endif 1974 1975 void 1976 Perl_my_swabn(void *ptr, int n) 1977 5153 { 1978 5153 register char *s = (char *)ptr; 1979 5153 register char *e = s + (n-1); 1980 5153 register char tc; 1981 1982 23097 for (n /= 2; n > 0; s++, e--, n--) { 1983 17944 tc = *s; 1984 17944 *s = *e; 1985 17944 *e = tc; 1986 } 1987 } 1988 1989 PerlIO * 1990 Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) 1991 ###### { 1992 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) 1993 ###### int p[2]; 1994 ###### register I32 This, that; 1995 ###### register Pid_t pid; 1996 ###### SV *sv; 1997 ###### I32 did_pipes = 0; 1998 ###### int pp[2]; 1999 2000 ###### PERL_FLUSHALL_FOR_CHILD; 2001 ###### This = (*mode == 'w'); 2002 ###### that = !This; 2003 ###### if (PL_tainting) { 2004 ###### taint_env(); 2005 ###### taint_proper("Insecure %s%s", "EXEC"); 2006 } 2007 ###### if (PerlProc_pipe(p) < 0) 2008 ###### return Nullfp; 2009 /* Try for another pipe pair for error return */ 2010 ###### if (PerlProc_pipe(pp) >= 0) 2011 ###### did_pipes = 1; 2012 ###### while ((pid = PerlProc_fork()) < 0) { 2013 ###### if (errno != EAGAIN) { 2014 ###### PerlLIO_close(p[This]); 2015 ###### PerlLIO_close(p[that]); 2016 ###### if (did_pipes) { 2017 ###### PerlLIO_close(pp[0]); 2018 ###### PerlLIO_close(pp[1]); 2019 } 2020 ###### return Nullfp; 2021 } 2022 ###### sleep(5); 2023 } 2024 ###### if (pid == 0) { 2025 /* Child */ 2026 #undef THIS 2027 #undef THAT 2028 #define THIS that 2029 #define THAT This 2030 /* Close parent's end of error status pipe (if any) */ 2031 ###### if (did_pipes) { 2032 ###### PerlLIO_close(pp[0]); 2033 #if defined(HAS_FCNTL) && defined(F_SETFD) 2034 /* Close error pipe automatically if exec works */ 2035 ###### fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2036 #endif 2037 } 2038 /* Now dup our end of _the_ pipe to right position */ 2039 ###### if (p[THIS] != (*mode == 'r')) { 2040 ###### PerlLIO_dup2(p[THIS], *mode == 'r'); 2041 ###### PerlLIO_close(p[THIS]); 2042 ###### if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2043 ###### PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2044 } 2045 else 2046 ###### PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ 2047 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2048 /* No automatic close - do it by hand */ 2049 # ifndef NOFILE 2050 # define NOFILE 20 2051 # endif 2052 { 2053 int fd; 2054 2055 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { 2056 if (fd != pp[1]) 2057 PerlLIO_close(fd); 2058 } 2059 } 2060 #endif 2061 ###### do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); 2062 ###### PerlProc__exit(1); 2063 #undef THIS 2064 #undef THAT 2065 } 2066 /* Parent */ 2067 ###### do_execfree(); /* free any memory malloced by child on fork */ 2068 ###### if (did_pipes) 2069 ###### PerlLIO_close(pp[1]); 2070 /* Keep the lower of the two fd numbers */ 2071 ###### if (p[that] < p[This]) { 2072 ###### PerlLIO_dup2(p[This], p[that]); 2073 ###### PerlLIO_close(p[This]); 2074 ###### p[This] = p[that]; 2075 } 2076 else 2077 ###### PerlLIO_close(p[that]); /* close child's end of pipe */ 2078 2079 LOCK_FDPID_MUTEX; 2080 ###### sv = *av_fetch(PL_fdpid,p[This],TRUE); 2081 UNLOCK_FDPID_MUTEX; 2082 ###### SvUPGRADE(sv,SVt_IV); 2083 ###### SvIV_set(sv, pid); 2084 ###### PL_forkprocess = pid; 2085 /* If we managed to get status pipe check for exec fail */ 2086 ###### if (did_pipes && pid > 0) { 2087 ###### int errkid; 2088 ###### int n = 0, n1; 2089 2090 ###### while (n < sizeof(int)) { 2091 ###### n1 = PerlLIO_read(pp[0], 2092 (void*)(((char*)&errkid)+n), 2093 (sizeof(int)) - n); 2094 ###### if (n1 <= 0) 2095 ###### break; 2096 ###### n += n1; 2097 } 2098 ###### PerlLIO_close(pp[0]); 2099 ###### did_pipes = 0; 2100 ###### if (n) { /* Error */ 2101 ###### int pid2, status; 2102 ###### PerlLIO_close(p[This]); 2103 ###### if (n != sizeof(int)) 2104 ###### Perl_croak(aTHX_ "panic: kid popen errno read"); 2105 ###### do { 2106 ###### pid2 = wait4pid(pid, &status, 0); 2107 ###### } while (pid2 == -1 && errno == EINTR); 2108 ###### errno = errkid; /* Propagate errno from kid */ 2109 ###### return Nullfp; 2110 } 2111 } 2112 ###### if (did_pipes) 2113 ###### PerlLIO_close(pp[0]); 2114 ###### return PerlIO_fdopen(p[This], mode); 2115 #else 2116 Perl_croak(aTHX_ "List form of piped open not implemented"); 2117 return (PerlIO *) NULL; 2118 #endif 2119 } 2120 2121 /* VMS' my_popen() is in VMS.c, same with OS/2. */ 2122 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 2123 PerlIO * 2124 Perl_my_popen(pTHX_ char *cmd, char *mode) 2125 4333 { 2126 4333 int p[2]; 2127 4333 register I32 This, that; 2128 4333 register Pid_t pid; 2129 4333 SV *sv; 2130 4333 I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); 2131 4333 I32 did_pipes = 0; 2132 4333 int pp[2]; 2133 2134 4333 PERL_FLUSHALL_FOR_CHILD; 2135 #ifdef OS2 2136 if (doexec) { 2137 return my_syspopen(aTHX_ cmd,mode); 2138 } 2139 #endif 2140 4333 This = (*mode == 'w'); 2141 4333 that = !This; 2142 4333 if (doexec && PL_tainting) { 2143 18 taint_env(); 2144 10 taint_proper("Insecure %s%s", "EXEC"); 2145 } 2146 4325 if (PerlProc_pipe(p) < 0) 2147 ###### return Nullfp; 2148 4325 if (doexec && PerlProc_pipe(pp) >= 0) 2149 4302 did_pipes = 1; 2150 4325 while ((pid = PerlProc_fork()) < 0) { 2151 ###### if (errno != EAGAIN) { 2152 ###### PerlLIO_close(p[This]); 2153 ###### PerlLIO_close(p[that]); 2154 ###### if (did_pipes) { 2155 ###### PerlLIO_close(pp[0]); 2156 ###### PerlLIO_close(pp[1]); 2157 } 2158 ###### if (!doexec) 2159 ###### Perl_croak(aTHX_ "Can't fork"); 2160 ###### return Nullfp; 2161 } 2162 ###### sleep(5); 2163 } 2164 8645 if (pid == 0) { 2165 4320 GV* tmpgv; 2166 2167 #undef THIS 2168 #undef THAT 2169 #define THIS that 2170 #define THAT This 2171 4320 if (did_pipes) { 2172 4297 PerlLIO_close(pp[0]); 2173 #if defined(HAS_FCNTL) && defined(F_SETFD) 2174 4297 fcntl(pp[1], F_SETFD, FD_CLOEXEC); 2175 #endif 2176 } 2177 4320 if (p[THIS] != (*mode == 'r')) { 2178 4320 PerlLIO_dup2(p[THIS], *mode == 'r'); 2179 4320 PerlLIO_close(p[THIS]); 2180 4320 if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ 2181 4320 PerlLIO_close(p[THAT]); 2182 } 2183 else 2184 ###### PerlLIO_close(p[THAT]); 2185 #ifndef OS2 2186 4320 if (doexec) { 2187 #if !defined(HAS_FCNTL) || !defined(F_SETFD) 2188 #ifndef NOFILE 2189 #define NOFILE 20 2190 #endif 2191 { 2192 int fd; 2193 2194 for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) 2195 if (fd != pp[1]) 2196 PerlLIO_close(fd); 2197 } 2198 #endif 2199 /* may or may not use the shell */ 2200 4297 do_exec3(cmd, pp[1], did_pipes); 2201 ###### PerlProc__exit(1); 2202 } 2203 #endif /* defined OS2 */ 2204 23 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { 2205 23 SvREADONLY_off(GvSV(tmpgv)); 2206 23 sv_setiv(GvSV(tmpgv), PerlProc_getpid()); 2207 23 SvREADONLY_on(GvSV(tmpgv)); 2208 } 2209 #ifdef THREADS_HAVE_PIDS 2210 PL_ppid = (IV)getppid(); 2211 #endif 2212 23 PL_forkprocess = 0; 2213 23 hv_clear(PL_pidstatus); /* we have no children */ 2214 23 return Nullfp; 2215 #undef THIS 2216 #undef THAT 2217 } 2218 4325 do_execfree(); /* free any memory malloced by child on vfork */ 2219 4325 if (did_pipes) 2220 4302 PerlLIO_close(pp[1]); 2221 4325 if (p[that] < p[This]) { 2222 33 PerlLIO_dup2(p[This], p[that]); 2223 33 PerlLIO_close(p[This]); 2224 33 p[This] = p[that]; 2225 } 2226 else 2227 4292 PerlLIO_close(p[that]); 2228 2229 LOCK_FDPID_MUTEX; 2230 4325 sv = *av_fetch(PL_fdpid,p[This],TRUE); 2231 UNLOCK_FDPID_MUTEX; 2232 4325 SvUPGRADE(sv,SVt_IV); 2233 4325 SvIV_set(sv, pid); 2234 4325 PL_forkprocess = pid; 2235 4325 if (did_pipes && pid > 0) { 2236 4302 int errkid; 2237 4302 int n = 0, n1; 2238 2239 4304 while (n < sizeof(int)) { 2240 4302 n1 = PerlLIO_read(pp[0], 2241 (void*)(((char*)&errkid)+n), 2242 (sizeof(int)) - n); 2243 4302 if (n1 <= 0) 2244 4300 break; 2245 2 n += n1; 2246 } 2247 4302 PerlLIO_close(pp[0]); 2248 4302 did_pipes = 0; 2249 4302 if (n) { /* Error */ 2250 2 int pid2, status; 2251 2 PerlLIO_close(p[This]); 2252 2 if (n != sizeof(int)) 2253 ###### Perl_croak(aTHX_ "panic: kid popen errno read"); 2254 2 do { 2255 2 pid2 = wait4pid(pid, &status, 0); 2256 2 } while (pid2 == -1 && errno == EINTR); 2257 2 errno = errkid; /* Propagate errno from kid */ 2258 2 return Nullfp; 2259 } 2260 } 2261 4323 if (did_pipes) 2262 ###### PerlLIO_close(pp[0]); 2263 4323 return PerlIO_fdopen(p[This], mode); 2264 } 2265 #else 2266 #if defined(atarist) || defined(EPOC) 2267 FILE *popen(); 2268 PerlIO * 2269 Perl_my_popen(pTHX_ char *cmd, char *mode) 2270 { 2271 PERL_FLUSHALL_FOR_CHILD; 2272 /* Call system's popen() to get a FILE *, then import it. 2273 used 0 for 2nd parameter to PerlIO_importFILE; 2274 apparently not used 2275 */ 2276 return PerlIO_importFILE(popen(cmd, mode), 0); 2277 } 2278 #else 2279 #if defined(DJGPP) 2280 FILE *djgpp_popen(); 2281 PerlIO * 2282 Perl_my_popen(pTHX_ char *cmd, char *mode) 2283 { 2284 PERL_FLUSHALL_FOR_CHILD; 2285 /* Call system's popen() to get a FILE *, then import it. 2286 used 0 for 2nd parameter to PerlIO_importFILE; 2287 apparently not used 2288 */ 2289 return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); 2290 } 2291 #endif 2292 #endif 2293 2294 #endif /* !DOSISH */ 2295 2296 /* this is called in parent before the fork() */ 2297 void 2298 Perl_atfork_lock(void) 2299 ###### { 2300 dVAR; 2301 #if defined(USE_ITHREADS) 2302 /* locks must be held in locking order (if any) */ 2303 # ifdef MYMALLOC 2304 MUTEX_LOCK(&PL_malloc_mutex); 2305 # endif 2306 OP_REFCNT_LOCK; 2307 #endif 2308 } 2309 2310 /* this is called in both parent and child after the fork() */ 2311 void 2312 Perl_atfork_unlock(void) 2313 ###### { 2314 dVAR; 2315 #if defined(USE_ITHREADS) 2316 /* locks must be released in same order as in atfork_lock() */ 2317 # ifdef MYMALLOC 2318 MUTEX_UNLOCK(&PL_malloc_mutex); 2319 # endif 2320 OP_REFCNT_UNLOCK; 2321 #endif 2322 } 2323 2324 Pid_t 2325 Perl_my_fork(void) 2326 4506 { 2327 #if defined(HAS_FORK) 2328 4506 Pid_t pid; 2329 #if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK) 2330 atfork_lock(); 2331 pid = fork(); 2332 atfork_unlock(); 2333 #else 2334 /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() 2335 * handlers elsewhere in the code */ 2336 4506 pid = fork(); 2337 #endif 2338 9005 return pid; 2339 #else 2340 /* this "canna happen" since nothing should be calling here if !HAS_FORK */ 2341 Perl_croak_nocontext("fork() not available"); 2342 return 0; 2343 #endif /* HAS_FORK */ 2344 } 2345 2346 #ifdef DUMP_FDS 2347 void 2348 Perl_dump_fds(pTHX_ char *s) 2349 { 2350 int fd; 2351 Stat_t tmpstatbuf; 2352 2353 PerlIO_printf(Perl_debug_log,"%s", s); 2354 for (fd = 0; fd < 32; fd++) { 2355 if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) 2356 PerlIO_printf(Perl_debug_log," %d",fd); 2357 } 2358 PerlIO_printf(Perl_debug_log,"\n"); 2359 return; 2360 } 2361 #endif /* DUMP_FDS */ 2362 2363 #ifndef HAS_DUP2 2364 int 2365 dup2(int oldfd, int newfd) 2366 { 2367 #if defined(HAS_FCNTL) && defined(F_DUPFD) 2368 if (oldfd == newfd) 2369 return oldfd; 2370 PerlLIO_close(newfd); 2371 return fcntl(oldfd, F_DUPFD, newfd); 2372 #else 2373 #define DUP2_MAX_FDS 256 2374 int fdtmp[DUP2_MAX_FDS]; 2375 I32 fdx = 0; 2376 int fd; 2377 2378 if (oldfd == newfd) 2379 return oldfd; 2380 PerlLIO_close(newfd); 2381 /* good enough for low fd's... */ 2382 while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { 2383 if (fdx >= DUP2_MAX_FDS) { 2384 PerlLIO_close(fd); 2385 fd = -1; 2386 break; 2387 } 2388 fdtmp[fdx++] = fd; 2389 } 2390 while (fdx > 0) 2391 PerlLIO_close(fdtmp[--fdx]); 2392 return fd; 2393 #endif 2394 } 2395 #endif 2396 2397 #ifndef PERL_MICRO 2398 #ifdef HAS_SIGACTION 2399 2400 #ifdef MACOS_TRADITIONAL 2401 /* We don't want restart behavior on MacOS */ 2402 #undef SA_RESTART 2403 #endif 2404 2405 Sighandler_t 2406 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2407 1483 { 2408 dVAR; 2409 1483 struct sigaction act, oact; 2410 2411 #ifdef USE_ITHREADS 2412 /* only "parent" interpreter can diddle signals */ 2413 if (PL_curinterp != aTHX) 2414 return SIG_ERR; 2415 #endif 2416 2417 1483 act.sa_handler = handler; 2418 1483 sigemptyset(&act.sa_mask); 2419 1483 act.sa_flags = 0; 2420 #ifdef SA_RESTART 2421 1483 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2422 ###### act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2423 #endif 2424 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2425 1483 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) 2426 ###### act.sa_flags |= SA_NOCLDWAIT; 2427 #endif 2428 1483 if (sigaction(signo, &act, &oact) == -1) 2429 1 return SIG_ERR; 2430 else 2431 1482 return oact.sa_handler; 2432 } 2433 2434 Sighandler_t 2435 Perl_rsignal_state(pTHX_ int signo) 2436 4511 { 2437 4511 struct sigaction oact; 2438 2439 4511 if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) 2440 ###### return SIG_ERR; 2441 else 2442 4511 return oact.sa_handler; 2443 } 2444 2445 int 2446 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2447 17621 { 2448 dVAR; 2449 17621 struct sigaction act; 2450 2451 #ifdef USE_ITHREADS 2452 /* only "parent" interpreter can diddle signals */ 2453 if (PL_curinterp != aTHX) 2454 return -1; 2455 #endif 2456 2457 17621 act.sa_handler = handler; 2458 17621 sigemptyset(&act.sa_mask); 2459 17621 act.sa_flags = 0; 2460 #ifdef SA_RESTART 2461 17621 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 2462 ###### act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ 2463 #endif 2464 #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ 2465 17621 if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) 2466 ###### act.sa_flags |= SA_NOCLDWAIT; 2467 #endif 2468 17621 return sigaction(signo, &act, save); 2469 } 2470 2471 int 2472 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2473 13166 { 2474 dVAR; 2475 #ifdef USE_ITHREADS 2476 /* only "parent" interpreter can diddle signals */ 2477 if (PL_curinterp != aTHX) 2478 return -1; 2479 #endif 2480 2481 13166 return sigaction(signo, save, (struct sigaction *)NULL); 2482 } 2483 2484 #else /* !HAS_SIGACTION */ 2485 2486 Sighandler_t 2487 Perl_rsignal(pTHX_ int signo, Sighandler_t handler) 2488 { 2489 #if defined(USE_ITHREADS) && !defined(WIN32) 2490 /* only "parent" interpreter can diddle signals */ 2491 if (PL_curinterp != aTHX) 2492 return SIG_ERR; 2493 #endif 2494 2495 return PerlProc_signal(signo, handler); 2496 } 2497 2498 static 2499 Signal_t 2500 sig_trap(int signo) 2501 { 2502 dVAR; 2503 PL_sig_trapped++; 2504 } 2505 2506 Sighandler_t 2507 Perl_rsignal_state(pTHX_ int signo) 2508 { 2509 dVAR; 2510 Sighandler_t oldsig; 2511 2512 #if defined(USE_ITHREADS) && !defined(WIN32) 2513 /* only "parent" interpreter can diddle signals */ 2514 if (PL_curinterp != aTHX) 2515 return SIG_ERR; 2516 #endif 2517 2518 PL_sig_trapped = 0; 2519 oldsig = PerlProc_signal(signo, sig_trap); 2520 PerlProc_signal(signo, oldsig); 2521 if (PL_sig_trapped) 2522 PerlProc_kill(PerlProc_getpid(), signo); 2523 return oldsig; 2524 } 2525 2526 int 2527 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) 2528 { 2529 #if defined(USE_ITHREADS) && !defined(WIN32) 2530 /* only "parent" interpreter can diddle signals */ 2531 if (PL_curinterp != aTHX) 2532 return -1; 2533 #endif 2534 *save = PerlProc_signal(signo, handler); 2535 return (*save == SIG_ERR) ? -1 : 0; 2536 } 2537 2538 int 2539 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) 2540 { 2541 #if defined(USE_ITHREADS) && !defined(WIN32) 2542 /* only "parent" interpreter can diddle signals */ 2543 if (PL_curinterp != aTHX) 2544 return -1; 2545 #endif 2546 return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; 2547 } 2548 2549 #endif /* !HAS_SIGACTION */ 2550 #endif /* !PERL_MICRO */ 2551 2552 /* VMS' my_pclose() is in VMS.c; same with OS/2 */ 2553 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) 2554 I32 2555 Perl_my_pclose(pTHX_ PerlIO *ptr) 2556 4322 { 2557 4322 Sigsave_t hstat, istat, qstat; 2558 4322 int status; 2559 4322 SV **svp; 2560 4322 Pid_t pid; 2561 4322 Pid_t pid2; 2562 4322 bool close_failed; 2563 4322 int saved_errno = 0; 2564 #ifdef WIN32 2565 int saved_win32_errno; 2566 #endif 2567 2568 LOCK_FDPID_MUTEX; 2569 4322 svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); 2570 UNLOCK_FDPID_MUTEX; 2571 4322 pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; 2572 4322 SvREFCNT_dec(*svp); 2573 4322 *svp = &PL_sv_undef; 2574 #ifdef OS2 2575 if (pid == -1) { /* Opened by popen. */ 2576 return my_syspclose(ptr); 2577 } 2578 #endif 2579 4322 if ((close_failed = (PerlIO_close(ptr) == EOF))) { 2580 1 saved_errno = errno; 2581 #ifdef WIN32 2582 saved_win32_errno = GetLastError(); 2583 #endif 2584 } 2585 #ifdef UTS 2586 if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ 2587 #endif 2588 #ifndef PERL_MICRO 2589 4322 rsignal_save(SIGHUP, SIG_IGN, &hstat); 2590 4322 rsignal_save(SIGINT, SIG_IGN, &istat); 2591 4322 rsignal_save(SIGQUIT, SIG_IGN, &qstat); 2592 #endif 2593 4323 do { 2594 4323 pid2 = wait4pid(pid, &status, 0); 2595 4323 } while (pid2 == -1 && errno == EINTR); 2596 #ifndef PERL_MICRO 2597 4322 rsignal_restore(SIGHUP, &hstat); 2598 4322 rsignal_restore(SIGINT, &istat); 2599 4322 rsignal_restore(SIGQUIT, &qstat); 2600 #endif 2601 4322 if (close_failed) { 2602 1 SETERRNO(saved_errno, 0); 2603 1 return -1; 2604 } 2605 4321 return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); 2606 } 2607 #endif /* !DOSISH */ 2608 2609 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) 2610 I32 2611 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) 2612 4477 { 2613 4477 I32 result = 0; 2614 4477 if (!pid) 2615 ###### return -1; 2616 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2617 { 2618 char spid[TYPE_CHARS(IV)]; 2619 2620 if (pid > 0) { 2621 SV** svp; 2622 sprintf(spid, "%"IVdf, (IV)pid); 2623 svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); 2624 if (svp && *svp != &PL_sv_undef) { 2625 *statusp = SvIVX(*svp); 2626 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); 2627 return pid; 2628 } 2629 } 2630 else { 2631 HE *entry; 2632 2633 hv_iterinit(PL_pidstatus); 2634 if ((entry = hv_iternext(PL_pidstatus))) { 2635 SV *sv = hv_iterval(PL_pidstatus,entry); 2636 2637 pid = atoi(hv_iterkey(entry,(I32*)statusp)); 2638 *statusp = SvIVX(sv); 2639 sprintf(spid, "%"IVdf, (IV)pid); 2640 (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); 2641 return pid; 2642 } 2643 } 2644 } 2645 #endif 2646 #ifdef HAS_WAITPID 2647 # ifdef HAS_WAITPID_RUNTIME 2648 if (!HAS_WAITPID_RUNTIME) 2649 goto hard_way; 2650 # endif 2651 4477 result = PerlProc_waitpid(pid,statusp,flags); 2652 4477 goto finish; 2653 #endif 2654 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) 2655 result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); 2656 goto finish; 2657 #endif 2658 #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) 2659 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) 2660 hard_way: 2661 #endif 2662 { 2663 if (flags) 2664 Perl_croak(aTHX_ "Can't do waitpid with flags"); 2665 else { 2666 while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) 2667 pidgone(result,*statusp); 2668 if (result < 0) 2669 *statusp = -1; 2670 } 2671 } 2672 #endif 2673 #if defined(HAS_WAITPID) || defined(HAS_WAIT4) 2674 finish: 2675 #endif 2676 4477 if (result < 0 && errno == EINTR) { 2677 2 PERL_ASYNC_CHECK(); 2678 } 2679 4476 return result; 2680 } 2681 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ 2682 2683 void 2684 Perl_pidgone(pTHX_ Pid_t pid, int status) 2685 ###### { 2686 ###### register SV *sv; 2687 ###### char spid[TYPE_CHARS(IV)]; 2688 2689 ###### sprintf(spid, "%"IVdf, (IV)pid); 2690 ###### sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); 2691 ###### SvUPGRADE(sv,SVt_IV); 2692 ###### SvIV_set(sv, status); 2693 return; 2694 } 2695 2696 #if defined(atarist) || defined(OS2) || defined(EPOC) 2697 int pclose(); 2698 #ifdef HAS_FORK 2699 int /* Cannot prototype with I32 2700 in os2ish.h. */ 2701 my_syspclose(PerlIO *ptr) 2702 #else 2703 I32 2704 Perl_my_pclose(pTHX_ PerlIO *ptr) 2705 #endif 2706 { 2707 /* Needs work for PerlIO ! */ 2708 FILE *f = PerlIO_findFILE(ptr); 2709 I32 result = pclose(f); 2710 PerlIO_releaseFILE(ptr,f); 2711 return result; 2712 } 2713 #endif 2714 2715 #if defined(DJGPP) 2716 int djgpp_pclose(); 2717 I32 2718 Perl_my_pclose(pTHX_ PerlIO *ptr) 2719 { 2720 /* Needs work for PerlIO ! */ 2721 FILE *f = PerlIO_findFILE(ptr); 2722 I32 result = djgpp_pclose(f); 2723 result = (result << 8) & 0xff00; 2724 PerlIO_releaseFILE(ptr,f); 2725 return result; 2726 } 2727 #endif 2728 2729 void 2730 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) 2731 107308 { 2732 107308 register I32 todo; 2733 107308 register const char *frombase = from; 2734 2735 107308 if (len == 1) { 2736 65827 register const char c = *from; 2737 25672967 while (count-- > 0) 2738 25607140 *to++ = c; 2739 41481 return; 2740 } 2741 1876480 while (count-- > 0) { 2742 27579296 for (todo = len; todo > 0; todo--) { 2743 25744297 *to++ = *from++; 2744 } 2745 1834999 from = frombase; 2746 } 2747 } 2748 2749 #ifndef HAS_RENAME 2750 I32 2751 Perl_same_dirent(pTHX_ const char *a, const char *b) 2752 { 2753 char *fa = strrchr(a,'/'); 2754 char *fb = strrchr(b,'/'); 2755 Stat_t tmpstatbuf1; 2756 Stat_t tmpstatbuf2; 2757 SV *tmpsv = sv_newmortal(); 2758 2759 if (fa) 2760 fa++; 2761 else 2762 fa = a; 2763 if (fb) 2764 fb++; 2765 else 2766 fb = b; 2767 if (strNE(a,b)) 2768 return FALSE; 2769 if (fa == a) 2770 sv_setpvn(tmpsv, ".", 1); 2771 else 2772 sv_setpvn(tmpsv, a, fa - a); 2773 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) 2774 return FALSE; 2775 if (fb == b) 2776 sv_setpvn(tmpsv, ".", 1); 2777 else 2778 sv_setpvn(tmpsv, b, fb - b); 2779 if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) 2780 return FALSE; 2781 return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && 2782 tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; 2783 } 2784 #endif /* !HAS_RENAME */ 2785 2786 char* 2787 Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags) 2788 2466 { 2789 2466 const char *xfound = Nullch; 2790 2466 char *xfailed = Nullch; 2791 2466 char tmpbuf[MAXPATHLEN]; 2792 2466 register char *s; 2793 2466 I32 len = 0; 2794 2466 int retval; 2795 #if defined(DOSISH) && !defined(OS2) && !defined(atarist) 2796 # define SEARCH_EXTS ".bat", ".cmd", NULL 2797 # define MAX_EXT_LEN 4 2798 #endif 2799 #ifdef OS2 2800 # define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL 2801 # define MAX_EXT_LEN 4 2802 #endif 2803 #ifdef VMS 2804 # define SEARCH_EXTS ".pl", ".com", NULL 2805 # define MAX_EXT_LEN 4 2806 #endif 2807 /* additional extensions to try in each dir if scriptname not found */ 2808 #ifdef SEARCH_EXTS 2809 const char *exts[] = { SEARCH_EXTS }; 2810 const char **ext = search_ext ? search_ext : exts; 2811 int extidx = 0, i = 0; 2812 const char *curext = Nullch; 2813 #else 2814 2466 PERL_UNUSED_ARG(search_ext); 2815 # define MAX_EXT_LEN 0 2816 #endif 2817 2818 /* 2819 * If dosearch is true and if scriptname does not contain path 2820 * delimiters, search the PATH for scriptname. 2821 * 2822 * If SEARCH_EXTS is also defined, will look for each 2823 * scriptname{SEARCH_EXTS} whenever scriptname is not found 2824 * while searching the PATH. 2825 * 2826 * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search 2827 * proceeds as follows: 2828 * If DOSISH or VMSISH: 2829 * + look for ./scriptname{,.foo,.bar} 2830 * + search the PATH for scriptname{,.foo,.bar} 2831 * 2832 * If !DOSISH: 2833 * + look *only* in the PATH for scriptname{,.foo,.bar} (note 2834 * this will not look in '.' if it's not in the PATH) 2835 */ 2836 2466 tmpbuf[0] = '\0'; 2837 2838 #ifdef VMS 2839 # ifdef ALWAYS_DEFTYPES 2840 len = strlen(scriptname); 2841 if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { 2842 int hasdir, idx = 0, deftypes = 1; 2843 bool seen_dot = 1; 2844 2845 hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof tmpbuf) 2864 continue; /* don't search dir with too-long name */ 2865 strcat(tmpbuf, scriptname); 2866 #else /* !VMS */ 2867 2868 #ifdef DOSISH 2869 if (strEQ(scriptname, "-")) 2870 dosearch = 0; 2871 if (dosearch) { /* Look in '.' first. */ 2872 const char *cur = scriptname; 2873 #ifdef SEARCH_EXTS 2874 if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ 2875 while (ext[i]) 2876 if (strEQ(ext[i++],curext)) { 2877 extidx = -1; /* already has an ext */ 2878 break; 2879 } 2880 do { 2881 #endif 2882 DEBUG_p(PerlIO_printf(Perl_debug_log, 2883 "Looking for %s\n",cur)); 2884 if (PerlLIO_stat(cur,&PL_statbuf) >= 0 2885 && !S_ISDIR(PL_statbuf.st_mode)) { 2886 dosearch = 0; 2887 scriptname = cur; 2888 #ifdef SEARCH_EXTS 2889 break; 2890 #endif 2891 } 2892 #ifdef SEARCH_EXTS 2893 if (cur == scriptname) { 2894 len = strlen(scriptname); 2895 if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) 2896 break; 2897 /* FIXME? Convert to memcpy */ 2898 cur = strcpy(tmpbuf, scriptname); 2899 } 2900 } while (extidx >= 0 && ext[extidx] /* try an extension? */ 2901 && strcpy(tmpbuf+len, ext[extidx++])); 2902 #endif 2903 } 2904 #endif 2905 2906 #ifdef MACOS_TRADITIONAL 2907 if (dosearch && !strchr(scriptname, ':') && 2908 (s = PerlEnv_getenv("Commands"))) 2909 #else 2910 2466 if (dosearch && !strchr(scriptname, '/') 2911 #ifdef DOSISH 2912 && !strchr(scriptname, '\\') 2913 #endif 2914 && (s = PerlEnv_getenv("PATH"))) 2915 #endif 2916 { 2917 ###### bool seen_dot = 0; 2918 2919 ###### PL_bufend = s + strlen(s); 2920 ###### while (s < PL_bufend) { 2921 #ifdef MACOS_TRADITIONAL 2922 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, 2923 ',', 2924 &len); 2925 #else 2926 #if defined(atarist) || defined(DOSISH) 2927 for (len = 0; *s 2928 # ifdef atarist 2929 && *s != ',' 2930 # endif 2931 && *s != ';'; len++, s++) { 2932 if (len < sizeof tmpbuf) 2933 tmpbuf[len] = *s; 2934 } 2935 if (len < sizeof tmpbuf) 2936 tmpbuf[len] = '\0'; 2937 #else /* ! (atarist || DOSISH) */ 2938 ###### s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, 2939 ':', 2940 &len); 2941 #endif /* ! (atarist || DOSISH) */ 2942 #endif /* MACOS_TRADITIONAL */ 2943 ###### if (s < PL_bufend) 2944 ###### s++; 2945 ###### if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) 2946 ###### continue; /* don't search dir with too-long name */ 2947 #ifdef MACOS_TRADITIONAL 2948 if (len && tmpbuf[len - 1] != ':') 2949 tmpbuf[len++] = ':'; 2950 #else 2951 ###### if (len 2952 # if defined(atarist) || defined(__MINT__) || defined(DOSISH) 2953 && tmpbuf[len - 1] != '/' 2954 && tmpbuf[len - 1] != '\\' 2955 # endif 2956 ) 2957 ###### tmpbuf[len++] = '/'; 2958 ###### if (len == 2 && tmpbuf[0] == '.') 2959 ###### seen_dot = 1; 2960 #endif 2961 /* FIXME? Convert to memcpy by storing previous strlen(scriptname) 2962 */ 2963 ###### (void)strcpy(tmpbuf + len, scriptname); 2964 #endif /* !VMS */ 2965 2966 #ifdef SEARCH_EXTS 2967 len = strlen(tmpbuf); 2968 if (extidx > 0) /* reset after previous loop */ 2969 extidx = 0; 2970 do { 2971 #endif 2972 ###### DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); 2973 ###### retval = PerlLIO_stat(tmpbuf,&PL_statbuf); 2974 ###### if (S_ISDIR(PL_statbuf.st_mode)) { 2975 ###### retval = -1; 2976 } 2977 #ifdef SEARCH_EXTS 2978 } while ( retval < 0 /* not there */ 2979 && extidx>=0 && ext[extidx] /* try an extension? */ 2980 && strcpy(tmpbuf+len, ext[extidx++]) 2981 ); 2982 #endif 2983 ###### if (retval < 0) 2984 ###### continue; 2985 ###### if (S_ISREG(PL_statbuf.st_mode) 2986 && cando(S_IRUSR,TRUE,&PL_statbuf) 2987 #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) 2988 && cando(S_IXUSR,TRUE,&PL_statbuf) 2989 #endif 2990 ) 2991 { 2992 ###### xfound = tmpbuf; /* bingo! */ 2993 ###### break; 2994 } 2995 ###### if (!xfailed) 2996 ###### xfailed = savepv(tmpbuf); 2997 } 2998 #ifndef DOSISH 2999 ###### if (!xfound && !seen_dot && !xfailed && 3000 (PerlLIO_stat(scriptname,&PL_statbuf) < 0 3001 || S_ISDIR(PL_statbuf.st_mode))) 3002 #endif 3003 ###### seen_dot = 1; /* Disable message. */ 3004 ###### if (!xfound) { 3005 ###### if (flags & 1) { /* do or die? */ 3006 ###### Perl_croak(aTHX_ "Can't %s %s%s%s", 3007 (xfailed ? "execute" : "find"), 3008 (xfailed ? xfailed : scriptname), 3009 (xfailed ? "" : " on PATH"), 3010 (xfailed || seen_dot) ? "" : ", '.' not in PATH"); 3011 } 3012 ###### scriptname = Nullch; 3013 } 3014 ###### Safefree(xfailed); 3015 ###### scriptname = xfound; 3016 } 3017 2466 return (scriptname ? savepv(scriptname) : Nullch); 3018 } 3019 3020 #ifndef PERL_GET_CONTEXT_DEFINED 3021 3022 void * 3023 Perl_get_context(void) 3024 ###### { 3025 dVAR; 3026 #if defined(USE_ITHREADS) 3027 # ifdef OLD_PTHREADS_API 3028 pthread_addr_t t; 3029 if (pthread_getspecific(PL_thr_key, &t)) 3030 Perl_croak_nocontext("panic: pthread_getspecific"); 3031 return (void*)t; 3032 # else 3033 # ifdef I_MACH_CTHREADS 3034 return (void*)cthread_data(cthread_self()); 3035 # else 3036 return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); 3037 # endif 3038 # endif 3039 #else 3040 ###### return (void*)NULL; 3041 #endif 3042 } 3043 3044 void 3045 Perl_set_context(void *t) 3046 ###### { 3047 dVAR; 3048 #if defined(USE_ITHREADS) 3049 # ifdef I_MACH_CTHREADS 3050 cthread_set_data(cthread_self(), t); 3051 # else 3052 if (pthread_setspecific(PL_thr_key, t)) 3053 Perl_croak_nocontext("panic: pthread_setspecific"); 3054 # endif 3055 #else 3056 ###### PERL_UNUSED_ARG(t); 3057 #endif 3058 } 3059 3060 #endif /* !PERL_GET_CONTEXT_DEFINED */ 3061 3062 #if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) 3063 struct perl_vars * 3064 Perl_GetVars(pTHX) 3065 { 3066 return &PL_Vars; 3067 } 3068 #endif 3069 3070 char ** 3071 Perl_get_op_names(pTHX) 3072 28 { 3073 28 return (char **)PL_op_name; 3074 } 3075 3076 char ** 3077 Perl_get_op_descs(pTHX) 3078 2 { 3079 2 return (char **)PL_op_desc; 3080 } 3081 3082 const char * 3083 Perl_get_no_modify(pTHX) 3084 ###### { 3085 ###### return PL_no_modify; 3086 } 3087 3088 U32 * 3089 Perl_get_opargs(pTHX) 3090 ###### { 3091 ###### return (U32 *)PL_opargs; 3092 } 3093 3094 PPADDR_t* 3095 Perl_get_ppaddr(pTHX) 3096 ###### { 3097 dVAR; 3098 ###### return (PPADDR_t*)PL_ppaddr; 3099 } 3100 3101 #ifndef HAS_GETENV_LEN 3102 char * 3103 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) 3104 ###### { 3105 ###### char * const env_trans = PerlEnv_getenv(env_elem); 3106 ###### if (env_trans) 3107 ###### *len = strlen(env_trans); 3108 ###### return env_trans; 3109 } 3110 #endif 3111 3112 3113 MGVTBL* 3114 Perl_get_vtbl(pTHX_ int vtbl_id) 3115 ###### { 3116 ###### const MGVTBL* result = Null(MGVTBL*); 3117 3118 ###### switch(vtbl_id) { 3119 case want_vtbl_sv: 3120 ###### result = &PL_vtbl_sv; 3121 ###### break; 3122 case want_vtbl_env: 3123 ###### result = &PL_vtbl_env; 3124 ###### break; 3125 case want_vtbl_envelem: 3126 ###### result = &PL_vtbl_envelem; 3127 ###### break; 3128 case want_vtbl_sig: 3129 ###### result = &PL_vtbl_sig; 3130 ###### break; 3131 case want_vtbl_sigelem: 3132 ###### result = &PL_vtbl_sigelem; 3133 ###### break; 3134 case want_vtbl_pack: 3135 ###### result = &PL_vtbl_pack; 3136 ###### break; 3137 case want_vtbl_packelem: 3138 ###### result = &PL_vtbl_packelem; 3139 ###### break; 3140 case want_vtbl_dbline: 3141 ###### result = &PL_vtbl_dbline; 3142 ###### break; 3143 case want_vtbl_isa: 3144 ###### result = &PL_vtbl_isa; 3145 ###### break; 3146 case want_vtbl_isaelem: 3147 ###### result = &PL_vtbl_isaelem; 3148 ###### break; 3149 case want_vtbl_arylen: 3150 ###### result = &PL_vtbl_arylen; 3151 ###### break; 3152 case want_vtbl_glob: 3153 ###### result = &PL_vtbl_glob; 3154 ###### break; 3155 case want_vtbl_mglob: 3156 ###### result = &PL_vtbl_mglob; 3157 ###### break; 3158 case want_vtbl_nkeys: 3159 ###### result = &PL_vtbl_nkeys; 3160 ###### break; 3161 case want_vtbl_taint: 3162 ###### result = &PL_vtbl_taint; 3163 ###### break; 3164 case want_vtbl_substr: 3165 ###### result = &PL_vtbl_substr; 3166 ###### break; 3167 case want_vtbl_vec: 3168 ###### result = &PL_vtbl_vec; 3169 ###### break; 3170 case want_vtbl_pos: 3171 ###### result = &PL_vtbl_pos; 3172 ###### break; 3173 case want_vtbl_bm: 3174 ###### result = &PL_vtbl_bm; 3175 ###### break; 3176 case want_vtbl_fm: 3177 ###### result = &PL_vtbl_fm; 3178 ###### break; 3179 case want_vtbl_uvar: 3180 ###### result = &PL_vtbl_uvar; 3181 ###### break; 3182 case want_vtbl_defelem: 3183 ###### result = &PL_vtbl_defelem; 3184 ###### break; 3185 case want_vtbl_regexp: 3186 ###### result = &PL_vtbl_regexp; 3187 ###### break; 3188 case want_vtbl_regdata: 3189 ###### result = &PL_vtbl_regdata; 3190 ###### break; 3191 case want_vtbl_regdatum: 3192 ###### result = &PL_vtbl_regdatum; 3193 ###### break; 3194 #ifdef USE_LOCALE_COLLATE 3195 case want_vtbl_collxfrm: 3196 ###### result = &PL_vtbl_collxfrm; 3197 ###### break; 3198 #endif 3199 case want_vtbl_amagic: 3200 ###### result = &PL_vtbl_amagic; 3201 ###### break; 3202 case want_vtbl_amagicelem: 3203 ###### result = &PL_vtbl_amagicelem; 3204 ###### break; 3205 case want_vtbl_backref: 3206 ###### result = &PL_vtbl_backref; 3207 ###### break; 3208 case want_vtbl_utf8: 3209 ###### result = &PL_vtbl_utf8; 3210 break; 3211 } 3212 ###### return (MGVTBL*)result; 3213 } 3214 3215 I32 3216 Perl_my_fflush_all(pTHX) 3217 4549 { 3218 #if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) 3219 4549 return PerlIO_flush(NULL); 3220 #else 3221 # if defined(HAS__FWALK) 3222 extern int fflush(FILE *); 3223 /* undocumented, unprototyped, but very useful BSDism */ 3224 extern void _fwalk(int (*)(FILE *)); 3225 _fwalk(&fflush); 3226 return 0; 3227 # else 3228 # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) 3229 long open_max = -1; 3230 # ifdef PERL_FFLUSH_ALL_FOPEN_MAX 3231 open_max = PERL_FFLUSH_ALL_FOPEN_MAX; 3232 # else 3233 # if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) 3234 open_max = sysconf(_SC_OPEN_MAX); 3235 # else 3236 # ifdef FOPEN_MAX 3237 open_max = FOPEN_MAX; 3238 # else 3239 # ifdef OPEN_MAX 3240 open_max = OPEN_MAX; 3241 # else 3242 # ifdef _NFILE 3243 open_max = _NFILE; 3244 # endif 3245 # endif 3246 # endif 3247 # endif 3248 # endif 3249 if (open_max > 0) { 3250 long i; 3251 for (i = 0; i < open_max; i++) 3252 if (STDIO_STREAM_ARRAY[i]._file >= 0 && 3253 STDIO_STREAM_ARRAY[i]._file < open_max && 3254 STDIO_STREAM_ARRAY[i]._flag) 3255 PerlIO_flush(&STDIO_STREAM_ARRAY[i]); 3256 return 0; 3257 } 3258 # endif 3259 SETERRNO(EBADF,RMS_IFI); 3260 return EOF; 3261 # endif 3262 #endif 3263 } 3264 3265 void 3266 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) 3267 86 { 3268 86 const char *func = 3269 op == OP_READLINE ? "readline" : /* "" not nice */ 3270 op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ 3271 86 PL_op_desc[op]; 3272 86 const char *pars = OP_IS_FILETEST(op) ? "" : "()"; 3273 86 const char *type = OP_IS_SOCKET(op) 3274 || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) 3275 86 ? "socket" : "filehandle"; 3276 86 const char *name = NULL; 3277 3278 86 if (gv && isGV(gv)) { 3279 81 name = GvENAME(gv); 3280 } 3281 3282 86 if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { 3283 12 if (ckWARN(WARN_IO)) { 3284 12 const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; 3285 12 if (name && *name) 3286 12 Perl_warner(aTHX_ packWARN(WARN_IO), 3287 "Filehandle %s opened only for %sput", 3288 name, direction); 3289 else 3290 ###### Perl_warner(aTHX_ packWARN(WARN_IO), 3291 "Filehandle opened only for %sput", direction); 3292 } 3293 } 3294 else { 3295 74 const char *vile; 3296 74 I32 warn_type; 3297 3298 74 if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { 3299 55 vile = "closed"; 3300 55 warn_type = WARN_CLOSED; 3301 } 3302 else { 3303 19 vile = "unopened"; 3304 19 warn_type = WARN_UNOPENED; 3305 } 3306 3307 74 if (ckWARN(warn_type)) { 3308 72 if (name && *name) { 3309 66 Perl_warner(aTHX_ packWARN(warn_type), 3310 "%s%s on %s %s %s", func, pars, vile, type, name); 3311 65 if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3312 16 Perl_warner( 3313 aTHX_ packWARN(warn_type), 3314 "\t(Are you trying to call %s%s on dirhandle %s?)\n", 3315 func, pars, name 3316 ); 3317 } 3318 else { 3319 6 Perl_warner(aTHX_ packWARN(warn_type), 3320 "%s%s on %s %s", func, pars, vile, type); 3321 6 if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) 3322 ###### Perl_warner( 3323 aTHX_ packWARN(warn_type), 3324 "\t(Are you trying to call %s%s on dirhandle?)\n", 3325 func, pars 3326 ); 3327 } 3328 } 3329 } 3330 } 3331 3332 #ifdef EBCDIC 3333 /* in ASCII order, not that it matters */ 3334 static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; 3335 3336 int 3337 Perl_ebcdic_control(pTHX_ int ch) 3338 { 3339 if (ch > 'a') { 3340 const char *ctlp; 3341 3342 if (islower(ch)) 3343 ch = toupper(ch); 3344 3345 if ((ctlp = strchr(controllablechars, ch)) == 0) { 3346 Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); 3347 } 3348 3349 if (ctlp == controllablechars) 3350 return('\177'); /* DEL */ 3351 else 3352 return((unsigned char)(ctlp - controllablechars - 1)); 3353 } else { /* Want uncontrol */ 3354 if (ch == '\177' || ch == -1) 3355 return('?'); 3356 else if (ch == '\157') 3357 return('\177'); 3358 else if (ch == '\174') 3359 return('\000'); 3360 else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ 3361 return('\036'); 3362 else if (ch == '\155') 3363 return('\037'); 3364 else if (0 < ch && ch < (sizeof(controllablechars) - 1)) 3365 return(controllablechars[ch+1]); 3366 else 3367 Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); 3368 } 3369 } 3370 #endif 3371 3372 /* To workaround core dumps from the uninitialised tm_zone we get the 3373 * system to give us a reasonable struct to copy. This fix means that 3374 * strftime uses the tm_zone and tm_gmtoff values returned by 3375 * localtime(time()). That should give the desired result most of the 3376 * time. But probably not always! 3377 * 3378 * This does not address tzname aspects of NETaa14816. 3379 * 3380 */ 3381 3382 #ifdef HAS_GNULIBC 3383 # ifndef STRUCT_TM_HASZONE 3384 # define STRUCT_TM_HASZONE 3385 # endif 3386 #endif 3387 3388 #ifdef STRUCT_TM_HASZONE /* Backward compat */ 3389 # ifndef HAS_TM_TM_ZONE 3390 # define HAS_TM_TM_ZONE 3391 # endif 3392 #endif 3393 3394 void 3395 Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ 3396 ###### { 3397 #ifdef HAS_TM_TM_ZONE 3398 ###### Time_t now; 3399 ###### const struct tm* my_tm; 3400 ###### (void)time(&now); 3401 ###### my_tm = localtime(&now); 3402 ###### if (my_tm) 3403 ###### Copy(my_tm, ptm, 1, struct tm); 3404 #else 3405 PERL_UNUSED_ARG(ptm); 3406 #endif 3407 } 3408 3409 /* 3410 * mini_mktime - normalise struct tm values without the localtime() 3411 * semantics (and overhead) of mktime(). 3412 */ 3413 void 3414 Perl_mini_mktime(pTHX_ struct tm *ptm) 3415 ###### { 3416 ###### int yearday; 3417 ###### int secs; 3418 ###### int month, mday, year, jday; 3419 ###### int odd_cent, odd_year; 3420 3421 #define DAYS_PER_YEAR 365 3422 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) 3423 #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) 3424 #define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) 3425 #define SECS_PER_HOUR (60*60) 3426 #define SECS_PER_DAY (24*SECS_PER_HOUR) 3427 /* parentheses deliberately absent on these two, otherwise they don't work */ 3428 #define MONTH_TO_DAYS 153/5 3429 #define DAYS_TO_MONTH 5/153 3430 /* offset to bias by March (month 4) 1st between month/mday & year finding */ 3431 #define YEAR_ADJUST (4*MONTH_TO_DAYS+1) 3432 /* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ 3433 #define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ 3434 3435 /* 3436 * Year/day algorithm notes: 3437 * 3438 * With a suitable offset for numeric value of the month, one can find 3439 * an offset into the year by considering months to have 30.6 (153/5) days, 3440 * using integer arithmetic (i.e., with truncation). To avoid too much 3441 * messing about with leap days, we consider January and February to be 3442 * the 13th and 14th month of the previous year. After that transformation, 3443 * we need the month index we use to be high by 1 from 'normal human' usage, 3444 * so the month index values we use run from 4 through 15. 3445 * 3446 * Given that, and the rules for the Gregorian calendar (leap years are those 3447 * divisible by 4 unless also divisible by 100, when they must be divisible 3448 * by 400 instead), we can simply calculate the number of days since some 3449 * arbitrary 'beginning of time' by futzing with the (adjusted) year number, 3450 * the days we derive from our month index, and adding in the day of the 3451 * month. The value used here is not adjusted for the actual origin which 3452 * it normally would use (1 January A.D. 1), since we're not exposing it. 3453 * We're only building the value so we can turn around and get the 3454 * normalised values for the year, month, day-of-month, and day-of-year. 3455 * 3456 * For going backward, we need to bias the value we're using so that we find 3457 * the right year value. (Basically, we don't want the contribution of 3458 * March 1st to the number to apply while deriving the year). Having done 3459 * that, we 'count up' the contribution to the year number by accounting for 3460 * full quadracenturies (400-year periods) with their extra leap days, plus 3461 * the contribution from full centuries (to avoid counting in the lost leap 3462 * days), plus the contribution from full quad-years (to count in the normal 3463 * leap days), plus the leftover contribution from any non-leap years. 3464 * At this point, if we were working with an actual leap day, we'll have 0 3465 * days left over. This is also true for March 1st, however. So, we have 3466 * to special-case that result, and (earlier) keep track of the 'odd' 3467 * century and year contributions. If we got 4 extra centuries in a qcent, 3468 * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. 3469 * Otherwise, we add back in the earlier bias we removed (the 123 from 3470 * figuring in March 1st), find the month index (integer division by 30.6), 3471 * and the remainder is the day-of-month. We then have to convert back to 3472 * 'real' months (including fixing January and February from being 14/15 in 3473 * the previous year to being in the proper year). After that, to get 3474 * tm_yday, we work with the normalised year and get a new yearday value for 3475 * January 1st, which we subtract from the yearday value we had earlier, 3476 * representing the date we've re-built. This is done from January 1 3477 * because tm_yday is 0-origin. 3478 * 3479 * Since POSIX time routines are only guaranteed to work for times since the 3480 * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm 3481 * applies Gregorian calendar rules even to dates before the 16th century 3482 * doesn't bother me. Besides, you'd need cultural context for a given 3483 * date to know whether it was Julian or Gregorian calendar, and that's 3484 * outside the scope for this routine. Since we convert back based on the 3485 * same rules we used to build the yearday, you'll only get strange results 3486 * for input which needed normalising, or for the 'odd' century years which 3487 * were leap years in the Julian calander but not in the Gregorian one. 3488 * I can live with that. 3489 * 3490 * This algorithm also fails to handle years before A.D. 1 gracefully, but 3491 * that's still outside the scope for POSIX time manipulation, so I don't 3492 * care. 3493 */ 3494 3495 ###### year = 1900 + ptm->tm_year; 3496 ###### month = ptm->tm_mon; 3497 ###### mday = ptm->tm_mday; 3498 /* allow given yday with no month & mday to dominate the result */ 3499 ###### if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { 3500 ###### month = 0; 3501 ###### mday = 0; 3502 ###### jday = 1 + ptm->tm_yday; 3503 } 3504 else { 3505 ###### jday = 0; 3506 } 3507 ###### if (month >= 2) 3508 ###### month+=2; 3509 else 3510 ###### month+=14, year--; 3511 ###### yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; 3512 ###### yearday += month*MONTH_TO_DAYS + mday + jday; 3513 /* 3514 * Note that we don't know when leap-seconds were or will be, 3515 * so we have to trust the user if we get something which looks 3516 * like a sensible leap-second. Wild values for seconds will 3517 * be rationalised, however. 3518 */ 3519 ###### if ((unsigned) ptm->tm_sec <= 60) { 3520 ###### secs = 0; 3521 } 3522 else { 3523 ###### secs = ptm->tm_sec; 3524 ###### ptm->tm_sec = 0; 3525 } 3526 ###### secs += 60 * ptm->tm_min; 3527 ###### secs += SECS_PER_HOUR * ptm->tm_hour; 3528 ###### if (secs < 0) { 3529 ###### if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { 3530 /* got negative remainder, but need positive time */ 3531 /* back off an extra day to compensate */ 3532 ###### yearday += (secs/SECS_PER_DAY)-1; 3533 ###### secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); 3534 } 3535 else { 3536 ###### yearday += (secs/SECS_PER_DAY); 3537 ######