mg.c

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