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