mg.c

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