mg.c

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