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