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