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