mg.c

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