mg.c

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