mg.c

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