mg.c

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