mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (c) 1991-1999, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
  12  * come here, and I don't want to see no more magic,' he said, and fell silent."
  13  */
  14
  15 #include "EXTERN.h"
  16 #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, const 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 = end + strlen(end+1)+2;
 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 int
1044 magic_setamagic(SV *sv, MAGIC *mg)
1045 {
1046     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1047     PL_amagic_generation++;
1048
1049     return 0;
1050 }
1051
1052 int
1053 magic_getnkeys(SV *sv, MAGIC *mg)
1054 {
1055     HV *hv = (HV*)LvTARG(sv);
1056     HE *entry;
1057     I32 i = 0;
1058
1059     if (hv) {
1060         (void) hv_iterinit(hv);
1061         if (! SvTIED_mg((SV*)hv, 'P'))
1062             i = HvKEYS(hv);
1063         else {
1064             /*SUPPRESS 560*/
1065             while (entry = hv_iternext(hv)) {
1066                 i++;
1067             }
1068         }
1069     }
1070
1071     sv_setiv(sv, (IV)i);
1072     return 0;
1073 }
1074
1075 int
1076 magic_setnkeys(SV *sv, MAGIC *mg)
1077 {
1078     if (LvTARG(sv)) {
1079         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1080     }
1081     return 0;
1082 }
1083
1084 /* caller is responsible for stack switching/cleanup */
1085 STATIC int
1086 magic_methcall(SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1087 {
1088     dSP;
1089
1090     PUSHMARK(SP);
1091     EXTEND(SP, n);
1092     PUSHs(SvTIED_obj(sv, mg));
1093     if (n > 1) {
1094         if (mg->mg_ptr) {
1095             if (mg->mg_len >= 0)
1096                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1097             else if (mg->mg_len == HEf_SVKEY)
1098                 PUSHs((SV*)mg->mg_ptr);
1099         }
1100         else if (mg->mg_type == 'p') {
1101             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1102         }
1103     }
1104     if (n > 2) {
1105         PUSHs(val);
1106     }
1107     PUTBACK;
1108
1109     return perl_call_method(meth, flags);
1110 }
1111
1112 STATIC int
1113 magic_methpack(SV *sv, MAGIC *mg, char *meth)
1114 {
1115     dSP;
1116
1117     ENTER;
1118     SAVETMPS;
1119     PUSHSTACKi(PERLSI_MAGIC);
1120
1121     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1122         sv_setsv(sv, *PL_stack_sp--);
1123     }
1124
1125     POPSTACK;
1126     FREETMPS;
1127     LEAVE;
1128     return 0;
1129 }
1130
1131 int
1132 magic_getpack(SV *sv, MAGIC *mg)
1133 {
1134     magic_methpack(sv,mg,"FETCH");
1135     if (mg->mg_ptr)
1136         mg->mg_flags |= MGf_GSKIP;
1137     return 0;
1138 }
1139
1140 int
1141 magic_setpack(SV *sv, MAGIC *mg)
1142 {
1143     dSP;
1144     ENTER;
1145     PUSHSTACKi(PERLSI_MAGIC);
1146     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1147     POPSTACK;
1148     LEAVE;
1149     return 0;
1150 }
1151
1152 int
1153 magic_clearpack(SV *sv, MAGIC *mg)
1154 {
1155     return magic_methpack(sv,mg,"DELETE");
1156 }
1157
1158
1159 U32
1160 magic_sizepack(SV *sv, MAGIC *mg)
1161 {
1162     dSP;
1163     U32 retval = 0;
1164
1165     ENTER;
1166     SAVETMPS;
1167     PUSHSTACKi(PERLSI_MAGIC);
1168     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1169         sv = *PL_stack_sp--;
1170         retval = (U32) SvIV(sv)-1;
1171     }
1172     POPSTACK;
1173     FREETMPS;
1174     LEAVE;
1175     return retval;
1176 }
1177
1178 int magic_wipepack(SV *sv, MAGIC *mg)
1179 {
1180     dSP;
1181
1182     ENTER;
1183     PUSHSTACKi(PERLSI_MAGIC);
1184     PUSHMARK(SP);
1185     XPUSHs(SvTIED_obj(sv, mg));
1186     PUTBACK;
1187     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
1188     POPSTACK;
1189     LEAVE;
1190     return 0;
1191 }
1192
1193 int
1194 magic_nextpack(SV *sv, MAGIC *mg, SV *key)
1195 {
1196     dSP;
1197     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1198
1199     ENTER;
1200     SAVETMPS;
1201     PUSHSTACKi(PERLSI_MAGIC);
1202     PUSHMARK(SP);
1203     EXTEND(SP, 2);
1204     PUSHs(SvTIED_obj(sv, mg));
1205     if (SvOK(key))
1206         PUSHs(key);
1207     PUTBACK;
1208
1209     if (perl_call_method(meth, G_SCALAR))
1210         sv_setsv(key, *PL_stack_sp--);
1211
1212     POPSTACK;
1213     FREETMPS;
1214     LEAVE;
1215     return 0;
1216 }
1217
1218 int
1219 magic_existspack(SV *sv, MAGIC *mg)
1220 {
1221     return magic_methpack(sv,mg,"EXISTS");
1222 }
1223
1224 int
1225 magic_setdbline(SV *sv, MAGIC *mg)
1226 {
1227     dTHR;
1228     OP *o;
1229     I32 i;
1230     GV* gv;
1231     SV** svp;
1232     STRLEN n_a;
1233
1234     gv = PL_DBline;
1235     i = SvTRUE(sv);
1236     svp = av_fetch(GvAV(gv),
1237                      atoi(MgPV(mg,n_a)), FALSE);
1238     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
1239         o->op_private = i;
1240     else
1241         warn("Can't break at that line\n");
1242     return 0;
1243 }
1244
1245 int
1246 magic_getarylen(SV *sv, MAGIC *mg)
1247 {
1248     dTHR;
1249     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1250     return 0;
1251 }
1252
1253 int
1254 magic_setarylen(SV *sv, MAGIC *mg)
1255 {
1256     dTHR;
1257     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1258     return 0;
1259 }
1260
1261 int
1262 magic_getpos(SV *sv, MAGIC *mg)
1263 {
1264     SV* lsv = LvTARG(sv);
1265
1266     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1267         mg = mg_find(lsv, 'g');
1268         if (mg && mg->mg_len >= 0) {
1269             dTHR;
1270             I32 i = mg->mg_len;
1271             if (IN_UTF8)
1272                 sv_pos_b2u(lsv, &i);
1273             sv_setiv(sv, i + PL_curcop->cop_arybase);
1274             return 0;
1275         }
1276     }
1277     (void)SvOK_off(sv);
1278     return 0;
1279 }
1280
1281 int
1282 magic_setpos(SV *sv, MAGIC *mg)
1283 {
1284     SV* lsv = LvTARG(sv);
1285     SSize_t pos;
1286     STRLEN len;
1287     STRLEN ulen;
1288     dTHR;
1289
1290     mg = 0;
1291
1292     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1293         mg = mg_find(lsv, 'g');
1294     if (!mg) {
1295         if (!SvOK(sv))
1296             return 0;
1297         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1298         mg = mg_find(lsv, 'g');
1299     }
1300     else if (!SvOK(sv)) {
1301         mg->mg_len = -1;
1302         return 0;
1303     }
1304     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1305
1306     pos = SvIV(sv) - PL_curcop->cop_arybase;
1307
1308     if (IN_UTF8) {
1309         ulen = sv_len_utf8(lsv);
1310         if (ulen)
1311             len = ulen;
1312         else
1313             ulen = 0;
1314     }
1315
1316     if (pos < 0) {
1317         pos += len;
1318         if (pos < 0)
1319             pos = 0;
1320     }
1321     else if (pos > len)
1322         pos = len;
1323
1324     if (ulen) {
1325         I32 p = pos;
1326         sv_pos_u2b(lsv, &p, 0);
1327         pos = p;
1328     }
1329
1330     mg->mg_len = pos;
1331     mg->mg_flags &= ~MGf_MINMATCH;
1332
1333     return 0;
1334 }
1335
1336 int
1337 magic_getglob(SV *sv, MAGIC *mg)
1338 {
1339     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1340         SvFAKE_off(sv);
1341         gv_efullname3(sv,((GV*)sv), "*");
1342         SvFAKE_on(sv);
1343     }
1344     else
1345         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1346     return 0;
1347 }
1348
1349 int
1350 magic_setglob(SV *sv, MAGIC *mg)
1351 {
1352     register char *s;
1353     GV* gv;
1354     STRLEN n_a;
1355
1356     if (!SvOK(sv))
1357         return 0;
1358     s = SvPV(sv, n_a);
1359     if (*s == '*' && s[1])
1360         s++;
1361     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1362     if (sv == (SV*)gv)
1363         return 0;
1364     if (GvGP(sv))
1365         gp_free((GV*)sv);
1366     GvGP(sv) = gp_ref(GvGP(gv));
1367     return 0;
1368 }
1369
1370 int
1371 magic_getsubstr(SV *sv, MAGIC *mg)
1372 {
1373     STRLEN len;
1374     SV *lsv = LvTARG(sv);
1375     char *tmps = SvPV(lsv,len);
1376     I32 offs = LvTARGOFF(sv);
1377     I32 rem = LvTARGLEN(sv);
1378
1379     if (offs > len)
1380         offs = len;
1381     if (rem + offs > len)
1382         rem = len - offs;
1383     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1384     return 0;
1385 }
1386
1387 int
1388 magic_setsubstr(SV *sv, MAGIC *mg)
1389 {
1390     STRLEN len;
1391     char *tmps = SvPV(sv,len);
1392     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1393     return 0;
1394 }
1395
1396 int
1397 magic_gettaint(SV *sv, MAGIC *mg)
1398 {
1399     dTHR;
1400     TAINT_IF((mg->mg_len & 1) ||
1401              (mg->mg_len & 2) && mg->mg_obj == sv);     /* kludge */
1402     return 0;
1403 }
1404
1405 int
1406 magic_settaint(SV *sv, MAGIC *mg)
1407 {
1408     dTHR;
1409     if (PL_localizing) {
1410         if (PL_localizing == 1)
1411             mg->mg_len <<= 1;
1412         else
1413             mg->mg_len >>= 1;
1414     }
1415     else if (PL_tainted)
1416         mg->mg_len |= 1;
1417     else
1418         mg->mg_len &= ~1;
1419     return 0;
1420 }
1421
1422 int
1423 magic_getvec(SV *sv, MAGIC *mg)
1424 {
1425     SV *lsv = LvTARG(sv);
1426     unsigned char *s;
1427     unsigned long retnum;
1428     STRLEN lsvlen;
1429     I32 len;
1430     I32 offset;
1431     I32 size;
1432
1433     if (!lsv) {
1434         SvOK_off(sv);
1435         return 0;
1436     }
1437     s = (unsigned char *) SvPV(lsv, lsvlen);
1438     offset = LvTARGOFF(sv);
1439     size = LvTARGLEN(sv);
1440     len = (offset + size + 7) / 8;
1441
1442     /* Copied from pp_vec() */
1443
1444     if (len > lsvlen) {
1445         if (size <= 8)
1446             retnum = 0;
1447         else {
1448             offset >>= 3;
1449             if (size == 16) {
1450                 if (offset >= lsvlen)
1451                     retnum = 0;
1452                 else
1453                     retnum = (unsigned long) s[offset] << 8;
1454             }
1455             else if (size == 32) {
1456                 if (offset >= lsvlen)
1457                     retnum = 0;
1458                 else if (offset + 1 >= lsvlen)
1459                     retnum = (unsigned long) s[offset] << 24;
1460                 else if (offset + 2 >= lsvlen)
1461                     retnum = ((unsigned long) s[offset] << 24) +
1462                         ((unsigned long) s[offset + 1] << 16);
1463                 else
1464                     retnum = ((unsigned long) s[offset] << 24) +
1465                         ((unsigned long) s[offset + 1] << 16) +
1466                         (s[offset + 2] << 8);
1467             }
1468         }
1469     }
1470     else if (size < 8)
1471         retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
1472     else {
1473         offset >>= 3;
1474         if (size == 8)
1475             retnum = s[offset];
1476         else if (size == 16)
1477             retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
1478         else if (size == 32)
1479             retnum = ((unsigned long) s[offset] << 24) +
1480                 ((unsigned long) s[offset + 1] << 16) +
1481                 (s[offset + 2] << 8) + s[offset+3];
1482     }
1483
1484     sv_setuv(sv, (UV)retnum);
1485     return 0;
1486 }
1487
1488 int
1489 magic_setvec(SV *sv, MAGIC *mg)
1490 {
1491     do_vecset(sv);      /* XXX slurp this routine */
1492     return 0;
1493 }
1494
1495 int
1496 magic_getdefelem(SV *sv, MAGIC *mg)
1497 {
1498     SV *targ = Nullsv;
1499     if (LvTARGLEN(sv)) {
1500         if (mg->mg_obj) {
1501             SV *ahv = LvTARG(sv);
1502             if (SvTYPE(ahv) == SVt_PVHV) {
1503                 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1504                 if (he)
1505                     targ = HeVAL(he);
1506             }
1507             else {
1508                 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1509                 if (svp)
1510                     targ = *svp;
1511             }
1512         }
1513         else {
1514             AV* av = (AV*)LvTARG(sv);
1515             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1516                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1517         }
1518         if (targ && targ != &PL_sv_undef) {
1519             dTHR;               /* just for SvREFCNT_dec */
1520             /* somebody else defined it for us */
1521             SvREFCNT_dec(LvTARG(sv));
1522             LvTARG(sv) = SvREFCNT_inc(targ);
1523             LvTARGLEN(sv) = 0;
1524             SvREFCNT_dec(mg->mg_obj);
1525             mg->mg_obj = Nullsv;
1526             mg->mg_flags &= ~MGf_REFCOUNTED;
1527         }
1528     }
1529     else
1530         targ = LvTARG(sv);
1531     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1532     return 0;
1533 }
1534
1535 int
1536 magic_setdefelem(SV *sv, MAGIC *mg)
1537 {
1538     if (LvTARGLEN(sv))
1539         vivify_defelem(sv);
1540     if (LvTARG(sv)) {
1541         sv_setsv(LvTARG(sv), sv);
1542         SvSETMAGIC(LvTARG(sv));
1543     }
1544     return 0;
1545 }
1546
1547 void
1548 vivify_defelem(SV *sv)
1549 {
1550     dTHR;                       /* just for SvREFCNT_inc and SvREFCNT_dec*/
1551     MAGIC *mg;
1552     SV *value = Nullsv;
1553
1554     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
1555         return;
1556     if (mg->mg_obj) {
1557         SV *ahv = LvTARG(sv);
1558         STRLEN n_a;
1559         if (SvTYPE(ahv) == SVt_PVHV) {
1560             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1561             if (he)
1562                 value = HeVAL(he);
1563         }
1564         else {
1565             SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
1566             if (svp)
1567                 value = *svp;
1568         }
1569         if (!value || value == &PL_sv_undef)
1570             croak(PL_no_helem, SvPV(mg->mg_obj, n_a));
1571     }
1572     else {
1573         AV* av = (AV*)LvTARG(sv);
1574         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1575             LvTARG(sv) = Nullsv;        /* array can't be extended */
1576         else {
1577             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1578             if (!svp || (value = *svp) == &PL_sv_undef)
1579                 croak(PL_no_aelem, (I32)LvTARGOFF(sv));
1580         }
1581     }
1582     (void)SvREFCNT_inc(value);
1583     SvREFCNT_dec(LvTARG(sv));
1584     LvTARG(sv) = value;
1585     LvTARGLEN(sv) = 0;
1586     SvREFCNT_dec(mg->mg_obj);
1587     mg->mg_obj = Nullsv;
1588     mg->mg_flags &= ~MGf_REFCOUNTED;
1589 }
1590
1591 int
1592 magic_setmglob(SV *sv, MAGIC *mg)
1593 {
1594     mg->mg_len = -1;
1595     SvSCREAM_off(sv);
1596     return 0;
1597 }
1598
1599 int
1600 magic_setbm(SV *sv, MAGIC *mg)
1601 {
1602     sv_unmagic(sv, 'B');
1603     SvVALID_off(sv);
1604     return 0;
1605 }
1606
1607 int
1608 magic_setfm(SV *sv, MAGIC *mg)
1609 {
1610     sv_unmagic(sv, 'f');
1611     SvCOMPILED_off(sv);
1612     return 0;
1613 }
1614
1615 int
1616 magic_setuvar(SV *sv, MAGIC *mg)
1617 {
1618     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1619
1620     if (uf && uf->uf_set)
1621         (*uf->uf_set)(uf->uf_index, sv);
1622     return 0;
1623 }
1624
1625 int
1626 magic_freeregexp(SV *sv, MAGIC *mg)
1627 {
1628     regexp *re = (regexp *)mg->mg_obj;
1629     ReREFCNT_dec(re);
1630     return 0;
1631 }
1632
1633 #ifdef USE_LOCALE_COLLATE
1634 int
1635 magic_setcollxfrm(SV *sv, MAGIC *mg)
1636 {
1637     /*
1638      * RenE<eacute> Descartes said "I think not."
1639      * and vanished with a faint plop.
1640      */
1641     if (mg->mg_ptr) {
1642         Safefree(mg->mg_ptr);
1643         mg->mg_ptr = NULL;
1644         mg->mg_len = -1;
1645     }
1646     return 0;
1647 }
1648 #endif /* USE_LOCALE_COLLATE */
1649
1650 int
1651 magic_set(SV *sv, MAGIC *mg)
1652 {
1653     dTHR;
1654     register char *s;
1655     I32 i;
1656     STRLEN len;
1657     switch (*mg->mg_ptr) {
1658     case '\001':        /* ^A */
1659         sv_setsv(PL_bodytarget, sv);
1660         break;
1661     case '\002':        /* ^B */
1662         if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1663             if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
1664                 PL_compiling.cop_warnings = WARN_ALL;
1665             else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
1666                 PL_compiling.cop_warnings = WARN_NONE;
1667             else {
1668                 if (PL_compiling.cop_warnings != WARN_NONE &&
1669                     PL_compiling.cop_warnings != WARN_ALL)
1670                     sv_setsv(PL_compiling.cop_warnings, sv);
1671                 else
1672                     PL_compiling.cop_warnings = newSVsv(sv) ;
1673             }
1674         }
1675         break;
1676
1677     case '\003':        /* ^C */
1678         PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1679         break;
1680
1681     case '\004':        /* ^D */
1682         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1683         DEBUG_x(dump_all());
1684         break;
1685     case '\005':  /* ^E */
1686 #ifdef VMS
1687         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1688 #else
1689 #ifdef WIN32
1690         SetLastError( SvIV(sv) );
1691 #else
1692         /* will anyone ever use this? */
1693         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
1694 #endif
1695 #endif
1696         break;
1697     case '\006':        /* ^F */
1698         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1699         break;
1700     case '\010':        /* ^H */
1701         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1702         break;
1703     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
1704         if (PL_inplace)
1705             Safefree(PL_inplace);
1706         if (SvOK(sv))
1707             PL_inplace = savepv(SvPV(sv,len));
1708         else
1709             PL_inplace = Nullch;
1710         break;
1711     case '\017':        /* ^O */
1712         if (PL_osname)
1713             Safefree(PL_osname);
1714         if (SvOK(sv))
1715             PL_osname = savepv(SvPV(sv,len));
1716         else
1717             PL_osname = Nullch;
1718         break;
1719     case '\020':        /* ^P */
1720         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1721         break;
1722     case '\024':        /* ^T */
1723 #ifdef BIG_TIME
1724         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1725 #else
1726         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1727 #endif
1728         break;
1729     case '\027':        /* ^W */
1730         if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1731             i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1732             PL_dowarn = (i ? G_WARN_ON : G_WARN_OFF) ;
1733         }
1734         break;
1735     case '.':
1736         if (PL_localizing) {
1737             if (PL_localizing == 1)
1738                 save_sptr((SV**)&PL_last_in_gv);
1739         }
1740         else if (SvOK(sv) && GvIO(PL_last_in_gv))
1741             IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
1742         break;
1743     case '^':
1744         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
1745         IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1746         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1747         break;
1748     case '~':
1749         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
1750         IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1751         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1752         break;
1753     case '=':
1754         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1755         break;
1756     case '-':
1757         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1758         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1759             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
1760         break;
1761     case '%':
1762         IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1763         break;
1764     case '|':
1765         {
1766             IO *io = GvIOp(PL_defoutgv);
1767             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1768                 IoFLAGS(io) &= ~IOf_FLUSH;
1769             else {
1770                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1771                     PerlIO *ofp = IoOFP(io);
1772                     if (ofp)
1773                         (void)PerlIO_flush(ofp);
1774                     IoFLAGS(io) |= IOf_FLUSH;
1775                 }
1776             }
1777         }
1778         break;
1779     case '*':
1780         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1781         PL_multiline = (i != 0);
1782         break;
1783     case '/':
1784         SvREFCNT_dec(PL_nrs);
1785         PL_nrs = newSVsv(sv);
1786         SvREFCNT_dec(PL_rs);
1787         PL_rs = SvREFCNT_inc(PL_nrs);
1788         break;
1789     case '\\':
1790         if (PL_ors)
1791             Safefree(PL_ors);
1792         if (SvOK(sv) || SvGMAGICAL(sv))
1793             PL_ors = savepv(SvPV(sv,PL_orslen));
1794         else {
1795             PL_ors = Nullch;
1796             PL_orslen = 0;
1797         }
1798         break;
1799     case ',':
1800         if (PL_ofs)
1801             Safefree(PL_ofs);
1802         PL_ofs = savepv(SvPV(sv, PL_ofslen));
1803         break;
1804     case '#':
1805         if (PL_ofmt)
1806             Safefree(PL_ofmt);
1807         PL_ofmt = savepv(SvPV(sv,len));
1808         break;
1809     case '[':
1810         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1811         break;
1812     case '?':
1813 #ifdef COMPLEX_STATUS
1814         if (PL_localizing == 2) {
1815             PL_statusvalue = LvTARGOFF(sv);
1816             PL_statusvalue_vms = LvTARGLEN(sv);
1817         }
1818         else
1819 #endif
1820 #ifdef VMSISH_STATUS
1821         if (VMSISH_STATUS)
1822             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1823         else
1824 #endif
1825             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1826         break;
1827     case '!':
1828         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
1829                  (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
1830         break;
1831     case '<':
1832         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1833         if (PL_delaymagic) {
1834             PL_delaymagic |= DM_RUID;
1835             break;                              /* don't do magic till later */
1836         }
1837 #ifdef HAS_SETRUID
1838         (void)setruid((Uid_t)PL_uid);
1839 #else
1840 #ifdef HAS_SETREUID
1841         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
1842 #else
1843 #ifdef HAS_SETRESUID
1844       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
1845 #else
1846         if (PL_uid == PL_euid)          /* special case $< = $> */
1847             (void)PerlProc_setuid(PL_uid);
1848         else {
1849             PL_uid = (I32)PerlProc_getuid();
1850             croak("setruid() not implemented");
1851         }
1852 #endif
1853 #endif
1854 #endif
1855         PL_uid = (I32)PerlProc_getuid();
1856         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1857         break;
1858     case '>':
1859         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1860         if (PL_delaymagic) {
1861             PL_delaymagic |= DM_EUID;
1862             break;                              /* don't do magic till later */
1863         }
1864 #ifdef HAS_SETEUID
1865         (void)seteuid((Uid_t)PL_euid);
1866 #else
1867 #ifdef HAS_SETREUID
1868         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
1869 #else
1870 #ifdef HAS_SETRESUID
1871         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
1872 #else
1873         if (PL_euid == PL_uid)          /* special case $> = $< */
1874             PerlProc_setuid(PL_euid);
1875         else {
1876             PL_euid = (I32)PerlProc_geteuid();
1877             croak("seteuid() not implemented");
1878         }
1879 #endif
1880 #endif
1881 #endif
1882         PL_euid = (I32)PerlProc_geteuid();
1883         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1884         break;
1885     case '(':
1886         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1887         if (PL_delaymagic) {
1888             PL_delaymagic |= DM_RGID;
1889             break;                              /* don't do magic till later */
1890         }
1891 #ifdef HAS_SETRGID
1892         (void)setrgid((Gid_t)PL_gid);
1893 #else
1894 #ifdef HAS_SETREGID
1895         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
1896 #else
1897 #ifdef HAS_SETRESGID
1898       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
1899 #else
1900         if (PL_gid == PL_egid)                  /* special case $( = $) */
1901             (void)PerlProc_setgid(PL_gid);
1902         else {
1903             PL_gid = (I32)PerlProc_getgid();
1904             croak("setrgid() not implemented");
1905         }
1906 #endif
1907 #endif
1908 #endif
1909         PL_gid = (I32)PerlProc_getgid();
1910         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1911         break;
1912     case ')':
1913 #ifdef HAS_SETGROUPS
1914         {
1915             char *p = SvPV(sv, len);
1916             Groups_t gary[NGROUPS];
1917
1918             SET_NUMERIC_STANDARD();
1919             while (isSPACE(*p))
1920                 ++p;
1921             PL_egid = I_V(atof(p));
1922             for (i = 0; i < NGROUPS; ++i) {
1923                 while (*p && !isSPACE(*p))
1924                     ++p;
1925                 while (isSPACE(*p))
1926                     ++p;
1927                 if (!*p)
1928                     break;
1929                 gary[i] = I_V(atof(p));
1930             }
1931             if (i)
1932                 (void)setgroups(i, gary);
1933         }
1934 #else  /* HAS_SETGROUPS */
1935         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1936 #endif /* HAS_SETGROUPS */
1937         if (PL_delaymagic) {
1938             PL_delaymagic |= DM_EGID;
1939             break;                              /* don't do magic till later */
1940         }
1941 #ifdef HAS_SETEGID
1942         (void)setegid((Gid_t)PL_egid);
1943 #else
1944 #ifdef HAS_SETREGID
1945         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
1946 #else
1947 #ifdef HAS_SETRESGID
1948         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
1949 #else
1950         if (PL_egid == PL_gid)                  /* special case $) = $( */
1951             (void)PerlProc_setgid(PL_egid);
1952         else {
1953             PL_egid = (I32)PerlProc_getegid();
1954             croak("setegid() not implemented");
1955         }
1956 #endif
1957 #endif
1958 #endif
1959         PL_egid = (I32)PerlProc_getegid();
1960         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1961         break;
1962     case ':':
1963         PL_chopset = SvPV_force(sv,len);
1964         break;
1965     case '0':
1966         if (!PL_origalen) {
1967             s = PL_origargv[0];
1968             s += strlen(s);
1969             /* See if all the arguments are contiguous in memory */
1970             for (i = 1; i < PL_origargc; i++) {
1971                 if (PL_origargv[i] == s + 1
1972 #ifdef OS2
1973                     || PL_origargv[i] == s + 2
1974 #endif
1975                    )
1976                 {
1977                     ++s;
1978                     s += strlen(s);     /* this one is ok too */
1979                 }
1980                 else
1981                     break;
1982             }
1983             /* can grab env area too? */
1984             if (PL_origenviron && (PL_origenviron[0] == s + 1
1985 #ifdef OS2
1986                                 || (PL_origenviron[0] == s + 9 && (s += 8))
1987 #endif
1988                )) {
1989                 my_setenv("NoNe  SuCh", Nullch);
1990                                             /* force copy of environment */
1991                 for (i = 0; PL_origenviron[i]; i++)
1992                     if (PL_origenviron[i] == s + 1) {
1993                         ++s;
1994                         s += strlen(s);
1995                     }
1996                     else
1997                         break;
1998             }
1999             PL_origalen = s - PL_origargv[0];
2000         }
2001         s = SvPV_force(sv,len);
2002         i = len;
2003         if (i >= PL_origalen) {
2004             i = PL_origalen;
2005             /* don't allow system to limit $0 seen by script */
2006             /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
2007             Copy(s, PL_origargv[0], i, char);
2008             s = PL_origargv[0]+i;
2009             *s = '\0';
2010         }
2011         else {
2012             Copy(s, PL_origargv[0], i, char);
2013             s = PL_origargv[0]+i;
2014             *s++ = '\0';
2015             while (++i < PL_origalen)
2016                 *s++ = ' ';
2017             s = PL_origargv[0]+i;
2018             for (i = 1; i < PL_origargc; i++)
2019                 PL_origargv[i] = Nullch;
2020         }
2021         break;
2022 #ifdef USE_THREADS
2023     case '@':
2024         sv_setsv(thr->errsv, sv);
2025         break;
2026 #endif /* USE_THREADS */
2027     }
2028     return 0;
2029 }
2030
2031 #ifdef USE_THREADS
2032 int
2033 magic_mutexfree(SV *sv, MAGIC *mg)
2034 {
2035     dTHR;
2036     DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
2037                           (unsigned long)thr, (unsigned long)sv);)
2038     if (MgOWNER(mg))
2039         croak("panic: magic_mutexfree");
2040     MUTEX_DESTROY(MgMUTEXP(mg));
2041     COND_DESTROY(MgCONDP(mg));
2042     return 0;
2043 }
2044 #endif /* USE_THREADS */
2045
2046 I32
2047 whichsig(char *sig)
2048 {
2049     register char **sigv;
2050
2051     for (sigv = PL_sig_name+1; *sigv; sigv++)
2052         if (strEQ(sig,*sigv))
2053             return PL_sig_num[sigv - PL_sig_name];
2054 #ifdef SIGCLD
2055     if (strEQ(sig,"CHLD"))
2056         return SIGCLD;
2057 #endif
2058 #ifdef SIGCHLD
2059     if (strEQ(sig,"CLD"))
2060         return SIGCHLD;
2061 #endif
2062     return 0;
2063 }
2064
2065 static SV* sig_sv;
2066
2067 STATIC void
2068 unwind_handler_stack(void *p)
2069 {
2070     dTHR;
2071     U32 flags = *(U32*)p;
2072
2073     if (flags & 1)
2074         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2075     /* cxstack_ix-- Not needed, die already unwound it. */
2076     if (flags & 64)
2077         SvREFCNT_dec(sig_sv);
2078 }
2079
2080 Signal_t
2081 sighandler(int sig)
2082 {
2083     dSP;
2084     GV *gv = Nullgv;
2085     HV *st;
2086     SV *sv, *tSv = PL_Sv;
2087     CV *cv = Nullcv;
2088     OP *myop = PL_op;
2089     U32 flags = 0;
2090     I32 o_save_i = PL_savestack_ix, type;
2091     XPV *tXpv = PL_Xpv;
2092
2093     if (PL_savestack_ix + 15 <= PL_savestack_max)
2094         flags |= 1;
2095     if (PL_markstack_ptr < PL_markstack_max - 2)
2096         flags |= 4;
2097     if (PL_retstack_ix < PL_retstack_max - 2)
2098         flags |= 8;
2099     if (PL_scopestack_ix < PL_scopestack_max - 3)
2100         flags |= 16;
2101
2102     if (!PL_psig_ptr[sig])
2103         die("Signal SIG%s received, but no signal handler set.\n",
2104             PL_sig_name[sig]);
2105
2106     /* Max number of items pushed there is 3*n or 4. We cannot fix
2107        infinity, so we fix 4 (in fact 5): */
2108     if (flags & 1) {
2109         PL_savestack_ix += 5;           /* Protect save in progress. */
2110         o_save_i = PL_savestack_ix;
2111         SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
2112     }
2113     if (flags & 4)
2114         PL_markstack_ptr++;             /* Protect mark. */
2115     if (flags & 8) {
2116         PL_retstack_ix++;
2117         PL_retstack[PL_retstack_ix] = NULL;
2118     }
2119     if (flags & 16)
2120         PL_scopestack_ix += 1;
2121     /* sv_2cv is too complicated, try a simpler variant first: */
2122     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2123         || SvTYPE(cv) != SVt_PVCV)
2124         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2125
2126     if (!cv || !CvROOT(cv)) {
2127         if (ckWARN(WARN_SIGNAL))
2128             warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
2129                 PL_sig_name[sig], (gv ? GvENAME(gv)
2130                                 : ((cv && CvGV(cv))
2131                                    ? GvENAME(CvGV(cv))
2132                                    : "__ANON__")));
2133         goto cleanup;
2134     }
2135
2136     if(PL_psig_name[sig]) {
2137         sv = SvREFCNT_inc(PL_psig_name[sig]);
2138         flags |= 64;
2139         sig_sv = sv;
2140     } else {
2141         sv = sv_newmortal();
2142         sv_setpv(sv,PL_sig_name[sig]);
2143     }
2144
2145     PUSHSTACKi(PERLSI_SIGNAL);
2146     PUSHMARK(SP);
2147     PUSHs(sv);
2148     PUTBACK;
2149
2150     perl_call_sv((SV*)cv, G_DISCARD);
2151
2152     POPSTACK;
2153 cleanup:
2154     if (flags & 1)
2155         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2156     if (flags & 4)
2157         PL_markstack_ptr--;
2158     if (flags & 8)
2159         PL_retstack_ix--;
2160     if (flags & 16)
2161         PL_scopestack_ix -= 1;
2162     if (flags & 64)
2163         SvREFCNT_dec(sv);
2164     PL_op = myop;                       /* Apparently not needed... */
2165
2166     PL_Sv = tSv;                        /* Restore global temporaries. */
2167     PL_Xpv = tXpv;
2168     return;
2169 }
2170
2171