1 /* mg.c 2 * 3 * Copyright (c) 1991-2001, Larry Wall 4 * 5 * You may distribute under the terms of either the GNU General Public 6 * License or the Artistic License, as specified in the README file. 7 * 8 */ 9 10 /* 11 * "Sam sat on the ground and put his head in his hands. 'I wish I had never 12 * come here, and I don't want to see no more magic,' he said, and fell silent." 13 */ 14 15 #include "EXTERN.h" 16 #define PERL_IN_MG_C 17 #include "perl.h" 18 19 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) 20 # ifndef NGROUPS 21 # define NGROUPS 32 22 # endif 23 #endif 24 25 static void restore_magic(pTHXo_ void *p); 26 static void unwind_handler_stack(pTHXo_ void *p); 27 28 /* 29 * Use the "DESTRUCTOR" scope cleanup to reinstate magic. 30 */ 31 32 struct magic_state { 33 SV* mgs_sv; 34 U32 mgs_flags; 35 I32 mgs_ss_ix; 36 }; 37 /* MGS is typedef'ed to struct magic_state in perl.h */ 38 39 STATIC void 40 S_save_magic(pTHX_ I32 mgs_ix, SV *sv) 41 { 42 MGS* mgs; 43 assert(SvMAGICAL(sv)); 44 45 SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix); 46 47 mgs = SSPTR(mgs_ix, MGS*); 48 mgs->mgs_sv = sv; 49 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); 50 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ 51 52 SvMAGICAL_off(sv); 53 SvREADONLY_off(sv); 54 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; 55 } 56 57 /* 58 =for apidoc mg_magical 59 60 Turns on the magical status of an SV. See C<sv_magic>. 61 62 =cut 63 */ 64 65 void 66 Perl_mg_magical(pTHX_ SV *sv) 67 { 68 MAGIC* mg; 69 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 70 MGVTBL* vtbl = mg->mg_virtual; 71 if (vtbl) { 72 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) 73 SvGMAGICAL_on(sv); 74 if (vtbl->svt_set) 75 SvSMAGICAL_on(sv); 76 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) 77 SvRMAGICAL_on(sv); 78 } 79 } 80 } 81 82 /* 83 =for apidoc mg_get 84 85 Do magic after a value is retrieved from the SV. See C<sv_magic>. 86 87 =cut 88 */ 89 90 int 91 Perl_mg_get(pTHX_ SV *sv) 92 { 93 I32 mgs_ix; 94 MAGIC* mg; 95 MAGIC** mgp; 96 int mgp_valid = 0; 97 98 mgs_ix = SSNEW(sizeof(MGS)); 99 save_magic(mgs_ix, sv); 100 101 mgp = &SvMAGIC(sv); 102 while ((mg = *mgp) != 0) { 103 MGVTBL* vtbl = mg->mg_virtual; 104 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { 105 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); 106 /* Ignore this magic if it's been deleted */ 107 if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && 108 (mg->mg_flags & MGf_GSKIP)) 109 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; 110 } 111 /* Advance to next magic (complicated by possible deletion) */ 112 if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) { 113 mgp = &mg->mg_moremagic; 114 mgp_valid = 1; 115 } 116 else 117 mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */ 118 } 119 120 restore_magic(aTHXo_ (void*)mgs_ix); 121 return 0; 122 } 123 124 /* 125 =for apidoc mg_set 126 127 Do magic after a value is assigned to the SV. See C<sv_magic>. 128 129 =cut 130 */ 131 132 int 133 Perl_mg_set(pTHX_ SV *sv) 134 { 135 I32 mgs_ix; 136 MAGIC* mg; 137 MAGIC* nextmg; 138 139 mgs_ix = SSNEW(sizeof(MGS)); 140 save_magic(mgs_ix, sv); 141 142 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 143 MGVTBL* vtbl = mg->mg_virtual; 144 nextmg = mg->mg_moremagic; /* it may delete itself */ 145 if (mg->mg_flags & MGf_GSKIP) { 146 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ 147 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; 148 } 149 if (vtbl && vtbl->svt_set) 150 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); 151 } 152 153 restore_magic(aTHXo_ (void*)mgs_ix); 154 return 0; 155 } 156 157 /* 158 =for apidoc mg_length 159 160 Report on the SV's length. See C<sv_magic>. 161 162 =cut 163 */ 164 165 U32 166 Perl_mg_length(pTHX_ SV *sv) 167 { 168 MAGIC* mg; 169 char *junk; 170 STRLEN len; 171 172 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 173 MGVTBL* vtbl = mg->mg_virtual; 174 if (vtbl && vtbl->svt_len) { 175 I32 mgs_ix; 176 177 mgs_ix = SSNEW(sizeof(MGS)); 178 save_magic(mgs_ix, sv); 179 /* omit MGf_GSKIP -- not changed here */ 180 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); 181 restore_magic(aTHXo_ (void*)mgs_ix); 182 return len; 183 } 184 } 185 186 junk = SvPV(sv, len); 187 return len; 188 } 189 190 I32 191 Perl_mg_size(pTHX_ SV *sv) 192 { 193 MAGIC* mg; 194 I32 len; 195 196 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 197 MGVTBL* vtbl = mg->mg_virtual; 198 if (vtbl && vtbl->svt_len) { 199 I32 mgs_ix; 200 201 mgs_ix = SSNEW(sizeof(MGS)); 202 save_magic(mgs_ix, sv); 203 /* omit MGf_GSKIP -- not changed here */ 204 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); 205 restore_magic(aTHXo_ (void*)mgs_ix); 206 return len; 207 } 208 } 209 210 switch(SvTYPE(sv)) { 211 case SVt_PVAV: 212 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */ 213 return len; 214 case SVt_PVHV: 215 /* FIXME */ 216 default: 217 Perl_croak(aTHX_ "Size magic not implemented"); 218 break; 219 } 220 return 0; 221 } 222 223 /* 224 =for apidoc mg_clear 225 226 Clear something magical that the SV represents. See C<sv_magic>. 227 228 =cut 229 */ 230 231 int 232 Perl_mg_clear(pTHX_ SV *sv) 233 { 234 I32 mgs_ix; 235 MAGIC* mg; 236 237 mgs_ix = SSNEW(sizeof(MGS)); 238 save_magic(mgs_ix, sv); 239 240 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 241 MGVTBL* vtbl = mg->mg_virtual; 242 /* omit GSKIP -- never set here */ 243 244 if (vtbl && vtbl->svt_clear) 245 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); 246 } 247 248 restore_magic(aTHXo_ (void*)mgs_ix); 249 return 0; 250 } 251 252 /* 253 =for apidoc mg_find 254 255 Finds the magic pointer for type matching the SV. See C<sv_magic>. 256 257 =cut 258 */ 259 260 MAGIC* 261 Perl_mg_find(pTHX_ SV *sv, int type) 262 { 263 MAGIC* mg; 264 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 265 if (mg->mg_type == type) 266 return mg; 267 } 268 return 0; 269 } 270 271 /* 272 =for apidoc mg_copy 273 274 Copies the magic from one SV to another. See C<sv_magic>. 275 276 =cut 277 */ 278 279 int 280 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) 281 { 282 int count = 0; 283 MAGIC* mg; 284 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 285 if (isUPPER(mg->mg_type)) { 286 sv_magic(nsv, 287 mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : 288 (mg->mg_type == 'D' && mg->mg_obj) ? sv : mg->mg_obj, 289 toLOWER(mg->mg_type), key, klen); 290 count++; 291 } 292 } 293 return count; 294 } 295 296 /* 297 =for apidoc mg_free 298 299 Free any magic storage used by the SV. See C<sv_magic>. 300 301 =cut 302 */ 303 304 int 305 Perl_mg_free(pTHX_ SV *sv) 306 { 307 MAGIC* mg; 308 MAGIC* moremagic; 309 for (mg = SvMAGIC(sv); mg; mg = moremagic) { 310 MGVTBL* vtbl = mg->mg_virtual; 311 moremagic = mg->mg_moremagic; 312 if (vtbl && vtbl->svt_free) 313 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); 314 if (mg->mg_ptr && mg->mg_type != 'g') 315 if (mg->mg_len >= 0) 316 Safefree(mg->mg_ptr); 317 else if (mg->mg_len == HEf_SVKEY) 318 SvREFCNT_dec((SV*)mg->mg_ptr); 319 if (mg->mg_flags & MGf_REFCOUNTED) 320 SvREFCNT_dec(mg->mg_obj); 321 Safefree(mg); 322 } 323 SvMAGIC(sv) = 0; 324 return 0; 325 } 326 327 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) 328 #include <signal.h> 329 #endif 330 331 U32 332 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) 333 { 334 register REGEXP *rx; 335 336 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 337 if (mg->mg_obj) /* @+ */ 338 return rx->nparens; 339 else /* @- */ 340 return rx->lastparen; 341 } 342 343 return (U32)-1; 344 } 345 346 int 347 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) 348 { 349 register I32 paren; 350 register I32 s; 351 register I32 i; 352 register REGEXP *rx; 353 I32 t; 354 355 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 356 paren = mg->mg_len; 357 if (paren < 0) 358 return 0; 359 if (paren <= rx->nparens && 360 (s = rx->startp[paren]) != -1 && 361 (t = rx->endp[paren]) != -1) 362 { 363 if (mg->mg_obj) /* @+ */ 364 i = t; 365 else /* @- */ 366 i = s; 367 sv_setiv(sv,i); 368 } 369 } 370 return 0; 371 } 372 373 int 374 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) 375 { 376 Perl_croak(aTHX_ PL_no_modify); 377 /* NOT REACHED */ 378 return 0; 379 } 380 381 U32 382 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 383 { 384 register I32 paren; 385 register I32 i; 386 register REGEXP *rx; 387 I32 s1, t1; 388 389 switch (*mg->mg_ptr) { 390 case '1': case '2': case '3': case '4': 391 case '5': case '6': case '7': case '8': case '9': case '&': 392 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 393 394 paren = atoi(mg->mg_ptr); 395 getparen: 396 if (paren <= rx->nparens && 397 (s1 = rx->startp[paren]) != -1 && 398 (t1 = rx->endp[paren]) != -1) 399 { 400 i = t1 - s1; 401 getlen: 402 if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { 403 char *s = rx->subbeg + s1; 404 char *send = rx->subbeg + t1; 405 i = 0; 406 while (s < send) { 407 s += UTF8SKIP(s); 408 i++; 409 } 410 } 411 if (i >= 0) 412 return i; 413 } 414 } 415 return 0; 416 case '+': 417 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 418 paren = rx->lastparen; 419 if (paren) 420 goto getparen; 421 } 422 return 0; 423 case '`': 424 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 425 if (rx->startp[0] != -1) { 426 i = rx->startp[0]; 427 if (i > 0) { 428 s1 = 0; 429 t1 = i; 430 goto getlen; 431 } 432 } 433 } 434 return 0; 435 case '\'': 436 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 437 if (rx->endp[0] != -1) { 438 i = rx->sublen - rx->endp[0]; 439 if (i > 0) { 440 s1 = rx->endp[0]; 441 t1 = rx->sublen; 442 goto getlen; 443 } 444 } 445 } 446 return 0; 447 case ',': 448 return (STRLEN)PL_ofslen; 449 case '\\': 450 return (STRLEN)PL_orslen; 451 } 452 magic_get(sv,mg); 453 if (!SvPOK(sv) && SvNIOK(sv)) { 454 STRLEN n_a; 455 sv_2pv(sv, &n_a); 456 } 457 if (SvPOK(sv)) 458 return SvCUR(sv); 459 return 0; 460 } 461 462 int 463 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 464 { 465 register I32 paren; 466 register char *s; 467 register I32 i; 468 register REGEXP *rx; 469 470 switch (*mg->mg_ptr) { 471 case '\001': /* ^A */ 472 sv_setsv(sv, PL_bodytarget); 473 break; 474 case '\003': /* ^C */ 475 sv_setiv(sv, (IV)PL_minus_c); 476 break; 477 478 case '\004': /* ^D */ 479 sv_setiv(sv, (IV)(PL_debug & 32767)); 480 #if defined(YYDEBUG) && defined(DEBUGGING) 481 PL_yydebug = (PL_debug & 1); 482 #endif 483 break; 484 case '\005': /* ^E */ 485 #ifdef MACOS_TRADITIONAL 486 { 487 char msg[256]; 488 489 sv_setnv(sv,(double)gMacPerl_OSErr); 490 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); 491 } 492 #else 493 #ifdef VMS 494 { 495 # include <descrip.h> 496 # include <starlet.h> 497 char msg[255]; 498 $DESCRIPTOR(msgdsc,msg); 499 sv_setnv(sv,(NV) vaxc$errno); 500 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) 501 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); 502 else 503 sv_setpv(sv,""); 504 } 505 #else 506 #ifdef OS2 507 if (!(_emx_env & 0x200)) { /* Under DOS */ 508 sv_setnv(sv, (NV)errno); 509 sv_setpv(sv, errno ? Strerror(errno) : ""); 510 } else { 511 if (errno != errno_isOS2) { 512 int tmp = _syserrno(); 513 if (tmp) /* 2nd call to _syserrno() makes it 0 */ 514 Perl_rc = tmp; 515 } 516 sv_setnv(sv, (NV)Perl_rc); 517 sv_setpv(sv, os2error(Perl_rc)); 518 } 519 #else 520 #ifdef WIN32 521 { 522 DWORD dwErr = GetLastError(); 523 sv_setnv(sv, (NV)dwErr); 524 if (dwErr) 525 { 526 PerlProc_GetOSError(sv, dwErr); 527 } 528 else 529 sv_setpv(sv, ""); 530 SetLastError(dwErr); 531 } 532 #else 533 sv_setnv(sv, (NV)errno); 534 sv_setpv(sv, errno ? Strerror(errno) : ""); 535 #endif 536 #endif 537 #endif 538 #endif 539 SvNOK_on(sv); /* what a wonderful hack! */ 540 break; 541 case '\006': /* ^F */ 542 sv_setiv(sv, (IV)PL_maxsysfd); 543 break; 544 case '\010': /* ^H */ 545 sv_setiv(sv, (IV)PL_hints); 546 break; 547 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 548 if (PL_inplace) 549 sv_setpv(sv, PL_inplace); 550 else 551 sv_setsv(sv, &PL_sv_undef); 552 break; 553 case '\017': /* ^O */ 554 sv_setpv(sv, PL_osname); 555 break; 556 case '\020': /* ^P */ 557 sv_setiv(sv, (IV)PL_perldb); 558 break; 559 case '\023': /* ^S */ 560 { 561 if (PL_lex_state != LEX_NOTPARSING) 562 (void)SvOK_off(sv); 563 else if (PL_in_eval) 564 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); 565 } 566 break; 567 case '\024': /* ^T */ 568 #ifdef BIG_TIME 569 sv_setnv(sv, PL_basetime); 570 #else 571 sv_setiv(sv, (IV)PL_basetime); 572 #endif 573 break; 574 case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ 575 if (*(mg->mg_ptr+1) == '\0') 576 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); 577 else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { 578 if (PL_compiling.cop_warnings == pWARN_NONE || 579 PL_compiling.cop_warnings == pWARN_STD) 580 { 581 sv_setpvn(sv, WARN_NONEstring, WARNsize) ; 582 } 583 else if (PL_compiling.cop_warnings == pWARN_ALL) { 584 sv_setpvn(sv, WARN_ALLstring, WARNsize) ; 585 } 586 else { 587 sv_setsv(sv, PL_compiling.cop_warnings); 588 } 589 SvPOK_only(sv); 590 } 591 else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) 592 sv_setiv(sv, (IV)PL_widesyscalls); 593 break; 594 case '1': case '2': case '3': case '4': 595 case '5': case '6': case '7': case '8': case '9': case '&': 596 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 597 I32 s1, t1; 598 599 /* 600 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); 601 * XXX Does the new way break anything? 602 */ 603 paren = atoi(mg->mg_ptr); 604 getparen: 605 if (paren <= rx->nparens && 606 (s1 = rx->startp[paren]) != -1 && 607 (t1 = rx->endp[paren]) != -1) 608 { 609 i = t1 - s1; 610 s = rx->subbeg + s1; 611 if (!rx->subbeg) 612 break; 613 614 getrx: 615 if (i >= 0) { 616 bool was_tainted; 617 if (PL_tainting) { 618 was_tainted = PL_tainted; 619 PL_tainted = FALSE; 620 } 621 sv_setpvn(sv, s, i); 622 if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) 623 SvUTF8_on(sv); 624 else 625 SvUTF8_off(sv); 626 if (PL_tainting) 627 PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx)); 628 break; 629 } 630 } 631 } 632 sv_setsv(sv,&PL_sv_undef); 633 break; 634 case '+': 635 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 636 paren = rx->lastparen; 637 if (paren) 638 goto getparen; 639 } 640 sv_setsv(sv,&PL_sv_undef); 641 break; 642 case '`': 643 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 644 if ((s = rx->subbeg) && rx->startp[0] != -1) { 645 i = rx->startp[0]; 646 goto getrx; 647 } 648 } 649 sv_setsv(sv,&PL_sv_undef); 650 break; 651 case '\'': 652 if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { 653 if (rx->subbeg && rx->endp[0] != -1) { 654 s = rx->subbeg + rx->endp[0]; 655 i = rx->sublen - rx->endp[0]; 656 goto getrx; 657 } 658 } 659 sv_setsv(sv,&PL_sv_undef); 660 break; 661 case '.': 662 #ifndef lint 663 if (GvIO(PL_last_in_gv)) { 664 sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv))); 665 } 666 #endif 667 break; 668 case '?': 669 { 670 sv_setiv(sv, (IV)STATUS_CURRENT); 671 #ifdef COMPLEX_STATUS 672 LvTARGOFF(sv) = PL_statusvalue; 673 LvTARGLEN(sv) = PL_statusvalue_vms; 674 #endif 675 } 676 break; 677 case '^': 678 s = IoTOP_NAME(GvIOp(PL_defoutgv)); 679 if (s) 680 sv_setpv(sv,s); 681 else { 682 sv_setpv(sv,GvENAME(PL_defoutgv)); 683 sv_catpv(sv,"_TOP"); 684 } 685 break; 686 case '~': 687 s = IoFMT_NAME(GvIOp(PL_defoutgv)); 688 if (!s) 689 s = GvENAME(PL_defoutgv); 690 sv_setpv(sv,s); 691 break; 692 #ifndef lint 693 case '=': 694 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); 695 break; 696 case '-': 697 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); 698 break; 699 case '%': 700 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); 701 break; 702 #endif 703 case ':': 704 break; 705 case '/': 706 break; 707 case '[': 708 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase)); 709 break; 710 case '|': 711 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); 712 break; 713 case ',': 714 sv_setpvn(sv,PL_ofs,PL_ofslen); 715 break; 716 case '\\': 717 sv_setpvn(sv,PL_ors,PL_orslen); 718 break; 719 case '#': 720 sv_setpv(sv,PL_ofmt); 721 break; 722 case '!': 723 #ifdef VMS 724 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); 725 sv_setpv(sv, errno ? Strerror(errno) : ""); 726 #else 727 { 728 int saveerrno = errno; 729 sv_setnv(sv, (NV)errno); 730 #ifdef OS2 731 if (errno == errno_isOS2 || errno == errno_isOS2_set) 732 sv_setpv(sv, os2error(Perl_rc)); 733 else 734 #endif 735 sv_setpv(sv, errno ? Strerror(errno) : ""); 736 errno = saveerrno; 737 } 738 #endif 739 SvNOK_on(sv); /* what a wonderful hack! */ 740 break; 741 case '<': 742 sv_setiv(sv, (IV)PL_uid); 743 break; 744 case '>': 745 sv_setiv(sv, (IV)PL_euid); 746 break; 747 case '(': 748 sv_setiv(sv, (IV)PL_gid); 749 #ifdef HAS_GETGROUPS 750 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid); 751 #endif 752 goto add_groups; 753 case ')': 754 sv_setiv(sv, (IV)PL_egid); 755 #ifdef HAS_GETGROUPS 756 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid); 757 #endif 758 add_groups: 759 #ifdef HAS_GETGROUPS 760 { 761 Groups_t gary[NGROUPS]; 762 i = getgroups(NGROUPS,gary); 763 while (--i >= 0) 764 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]); 765 } 766 #endif 767 (void)SvIOK_on(sv); /* what a wonderful hack! */ 768 break; 769 case '*': 770 break; 771 #ifndef MACOS_TRADITIONAL 772 case '0': 773 break; 774 #endif 775 #ifdef USE_THREADS 776 case '@': 777 sv_setsv(sv, thr->errsv); 778 break; 779 #endif /* USE_THREADS */ 780 } 781 return 0; 782 } 783 784 int 785 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) 786 { 787 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; 788 789 if (uf && uf->uf_val) 790 (*uf->uf_val)(uf->uf_index, sv); 791 return 0; 792 } 793 794 int 795 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) 796 { 797 register char *s; 798 char *ptr; 799 STRLEN len, klen; 800 I32 i; 801 802 s = SvPV(sv,len); 803 ptr = MgPV(mg,klen); 804 my_setenv(ptr, s); 805 806 #ifdef DYNAMIC_ENV_FETCH 807 /* We just undefd an environment var. Is a replacement */ 808 /* waiting in the wings? */ 809 if (!len) { 810 SV **valp; 811 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE))) 812 s = SvPV(*valp, len); 813 } 814 #endif 815 816 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) 817 /* And you'll never guess what the dog had */ 818 /* in its mouth... */ 819 if (PL_tainting) { 820 MgTAINTEDDIR_off(mg); 821 #ifdef VMS 822 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { 823 char pathbuf[256], eltbuf[256], *cp, *elt = s; 824 struct stat sbuf; 825 int i = 0, j = 0; 826 827 do { /* DCL$PATH may be a search list */ 828 while (1) { /* as may dev portion of any element */ 829 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { 830 if ( *(cp+1) == '.' || *(cp+1) == '-' || 831 cando_by_name(S_IWUSR,0,elt) ) { 832 MgTAINTEDDIR_on(mg); 833 return 0; 834 } 835 } 836 if ((cp = strchr(elt, ':')) != Nullch) 837 *cp = '\0'; 838 if (my_trnlnm(elt, eltbuf, j++)) 839 elt = eltbuf; 840 else 841 break; 842 } 843 j = 0; 844 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); 845 } 846 #endif /* VMS */ 847 if (s && klen == 4 && strEQ(ptr,"PATH")) { 848 char *strend = s + len; 849 850 while (s < strend) { 851 char tmpbuf[256]; 852 struct stat st; 853 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, 854 s, strend, ':', &i); 855 s++; 856 if (i >= sizeof tmpbuf /* too long -- assume the worst */ 857 || *tmpbuf != '/' 858 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { 859 MgTAINTEDDIR_on(mg); 860 return 0; 861 } 862 } 863 } 864 } 865 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ 866 867 return 0; 868 } 869 870 int 871 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) 872 { 873 STRLEN n_a; 874 my_setenv(MgPV(mg,n_a),Nullch); 875 return 0; 876 } 877 878 int 879 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) 880 { 881 #if defined(VMS) 882 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 883 #else 884 if (PL_localizing) { 885 HE* entry; 886 STRLEN n_a; 887 magic_clear_all_env(sv,mg); 888 hv_iterinit((HV*)sv); 889 while ((entry = hv_iternext((HV*)sv))) { 890 I32 keylen; 891 my_setenv(hv_iterkey(entry, &keylen), 892 SvPV(hv_iterval((HV*)sv, entry), n_a)); 893 } 894 } 895 #endif 896 return 0; 897 } 898 899 int 900 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 901 { 902 #if defined(VMS) || defined(EPOC) 903 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 904 #else 905 # ifdef PERL_IMPLICIT_SYS 906 PerlEnv_clearenv(); 907 # else 908 # ifdef WIN32 909 char *envv = GetEnvironmentStrings(); 910 char *cur = envv; 911 STRLEN len; 912 while (*cur) { 913 char *end = strchr(cur,'='); 914 if (end && end != cur) { 915 *end = '\0'; 916 my_setenv(cur,Nullch); 917 *end = '='; 918 cur = end + strlen(end+1)+2; 919 } 920 else if ((len = strlen(cur))) 921 cur += len+1; 922 } 923 FreeEnvironmentStrings(envv); 924 # else 925 #if !defined(MACOS_TRADITIONAL) 926 # ifndef PERL_USE_SAFE_PUTENV 927 I32 i; 928 929 if (environ == PL_origenviron) 930 environ = (char**)safesysmalloc(sizeof(char*)); 931 else 932 for (i = 0; environ[i]; i++) 933 safesysfree(environ[i]); 934 # endif /* PERL_USE_SAFE_PUTENV */ 935 936 environ[0] = Nullch; 937 938 #endif /* !defined(MACOS_TRADITIONAL) */ 939 # endif /* WIN32 */ 940 # endif /* PERL_IMPLICIT_SYS */ 941 #endif /* VMS */ 942 return 0; 943 } 944 945 int 946 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 947 { 948 I32 i; 949 STRLEN n_a; 950 /* Are we fetching a signal entry? */ 951 i = whichsig(MgPV(mg,n_a)); 952 if (i) { 953 if(PL_psig_ptr[i]) 954 sv_setsv(sv,PL_psig_ptr[i]); 955 else { 956 Sighandler_t sigstate = rsignal_state(i); 957 958 /* cache state so we don't fetch it again */ 959 if(sigstate == SIG_IGN) 960 sv_setpv(sv,"IGNORE"); 961 else 962 sv_setsv(sv,&PL_sv_undef); 963 PL_psig_ptr[i] = SvREFCNT_inc(sv); 964 SvTEMP_off(sv); 965 } 966 } 967 return 0; 968 } 969 int 970 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 971 { 972 I32 i; 973 STRLEN n_a; 974 /* Are we clearing a signal entry? */ 975 i = whichsig(MgPV(mg,n_a)); 976 if (i) { 977 if(PL_psig_ptr[i]) { 978 SvREFCNT_dec(PL_psig_ptr[i]); 979 PL_psig_ptr[i]=0; 980 } 981 if(PL_psig_name[i]) { 982 SvREFCNT_dec(PL_psig_name[i]); 983 PL_psig_name[i]=0; 984 } 985 } 986 return 0; 987 } 988 989 int 990 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 991 { 992 register char *s; 993 I32 i; 994 SV** svp; 995 STRLEN len; 996 997 s = MgPV(mg,len); 998 if (*s == '_') { 999 if (strEQ(s,"__DIE__")) 1000 svp = &PL_diehook; 1001 else if (strEQ(s,"__WARN__")) 1002 svp = &PL_warnhook; 1003 else 1004 Perl_croak(aTHX_ "No such hook: %s", s); 1005 i = 0; 1006 if (*svp) { 1007 SvREFCNT_dec(*svp); 1008 *svp = 0; 1009 } 1010 } 1011 else { 1012 i = whichsig(s); /* ...no, a brick */ 1013 if (!i) { 1014 if (ckWARN(WARN_SIGNAL)) 1015 Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s); 1016 return 0; 1017 } 1018 SvREFCNT_dec(PL_psig_name[i]); 1019 SvREFCNT_dec(PL_psig_ptr[i]); 1020 PL_psig_ptr[i] = SvREFCNT_inc(sv); 1021 SvTEMP_off(sv); /* Make sure it doesn't go away on us */ 1022 PL_psig_name[i] = newSVpvn(s, len); 1023 SvREADONLY_on(PL_psig_name[i]); 1024 } 1025 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { 1026 if (i) 1027 (void)rsignal(i, PL_sighandlerp); 1028 else 1029 *svp = SvREFCNT_inc(sv); 1030 return 0; 1031 } 1032 s = SvPV_force(sv,len); 1033 if (strEQ(s,"IGNORE")) { 1034 if (i) 1035 (void)rsignal(i, SIG_IGN); 1036 else 1037 *svp = 0; 1038 } 1039 else if (strEQ(s,"DEFAULT") || !*s) { 1040 if (i) 1041 (void)rsignal(i, SIG_DFL); 1042 else 1043 *svp = 0; 1044 } 1045 else { 1046 /* 1047 * We should warn if HINT_STRICT_REFS, but without 1048 * access to a known hint bit in a known OP, we can't 1049 * tell whether HINT_STRICT_REFS is in force or not. 1050 */ 1051 if (!strchr(s,':') && !strchr(s,'\'')) 1052 sv_insert(sv, 0, 0, "main::", 6); 1053 if (i) 1054 (void)rsignal(i, PL_sighandlerp); 1055 else 1056 *svp = SvREFCNT_inc(sv); 1057 } 1058 return 0; 1059 } 1060 1061 int 1062 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 1063 { 1064 PL_sub_generation++; 1065 return 0; 1066 } 1067 1068 int 1069 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg) 1070 { 1071 /* HV_badAMAGIC_on(Sv_STASH(sv)); */ 1072 PL_amagic_generation++; 1073 1074 return 0; 1075 } 1076 1077 int 1078 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) 1079 { 1080 HV *hv = (HV*)LvTARG(sv); 1081 HE *entry; 1082 I32 i = 0; 1083 1084 if (hv) { 1085 (void) hv_iterinit(hv); 1086 if (! SvTIED_mg((SV*)hv, 'P')) 1087 i = HvKEYS(hv); 1088 else { 1089 /*SUPPRESS 560*/ 1090 while ((entry = hv_iternext(hv))) { 1091 i++; 1092 } 1093 } 1094 } 1095 1096 sv_setiv(sv, (IV)i); 1097 return 0; 1098 } 1099 1100 int 1101 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 1102 { 1103 if (LvTARG(sv)) { 1104 hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); 1105 } 1106 return 0; 1107 } 1108 1109 /* caller is responsible for stack switching/cleanup */ 1110 STATIC int 1111 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) 1112 { 1113 dSP; 1114 1115 PUSHMARK(SP); 1116 EXTEND(SP, n); 1117 PUSHs(SvTIED_obj(sv, mg)); 1118 if (n > 1) { 1119 if (mg->mg_ptr) { 1120 if (mg->mg_len >= 0) 1121 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); 1122 else if (mg->mg_len == HEf_SVKEY) 1123 PUSHs((SV*)mg->mg_ptr); 1124 } 1125 else if (mg->mg_type == 'p') { 1126 PUSHs(sv_2mortal(newSViv(mg->mg_len))); 1127 } 1128 } 1129 if (n > 2) { 1130 PUSHs(val); 1131 } 1132 PUTBACK; 1133 1134 return call_method(meth, flags); 1135 } 1136 1137 STATIC int 1138 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth) 1139 { 1140 dSP; 1141 1142 ENTER; 1143 SAVETMPS; 1144 PUSHSTACKi(PERLSI_MAGIC); 1145 1146 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { 1147 sv_setsv(sv, *PL_stack_sp--); 1148 } 1149 1150 POPSTACK; 1151 FREETMPS; 1152 LEAVE; 1153 return 0; 1154 } 1155 1156 int 1157 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) 1158 { 1159 magic_methpack(sv,mg,"FETCH"); 1160 if (mg->mg_ptr) 1161 mg->mg_flags |= MGf_GSKIP; 1162 return 0; 1163 } 1164 1165 int 1166 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) 1167 { 1168 dSP; 1169 ENTER; 1170 PUSHSTACKi(PERLSI_MAGIC); 1171 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); 1172 POPSTACK; 1173 LEAVE; 1174 return 0; 1175 } 1176 1177 int 1178 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) 1179 { 1180 return magic_methpack(sv,mg,"DELETE"); 1181 } 1182 1183 1184 U32 1185 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) 1186 { 1187 dSP; 1188 U32 retval = 0; 1189 1190 ENTER; 1191 SAVETMPS; 1192 PUSHSTACKi(PERLSI_MAGIC); 1193 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { 1194 sv = *PL_stack_sp--; 1195 retval = (U32) SvIV(sv)-1; 1196 } 1197 POPSTACK; 1198 FREETMPS; 1199 LEAVE; 1200 return retval; 1201 } 1202 1203 int 1204 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) 1205 { 1206 dSP; 1207 1208 ENTER; 1209 PUSHSTACKi(PERLSI_MAGIC); 1210 PUSHMARK(SP); 1211 XPUSHs(SvTIED_obj(sv, mg)); 1212 PUTBACK; 1213 call_method("CLEAR", G_SCALAR|G_DISCARD); 1214 POPSTACK; 1215 LEAVE; 1216 return 0; 1217 } 1218 1219 int 1220 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) 1221 { 1222 dSP; 1223 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; 1224 1225 ENTER; 1226 SAVETMPS; 1227 PUSHSTACKi(PERLSI_MAGIC); 1228 PUSHMARK(SP); 1229 EXTEND(SP, 2); 1230 PUSHs(SvTIED_obj(sv, mg)); 1231 if (SvOK(key)) 1232 PUSHs(key); 1233 PUTBACK; 1234 1235 if (call_method(meth, G_SCALAR)) 1236 sv_setsv(key, *PL_stack_sp--); 1237 1238 POPSTACK; 1239 FREETMPS; 1240 LEAVE; 1241 return 0; 1242 } 1243 1244 int 1245 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) 1246 { 1247 return magic_methpack(sv,mg,"EXISTS"); 1248 } 1249 1250 int 1251 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) 1252 { 1253 OP *o; 1254 I32 i; 1255 GV* gv; 1256 SV** svp; 1257 STRLEN n_a; 1258 1259 gv = PL_DBline; 1260 i = SvTRUE(sv); 1261 svp = av_fetch(GvAV(gv), 1262 atoi(MgPV(mg,n_a)), FALSE); 1263 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) 1264 o->op_private = i; 1265 return 0; 1266 } 1267 1268 int 1269 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) 1270 { 1271 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase); 1272 return 0; 1273 } 1274 1275 int 1276 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) 1277 { 1278 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase); 1279 return 0; 1280 } 1281 1282 int 1283 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 1284 { 1285 SV* lsv = LvTARG(sv); 1286 1287 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { 1288 mg = mg_find(lsv, 'g'); 1289 if (mg && mg->mg_len >= 0) { 1290 I32 i = mg->mg_len; 1291 if (DO_UTF8(lsv)) 1292 sv_pos_b2u(lsv, &i); 1293 sv_setiv(sv, i + PL_curcop->cop_arybase); 1294 return 0; 1295 } 1296 } 1297 (void)SvOK_off(sv); 1298 return 0; 1299 } 1300 1301 int 1302 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 1303 { 1304 SV* lsv = LvTARG(sv); 1305 SSize_t pos; 1306 STRLEN len; 1307 STRLEN ulen = 0; 1308 1309 mg = 0; 1310 1311 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) 1312 mg = mg_find(lsv, 'g'); 1313 if (!mg) { 1314 if (!SvOK(sv)) 1315 return 0; 1316 sv_magic(lsv, (SV*)0, 'g', Nullch, 0); 1317 mg = mg_find(lsv, 'g'); 1318 } 1319 else if (!SvOK(sv)) { 1320 mg->mg_len = -1; 1321 return 0; 1322 } 1323 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); 1324 1325 pos = SvIV(sv) - PL_curcop->cop_arybase; 1326 1327 if (DO_UTF8(lsv)) { 1328 ulen = sv_len_utf8(lsv); 1329 if (ulen) 1330 len = ulen; 1331 } 1332 1333 if (pos < 0) { 1334 pos += len; 1335 if (pos < 0) 1336 pos = 0; 1337 } 1338 else if (pos > len) 1339 pos = len; 1340 1341 if (ulen) { 1342 I32 p = pos; 1343 sv_pos_u2b(lsv, &p, 0); 1344 pos = p; 1345 } 1346 1347 mg->mg_len = pos; 1348 mg->mg_flags &= ~MGf_MINMATCH; 1349 1350 return 0; 1351 } 1352 1353 int 1354 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg) 1355 { 1356 if (SvFAKE(sv)) { /* FAKE globs can get coerced */ 1357 SvFAKE_off(sv); 1358 gv_efullname3(sv,((GV*)sv), "*"); 1359 SvFAKE_on(sv); 1360 } 1361 else 1362 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */ 1363 return 0; 1364 } 1365 1366 int 1367 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg) 1368 { 1369 register char *s; 1370 GV* gv; 1371 STRLEN n_a; 1372 1373 if (!SvOK(sv)) 1374 return 0; 1375 s = SvPV(sv, n_a); 1376 if (*s == '*' && s[1]) 1377 s++; 1378 gv = gv_fetchpv(s,TRUE, SVt_PVGV); 1379 if (sv == (SV*)gv) 1380 return 0; 1381 if (GvGP(sv)) 1382 gp_free((GV*)sv); 1383 GvGP(sv) = gp_ref(GvGP(gv)); 1384 return 0; 1385 } 1386 1387 int 1388 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) 1389 { 1390 STRLEN len; 1391 SV *lsv = LvTARG(sv); 1392 char *tmps = SvPV(lsv,len); 1393 I32 offs = LvTARGOFF(sv); 1394 I32 rem = LvTARGLEN(sv); 1395 1396 if (SvUTF8(lsv)) 1397 sv_pos_u2b(lsv, &offs, &rem); 1398 if (offs > len) 1399 offs = len; 1400 if (rem + offs > len) 1401 rem = len - offs; 1402 sv_setpvn(sv, tmps + offs, (STRLEN)rem); 1403 if (SvUTF8(lsv)) 1404 SvUTF8_on(sv); 1405 return 0; 1406 } 1407 1408 int 1409 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) 1410 { 1411 STRLEN len; 1412 char *tmps = SvPV(sv, len); 1413 SV *lsv = LvTARG(sv); 1414 I32 lvoff = LvTARGOFF(sv); 1415 I32 lvlen = LvTARGLEN(sv); 1416 1417 if (DO_UTF8(sv)) { 1418 sv_utf8_upgrade(lsv); 1419 sv_pos_u2b(lsv, &lvoff, &lvlen); 1420 sv_insert(lsv, lvoff, lvlen, tmps, len); 1421 SvUTF8_on(lsv); 1422 } 1423 else if (SvUTF8(lsv)) { 1424 sv_pos_u2b(lsv, &lvoff, &lvlen); 1425 tmps = (char*)bytes_to_utf8((U8*)tmps, &len); 1426 sv_insert(lsv, lvoff, lvlen, tmps, len); 1427 Safefree(tmps); 1428 } 1429 else 1430 sv_insert(lsv, lvoff, lvlen, tmps, len); 1431 1432 return 0; 1433 } 1434 1435 int 1436 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) 1437 { 1438 TAINT_IF((mg->mg_len & 1) || 1439 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */ 1440 return 0; 1441 } 1442 1443 int 1444 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) 1445 { 1446 if (PL_localizing) { 1447 if (PL_localizing == 1) 1448 mg->mg_len <<= 1; 1449 else 1450 mg->mg_len >>= 1; 1451 } 1452 else if (PL_tainted) 1453 mg->mg_len |= 1; 1454 else 1455 mg->mg_len &= ~1; 1456 return 0; 1457 } 1458 1459 int 1460 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) 1461 { 1462 SV *lsv = LvTARG(sv); 1463 1464 if (!lsv) { 1465 (void)SvOK_off(sv); 1466 return 0; 1467 } 1468 1469 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); 1470 return 0; 1471 } 1472 1473 int 1474 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) 1475 { 1476 do_vecset(sv); /* XXX slurp this routine */ 1477 return 0; 1478 } 1479 1480 int 1481 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 1482 { 1483 SV *targ = Nullsv; 1484 if (LvTARGLEN(sv)) { 1485 if (mg->mg_obj) { 1486 SV *ahv = LvTARG(sv); 1487 if (SvTYPE(ahv) == SVt_PVHV) { 1488 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); 1489 if (he) 1490 targ = HeVAL(he); 1491 } 1492 else { 1493 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0); 1494 if (svp) 1495 targ = *svp; 1496 } 1497 } 1498 else { 1499 AV* av = (AV*)LvTARG(sv); 1500 if ((I32)LvTARGOFF(sv) <= AvFILL(av)) 1501 targ = AvARRAY(av)[LvTARGOFF(sv)]; 1502 } 1503 if (targ && targ != &PL_sv_undef) { 1504 /* somebody else defined it for us */ 1505 SvREFCNT_dec(LvTARG(sv)); 1506 LvTARG(sv) = SvREFCNT_inc(targ); 1507 LvTARGLEN(sv) = 0; 1508 SvREFCNT_dec(mg->mg_obj); 1509 mg->mg_obj = Nullsv; 1510 mg->mg_flags &= ~MGf_REFCOUNTED; 1511 } 1512 } 1513 else 1514 targ = LvTARG(sv); 1515 sv_setsv(sv, targ ? targ : &PL_sv_undef); 1516 return 0; 1517 } 1518 1519 int 1520 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) 1521 { 1522 if (LvTARGLEN(sv)) 1523 vivify_defelem(sv); 1524 if (LvTARG(sv)) { 1525 sv_setsv(LvTARG(sv), sv); 1526 SvSETMAGIC(LvTARG(sv)); 1527 } 1528 return 0; 1529 } 1530 1531 void 1532 Perl_vivify_defelem(pTHX_ SV *sv) 1533 { 1534 MAGIC *mg; 1535 SV *value = Nullsv; 1536 1537 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y'))) 1538 return; 1539 if (mg->mg_obj) { 1540 SV *ahv = LvTARG(sv); 1541 STRLEN n_a; 1542 if (SvTYPE(ahv) == SVt_PVHV) { 1543 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); 1544 if (he) 1545 value = HeVAL(he); 1546 } 1547 else { 1548 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0); 1549 if (svp) 1550 value = *svp; 1551 } 1552 if (!value || value == &PL_sv_undef) 1553 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a)); 1554 } 1555 else { 1556 AV* av = (AV*)LvTARG(sv); 1557 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av)) 1558 LvTARG(sv) = Nullsv; /* array can't be extended */ 1559 else { 1560 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE); 1561 if (!svp || (value = *svp) == &PL_sv_undef) 1562 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv)); 1563 } 1564 } 1565 (void)SvREFCNT_inc(value); 1566 SvREFCNT_dec(LvTARG(sv)); 1567 LvTARG(sv) = value; 1568 LvTARGLEN(sv) = 0; 1569 SvREFCNT_dec(mg->mg_obj); 1570 mg->mg_obj = Nullsv; 1571 mg->mg_flags &= ~MGf_REFCOUNTED; 1572 } 1573 1574 int 1575 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) 1576 { 1577 AV *av = (AV*)mg->mg_obj; 1578 SV **svp = AvARRAY(av); 1579 I32 i = AvFILLp(av); 1580 while (i >= 0) { 1581 if (svp[i] && svp[i] != &PL_sv_undef) { 1582 if (!SvWEAKREF(svp[i])) 1583 Perl_croak(aTHX_ "panic: magic_killbackrefs"); 1584 /* XXX Should we check that it hasn't changed? */ 1585 SvRV(svp[i]) = 0; 1586 (void)SvOK_off(svp[i]); 1587 SvWEAKREF_off(svp[i]); 1588 svp[i] = &PL_sv_undef; 1589 } 1590 i--; 1591 } 1592 return 0; 1593 } 1594 1595 int 1596 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) 1597 { 1598 mg->mg_len = -1; 1599 SvSCREAM_off(sv); 1600 return 0; 1601 } 1602 1603 int 1604 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg) 1605 { 1606 sv_unmagic(sv, 'B'); 1607 SvVALID_off(sv); 1608 return 0; 1609 } 1610 1611 int 1612 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg) 1613 { 1614 sv_unmagic(sv, 'f'); 1615 SvCOMPILED_off(sv); 1616 return 0; 1617 } 1618 1619 int 1620 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) 1621 { 1622 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; 1623 1624 if (uf && uf->uf_set) 1625 (*uf->uf_set)(uf->uf_index, sv); 1626 return 0; 1627 } 1628 1629 int 1630 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg) 1631 { 1632 regexp *re = (regexp *)mg->mg_obj; 1633 ReREFCNT_dec(re); 1634 return 0; 1635 } 1636 1637 #ifdef USE_LOCALE_COLLATE 1638 int 1639 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) 1640 { 1641 /* 1642 * RenE<eacute> Descartes said "I think not." 1643 * and vanished with a faint plop. 1644 */ 1645 if (mg->mg_ptr) { 1646 Safefree(mg->mg_ptr); 1647 mg->mg_ptr = NULL; 1648 mg->mg_len = -1; 1649 } 1650 return 0; 1651 } 1652 #endif /* USE_LOCALE_COLLATE */ 1653 1654 int 1655 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 1656 { 1657 register char *s; 1658 I32 i; 1659 STRLEN len; 1660 switch (*mg->mg_ptr) { 1661 case '\001': /* ^A */ 1662 sv_setsv(PL_bodytarget, sv); 1663 break; 1664 case '\003': /* ^C */ 1665 PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1666 break; 1667 1668 case '\004': /* ^D */ 1669 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000; 1670 DEBUG_x(dump_all()); 1671 break; 1672 case '\005': /* ^E */ 1673 #ifdef MACOS_TRADITIONAL 1674 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1675 #else 1676 # ifdef VMS 1677 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 1678 # else 1679 # ifdef WIN32 1680 SetLastError( SvIV(sv) ); 1681 # else 1682 # ifndef OS2 1683 /* will anyone ever use this? */ 1684 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); 1685 # endif 1686 # endif 1687 # endif 1688 #endif 1689 break; 1690 case '\006': /* ^F */ 1691 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1692 break; 1693 case '\010': /* ^H */ 1694 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1695 break; 1696 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 1697 if (PL_inplace) 1698 Safefree(PL_inplace); 1699 if (SvOK(sv)) 1700 PL_inplace = savepv(SvPV(sv,len)); 1701 else 1702 PL_inplace = Nullch; 1703 break; 1704 case '\017': /* ^O */ 1705 if (PL_osname) 1706 Safefree(PL_osname); 1707 if (SvOK(sv)) 1708 PL_osname = savepv(SvPV(sv,len)); 1709 else 1710 PL_osname = Nullch; 1711 break; 1712 case '\020': /* ^P */ 1713 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1714 if (PL_perldb && !PL_DBsingle) 1715 init_debugger(); 1716 break; 1717 case '\024': /* ^T */ 1718 #ifdef BIG_TIME 1719 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); 1720 #else 1721 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 1722 #endif 1723 break; 1724 case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ 1725 if (*(mg->mg_ptr+1) == '\0') { 1726 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 1727 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1728 PL_dowarn = (PL_dowarn & ~G_WARN_ON) 1729 | (i ? G_WARN_ON : G_WARN_OFF) ; 1730 } 1731 } 1732 else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { 1733 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 1734 if (!SvPOK(sv) && PL_localizing) { 1735 sv_setpvn(sv, WARN_NONEstring, WARNsize); 1736 PL_compiling.cop_warnings = pWARN_NONE; 1737 break; 1738 } 1739 { 1740 STRLEN len, i; 1741 int accumulate = 0 ; 1742 int any_fatals = 0 ; 1743 char * ptr = (char*)SvPV(sv, len) ; 1744 for (i = 0 ; i < len ; ++i) { 1745 accumulate |= ptr[i] ; 1746 any_fatals |= (ptr[i] & 0xAA) ; 1747 } 1748 if (!accumulate) 1749 PL_compiling.cop_warnings = pWARN_NONE; 1750 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) { 1751 PL_compiling.cop_warnings = pWARN_ALL; 1752 PL_dowarn |= G_WARN_ONCE ; 1753 } 1754 else { 1755 if (specialWARN(PL_compiling.cop_warnings)) 1756 PL_compiling.cop_warnings = newSVsv(sv) ; 1757 else 1758 sv_setsv(PL_compiling.cop_warnings, sv); 1759 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) 1760 PL_dowarn |= G_WARN_ONCE ; 1761 } 1762 1763 } 1764 } 1765 } 1766 else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) 1767 PL_widesyscalls = SvTRUE(sv); 1768 break; 1769 case '.': 1770 if (PL_localizing) { 1771 if (PL_localizing == 1) 1772 SAVESPTR(PL_last_in_gv); 1773 } 1774 else if (SvOK(sv) && GvIO(PL_last_in_gv)) 1775 IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv); 1776 break; 1777 case '^': 1778 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); 1779 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); 1780 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); 1781 break; 1782 case '~': 1783 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); 1784 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len)); 1785 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); 1786 break; 1787 case '=': 1788 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 1789 break; 1790 case '-': 1791 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 1792 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) 1793 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; 1794 break; 1795 case '%': 1796 IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 1797 break; 1798 case '|': 1799 { 1800 IO *io = GvIOp(PL_defoutgv); 1801 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0) 1802 IoFLAGS(io) &= ~IOf_FLUSH; 1803 else { 1804 if (!(IoFLAGS(io) & IOf_FLUSH)) { 1805 PerlIO *ofp = IoOFP(io); 1806 if (ofp) 1807 (void)PerlIO_flush(ofp); 1808 IoFLAGS(io) |= IOf_FLUSH; 1809 } 1810 } 1811 } 1812 break; 1813 case '*': 1814 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1815 PL_multiline = (i != 0); 1816 break; 1817 case '/': 1818 SvREFCNT_dec(PL_nrs); 1819 PL_nrs = newSVsv(sv); 1820 SvREFCNT_dec(PL_rs); 1821 PL_rs = SvREFCNT_inc(PL_nrs); 1822 break; 1823 case '\\': 1824 if (PL_ors) 1825 Safefree(PL_ors); 1826 if (SvOK(sv) || SvGMAGICAL(sv)) { 1827 s = SvPV(sv,PL_orslen); 1828 PL_ors = savepvn(s,PL_orslen); 1829 } 1830 else { 1831 PL_ors = Nullch; 1832 PL_orslen = 0; 1833 } 1834 break; 1835 case ',': 1836 if (PL_ofs) 1837 Safefree(PL_ofs); 1838 PL_ofs = savepv(SvPV(sv, PL_ofslen)); 1839 break; 1840 case '#': 1841 if (PL_ofmt) 1842 Safefree(PL_ofmt); 1843 PL_ofmt = savepv(SvPV(sv,len)); 1844 break; 1845 case '[': 1846 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1847 break; 1848 case '?': 1849 #ifdef COMPLEX_STATUS 1850 if (PL_localizing == 2) { 1851 PL_statusvalue = LvTARGOFF(sv); 1852 PL_statusvalue_vms = LvTARGLEN(sv); 1853 } 1854 else 1855 #endif 1856 #ifdef VMSISH_STATUS 1857 if (VMSISH_STATUS) 1858 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))); 1859 else 1860 #endif 1861 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 1862 break; 1863 case '!': 1864 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, 1865 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno); 1866 break; 1867 case '<': 1868 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1869 if (PL_delaymagic) { 1870 PL_delaymagic |= DM_RUID; 1871 break; /* don't do magic till later */ 1872 } 1873 #ifdef HAS_SETRUID 1874 (void)setruid((Uid_t)PL_uid); 1875 #else 1876 #ifdef HAS_SETREUID 1877 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1); 1878 #else 1879 #ifdef HAS_SETRESUID 1880 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); 1881 #else 1882 if (PL_uid == PL_euid) /* special case $< = $> */ 1883 (void)PerlProc_setuid(PL_uid); 1884 else { 1885 PL_uid = PerlProc_getuid(); 1886 Perl_croak(aTHX_ "setruid() not implemented"); 1887 } 1888 #endif 1889 #endif 1890 #endif 1891 PL_uid = PerlProc_getuid(); 1892 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 1893 break; 1894 case '>': 1895 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1896 if (PL_delaymagic) { 1897 PL_delaymagic |= DM_EUID; 1898 break; /* don't do magic till later */ 1899 } 1900 #ifdef HAS_SETEUID 1901 (void)seteuid((Uid_t)PL_euid); 1902 #else 1903 #ifdef HAS_SETREUID 1904 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid); 1905 #else 1906 #ifdef HAS_SETRESUID 1907 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1); 1908 #else 1909 if (PL_euid == PL_uid) /* special case $> = $< */ 1910 PerlProc_setuid(PL_euid); 1911 else { 1912 PL_euid = PerlProc_geteuid(); 1913 Perl_croak(aTHX_ "seteuid() not implemented"); 1914 } 1915 #endif 1916 #endif 1917 #endif 1918 PL_euid = PerlProc_geteuid(); 1919 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 1920 break; 1921 case '(': 1922 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1923 if (PL_delaymagic) { 1924 PL_delaymagic |= DM_RGID; 1925 break; /* don't do magic till later */ 1926 } 1927 #ifdef HAS_SETRGID 1928 (void)setrgid((Gid_t)PL_gid); 1929 #else 1930 #ifdef HAS_SETREGID 1931 (void)setregid((Gid_t)PL_gid, (Gid_t)-1); 1932 #else 1933 #ifdef HAS_SETRESGID 1934 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1); 1935 #else 1936 if (PL_gid == PL_egid) /* special case $( = $) */ 1937 (void)PerlProc_setgid(PL_gid); 1938 else { 1939 PL_gid = PerlProc_getgid(); 1940 Perl_croak(aTHX_ "setrgid() not implemented"); 1941 } 1942 #endif 1943 #endif 1944 #endif 1945 PL_gid = PerlProc_getgid(); 1946 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 1947 break; 1948 case ')': 1949 #ifdef HAS_SETGROUPS 1950 { 1951 char *p = SvPV(sv, len); 1952 Groups_t gary[NGROUPS]; 1953 1954 while (isSPACE(*p)) 1955 ++p; 1956 PL_egid = Atol(p); 1957 for (i = 0; i < NGROUPS; ++i) { 1958 while (*p && !isSPACE(*p)) 1959 ++p; 1960 while (isSPACE(*p)) 1961 ++p; 1962 if (!*p) 1963 break; 1964 gary[i] = Atol(p); 1965 } 1966 if (i) 1967 (void)setgroups(i, gary); 1968 } 1969 #else /* HAS_SETGROUPS */ 1970 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 1971 #endif /* HAS_SETGROUPS */ 1972 if (PL_delaymagic) { 1973 PL_delaymagic |= DM_EGID; 1974 break; /* don't do magic till later */ 1975 } 1976 #ifdef HAS_SETEGID 1977 (void)setegid((Gid_t)PL_egid); 1978 #else 1979 #ifdef HAS_SETREGID 1980 (void)setregid((Gid_t)-1, (Gid_t)PL_egid); 1981 #else 1982 #ifdef HAS_SETRESGID 1983 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1); 1984 #else 1985 if (PL_egid == PL_gid) /* special case $) = $( */ 1986 (void)PerlProc_setgid(PL_egid); 1987 else { 1988 PL_egid = PerlProc_getegid(); 1989 Perl_croak(aTHX_ "setegid() not implemented"); 1990 } 1991 #endif 1992 #endif 1993 #endif 1994 PL_egid = PerlProc_getegid(); 1995 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 1996 break; 1997 case ':': 1998 PL_chopset = SvPV_force(sv,len); 1999 break; 2000 #ifndef MACOS_TRADITIONAL 2001 case '0': 2002 #ifdef HAS_SETPROCTITLE 2003 /* The BSDs don't show the argv[] in ps(1) output, they 2004 * show a string from the process struct and provide 2005 * the setproctitle() routine to manipulate that. */ 2006 { 2007 s = SvPV(sv, len); 2008 # if __FreeBSD_version >= 410001 2009 /* The leading "-" removes the "perl: " prefix, 2010 * but not the "(perl) suffix from the ps(1) 2011 * output, because that's what ps(1) shows if the 2012 * argv[] is modified. */ 2013 setproctitle("-%s", s, len + 1); 2014 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ 2015 /* This doesn't really work if you assume that 2016 * $0 = 'foobar'; will wipe out 'perl' from the $0 2017 * because in ps(1) output the result will be like 2018 * sprintf("perl: %s (perl)", s) 2019 * I guess this is a security feature: 2020 * one (a user process) cannot get rid of the original name. 2021 * --jhi */ 2022 setproctitle("%s", s); 2023 # endif 2024 } 2025 #endif 2026 if (!PL_origalen) { 2027 s = PL_origargv[0]; 2028 s += strlen(s); 2029 /* See if all the arguments are contiguous in memory */ 2030 for (i = 1; i < PL_origargc; i++) { 2031 if (PL_origargv[i] == s + 1 2032 #ifdef OS2 2033 || PL_origargv[i] == s + 2 2034 #endif 2035 ) 2036 { 2037 ++s; 2038 s += strlen(s); /* this one is ok too */ 2039 } 2040 else 2041 break; 2042 } 2043 /* can grab env area too? */ 2044 if (PL_origenviron && (PL_origenviron[0] == s + 1 2045 #ifdef OS2 2046 || (PL_origenviron[0] == s + 9 && (s += 8)) 2047 #endif 2048 )) { 2049 my_setenv("NoNe SuCh", Nullch); 2050 /* force copy of environment */ 2051 for (i = 0; PL_origenviron[i]; i++) 2052 if (PL_origenviron[i] == s + 1) { 2053 ++s; 2054 s += strlen(s); 2055 } 2056 else 2057 break; 2058 } 2059 PL_origalen = s - PL_origargv[0]; 2060 } 2061 s = SvPV_force(sv,len); 2062 i = len; 2063 if (i >= PL_origalen) { 2064 i = PL_origalen; 2065 /* don't allow system to limit $0 seen by script */ 2066 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */ 2067 Copy(s, PL_origargv[0], i, char); 2068 s = PL_origargv[0]+i; 2069 *s = '\0'; 2070 } 2071 else { 2072 Copy(s, PL_origargv[0], i, char); 2073 s = PL_origargv[0]+i; 2074 *s++ = '\0'; 2075 while (++i < PL_origalen) 2076 *s++ = ' '; 2077 s = PL_origargv[0]+i; 2078 for (i = 1; i < PL_origargc; i++) 2079 PL_origargv[i] = Nullch; 2080 } 2081 break; 2082 #endif 2083 #ifdef USE_THREADS 2084 case '@': 2085 sv_setsv(thr->errsv, sv); 2086 break; 2087 #endif /* USE_THREADS */ 2088 } 2089 return 0; 2090 } 2091 2092 #ifdef USE_THREADS 2093 int 2094 Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg) 2095 { 2096 DEBUG_S(PerlIO_printf(Perl_debug_log, 2097 "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n", 2098 PTR2UV(thr), PTR2UV(sv));) 2099 if (MgOWNER(mg)) 2100 Perl_croak(aTHX_ "panic: magic_mutexfree"); 2101 MUTEX_DESTROY(MgMUTEXP(mg)); 2102 COND_DESTROY(MgCONDP(mg)); 2103 return 0; 2104 } 2105 #endif /* USE_THREADS */ 2106 2107 I32 2108 Perl_whichsig(pTHX_ char *sig) 2109 { 2110 register char **sigv; 2111 2112 for (sigv = PL_sig_name+1; *sigv; sigv++) 2113 if (strEQ(sig,*sigv)) 2114 return PL_sig_num[sigv - PL_sig_name]; 2115 #ifdef SIGCLD 2116 if (strEQ(sig,"CHLD")) 2117 return SIGCLD; 2118 #endif 2119 #ifdef SIGCHLD 2120 if (strEQ(sig,"CLD")) 2121 return SIGCHLD; 2122 #endif 2123 return 0; 2124 } 2125 2126 static SV* sig_sv; 2127 2128 Signal_t 2129 Perl_sighandler(int sig) 2130 { 2131 #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) 2132 dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */ 2133 #else 2134 dTHX; 2135 #endif 2136 dSP; 2137 GV *gv = Nullgv; 2138 HV *st; 2139 SV *sv, *tSv = PL_Sv; 2140 CV *cv = Nullcv; 2141 OP *myop = PL_op; 2142 U32 flags = 0; 2143 I32 o_save_i = PL_savestack_ix; 2144 XPV *tXpv = PL_Xpv; 2145 2146 #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) 2147 PERL_SET_THX(aTHXo); /* fake TLS, see above */ 2148 #endif 2149 2150 if (PL_savestack_ix + 15 <= PL_savestack_max) 2151 flags |= 1; 2152 if (PL_markstack_ptr < PL_markstack_max - 2) 2153 flags |= 4; 2154 if (PL_retstack_ix < PL_retstack_max - 2) 2155 flags |= 8; 2156 if (PL_scopestack_ix < PL_scopestack_max - 3) 2157 flags |= 16; 2158 2159 if (!PL_psig_ptr[sig]) 2160 Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n", 2161 PL_sig_name[sig]); 2162 2163 /* Max number of items pushed there is 3*n or 4. We cannot fix 2164 infinity, so we fix 4 (in fact 5): */ 2165 if (flags & 1) { 2166 PL_savestack_ix += 5; /* Protect save in progress. */ 2167 o_save_i = PL_savestack_ix; 2168 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags); 2169 } 2170 if (flags & 4) 2171 PL_markstack_ptr++; /* Protect mark. */ 2172 if (flags & 8) { 2173 PL_retstack_ix++; 2174 PL_retstack[PL_retstack_ix] = NULL; 2175 } 2176 if (flags & 16) 2177 PL_scopestack_ix += 1; 2178 /* sv_2cv is too complicated, try a simpler variant first: */ 2179 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) 2180 || SvTYPE(cv) != SVt_PVCV) 2181 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); 2182 2183 if (!cv || !CvROOT(cv)) { 2184 if (ckWARN(WARN_SIGNAL)) 2185 Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n", 2186 PL_sig_name[sig], (gv ? GvENAME(gv) 2187 : ((cv && CvGV(cv)) 2188 ? GvENAME(CvGV(cv)) 2189 : "__ANON__"))); 2190 goto cleanup; 2191 } 2192 2193 if(PL_psig_name[sig]) { 2194 sv = SvREFCNT_inc(PL_psig_name[sig]); 2195 flags |= 64; 2196 sig_sv = sv; 2197 } else { 2198 sv = sv_newmortal(); 2199 sv_setpv(sv,PL_sig_name[sig]); 2200 } 2201 2202 PUSHSTACKi(PERLSI_SIGNAL); 2203 PUSHMARK(SP); 2204 PUSHs(sv); 2205 PUTBACK; 2206 2207 call_sv((SV*)cv, G_DISCARD); 2208 2209 POPSTACK; 2210 cleanup: 2211 if (flags & 1) 2212 PL_savestack_ix -= 8; /* Unprotect save in progress. */ 2213 if (flags & 4) 2214 PL_markstack_ptr--; 2215 if (flags & 8) 2216 PL_retstack_ix--; 2217 if (flags & 16) 2218 PL_scopestack_ix -= 1; 2219 if (flags & 64) 2220 SvREFCNT_dec(sv); 2221 PL_op = myop; /* Apparently not needed... */ 2222 2223 PL_Sv = tSv; /* Restore global temporaries. */ 2224 PL_Xpv = tXpv; 2225 return; 2226 } 2227 2228 2229 #ifdef PERL_OBJECT 2230 #include "XSUB.h" 2231 #endif 2232 2233 static void 2234 restore_magic(pTHXo_ void *p) 2235 { 2236 MGS* mgs = SSPTR(PTR2IV(p), MGS*); 2237 SV* sv = mgs->mgs_sv; 2238 2239 if (!sv) 2240 return; 2241 2242 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) 2243 { 2244 if (mgs->mgs_flags) 2245 SvFLAGS(sv) |= mgs->mgs_flags; 2246 else 2247 mg_magical(sv); 2248 if (SvGMAGICAL(sv)) 2249 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); 2250 } 2251 2252 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ 2253 2254 /* If we're still on top of the stack, pop us off. (That condition 2255 * will be satisfied if restore_magic was called explicitly, but *not* 2256 * if it's being called via leave_scope.) 2257 * The reason for doing this is that otherwise, things like sv_2cv() 2258 * may leave alloc gunk on the savestack, and some code 2259 * (e.g. sighandler) doesn't expect that... 2260 */ 2261 if (PL_savestack_ix == mgs->mgs_ss_ix) 2262 { 2263 I32 popval = SSPOPINT; 2264 assert(popval == SAVEt_DESTRUCTOR_X); 2265 PL_savestack_ix -= 2; 2266 popval = SSPOPINT; 2267 assert(popval == SAVEt_ALLOC); 2268 popval = SSPOPINT; 2269 PL_savestack_ix -= popval; 2270 } 2271 2272 } 2273 2274 static void 2275 unwind_handler_stack(pTHXo_ void *p) 2276 { 2277 U32 flags = *(U32*)p; 2278 2279 if (flags & 1) 2280 PL_savestack_ix -= 5; /* Unprotect save in progress. */ 2281 /* cxstack_ix-- Not needed, die already unwound it. */ 2282 if (flags & 64) 2283 SvREFCNT_dec(sig_sv); 2284 } 2285