1 /* mg.c 2 * 3 * Copyright (C) 1991, 1992, 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 * "Sam sat on the ground and put his head in his hands. 'I wish I had never 13 * come here, and I don't want to see no more magic,' he said, and fell silent." 14 */ 15 16 /* 17 =head1 Magical Functions 18 19 "Magic" is special data attached to SV structures in order to give them 20 "magical" properties. When any Perl code tries to read from, or assign to, 21 an SV marked as magical, it calls the 'get' or 'set' function associated 22 with that SV's magic. A get is called prior to reading an SV, in order to 23 give it a chance to update its internal value (get on $. writes the line 24 number of the last read filehandle into to the SV's IV slot), while 25 set is called after an SV has been written to, in order to allow it to make 26 use of its changed value (set on $/ copies the SV's new value to the 27 PL_rs global variable). 28 29 Magic is implemented as a linked list of MAGIC structures attached to the 30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array 31 of functions that implement the get(), set(), length() etc functions, 32 plus space for some flags and pointers. For example, a tied variable has 33 a MAGIC structure that contains a pointer to the object associated with the 34 tie. 35 36 */ 37 38 #include "EXTERN.h" 39 #define PERL_IN_MG_C 40 #include "perl.h" 41 42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) 43 # ifndef NGROUPS 44 # define NGROUPS 32 45 # endif 46 # ifdef I_GRP 47 # include 48 # endif 49 #endif 50 51 #ifdef __hpux 52 # include 53 #endif 54 55 Signal_t Perl_csighandler(int sig); 56 57 #ifdef __Lynx__ 58 /* Missing protos on LynxOS */ 59 void setruid(uid_t id); 60 void seteuid(uid_t id); 61 void setrgid(uid_t id); 62 void setegid(uid_t id); 63 #endif 64 65 /* 66 * Use the "DESTRUCTOR" scope cleanup to reinstate magic. 67 */ 68 69 struct magic_state { 70 SV* mgs_sv; 71 U32 mgs_flags; 72 I32 mgs_ss_ix; 73 }; 74 /* MGS is typedef'ed to struct magic_state in perl.h */ 75 76 STATIC void 77 S_save_magic(pTHX_ I32 mgs_ix, SV *sv) 78 17620145 { 79 17620145 MGS* mgs; 80 17620145 assert(SvMAGICAL(sv)); 81 #ifdef PERL_OLD_COPY_ON_WRITE 82 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */ 83 if (SvIsCOW(sv)) 84 sv_force_normal(sv); 85 #endif 86 87 17620145 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); 88 89 17620145 mgs = SSPTR(mgs_ix, MGS*); 90 17620145 mgs->mgs_sv = sv; 91 17620145 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); 92 17620145 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ 93 94 17620145 SvMAGICAL_off(sv); 95 17620145 SvREADONLY_off(sv); 96 17620145 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; 97 } 98 99 /* 100 =for apidoc mg_magical 101 102 Turns on the magical status of an SV. See C. 103 104 =cut 105 */ 106 107 void 108 Perl_mg_magical(pTHX_ SV *sv) 109 11067776 { 110 11067776 const MAGIC* mg; 111 22246477 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 112 11178701 const MGVTBL* const vtbl = mg->mg_virtual; 113 11178701 if (vtbl) { 114 11147340 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) 115 5377901 SvGMAGICAL_on(sv); 116 11147340 if (vtbl->svt_set) 117 6803382 SvSMAGICAL_on(sv); 118 11147340 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) 119 4958457 SvRMAGICAL_on(sv); 120 } 121 } 122 } 123 124 /* 125 =for apidoc mg_get 126 127 Do magic after a value is retrieved from the SV. See C. 128 129 =cut 130 */ 131 132 int 133 Perl_mg_get(pTHX_ SV *sv) 134 10635393 { 135 10635393 const I32 mgs_ix = SSNEW(sizeof(MGS)); 136 10635393 const bool was_temp = (bool)SvTEMP(sv); 137 10635393 int have_new = 0; 138 10635393 MAGIC *newmg, *head, *cur, *mg; 139 /* guard against sv having being freed midway by holding a private 140 reference. */ 141 142 /* sv_2mortal has this side effect of turning on the TEMP flag, which can 143 cause the SV's buffer to get stolen (and maybe other stuff). 144 So restore it. 145 */ 146 10635393 sv_2mortal(SvREFCNT_inc(sv)); 147 10635393 if (!was_temp) { 148 10635393 SvTEMP_off(sv); 149 } 150 151 10635393 save_magic(mgs_ix, sv); 152 153 /* We must call svt_get(sv, mg) for each valid entry in the linked 154 list of magic. svt_get() may delete the current entry, add new 155 magic to the head of the list, or upgrade the SV. AMS 20010810 */ 156 157 10635393 newmg = cur = head = mg = SvMAGIC(sv); 158 21281687 while (mg) { 159 10646309 const MGVTBL * const vtbl = mg->mg_virtual; 160 161 10646309 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { 162 10635910 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); 163 164 /* guard against magic having been deleted - eg FETCH calling 165 * untie */ 166 10635900 if (!SvMAGIC(sv)) 167 5 break; 168 169 /* Don't restore the flags for this entry if it was deleted. */ 170 10635895 if (mg->mg_flags & MGf_GSKIP) 171 115214 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; 172 } 173 174 10646294 mg = mg->mg_moremagic; 175 176 10646294 if (have_new) { 177 /* Have we finished with the new entries we saw? Start again 178 where we left off (unless there are more new entries). */ 179 3 if (mg == head) { 180 3 have_new = 0; 181 3 mg = cur; 182 3 head = newmg; 183 } 184 } 185 186 /* Were any new entries added? */ 187 10646294 if (!have_new && (newmg = SvMAGIC(sv)) != head) { 188 3 have_new = 1; 189 3 cur = mg; 190 3 mg = newmg; 191 } 192 } 193 194 10635383 restore_magic(INT2PTR(void *, (IV)mgs_ix)); 195 196 10635383 if (SvREFCNT(sv) == 1) { 197 /* We hold the last reference to this SV, which implies that the 198 SV was deleted as a side effect of the routines we called. */ 199 1 SvOK_off(sv); 200 } 201 10635383 return 0; 202 } 203 204 /* 205 =for apidoc mg_set 206 207 Do magic after a value is assigned to the SV. See C. 208 209 =cut 210 */ 211 212 int 213 Perl_mg_set(pTHX_ SV *sv) 214 6818369 { 215 6818369 const I32 mgs_ix = SSNEW(sizeof(MGS)); 216 6818369 MAGIC* mg; 217 6818369 MAGIC* nextmg; 218 219 6818369 save_magic(mgs_ix, sv); 220 221 13075198 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 222 6256846 const MGVTBL* vtbl = mg->mg_virtual; 223 6256846 nextmg = mg->mg_moremagic; /* it may delete itself */ 224 6256846 if (mg->mg_flags & MGf_GSKIP) { 225 40 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ 226 40 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; 227 } 228 6256846 if (vtbl && vtbl->svt_set) 229 6256830 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); 230 } 231 232 6818352 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 233 6818352 return 0; 234 } 235 236 /* 237 =for apidoc mg_length 238 239 Report on the SV's length. See C. 240 241 =cut 242 */ 243 244 U32 245 Perl_mg_length(pTHX_ SV *sv) 246 9846 { 247 9846 MAGIC* mg; 248 9846 STRLEN len; 249 250 9856 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 251 9846 const MGVTBL * const vtbl = mg->mg_virtual; 252 9846 if (vtbl && vtbl->svt_len) { 253 9836 const I32 mgs_ix = SSNEW(sizeof(MGS)); 254 9836 save_magic(mgs_ix, sv); 255 /* omit MGf_GSKIP -- not changed here */ 256 9836 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); 257 9836 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 258 9836 return len; 259 } 260 } 261 262 10 if (DO_UTF8(sv)) { 263 1 const U8 *s = (U8*)SvPV_const(sv, len); 264 1 len = Perl_utf8_length(aTHX_ s, s + len); 265 } 266 else 267 9 (void)SvPV_const(sv, len); 268 10 return len; 269 } 270 271 I32 272 Perl_mg_size(pTHX_ SV *sv) 273 713638 { 274 713638 MAGIC* mg; 275 276 1427018 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 277 713764 const MGVTBL* const vtbl = mg->mg_virtual; 278 713764 if (vtbl && vtbl->svt_len) { 279 384 const I32 mgs_ix = SSNEW(sizeof(MGS)); 280 384 I32 len; 281 384 save_magic(mgs_ix, sv); 282 /* omit MGf_GSKIP -- not changed here */ 283 384 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); 284 384 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 285 384 return len; 286 } 287 } 288 289 713254 switch(SvTYPE(sv)) { 290 case SVt_PVAV: 291 713254 return AvFILLp((AV *) sv); /* Fallback to non-tied array */ 292 case SVt_PVHV: 293 /* FIXME */ 294 default: 295 ###### Perl_croak(aTHX_ "Size magic not implemented"); 296 713638 break; 297 } 298 713638 return 0; 299 } 300 301 /* 302 =for apidoc mg_clear 303 304 Clear something magical that the SV represents. See C. 305 306 =cut 307 */ 308 309 int 310 Perl_mg_clear(pTHX_ SV *sv) 311 156163 { 312 156163 const I32 mgs_ix = SSNEW(sizeof(MGS)); 313 156163 MAGIC* mg; 314 315 156163 save_magic(mgs_ix, sv); 316 317 175623 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 318 19464 const MGVTBL* const vtbl = mg->mg_virtual; 319 /* omit GSKIP -- never set here */ 320 321 19464 if (vtbl && vtbl->svt_clear) 322 14021 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); 323 } 324 325 156159 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 326 156159 return 0; 327 } 328 329 /* 330 =for apidoc mg_find 331 332 Finds the magic pointer for type matching the SV. See C. 333 334 =cut 335 */ 336 337 MAGIC* 338 Perl_mg_find(pTHX_ const SV *sv, int type) 339 69226344 { 340 69226344 if (sv) { 341 69224331 MAGIC *mg; 342 134640296 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 343 86004774 if (mg->mg_type == type) 344 20588809 return mg; 345 } 346 } 347 48637535 return 0; 348 } 349 350 /* 351 =for apidoc mg_copy 352 353 Copies the magic from one SV to another. See C. 354 355 =cut 356 */ 357 358 int 359 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) 360 475343 { 361 475343 int count = 0; 362 475343 MAGIC* mg; 363 951114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 364 475771 const MGVTBL* const vtbl = mg->mg_virtual; 365 475771 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ 366 ###### count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen); 367 } 368 475771 else if (isUPPER(mg->mg_type)) { 369 475343 sv_magic(nsv, 370 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) : 371 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj) 372 ? sv : mg->mg_obj, 373 toLOWER(mg->mg_type), key, klen); 374 475343 count++; 375 } 376 } 377 475343 return count; 378 } 379 380 /* 381 =for apidoc mg_localize 382 383 Copy some of the magic from an existing SV to new localized version of 384 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic 385 doesn't (eg taint, pos). 386 387 =cut 388 */ 389 390 void 391 Perl_mg_localize(pTHX_ SV *sv, SV *nsv) 392 237502 { 393 237502 MAGIC *mg; 394 480380 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 395 242878 const MGVTBL* const vtbl = mg->mg_virtual; 396 242878 switch (mg->mg_type) { 397 /* value magic types: don't copy */ 398 case PERL_MAGIC_bm: 399 case PERL_MAGIC_fm: 400 case PERL_MAGIC_regex_global: 401 case PERL_MAGIC_nkeys: 402 #ifdef USE_LOCALE_COLLATE 403 case PERL_MAGIC_collxfrm: 404 #endif 405 case PERL_MAGIC_qr: 406 case PERL_MAGIC_taint: 407 case PERL_MAGIC_vec: 408 case PERL_MAGIC_vstring: 409 case PERL_MAGIC_utf8: 410 case PERL_MAGIC_substr: 411 case PERL_MAGIC_defelem: 412 case PERL_MAGIC_arylen: 413 case PERL_MAGIC_pos: 414 case PERL_MAGIC_backref: 415 case PERL_MAGIC_arylen_p: 416 case PERL_MAGIC_rhash: 417 case PERL_MAGIC_symtab: 418 229745 continue; 419 } 420 421 229745 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) { 422 /* XXX calling the copy method is probably not correct. DAPM */ 423 ###### (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, 424 mg->mg_ptr, mg->mg_len); 425 } 426 else { 427 229745 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, 428 mg->mg_ptr, mg->mg_len); 429 } 430 /* container types should remain read-only across localization */ 431 229745 SvFLAGS(nsv) |= SvREADONLY(sv); 432 } 433 434 237502 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { 435 229745 SvFLAGS(nsv) |= SvMAGICAL(sv); 436 229745 PL_localizing = 1; 437 229745 SvSETMAGIC(nsv); 438 229745 PL_localizing = 0; 439 } 440 } 441 442 /* 443 =for apidoc mg_free 444 445 Free any magic storage used by the SV. See C. 446 447 =cut 448 */ 449 450 int 451 Perl_mg_free(pTHX_ SV *sv) 452 6816818 { 453 6816818 MAGIC* mg; 454 6816818 MAGIC* moremagic; 455 13670909 for (mg = SvMAGIC(sv); mg; mg = moremagic) { 456 6854091 const MGVTBL* const vtbl = mg->mg_virtual; 457 6854091 moremagic = mg->mg_moremagic; 458 6854091 if (vtbl && vtbl->svt_free) 459 183865 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); 460 6854091 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 461 824206 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) 462 682926 Safefree(mg->mg_ptr); 463 141280 else if (mg->mg_len == HEf_SVKEY) 464 141280 SvREFCNT_dec((SV*)mg->mg_ptr); 465 } 466 6854091 if (mg->mg_flags & MGf_REFCOUNTED) 467 281471 SvREFCNT_dec(mg->mg_obj); 468 6854091 Safefree(mg); 469 } 470 6816818 SvMAGIC_set(sv, NULL); 471 6816818 return 0; 472 } 473 474 #include 475 476 U32 477 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) 478 40 { 479 40 register const REGEXP *rx; 480 40 PERL_UNUSED_ARG(sv); 481 482 40 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 483 38 if (mg->mg_obj) /* @+ */ 484 18 return rx->nparens; 485 else /* @- */ 486 20 return rx->lastparen; 487 } 488 489 2 return (U32)-1; 490 } 491 492 int 493 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) 494 1888 { 495 1888 register REGEXP *rx; 496 497 1888 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 498 1888 register const I32 paren = mg->mg_len; 499 1888 register I32 s; 500 1888 register I32 t; 501 1888 if (paren < 0) 502 ###### return 0; 503 1888 if (paren <= (I32)rx->nparens && 504 (s = rx->startp[paren]) != -1 && 505 (t = rx->endp[paren]) != -1) 506 { 507 1852 register I32 i; 508 1852 if (mg->mg_obj) /* @+ */ 509 629 i = t; 510 else /* @- */ 511 1223 i = s; 512 513 1852 if (i > 0 && RX_MATCH_UTF8(rx)) { 514 ###### const char * const b = rx->subbeg; 515 ###### if (b) 516 ###### i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); 517 } 518 519 1852 sv_setiv(sv, i); 520 } 521 } 522 1888 return 0; 523 } 524 525 int 526 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) 527 2 { 528 2 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); 529 2 Perl_croak(aTHX_ PL_no_modify); 530 NORETURN_FUNCTION_END; 531 } 532 533 U32 534 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 535 9836 { 536 9836 register I32 paren; 537 9836 register I32 i; 538 9836 register const REGEXP *rx; 539 9836 I32 s1, t1; 540 541 9836 switch (*mg->mg_ptr) { 542 case '1': case '2': case '3': case '4': 543 case '5': case '6': case '7': case '8': case '9': case '&': 544 9832 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 545 546 9831 paren = atoi(mg->mg_ptr); /* $& is in [0] */ 547 getparen: 548 9831 if (paren <= (I32)rx->nparens && 549 (s1 = rx->startp[paren]) != -1 && 550 (t1 = rx->endp[paren]) != -1) 551 { 552 9830 i = t1 - s1; 553 getlen: 554 9832 if (i > 0 && RX_MATCH_UTF8(rx)) { 555 7 const char * const s = rx->subbeg + s1; 556 7 const U8 *ep; 557 7 STRLEN el; 558 559 7 i = t1 - s1; 560 7 if (is_utf8_string_loclen((U8*)s, i, &ep, &el)) 561 7 i = el; 562 } 563 9832 if (i < 0) 564 ###### Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); 565 9832 return i; 566 } 567 else { 568 1 if (ckWARN(WARN_UNINITIALIZED)) 569 1 report_uninit(sv); 570 } 571 } 572 else { 573 1 if (ckWARN(WARN_UNINITIALIZED)) 574 1 report_uninit(sv); 575 } 576 2 return 0; 577 case '+': 578 ###### if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 579 ###### paren = rx->lastparen; 580 ###### if (paren) 581 ###### goto getparen; 582 } 583 ###### return 0; 584 case '\016': /* ^N */ 585 ###### if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 586 ###### paren = rx->lastcloseparen; 587 ###### if (paren) 588 ###### goto getparen; 589 } 590 ###### return 0; 591 case '`': 592 1 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 593 1 if (rx->startp[0] != -1) { 594 1 i = rx->startp[0]; 595 1 if (i > 0) { 596 1 s1 = 0; 597 1 t1 = i; 598 1 goto getlen; 599 } 600 } 601 } 602 ###### return 0; 603 case '\'': 604 1 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 605 1 if (rx->endp[0] != -1) { 606 1 i = rx->sublen - rx->endp[0]; 607 1 if (i > 0) { 608 1 s1 = rx->endp[0]; 609 1 t1 = rx->sublen; 610 1 goto getlen; 611 } 612 } 613 } 614 ###### return 0; 615 } 616 2 magic_get(sv,mg); 617 2 if (!SvPOK(sv) && SvNIOK(sv)) { 618 ###### sv_2pv(sv, 0); 619 } 620 2 if (SvPOK(sv)) 621 2 return SvCUR(sv); 622 ###### return 0; 623 } 624 625 #define SvRTRIM(sv) STMT_START { \ 626 STRLEN len = SvCUR(sv); \ 627 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \ 628 --len; \ 629 SvCUR_set(sv, len); \ 630 } STMT_END 631 632 int 633 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 634 4591256 { 635 dVAR; 636 4591256 register I32 paren; 637 4591256 register char *s = NULL; 638 4591256 register I32 i; 639 4591256 register REGEXP *rx; 640 641 4591256 switch (*mg->mg_ptr) { 642 case '\001': /* ^A */ 643 85 sv_setsv(sv, PL_bodytarget); 644 85 break; 645 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ 646 15873 if (*(mg->mg_ptr+1) == '\0') { 647 15870 sv_setiv(sv, (IV)PL_minus_c); 648 } 649 3 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) { 650 3 sv_setiv(sv, (IV)STATUS_NATIVE); 651 } 652 3 break; 653 654 case '\004': /* ^D */ 655 71769 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); 656 71769 break; 657 case '\005': /* ^E */ 658 159 if (*(mg->mg_ptr+1) == '\0') { 659 #ifdef MACOS_TRADITIONAL 660 { 661 char msg[256]; 662 663 sv_setnv(sv,(double)gMacPerl_OSErr); 664 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); 665 } 666 #else 667 #ifdef VMS 668 { 669 # include 670 # include 671 char msg[255]; 672 $DESCRIPTOR(msgdsc,msg); 673 sv_setnv(sv,(NV) vaxc$errno); 674 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) 675 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); 676 else 677 sv_setpvn(sv,"",0); 678 } 679 #else 680 #ifdef OS2 681 if (!(_emx_env & 0x200)) { /* Under DOS */ 682 sv_setnv(sv, (NV)errno); 683 sv_setpv(sv, errno ? Strerror(errno) : ""); 684 } else { 685 if (errno != errno_isOS2) { 686 int tmp = _syserrno(); 687 if (tmp) /* 2nd call to _syserrno() makes it 0 */ 688 Perl_rc = tmp; 689 } 690 sv_setnv(sv, (NV)Perl_rc); 691 sv_setpv(sv, os2error(Perl_rc)); 692 } 693 #else 694 #ifdef WIN32 695 { 696 DWORD dwErr = GetLastError(); 697 sv_setnv(sv, (NV)dwErr); 698 if (dwErr) 699 { 700 PerlProc_GetOSError(sv, dwErr); 701 } 702 else 703 sv_setpvn(sv, "", 0); 704 SetLastError(dwErr); 705 } 706 #else 707 { 708 2 const int saveerrno = errno; 709 2 sv_setnv(sv, (NV)errno); 710 2 sv_setpv(sv, errno ? Strerror(errno) : ""); 711 2 errno = saveerrno; 712 } 713 #endif 714 #endif 715 #endif 716 #endif 717 2 SvRTRIM(sv); 718 2 SvNOK_on(sv); /* what a wonderful hack! */ 719 } 720 157 else if (strEQ(mg->mg_ptr+1, "NCODING")) 721 157 sv_setsv(sv, PL_encoding); 722 157 break; 723 case '\006': /* ^F */ 724 25 sv_setiv(sv, (IV)PL_maxsysfd); 725 25 break; 726 case '\010': /* ^H */ 727 54747 sv_setiv(sv, (IV)PL_hints); 728 54747 break; 729 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 730 13 if (PL_inplace) 731 9 sv_setpv(sv, PL_inplace); 732 else 733 4 sv_setsv(sv, &PL_sv_undef); 734 4 break; 735 case '\017': /* ^O & ^OPEN */ 736 66009 if (*(mg->mg_ptr+1) == '\0') { 737 65991 sv_setpv(sv, PL_osname); 738 65991 SvTAINTED_off(sv); 739 } 740 18 else if (strEQ(mg->mg_ptr, "\017PEN")) { 741 18 if (!PL_compiling.cop_io) 742 11 sv_setsv(sv, &PL_sv_undef); 743 else { 744 7 sv_setsv(sv, PL_compiling.cop_io); 745 } 746 } 747 7 break; 748 case '\020': /* ^P */ 749 419 sv_setiv(sv, (IV)PL_perldb); 750 419 break; 751 case '\023': /* ^S */ 752 14 if (*(mg->mg_ptr+1) == '\0') { 753 14 if (PL_lex_state != LEX_NOTPARSING) 754 1 SvOK_off(sv); 755 13 else if (PL_in_eval) 756 6 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); 757 else 758 7 sv_setiv(sv, 0); 759 } 760 7 break; 761 case '\024': /* ^T */ 762 970 if (*(mg->mg_ptr+1) == '\0') { 763 #ifdef BIG_TIME 764 sv_setnv(sv, PL_basetime); 765 #else 766 335 sv_setiv(sv, (IV)PL_basetime); 767 #endif 768 } 769 635 else if (strEQ(mg->mg_ptr, "\024AINT")) 770 635 sv_setiv(sv, PL_tainting 771 ? (PL_taint_warn || PL_unsafe ? -1 : 1) 772 : 0); 773 635 break; 774 case '\025': /* $^UNICODE, $^UTF8LOCALE */ 775 31 if (strEQ(mg->mg_ptr, "\025NICODE")) 776 30 sv_setuv(sv, (UV) PL_unicode); 777 1 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE")) 778 1 sv_setuv(sv, (UV) PL_utf8locale); 779 1 break; 780 case '\027': /* ^W & $^WARNING_BITS */ 781 31882 if (*(mg->mg_ptr+1) == '\0') 782 21911 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); 783 9971 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 784 9971 if (PL_compiling.cop_warnings == pWARN_NONE || 785 PL_compiling.cop_warnings == pWARN_STD) 786 { 787 5412 sv_setpvn(sv, WARN_NONEstring, WARNsize) ; 788 } 789 4559 else if (PL_compiling.cop_warnings == pWARN_ALL) { 790 /* Get the bit mask for $warnings::Bits{all}, because 791 * it could have been extended by warnings::register */ 792 3574 SV **bits_all; 793 3574 HV *bits=get_hv("warnings::Bits", FALSE); 794 3574 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { 795 3574 sv_setsv(sv, *bits_all); 796 } 797 else { 798 ###### sv_setpvn(sv, WARN_ALLstring, WARNsize) ; 799 } 800 } 801 else { 802 985 sv_setsv(sv, PL_compiling.cop_warnings); 803 } 804 9971 SvPOK_only(sv); 805 } 806 9971 break; 807 case '1': case '2': case '3': case '4': 808 case '5': case '6': case '7': case '8': case '9': case '&': 809 4086838 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 810 4086545 I32 s1, t1; 811 812 /* 813 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); 814 * XXX Does the new way break anything? 815 */ 816 4086545 paren = atoi(mg->mg_ptr); /* $& is in [0] */ 817 getparen: 818 4087347 if (paren <= (I32)rx->nparens && 819 (s1 = rx->startp[paren]) != -1 && 820 (t1 = rx->endp[paren]) != -1) 821 { 822 3398332 i = t1 - s1; 823 3398332 s = rx->subbeg + s1; 824 3398332 if (!rx->subbeg) 825 ###### break; 826 827 getrx: 828 3398419 if (i >= 0) { 829 3398419 sv_setpvn(sv, s, i); 830 3398419 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i)) 831 76907 SvUTF8_on(sv); 832 else 833 3321512 SvUTF8_off(sv); 834 3398419 if (PL_tainting) { 835 965 if (RX_MATCH_TAINTED(rx)) { 836 53 MAGIC* mg = SvMAGIC(sv); 837 53 MAGIC* mgt; 838 53 PL_tainted = 1; 839 53 SvMAGIC_set(sv, mg->mg_moremagic); 840 53 SvTAINT(sv); 841 53 if ((mgt = SvMAGIC(sv))) { 842 53 mg->mg_moremagic = mgt; 843 53 SvMAGIC_set(sv, mg); 844 } 845 } else 846 912 SvTAINTED_off(sv); 847 } 848 912 break; 849 } 850 } 851 } 852 689308 sv_setsv(sv,&PL_sv_undef); 853 689308 break; 854 case '+': 855 776 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 856 776 paren = rx->lastparen; 857 776 if (paren) 858 776 goto getparen; 859 } 860 ###### sv_setsv(sv,&PL_sv_undef); 861 ###### break; 862 case '\016': /* ^N */ 863 27 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 864 27 paren = rx->lastcloseparen; 865 27 if (paren) 866 26 goto getparen; 867 } 868 1 sv_setsv(sv,&PL_sv_undef); 869 1 break; 870 case '`': 871 55 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 872 55 if ((s = rx->subbeg) && rx->startp[0] != -1) { 873 55 i = rx->startp[0]; 874 55 goto getrx; 875 } 876 } 877 ###### sv_setsv(sv,&PL_sv_undef); 878 ###### break; 879 case '\'': 880 32 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 881 32 if (rx->subbeg && rx->endp[0] != -1) { 882 32 s = rx->subbeg + rx->endp[0]; 883 32 i = rx->sublen - rx->endp[0]; 884 32 goto getrx; 885 } 886 } 887 ###### sv_setsv(sv,&PL_sv_undef); 888 ###### break; 889 case '.': 890 93335 if (GvIO(PL_last_in_gv)) { 891 93318 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); 892 } 893 93318 break; 894 case '?': 895 { 896 6555 sv_setiv(sv, (IV)STATUS_CURRENT); 897 #ifdef COMPLEX_STATUS 898 LvTARGOFF(sv) = PL_statusvalue; 899 LvTARGLEN(sv) = PL_statusvalue_vms; 900 #endif 901 } 902 6555 break; 903 case '^': 904 2 if (GvIOp(PL_defoutgv)) 905 2 s = IoTOP_NAME(GvIOp(PL_defoutgv)); 906 2 if (s) 907 1 sv_setpv(sv,s); 908 else { 909 1 sv_setpv(sv,GvENAME(PL_defoutgv)); 910 1 sv_catpv(sv,"_TOP"); 911 } 912 1 break; 913 case '~': 914 6 if (GvIOp(PL_defoutgv)) 915 6 s = IoFMT_NAME(GvIOp(PL_defoutgv)); 916 6 if (!s) 917 3 s = GvENAME(PL_defoutgv); 918 6 sv_setpv(sv,s); 919 6 break; 920 case '=': 921 6 if (GvIOp(PL_defoutgv)) 922 6 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); 923 6 break; 924 case '-': 925 11 if (GvIOp(PL_defoutgv)) 926 11 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); 927 11 break; 928 case '%': 929 7 if (GvIOp(PL_defoutgv)) 930 7 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); 931 7 break; 932 case ':': 933 ###### break; 934 case '/': 935 ###### break; 936 case '[': 937 ###### WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase)); 938 ###### break; 939 case '|': 940 169 if (GvIOp(PL_defoutgv)) 941 169 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); 942 169 break; 943 case ',': 944 60624 break; 945 case '\\': 946 60624 if (PL_ors_sv) 947 132 sv_copypv(sv, PL_ors_sv); 948 132 break; 949 case '!': 950 #ifdef VMS 951 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); 952 sv_setpv(sv, errno ? Strerror(errno) : ""); 953 #else 954 { 955 41949 const int saveerrno = errno; 956 41949 sv_setnv(sv, (NV)errno); 957 #ifdef OS2 958 if (errno == errno_isOS2 || errno == errno_isOS2_set) 959 sv_setpv(sv, os2error(Perl_rc)); 960 else 961 #endif 962 41949 sv_setpv(sv, errno ? Strerror(errno) : ""); 963 41949 errno = saveerrno; 964 } 965 #endif 966 41949 SvRTRIM(sv); 967 41949 SvNOK_on(sv); /* what a wonderful hack! */ 968 41949 break; 969 case '<': 970 21 sv_setiv(sv, (IV)PL_uid); 971 21 break; 972 case '>': 973 44 sv_setiv(sv, (IV)PL_euid); 974 44 break; 975 case '(': 976 4 sv_setiv(sv, (IV)PL_gid); 977 #ifdef HAS_GETGROUPS 978 4 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid); 979 #endif 980 4 goto add_groups; 981 case ')': 982 5 sv_setiv(sv, (IV)PL_egid); 983 #ifdef HAS_GETGROUPS 984 5 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid); 985 #endif 986 add_groups: 987 #ifdef HAS_GETGROUPS 988 { 989 9 Groups_t gary[NGROUPS]; 990 9 I32 j = getgroups(NGROUPS,gary); 991 27 while (--j >= 0) 992 18 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]); 993 } 994 #endif 995 9 (void)SvIOK_on(sv); /* what a wonderful hack! */ 996 break; 997 #ifndef MACOS_TRADITIONAL 998 case '0': 999 4591256 break; 1000 #endif 1001 } 1002 4591256 return 0; 1003 } 1004 1005 int 1006 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) 1007 ###### { 1008 ###### struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 1009 1010 ###### if (uf && uf->uf_val) 1011 ###### (*uf->uf_val)(aTHX_ uf->uf_index, sv); 1012 ###### return 0; 1013 } 1014 1015 int 1016 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) 1017 218436 { 1018 dVAR; 1019 218436 const char *s; 1020 218436 const char *ptr; 1021 218436 STRLEN len, klen; 1022 1023 218436 s = SvPV_const(sv,len); 1024 218436 ptr = MgPV_const(mg,klen); 1025 218436 my_setenv(ptr, s); 1026 1027 #ifdef DYNAMIC_ENV_FETCH 1028 /* We just undefd an environment var. Is a replacement */ 1029 /* waiting in the wings? */ 1030 if (!len) { 1031 SV **valp; 1032 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE))) 1033 s = SvPV_const(*valp, len); 1034 } 1035 #endif 1036 1037 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) 1038 /* And you'll never guess what the dog had */ 1039 /* in its mouth... */ 1040 218436 if (PL_tainting) { 1041 2195 MgTAINTEDDIR_off(mg); 1042 #ifdef VMS 1043 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { 1044 char pathbuf[256], eltbuf[256], *cp, *elt = s; 1045 Stat_t sbuf; 1046 int i = 0, j = 0; 1047 1048 do { /* DCL$PATH may be a search list */ 1049 while (1) { /* as may dev portion of any element */ 1050 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { 1051 if ( *(cp+1) == '.' || *(cp+1) == '-' || 1052 cando_by_name(S_IWUSR,0,elt) ) { 1053 MgTAINTEDDIR_on(mg); 1054 return 0; 1055 } 1056 } 1057 if ((cp = strchr(elt, ':')) != Nullch) 1058 *cp = '\0'; 1059 if (my_trnlnm(elt, eltbuf, j++)) 1060 elt = eltbuf; 1061 else 1062 break; 1063 } 1064 j = 0; 1065 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); 1066 } 1067 #endif /* VMS */ 1068 2195 if (s && klen == 4 && strEQ(ptr,"PATH")) { 1069 63 const char * const strend = s + len; 1070 1071 543 while (s < strend) { 1072 482 char tmpbuf[256]; 1073 482 Stat_t st; 1074 482 I32 i; 1075 482 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, 1076 s, strend, ':', &i); 1077 482 s++; 1078 482 if (i >= sizeof tmpbuf /* too long -- assume the worst */ 1079 || *tmpbuf != '/' 1080 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { 1081 2 MgTAINTEDDIR_on(mg); 1082 2 return 0; 1083 } 1084 } 1085 } 1086 } 1087 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ 1088 1089 218434 return 0; 1090 } 1091 1092 int 1093 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) 1094 187 { 1095 187 PERL_UNUSED_ARG(sv); 1096 187 my_setenv(MgPV_nolen_const(mg),Nullch); 1097 187 return 0; 1098 } 1099 1100 int 1101 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) 1102 36 { 1103 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN) 1104 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1105 #else 1106 36 if (PL_localizing) { 1107 36 HE* entry; 1108 36 magic_clear_all_env(sv,mg); 1109 36 hv_iterinit((HV*)sv); 1110 872 while ((entry = hv_iternext((HV*)sv))) { 1111 836 I32 keylen; 1112 836 my_setenv(hv_iterkey(entry, &keylen), 1113 SvPV_nolen_const(hv_iterval((HV*)sv, entry))); 1114 } 1115 } 1116 #endif 1117 36 return 0; 1118 } 1119 1120 int 1121 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 1122 56 { 1123 dVAR; 1124 #ifndef PERL_MICRO 1125 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN) 1126 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1127 #else 1128 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) 1129 PerlEnv_clearenv(); 1130 # else 1131 # ifdef USE_ENVIRON_ARRAY 1132 # if defined(USE_ITHREADS) 1133 /* only the parent thread can clobber the process environment */ 1134 if (PL_curinterp == aTHX) 1135 # endif 1136 { 1137 # ifndef PERL_USE_SAFE_PUTENV 1138 56 if (!PL_use_safe_putenv) { 1139 56 I32 i; 1140 1141 56 if (environ == PL_origenviron) 1142 ###### environ = (char**)safesysmalloc(sizeof(char*)); 1143 else 1144 1778 for (i = 0; environ[i]; i++) 1145 1722 safesysfree(environ[i]); 1146 } 1147 # endif /* PERL_USE_SAFE_PUTENV */ 1148 1149 56 environ[0] = Nullch; 1150 } 1151 # endif /* USE_ENVIRON_ARRAY */ 1152 # endif /* PERL_IMPLICIT_SYS || WIN32 */ 1153 #endif /* VMS || EPOC */ 1154 #endif /* !PERL_MICRO */ 1155 56 PERL_UNUSED_ARG(sv); 1156 56 PERL_UNUSED_ARG(mg); 1157 56 return 0; 1158 } 1159 1160 #ifndef PERL_MICRO 1161 #ifdef HAS_SIGPROCMASK 1162 static void 1163 restore_sigmask(pTHX_ SV *save_sv) 1164 1483 { 1165 1483 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); 1166 1483 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); 1167 } 1168 #endif 1169 int 1170 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 1171 22076 { 1172 /* Are we fetching a signal entry? */ 1173 22076 const I32 i = whichsig(MgPV_nolen_const(mg)); 1174 22076 if (i > 0) { 1175 531 if(PL_psig_ptr[i]) 1176 520 sv_setsv(sv,PL_psig_ptr[i]); 1177 else { 1178 11 Sighandler_t sigstate; 1179 11 sigstate = rsignal_state(i); 1180 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1181 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN; 1182 #endif 1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1184 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL; 1185 #endif 1186 /* cache state so we don't fetch it again */ 1187 11 if(sigstate == SIG_IGN) 1188 2 sv_setpv(sv,"IGNORE"); 1189 else 1190 9 sv_setsv(sv,&PL_sv_undef); 1191 11 PL_psig_ptr[i] = SvREFCNT_inc(sv); 1192 11 SvTEMP_off(sv); 1193 } 1194 } 1195 22076 return 0; 1196 } 1197 int 1198 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 1199 1 { 1200 /* XXX Some of this code was copied from Perl_magic_setsig. A little 1201 * refactoring might be in order. 1202 */ 1203 dVAR; 1204 1 register const char * const s = MgPV_nolen_const(mg); 1205 1 PERL_UNUSED_ARG(sv); 1206 1 if (*s == '_') { 1207 1 SV** svp = 0; 1208 1 if (strEQ(s,"__DIE__")) 1209 ###### svp = &PL_diehook; 1210 1 else if (strEQ(s,"__WARN__")) 1211 1 svp = &PL_warnhook; 1212 else 1213 ###### Perl_croak(aTHX_ "No such hook: %s", s); 1214 1 if (svp && *svp) { 1215 1 SV * const to_dec = *svp; 1216 1 *svp = 0; 1217 1 SvREFCNT_dec(to_dec); 1218 } 1219 } 1220 else { 1221 /* Are we clearing a signal entry? */ 1222 ###### const I32 i = whichsig(s); 1223 ###### if (i > 0) { 1224 #ifdef HAS_SIGPROCMASK 1225 ###### sigset_t set, save; 1226 ###### SV* save_sv; 1227 /* Avoid having the signal arrive at a bad time, if possible. */ 1228 ###### sigemptyset(&set); 1229 ###### sigaddset(&set,i); 1230 ###### sigprocmask(SIG_BLOCK, &set, &save); 1231 ###### ENTER; 1232 ###### save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); 1233 ###### SAVEFREESV(save_sv); 1234 ###### SAVEDESTRUCTOR_X(restore_sigmask, save_sv); 1235 #endif 1236 ###### PERL_ASYNC_CHECK(); 1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1238 if (!PL_sig_handlers_initted) Perl_csighandler_init(); 1239 #endif 1240 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1241 PL_sig_defaulting[i] = 1; 1242 (void)rsignal(i, PL_csighandlerp); 1243 #else 1244 ###### (void)rsignal(i, SIG_DFL); 1245 #endif 1246 ###### if(PL_psig_name[i]) { 1247 ###### SvREFCNT_dec(PL_psig_name[i]); 1248 ###### PL_psig_name[i]=0; 1249 } 1250 ###### if(PL_psig_ptr[i]) { 1251 ###### SV *to_dec=PL_psig_ptr[i]; 1252 ###### PL_psig_ptr[i]=0; 1253 ###### LEAVE; 1254 ###### SvREFCNT_dec(to_dec); 1255 } 1256 else 1257 ###### LEAVE; 1258 } 1259 } 1260 1 return 0; 1261 } 1262 1263 static void 1264 S_raise_signal(pTHX_ int sig) 1265 22 { 1266 /* Set a flag to say this signal is pending */ 1267 22 PL_psig_pend[sig]++; 1268 /* And one to say _a_ signal is pending */ 1269 22 PL_sig_pending = 1; 1270 } 1271 1272 Signal_t 1273 Perl_csighandler(int sig) 1274 22 { 1275 #ifdef PERL_GET_SIG_CONTEXT 1276 dTHXa(PERL_GET_SIG_CONTEXT); 1277 #else 1278 dTHX; 1279 #endif 1280 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1281 (void) rsignal(sig, PL_csighandlerp); 1282 if (PL_sig_ignoring[sig]) return; 1283 #endif 1284 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1285 if (PL_sig_defaulting[sig]) 1286 #ifdef KILL_BY_SIGPRC 1287 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); 1288 #else 1289 exit(1); 1290 #endif 1291 #endif 1292 22 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) 1293 /* Call the perl level handler now-- 1294 * with risk we may be in malloc() etc. */ 1295 ###### (*PL_sighandlerp)(sig); 1296 else 1297 22 S_raise_signal(aTHX_ sig); 1298 } 1299 1300 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1301 void 1302 Perl_csighandler_init(void) 1303 { 1304 int sig; 1305 if (PL_sig_handlers_initted) return; 1306 1307 for (sig = 1; sig < SIG_SIZE; sig++) { 1308 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1309 dTHX; 1310 PL_sig_defaulting[sig] = 1; 1311 (void) rsignal(sig, PL_csighandlerp); 1312 #endif 1313 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1314 PL_sig_ignoring[sig] = 0; 1315 #endif 1316 } 1317 PL_sig_handlers_initted = 1; 1318 } 1319 #endif 1320 1321 void 1322 Perl_despatch_signals(pTHX) 1323 22 { 1324 22 int sig; 1325 22 PL_sig_pending = 0; 1326 1231 for (sig = 1; sig < SIG_SIZE; sig++) { 1327 1214 if (PL_psig_pend[sig]) { 1328 22 PERL_BLOCKSIG_ADD(set, sig); 1329 22 PL_psig_pend[sig] = 0; 1330 22 PERL_BLOCKSIG_BLOCK(set); 1331 22 (*PL_sighandlerp)(sig); 1332 17 PERL_BLOCKSIG_UNBLOCK(set); 1333 } 1334 } 1335 } 1336 1337 int 1338 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 1339 53763 { 1340 dVAR; 1341 53763 I32 i; 1342 53763 SV** svp = 0; 1343 /* Need to be careful with SvREFCNT_dec(), because that can have side 1344 * effects (due to closures). We must make sure that the new disposition 1345 * is in place before it is called. 1346 */ 1347 53763 SV* to_dec = 0; 1348 53763 STRLEN len; 1349 #ifdef HAS_SIGPROCMASK 1350 53763 sigset_t set, save; 1351 53763 SV* save_sv; 1352 #endif 1353 1354 53763 register const char *s = MgPV_const(mg,len); 1355 53763 if (*s == '_') { 1356 52267 if (strEQ(s,"__DIE__")) 1357 6619 svp = &PL_diehook; 1358 45648 else if (strEQ(s,"__WARN__")) 1359 45648 svp = &PL_warnhook; 1360 else 1361 ###### Perl_croak(aTHX_ "No such hook: %s", s); 1362 52267 i = 0; 1363 52267 if (*svp) { 1364 17854 to_dec = *svp; 1365 17854 *svp = 0; 1366 } 1367 } 1368 else { 1369 1496 i = whichsig(s); /* ...no, a brick */ 1370 1496 if (i <= 0) { 1371 13 if (ckWARN(WARN_SIGNAL)) 1372 1 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); 1373 13 return 0; 1374 } 1375 #ifdef HAS_SIGPROCMASK 1376 /* Avoid having the signal arrive at a bad time, if possible. */ 1377 1483 sigemptyset(&set); 1378 1483 sigaddset(&set,i); 1379 1483 sigprocmask(SIG_BLOCK, &set, &save); 1380 1483 ENTER; 1381 1483 save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); 1382 1483 SAVEFREESV(save_sv); 1383 1483 SAVEDESTRUCTOR_X(restore_sigmask, save_sv); 1384 #endif 1385 1483 PERL_ASYNC_CHECK(); 1386 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1387 if (!PL_sig_handlers_initted) Perl_csighandler_init(); 1388 #endif 1389 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1390 PL_sig_ignoring[i] = 0; 1391 #endif 1392 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1393 PL_sig_defaulting[i] = 0; 1394 #endif 1395 1483 SvREFCNT_dec(PL_psig_name[i]); 1396 1483 to_dec = PL_psig_ptr[i]; 1397 1483 PL_psig_ptr[i] = SvREFCNT_inc(sv); 1398 1483 SvTEMP_off(sv); /* Make sure it doesn't go away on us */ 1399 1483 PL_psig_name[i] = newSVpvn(s, len); 1400 1483 SvREADONLY_on(PL_psig_name[i]); 1401 } 1402 53750 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { 1403 18904 if (i) { 1404 660 (void)rsignal(i, PL_csighandlerp); 1405 #ifdef HAS_SIGPROCMASK 1406 660 LEAVE; 1407 #endif 1408 } 1409 else 1410 18244 *svp = SvREFCNT_inc(sv); 1411 18904 if(to_dec) 1412 1356 SvREFCNT_dec(to_dec); 1413 18904 return 0; 1414 } 1415 34846 s = SvPV_force(sv,len); 1416 34846 if (strEQ(s,"IGNORE")) { 1417 43 if (i) { 1418 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1419 PL_sig_ignoring[i] = 1; 1420 (void)rsignal(i, PL_csighandlerp); 1421 #else 1422 43 (void)rsignal(i, SIG_IGN); 1423 #endif 1424 } 1425 } 1426 34803 else if (strEQ(s,"DEFAULT") || !*s) { 1427 34783 if (i) 1428 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1429 { 1430 PL_sig_defaulting[i] = 1; 1431 (void)rsignal(i, PL_csighandlerp); 1432 } 1433 #else 1434 763 (void)rsignal(i, SIG_DFL); 1435 #endif 1436 } 1437 else { 1438 /* 1439 * We should warn if HINT_STRICT_REFS, but without 1440 * access to a known hint bit in a known OP, we can't 1441 * tell whether HINT_STRICT_REFS is in force or not. 1442 */ 1443 20 if (!strchr(s,':') && !strchr(s,'\'')) 1444 15 sv_insert(sv, 0, 0, "main::", 6); 1445 20 if (i) 1446 17 (void)rsignal(i, PL_csighandlerp); 1447 else 1448 3 *svp = SvREFCNT_inc(sv); 1449 } 1450 #ifdef HAS_SIGPROCMASK 1451 34846 if(i) 1452 823 LEAVE; 1453 #endif 1454 34846 if(to_dec) 1455 17949 SvREFCNT_dec(to_dec); 1456 34846 return 0; 1457 } 1458 #endif /* !PERL_MICRO */ 1459 1460 int 1461 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 1462 43463 { 1463 43463 PERL_UNUSED_ARG(sv); 1464 43463 PERL_UNUSED_ARG(mg); 1465 43463 PL_sub_generation++; 1466 43463 return 0; 1467 } 1468 1469 int 1470 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg) 1471 1079 { 1472 1079 PERL_UNUSED_ARG(sv); 1473 1079 PERL_UNUSED_ARG(mg); 1474 /* HV_badAMAGIC_on(Sv_STASH(sv)); */ 1475 1079 PL_amagic_generation++; 1476 1477 1079 return 0; 1478 } 1479 1480 int 1481 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) 1482 12 { 1483 12 HV * const hv = (HV*)LvTARG(sv); 1484 12 I32 i = 0; 1485 12 PERL_UNUSED_ARG(mg); 1486 1487 12 if (hv) { 1488 12 (void) hv_iterinit(hv); 1489 12 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) 1490 12 i = HvKEYS(hv); 1491 else { 1492 ###### while (hv_iternext(hv)) 1493 ###### i++; 1494 } 1495 } 1496 1497 12 sv_setiv(sv, (IV)i); 1498 12 return 0; 1499 } 1500 1501 int 1502 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 1503 4 { 1504 4 PERL_UNUSED_ARG(mg); 1505 4 if (LvTARG(sv)) { 1506 4 hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); 1507 } 1508 4 return 0; 1509 } 1510 1511 /* caller is responsible for stack switching/cleanup */ 1512 STATIC int 1513 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) 1514 120645 { 1515 120645 dSP; 1516 1517 120645 PUSHMARK(SP); 1518 120645 EXTEND(SP, n); 1519 120645 PUSHs(SvTIED_obj(sv, mg)); 1520 120645 if (n > 1) { 1521 120645 if (mg->mg_ptr) { 1522 117483 if (mg->mg_len >= 0) 1523 24 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); 1524 117459 else if (mg->mg_len == HEf_SVKEY) 1525 117459 PUSHs((SV*)mg->mg_ptr); 1526 } 1527 3162 else if (mg->mg_type == PERL_MAGIC_tiedelem) { 1528 2479 PUSHs(sv_2mortal(newSViv(mg->mg_len))); 1529 } 1530 } 1531 120645 if (n > 2) { 1532 2753 PUSHs(val); 1533 } 1534 120645 PUTBACK; 1535 1536 120645 return call_method(meth, flags); 1537 } 1538 1539 STATIC int 1540 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) 1541 117548 { 1542 117548 dVAR; dSP; 1543 1544 117548 ENTER; 1545 117548 SAVETMPS; 1546 117548 PUSHSTACKi(PERLSI_MAGIC); 1547 1548 117548 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { 1549 117535 sv_setsv(sv, *PL_stack_sp--); 1550 } 1551 1552 117535 POPSTACK; 1553 117535 FREETMPS; 1554 117535 LEAVE; 1555 117535 return 0; 1556 } 1557 1558 int 1559 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) 1560 117113 { 1561 117113 if (mg->mg_ptr) 1562 115216 mg->mg_flags |= MGf_GSKIP; 1563 117113 magic_methpack(sv,mg,"FETCH"); 1564 117103 return 0; 1565 } 1566 1567 int 1568 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) 1569 2753 { 1570 2753 dVAR; dSP; 1571 2753 ENTER; 1572 2753 PUSHSTACKi(PERLSI_MAGIC); 1573 2753 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); 1574 2741 POPSTACK; 1575 2741 LEAVE; 1576 2741 return 0; 1577 } 1578 1579 int 1580 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) 1581 94 { 1582 94 return magic_methpack(sv,mg,"DELETE"); 1583 } 1584 1585 1586 U32 1587 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) 1588 344 { 1589 344 dVAR; dSP; 1590 344 U32 retval = 0; 1591 1592 344 ENTER; 1593 344 SAVETMPS; 1594 344 PUSHSTACKi(PERLSI_MAGIC); 1595 344 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { 1596 344 sv = *PL_stack_sp--; 1597 344 retval = (U32) SvIV(sv)-1; 1598 } 1599 344 POPSTACK; 1600 344 FREETMPS; 1601 344 LEAVE; 1602 344 return retval; 1603 } 1604 1605 int 1606 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) 1607 133 { 1608 133 dVAR; dSP; 1609 1610 133 ENTER; 1611 133 PUSHSTACKi(PERLSI_MAGIC); 1612 133 PUSHMARK(SP); 1613 133 XPUSHs(SvTIED_obj(sv, mg)); 1614 133 PUTBACK; 1615 133 call_method("CLEAR", G_SCALAR|G_DISCARD); 1616 132 POPSTACK; 1617 132 LEAVE; 1618 1619 132 return 0; 1620 } 1621 1622 int 1623 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) 1624 107962 { 1625 107962 dVAR; dSP; 1626 107962 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; 1627 1628 107962 ENTER; 1629 107962 SAVETMPS; 1630 107962 PUSHSTACKi(PERLSI_MAGIC); 1631 107962 PUSHMARK(SP); 1632 107962 EXTEND(SP, 2); 1633 107962 PUSHs(SvTIED_obj(sv, mg)); 1634 107962 if (SvOK(key)) 1635 107098 PUSHs(key); 1636 107962 PUTBACK; 1637 1638 107962 if (call_method(meth, G_SCALAR)) 1639 107962 sv_setsv(key, *PL_stack_sp--); 1640 1641 107962 POPSTACK; 1642 107962 FREETMPS; 1643 107962 LEAVE; 1644 107962 return 0; 1645 } 1646 1647 int 1648 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) 1649 341 { 1650 341 return magic_methpack(sv,mg,"EXISTS"); 1651 } 1652 1653 SV * 1654 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) 1655 7 { 1656 7 dVAR; dSP; 1657 7 SV *retval = &PL_sv_undef; 1658 7 SV * const tied = SvTIED_obj((SV*)hv, mg); 1659 7 HV * const pkg = SvSTASH((SV*)SvRV(tied)); 1660 1661 7 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { 1662 5 SV *key; 1663 5 if (HvEITER_get(hv)) 1664 /* we are in an iteration so the hash cannot be empty */ 1665 1 return &PL_sv_yes; 1666 /* no xhv_eiter so now use FIRSTKEY */ 1667 4 key = sv_newmortal(); 1668 4 magic_nextpack((SV*)hv, mg, key); 1669 4 HvEITER_set(hv, NULL); /* need to reset iterator */ 1670 4 return SvOK(key) ? &PL_sv_yes : &PL_sv_no; 1671 } 1672 1673 /* there is a SCALAR method that we can call */ 1674 2 ENTER; 1675 2 PUSHSTACKi(PERLSI_MAGIC); 1676 2 PUSHMARK(SP); 1677 2 EXTEND(SP, 1); 1678 2 PUSHs(tied); 1679 2 PUTBACK; 1680 1681 2 if (call_method("SCALAR", G_SCALAR)) 1682 2 retval = *PL_stack_sp--; 1683 2 POPSTACK; 1684 2 LEAVE; 1685 2 return retval; 1686 } 1687 1688 int 1689 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) 1690 ###### { 1691 ###### GV * const gv = PL_DBline; 1692 ###### const I32 i = SvTRUE(sv); 1693 ###### SV ** const svp = av_fetch(GvAV(gv), 1694 ###### atoi(MgPV_nolen_const(mg)), FALSE); 1695 ###### if (svp && SvIOKp(*svp)) { 1696 ###### OP * const o = INT2PTR(OP*,SvIVX(*svp)); 1697 ###### if (o) { 1698 /* set or clear breakpoint in the relevant control op */ 1699 ###### if (i) 1700 ###### o->op_flags |= OPf_SPECIAL; 1701 else 1702 ###### o->op_flags &= ~OPf_SPECIAL; 1703 } 1704 } 1705 ###### return 0; 1706 } 1707 1708 int 1709 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) 1710 387095 { 1711 387095 const AV * const obj = (AV*)mg->mg_obj; 1712 387095 if (obj) { 1713 387089 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase); 1714 } else { 1715 6 SvOK_off(sv); 1716 } 1717 387095 return 0; 1718 } 1719 1720 int 1721 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) 1722 430 { 1723 430 AV * const obj = (AV*)mg->mg_obj; 1724 430 if (obj) { 1725 422 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase); 1726 } else { 1727 8 if (ckWARN(WARN_MISC)) 1728 4 Perl_warner(aTHX_ packWARN(WARN_MISC), 1729 "Attempt to set length of freed array"); 1730 } 1731 429 return 0; 1732 } 1733 1734 int 1735 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) 1736 18296 { 1737 18296 PERL_UNUSED_ARG(sv); 1738 /* during global destruction, mg_obj may already have been freed */ 1739 18296 if (PL_in_clean_all) 1740 1355 return 0; 1741 1742 16941 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); 1743 1744 16941 if (mg) { 1745 /* arylen scalar holds a pointer back to the array, but doesn't own a 1746 reference. Hence the we (the array) are about to go away with it 1747 still pointing at us. Clear its pointer, else it would be pointing 1748 at free memory. See the comment in sv_magic about reference loops, 1749 and why it can't own a reference to us. */ 1750 14928 mg->mg_obj = 0; 1751 } 1752 16941 return 0; 1753 } 1754 1755 int 1756 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 1757 48138 { 1758 48138 SV* const lsv = LvTARG(sv); 1759 1760 48138 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { 1761 48134 mg = mg_find(lsv, PERL_MAGIC_regex_global); 1762 48134 if (mg && mg->mg_len >= 0) { 1763 48108 I32 i = mg->mg_len; 1764 48108 if (DO_UTF8(lsv)) 1765 ###### sv_pos_b2u(lsv, &i); 1766 48108 sv_setiv(sv, i + PL_curcop->cop_arybase); 1767 48108 return 0; 1768 } 1769 } 1770 30 SvOK_off(sv); 1771 30 return 0; 1772 } 1773 1774 int 1775 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 1776 178420 { 1777 178420 SV* const lsv = LvTARG(sv); 1778 178420 SSize_t pos; 1779 178420 STRLEN len; 1780 178420 STRLEN ulen = 0; 1781 1782 178420 mg = 0; 1783 1784 178420 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) 1785 139963 mg = mg_find(lsv, PERL_MAGIC_regex_global); 1786 178420 if (!mg) { 1787 38464 if (!SvOK(sv)) 1788 151 return 0; 1789 38313 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); 1790 38313 mg = mg_find(lsv, PERL_MAGIC_regex_global); 1791 } 1792 139956 else if (!SvOK(sv)) { 1793 25 mg->mg_len = -1; 1794 25 return 0; 1795 } 1796 178244 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); 1797 1798 178244 pos = SvIV(sv) - PL_curcop->cop_arybase; 1799 1800 178244 if (DO_UTF8(lsv)) { 1801 41 ulen = sv_len_utf8(lsv); 1802 41 if (ulen) 1803 41 len = ulen; 1804 } 1805 1806 178244 if (pos < 0) { 1807 ###### pos += len; 1808 ###### if (pos < 0) 1809 ###### pos = 0; 1810 } 1811 178244 else if (pos > (SSize_t)len) 1812 1 pos = len; 1813 1814 178244 if (ulen) { 1815 41 I32 p = pos; 1816 41 sv_pos_u2b(lsv, &p, 0); 1817 41 pos = p; 1818 } 1819 1820 178244 mg->mg_len = pos; 1821 178244 mg->mg_flags &= ~MGf_MINMATCH; 1822 1823 178244 return 0; 1824 } 1825 1826 int 1827 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg) 1828 442 { 1829 442 PERL_UNUSED_ARG(mg); 1830 442 if (SvFAKE(sv)) { /* FAKE globs can get coerced */ 1831 390 SvFAKE_off(sv); 1832 390 gv_efullname3(sv,((GV*)sv), "*"); 1833 390 SvFAKE_on(sv); 1834 } 1835 else 1836 52 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */ 1837 442 return 0; 1838 } 1839 1840 int 1841 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg) 1842 132136 { 1843 132136 GV* gv; 1844 132136 PERL_UNUSED_ARG(mg); 1845 1846 132136 if (!SvOK(sv)) 1847 132117 return 0; 1848 19 gv = gv_fetchsv(sv,TRUE, SVt_PVGV); 1849 19 if (sv == (SV*)gv) 1850 ###### return 0; 1851 19 if (GvGP(sv)) 1852 19 gp_free((GV*)sv); 1853 19 GvGP(sv) = gp_ref(GvGP(gv)); 1854 19 return 0; 1855 } 1856 1857 int 1858 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) 1859 6068 { 1860 6068 STRLEN len; 1861 6068 SV * const lsv = LvTARG(sv); 1862 6068 const char * const tmps = SvPV_const(lsv,len); 1863 6068 I32 offs = LvTARGOFF(sv); 1864 6068 I32 rem = LvTARGLEN(sv); 1865 6068 PERL_UNUSED_ARG(mg); 1866 1867 6068 if (SvUTF8(lsv)) 1868 3314 sv_pos_u2b(lsv, &offs, &rem); 1869 6068 if (offs > (I32)len) 1870 ###### offs = len; 1871 6068 if (rem + offs > (I32)len) 1872 ###### rem = len - offs; 1873 6068 sv_setpvn(sv, tmps + offs, (STRLEN)rem); 1874 6068 if (SvUTF8(lsv)) 1875 3314 SvUTF8_on(sv); 1876 6068 return 0; 1877 } 1878 1879 int 1880 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) 1881 16797 { 1882 16797 STRLEN len; 1883 16797 const char *tmps = SvPV_const(sv, len); 1884 16797 SV * const lsv = LvTARG(sv); 1885 16797 I32 lvoff = LvTARGOFF(sv); 1886 16797 I32 lvlen = LvTARGLEN(sv); 1887 16797 PERL_UNUSED_ARG(mg); 1888 1889 16797 if (DO_UTF8(sv)) { 1890 293 sv_utf8_upgrade(lsv); 1891 293 sv_pos_u2b(lsv, &lvoff, &lvlen); 1892 293 sv_insert(lsv, lvoff, lvlen, tmps, len); 1893 293 LvTARGLEN(sv) = sv_len_utf8(sv); 1894 293 SvUTF8_on(lsv); 1895 } 1896 16504 else if (lsv && SvUTF8(lsv)) { 1897 883 sv_pos_u2b(lsv, &lvoff, &lvlen); 1898 883 LvTARGLEN(sv) = len; 1899 883 tmps = (char*)bytes_to_utf8((U8*)tmps, &len); 1900 883 sv_insert(lsv, lvoff, lvlen, tmps, len); 1901 883 Safefree(tmps); 1902 } 1903 else { 1904 15621 sv_insert(lsv, lvoff, lvlen, tmps, len); 1905 15621 LvTARGLEN(sv) = len; 1906 } 1907 1908 1909 16797 return 0; 1910 } 1911 1912 int 1913 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) 1914 5456972 { 1915 5456972 PERL_UNUSED_ARG(sv); 1916 5456972 TAINT_IF(mg->mg_len & 1); 1917 5456972 return 0; 1918 } 1919 1920 int 1921 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) 1922 2733505 { 1923 2733505 PERL_UNUSED_ARG(sv); 1924 2733505 if (PL_tainted) 1925 2713706 mg->mg_len |= 1; 1926 else 1927 19799 mg->mg_len &= ~1; 1928 2733505 return 0; 1929 } 1930 1931 int 1932 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) 1933 2591 { 1934 2591 SV * const lsv = LvTARG(sv); 1935 2591 PERL_UNUSED_ARG(mg); 1936 1937 2591 if (!lsv) { 1938 ###### SvOK_off(sv); 1939 ###### return 0; 1940 } 1941 1942 2591 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); 1943 2591 return 0; 1944 } 1945 1946 int 1947 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) 1948 1937936 { 1949 1937936 PERL_UNUSED_ARG(mg); 1950 1937936 do_vecset(sv); /* XXX slurp this routine */ 1951 1937935 return 0; 1952 } 1953 1954 int 1955 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 1956 2261 { 1957 2261 SV *targ = Nullsv; 1958 2261 if (LvTARGLEN(sv)) { 1959 2261 if (mg->mg_obj) { 1960 2245 SV * const ahv = LvTARG(sv); 1961 2245 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); 1962 2245 if (he) 1963 ###### targ = HeVAL(he); 1964 } 1965 else { 1966 16 AV* const av = (AV*)LvTARG(sv); 1967 16 if ((I32)LvTARGOFF(sv) <= AvFILL(av)) 1968 11 targ = AvARRAY(av)[LvTARGOFF(sv)]; 1969 } 1970 2261 if (targ && targ != &PL_sv_undef) { 1971 /* somebody else defined it for us */ 1972 ###### SvREFCNT_dec(LvTARG(sv)); 1973 ###### LvTARG(sv) = SvREFCNT_inc(targ); 1974 ###### LvTARGLEN(sv) = 0; 1975 ###### SvREFCNT_dec(mg->mg_obj); 1976 ###### mg->mg_obj = Nullsv; 1977 ###### mg->mg_flags &= ~MGf_REFCOUNTED; 1978 } 1979 } 1980 else 1981 ###### targ = LvTARG(sv); 1982 2261 sv_setsv(sv, targ ? targ : &PL_sv_undef); 1983 2261 return 0; 1984 } 1985 1986 int 1987 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) 1988 4 { 1989 4 PERL_UNUSED_ARG(mg); 1990 4 if (LvTARGLEN(sv)) 1991 4 vivify_defelem(sv); 1992 4 if (LvTARG(sv)) { 1993 4 sv_setsv(LvTARG(sv), sv); 1994 4 SvSETMAGIC(LvTARG(sv)); 1995 } 1996 4 return 0; 1997 } 1998 1999 void 2000 Perl_vivify_defelem(pTHX_ SV *sv) 2001 7 { 2002 7 MAGIC *mg; 2003 7 SV *value = Nullsv; 2004 2005 7 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) 2006 ###### return; 2007 7 if (mg->mg_obj) { 2008 1 SV * const ahv = LvTARG(sv); 2009 1 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); 2010 1 if (he) 2011 1 value = HeVAL(he); 2012 1 if (!value || value == &PL_sv_undef) 2013 ###### Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj); 2014 } 2015 else { 2016 6 AV* const av = (AV*)LvTARG(sv); 2017 6 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av)) 2018 ###### LvTARG(sv) = Nullsv; /* array can't be extended */ 2019 else { 2020 6 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE); 2021 6 if (!svp || (value = *svp) == &PL_sv_undef) 2022 ###### Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv)); 2023 } 2024 } 2025 7 (void)SvREFCNT_inc(value); 2026 7 SvREFCNT_dec(LvTARG(sv)); 2027 7 LvTARG(sv) = value; 2028 7 LvTARGLEN(sv) = 0; 2029 7 SvREFCNT_dec(mg->mg_obj); 2030 7 mg->mg_obj = Nullsv; 2031 7 mg->mg_flags &= ~MGf_REFCOUNTED; 2032 } 2033 2034 int 2035 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) 2036 123580 { 2037 123580 AV *const av = (AV*)mg->mg_obj; 2038 123580 SV **svp = AvARRAY(av); 2039 123580 PERL_UNUSED_ARG(sv); 2040 2041 123580 if (svp) { 2042 123580 SV *const *const last = svp + AvFILLp(av); 2043 2044 613480 while (svp <= last) { 2045 489900 if (*svp) { 2046 489900 SV *const referrer = *svp; 2047 489900 if (SvWEAKREF(referrer)) { 2048 /* XXX Should we check that it hasn't changed? */ 2049 19 SvRV_set(referrer, 0); 2050 19 SvOK_off(referrer); 2051 19 SvWEAKREF_off(referrer); 2052 489881 } else if (SvTYPE(referrer) == SVt_PVGV || 2053 SvTYPE(referrer) == SVt_PVLV) { 2054 /* You lookin' at me? */ 2055 489881 assert(GvSTASH(referrer)); 2056 489881 assert(GvSTASH(referrer) == (HV*)sv); 2057 489881 GvSTASH(referrer) = 0; 2058 } else { 2059 ###### Perl_croak(aTHX_ 2060 "panic: magic_killbackrefs (flags=%"UVxf")", 2061 SvFLAGS(referrer)); 2062 } 2063 2064 489900 *svp = Nullsv; 2065 } 2066 489900 svp++; 2067 } 2068 } 2069 123580 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ 2070 123580 return 0; 2071 } 2072 2073 int 2074 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) 2075 340158 { 2076 340158 mg->mg_len = -1; 2077 340158 SvSCREAM_off(sv); 2078 340158 return 0; 2079 } 2080 2081 int 2082 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg) 2083 ###### { 2084 ###### PERL_UNUSED_ARG(mg); 2085 ###### sv_unmagic(sv, PERL_MAGIC_bm); 2086 ###### SvVALID_off(sv); 2087 ###### return 0; 2088 } 2089 2090 int 2091 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg) 2092 ###### { 2093 ###### PERL_UNUSED_ARG(mg); 2094 ###### sv_unmagic(sv, PERL_MAGIC_fm); 2095 ###### SvCOMPILED_off(sv); 2096 ###### return 0; 2097 } 2098 2099 int 2100 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) 2101 ###### { 2102 ###### const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 2103 2104 ###### if (uf && uf->uf_set) 2105 ###### (*uf->uf_set)(aTHX_ uf->uf_index, sv); 2106 ###### return 0; 2107 } 2108 2109 int 2110 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) 2111 6 { 2112 6 PERL_UNUSED_ARG(mg); 2113 6 sv_unmagic(sv, PERL_MAGIC_qr); 2114 6 return 0; 2115 } 2116 2117 int 2118 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg) 2119 31490 { 2120 31490 regexp * const re = (regexp *)mg->mg_obj; 2121 31490 PERL_UNUSED_ARG(sv); 2122 2123 31490 ReREFCNT_dec(re); 2124 31490 return 0; 2125 } 2126 2127 #ifdef USE_LOCALE_COLLATE 2128 int 2129 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) 2130 5011 { 2131 /* 2132 * RenE Descartes said "I think not." 2133 * and vanished with a faint plop. 2134 */ 2135 5011 PERL_UNUSED_ARG(sv); 2136 5011 if (mg->mg_ptr) { 2137 4513 Safefree(mg->mg_ptr); 2138 4513 mg->mg_ptr = NULL; 2139 4513 mg->mg_len = -1; 2140 } 2141 5011 return 0; 2142 } 2143 #endif /* USE_LOCALE_COLLATE */ 2144 2145 /* Just clear the UTF-8 cache data. */ 2146 int 2147 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) 2148 81255 { 2149 81255 PERL_UNUSED_ARG(sv); 2150 81255 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ 2151 81255 mg->mg_ptr = 0; 2152 81255 mg->mg_len = -1; /* The mg_len holds the len cache. */ 2153 81255 return 0; 2154 } 2155 2156 int 2157 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 2158 526064 { 2159 526064 register const char *s; 2160 526064 I32 i; 2161 526064 STRLEN len; 2162 526064 switch (*mg->mg_ptr) { 2163 case '\001': /* ^A */ 2164 114 sv_setsv(PL_bodytarget, sv); 2165 114 break; 2166 case '\003': /* ^C */ 2167 313 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2168 313 break; 2169 2170 case '\004': /* ^D */ 2171 #ifdef DEBUGGING 2172 ###### s = SvPV_nolen_const(sv); 2173 ###### PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; 2174 ###### DEBUG_x(dump_all()); 2175 #else 2176 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; 2177 #endif 2178 ###### break; 2179 case '\005': /* ^E */ 2180 316 if (*(mg->mg_ptr+1) == '\0') { 2181 #ifdef MACOS_TRADITIONAL 2182 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2183 #else 2184 # ifdef VMS 2185 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2186 # else 2187 # ifdef WIN32 2188 SetLastError( SvIV(sv) ); 2189 # else 2190 # ifdef OS2 2191 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2192 # else 2193 /* will anyone ever use this? */ 2194 2 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); 2195 # endif 2196 # endif 2197 # endif 2198 #endif 2199 } 2200 314 else if (strEQ(mg->mg_ptr+1, "NCODING")) { 2201 314 if (PL_encoding) 2202 104 SvREFCNT_dec(PL_encoding); 2203 314 if (SvOK(sv) || SvGMAGICAL(sv)) { 2204 117 PL_encoding = newSVsv(sv); 2205 } 2206 else { 2207 197 PL_encoding = Nullsv; 2208 } 2209 } 2210 197 break; 2211 case '\006': /* ^F */ 2212 72 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2213 72 break; 2214 case '\010': /* ^H */ 2215 27394 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2216 27394 break; 2217 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 2218 17 Safefree(PL_inplace); 2219 17 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch; 2220 case '\017': /* ^O */ 2221 30 if (*(mg->mg_ptr+1) == '\0') { 2222 18 Safefree(PL_osname); 2223 18 PL_osname = Nullch; 2224 18 if (SvOK(sv)) { 2225 8 TAINT_PROPER("assigning to $^O"); 2226 7 PL_osname = savesvpv(sv); 2227 } 2228 } 2229 12 else if (strEQ(mg->mg_ptr, "\017PEN")) { 2230 12 if (!PL_compiling.cop_io) 2231 10 PL_compiling.cop_io = newSVsv(sv); 2232 else 2233 2 sv_setsv(PL_compiling.cop_io,sv); 2234 } 2235 2 break; 2236 case '\020': /* ^P */ 2237 6 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2238 6 if (PL_perldb && !PL_DBsingle) 2239 1 init_debugger(); 2240 1 break; 2241 case '\024': /* ^T */ 2242 #ifdef BIG_TIME 2243 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); 2244 #else 2245 ###### PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2246 #endif 2247 ###### break; 2248 case '\027': /* ^W & $^WARNING_BITS */ 2249 69000 if (*(mg->mg_ptr+1) == '\0') { 2250 64017 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 2251 64001 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2252 64001 PL_dowarn = (PL_dowarn & ~G_WARN_ON) 2253 | (i ? G_WARN_ON : G_WARN_OFF) ; 2254 } 2255 } 2256 4983 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 2257 4983 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 2258 4917 if (!SvPOK(sv) && PL_localizing) { 2259 ###### sv_setpvn(sv, WARN_NONEstring, WARNsize); 2260 ###### PL_compiling.cop_warnings = pWARN_NONE; 2261 ###### break; 2262 } 2263 { 2264 4917 STRLEN len, i; 2265 4917 int accumulate = 0 ; 2266 4917 int any_fatals = 0 ; 2267 4917 const char * const ptr = SvPV_const(sv, len) ; 2268 64377 for (i = 0 ; i < len ; ++i) { 2269 59460 accumulate |= ptr[i] ; 2270 59460 any_fatals |= (ptr[i] & 0xAA) ; 2271 } 2272 4917 if (!accumulate) 2273 1102 PL_compiling.cop_warnings = pWARN_NONE; 2274 3815 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) { 2275 3060 PL_compiling.cop_warnings = pWARN_ALL; 2276 3060 PL_dowarn |= G_WARN_ONCE ; 2277 } 2278 else { 2279 755 if (specialWARN(PL_compiling.cop_warnings)) 2280 726 PL_compiling.cop_warnings = newSVsv(sv) ; 2281 else 2282 29 sv_setsv(PL_compiling.cop_warnings, sv); 2283 755 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) 2284 235 PL_dowarn |= G_WARN_ONCE ; 2285 } 2286 2287 } 2288 } 2289 } 2290 235 break; 2291 case '.': 2292 1192 if (PL_localizing) { 2293 804 if (PL_localizing == 1) 2294 402 SAVESPTR(PL_last_in_gv); 2295 } 2296 388 else if (SvOK(sv) && GvIO(PL_last_in_gv)) 2297 386 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); 2298 386 break; 2299 case '^': 2300 22 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); 2301 22 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 2302 22 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO); 2303 22 break; 2304 case '~': 2305 38 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); 2306 38 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 2307 38 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO); 2308 38 break; 2309 case '=': 2310 4 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2311 4 break; 2312 case '-': 2313 2 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2314 2 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) 2315 ###### IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; 2316 ###### break; 2317 case '%': 2318 ###### IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2319 ###### break; 2320 case '|': 2321 { 2322 4990 IO * const io = GvIOp(PL_defoutgv); 2323 4990 if(!io) 2324 ###### break; 2325 4990 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0) 2326 86 IoFLAGS(io) &= ~IOf_FLUSH; 2327 else { 2328 4904 if (!(IoFLAGS(io) & IOf_FLUSH)) { 2329 4668 PerlIO *ofp = IoOFP(io); 2330 4668 if (ofp) 2331 4610 (void)PerlIO_flush(ofp); 2332 4668 IoFLAGS(io) |= IOf_FLUSH; 2333 } 2334 } 2335 } 2336 4668 break; 2337 case '/': 2338 16048 SvREFCNT_dec(PL_rs); 2339 16048 PL_rs = newSVsv(sv); 2340 16048 break; 2341 case '\\': 2342 151591 if (PL_ors_sv) 2343 15394 SvREFCNT_dec(PL_ors_sv); 2344 151591 if (SvOK(sv) || SvGMAGICAL(sv)) { 2345 15403 PL_ors_sv = newSVsv(sv); 2346 } 2347 else { 2348 136188 PL_ors_sv = Nullsv; 2349 } 2350 136188 break; 2351 case ',': 2352 105831 if (PL_ofs_sv) 2353 15486 SvREFCNT_dec(PL_ofs_sv); 2354 105831 if (SvOK(sv) || SvGMAGICAL(sv)) { 2355 15490 PL_ofs_sv = newSVsv(sv); 2356 } 2357 else { 2358 90341 PL_ofs_sv = Nullsv; 2359 } 2360 90341 break; 2361 case '[': 2362 ###### PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2363 ###### break; 2364 case '?': 2365 #ifdef COMPLEX_STATUS 2366 if (PL_localizing == 2) { 2367 PL_statusvalue = LvTARGOFF(sv); 2368 PL_statusvalue_vms = LvTARGLEN(sv); 2369 } 2370 else 2371 #endif 2372 #ifdef VMSISH_STATUS 2373 if (VMSISH_STATUS) 2374 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))); 2375 else 2376 #endif 2377 327 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2378 327 break; 2379 case '!': 2380 { 2381 #ifdef VMS 2382 # define PERL_VMS_BANG vaxc$errno 2383 #else 2384 # define PERL_VMS_BANG 0 2385 #endif 2386 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, 2387 83452 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); 2388 } 2389 83452 break; 2390 case '<': 2391 ###### PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2392 ###### if (PL_delaymagic) { 2393 ###### PL_delaymagic |= DM_RUID; 2394 ###### break; /* don't do magic till later */ 2395 } 2396 #ifdef HAS_SETRUID 2397 (void)setruid((Uid_t)PL_uid); 2398 #else 2399 #ifdef HAS_SETREUID 2400 ###### (void)setreuid((Uid_t)PL_uid, (Uid_t)-1); 2401 #else 2402 #ifdef HAS_SETRESUID 2403 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); 2404 #else 2405 if (PL_uid == PL_euid) { /* special case $< = $> */ 2406 #ifdef PERL_DARWIN 2407 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ 2408 if (PL_uid != 0 && PerlProc_getuid() == 0) 2409 (void)PerlProc_setuid(0); 2410 #endif 2411 (void)PerlProc_setuid(PL_uid); 2412 } else { 2413 PL_uid = PerlProc_getuid(); 2414 Perl_croak(aTHX_ "setruid() not implemented"); 2415 } 2416 #endif 2417 #endif 2418 #endif 2419 ###### PL_uid = PerlProc_getuid(); 2420 ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 2421 ###### break; 2422 case '>': 2423 4 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2424 4 if (PL_delaymagic) { 2425 ###### PL_delaymagic |= DM_EUID; 2426 ###### break; /* don't do magic till later */ 2427 } 2428 #ifdef HAS_SETEUID 2429 4 (void)seteuid((Uid_t)PL_euid); 2430 #else 2431 #ifdef HAS_SETREUID 2432 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid); 2433 #else 2434 #ifdef HAS_SETRESUID 2435 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1); 2436 #else 2437 if (PL_euid == PL_uid) /* special case $> = $< */ 2438 PerlProc_setuid(PL_euid); 2439 else { 2440 PL_euid = PerlProc_geteuid(); 2441 Perl_croak(aTHX_ "seteuid() not implemented"); 2442 } 2443 #endif 2444 #endif 2445 #endif 2446 4 PL_euid = PerlProc_geteuid(); 2447 4 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 2448 4 break; 2449 case '(': 2450 ###### PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2451 ###### if (PL_delaymagic) { 2452 ###### PL_delaymagic |= DM_RGID; 2453 ###### break; /* don't do magic till later */ 2454 } 2455 #ifdef HAS_SETRGID 2456 (void)setrgid((Gid_t)PL_gid); 2457 #else 2458 #ifdef HAS_SETREGID 2459 ###### (void)setregid((Gid_t)PL_gid, (Gid_t)-1); 2460 #else 2461 #ifdef HAS_SETRESGID 2462 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1); 2463 #else 2464 if (PL_gid == PL_egid) /* special case $( = $) */ 2465 (void)PerlProc_setgid(PL_gid); 2466 else { 2467 PL_gid = PerlProc_getgid(); 2468 Perl_croak(aTHX_ "setrgid() not implemented"); 2469 } 2470 #endif 2471 #endif 2472 #endif 2473 ###### PL_gid = PerlProc_getgid(); 2474 ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 2475 ###### break; 2476 case ')': 2477 #ifdef HAS_SETGROUPS 2478 { 2479 ###### const char *p = SvPV_const(sv, len); 2480 ###### Groups_t gary[NGROUPS]; 2481 2482 ###### while (isSPACE(*p)) 2483 ###### ++p; 2484 ###### PL_egid = Atol(p); 2485 ###### for (i = 0; i < NGROUPS; ++i) { 2486 ###### while (*p && !isSPACE(*p)) 2487 ###### ++p; 2488 ###### while (isSPACE(*p)) 2489 ###### ++p; 2490 ###### if (!*p) 2491 ###### break; 2492 ###### gary[i] = Atol(p); 2493 } 2494 ###### if (i) 2495 ###### (void)setgroups(i, gary); 2496 } 2497 #else /* HAS_SETGROUPS */ 2498 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 2499 #endif /* HAS_SETGROUPS */ 2500 ###### if (PL_delaymagic) { 2501 ###### PL_delaymagic |= DM_EGID; 2502 ###### break; /* don't do magic till later */ 2503 } 2504 #ifdef HAS_SETEGID 2505 ###### (void)setegid((Gid_t)PL_egid); 2506 #else 2507 #ifdef HAS_SETREGID 2508 (void)setregid((Gid_t)-1, (Gid_t)PL_egid); 2509 #else 2510 #ifdef HAS_SETRESGID 2511 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1); 2512 #else 2513 if (PL_egid == PL_gid) /* special case $) = $( */ 2514 (void)PerlProc_setgid(PL_egid); 2515 else { 2516 PL_egid = PerlProc_getegid(); 2517 Perl_croak(aTHX_ "setegid() not implemented"); 2518 } 2519 #endif 2520 #endif 2521 #endif 2522 ###### PL_egid = PerlProc_getegid(); 2523 ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 2524 ###### break; 2525 case ':': 2526 30 PL_chopset = SvPV_force(sv,len); 2527 30 break; 2528 #ifndef MACOS_TRADITIONAL 2529 case '0': 2530 LOCK_DOLLARZERO_MUTEX; 2531 #ifdef HAS_SETPROCTITLE 2532 /* The BSDs don't show the argv[] in ps(1) output, they 2533 * show a string from the process struct and provide 2534 * the setproctitle() routine to manipulate that. */ 2535 { 2536 s = SvPV_const(sv, len); 2537 # if __FreeBSD_version > 410001 2538 /* The leading "-" removes the "perl: " prefix, 2539 * but not the "(perl) suffix from the ps(1) 2540 * output, because that's what ps(1) shows if the 2541 * argv[] is modified. */ 2542 setproctitle("-%s", s); 2543 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ 2544 /* This doesn't really work if you assume that 2545 * $0 = 'foobar'; will wipe out 'perl' from the $0 2546 * because in ps(1) output the result will be like 2547 * sprintf("perl: %s (perl)", s) 2548 * I guess this is a security feature: 2549 * one (a user process) cannot get rid of the original name. 2550 * --jhi */ 2551 setproctitle("%s", s); 2552 # endif 2553 } 2554 #endif 2555 #if defined(__hpux) && defined(PSTAT_SETCMD) 2556 { 2557 union pstun un; 2558 s = SvPV_const(sv, len); 2559 un.pst_command = (char *)s; 2560 pstat(PSTAT_SETCMD, un, len, 0, 0); 2561 } 2562 #endif 2563 /* PL_origalen is set in perl_parse(). */ 2564 89 s = SvPV_force(sv,len); 2565 89 if (len >= (STRLEN)PL_origalen-1) { 2566 /* Longer than original, will be truncated. We assume that 2567 * PL_origalen bytes are available. */ 2568 ###### Copy(s, PL_origargv[0], PL_origalen-1, char); 2569 } 2570 else { 2571 /* Shorter than original, will be padded. */ 2572 89 Copy(s, PL_origargv[0], len, char); 2573 89 PL_origargv[0][len] = 0; 2574 89 memset(PL_origargv[0] + len + 1, 2575 /* Is the space counterintuitive? Yes. 2576 * (You were expecting \0?) 2577 * Does it work? Seems to. (In Linux 2.4.20 at least.) 2578 * --jhi */ 2579 (int)' ', 2580 PL_origalen - len - 1); 2581 } 2582 89 PL_origargv[0][PL_origalen-1] = 0; 2583 432 for (i = 1; i < PL_origargc; i++) 2584 343 PL_origargv[i] = 0; 2585 UNLOCK_DOLLARZERO_MUTEX; 2586 526063 break; 2587 #endif 2588 } 2589 526063 return 0; 2590 } 2591 2592 I32 2593 Perl_whichsig(pTHX_ const char *sig) 2594 23590 { 2595 23590 register char* const* sigv; 2596 2597 1538226 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) 2598 1516666 if (strEQ(sig,*sigv)) 2599 2030 return PL_sig_num[sigv - (char* const*)PL_sig_name]; 2600 #ifdef SIGCLD 2601 21560 if (strEQ(sig,"CHLD")) 2602 ###### return SIGCLD; 2603 #endif 2604 #ifdef SIGCHLD 2605 21560 if (strEQ(sig,"CLD")) 2606 ###### return SIGCHLD; 2607 #endif 2608 21560 return -1; 2609 } 2610 2611 Signal_t 2612 Perl_sighandler(int sig) 2613 27 { 2614 #ifdef PERL_GET_SIG_CONTEXT 2615 dTHXa(PERL_GET_SIG_CONTEXT); 2616 #else 2617 dTHX; 2618 #endif 2619 27 dSP; 2620 27 GV *gv = Nullgv; 2621 27 SV *sv = Nullsv; 2622 27 SV * const tSv = PL_Sv; 2623 27 CV *cv = Nullcv; 2624 27 OP *myop = PL_op; 2625 27 U32 flags = 0; 2626 27 XPV * const tXpv = PL_Xpv; 2627 2628 27 if (PL_savestack_ix + 15 <= PL_savestack_max) 2629 27 flags |= 1; 2630 27 if (PL_markstack_ptr < PL_markstack_max - 2) 2631 27 flags |= 4; 2632 27 if (PL_scopestack_ix < PL_scopestack_max - 3) 2633 27 flags |= 16; 2634 2635 27 if (!PL_psig_ptr[sig]) { 2636 ###### PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", 2637 PL_sig_name[sig]); 2638 ###### exit(sig); 2639 } 2640 2641 /* Max number of items pushed there is 3*n or 4. We cannot fix 2642 infinity, so we fix 4 (in fact 5): */ 2643 27 if (flags & 1) { 2644 27 PL_savestack_ix += 5; /* Protect save in progress. */ 2645 27 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags); 2646 } 2647 27 if (flags & 4) 2648 27 PL_markstack_ptr++; /* Protect mark. */ 2649 27 if (flags & 16) 2650 27 PL_scopestack_ix += 1; 2651 /* sv_2cv is too complicated, try a simpler variant first: */ 2652 27 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) 2653 || SvTYPE(cv) != SVt_PVCV) { 2654 9 HV *st; 2655 9 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); 2656 } 2657 2658 27 if (!cv || !CvROOT(cv)) { 2659 2 if (ckWARN(WARN_SIGNAL)) 2660 1 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", 2661 PL_sig_name[sig], (gv ? GvENAME(gv) 2662 : ((cv && CvGV(cv)) 2663 ? GvENAME(CvGV(cv)) 2664 : "__ANON__"))); 2665 1 goto cleanup; 2666 } 2667 2668 25 if(PL_psig_name[sig]) { 2669 25 sv = SvREFCNT_inc(PL_psig_name[sig]); 2670 25 flags |= 64; 2671 #if !defined(PERL_IMPLICIT_CONTEXT) 2672 25 PL_sig_sv = sv; 2673 #endif 2674 } else { 2675 ###### sv = sv_newmortal(); 2676 ###### sv_setpv(sv,PL_sig_name[sig]); 2677 } 2678 2679 25 PUSHSTACKi(PERLSI_SIGNAL); 2680 25 PUSHMARK(SP); 2681 25 PUSHs(sv); 2682 25 PUTBACK; 2683 2684 25 call_sv((SV*)cv, G_DISCARD|G_EVAL); 2685 2686 24 POPSTACK; 2687 24 if (SvTRUE(ERRSV)) { 2688 #ifndef PERL_MICRO 2689 #ifdef HAS_SIGPROCMASK 2690 /* Handler "died", for example to get out of a restart-able read(). 2691 * Before we re-do that on its behalf re-enable the signal which was 2692 * blocked by the system when we entered. 2693 */ 2694 4 sigset_t set; 2695 4 sigemptyset(&set); 2696 4 sigaddset(&set,sig); 2697 4 sigprocmask(SIG_UNBLOCK, &set, NULL); 2698 #else 2699 /* Not clear if this will work */ 2700 (void)rsignal(sig, SIG_IGN); 2701 (void)rsignal(sig, PL_csighandlerp); 2702 #endif 2703 #endif /* !PERL_MICRO */ 2704 4 DieNull; 2705 } 2706 cleanup: 2707 22 if (flags & 1) 2708 22 PL_savestack_ix -= 8; /* Unprotect save in progress. */ 2709 22 if (flags & 4) 2710 22 PL_markstack_ptr--; 2711 22 if (flags & 16) 2712 22 PL_scopestack_ix -= 1; 2713 22 if (flags & 64) 2714 20 SvREFCNT_dec(sv); 2715 22 PL_op = myop; /* Apparently not needed... */ 2716 2717 22 PL_Sv = tSv; /* Restore global temporaries. */ 2718 22 PL_Xpv = tXpv; 2719 return; 2720 } 2721 2722 2723 static void 2724 S_restore_magic(pTHX_ const void *p) 2725 17620547 { 2726 17620547 MGS* const mgs = SSPTR(PTR2IV(p), MGS*); 2727 17620547 SV* const sv = mgs->mgs_sv; 2728 2729 17620547 if (!sv) 2730 402 return; 2731 2732 17620145 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) 2733 { 2734 #ifdef PERL_OLD_COPY_ON_WRITE 2735 /* While magic was saved (and off) sv_setsv may well have seen 2736 this SV as a prime candidate for COW. */ 2737 if (SvIsCOW(sv)) 2738 sv_force_normal(sv); 2739 #endif 2740 2741 16878804 if (mgs->mgs_flags) 2742 16763550 SvFLAGS(sv) |= mgs->mgs_flags; 2743 else 2744 115254 mg_magical(sv); 2745 16878804 if (SvGMAGICAL(sv)) 2746 16111895 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); 2747 } 2748 2749 17620145 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ 2750 2751 /* If we're still on top of the stack, pop us off. (That condition 2752 * will be satisfied if restore_magic was called explicitly, but *not* 2753 * if it's being called via leave_scope.) 2754 * The reason for doing this is that otherwise, things like sv_2cv() 2755 * may leave alloc gunk on the savestack, and some code 2756 * (e.g. sighandler) doesn't expect that... 2757 */ 2758 17620145 if (PL_savestack_ix == mgs->mgs_ss_ix) 2759 { 2760 17619712 I32 popval = SSPOPINT; 2761 17619712 assert(popval == SAVEt_DESTRUCTOR_X); 2762 17619712 PL_savestack_ix -= 2; 2763 17619712 popval = SSPOPINT; 2764 17619712 assert(popval == SAVEt_ALLOC); 2765 17619712 popval = SSPOPINT; 2766 17619712 PL_savestack_ix -= popval; 2767 } 2768 2769 } 2770 2771 static void 2772 S_unwind_handler_stack(pTHX_ const void *p) 2773 5 { 2774 dVAR; 2775 5 const U32 flags = *(const U32*)p; 2776 2777 5 if (flags & 1) 2778 5 PL_savestack_ix -= 5; /* Unprotect save in progress. */ 2779 /* cxstack_ix-- Not needed, die already unwound it. */ 2780 #if !defined(PERL_IMPLICIT_CONTEXT) 2781 5 if (flags & 64) 2782 5 SvREFCNT_dec(PL_sig_sv); 2783 #endif 2784 } 2785 2786 /* 2787 * Local variables: 2788 * c-indentation-style: bsd 2789 * c-basic-offset: 4 2790 * indent-tabs-mode: t 2791 * End: 2792 * 2793 * ex: set ts=8 sts=4 sw=4 noet: 2794 */