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