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