1 /* mg.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"] 16 */ 17 18 /* 19 =head1 Magical Functions 20 "Magic" is special data attached to SV structures in order to give them 21 "magical" properties. When any Perl code tries to read from, or assign to, 22 an SV marked as magical, it calls the 'get' or 'set' function associated 23 with that SV's magic. A get is called prior to reading an SV, in order to 24 give it a chance to update its internal value (get on $. writes the line 25 number of the last read filehandle into the SV's IV slot), while 26 set is called after an SV has been written to, in order to allow it to make 27 use of its changed value (set on $/ copies the SV's new value to the 28 PL_rs global variable). 29 30 Magic is implemented as a linked list of MAGIC structures attached to the 31 SV. Each MAGIC struct holds the type of the magic, a pointer to an array 32 of functions that implement the get(), set(), length() etc functions, 33 plus space for some flags and pointers. For example, a tied variable has 34 a MAGIC structure that contains a pointer to the object associated with the 35 tie. 36 37 =cut 38 39 */ 40 41 #include "EXTERN.h" 42 #define PERL_IN_MG_C 43 #include "perl.h" 44 #include "feature.h" 45 46 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) 47 # ifdef I_GRP 48 # include <grp.h> 49 # endif 50 #endif 51 52 #if defined(HAS_SETGROUPS) 53 # ifndef NGROUPS 54 # define NGROUPS 32 55 # endif 56 #endif 57 58 #ifdef __hpux 59 # include <sys/pstat.h> 60 #endif 61 62 #ifdef HAS_PRCTL_SET_NAME 63 # include <sys/prctl.h> 64 #endif 65 66 #ifdef __Lynx__ 67 /* Missing protos on LynxOS */ 68 void setruid(uid_t id); 69 void seteuid(uid_t id); 70 void setrgid(uid_t id); 71 void setegid(uid_t id); 72 #endif 73 74 /* 75 * Pre-magic setup and post-magic takedown. 76 * Use the "DESTRUCTOR" scope cleanup to reinstate magic. 77 */ 78 79 struct magic_state { 80 SV* mgs_sv; 81 I32 mgs_ss_ix; 82 U32 mgs_flags; 83 bool mgs_bumped; 84 }; 85 /* MGS is typedef'ed to struct magic_state in perl.h */ 86 87 STATIC void 88 S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) 89 { 90 MGS* mgs; 91 bool bumped = FALSE; 92 93 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS; 94 95 assert(SvMAGICAL(sv)); 96 97 /* we shouldn't really be called here with RC==0, but it can sometimes 98 * happen via mg_clear() (which also shouldn't be called when RC==0, 99 * but it can happen). Handle this case gracefully(ish) by not RC++ 100 * and thus avoiding the resultant double free */ 101 if (SvREFCNT(sv) > 0) { 102 /* guard against sv getting freed midway through the mg clearing, 103 * by holding a private reference for the duration. */ 104 SvREFCNT_inc_simple_void_NN(sv); 105 bumped = TRUE; 106 } 107 108 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); 109 110 mgs = SSPTR(mgs_ix, MGS*); 111 mgs->mgs_sv = sv; 112 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); 113 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ 114 mgs->mgs_bumped = bumped; 115 116 SvFLAGS(sv) &= ~flags; 117 SvREADONLY_off(sv); 118 } 119 120 #define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG) 121 122 /* 123 =for apidoc mg_magical 124 125 Turns on the magical status of an SV. See C<L</sv_magic>>. 126 127 =cut 128 */ 129 130 void 131 Perl_mg_magical(SV *sv) 132 { 133 const MAGIC* mg; 134 PERL_ARGS_ASSERT_MG_MAGICAL; 135 136 SvMAGICAL_off(sv); 137 if ((mg = SvMAGIC(sv))) { 138 do { 139 const MGVTBL* const vtbl = mg->mg_virtual; 140 if (vtbl) { 141 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) 142 SvGMAGICAL_on(sv); 143 if (vtbl->svt_set) 144 SvSMAGICAL_on(sv); 145 if (vtbl->svt_clear) 146 SvRMAGICAL_on(sv); 147 } 148 } while ((mg = mg->mg_moremagic)); 149 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) 150 SvRMAGICAL_on(sv); 151 } 152 } 153 154 /* 155 =for apidoc mg_get 156 157 Do magic before a value is retrieved from the SV. The type of SV must 158 be >= C<SVt_PVMG>. See C<L</sv_magic>>. 159 160 =cut 161 */ 162 163 int 164 Perl_mg_get(pTHX_ SV *sv) 165 { 166 const I32 mgs_ix = SSNEW(sizeof(MGS)); 167 bool saved = FALSE; 168 bool have_new = 0; 169 bool taint_only = TRUE; /* the only get method seen is taint */ 170 MAGIC *newmg, *head, *cur, *mg; 171 172 PERL_ARGS_ASSERT_MG_GET; 173 174 if (PL_localizing == 1 && sv == DEFSV) return 0; 175 176 /* We must call svt_get(sv, mg) for each valid entry in the linked 177 list of magic. svt_get() may delete the current entry, add new 178 magic to the head of the list, or upgrade the SV. AMS 20010810 */ 179 180 newmg = cur = head = mg = SvMAGIC(sv); 181 while (mg) { 182 const MGVTBL * const vtbl = mg->mg_virtual; 183 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ 184 185 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { 186 187 /* taint's mg get is so dumb it doesn't need flag saving */ 188 if (mg->mg_type != PERL_MAGIC_taint) { 189 taint_only = FALSE; 190 if (!saved) { 191 save_magic(mgs_ix, sv); 192 saved = TRUE; 193 } 194 } 195 196 vtbl->svt_get(aTHX_ sv, mg); 197 198 /* guard against magic having been deleted - eg FETCH calling 199 * untie */ 200 if (!SvMAGIC(sv)) { 201 /* recalculate flags */ 202 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); 203 break; 204 } 205 206 /* recalculate flags if this entry was deleted. */ 207 if (mg->mg_flags & MGf_GSKIP) 208 (SSPTR(mgs_ix, MGS *))->mgs_flags &= 209 ~(SVs_GMG|SVs_SMG|SVs_RMG); 210 } 211 else if (vtbl == &PL_vtbl_utf8) { 212 /* get-magic can reallocate the PV, unless there's only taint 213 * magic */ 214 if (taint_only) { 215 MAGIC *mg2; 216 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) { 217 if ( mg2->mg_type != PERL_MAGIC_taint 218 && !(mg2->mg_flags & MGf_GSKIP) 219 && mg2->mg_virtual 220 && mg2->mg_virtual->svt_get 221 ) { 222 taint_only = FALSE; 223 break; 224 } 225 } 226 } 227 if (!taint_only) 228 magic_setutf8(sv, mg); 229 } 230 231 mg = nextmg; 232 233 if (have_new) { 234 /* Have we finished with the new entries we saw? Start again 235 where we left off (unless there are more new entries). */ 236 if (mg == head) { 237 have_new = 0; 238 mg = cur; 239 head = newmg; 240 } 241 } 242 243 /* Were any new entries added? */ 244 if (!have_new && (newmg = SvMAGIC(sv)) != head) { 245 have_new = 1; 246 cur = mg; 247 mg = newmg; 248 /* recalculate flags */ 249 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); 250 } 251 } 252 253 if (saved) 254 restore_magic(INT2PTR(void *, (IV)mgs_ix)); 255 256 return 0; 257 } 258 259 /* 260 =for apidoc mg_set 261 262 Do magic after a value is assigned to the SV. See C<L</sv_magic>>. 263 264 =cut 265 */ 266 267 int 268 Perl_mg_set(pTHX_ SV *sv) 269 { 270 const I32 mgs_ix = SSNEW(sizeof(MGS)); 271 MAGIC* mg; 272 MAGIC* nextmg; 273 274 PERL_ARGS_ASSERT_MG_SET; 275 276 if (PL_localizing == 2 && sv == DEFSV) return 0; 277 278 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */ 279 280 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 281 const MGVTBL* vtbl = mg->mg_virtual; 282 nextmg = mg->mg_moremagic; /* it may delete itself */ 283 if (mg->mg_flags & MGf_GSKIP) { 284 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ 285 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); 286 } 287 if (PL_localizing == 2 288 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) 289 continue; 290 if (vtbl && vtbl->svt_set) 291 vtbl->svt_set(aTHX_ sv, mg); 292 } 293 294 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 295 return 0; 296 } 297 298 /* 299 =for apidoc mg_length 300 301 Reports on the SV's length in bytes, calling length magic if available, 302 but does not set the UTF8 flag on C<sv>. It will fall back to 'get' 303 magic if there is no 'length' magic, but with no indication as to 304 whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or 305 higher. Use C<sv_len()> instead. 306 307 =cut 308 */ 309 310 U32 311 Perl_mg_length(pTHX_ SV *sv) 312 { 313 MAGIC* mg; 314 STRLEN len; 315 316 PERL_ARGS_ASSERT_MG_LENGTH; 317 318 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 319 const MGVTBL * const vtbl = mg->mg_virtual; 320 if (vtbl && vtbl->svt_len) { 321 const I32 mgs_ix = SSNEW(sizeof(MGS)); 322 save_magic(mgs_ix, sv); 323 /* omit MGf_GSKIP -- not changed here */ 324 len = vtbl->svt_len(aTHX_ sv, mg); 325 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 326 return len; 327 } 328 } 329 330 (void)SvPV_const(sv, len); 331 return len; 332 } 333 334 I32 335 Perl_mg_size(pTHX_ SV *sv) 336 { 337 MAGIC* mg; 338 339 PERL_ARGS_ASSERT_MG_SIZE; 340 341 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 342 const MGVTBL* const vtbl = mg->mg_virtual; 343 if (vtbl && vtbl->svt_len) { 344 const I32 mgs_ix = SSNEW(sizeof(MGS)); 345 I32 len; 346 save_magic(mgs_ix, sv); 347 /* omit MGf_GSKIP -- not changed here */ 348 len = vtbl->svt_len(aTHX_ sv, mg); 349 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 350 return len; 351 } 352 } 353 354 switch(SvTYPE(sv)) { 355 case SVt_PVAV: 356 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ 357 case SVt_PVHV: 358 /* FIXME */ 359 default: 360 Perl_croak(aTHX_ "Size magic not implemented"); 361 362 } 363 NOT_REACHED; /* NOTREACHED */ 364 } 365 366 /* 367 =for apidoc mg_clear 368 369 Clear something magical that the SV represents. See C<L</sv_magic>>. 370 371 =cut 372 */ 373 374 int 375 Perl_mg_clear(pTHX_ SV *sv) 376 { 377 const I32 mgs_ix = SSNEW(sizeof(MGS)); 378 MAGIC* mg; 379 MAGIC *nextmg; 380 381 PERL_ARGS_ASSERT_MG_CLEAR; 382 383 save_magic(mgs_ix, sv); 384 385 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 386 const MGVTBL* const vtbl = mg->mg_virtual; 387 /* omit GSKIP -- never set here */ 388 389 nextmg = mg->mg_moremagic; /* it may delete itself */ 390 391 if (vtbl && vtbl->svt_clear) 392 vtbl->svt_clear(aTHX_ sv, mg); 393 } 394 395 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 396 return 0; 397 } 398 399 static MAGIC* 400 S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) 401 { 402 assert(flags <= 1); 403 404 if (sv) { 405 MAGIC *mg; 406 407 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 408 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { 409 return mg; 410 } 411 } 412 } 413 414 return NULL; 415 } 416 417 /* 418 =for apidoc mg_find 419 420 Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>. 421 422 =cut 423 */ 424 425 MAGIC* 426 Perl_mg_find(const SV *sv, int type) 427 { 428 return S_mg_findext_flags(sv, type, NULL, 0); 429 } 430 431 /* 432 =for apidoc mg_findext 433 434 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See 435 C<L</sv_magicext>>. 436 437 =cut 438 */ 439 440 MAGIC* 441 Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl) 442 { 443 return S_mg_findext_flags(sv, type, vtbl, 1); 444 } 445 446 MAGIC * 447 Perl_mg_find_mglob(pTHX_ SV *sv) 448 { 449 PERL_ARGS_ASSERT_MG_FIND_MGLOB; 450 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 451 /* This sv is only a delegate. //g magic must be attached to 452 its target. */ 453 vivify_defelem(sv); 454 sv = LvTARG(sv); 455 } 456 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) 457 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0); 458 return NULL; 459 } 460 461 /* 462 =for apidoc mg_copy 463 464 Copies the magic from one SV to another. See C<L</sv_magic>>. 465 466 =cut 467 */ 468 469 int 470 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) 471 { 472 int count = 0; 473 MAGIC* mg; 474 475 PERL_ARGS_ASSERT_MG_COPY; 476 477 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 478 const MGVTBL* const vtbl = mg->mg_virtual; 479 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ 480 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); 481 } 482 else { 483 const char type = mg->mg_type; 484 if (isUPPER(type) && type != PERL_MAGIC_uvar) { 485 sv_magic(nsv, 486 (type == PERL_MAGIC_tied) 487 ? SvTIED_obj(sv, mg) 488 : mg->mg_obj, 489 toLOWER(type), key, klen); 490 count++; 491 } 492 } 493 } 494 return count; 495 } 496 497 /* 498 =for apidoc mg_localize 499 500 Copy some of the magic from an existing SV to new localized version of that 501 SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>) 502 gets copied, value magic doesn't (I<e.g.>, 503 C<taint>, C<pos>). 504 505 If C<setmagic> is false then no set magic will be called on the new (empty) SV. 506 This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>), 507 and that will handle the magic. 508 509 =cut 510 */ 511 512 void 513 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) 514 { 515 MAGIC *mg; 516 517 PERL_ARGS_ASSERT_MG_LOCALIZE; 518 519 if (nsv == DEFSV) 520 return; 521 522 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 523 const MGVTBL* const vtbl = mg->mg_virtual; 524 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) 525 continue; 526 527 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) 528 (void)vtbl->svt_local(aTHX_ nsv, mg); 529 else 530 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, 531 mg->mg_ptr, mg->mg_len); 532 533 /* container types should remain read-only across localization */ 534 SvFLAGS(nsv) |= SvREADONLY(sv); 535 } 536 537 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { 538 SvFLAGS(nsv) |= SvMAGICAL(sv); 539 if (setmagic) { 540 PL_localizing = 1; 541 SvSETMAGIC(nsv); 542 PL_localizing = 0; 543 } 544 } 545 } 546 547 #define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg) 548 static void 549 S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) 550 { 551 const MGVTBL* const vtbl = mg->mg_virtual; 552 if (vtbl && vtbl->svt_free) 553 vtbl->svt_free(aTHX_ sv, mg); 554 555 if (mg->mg_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0) 556 /* collate magic uses string len not buffer len, so 557 * free even with mg_len == 0 */ 558 Safefree(mg->mg_ptr); 559 else if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 560 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) 561 Safefree(mg->mg_ptr); 562 else if (mg->mg_len == HEf_SVKEY) 563 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); 564 } 565 566 if (mg->mg_flags & MGf_REFCOUNTED) 567 SvREFCNT_dec(mg->mg_obj); 568 Safefree(mg); 569 } 570 571 /* 572 =for apidoc mg_free 573 574 Free any magic storage used by the SV. See C<L</sv_magic>>. 575 576 =cut 577 */ 578 579 int 580 Perl_mg_free(pTHX_ SV *sv) 581 { 582 MAGIC* mg; 583 MAGIC* moremagic; 584 585 PERL_ARGS_ASSERT_MG_FREE; 586 587 for (mg = SvMAGIC(sv); mg; mg = moremagic) { 588 moremagic = mg->mg_moremagic; 589 mg_free_struct(sv, mg); 590 SvMAGIC_set(sv, moremagic); 591 } 592 SvMAGIC_set(sv, NULL); 593 SvMAGICAL_off(sv); 594 return 0; 595 } 596 597 /* 598 =for apidoc mg_free_type 599 600 Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>. 601 602 =cut 603 */ 604 605 void 606 Perl_mg_free_type(pTHX_ SV *sv, int how) 607 { 608 MAGIC *mg, *prevmg, *moremg; 609 PERL_ARGS_ASSERT_MG_FREE_TYPE; 610 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { 611 moremg = mg->mg_moremagic; 612 if (mg->mg_type == how) { 613 MAGIC *newhead; 614 /* temporarily move to the head of the magic chain, in case 615 custom free code relies on this historical aspect of mg_free */ 616 if (prevmg) { 617 prevmg->mg_moremagic = moremg; 618 mg->mg_moremagic = SvMAGIC(sv); 619 SvMAGIC_set(sv, mg); 620 } 621 newhead = mg->mg_moremagic; 622 mg_free_struct(sv, mg); 623 SvMAGIC_set(sv, newhead); 624 mg = prevmg; 625 } 626 } 627 mg_magical(sv); 628 } 629 630 /* 631 =for apidoc mg_freeext 632 633 Remove any magic of type C<how> using virtual table C<vtbl> from the 634 SV C<sv>. See L</sv_magic>. 635 636 C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>. 637 638 =cut 639 */ 640 641 void 642 Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl) 643 { 644 MAGIC *mg, *prevmg, *moremg; 645 PERL_ARGS_ASSERT_MG_FREEEXT; 646 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { 647 MAGIC *newhead; 648 moremg = mg->mg_moremagic; 649 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { 650 /* temporarily move to the head of the magic chain, in case 651 custom free code relies on this historical aspect of mg_free */ 652 if (prevmg) { 653 prevmg->mg_moremagic = moremg; 654 mg->mg_moremagic = SvMAGIC(sv); 655 SvMAGIC_set(sv, mg); 656 } 657 newhead = mg->mg_moremagic; 658 mg_free_struct(sv, mg); 659 SvMAGIC_set(sv, newhead); 660 mg = prevmg; 661 } 662 } 663 mg_magical(sv); 664 } 665 666 #include <signal.h> 667 668 U32 669 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) 670 { 671 PERL_UNUSED_ARG(sv); 672 673 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; 674 675 if (PL_curpm) { 676 REGEXP * const rx = PM_GETRE(PL_curpm); 677 if (rx) { 678 const SSize_t n = (SSize_t)mg->mg_obj; 679 if (n == '+') { /* @+ */ 680 /* return the number possible */ 681 return RX_NPARENS(rx); 682 } else { /* @- @^CAPTURE @{^CAPTURE} */ 683 I32 paren = RX_LASTPAREN(rx); 684 685 /* return the last filled */ 686 while ( paren >= 0 687 && (RX_OFFS(rx)[paren].start == -1 688 || RX_OFFS(rx)[paren].end == -1) ) 689 paren--; 690 if (n == '-') { 691 /* @- */ 692 return (U32)paren; 693 } else { 694 /* @^CAPTURE @{^CAPTURE} */ 695 return paren >= 0 ? (U32)(paren-1) : (U32)-1; 696 } 697 } 698 } 699 } 700 701 return (U32)-1; 702 } 703 704 /* @-, @+ */ 705 706 int 707 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) 708 { 709 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; 710 711 if (PL_curpm) { 712 REGEXP * const rx = PM_GETRE(PL_curpm); 713 if (rx) { 714 const SSize_t n = (SSize_t)mg->mg_obj; 715 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ 716 const I32 paren = mg->mg_len 717 + (n == '\003' ? 1 : 0); 718 SSize_t s; 719 SSize_t t; 720 if (paren < 0) 721 return 0; 722 if (paren <= (I32)RX_NPARENS(rx) && 723 (s = RX_OFFS(rx)[paren].start) != -1 && 724 (t = RX_OFFS(rx)[paren].end) != -1) 725 { 726 SSize_t i; 727 728 if (n == '+') /* @+ */ 729 i = t; 730 else if (n == '-') /* @- */ 731 i = s; 732 else { /* @^CAPTURE @{^CAPTURE} */ 733 CALLREG_NUMBUF_FETCH(rx,paren,sv); 734 return 0; 735 } 736 737 if (RX_MATCH_UTF8(rx)) { 738 const char * const b = RX_SUBBEG(rx); 739 if (b) 740 i = RX_SUBCOFFSET(rx) + 741 utf8_length((U8*)b, 742 (U8*)(b-RX_SUBOFFSET(rx)+i)); 743 } 744 745 sv_setuv(sv, i); 746 return 0; 747 } 748 } 749 } 750 sv_set_undef(sv); 751 return 0; 752 } 753 754 /* @-, @+ */ 755 756 int 757 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) 758 { 759 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET; 760 PERL_UNUSED_CONTEXT; 761 PERL_UNUSED_ARG(sv); 762 PERL_UNUSED_ARG(mg); 763 Perl_croak_no_modify(); 764 NORETURN_FUNCTION_END; 765 } 766 767 #define SvRTRIM(sv) STMT_START { \ 768 if (SvPOK(sv)) { \ 769 STRLEN len = SvCUR(sv); \ 770 char * const p = SvPVX(sv); \ 771 while (len > 0 && isSPACE(p[len-1])) \ 772 --len; \ 773 SvCUR_set(sv, len); \ 774 p[len] = '\0'; \ 775 } \ 776 } STMT_END 777 778 void 779 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) 780 { 781 PERL_ARGS_ASSERT_EMULATE_COP_IO; 782 783 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) 784 sv_set_undef(sv); 785 else { 786 SvPVCLEAR(sv); 787 SvUTF8_off(sv); 788 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { 789 SV *const value = cop_hints_fetch_pvs(c, "open<", 0); 790 assert(value); 791 sv_catsv(sv, value); 792 } 793 sv_catpvs(sv, "\0"); 794 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { 795 SV *const value = cop_hints_fetch_pvs(c, "open>", 0); 796 assert(value); 797 sv_catsv(sv, value); 798 } 799 } 800 } 801 802 STATIC void 803 S_fixup_errno_string(pTHX_ SV* sv) 804 { 805 /* Do what is necessary to fixup the non-empty string in 'sv' for return to 806 * Perl space. */ 807 808 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING; 809 810 assert(SvOK(sv)); 811 812 if(strEQ(SvPVX(sv), "")) { 813 sv_catpv(sv, UNKNOWN_ERRNO_MSG); 814 } 815 else { 816 817 /* In some locales the error string may come back as UTF-8, in which 818 * case we should turn on that flag. This didn't use to happen, and to 819 * avoid as many possible backward compatibility issues as possible, we 820 * don't turn on the flag unless we have to. So the flag stays off for 821 * an entirely invariant string. We assume that if the string looks 822 * like UTF-8 in a single script, it really is UTF-8: "text in any 823 * other encoding that uses bytes with the high bit set is extremely 824 * unlikely to pass a UTF-8 validity test" 825 * (http://en.wikipedia.org/wiki/Charset_detection). There is a 826 * potential that we will get it wrong however, especially on short 827 * error message text, so do an additional check. */ 828 if ( ! IN_BYTES /* respect 'use bytes' */ 829 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv)) 830 831 #ifdef USE_LOCALE_MESSAGES 832 833 && _is_cur_LC_category_utf8(LC_MESSAGES) 834 835 #else /* If can't check directly, at least can see if script is consistent, 836 under UTF-8, which gives us an extra measure of confidence. */ 837 838 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv), 839 TRUE) /* Means assume UTF-8 */ 840 #endif 841 842 ) { 843 SvUTF8_on(sv); 844 } 845 } 846 } 847 848 /* 849 =for apidoc sv_string_from_errnum 850 851 Generates the message string describing an OS error and returns it as 852 an SV. C<errnum> must be a value that C<errno> could take, identifying 853 the type of error. 854 855 If C<tgtsv> is non-null then the string will be written into that SV 856 (overwriting existing content) and it will be returned. If C<tgtsv> 857 is a null pointer then the string will be written into a new mortal SV 858 which will be returned. 859 860 The message will be taken from whatever locale would be used by C<$!>, 861 and will be encoded in the SV in whatever manner would be used by C<$!>. 862 The details of this process are subject to future change. Currently, 863 the message is taken from the C locale by default (usually producing an 864 English message), and from the currently selected locale when in the scope 865 of the C<use locale> pragma. A heuristic attempt is made to decode the 866 message from the locale's character encoding, but it will only be decoded 867 as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8 868 locale, usually in an ISO-8859-1 locale, and never in any other locale. 869 870 The SV is always returned containing an actual string, and with no other 871 OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero 872 (meaning success), and if no useful message is available then a useless 873 string (currently empty) is returned. 874 875 =cut 876 */ 877 878 SV * 879 Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv) 880 { 881 char const *errstr; 882 if(!tgtsv) 883 tgtsv = sv_newmortal(); 884 errstr = my_strerror(errnum); 885 if(errstr) { 886 sv_setpv(tgtsv, errstr); 887 fixup_errno_string(tgtsv); 888 } else { 889 SvPVCLEAR(tgtsv); 890 } 891 return tgtsv; 892 } 893 894 #ifdef VMS 895 #include <descrip.h> 896 #include <starlet.h> 897 #endif 898 899 int 900 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 901 { 902 I32 paren; 903 const char *s = NULL; 904 REGEXP *rx; 905 const char * const remaining = mg->mg_ptr + 1; 906 char nextchar; 907 908 PERL_ARGS_ASSERT_MAGIC_GET; 909 910 if (!mg->mg_ptr) { 911 paren = mg->mg_len; 912 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 913 do_numbuf_fetch: 914 CALLREG_NUMBUF_FETCH(rx,paren,sv); 915 } 916 else 917 goto set_undef; 918 return 0; 919 } 920 921 nextchar = *remaining; 922 switch (*mg->mg_ptr) { 923 case '\001': /* ^A */ 924 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); 925 else 926 sv_set_undef(sv); 927 if (SvTAINTED(PL_bodytarget)) 928 SvTAINTED_on(sv); 929 break; 930 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ 931 if (nextchar == '\0') { 932 sv_setiv(sv, (IV)PL_minus_c); 933 } 934 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { 935 sv_setiv(sv, (IV)STATUS_NATIVE); 936 } 937 break; 938 939 case '\004': /* ^D */ 940 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); 941 break; 942 case '\005': /* ^E */ 943 if (nextchar != '\0') { 944 if (strEQ(remaining, "NCODING")) 945 sv_set_undef(sv); 946 break; 947 } 948 949 #if defined(VMS) || defined(OS2) || defined(WIN32) 950 # if defined(VMS) 951 { 952 char msg[255]; 953 $DESCRIPTOR(msgdsc,msg); 954 sv_setnv(sv,(NV) vaxc$errno); 955 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) 956 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); 957 else 958 SvPVCLEAR(sv); 959 } 960 #elif defined(OS2) 961 if (!(_emx_env & 0x200)) { /* Under DOS */ 962 sv_setnv(sv, (NV)errno); 963 sv_setpv(sv, errno ? my_strerror(errno) : ""); 964 } else { 965 if (errno != errno_isOS2) { 966 const int tmp = _syserrno(); 967 if (tmp) /* 2nd call to _syserrno() makes it 0 */ 968 Perl_rc = tmp; 969 } 970 sv_setnv(sv, (NV)Perl_rc); 971 sv_setpv(sv, os2error(Perl_rc)); 972 } 973 if (SvOK(sv) && strNE(SvPVX(sv), "")) { 974 fixup_errno_string(sv); 975 } 976 # elif defined(WIN32) 977 { 978 const DWORD dwErr = GetLastError(); 979 sv_setnv(sv, (NV)dwErr); 980 if (dwErr) { 981 PerlProc_GetOSError(sv, dwErr); 982 fixup_errno_string(sv); 983 } 984 else 985 SvPVCLEAR(sv); 986 SetLastError(dwErr); 987 } 988 # else 989 # error Missing code for platform 990 # endif 991 SvRTRIM(sv); 992 SvNOK_on(sv); /* what a wonderful hack! */ 993 break; 994 #endif /* End of platforms with special handling for $^E; others just fall 995 through to $! */ 996 /* FALLTHROUGH */ 997 998 case '!': 999 { 1000 dSAVE_ERRNO; 1001 #ifdef VMS 1002 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); 1003 #else 1004 sv_setnv(sv, (NV)errno); 1005 #endif 1006 #ifdef OS2 1007 if (errno == errno_isOS2 || errno == errno_isOS2_set) 1008 sv_setpv(sv, os2error(Perl_rc)); 1009 else 1010 #endif 1011 if (! errno) { 1012 SvPVCLEAR(sv); 1013 } 1014 else { 1015 sv_string_from_errnum(errno, sv); 1016 /* If no useful string is available, don't 1017 * claim to have a string part. The SvNOK_on() 1018 * below will cause just the number part to be valid */ 1019 if (!SvCUR(sv)) 1020 SvPOK_off(sv); 1021 } 1022 RESTORE_ERRNO; 1023 } 1024 1025 SvRTRIM(sv); 1026 SvNOK_on(sv); /* what a wonderful hack! */ 1027 break; 1028 1029 case '\006': /* ^F */ 1030 if (nextchar == '\0') { 1031 sv_setiv(sv, (IV)PL_maxsysfd); 1032 } 1033 break; 1034 case '\007': /* ^GLOBAL_PHASE */ 1035 if (strEQ(remaining, "LOBAL_PHASE")) { 1036 sv_setpvn(sv, PL_phase_names[PL_phase], 1037 strlen(PL_phase_names[PL_phase])); 1038 } 1039 break; 1040 case '\010': /* ^H */ 1041 sv_setuv(sv, PL_hints); 1042 break; 1043 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 1044 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ 1045 break; 1046 case '\014': /* ^LAST_FH */ 1047 if (strEQ(remaining, "AST_FH")) { 1048 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { 1049 assert(isGV_with_GP(PL_last_in_gv)); 1050 SV_CHECK_THINKFIRST_COW_DROP(sv); 1051 prepare_SV_for_RV(sv); 1052 SvOK_off(sv); 1053 SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); 1054 SvROK_on(sv); 1055 sv_rvweaken(sv); 1056 } 1057 else 1058 sv_set_undef(sv); 1059 } 1060 break; 1061 case '\017': /* ^O & ^OPEN */ 1062 if (nextchar == '\0') { 1063 sv_setpv(sv, PL_osname); 1064 SvTAINTED_off(sv); 1065 } 1066 else if (strEQ(remaining, "PEN")) { 1067 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); 1068 } 1069 break; 1070 case '\020': 1071 sv_setiv(sv, (IV)PL_perldb); 1072 break; 1073 case '\023': /* ^S */ 1074 if (nextchar == '\0') { 1075 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) 1076 SvOK_off(sv); 1077 else if (PL_in_eval) 1078 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); 1079 else 1080 sv_setiv(sv, 0); 1081 } 1082 else if (strEQ(remaining, "AFE_LOCALES")) { 1083 1084 #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE) 1085 1086 sv_setuv(sv, (UV) 1); 1087 1088 #else 1089 sv_setuv(sv, (UV) 0); 1090 1091 #endif 1092 1093 } 1094 break; 1095 case '\024': /* ^T */ 1096 if (nextchar == '\0') { 1097 #ifdef BIG_TIME 1098 sv_setnv(sv, PL_basetime); 1099 #else 1100 sv_setiv(sv, (IV)PL_basetime); 1101 #endif 1102 } 1103 else if (strEQ(remaining, "AINT")) 1104 sv_setiv(sv, TAINTING_get 1105 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) 1106 : 0); 1107 break; 1108 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ 1109 if (strEQ(remaining, "NICODE")) 1110 sv_setuv(sv, (UV) PL_unicode); 1111 else if (strEQ(remaining, "TF8LOCALE")) 1112 sv_setuv(sv, (UV) PL_utf8locale); 1113 else if (strEQ(remaining, "TF8CACHE")) 1114 sv_setiv(sv, (IV) PL_utf8cache); 1115 break; 1116 case '\027': /* ^W & $^WARNING_BITS */ 1117 if (nextchar == '\0') 1118 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); 1119 else if (strEQ(remaining, "ARNING_BITS")) { 1120 if (PL_compiling.cop_warnings == pWARN_NONE) { 1121 sv_setpvn(sv, WARN_NONEstring, WARNsize) ; 1122 } 1123 else if (PL_compiling.cop_warnings == pWARN_STD) { 1124 goto set_undef; 1125 } 1126 else if (PL_compiling.cop_warnings == pWARN_ALL) { 1127 sv_setpvn(sv, WARN_ALLstring, WARNsize); 1128 } 1129 else { 1130 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), 1131 *PL_compiling.cop_warnings); 1132 } 1133 } 1134 #ifdef WIN32 1135 else if (strEQ(remaining, "IN32_SLOPPY_STAT")) { 1136 sv_setiv(sv, w32_sloppystat); 1137 } 1138 #endif 1139 break; 1140 case '+': 1141 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1142 paren = RX_LASTPAREN(rx); 1143 if (paren) 1144 goto do_numbuf_fetch; 1145 } 1146 goto set_undef; 1147 case '\016': /* ^N */ 1148 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1149 paren = RX_LASTCLOSEPAREN(rx); 1150 if (paren) 1151 goto do_numbuf_fetch; 1152 } 1153 goto set_undef; 1154 case '.': 1155 if (GvIO(PL_last_in_gv)) { 1156 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); 1157 } 1158 break; 1159 case '?': 1160 { 1161 sv_setiv(sv, (IV)STATUS_CURRENT); 1162 #ifdef COMPLEX_STATUS 1163 SvUPGRADE(sv, SVt_PVLV); 1164 LvTARGOFF(sv) = PL_statusvalue; 1165 LvTARGLEN(sv) = PL_statusvalue_vms; 1166 #endif 1167 } 1168 break; 1169 case '^': 1170 if (GvIOp(PL_defoutgv)) 1171 s = IoTOP_NAME(GvIOp(PL_defoutgv)); 1172 if (s) 1173 sv_setpv(sv,s); 1174 else { 1175 sv_setpv(sv,GvENAME(PL_defoutgv)); 1176 sv_catpvs(sv,"_TOP"); 1177 } 1178 break; 1179 case '~': 1180 if (GvIOp(PL_defoutgv)) 1181 s = IoFMT_NAME(GvIOp(PL_defoutgv)); 1182 if (!s) 1183 s = GvENAME(PL_defoutgv); 1184 sv_setpv(sv,s); 1185 break; 1186 case '=': 1187 if (GvIO(PL_defoutgv)) 1188 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); 1189 break; 1190 case '-': 1191 if (GvIO(PL_defoutgv)) 1192 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); 1193 break; 1194 case '%': 1195 if (GvIO(PL_defoutgv)) 1196 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); 1197 break; 1198 case ':': 1199 case '/': 1200 break; 1201 case '[': 1202 sv_setiv(sv, 0); 1203 break; 1204 case '|': 1205 if (GvIO(PL_defoutgv)) 1206 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); 1207 break; 1208 case '\\': 1209 if (PL_ors_sv) 1210 sv_copypv(sv, PL_ors_sv); 1211 else 1212 goto set_undef; 1213 break; 1214 case '$': /* $$ */ 1215 { 1216 IV const pid = (IV)PerlProc_getpid(); 1217 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { 1218 /* never set manually, or at least not since last fork */ 1219 sv_setiv(sv, pid); 1220 /* never unsafe, even if reading in a tainted expression */ 1221 SvTAINTED_off(sv); 1222 } 1223 /* else a value has been assigned manually, so do nothing */ 1224 } 1225 break; 1226 case '<': 1227 sv_setuid(sv, PerlProc_getuid()); 1228 break; 1229 case '>': 1230 sv_setuid(sv, PerlProc_geteuid()); 1231 break; 1232 case '(': 1233 sv_setgid(sv, PerlProc_getgid()); 1234 goto add_groups; 1235 case ')': 1236 sv_setgid(sv, PerlProc_getegid()); 1237 add_groups: 1238 #ifdef HAS_GETGROUPS 1239 { 1240 Groups_t *gary = NULL; 1241 I32 num_groups = getgroups(0, gary); 1242 if (num_groups > 0) { 1243 I32 i; 1244 Newx(gary, num_groups, Groups_t); 1245 num_groups = getgroups(num_groups, gary); 1246 for (i = 0; i < num_groups; i++) 1247 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]); 1248 Safefree(gary); 1249 } 1250 } 1251 (void)SvIOK_on(sv); /* what a wonderful hack! */ 1252 #endif 1253 break; 1254 case '0': 1255 break; 1256 } 1257 return 0; 1258 1259 set_undef: 1260 sv_set_undef(sv); 1261 return 0; 1262 } 1263 1264 int 1265 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) 1266 { 1267 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 1268 1269 PERL_ARGS_ASSERT_MAGIC_GETUVAR; 1270 1271 if (uf && uf->uf_val) 1272 (*uf->uf_val)(aTHX_ uf->uf_index, sv); 1273 return 0; 1274 } 1275 1276 int 1277 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) 1278 { 1279 STRLEN len = 0, klen; 1280 const char * const key = MgPV_const(mg,klen); 1281 const char *s = ""; 1282 1283 PERL_ARGS_ASSERT_MAGIC_SETENV; 1284 1285 SvGETMAGIC(sv); 1286 if (SvOK(sv)) { 1287 /* defined environment variables are byte strings; unfortunately 1288 there is no SvPVbyte_force_nomg(), so we must do this piecewise */ 1289 (void)SvPV_force_nomg_nolen(sv); 1290 sv_utf8_downgrade(sv, /* fail_ok */ TRUE); 1291 if (SvUTF8(sv)) { 1292 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv"); 1293 SvUTF8_off(sv); 1294 } 1295 s = SvPVX(sv); 1296 len = SvCUR(sv); 1297 } 1298 my_setenv(key, s); /* does the deed */ 1299 1300 #ifdef DYNAMIC_ENV_FETCH 1301 /* We just undefd an environment var. Is a replacement */ 1302 /* waiting in the wings? */ 1303 if (!len) { 1304 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); 1305 if (valp) 1306 s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; 1307 } 1308 #endif 1309 1310 #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS) 1311 /* And you'll never guess what the dog had */ 1312 /* in its mouth... */ 1313 if (TAINTING_get) { 1314 MgTAINTEDDIR_off(mg); 1315 #ifdef VMS 1316 if (s && memEQs(key, klen, "DCL$PATH")) { 1317 char pathbuf[256], eltbuf[256], *cp, *elt; 1318 int i = 0, j = 0; 1319 1320 my_strlcpy(eltbuf, s, sizeof(eltbuf)); 1321 elt = eltbuf; 1322 do { /* DCL$PATH may be a search list */ 1323 while (1) { /* as may dev portion of any element */ 1324 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { 1325 if ( *(cp+1) == '.' || *(cp+1) == '-' || 1326 cando_by_name(S_IWUSR,0,elt) ) { 1327 MgTAINTEDDIR_on(mg); 1328 return 0; 1329 } 1330 } 1331 if ((cp = strchr(elt, ':')) != NULL) 1332 *cp = '\0'; 1333 if (my_trnlnm(elt, eltbuf, j++)) 1334 elt = eltbuf; 1335 else 1336 break; 1337 } 1338 j = 0; 1339 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); 1340 } 1341 #endif /* VMS */ 1342 if (s && memEQs(key, klen, "PATH")) { 1343 const char * const strend = s + len; 1344 1345 /* set MGf_TAINTEDDIR if any component of the new path is 1346 * relative or world-writeable */ 1347 while (s < strend) { 1348 char tmpbuf[256]; 1349 Stat_t st; 1350 I32 i; 1351 #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */ 1352 const char path_sep = PL_perllib_sep; 1353 #else 1354 const char path_sep = ':'; 1355 #endif 1356 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, 1357 s, strend, path_sep, &i); 1358 s++; 1359 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ 1360 #ifdef __VMS 1361 /* no colon thus no device name -- assume relative path */ 1362 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) 1363 /* Using Unix separator, e.g. under bash, so act line Unix */ 1364 || (PL_perllib_sep == ':' && *tmpbuf != '/') 1365 #else 1366 || *tmpbuf != '/' /* no starting slash -- assume relative path */ 1367 #endif 1368 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { 1369 MgTAINTEDDIR_on(mg); 1370 return 0; 1371 } 1372 } 1373 } 1374 } 1375 #endif /* neither OS2 nor WIN32 nor MSDOS */ 1376 1377 return 0; 1378 } 1379 1380 int 1381 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) 1382 { 1383 PERL_ARGS_ASSERT_MAGIC_CLEARENV; 1384 PERL_UNUSED_ARG(sv); 1385 my_setenv(MgPV_nolen_const(mg),NULL); 1386 return 0; 1387 } 1388 1389 int 1390 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) 1391 { 1392 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV; 1393 PERL_UNUSED_ARG(mg); 1394 #if defined(VMS) 1395 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1396 #else 1397 if (PL_localizing) { 1398 HE* entry; 1399 my_clearenv(); 1400 hv_iterinit(MUTABLE_HV(sv)); 1401 while ((entry = hv_iternext(MUTABLE_HV(sv)))) { 1402 I32 keylen; 1403 my_setenv(hv_iterkey(entry, &keylen), 1404 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); 1405 } 1406 } 1407 #endif 1408 return 0; 1409 } 1410 1411 int 1412 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 1413 { 1414 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV; 1415 PERL_UNUSED_ARG(sv); 1416 PERL_UNUSED_ARG(mg); 1417 #if defined(VMS) 1418 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); 1419 #else 1420 my_clearenv(); 1421 #endif 1422 return 0; 1423 } 1424 1425 #ifndef PERL_MICRO 1426 #ifdef HAS_SIGPROCMASK 1427 static void 1428 restore_sigmask(pTHX_ SV *save_sv) 1429 { 1430 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); 1431 (void)sigprocmask(SIG_SETMASK, ossetp, NULL); 1432 } 1433 #endif 1434 int 1435 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 1436 { 1437 /* Are we fetching a signal entry? */ 1438 int i = (I16)mg->mg_private; 1439 1440 PERL_ARGS_ASSERT_MAGIC_GETSIG; 1441 1442 if (!i) { 1443 STRLEN siglen; 1444 const char * sig = MgPV_const(mg, siglen); 1445 mg->mg_private = i = whichsig_pvn(sig, siglen); 1446 } 1447 1448 if (i > 0) { 1449 if(PL_psig_ptr[i]) 1450 sv_setsv(sv,PL_psig_ptr[i]); 1451 else { 1452 Sighandler_t sigstate = rsignal_state(i); 1453 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1454 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) 1455 sigstate = SIG_IGN; 1456 #endif 1457 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1458 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) 1459 sigstate = SIG_DFL; 1460 #endif 1461 /* cache state so we don't fetch it again */ 1462 if(sigstate == (Sighandler_t) SIG_IGN) 1463 sv_setpvs(sv,"IGNORE"); 1464 else 1465 sv_set_undef(sv); 1466 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); 1467 SvTEMP_off(sv); 1468 } 1469 } 1470 return 0; 1471 } 1472 int 1473 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 1474 { 1475 PERL_ARGS_ASSERT_MAGIC_CLEARSIG; 1476 1477 magic_setsig(NULL, mg); 1478 return sv_unmagic(sv, mg->mg_type); 1479 } 1480 1481 1482 #ifdef PERL_USE_3ARG_SIGHANDLER 1483 Signal_t 1484 Perl_csighandler(int sig, Siginfo_t *sip, void *uap) 1485 { 1486 Perl_csighandler3(sig, sip, uap); 1487 } 1488 #else 1489 Signal_t 1490 Perl_csighandler(int sig) 1491 { 1492 Perl_csighandler3(sig, NULL, NULL); 1493 } 1494 #endif 1495 1496 Signal_t 1497 Perl_csighandler1(int sig) 1498 { 1499 Perl_csighandler3(sig, NULL, NULL); 1500 } 1501 1502 /* Handler intended to directly handle signal calls from the kernel. 1503 * (Depending on configuration, the kernel may actually call one of the 1504 * wrappers csighandler() or csighandler1() instead.) 1505 * It either queues up the signal or dispatches it immediately depending 1506 * on whether safe signals are enabled and whether the signal is capable 1507 * of being deferred (e.g. SEGV isn't). 1508 */ 1509 1510 Signal_t 1511 Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) 1512 { 1513 #ifdef PERL_GET_SIG_CONTEXT 1514 dTHXa(PERL_GET_SIG_CONTEXT); 1515 #else 1516 dTHX; 1517 #endif 1518 1519 #ifdef PERL_USE_3ARG_SIGHANDLER 1520 #if defined(__cplusplus) && defined(__GNUC__) 1521 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap 1522 * parameters would be warned about. */ 1523 PERL_UNUSED_ARG(sip); 1524 PERL_UNUSED_ARG(uap); 1525 #endif 1526 #endif 1527 1528 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1529 (void) rsignal(sig, PL_csighandlerp); 1530 if (PL_sig_ignoring[sig]) return; 1531 #endif 1532 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1533 if (PL_sig_defaulting[sig]) 1534 #ifdef KILL_BY_SIGPRC 1535 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); 1536 #else 1537 exit(1); 1538 #endif 1539 #endif 1540 if ( 1541 #ifdef SIGILL 1542 sig == SIGILL || 1543 #endif 1544 #ifdef SIGBUS 1545 sig == SIGBUS || 1546 #endif 1547 #ifdef SIGSEGV 1548 sig == SIGSEGV || 1549 #endif 1550 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) 1551 /* Call the perl level handler now-- 1552 * with risk we may be in malloc() or being destructed etc. */ 1553 { 1554 if (PL_sighandlerp == Perl_sighandler) 1555 /* default handler, so can call perly_sighandler() directly 1556 * rather than via Perl_sighandler, passing the extra 1557 * 'safe = false' arg 1558 */ 1559 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */); 1560 else 1561 #ifdef PERL_USE_3ARG_SIGHANDLER 1562 (*PL_sighandlerp)(sig, NULL, NULL); 1563 #else 1564 (*PL_sighandlerp)(sig); 1565 #endif 1566 } 1567 else { 1568 if (!PL_psig_pend) return; 1569 /* Set a flag to say this signal is pending, that is awaiting delivery after 1570 * the current Perl opcode completes */ 1571 PL_psig_pend[sig]++; 1572 1573 #ifndef SIG_PENDING_DIE_COUNT 1574 # define SIG_PENDING_DIE_COUNT 120 1575 #endif 1576 /* Add one to say _a_ signal is pending */ 1577 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) 1578 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", 1579 (unsigned long)SIG_PENDING_DIE_COUNT); 1580 } 1581 } 1582 1583 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1584 void 1585 Perl_csighandler_init(void) 1586 { 1587 int sig; 1588 if (PL_sig_handlers_initted) return; 1589 1590 for (sig = 1; sig < SIG_SIZE; sig++) { 1591 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1592 dTHX; 1593 PL_sig_defaulting[sig] = 1; 1594 (void) rsignal(sig, PL_csighandlerp); 1595 #endif 1596 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1597 PL_sig_ignoring[sig] = 0; 1598 #endif 1599 } 1600 PL_sig_handlers_initted = 1; 1601 } 1602 #endif 1603 1604 #if defined HAS_SIGPROCMASK 1605 static void 1606 unblock_sigmask(pTHX_ void* newset) 1607 { 1608 PERL_UNUSED_CONTEXT; 1609 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL); 1610 } 1611 #endif 1612 1613 void 1614 Perl_despatch_signals(pTHX) 1615 { 1616 int sig; 1617 PL_sig_pending = 0; 1618 for (sig = 1; sig < SIG_SIZE; sig++) { 1619 if (PL_psig_pend[sig]) { 1620 dSAVE_ERRNO; 1621 #ifdef HAS_SIGPROCMASK 1622 /* From sigaction(2) (FreeBSD man page): 1623 * | Signal routines normally execute with the signal that 1624 * | caused their invocation blocked, but other signals may 1625 * | yet occur. 1626 * Emulation of this behavior (from within Perl) is enabled 1627 * using sigprocmask 1628 */ 1629 int was_blocked; 1630 sigset_t newset, oldset; 1631 1632 sigemptyset(&newset); 1633 sigaddset(&newset, sig); 1634 sigprocmask(SIG_BLOCK, &newset, &oldset); 1635 was_blocked = sigismember(&oldset, sig); 1636 if (!was_blocked) { 1637 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); 1638 ENTER; 1639 SAVEFREESV(save_sv); 1640 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); 1641 } 1642 #endif 1643 PL_psig_pend[sig] = 0; 1644 if (PL_sighandlerp == Perl_sighandler) 1645 /* default handler, so can call perly_sighandler() directly 1646 * rather than via Perl_sighandler, passing the extra 1647 * 'safe = true' arg 1648 */ 1649 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */); 1650 else 1651 #ifdef PERL_USE_3ARG_SIGHANDLER 1652 (*PL_sighandlerp)(sig, NULL, NULL); 1653 #else 1654 (*PL_sighandlerp)(sig); 1655 #endif 1656 1657 #ifdef HAS_SIGPROCMASK 1658 if (!was_blocked) 1659 LEAVE; 1660 #endif 1661 RESTORE_ERRNO; 1662 } 1663 } 1664 } 1665 1666 /* sv of NULL signifies that we're acting as magic_clearsig. */ 1667 int 1668 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 1669 { 1670 dVAR; 1671 I32 i; 1672 SV** svp = NULL; 1673 /* Need to be careful with SvREFCNT_dec(), because that can have side 1674 * effects (due to closures). We must make sure that the new disposition 1675 * is in place before it is called. 1676 */ 1677 SV* to_dec = NULL; 1678 STRLEN len; 1679 #ifdef HAS_SIGPROCMASK 1680 sigset_t set, save; 1681 SV* save_sv; 1682 #endif 1683 const char *s = MgPV_const(mg,len); 1684 1685 PERL_ARGS_ASSERT_MAGIC_SETSIG; 1686 1687 if (*s == '_') { 1688 if (memEQs(s, len, "__DIE__")) 1689 svp = &PL_diehook; 1690 else if (memEQs(s, len, "__WARN__") 1691 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { 1692 /* Merge the existing behaviours, which are as follows: 1693 magic_setsig, we always set svp to &PL_warnhook 1694 (hence we always change the warnings handler) 1695 For magic_clearsig, we don't change the warnings handler if it's 1696 set to the &PL_warnhook. */ 1697 svp = &PL_warnhook; 1698 } else if (sv) { 1699 SV *tmp = sv_newmortal(); 1700 Perl_croak(aTHX_ "No such hook: %s", 1701 pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); 1702 } 1703 i = 0; 1704 if (svp && *svp) { 1705 if (*svp != PERL_WARNHOOK_FATAL) 1706 to_dec = *svp; 1707 *svp = NULL; 1708 } 1709 } 1710 else { 1711 i = (I16)mg->mg_private; 1712 if (!i) { 1713 i = whichsig_pvn(s, len); /* ...no, a brick */ 1714 mg->mg_private = (U16)i; 1715 } 1716 if (i <= 0) { 1717 if (sv) { 1718 SV *tmp = sv_newmortal(); 1719 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", 1720 pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); 1721 } 1722 return 0; 1723 } 1724 #ifdef HAS_SIGPROCMASK 1725 /* Avoid having the signal arrive at a bad time, if possible. */ 1726 sigemptyset(&set); 1727 sigaddset(&set,i); 1728 sigprocmask(SIG_BLOCK, &set, &save); 1729 ENTER; 1730 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); 1731 SAVEFREESV(save_sv); 1732 SAVEDESTRUCTOR_X(restore_sigmask, save_sv); 1733 #endif 1734 PERL_ASYNC_CHECK(); 1735 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) 1736 if (!PL_sig_handlers_initted) Perl_csighandler_init(); 1737 #endif 1738 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1739 PL_sig_ignoring[i] = 0; 1740 #endif 1741 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1742 PL_sig_defaulting[i] = 0; 1743 #endif 1744 to_dec = PL_psig_ptr[i]; 1745 if (sv) { 1746 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); 1747 SvTEMP_off(sv); /* Make sure it doesn't go away on us */ 1748 1749 /* Signals don't change name during the program's execution, so once 1750 they're cached in the appropriate slot of PL_psig_name, they can 1751 stay there. 1752 1753 Ideally we'd find some way of making SVs at (C) compile time, or 1754 at least, doing most of the work. */ 1755 if (!PL_psig_name[i]) { 1756 const char* name = PL_sig_name[i]; 1757 PL_psig_name[i] = newSVpvn(name, strlen(name)); 1758 SvREADONLY_on(PL_psig_name[i]); 1759 } 1760 } else { 1761 SvREFCNT_dec(PL_psig_name[i]); 1762 PL_psig_name[i] = NULL; 1763 PL_psig_ptr[i] = NULL; 1764 } 1765 } 1766 if (sv && (isGV_with_GP(sv) || SvROK(sv))) { 1767 if (i) { 1768 (void)rsignal(i, PL_csighandlerp); 1769 } 1770 else 1771 *svp = SvREFCNT_inc_simple_NN(sv); 1772 } else { 1773 if (sv && SvOK(sv)) { 1774 s = SvPV_force(sv, len); 1775 } else { 1776 sv = NULL; 1777 } 1778 if (sv && memEQs(s, len,"IGNORE")) { 1779 if (i) { 1780 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS 1781 PL_sig_ignoring[i] = 1; 1782 (void)rsignal(i, PL_csighandlerp); 1783 #else 1784 (void)rsignal(i, (Sighandler_t) SIG_IGN); 1785 #endif 1786 } 1787 } 1788 else if (!sv || memEQs(s, len,"DEFAULT") || !len) { 1789 if (i) { 1790 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS 1791 PL_sig_defaulting[i] = 1; 1792 (void)rsignal(i, PL_csighandlerp); 1793 #else 1794 (void)rsignal(i, (Sighandler_t) SIG_DFL); 1795 #endif 1796 } 1797 } 1798 else { 1799 /* 1800 * We should warn if HINT_STRICT_REFS, but without 1801 * access to a known hint bit in a known OP, we can't 1802 * tell whether HINT_STRICT_REFS is in force or not. 1803 */ 1804 if (!memchr(s, ':', len) && !memchr(s, '\'', len)) 1805 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), 1806 SV_GMAGIC); 1807 if (i) 1808 (void)rsignal(i, PL_csighandlerp); 1809 else 1810 *svp = SvREFCNT_inc_simple_NN(sv); 1811 } 1812 } 1813 1814 #ifdef HAS_SIGPROCMASK 1815 if(i) 1816 LEAVE; 1817 #endif 1818 SvREFCNT_dec(to_dec); 1819 return 0; 1820 } 1821 #endif /* !PERL_MICRO */ 1822 1823 int 1824 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 1825 { 1826 PERL_ARGS_ASSERT_MAGIC_SETISA; 1827 PERL_UNUSED_ARG(sv); 1828 1829 /* Skip _isaelem because _isa will handle it shortly */ 1830 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) 1831 return 0; 1832 1833 return magic_clearisa(NULL, mg); 1834 } 1835 1836 /* sv of NULL signifies that we're acting as magic_setisa. */ 1837 int 1838 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) 1839 { 1840 HV* stash; 1841 PERL_ARGS_ASSERT_MAGIC_CLEARISA; 1842 1843 /* Bail out if destruction is going on */ 1844 if(PL_phase == PERL_PHASE_DESTRUCT) return 0; 1845 1846 if (sv) 1847 av_clear(MUTABLE_AV(sv)); 1848 1849 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) 1850 /* This occurs with setisa_elem magic, which calls this 1851 same function. */ 1852 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); 1853 1854 assert(mg); 1855 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ 1856 SV **svp = AvARRAY((AV *)mg->mg_obj); 1857 I32 items = AvFILLp((AV *)mg->mg_obj) + 1; 1858 while (items--) { 1859 stash = GvSTASH((GV *)*svp++); 1860 if (stash && HvENAME(stash)) mro_isa_changed_in(stash); 1861 } 1862 1863 return 0; 1864 } 1865 1866 stash = GvSTASH( 1867 (const GV *)mg->mg_obj 1868 ); 1869 1870 /* The stash may have been detached from the symbol table, so check its 1871 name before doing anything. */ 1872 if (stash && HvENAME_get(stash)) 1873 mro_isa_changed_in(stash); 1874 1875 return 0; 1876 } 1877 1878 int 1879 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) 1880 { 1881 HV * const hv = MUTABLE_HV(LvTARG(sv)); 1882 I32 i = 0; 1883 1884 PERL_ARGS_ASSERT_MAGIC_GETNKEYS; 1885 PERL_UNUSED_ARG(mg); 1886 1887 if (hv) { 1888 (void) hv_iterinit(hv); 1889 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) 1890 i = HvUSEDKEYS(hv); 1891 else { 1892 while (hv_iternext(hv)) 1893 i++; 1894 } 1895 } 1896 1897 sv_setiv(sv, (IV)i); 1898 return 0; 1899 } 1900 1901 int 1902 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 1903 { 1904 PERL_ARGS_ASSERT_MAGIC_SETNKEYS; 1905 PERL_UNUSED_ARG(mg); 1906 if (LvTARG(sv)) { 1907 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); 1908 } 1909 return 0; 1910 } 1911 1912 /* 1913 =for apidoc magic_methcall 1914 1915 Invoke a magic method (like FETCH). 1916 1917 C<sv> and C<mg> are the tied thingy and the tie magic. 1918 1919 C<meth> is the name of the method to call. 1920 1921 C<argc> is the number of args (in addition to $self) to pass to the method. 1922 1923 The C<flags> can be: 1924 1925 G_DISCARD invoke method with G_DISCARD flag and don't 1926 return a value 1927 G_UNDEF_FILL fill the stack with argc pointers to 1928 PL_sv_undef 1929 1930 The arguments themselves are any values following the C<flags> argument. 1931 1932 Returns the SV (if any) returned by the method, or C<NULL> on failure. 1933 1934 1935 =cut 1936 */ 1937 1938 SV* 1939 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, 1940 U32 argc, ...) 1941 { 1942 dSP; 1943 SV* ret = NULL; 1944 1945 PERL_ARGS_ASSERT_MAGIC_METHCALL; 1946 1947 ENTER; 1948 1949 if (flags & G_WRITING_TO_STDERR) { 1950 SAVETMPS; 1951 1952 save_re_context(); 1953 SAVESPTR(PL_stderrgv); 1954 PL_stderrgv = NULL; 1955 } 1956 1957 PUSHSTACKi(PERLSI_MAGIC); 1958 PUSHMARK(SP); 1959 1960 /* EXTEND() expects a signed argc; don't wrap when casting */ 1961 assert(argc <= I32_MAX); 1962 EXTEND(SP, (I32)argc+1); 1963 PUSHs(SvTIED_obj(sv, mg)); 1964 if (flags & G_UNDEF_FILL) { 1965 while (argc--) { 1966 PUSHs(&PL_sv_undef); 1967 } 1968 } else if (argc > 0) { 1969 va_list args; 1970 va_start(args, argc); 1971 1972 do { 1973 SV *const this_sv = va_arg(args, SV *); 1974 PUSHs(this_sv); 1975 } while (--argc); 1976 1977 va_end(args); 1978 } 1979 PUTBACK; 1980 if (flags & G_DISCARD) { 1981 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); 1982 } 1983 else { 1984 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) 1985 ret = *PL_stack_sp--; 1986 } 1987 POPSTACK; 1988 if (flags & G_WRITING_TO_STDERR) 1989 FREETMPS; 1990 LEAVE; 1991 return ret; 1992 } 1993 1994 /* wrapper for magic_methcall that creates the first arg */ 1995 1996 STATIC SV* 1997 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, 1998 int n, SV *val) 1999 { 2000 SV* arg1 = NULL; 2001 2002 PERL_ARGS_ASSERT_MAGIC_METHCALL1; 2003 2004 if (mg->mg_ptr) { 2005 if (mg->mg_len >= 0) { 2006 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); 2007 } 2008 else if (mg->mg_len == HEf_SVKEY) 2009 arg1 = MUTABLE_SV(mg->mg_ptr); 2010 } 2011 else if (mg->mg_type == PERL_MAGIC_tiedelem) { 2012 arg1 = newSViv((IV)(mg->mg_len)); 2013 sv_2mortal(arg1); 2014 } 2015 if (!arg1) { 2016 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); 2017 } 2018 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); 2019 } 2020 2021 STATIC int 2022 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) 2023 { 2024 SV* ret; 2025 2026 PERL_ARGS_ASSERT_MAGIC_METHPACK; 2027 2028 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); 2029 if (ret) 2030 sv_setsv(sv, ret); 2031 return 0; 2032 } 2033 2034 int 2035 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) 2036 { 2037 PERL_ARGS_ASSERT_MAGIC_GETPACK; 2038 2039 if (mg->mg_type == PERL_MAGIC_tiedelem) 2040 mg->mg_flags |= MGf_GSKIP; 2041 magic_methpack(sv,mg,SV_CONST(FETCH)); 2042 return 0; 2043 } 2044 2045 int 2046 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) 2047 { 2048 MAGIC *tmg; 2049 SV *val; 2050 2051 PERL_ARGS_ASSERT_MAGIC_SETPACK; 2052 2053 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to 2054 * STORE() is not $val, but rather a PVLV (the sv in this call), whose 2055 * public flags indicate its value based on copying from $val. Doing 2056 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us. 2057 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes 2058 * wrong if $val happened to be tainted, as sv hasn't got magic 2059 * enabled, even though taint magic is in the chain. In which case, 2060 * fake up a temporary tainted value (this is easier than temporarily 2061 * re-enabling magic on sv). */ 2062 2063 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) 2064 && (tmg->mg_len & 1)) 2065 { 2066 val = sv_mortalcopy(sv); 2067 SvTAINTED_on(val); 2068 } 2069 else 2070 val = sv; 2071 2072 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); 2073 return 0; 2074 } 2075 2076 int 2077 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) 2078 { 2079 PERL_ARGS_ASSERT_MAGIC_CLEARPACK; 2080 2081 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0; 2082 return magic_methpack(sv,mg,SV_CONST(DELETE)); 2083 } 2084 2085 2086 U32 2087 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) 2088 { 2089 I32 retval = 0; 2090 SV* retsv; 2091 2092 PERL_ARGS_ASSERT_MAGIC_SIZEPACK; 2093 2094 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); 2095 if (retsv) { 2096 retval = SvIV(retsv)-1; 2097 if (retval < -1) 2098 Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); 2099 } 2100 return (U32) retval; 2101 } 2102 2103 int 2104 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) 2105 { 2106 PERL_ARGS_ASSERT_MAGIC_WIPEPACK; 2107 2108 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0); 2109 return 0; 2110 } 2111 2112 int 2113 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) 2114 { 2115 SV* ret; 2116 2117 PERL_ARGS_ASSERT_MAGIC_NEXTPACK; 2118 2119 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) 2120 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); 2121 if (ret) 2122 sv_setsv(key,ret); 2123 return 0; 2124 } 2125 2126 int 2127 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) 2128 { 2129 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK; 2130 2131 return magic_methpack(sv,mg,SV_CONST(EXISTS)); 2132 } 2133 2134 SV * 2135 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) 2136 { 2137 SV *retval; 2138 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); 2139 HV * const pkg = SvSTASH((const SV *)SvRV(tied)); 2140 2141 PERL_ARGS_ASSERT_MAGIC_SCALARPACK; 2142 2143 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { 2144 SV *key; 2145 if (HvEITER_get(hv)) 2146 /* we are in an iteration so the hash cannot be empty */ 2147 return &PL_sv_yes; 2148 /* no xhv_eiter so now use FIRSTKEY */ 2149 key = sv_newmortal(); 2150 magic_nextpack(MUTABLE_SV(hv), mg, key); 2151 HvEITER_set(hv, NULL); /* need to reset iterator */ 2152 return SvOK(key) ? &PL_sv_yes : &PL_sv_no; 2153 } 2154 2155 /* there is a SCALAR method that we can call */ 2156 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); 2157 if (!retval) 2158 retval = &PL_sv_undef; 2159 return retval; 2160 } 2161 2162 int 2163 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) 2164 { 2165 SV **svp; 2166 2167 PERL_ARGS_ASSERT_MAGIC_SETDBLINE; 2168 2169 /* The magic ptr/len for the debugger's hash should always be an SV. */ 2170 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) { 2171 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'", 2172 (IV)mg->mg_len, mg->mg_ptr); 2173 } 2174 2175 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and 2176 setting/clearing debugger breakpoints is not a hot path. */ 2177 svp = av_fetch(MUTABLE_AV(mg->mg_obj), 2178 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); 2179 2180 if (svp && SvIOKp(*svp)) { 2181 OP * const o = INT2PTR(OP*,SvIVX(*svp)); 2182 if (o) { 2183 #ifdef PERL_DEBUG_READONLY_OPS 2184 Slab_to_rw(OpSLAB(o)); 2185 #endif 2186 /* set or clear breakpoint in the relevant control op */ 2187 if (SvTRUE(sv)) 2188 o->op_flags |= OPf_SPECIAL; 2189 else 2190 o->op_flags &= ~OPf_SPECIAL; 2191 #ifdef PERL_DEBUG_READONLY_OPS 2192 Slab_to_ro(OpSLAB(o)); 2193 #endif 2194 } 2195 } 2196 return 0; 2197 } 2198 2199 int 2200 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) 2201 { 2202 AV * const obj = MUTABLE_AV(mg->mg_obj); 2203 2204 PERL_ARGS_ASSERT_MAGIC_GETARYLEN; 2205 2206 if (obj) { 2207 sv_setiv(sv, AvFILL(obj)); 2208 } else { 2209 sv_set_undef(sv); 2210 } 2211 return 0; 2212 } 2213 2214 int 2215 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) 2216 { 2217 AV * const obj = MUTABLE_AV(mg->mg_obj); 2218 2219 PERL_ARGS_ASSERT_MAGIC_SETARYLEN; 2220 2221 if (obj) { 2222 av_fill(obj, SvIV(sv)); 2223 } else { 2224 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), 2225 "Attempt to set length of freed array"); 2226 } 2227 return 0; 2228 } 2229 2230 int 2231 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) 2232 { 2233 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; 2234 PERL_UNUSED_ARG(sv); 2235 PERL_UNUSED_CONTEXT; 2236 2237 /* Reset the iterator when the array is cleared */ 2238 if (sizeof(IV) == sizeof(SSize_t)) { 2239 *((IV *) &(mg->mg_len)) = 0; 2240 } else { 2241 if (mg->mg_ptr) 2242 *((IV *) mg->mg_ptr) = 0; 2243 } 2244 2245 return 0; 2246 } 2247 2248 int 2249 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) 2250 { 2251 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P; 2252 PERL_UNUSED_ARG(sv); 2253 2254 /* during global destruction, mg_obj may already have been freed */ 2255 if (PL_in_clean_all) 2256 return 0; 2257 2258 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); 2259 2260 if (mg) { 2261 /* arylen scalar holds a pointer back to the array, but doesn't own a 2262 reference. Hence the we (the array) are about to go away with it 2263 still pointing at us. Clear its pointer, else it would be pointing 2264 at free memory. See the comment in sv_magic about reference loops, 2265 and why it can't own a reference to us. */ 2266 mg->mg_obj = 0; 2267 } 2268 return 0; 2269 } 2270 2271 int 2272 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 2273 { 2274 SV* const lsv = LvTARG(sv); 2275 MAGIC * const found = mg_find_mglob(lsv); 2276 2277 PERL_ARGS_ASSERT_MAGIC_GETPOS; 2278 PERL_UNUSED_ARG(mg); 2279 2280 if (found && found->mg_len != -1) { 2281 STRLEN i = found->mg_len; 2282 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) 2283 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); 2284 sv_setuv(sv, i); 2285 return 0; 2286 } 2287 sv_set_undef(sv); 2288 return 0; 2289 } 2290 2291 int 2292 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 2293 { 2294 SV* const lsv = LvTARG(sv); 2295 SSize_t pos; 2296 STRLEN len; 2297 MAGIC* found; 2298 const char *s; 2299 2300 PERL_ARGS_ASSERT_MAGIC_SETPOS; 2301 PERL_UNUSED_ARG(mg); 2302 2303 found = mg_find_mglob(lsv); 2304 if (!found) { 2305 if (!SvOK(sv)) 2306 return 0; 2307 found = sv_magicext_mglob(lsv); 2308 } 2309 else if (!SvOK(sv)) { 2310 found->mg_len = -1; 2311 return 0; 2312 } 2313 s = SvPV_const(lsv, len); 2314 2315 pos = SvIV(sv); 2316 2317 if (DO_UTF8(lsv)) { 2318 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len); 2319 if (ulen) 2320 len = ulen; 2321 } 2322 2323 if (pos < 0) { 2324 pos += len; 2325 if (pos < 0) 2326 pos = 0; 2327 } 2328 else if (pos > (SSize_t)len) 2329 pos = len; 2330 2331 found->mg_len = pos; 2332 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES); 2333 2334 return 0; 2335 } 2336 2337 int 2338 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) 2339 { 2340 STRLEN len; 2341 SV * const lsv = LvTARG(sv); 2342 const char * const tmps = SvPV_const(lsv,len); 2343 STRLEN offs = LvTARGOFF(sv); 2344 STRLEN rem = LvTARGLEN(sv); 2345 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; 2346 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN; 2347 2348 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; 2349 PERL_UNUSED_ARG(mg); 2350 2351 if (!translate_substr_offsets( 2352 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, 2353 negoff ? -(IV)offs : (IV)offs, !negoff, 2354 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem 2355 )) { 2356 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 2357 sv_set_undef(sv); 2358 return 0; 2359 } 2360 2361 if (SvUTF8(lsv)) 2362 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); 2363 sv_setpvn(sv, tmps + offs, rem); 2364 if (SvUTF8(lsv)) 2365 SvUTF8_on(sv); 2366 return 0; 2367 } 2368 2369 int 2370 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) 2371 { 2372 STRLEN len, lsv_len, oldtarglen, newtarglen; 2373 const char * const tmps = SvPV_const(sv, len); 2374 SV * const lsv = LvTARG(sv); 2375 STRLEN lvoff = LvTARGOFF(sv); 2376 STRLEN lvlen = LvTARGLEN(sv); 2377 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; 2378 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN; 2379 2380 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; 2381 PERL_UNUSED_ARG(mg); 2382 2383 SvGETMAGIC(lsv); 2384 if (SvROK(lsv)) 2385 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), 2386 "Attempt to use reference as lvalue in substr" 2387 ); 2388 SvPV_force_nomg(lsv,lsv_len); 2389 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); 2390 if (!translate_substr_offsets( 2391 lsv_len, 2392 negoff ? -(IV)lvoff : (IV)lvoff, !negoff, 2393 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen 2394 )) 2395 Perl_croak(aTHX_ "substr outside of string"); 2396 oldtarglen = lvlen; 2397 if (DO_UTF8(sv)) { 2398 sv_utf8_upgrade_nomg(lsv); 2399 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); 2400 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); 2401 newtarglen = sv_or_pv_len_utf8(sv, tmps, len); 2402 SvUTF8_on(lsv); 2403 } 2404 else if (SvUTF8(lsv)) { 2405 const char *utf8; 2406 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); 2407 newtarglen = len; 2408 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); 2409 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); 2410 Safefree(utf8); 2411 } 2412 else { 2413 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); 2414 newtarglen = len; 2415 } 2416 if (!neglen) LvTARGLEN(sv) = newtarglen; 2417 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; 2418 2419 return 0; 2420 } 2421 2422 int 2423 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) 2424 { 2425 PERL_ARGS_ASSERT_MAGIC_GETTAINT; 2426 PERL_UNUSED_ARG(sv); 2427 #ifdef NO_TAINT_SUPPORT 2428 PERL_UNUSED_ARG(mg); 2429 #endif 2430 2431 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME); 2432 return 0; 2433 } 2434 2435 int 2436 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) 2437 { 2438 PERL_ARGS_ASSERT_MAGIC_SETTAINT; 2439 PERL_UNUSED_ARG(sv); 2440 2441 /* update taint status */ 2442 if (TAINT_get) 2443 mg->mg_len |= 1; 2444 else 2445 mg->mg_len &= ~1; 2446 return 0; 2447 } 2448 2449 int 2450 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) 2451 { 2452 SV * const lsv = LvTARG(sv); 2453 char errflags = LvFLAGS(sv); 2454 2455 PERL_ARGS_ASSERT_MAGIC_GETVEC; 2456 PERL_UNUSED_ARG(mg); 2457 2458 /* non-zero errflags implies deferred out-of-range condition */ 2459 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE))); 2460 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); 2461 2462 return 0; 2463 } 2464 2465 int 2466 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) 2467 { 2468 PERL_ARGS_ASSERT_MAGIC_SETVEC; 2469 PERL_UNUSED_ARG(mg); 2470 do_vecset(sv); /* XXX slurp this routine */ 2471 return 0; 2472 } 2473 2474 SV * 2475 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) 2476 { 2477 SV *targ = NULL; 2478 PERL_ARGS_ASSERT_DEFELEM_TARGET; 2479 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); 2480 assert(mg); 2481 if (LvTARGLEN(sv)) { 2482 if (mg->mg_obj) { 2483 SV * const ahv = LvTARG(sv); 2484 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); 2485 if (he) 2486 targ = HeVAL(he); 2487 } 2488 else if (LvSTARGOFF(sv) >= 0) { 2489 AV *const av = MUTABLE_AV(LvTARG(sv)); 2490 if (LvSTARGOFF(sv) <= AvFILL(av)) 2491 { 2492 if (SvRMAGICAL(av)) { 2493 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); 2494 targ = svp ? *svp : NULL; 2495 } 2496 else 2497 targ = AvARRAY(av)[LvSTARGOFF(sv)]; 2498 } 2499 } 2500 if (targ && (targ != &PL_sv_undef)) { 2501 /* somebody else defined it for us */ 2502 SvREFCNT_dec(LvTARG(sv)); 2503 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); 2504 LvTARGLEN(sv) = 0; 2505 SvREFCNT_dec(mg->mg_obj); 2506 mg->mg_obj = NULL; 2507 mg->mg_flags &= ~MGf_REFCOUNTED; 2508 } 2509 return targ; 2510 } 2511 else 2512 return LvTARG(sv); 2513 } 2514 2515 int 2516 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 2517 { 2518 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; 2519 2520 sv_setsv(sv, defelem_target(sv, mg)); 2521 return 0; 2522 } 2523 2524 int 2525 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) 2526 { 2527 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; 2528 PERL_UNUSED_ARG(mg); 2529 if (LvTARGLEN(sv)) 2530 vivify_defelem(sv); 2531 if (LvTARG(sv)) { 2532 sv_setsv(LvTARG(sv), sv); 2533 SvSETMAGIC(LvTARG(sv)); 2534 } 2535 return 0; 2536 } 2537 2538 void 2539 Perl_vivify_defelem(pTHX_ SV *sv) 2540 { 2541 MAGIC *mg; 2542 SV *value = NULL; 2543 2544 PERL_ARGS_ASSERT_VIVIFY_DEFELEM; 2545 2546 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) 2547 return; 2548 if (mg->mg_obj) { 2549 SV * const ahv = LvTARG(sv); 2550 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); 2551 if (he) 2552 value = HeVAL(he); 2553 if (!value || value == &PL_sv_undef) 2554 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); 2555 } 2556 else if (LvSTARGOFF(sv) < 0) 2557 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); 2558 else { 2559 AV *const av = MUTABLE_AV(LvTARG(sv)); 2560 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) 2561 LvTARG(sv) = NULL; /* array can't be extended */ 2562 else { 2563 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); 2564 if (!svp || !(value = *svp)) 2565 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); 2566 } 2567 } 2568 SvREFCNT_inc_simple_void(value); 2569 SvREFCNT_dec(LvTARG(sv)); 2570 LvTARG(sv) = value; 2571 LvTARGLEN(sv) = 0; 2572 SvREFCNT_dec(mg->mg_obj); 2573 mg->mg_obj = NULL; 2574 mg->mg_flags &= ~MGf_REFCOUNTED; 2575 } 2576 2577 int 2578 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg) 2579 { 2580 PERL_ARGS_ASSERT_MAGIC_SETNONELEM; 2581 PERL_UNUSED_ARG(mg); 2582 sv_unmagic(sv, PERL_MAGIC_nonelem); 2583 return 0; 2584 } 2585 2586 int 2587 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) 2588 { 2589 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; 2590 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); 2591 return 0; 2592 } 2593 2594 int 2595 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) 2596 { 2597 PERL_ARGS_ASSERT_MAGIC_SETMGLOB; 2598 PERL_UNUSED_CONTEXT; 2599 PERL_UNUSED_ARG(sv); 2600 mg->mg_len = -1; 2601 return 0; 2602 } 2603 2604 int 2605 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) 2606 { 2607 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; 2608 2609 PERL_ARGS_ASSERT_MAGIC_SETUVAR; 2610 2611 if (uf && uf->uf_set) 2612 (*uf->uf_set)(aTHX_ uf->uf_index, sv); 2613 return 0; 2614 } 2615 2616 int 2617 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) 2618 { 2619 const char type = mg->mg_type; 2620 2621 PERL_ARGS_ASSERT_MAGIC_SETREGEXP; 2622 2623 assert( type == PERL_MAGIC_fm 2624 || type == PERL_MAGIC_qr 2625 || type == PERL_MAGIC_bm); 2626 return sv_unmagic(sv, type); 2627 } 2628 2629 #ifdef USE_LOCALE_COLLATE 2630 int 2631 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) 2632 { 2633 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM; 2634 2635 /* 2636 * RenE<eacute> Descartes said "I think not." 2637 * and vanished with a faint plop. 2638 */ 2639 PERL_UNUSED_CONTEXT; 2640 PERL_UNUSED_ARG(sv); 2641 if (mg->mg_ptr) { 2642 Safefree(mg->mg_ptr); 2643 mg->mg_ptr = NULL; 2644 mg->mg_len = -1; 2645 } 2646 return 0; 2647 } 2648 #endif /* USE_LOCALE_COLLATE */ 2649 2650 /* Just clear the UTF-8 cache data. */ 2651 int 2652 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) 2653 { 2654 PERL_ARGS_ASSERT_MAGIC_SETUTF8; 2655 PERL_UNUSED_CONTEXT; 2656 PERL_UNUSED_ARG(sv); 2657 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ 2658 mg->mg_ptr = NULL; 2659 mg->mg_len = -1; /* The mg_len holds the len cache. */ 2660 return 0; 2661 } 2662 2663 int 2664 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) 2665 { 2666 const char *bad = NULL; 2667 PERL_ARGS_ASSERT_MAGIC_SETLVREF; 2668 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference"); 2669 switch (mg->mg_private & OPpLVREF_TYPE) { 2670 case OPpLVREF_SV: 2671 if (SvTYPE(SvRV(sv)) > SVt_PVLV) 2672 bad = " SCALAR"; 2673 break; 2674 case OPpLVREF_AV: 2675 if (SvTYPE(SvRV(sv)) != SVt_PVAV) 2676 bad = "n ARRAY"; 2677 break; 2678 case OPpLVREF_HV: 2679 if (SvTYPE(SvRV(sv)) != SVt_PVHV) 2680 bad = " HASH"; 2681 break; 2682 case OPpLVREF_CV: 2683 if (SvTYPE(SvRV(sv)) != SVt_PVCV) 2684 bad = " CODE"; 2685 } 2686 if (bad) 2687 /* diag_listed_as: Assigned value is not %s reference */ 2688 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); 2689 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) { 2690 case 0: 2691 { 2692 SV * const old = PAD_SV(mg->mg_len); 2693 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); 2694 SvREFCNT_dec(old); 2695 break; 2696 } 2697 case SVt_PVGV: 2698 gv_setref(mg->mg_obj, sv); 2699 SvSETMAGIC(mg->mg_obj); 2700 break; 2701 case SVt_PVAV: 2702 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), 2703 SvREFCNT_inc_simple_NN(SvRV(sv))); 2704 break; 2705 case SVt_PVHV: 2706 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, 2707 SvREFCNT_inc_simple_NN(SvRV(sv)), 0); 2708 } 2709 if (mg->mg_flags & MGf_PERSIST) 2710 NOOP; /* This sv is in use as an iterator var and will be reused, 2711 so we must leave the magic. */ 2712 else 2713 /* This sv could be returned by the assignment op, so clear the 2714 magic, as lvrefs are an implementation detail that must not be 2715 leaked to the user. */ 2716 sv_unmagic(sv, PERL_MAGIC_lvref); 2717 return 0; 2718 } 2719 2720 static void 2721 S_set_dollarzero(pTHX_ SV *sv) 2722 PERL_TSA_REQUIRES(PL_dollarzero_mutex) 2723 { 2724 #ifdef USE_ITHREADS 2725 dVAR; 2726 #endif 2727 const char *s; 2728 STRLEN len; 2729 #ifdef HAS_SETPROCTITLE 2730 /* The BSDs don't show the argv[] in ps(1) output, they 2731 * show a string from the process struct and provide 2732 * the setproctitle() routine to manipulate that. */ 2733 if (PL_origalen != 1) { 2734 s = SvPV_const(sv, len); 2735 # if __FreeBSD_version > 410001 || defined(__DragonFly__) 2736 /* The leading "-" removes the "perl: " prefix, 2737 * but not the "(perl) suffix from the ps(1) 2738 * output, because that's what ps(1) shows if the 2739 * argv[] is modified. */ 2740 setproctitle("-%s", s); 2741 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ 2742 /* This doesn't really work if you assume that 2743 * $0 = 'foobar'; will wipe out 'perl' from the $0 2744 * because in ps(1) output the result will be like 2745 * sprintf("perl: %s (perl)", s) 2746 * I guess this is a security feature: 2747 * one (a user process) cannot get rid of the original name. 2748 * --jhi */ 2749 setproctitle("%s", s); 2750 # endif 2751 } 2752 #elif defined(__hpux) && defined(PSTAT_SETCMD) 2753 if (PL_origalen != 1) { 2754 union pstun un; 2755 s = SvPV_const(sv, len); 2756 un.pst_command = (char *)s; 2757 pstat(PSTAT_SETCMD, un, len, 0, 0); 2758 } 2759 #else 2760 if (PL_origalen > 1) { 2761 I32 i; 2762 /* PL_origalen is set in perl_parse(). */ 2763 s = SvPV_force(sv,len); 2764 if (len >= (STRLEN)PL_origalen-1) { 2765 /* Longer than original, will be truncated. We assume that 2766 * PL_origalen bytes are available. */ 2767 Copy(s, PL_origargv[0], PL_origalen-1, char); 2768 } 2769 else { 2770 /* Shorter than original, will be padded. */ 2771 #ifdef PERL_DARWIN 2772 /* Special case for Mac OS X: see [perl #38868] */ 2773 const int pad = 0; 2774 #else 2775 /* Is the space counterintuitive? Yes. 2776 * (You were expecting \0?) 2777 * Does it work? Seems to. (In Linux 2.4.20 at least.) 2778 * --jhi */ 2779 const int pad = ' '; 2780 #endif 2781 Copy(s, PL_origargv[0], len, char); 2782 PL_origargv[0][len] = 0; 2783 memset(PL_origargv[0] + len + 1, 2784 pad, PL_origalen - len - 1); 2785 } 2786 PL_origargv[0][PL_origalen-1] = 0; 2787 for (i = 1; i < PL_origargc; i++) 2788 PL_origargv[i] = 0; 2789 #ifdef HAS_PRCTL_SET_NAME 2790 /* Set the legacy process name in addition to the POSIX name on Linux */ 2791 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { 2792 /* diag_listed_as: SKIPME */ 2793 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); 2794 } 2795 #endif 2796 } 2797 #endif 2798 } 2799 2800 int 2801 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 2802 { 2803 #ifdef USE_ITHREADS 2804 dVAR; 2805 #endif 2806 I32 paren; 2807 const REGEXP * rx; 2808 I32 i; 2809 STRLEN len; 2810 MAGIC *tmg; 2811 2812 PERL_ARGS_ASSERT_MAGIC_SET; 2813 2814 if (!mg->mg_ptr) { 2815 paren = mg->mg_len; 2816 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 2817 setparen_got_rx: 2818 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); 2819 } else { 2820 /* Croak with a READONLY error when a numbered match var is 2821 * set without a previous pattern match. Unless it's C<local $1> 2822 */ 2823 croakparen: 2824 if (!PL_localizing) { 2825 Perl_croak_no_modify(); 2826 } 2827 } 2828 return 0; 2829 } 2830 2831 switch (*mg->mg_ptr) { 2832 case '\001': /* ^A */ 2833 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); 2834 else SvOK_off(PL_bodytarget); 2835 FmLINES(PL_bodytarget) = 0; 2836 if (SvPOK(PL_bodytarget)) { 2837 char *s = SvPVX(PL_bodytarget); 2838 char *e = SvEND(PL_bodytarget); 2839 while ( ((s = (char *) memchr(s, '\n', e - s))) ) { 2840 FmLINES(PL_bodytarget)++; 2841 s++; 2842 } 2843 } 2844 /* mg_set() has temporarily made sv non-magical */ 2845 if (TAINTING_get) { 2846 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) 2847 SvTAINTED_on(PL_bodytarget); 2848 else 2849 SvTAINTED_off(PL_bodytarget); 2850 } 2851 break; 2852 case '\003': /* ^C */ 2853 PL_minus_c = cBOOL(SvIV(sv)); 2854 break; 2855 2856 case '\004': /* ^D */ 2857 #ifdef DEBUGGING 2858 { 2859 const char *s = SvPV_nolen_const(sv); 2860 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; 2861 if (DEBUG_x_TEST || DEBUG_B_TEST) 2862 dump_all_perl(!DEBUG_B_TEST); 2863 } 2864 #else 2865 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; 2866 #endif 2867 break; 2868 case '\005': /* ^E */ 2869 if (*(mg->mg_ptr+1) == '\0') { 2870 #ifdef VMS 2871 set_vaxc_errno(SvIV(sv)); 2872 #elif defined(WIN32) 2873 SetLastError( SvIV(sv) ); 2874 #elif defined(OS2) 2875 os2_setsyserrno(SvIV(sv)); 2876 #else 2877 /* will anyone ever use this? */ 2878 SETERRNO(SvIV(sv), 4); 2879 #endif 2880 } 2881 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) 2882 Perl_croak(aTHX_ "${^ENCODING} is no longer supported"); 2883 break; 2884 case '\006': /* ^F */ 2885 if (mg->mg_ptr[1] == '\0') { 2886 PL_maxsysfd = SvIV(sv); 2887 } 2888 break; 2889 case '\010': /* ^H */ 2890 { 2891 U32 save_hints = PL_hints; 2892 PL_hints = SvUV(sv); 2893 2894 /* If wasn't UTF-8, and now is, notify the parser */ 2895 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) { 2896 notify_parser_that_changed_to_utf8(); 2897 } 2898 } 2899 break; 2900 case '\011': /* ^I */ /* NOT \t in EBCDIC */ 2901 Safefree(PL_inplace); 2902 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; 2903 break; 2904 case '\016': /* ^N */ 2905 if (PL_curpm && (rx = PM_GETRE(PL_curpm)) 2906 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; 2907 goto croakparen; 2908 case '\017': /* ^O */ 2909 if (*(mg->mg_ptr+1) == '\0') { 2910 Safefree(PL_osname); 2911 PL_osname = NULL; 2912 if (SvOK(sv)) { 2913 TAINT_PROPER("assigning to $^O"); 2914 PL_osname = savesvpv(sv); 2915 } 2916 } 2917 else if (strEQ(mg->mg_ptr, "\017PEN")) { 2918 STRLEN len; 2919 const char *const start = SvPV(sv, len); 2920 const char *out = (const char*)memchr(start, '\0', len); 2921 SV *tmp; 2922 2923 2924 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; 2925 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; 2926 2927 /* Opening for input is more common than opening for output, so 2928 ensure that hints for input are sooner on linked list. */ 2929 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, 2930 SvUTF8(sv)) 2931 : newSVpvs_flags("", SvUTF8(sv)); 2932 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); 2933 mg_set(tmp); 2934 2935 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, 2936 SvUTF8(sv)); 2937 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); 2938 mg_set(tmp); 2939 } 2940 break; 2941 case '\020': /* ^P */ 2942 PL_perldb = SvIV(sv); 2943 if (PL_perldb && !PL_DBsingle) 2944 init_debugger(); 2945 break; 2946 case '\024': /* ^T */ 2947 #ifdef BIG_TIME 2948 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); 2949 #else 2950 PL_basetime = (Time_t)SvIV(sv); 2951 #endif 2952 break; 2953 case '\025': /* ^UTF8CACHE */ 2954 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { 2955 PL_utf8cache = (signed char) sv_2iv(sv); 2956 } 2957 break; 2958 case '\027': /* ^W & $^WARNING_BITS */ 2959 if (*(mg->mg_ptr+1) == '\0') { 2960 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 2961 i = SvIV(sv); 2962 PL_dowarn = (PL_dowarn & ~G_WARN_ON) 2963 | (i ? G_WARN_ON : G_WARN_OFF) ; 2964 } 2965 } 2966 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 2967 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 2968 if (!SvPOK(sv)) { 2969 free_and_set_cop_warnings(&PL_compiling, pWARN_STD); 2970 break; 2971 } 2972 { 2973 STRLEN len, i; 2974 int not_none = 0, not_all = 0; 2975 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; 2976 for (i = 0 ; i < len ; ++i) { 2977 not_none |= ptr[i]; 2978 not_all |= ptr[i] ^ 0x55; 2979 } 2980 if (!not_none) { 2981 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); 2982 } else if (len >= WARNsize && !not_all) { 2983 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); 2984 PL_dowarn |= G_WARN_ONCE ; 2985 } 2986 else { 2987 STRLEN len; 2988 const char *const p = SvPV_const(sv, len); 2989 2990 PL_compiling.cop_warnings 2991 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, 2992 p, len); 2993 2994 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) 2995 PL_dowarn |= G_WARN_ONCE ; 2996 } 2997 2998 } 2999 } 3000 } 3001 #ifdef WIN32 3002 else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) { 3003 w32_sloppystat = (bool)sv_true(sv); 3004 } 3005 #endif 3006 break; 3007 case '.': 3008 if (PL_localizing) { 3009 if (PL_localizing == 1) 3010 SAVESPTR(PL_last_in_gv); 3011 } 3012 else if (SvOK(sv) && GvIO(PL_last_in_gv)) 3013 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); 3014 break; 3015 case '^': 3016 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); 3017 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 3018 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); 3019 break; 3020 case '~': 3021 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); 3022 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 3023 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); 3024 break; 3025 case '=': 3026 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); 3027 break; 3028 case '-': 3029 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); 3030 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) 3031 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; 3032 break; 3033 case '%': 3034 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); 3035 break; 3036 case '|': 3037 { 3038 IO * const io = GvIO(PL_defoutgv); 3039 if(!io) 3040 break; 3041 if ((SvIV(sv)) == 0) 3042 IoFLAGS(io) &= ~IOf_FLUSH; 3043 else { 3044 if (!(IoFLAGS(io) & IOf_FLUSH)) { 3045 PerlIO *ofp = IoOFP(io); 3046 if (ofp) 3047 (void)PerlIO_flush(ofp); 3048 IoFLAGS(io) |= IOf_FLUSH; 3049 } 3050 } 3051 } 3052 break; 3053 case '/': 3054 { 3055 if (SvROK(sv)) { 3056 SV *referent = SvRV(sv); 3057 const char *reftype = sv_reftype(referent, 0); 3058 /* XXX: dodgy type check: This leaves me feeling dirty, but 3059 * the alternative is to copy pretty much the entire 3060 * sv_reftype() into this routine, or to do a full string 3061 * comparison on the return of sv_reftype() both of which 3062 * make me feel worse! NOTE, do not modify this comment 3063 * without reviewing the corresponding comment in 3064 * sv_reftype(). - Yves */ 3065 if (reftype[0] == 'S' || reftype[0] == 'L') { 3066 IV val = SvIV(referent); 3067 if (val <= 0) { 3068 sv_setsv(sv, PL_rs); 3069 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden", 3070 val < 0 ? "a negative integer" : "zero"); 3071 } 3072 } else { 3073 sv_setsv(sv, PL_rs); 3074 /* diag_listed_as: Setting $/ to %s reference is forbidden */ 3075 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden", 3076 *reftype == 'A' ? "n" : "", reftype); 3077 } 3078 } 3079 SvREFCNT_dec(PL_rs); 3080 PL_rs = newSVsv(sv); 3081 } 3082 break; 3083 case '\\': 3084 SvREFCNT_dec(PL_ors_sv); 3085 if (SvOK(sv)) { 3086 PL_ors_sv = newSVsv(sv); 3087 } 3088 else { 3089 PL_ors_sv = NULL; 3090 } 3091 break; 3092 case '[': 3093 if (SvIV(sv) != 0) 3094 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); 3095 break; 3096 case '?': 3097 #ifdef COMPLEX_STATUS 3098 if (PL_localizing == 2) { 3099 SvUPGRADE(sv, SVt_PVLV); 3100 PL_statusvalue = LvTARGOFF(sv); 3101 PL_statusvalue_vms = LvTARGLEN(sv); 3102 } 3103 else 3104 #endif 3105 #ifdef VMSISH_STATUS 3106 if (VMSISH_STATUS) 3107 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); 3108 else 3109 #endif 3110 STATUS_UNIX_EXIT_SET(SvIV(sv)); 3111 break; 3112 case '!': 3113 { 3114 #ifdef VMS 3115 # define PERL_VMS_BANG vaxc$errno 3116 #else 3117 # define PERL_VMS_BANG 0 3118 #endif 3119 #if defined(WIN32) 3120 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), 3121 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); 3122 #else 3123 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, 3124 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); 3125 #endif 3126 } 3127 break; 3128 case '<': 3129 { 3130 /* XXX $< currently silently ignores failures */ 3131 const Uid_t new_uid = SvUID(sv); 3132 PL_delaymagic_uid = new_uid; 3133 if (PL_delaymagic) { 3134 PL_delaymagic |= DM_RUID; 3135 break; /* don't do magic till later */ 3136 } 3137 #ifdef HAS_SETRUID 3138 PERL_UNUSED_RESULT(setruid(new_uid)); 3139 #elif defined(HAS_SETREUID) 3140 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1)); 3141 #elif defined(HAS_SETRESUID) 3142 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1)); 3143 #else 3144 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ 3145 # ifdef PERL_DARWIN 3146 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ 3147 if (new_uid != 0 && PerlProc_getuid() == 0) 3148 PERL_UNUSED_RESULT(PerlProc_setuid(0)); 3149 # endif 3150 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid)); 3151 } else { 3152 Perl_croak(aTHX_ "setruid() not implemented"); 3153 } 3154 #endif 3155 break; 3156 } 3157 case '>': 3158 { 3159 /* XXX $> currently silently ignores failures */ 3160 const Uid_t new_euid = SvUID(sv); 3161 PL_delaymagic_euid = new_euid; 3162 if (PL_delaymagic) { 3163 PL_delaymagic |= DM_EUID; 3164 break; /* don't do magic till later */ 3165 } 3166 #ifdef HAS_SETEUID 3167 PERL_UNUSED_RESULT(seteuid(new_euid)); 3168 #elif defined(HAS_SETREUID) 3169 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); 3170 #elif defined(HAS_SETRESUID) 3171 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); 3172 #else 3173 if (new_euid == PerlProc_getuid()) /* special case $> = $< */ 3174 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid)); 3175 else { 3176 Perl_croak(aTHX_ "seteuid() not implemented"); 3177 } 3178 #endif 3179 break; 3180 } 3181 case '(': 3182 { 3183 /* XXX $( currently silently ignores failures */ 3184 const Gid_t new_gid = SvGID(sv); 3185 PL_delaymagic_gid = new_gid; 3186 if (PL_delaymagic) { 3187 PL_delaymagic |= DM_RGID; 3188 break; /* don't do magic till later */ 3189 } 3190 #ifdef HAS_SETRGID 3191 PERL_UNUSED_RESULT(setrgid(new_gid)); 3192 #elif defined(HAS_SETREGID) 3193 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); 3194 #elif defined(HAS_SETRESGID) 3195 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1)); 3196 #else 3197 if (new_gid == PerlProc_getegid()) /* special case $( = $) */ 3198 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid)); 3199 else { 3200 Perl_croak(aTHX_ "setrgid() not implemented"); 3201 } 3202 #endif 3203 break; 3204 } 3205 case ')': 3206 { 3207 /* (hv) best guess: maybe we'll need configure probes to do a better job, 3208 * but you can override it if you need to. 3209 */ 3210 #ifndef INVALID_GID 3211 #define INVALID_GID ((Gid_t)-1) 3212 #endif 3213 /* XXX $) currently silently ignores failures */ 3214 Gid_t new_egid; 3215 #ifdef HAS_SETGROUPS 3216 { 3217 const char *p = SvPV_const(sv, len); 3218 Groups_t *gary = NULL; 3219 const char* p_end = p + len; 3220 const char* endptr = p_end; 3221 UV uv; 3222 #ifdef _SC_NGROUPS_MAX 3223 int maxgrp = sysconf(_SC_NGROUPS_MAX); 3224 3225 if (maxgrp < 0) 3226 maxgrp = NGROUPS; 3227 #else 3228 int maxgrp = NGROUPS; 3229 #endif 3230 3231 while (isSPACE(*p)) 3232 ++p; 3233 if (grok_atoUV(p, &uv, &endptr)) 3234 new_egid = (Gid_t)uv; 3235 else { 3236 new_egid = INVALID_GID; 3237 endptr = NULL; 3238 } 3239 for (i = 0; i < maxgrp; ++i) { 3240 if (endptr == NULL) 3241 break; 3242 p = endptr; 3243 endptr = p_end; 3244 while (isSPACE(*p)) 3245 ++p; 3246 if (!*p) 3247 break; 3248 if (!gary) 3249 Newx(gary, i + 1, Groups_t); 3250 else 3251 Renew(gary, i + 1, Groups_t); 3252 if (grok_atoUV(p, &uv, &endptr)) 3253 gary[i] = (Groups_t)uv; 3254 else { 3255 gary[i] = INVALID_GID; 3256 endptr = NULL; 3257 } 3258 } 3259 if (i) 3260 PERL_UNUSED_RESULT(setgroups(i, gary)); 3261 Safefree(gary); 3262 } 3263 #else /* HAS_SETGROUPS */ 3264 new_egid = SvGID(sv); 3265 #endif /* HAS_SETGROUPS */ 3266 PL_delaymagic_egid = new_egid; 3267 if (PL_delaymagic) { 3268 PL_delaymagic |= DM_EGID; 3269 break; /* don't do magic till later */ 3270 } 3271 #ifdef HAS_SETEGID 3272 PERL_UNUSED_RESULT(setegid(new_egid)); 3273 #elif defined(HAS_SETREGID) 3274 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); 3275 #elif defined(HAS_SETRESGID) 3276 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); 3277 #else 3278 if (new_egid == PerlProc_getgid()) /* special case $) = $( */ 3279 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid)); 3280 else { 3281 Perl_croak(aTHX_ "setegid() not implemented"); 3282 } 3283 #endif 3284 break; 3285 } 3286 case ':': 3287 PL_chopset = SvPV_force(sv,len); 3288 break; 3289 case '$': /* $$ */ 3290 /* Store the pid in mg->mg_obj so we can tell when a fork has 3291 occurred. mg->mg_obj points to *$ by default, so clear it. */ 3292 if (isGV(mg->mg_obj)) { 3293 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ 3294 SvREFCNT_dec(mg->mg_obj); 3295 mg->mg_flags |= MGf_REFCOUNTED; 3296 mg->mg_obj = newSViv((IV)PerlProc_getpid()); 3297 } 3298 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); 3299 break; 3300 case '0': 3301 LOCK_DOLLARZERO_MUTEX; 3302 S_set_dollarzero(aTHX_ sv); 3303 UNLOCK_DOLLARZERO_MUTEX; 3304 break; 3305 } 3306 return 0; 3307 } 3308 3309 I32 3310 Perl_whichsig_sv(pTHX_ SV *sigsv) 3311 { 3312 const char *sigpv; 3313 STRLEN siglen; 3314 PERL_ARGS_ASSERT_WHICHSIG_SV; 3315 sigpv = SvPV_const(sigsv, siglen); 3316 return whichsig_pvn(sigpv, siglen); 3317 } 3318 3319 I32 3320 Perl_whichsig_pv(pTHX_ const char *sig) 3321 { 3322 PERL_ARGS_ASSERT_WHICHSIG_PV; 3323 return whichsig_pvn(sig, strlen(sig)); 3324 } 3325 3326 I32 3327 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) 3328 { 3329 char* const* sigv; 3330 3331 PERL_ARGS_ASSERT_WHICHSIG_PVN; 3332 PERL_UNUSED_CONTEXT; 3333 3334 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) 3335 if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) 3336 return PL_sig_num[sigv - (char* const*)PL_sig_name]; 3337 #ifdef SIGCLD 3338 if (memEQs(sig, len, "CHLD")) 3339 return SIGCLD; 3340 #endif 3341 #ifdef SIGCHLD 3342 if (memEQs(sig, len, "CLD")) 3343 return SIGCHLD; 3344 #endif 3345 return -1; 3346 } 3347 3348 3349 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3(): 3350 * these three function are intended to be called by the OS as 'C' level 3351 * signal handler functions in the case where unsafe signals are being 3352 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the 3353 * perl-level sighandler, rather than deferring. 3354 * In fact, the core itself will normally use Perl_csighandler as the 3355 * OS-level handler; that function will then decide whether to queue the 3356 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these 3357 * functions are more useful for e.g. POSIX.xs when it wants explicit 3358 * control of what's happening. 3359 */ 3360 3361 3362 #ifdef PERL_USE_3ARG_SIGHANDLER 3363 3364 Signal_t 3365 Perl_sighandler(int sig, Siginfo_t *sip, void *uap) 3366 { 3367 Perl_perly_sighandler(sig, sip, uap, 0); 3368 } 3369 3370 #else 3371 3372 Signal_t 3373 Perl_sighandler(int sig) 3374 { 3375 Perl_perly_sighandler(sig, NULL, NULL, 0); 3376 } 3377 3378 #endif 3379 3380 Signal_t 3381 Perl_sighandler1(int sig) 3382 { 3383 Perl_perly_sighandler(sig, NULL, NULL, 0); 3384 } 3385 3386 Signal_t 3387 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) 3388 { 3389 Perl_perly_sighandler(sig, sip, uap, 0); 3390 } 3391 3392 3393 /* Invoke the perl-level signal handler. This function is called either 3394 * directly from one of the C-level signals handlers (Perl_sighandler or 3395 * Perl_csighandler), or for safe signals, later from 3396 * Perl_despatch_signals() at a suitable safe point during execution. 3397 * 3398 * 'safe' is a boolean indicating the latter call path. 3399 */ 3400 3401 Signal_t 3402 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, 3403 void *uap PERL_UNUSED_DECL, bool safe) 3404 { 3405 #ifdef PERL_GET_SIG_CONTEXT 3406 dTHXa(PERL_GET_SIG_CONTEXT); 3407 #else 3408 dTHX; 3409 #endif 3410 dSP; 3411 GV *gv = NULL; 3412 SV *sv = NULL; 3413 SV * const tSv = PL_Sv; 3414 CV *cv = NULL; 3415 OP *myop = PL_op; 3416 U32 flags = 0; 3417 XPV * const tXpv = PL_Xpv; 3418 I32 old_ss_ix = PL_savestack_ix; 3419 SV *errsv_save = NULL; 3420 3421 3422 if (!PL_psig_ptr[sig]) { 3423 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", 3424 PL_sig_name[sig]); 3425 exit(sig); 3426 } 3427 3428 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { 3429 /* Max number of items pushed there is 3*n or 4. We cannot fix 3430 infinity, so we fix 4 (in fact 5): */ 3431 if (PL_savestack_ix + 15 <= PL_savestack_max) { 3432 flags |= 1; 3433 PL_savestack_ix += 5; /* Protect save in progress. */ 3434 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); 3435 } 3436 } 3437 /* sv_2cv is too complicated, try a simpler variant first: */ 3438 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) 3439 || SvTYPE(cv) != SVt_PVCV) { 3440 HV *st; 3441 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); 3442 } 3443 3444 if (!cv || !CvROOT(cv)) { 3445 const HEK * const hek = gv 3446 ? GvENAME_HEK(gv) 3447 : cv && CvNAMED(cv) 3448 ? CvNAME_HEK(cv) 3449 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; 3450 if (hek) 3451 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), 3452 "SIG%s handler \"%" HEKf "\" not defined.\n", 3453 PL_sig_name[sig], HEKfARG(hek)); 3454 /* diag_listed_as: SIG%s handler "%s" not defined */ 3455 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), 3456 "SIG%s handler \"__ANON__\" not defined.\n", 3457 PL_sig_name[sig]); 3458 goto cleanup; 3459 } 3460 3461 sv = PL_psig_name[sig] 3462 ? SvREFCNT_inc_NN(PL_psig_name[sig]) 3463 : newSVpv(PL_sig_name[sig],0); 3464 flags |= 8; 3465 SAVEFREESV(sv); 3466 3467 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { 3468 /* make sure our assumption about the size of the SAVEs are correct: 3469 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ 3470 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); 3471 } 3472 3473 PUSHSTACKi(PERLSI_SIGNAL); 3474 PUSHMARK(SP); 3475 PUSHs(sv); 3476 3477 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) 3478 { 3479 struct sigaction oact; 3480 3481 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { 3482 HV *sih = newHV(); 3483 SV *rv = newRV_noinc(MUTABLE_SV(sih)); 3484 /* The siginfo fields signo, code, errno, pid, uid, 3485 * addr, status, and band are defined by POSIX/SUSv3. */ 3486 (void)hv_stores(sih, "signo", newSViv(sip->si_signo)); 3487 (void)hv_stores(sih, "code", newSViv(sip->si_code)); 3488 # ifdef HAS_SIGINFO_SI_ERRNO 3489 (void)hv_stores(sih, "errno", newSViv(sip->si_errno)); 3490 # endif 3491 # ifdef HAS_SIGINFO_SI_STATUS 3492 (void)hv_stores(sih, "status", newSViv(sip->si_status)); 3493 # endif 3494 # ifdef HAS_SIGINFO_SI_UID 3495 { 3496 SV *uid = newSV(0); 3497 sv_setuid(uid, sip->si_uid); 3498 (void)hv_stores(sih, "uid", uid); 3499 } 3500 # endif 3501 # ifdef HAS_SIGINFO_SI_PID 3502 (void)hv_stores(sih, "pid", newSViv(sip->si_pid)); 3503 # endif 3504 # ifdef HAS_SIGINFO_SI_ADDR 3505 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr))); 3506 # endif 3507 # ifdef HAS_SIGINFO_SI_BAND 3508 (void)hv_stores(sih, "band", newSViv(sip->si_band)); 3509 # endif 3510 EXTEND(SP, 2); 3511 PUSHs(rv); 3512 mPUSHp((char *)sip, sizeof(*sip)); 3513 3514 } 3515 } 3516 #endif 3517 3518 PUTBACK; 3519 3520 errsv_save = newSVsv(ERRSV); 3521 3522 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); 3523 3524 POPSTACK; 3525 { 3526 SV * const errsv = ERRSV; 3527 if (SvTRUE_NN(errsv)) { 3528 SvREFCNT_dec(errsv_save); 3529 3530 #ifndef PERL_MICRO 3531 /* Handler "died", for example to get out of a restart-able read(). 3532 * Before we re-do that on its behalf re-enable the signal which was 3533 * blocked by the system when we entered. 3534 */ 3535 # ifdef HAS_SIGPROCMASK 3536 if (!safe) { 3537 /* safe signals called via dispatch_signals() set up a 3538 * savestack destructor, unblock_sigmask(), to 3539 * automatically unblock the handler at the end. If 3540 * instead we get here directly, we have to do it 3541 * ourselves 3542 */ 3543 sigset_t set; 3544 sigemptyset(&set); 3545 sigaddset(&set,sig); 3546 sigprocmask(SIG_UNBLOCK, &set, NULL); 3547 } 3548 # else 3549 /* Not clear if this will work */ 3550 /* XXX not clear if this should be protected by 'if (safe)' 3551 * too */ 3552 3553 (void)rsignal(sig, SIG_IGN); 3554 (void)rsignal(sig, PL_csighandlerp); 3555 # endif 3556 #endif /* !PERL_MICRO */ 3557 3558 die_sv(errsv); 3559 } 3560 else { 3561 sv_setsv(errsv, errsv_save); 3562 SvREFCNT_dec(errsv_save); 3563 } 3564 } 3565 3566 cleanup: 3567 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ 3568 PL_savestack_ix = old_ss_ix; 3569 if (flags & 8) 3570 SvREFCNT_dec_NN(sv); 3571 PL_op = myop; /* Apparently not needed... */ 3572 3573 PL_Sv = tSv; /* Restore global temporaries. */ 3574 PL_Xpv = tXpv; 3575 return; 3576 } 3577 3578 3579 static void 3580 S_restore_magic(pTHX_ const void *p) 3581 { 3582 MGS* const mgs = SSPTR(PTR2IV(p), MGS*); 3583 SV* const sv = mgs->mgs_sv; 3584 bool bumped; 3585 3586 if (!sv) 3587 return; 3588 3589 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 3590 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ 3591 if (mgs->mgs_flags) 3592 SvFLAGS(sv) |= mgs->mgs_flags; 3593 else 3594 mg_magical(sv); 3595 } 3596 3597 bumped = mgs->mgs_bumped; 3598 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ 3599 3600 /* If we're still on top of the stack, pop us off. (That condition 3601 * will be satisfied if restore_magic was called explicitly, but *not* 3602 * if it's being called via leave_scope.) 3603 * The reason for doing this is that otherwise, things like sv_2cv() 3604 * may leave alloc gunk on the savestack, and some code 3605 * (e.g. sighandler) doesn't expect that... 3606 */ 3607 if (PL_savestack_ix == mgs->mgs_ss_ix) 3608 { 3609 UV popval = SSPOPUV; 3610 assert(popval == SAVEt_DESTRUCTOR_X); 3611 PL_savestack_ix -= 2; 3612 popval = SSPOPUV; 3613 assert((popval & SAVE_MASK) == SAVEt_ALLOC); 3614 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT; 3615 } 3616 if (bumped) { 3617 if (SvREFCNT(sv) == 1) { 3618 /* We hold the last reference to this SV, which implies that the 3619 SV was deleted as a side effect of the routines we called. 3620 So artificially keep it alive a bit longer. 3621 We avoid turning on the TEMP flag, which can cause the SV's 3622 buffer to get stolen (and maybe other stuff). */ 3623 sv_2mortal(sv); 3624 SvTEMP_off(sv); 3625 } 3626 else 3627 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ 3628 } 3629 } 3630 3631 /* clean up the mess created by Perl_sighandler(). 3632 * Note that this is only called during an exit in a signal handler; 3633 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually 3634 * skipped over. */ 3635 3636 static void 3637 S_unwind_handler_stack(pTHX_ const void *p) 3638 { 3639 PERL_UNUSED_ARG(p); 3640 3641 PL_savestack_ix -= 5; /* Unprotect save in progress. */ 3642 } 3643 3644 /* 3645 =for apidoc magic_sethint 3646 3647 Triggered by a store to C<%^H>, records the key/value pair to 3648 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing 3649 anything that would need a deep copy. Maybe we should warn if we find a 3650 reference. 3651 3652 =cut 3653 */ 3654 int 3655 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) 3656 { 3657 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) 3658 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); 3659 3660 PERL_ARGS_ASSERT_MAGIC_SETHINT; 3661 3662 /* mg->mg_obj isn't being used. If needed, it would be possible to store 3663 an alternative leaf in there, with PL_compiling.cop_hints being used if 3664 it's NULL. If needed for threads, the alternative could lock a mutex, 3665 or take other more complex action. */ 3666 3667 /* Something changed in %^H, so it will need to be restored on scope exit. 3668 Doing this here saves a lot of doing it manually in perl code (and 3669 forgetting to do it, and consequent subtle errors. */ 3670 PL_hints |= HINT_LOCALIZE_HH; 3671 CopHINTHASH_set(&PL_compiling, 3672 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); 3673 magic_sethint_feature(key, NULL, 0, sv, 0); 3674 return 0; 3675 } 3676 3677 /* 3678 =for apidoc magic_clearhint 3679 3680 Triggered by a delete from C<%^H>, records the key to 3681 C<PL_compiling.cop_hints_hash>. 3682 3683 =cut 3684 */ 3685 int 3686 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) 3687 { 3688 PERL_ARGS_ASSERT_MAGIC_CLEARHINT; 3689 PERL_UNUSED_ARG(sv); 3690 3691 PL_hints |= HINT_LOCALIZE_HH; 3692 CopHINTHASH_set(&PL_compiling, 3693 mg->mg_len == HEf_SVKEY 3694 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), 3695 MUTABLE_SV(mg->mg_ptr), 0, 0) 3696 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), 3697 mg->mg_ptr, mg->mg_len, 0, 0)); 3698 if (mg->mg_len == HEf_SVKEY) 3699 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE); 3700 else 3701 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE); 3702 return 0; 3703 } 3704 3705 /* 3706 =for apidoc magic_clearhints 3707 3708 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>. 3709 3710 =cut 3711 */ 3712 int 3713 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) 3714 { 3715 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; 3716 PERL_UNUSED_ARG(sv); 3717 PERL_UNUSED_ARG(mg); 3718 cophh_free(CopHINTHASH_get(&PL_compiling)); 3719 CopHINTHASH_set(&PL_compiling, cophh_new_empty()); 3720 CLEARFEATUREBITS(); 3721 return 0; 3722 } 3723 3724 int 3725 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, 3726 const char *name, I32 namlen) 3727 { 3728 MAGIC *nmg; 3729 3730 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER; 3731 PERL_UNUSED_ARG(sv); 3732 PERL_UNUSED_ARG(name); 3733 PERL_UNUSED_ARG(namlen); 3734 3735 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0); 3736 nmg = mg_find(nsv, mg->mg_type); 3737 assert(nmg); 3738 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj); 3739 nmg->mg_ptr = mg->mg_ptr; 3740 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj); 3741 nmg->mg_flags |= MGf_REFCOUNTED; 3742 return 1; 3743 } 3744 3745 int 3746 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) { 3747 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR; 3748 3749 #if DBVARMG_SINGLE != 0 3750 assert(mg->mg_private >= DBVARMG_SINGLE); 3751 #endif 3752 assert(mg->mg_private < DBVARMG_COUNT); 3753 3754 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv); 3755 3756 return 1; 3757 } 3758 3759 int 3760 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) { 3761 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR; 3762 3763 #if DBVARMG_SINGLE != 0 3764 assert(mg->mg_private >= DBVARMG_SINGLE); 3765 #endif 3766 assert(mg->mg_private < DBVARMG_COUNT); 3767 sv_setiv(sv, PL_DBcontrol[mg->mg_private]); 3768 3769 return 0; 3770 } 3771 3772 /* 3773 * ex: set ts=8 sts=4 sw=4 et: 3774 */ 3775