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