[differences between cumulative patch application and perl5.004_01]
[p5sagit/p5-mst-13.2.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
79072805 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 *
a0d0e21e 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."
79072805 13 */
14
15#include "EXTERN.h"
16#include "perl.h"
17
e6d9441c 18/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e 19#ifdef I_UNISTD
20# include <unistd.h>
21#endif
a0d0e21e 22
5cd24f17 23#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221 24# ifndef NGROUPS
25# define NGROUPS 32
26# endif
27#endif
28
c07a80fd 29/*
30 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
31 */
32
33struct magic_state {
34 SV* mgs_sv;
35 U32 mgs_flags;
36};
37typedef struct magic_state MGS;
38
39static void restore_magic _((void *p));
40
48e43a1c 41static void
42save_magic(mgs, sv)
43MGS* mgs;
c07a80fd 44SV* sv;
45{
c07a80fd 46 assert(SvMAGICAL(sv));
47
c07a80fd 48 mgs->mgs_sv = sv;
49 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
50 SAVEDESTRUCTOR(restore_magic, mgs);
51
52 SvMAGICAL_off(sv);
53 SvREADONLY_off(sv);
54 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd 55}
56
57static void
58restore_magic(p)
59void* p;
60{
48e43a1c 61 MGS* mgs = (MGS*)p;
c07a80fd 62 SV* sv = mgs->mgs_sv;
63
64 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
65 {
66 if (mgs->mgs_flags)
67 SvFLAGS(sv) |= mgs->mgs_flags;
68 else
69 mg_magical(sv);
70 if (SvGMAGICAL(sv))
71 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
72 }
c07a80fd 73}
74
8e07c86e 75
8990e307 76void
77mg_magical(sv)
78SV* sv;
79{
80 MAGIC* mg;
81 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
82 MGVTBL* vtbl = mg->mg_virtual;
83 if (vtbl) {
a0d0e21e 84 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307 85 SvGMAGICAL_on(sv);
86 if (vtbl->svt_set)
87 SvSMAGICAL_on(sv);
88 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
89 SvRMAGICAL_on(sv);
90 }
91 }
92}
93
79072805 94int
95mg_get(sv)
96SV* sv;
97{
48e43a1c 98 MGS mgs;
79072805 99 MAGIC* mg;
c6496cc7 100 MAGIC** mgp;
760ac839 101 int mgp_valid = 0;
463ee0b2 102
c07a80fd 103 ENTER;
48e43a1c 104 save_magic(&mgs, sv);
463ee0b2 105
c6496cc7 106 mgp = &SvMAGIC(sv);
107 while ((mg = *mgp) != 0) {
79072805 108 MGVTBL* vtbl = mg->mg_virtual;
a0d0e21e 109 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
79072805 110 (*vtbl->svt_get)(sv, mg);
c6496cc7 111 /* Ignore this magic if it's been deleted */
48e43a1c 112 if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
113 (mg->mg_flags & MGf_GSKIP))
114 mgs.mgs_flags = 0;
a0d0e21e 115 }
c6496cc7 116 /* Advance to next magic (complicated by possible deletion) */
760ac839 117 if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
c6496cc7 118 mgp = &mg->mg_moremagic;
760ac839 119 mgp_valid = 1;
120 }
121 else
122 mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
79072805 123 }
463ee0b2 124
c07a80fd 125 LEAVE;
79072805 126 return 0;
127}
128
129int
130mg_set(sv)
131SV* sv;
132{
48e43a1c 133 MGS mgs;
79072805 134 MAGIC* mg;
463ee0b2 135 MAGIC* nextmg;
136
c07a80fd 137 ENTER;
48e43a1c 138 save_magic(&mgs, sv);
463ee0b2 139
140 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
79072805 141 MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 142 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e 143 if (mg->mg_flags & MGf_GSKIP) {
144 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
48e43a1c 145 mgs.mgs_flags = 0;
a0d0e21e 146 }
79072805 147 if (vtbl && vtbl->svt_set)
148 (*vtbl->svt_set)(sv, mg);
149 }
463ee0b2 150
c07a80fd 151 LEAVE;
79072805 152 return 0;
153}
154
155U32
156mg_len(sv)
157SV* sv;
158{
159 MAGIC* mg;
748a9306 160 char *junk;
463ee0b2 161 STRLEN len;
463ee0b2 162
79072805 163 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
164 MGVTBL* vtbl = mg->mg_virtual;
85e6fe83 165 if (vtbl && vtbl->svt_len) {
48e43a1c 166 MGS mgs;
167
c07a80fd 168 ENTER;
48e43a1c 169 save_magic(&mgs, sv);
a0d0e21e 170 /* omit MGf_GSKIP -- not changed here */
85e6fe83 171 len = (*vtbl->svt_len)(sv, mg);
c07a80fd 172 LEAVE;
85e6fe83 173 return len;
174 }
175 }
176
748a9306 177 junk = SvPV(sv, len);
463ee0b2 178 return len;
79072805 179}
180
181int
182mg_clear(sv)
183SV* sv;
184{
48e43a1c 185 MGS mgs;
79072805 186 MAGIC* mg;
463ee0b2 187
c07a80fd 188 ENTER;
48e43a1c 189 save_magic(&mgs, sv);
463ee0b2 190
79072805 191 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
192 MGVTBL* vtbl = mg->mg_virtual;
a0d0e21e 193 /* omit GSKIP -- never set here */
194
79072805 195 if (vtbl && vtbl->svt_clear)
196 (*vtbl->svt_clear)(sv, mg);
197 }
463ee0b2 198
c07a80fd 199 LEAVE;
79072805 200 return 0;
201}
202
93a17b20 203MAGIC*
204mg_find(sv, type)
205SV* sv;
a0d0e21e 206int type;
93a17b20 207{
208 MAGIC* mg;
93a17b20 209 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
210 if (mg->mg_type == type)
211 return mg;
212 }
213 return 0;
214}
215
79072805 216int
463ee0b2 217mg_copy(sv, nsv, key, klen)
79072805 218SV* sv;
463ee0b2 219SV* nsv;
220char *key;
88e89b8a 221I32 klen;
79072805 222{
463ee0b2 223 int count = 0;
79072805 224 MAGIC* mg;
463ee0b2 225 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
226 if (isUPPER(mg->mg_type)) {
a0d0e21e 227 sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
463ee0b2 228 count++;
79072805 229 }
79072805 230 }
463ee0b2 231 return count;
79072805 232}
233
234int
463ee0b2 235mg_free(sv)
79072805 236SV* sv;
237{
238 MAGIC* mg;
239 MAGIC* moremagic;
240 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
241 MGVTBL* vtbl = mg->mg_virtual;
242 moremagic = mg->mg_moremagic;
243 if (vtbl && vtbl->svt_free)
244 (*vtbl->svt_free)(sv, mg);
93a17b20 245 if (mg->mg_ptr && mg->mg_type != 'g')
88e89b8a 246 if (mg->mg_len >= 0)
247 Safefree(mg->mg_ptr);
248 else if (mg->mg_len == HEf_SVKEY)
249 SvREFCNT_dec((SV*)mg->mg_ptr);
85e6fe83 250 if (mg->mg_flags & MGf_REFCOUNTED)
8990e307 251 SvREFCNT_dec(mg->mg_obj);
79072805 252 Safefree(mg);
253 }
254 SvMAGIC(sv) = 0;
255 return 0;
256}
257
258#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
259#include <signal.h>
260#endif
261
93a17b20 262U32
263magic_len(sv, mg)
264SV *sv;
265MAGIC *mg;
266{
267 register I32 paren;
268 register char *s;
269 register I32 i;
bbce6d69 270 register REGEXP *rx;
748a9306 271 char *t;
93a17b20 272
273 switch (*mg->mg_ptr) {
274 case '1': case '2': case '3': case '4':
275 case '5': case '6': case '7': case '8': case '9': case '&':
bbce6d69 276 if (curpm && (rx = curpm->op_pmregexp)) {
93a17b20 277 paren = atoi(mg->mg_ptr);
278 getparen:
bbce6d69 279 if (paren <= rx->nparens &&
280 (s = rx->startp[paren]) &&
281 (t = rx->endp[paren]))
282 {
748a9306 283 i = t - s;
71be2cbc 284 if (i >= 0)
93a17b20 285 return i;
93a17b20 286 }
93a17b20 287 }
748a9306 288 return 0;
93a17b20 289 case '+':
bbce6d69 290 if (curpm && (rx = curpm->op_pmregexp)) {
291 paren = rx->lastparen;
13f57bf8 292 if (paren)
293 goto getparen;
93a17b20 294 }
748a9306 295 return 0;
93a17b20 296 case '`':
bbce6d69 297 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 298 if ((s = rx->subbeg) && rx->startp[0]) {
bbce6d69 299 i = rx->startp[0] - s;
71be2cbc 300 if (i >= 0)
93a17b20 301 return i;
93a17b20 302 }
93a17b20 303 }
748a9306 304 return 0;
93a17b20 305 case '\'':
bbce6d69 306 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 307 if (rx->subend && (s = rx->endp[0])) {
308 i = rx->subend - s;
309 if (i >= 0)
5cd24f17 310 return i;
93a17b20 311 }
93a17b20 312 }
748a9306 313 return 0;
93a17b20 314 case ',':
315 return (STRLEN)ofslen;
316 case '\\':
317 return (STRLEN)orslen;
318 }
319 magic_get(sv,mg);
320 if (!SvPOK(sv) && SvNIOK(sv))
463ee0b2 321 sv_2pv(sv, &na);
93a17b20 322 if (SvPOK(sv))
323 return SvCUR(sv);
324 return 0;
325}
326
79072805 327int
328magic_get(sv, mg)
329SV *sv;
330MAGIC *mg;
331{
332 register I32 paren;
333 register char *s;
334 register I32 i;
bbce6d69 335 register REGEXP *rx;
748a9306 336 char *t;
79072805 337
338 switch (*mg->mg_ptr) {
748a9306 339 case '\001': /* ^A */
340 sv_setsv(sv, bodytarget);
341 break;
79072805 342 case '\004': /* ^D */
188ea221 343 sv_setiv(sv, (IV)(debug & 32767));
79072805 344 break;
28f23441 345 case '\005': /* ^E */
346#ifdef VMS
347 {
348# include <descrip.h>
349# include <starlet.h>
350 char msg[255];
351 $DESCRIPTOR(msgdsc,msg);
946ec16e 352 sv_setnv(sv,(double) vaxc$errno);
28f23441 353 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
354 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
355 else
356 sv_setpv(sv,"");
357 }
358#else
88e89b8a 359#ifdef OS2
946ec16e 360 sv_setnv(sv, (double)Perl_rc);
88e89b8a 361 sv_setpv(sv, os2error(Perl_rc));
362#else
946ec16e 363 sv_setnv(sv, (double)errno);
28f23441 364 sv_setpv(sv, errno ? Strerror(errno) : "");
365#endif
88e89b8a 366#endif
946ec16e 367 SvNOK_on(sv); /* what a wonderful hack! */
28f23441 368 break;
79072805 369 case '\006': /* ^F */
188ea221 370 sv_setiv(sv, (IV)maxsysfd);
79072805 371 break;
a0d0e21e 372 case '\010': /* ^H */
188ea221 373 sv_setiv(sv, (IV)hints);
a0d0e21e 374 break;
79072805 375 case '\t': /* ^I */
376 if (inplace)
377 sv_setpv(sv, inplace);
378 else
188ea221 379 sv_setsv(sv, &sv_undef);
79072805 380 break;
28f23441 381 case '\017': /* ^O */
188ea221 382 sv_setpv(sv, osname);
28f23441 383 break;
79072805 384 case '\020': /* ^P */
188ea221 385 sv_setiv(sv, (IV)perldb);
79072805 386 break;
387 case '\024': /* ^T */
88e89b8a 388#ifdef BIG_TIME
188ea221 389 sv_setnv(sv, basetime);
88e89b8a 390#else
188ea221 391 sv_setiv(sv, (IV)basetime);
88e89b8a 392#endif
79072805 393 break;
394 case '\027': /* ^W */
188ea221 395 sv_setiv(sv, (IV)dowarn);
79072805 396 break;
397 case '1': case '2': case '3': case '4':
398 case '5': case '6': case '7': case '8': case '9': case '&':
bbce6d69 399 if (curpm && (rx = curpm->op_pmregexp)) {
88e89b8a 400 paren = atoi(GvENAME((GV*)mg->mg_obj));
79072805 401 getparen:
bbce6d69 402 if (paren <= rx->nparens &&
403 (s = rx->startp[paren]) &&
404 (t = rx->endp[paren]))
405 {
748a9306 406 i = t - s;
13f57bf8 407 getrx:
748a9306 408 if (i >= 0) {
13f57bf8 409 bool was_tainted;
410 if (tainting) {
411 was_tainted = tainted;
412 tainted = FALSE;
413 }
79072805 414 sv_setpvn(sv,s,i);
13f57bf8 415 if (tainting)
416 tainted = was_tainted || rx->exec_tainted;
748a9306 417 break;
418 }
79072805 419 }
79072805 420 }
748a9306 421 sv_setsv(sv,&sv_undef);
79072805 422 break;
423 case '+':
bbce6d69 424 if (curpm && (rx = curpm->op_pmregexp)) {
425 paren = rx->lastparen;
a0d0e21e 426 if (paren)
427 goto getparen;
79072805 428 }
748a9306 429 sv_setsv(sv,&sv_undef);
79072805 430 break;
431 case '`':
bbce6d69 432 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 433 if ((s = rx->subbeg) && rx->startp[0]) {
bbce6d69 434 i = rx->startp[0] - s;
13f57bf8 435 goto getrx;
79072805 436 }
79072805 437 }
748a9306 438 sv_setsv(sv,&sv_undef);
79072805 439 break;
440 case '\'':
bbce6d69 441 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 442 if (rx->subend && (s = rx->endp[0])) {
443 i = rx->subend - s;
444 goto getrx;
79072805 445 }
79072805 446 }
748a9306 447 sv_setsv(sv,&sv_undef);
79072805 448 break;
449 case '.':
450#ifndef lint
a0d0e21e 451 if (GvIO(last_in_gv)) {
188ea221 452 sv_setiv(sv, (IV)IoLINES(GvIO(last_in_gv)));
79072805 453 }
454#endif
455 break;
456 case '?':
ff0cee69 457 sv_setiv(sv, (IV)STATUS_CURRENT);
458#ifdef COMPLEX_STATUS
459 LvTARGOFF(sv) = statusvalue;
460 LvTARGLEN(sv) = statusvalue_vms;
461#endif
79072805 462 break;
463 case '^':
a0d0e21e 464 s = IoTOP_NAME(GvIOp(defoutgv));
79072805 465 if (s)
466 sv_setpv(sv,s);
467 else {
468 sv_setpv(sv,GvENAME(defoutgv));
469 sv_catpv(sv,"_TOP");
470 }
471 break;
472 case '~':
a0d0e21e 473 s = IoFMT_NAME(GvIOp(defoutgv));
79072805 474 if (!s)
475 s = GvENAME(defoutgv);
476 sv_setpv(sv,s);
477 break;
478#ifndef lint
479 case '=':
188ea221 480 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(defoutgv)));
79072805 481 break;
482 case '-':
188ea221 483 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(defoutgv)));
79072805 484 break;
485 case '%':
188ea221 486 sv_setiv(sv, (IV)IoPAGE(GvIOp(defoutgv)));
79072805 487 break;
488#endif
489 case ':':
490 break;
491 case '/':
492 break;
493 case '[':
188ea221 494 sv_setiv(sv, (IV)curcop->cop_arybase);
79072805 495 break;
496 case '|':
188ea221 497 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
79072805 498 break;
499 case ',':
500 sv_setpvn(sv,ofs,ofslen);
501 break;
502 case '\\':
503 sv_setpvn(sv,ors,orslen);
504 break;
505 case '#':
506 sv_setpv(sv,ofmt);
507 break;
508 case '!':
a5f75d66 509#ifdef VMS
946ec16e 510 sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 511 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 512#else
88e89b8a 513 {
514 int saveerrno = errno;
946ec16e 515 sv_setnv(sv, (double)errno);
88e89b8a 516#ifdef OS2
517 if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
518 else
a5f75d66 519#endif
2304df62 520 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a 521 errno = saveerrno;
522 }
523#endif
946ec16e 524 SvNOK_on(sv); /* what a wonderful hack! */
79072805 525 break;
526 case '<':
188ea221 527 sv_setiv(sv, (IV)uid);
79072805 528 break;
529 case '>':
188ea221 530 sv_setiv(sv, (IV)euid);
79072805 531 break;
532 case '(':
188ea221 533 sv_setiv(sv, (IV)gid);
fc36a67e 534 sv_setpvf(sv, "%Vd", (IV)gid);
79072805 535 goto add_groups;
536 case ')':
188ea221 537 sv_setiv(sv, (IV)egid);
fc36a67e 538 sv_setpvf(sv, "%Vd", (IV)egid);
79072805 539 add_groups:
79072805 540#ifdef HAS_GETGROUPS
79072805 541 {
a0d0e21e 542 Groups_t gary[NGROUPS];
79072805 543 i = getgroups(NGROUPS,gary);
46fc3d4c 544 while (--i >= 0)
fc36a67e 545 sv_catpvf(sv, " %Vd", (IV)gary[i]);
79072805 546 }
547#endif
29355cf7 548 SvIOK_on(sv); /* what a wonderful hack! */
79072805 549 break;
550 case '*':
551 break;
552 case '0':
553 break;
554 }
a0d0e21e 555 return 0;
79072805 556}
557
558int
559magic_getuvar(sv, mg)
560SV *sv;
561MAGIC *mg;
562{
563 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
564
565 if (uf && uf->uf_val)
566 (*uf->uf_val)(uf->uf_index, sv);
567 return 0;
568}
569
570int
571magic_setenv(sv,mg)
572SV* sv;
573MAGIC* mg;
574{
575 register char *s;
88e89b8a 576 char *ptr;
5aabfad6 577 STRLEN len, klen;
a0d0e21e 578 I32 i;
1e422769 579
a0d0e21e 580 s = SvPV(sv,len);
5aabfad6 581 ptr = MgPV(mg,klen);
88e89b8a 582 my_setenv(ptr, s);
1e422769 583
a0d0e21e 584#ifdef DYNAMIC_ENV_FETCH
585 /* We just undefd an environment var. Is a replacement */
586 /* waiting in the wings? */
587 if (!len) {
5aabfad6 588 SV **valp;
589 if ((valp = hv_fetch(GvHVn(envgv), ptr, klen, FALSE)))
590 s = SvPV(*valp, len);
a0d0e21e 591 }
592#endif
1e422769 593
3e3baf6d 594#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32)
79072805 595 /* And you'll never guess what the dog had */
596 /* in its mouth... */
463ee0b2 597 if (tainting) {
1e422769 598 MgTAINTEDDIR_off(mg);
599#ifdef VMS
5aabfad6 600 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769 601 char pathbuf[256], eltbuf[256], *cp, *elt = s;
602 struct stat sbuf;
603 int i = 0, j = 0;
604
605 do { /* DCL$PATH may be a search list */
606 while (1) { /* as may dev portion of any element */
607 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
608 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
609 cando_by_name(S_IWUSR,0,elt) ) {
610 MgTAINTEDDIR_on(mg);
611 return 0;
612 }
613 }
614 if ((cp = strchr(elt, ':')) != Nullch)
615 *cp = '\0';
616 if (my_trnlnm(elt, eltbuf, j++))
617 elt = eltbuf;
618 else
619 break;
620 }
621 j = 0;
622 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
623 }
624#endif /* VMS */
5aabfad6 625 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 626 char *strend = s + len;
463ee0b2 627
628 while (s < strend) {
1e422769 629 struct stat st;
fc36a67e 630 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf,
631 s, strend, ':', &i);
463ee0b2 632 s++;
fc36a67e 633 if (i >= sizeof tokenbuf /* too long -- assume the worst */
634 || *tokenbuf != '/'
1e422769 635 || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 636 MgTAINTEDDIR_on(mg);
1e422769 637 return 0;
638 }
463ee0b2 639 }
79072805 640 }
641 }
3e3baf6d 642#endif /* neither OS2 nor AMIGAOS nor WIN32 */
1e422769 643
79072805 644 return 0;
645}
646
647int
85e6fe83 648magic_clearenv(sv,mg)
649SV* sv;
650MAGIC* mg;
651{
5aabfad6 652 my_setenv(MgPV(mg,na),Nullch);
85e6fe83 653 return 0;
654}
655
88e89b8a 656int
3e3baf6d 657magic_clear_all_env(sv,mg)
658SV* sv;
659MAGIC* mg;
66b1d557 660{
3e3baf6d 661#if defined(VMS)
662 die("Can't make list assignment to %%ENV on this system");
663#else
664#ifdef WIN32
665 char *envv = GetEnvironmentStrings();
666 char *cur = envv;
667 STRLEN len;
668 while (*cur) {
669 char *end = strchr(cur,'=');
670 if (end && end != cur) {
671 *end = '\0';
672 my_setenv(cur,Nullch);
673 *end = '=';
674 cur += strlen(end+1)+1;
675 }
676 else if ((len = strlen(cur)))
677 cur += len+1;
678 }
679 FreeEnvironmentStrings(envv);
66b1d557 680#else
681 I32 i;
682
683 if (environ == origenviron)
684 New(901, environ, 1, char*);
685 else
686 for (i = 0; environ[i]; i++)
687 Safefree(environ[i]);
688 environ[0] = Nullch;
689
66b1d557 690#endif
3e3baf6d 691#endif
692 return 0;
66b1d557 693}
694
695int
88e89b8a 696magic_getsig(sv,mg)
697SV* sv;
698MAGIC* mg;
699{
700 I32 i;
701 /* Are we fetching a signal entry? */
5aabfad6 702 i = whichsig(MgPV(mg,na));
88e89b8a 703 if (i) {
704 if(psig_ptr[i])
705 sv_setsv(sv,psig_ptr[i]);
706 else {
ff68c719 707 Sighandler_t sigstate = rsignal_state(i);
708
88e89b8a 709 /* cache state so we don't fetch it again */
ff68c719 710 if(sigstate == SIG_IGN)
88e89b8a 711 sv_setpv(sv,"IGNORE");
712 else
713 sv_setsv(sv,&sv_undef);
714 psig_ptr[i] = SvREFCNT_inc(sv);
715 SvTEMP_off(sv);
716 }
717 }
718 return 0;
719}
720int
721magic_clearsig(sv,mg)
722SV* sv;
723MAGIC* mg;
724{
725 I32 i;
726 /* Are we clearing a signal entry? */
5aabfad6 727 i = whichsig(MgPV(mg,na));
88e89b8a 728 if (i) {
729 if(psig_ptr[i]) {
730 SvREFCNT_dec(psig_ptr[i]);
731 psig_ptr[i]=0;
732 }
733 if(psig_name[i]) {
734 SvREFCNT_dec(psig_name[i]);
735 psig_name[i]=0;
736 }
737 }
738 return 0;
739}
3d37d572 740
85e6fe83 741int
79072805 742magic_setsig(sv,mg)
743SV* sv;
744MAGIC* mg;
745{
746 register char *s;
747 I32 i;
748a9306 748 SV** svp;
a0d0e21e 749
5aabfad6 750 s = MgPV(mg,na);
748a9306 751 if (*s == '_') {
752 if (strEQ(s,"__DIE__"))
753 svp = &diehook;
754 else if (strEQ(s,"__WARN__"))
755 svp = &warnhook;
756 else if (strEQ(s,"__PARSE__"))
757 svp = &parsehook;
758 else
759 croak("No such hook: %s", s);
760 i = 0;
4633a7c4 761 if (*svp) {
762 SvREFCNT_dec(*svp);
763 *svp = 0;
764 }
748a9306 765 }
766 else {
767 i = whichsig(s); /* ...no, a brick */
768 if (!i) {
769 if (dowarn || strEQ(s,"ALARM"))
770 warn("No such signal: SIG%s", s);
771 return 0;
772 }
ff0cee69 773 SvREFCNT_dec(psig_name[i]);
774 SvREFCNT_dec(psig_ptr[i]);
88e89b8a 775 psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 776 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
ff0cee69 777 psig_name[i] = newSVpv(s, strlen(s));
88e89b8a 778 SvREADONLY_on(psig_name[i]);
748a9306 779 }
a0d0e21e 780 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 781 if (i)
ff68c719 782 (void)rsignal(i, sighandler);
748a9306 783 else
784 *svp = SvREFCNT_inc(sv);
a0d0e21e 785 return 0;
786 }
787 s = SvPV_force(sv,na);
748a9306 788 if (strEQ(s,"IGNORE")) {
789 if (i)
ff68c719 790 (void)rsignal(i, SIG_IGN);
748a9306 791 else
792 *svp = 0;
793 }
794 else if (strEQ(s,"DEFAULT") || !*s) {
795 if (i)
ff68c719 796 (void)rsignal(i, SIG_DFL);
748a9306 797 else
798 *svp = 0;
799 }
79072805 800 else {
5aabfad6 801 /*
802 * We should warn if HINT_STRICT_REFS, but without
803 * access to a known hint bit in a known OP, we can't
804 * tell whether HINT_STRICT_REFS is in force or not.
805 */
46fc3d4c 806 if (!strchr(s,':') && !strchr(s,'\''))
807 sv_setpv(sv, form("main::%s", s));
748a9306 808 if (i)
ff68c719 809 (void)rsignal(i, sighandler);
748a9306 810 else
811 *svp = SvREFCNT_inc(sv);
79072805 812 }
813 return 0;
814}
815
816int
463ee0b2 817magic_setisa(sv,mg)
79072805 818SV* sv;
819MAGIC* mg;
820{
463ee0b2 821 sub_generation++;
822 return 0;
823}
824
a0d0e21e 825#ifdef OVERLOAD
826
463ee0b2 827int
a0d0e21e 828magic_setamagic(sv,mg)
463ee0b2 829SV* sv;
830MAGIC* mg;
831{
a0d0e21e 832 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
833 amagic_generation++;
463ee0b2 834
a0d0e21e 835 return 0;
836}
837#endif /* OVERLOAD */
463ee0b2 838
946ec16e 839int
840magic_setnkeys(sv,mg)
841SV* sv;
842MAGIC* mg;
843{
844 if (LvTARG(sv)) {
845 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
846 LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */
847 }
848 return 0;
849}
850
a0d0e21e 851static int
852magic_methpack(sv,mg,meth)
853SV* sv;
854MAGIC* mg;
855char *meth;
856{
857 dSP;
463ee0b2 858
a0d0e21e 859 ENTER;
860 SAVETMPS;
861 PUSHMARK(sp);
862 EXTEND(sp, 2);
863 PUSHs(mg->mg_obj);
88e89b8a 864 if (mg->mg_ptr) {
865 if (mg->mg_len >= 0)
866 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
867 else if (mg->mg_len == HEf_SVKEY)
868 PUSHs((SV*)mg->mg_ptr);
869 }
a0d0e21e 870 else if (mg->mg_type == 'p')
871 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
463ee0b2 872 PUTBACK;
873
a0d0e21e 874 if (perl_call_method(meth, G_SCALAR))
875 sv_setsv(sv, *stack_sp--);
463ee0b2 876
a0d0e21e 877 FREETMPS;
878 LEAVE;
879 return 0;
880}
463ee0b2 881
a0d0e21e 882int
883magic_getpack(sv,mg)
884SV* sv;
885MAGIC* mg;
886{
887 magic_methpack(sv,mg,"FETCH");
888 if (mg->mg_ptr)
889 mg->mg_flags |= MGf_GSKIP;
463ee0b2 890 return 0;
891}
892
893int
894magic_setpack(sv,mg)
895SV* sv;
896MAGIC* mg;
897{
463ee0b2 898 dSP;
463ee0b2 899
a0d0e21e 900 PUSHMARK(sp);
901 EXTEND(sp, 3);
902 PUSHs(mg->mg_obj);
88e89b8a 903 if (mg->mg_ptr) {
904 if (mg->mg_len >= 0)
905 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
906 else if (mg->mg_len == HEf_SVKEY)
907 PUSHs((SV*)mg->mg_ptr);
908 }
a0d0e21e 909 else if (mg->mg_type == 'p')
910 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
463ee0b2 911 PUSHs(sv);
912 PUTBACK;
913
a0d0e21e 914 perl_call_method("STORE", G_SCALAR|G_DISCARD);
463ee0b2 915
916 return 0;
917}
918
919int
920magic_clearpack(sv,mg)
921SV* sv;
922MAGIC* mg;
923{
a0d0e21e 924 return magic_methpack(sv,mg,"DELETE");
925}
463ee0b2 926
a0d0e21e 927int magic_wipepack(sv,mg)
928SV* sv;
929MAGIC* mg;
930{
931 dSP;
463ee0b2 932
a0d0e21e 933 PUSHMARK(sp);
934 XPUSHs(mg->mg_obj);
463ee0b2 935 PUTBACK;
463ee0b2 936
a0d0e21e 937 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
463ee0b2 938
939 return 0;
940}
941
942int
943magic_nextpack(sv,mg,key)
944SV* sv;
945MAGIC* mg;
946SV* key;
947{
463ee0b2 948 dSP;
a0d0e21e 949 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2 950
951 ENTER;
a0d0e21e 952 SAVETMPS;
953 PUSHMARK(sp);
954 EXTEND(sp, 2);
955 PUSHs(mg->mg_obj);
463ee0b2 956 if (SvOK(key))
957 PUSHs(key);
958 PUTBACK;
959
a0d0e21e 960 if (perl_call_method(meth, G_SCALAR))
961 sv_setsv(key, *stack_sp--);
463ee0b2 962
a0d0e21e 963 FREETMPS;
964 LEAVE;
79072805 965 return 0;
966}
967
968int
a0d0e21e 969magic_existspack(sv,mg)
970SV* sv;
971MAGIC* mg;
972{
973 return magic_methpack(sv,mg,"EXISTS");
974}
975
976int
79072805 977magic_setdbline(sv,mg)
978SV* sv;
979MAGIC* mg;
980{
981 OP *o;
982 I32 i;
983 GV* gv;
984 SV** svp;
985
986 gv = DBline;
987 i = SvTRUE(sv);
188ea221 988 svp = av_fetch(GvAV(gv),
5aabfad6 989 atoi(MgPV(mg,na)), FALSE);
8990e307 990 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
93a17b20 991 o->op_private = i;
79072805 992 else
993 warn("Can't break at that line\n");
994 return 0;
995}
996
997int
998magic_getarylen(sv,mg)
999SV* sv;
1000MAGIC* mg;
1001{
a0d0e21e 1002 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
79072805 1003 return 0;
1004}
1005
1006int
1007magic_setarylen(sv,mg)
1008SV* sv;
1009MAGIC* mg;
1010{
a0d0e21e 1011 av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
1012 return 0;
1013}
1014
1015int
1016magic_getpos(sv,mg)
1017SV* sv;
1018MAGIC* mg;
1019{
1020 SV* lsv = LvTARG(sv);
1021
1022 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1023 mg = mg_find(lsv, 'g');
1024 if (mg && mg->mg_len >= 0) {
1025 sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
1026 return 0;
1027 }
1028 }
1029 (void)SvOK_off(sv);
1030 return 0;
1031}
1032
1033int
1034magic_setpos(sv,mg)
1035SV* sv;
1036MAGIC* mg;
1037{
1038 SV* lsv = LvTARG(sv);
1039 SSize_t pos;
1040 STRLEN len;
1041
1042 mg = 0;
1043
1044 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1045 mg = mg_find(lsv, 'g');
1046 if (!mg) {
1047 if (!SvOK(sv))
1048 return 0;
1049 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1050 mg = mg_find(lsv, 'g');
1051 }
1052 else if (!SvOK(sv)) {
1053 mg->mg_len = -1;
1054 return 0;
1055 }
1056 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1057
1058 pos = SvIV(sv) - curcop->cop_arybase;
1059 if (pos < 0) {
1060 pos += len;
1061 if (pos < 0)
1062 pos = 0;
1063 }
1064 else if (pos > len)
1065 pos = len;
1066 mg->mg_len = pos;
71be2cbc 1067 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1068
79072805 1069 return 0;
1070}
1071
1072int
1073magic_getglob(sv,mg)
1074SV* sv;
1075MAGIC* mg;
1076{
8646b087 1077 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1078 SvFAKE_off(sv);
946ec16e 1079 gv_efullname3(sv,((GV*)sv), "*");
8646b087 1080 SvFAKE_on(sv);
1081 }
1082 else
946ec16e 1083 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805 1084 return 0;
1085}
1086
1087int
1088magic_setglob(sv,mg)
1089SV* sv;
1090MAGIC* mg;
1091{
1092 register char *s;
1093 GV* gv;
1094
1095 if (!SvOK(sv))
1096 return 0;
463ee0b2 1097 s = SvPV(sv, na);
79072805 1098 if (*s == '*' && s[1])
1099 s++;
85e6fe83 1100 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805 1101 if (sv == (SV*)gv)
1102 return 0;
1103 if (GvGP(sv))
88e89b8a 1104 gp_free((GV*)sv);
79072805 1105 GvGP(sv) = gp_ref(GvGP(gv));
79072805 1106 return 0;
1107}
1108
1109int
1110magic_setsubstr(sv,mg)
1111SV* sv;
1112MAGIC* mg;
1113{
8990e307 1114 STRLEN len;
1115 char *tmps = SvPV(sv,len);
1116 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
79072805 1117 return 0;
1118}
1119
1120int
463ee0b2 1121magic_gettaint(sv,mg)
1122SV* sv;
1123MAGIC* mg;
1124{
bbce6d69 1125 TAINT_IF((mg->mg_len & 1) ||
1126 (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
463ee0b2 1127 return 0;
1128}
1129
1130int
1131magic_settaint(sv,mg)
1132SV* sv;
1133MAGIC* mg;
1134{
748a9306 1135 if (localizing) {
1136 if (localizing == 1)
1137 mg->mg_len <<= 1;
1138 else
1139 mg->mg_len >>= 1;
a0d0e21e 1140 }
748a9306 1141 else if (tainted)
1142 mg->mg_len |= 1;
1143 else
1144 mg->mg_len &= ~1;
463ee0b2 1145 return 0;
1146}
1147
1148int
79072805 1149magic_setvec(sv,mg)
1150SV* sv;
1151MAGIC* mg;
1152{
1153 do_vecset(sv); /* XXX slurp this routine */
1154 return 0;
1155}
1156
1157int
68dc0745 1158magic_getdefelem(sv,mg)
5f05dabc 1159SV* sv;
1160MAGIC* mg;
1161{
71be2cbc 1162 SV *targ = Nullsv;
5f05dabc 1163 if (LvTARGLEN(sv)) {
68dc0745 1164 if (mg->mg_obj) {
1165 HV* hv = (HV*)LvTARG(sv);
1166 HE* he = hv_fetch_ent(hv, mg->mg_obj, FALSE, 0);
1167 if (he)
1168 targ = HeVAL(he);
1169 }
1170 else {
1171 AV* av = (AV*)LvTARG(sv);
1172 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1173 targ = AvARRAY(av)[LvTARGOFF(sv)];
1174 }
1175 if (targ && targ != &sv_undef) {
1176 /* somebody else defined it for us */
1177 SvREFCNT_dec(LvTARG(sv));
1178 LvTARG(sv) = SvREFCNT_inc(targ);
1179 LvTARGLEN(sv) = 0;
1180 SvREFCNT_dec(mg->mg_obj);
1181 mg->mg_obj = Nullsv;
1182 mg->mg_flags &= ~MGf_REFCOUNTED;
1183 }
5f05dabc 1184 }
71be2cbc 1185 else
1186 targ = LvTARG(sv);
1187 sv_setsv(sv, targ ? targ : &sv_undef);
1188 return 0;
1189}
1190
1191int
68dc0745 1192magic_setdefelem(sv,mg)
71be2cbc 1193SV* sv;
1194MAGIC* mg;
1195{
1196 if (LvTARGLEN(sv))
68dc0745 1197 vivify_defelem(sv);
1198 if (LvTARG(sv)) {
5f05dabc 1199 sv_setsv(LvTARG(sv), sv);
68dc0745 1200 SvSETMAGIC(LvTARG(sv));
1201 }
5f05dabc 1202 return 0;
1203}
1204
1205int
68dc0745 1206magic_freedefelem(sv,mg)
5f05dabc 1207SV* sv;
1208MAGIC* mg;
1209{
1210 SvREFCNT_dec(LvTARG(sv));
71be2cbc 1211 return 0;
1212}
1213
1214void
68dc0745 1215vivify_defelem(sv)
71be2cbc 1216SV* sv;
1217{
68dc0745 1218 MAGIC* mg;
1219 SV* value;
71be2cbc 1220
68dc0745 1221 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
71be2cbc 1222 return;
68dc0745 1223 if (mg->mg_obj) {
1224 HV* hv = (HV*)LvTARG(sv);
1225 HE* he = hv_fetch_ent(hv, mg->mg_obj, TRUE, 0);
1226 if (!he || (value = HeVAL(he)) == &sv_undef)
1227 croak(no_helem, SvPV(mg->mg_obj, na));
71be2cbc 1228 }
68dc0745 1229 else {
1230 AV* av = (AV*)LvTARG(sv);
5aabfad6 1231 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745 1232 LvTARG(sv) = Nullsv; /* array can't be extended */
1233 else {
1234 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1235 if (!svp || (value = *svp) == &sv_undef)
1236 croak(no_aelem, (I32)LvTARGOFF(sv));
1237 }
1238 }
3e3baf6d 1239 (void)SvREFCNT_inc(value);
68dc0745 1240 SvREFCNT_dec(LvTARG(sv));
1241 LvTARG(sv) = value;
71be2cbc 1242 LvTARGLEN(sv) = 0;
68dc0745 1243 SvREFCNT_dec(mg->mg_obj);
1244 mg->mg_obj = Nullsv;
1245 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc 1246}
1247
1248int
93a17b20 1249magic_setmglob(sv,mg)
1250SV* sv;
1251MAGIC* mg;
1252{
a0d0e21e 1253 mg->mg_len = -1;
c6496cc7 1254 SvSCREAM_off(sv);
93a17b20 1255 return 0;
1256}
1257
1258int
79072805 1259magic_setbm(sv,mg)
1260SV* sv;
1261MAGIC* mg;
1262{
463ee0b2 1263 sv_unmagic(sv, 'B');
79072805 1264 SvVALID_off(sv);
1265 return 0;
1266}
1267
1268int
55497cff 1269magic_setfm(sv,mg)
1270SV* sv;
1271MAGIC* mg;
1272{
1273 sv_unmagic(sv, 'f');
1274 SvCOMPILED_off(sv);
1275 return 0;
1276}
1277
1278int
79072805 1279magic_setuvar(sv,mg)
1280SV* sv;
1281MAGIC* mg;
1282{
1283 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1284
1285 if (uf && uf->uf_set)
1286 (*uf->uf_set)(uf->uf_index, sv);
1287 return 0;
1288}
1289
7a4c00b4 1290#ifdef USE_LOCALE_COLLATE
79072805 1291int
bbce6d69 1292magic_setcollxfrm(sv,mg)
1293SV* sv;
1294MAGIC* mg;
1295{
1296 /*
1297 * René Descartes said "I think not."
1298 * and vanished with a faint plop.
1299 */
7a4c00b4 1300 if (mg->mg_ptr) {
1301 Safefree(mg->mg_ptr);
1302 mg->mg_ptr = NULL;
1303 mg->mg_len = -1;
1304 }
bbce6d69 1305 return 0;
1306}
7a4c00b4 1307#endif /* USE_LOCALE_COLLATE */
bbce6d69 1308
1309int
79072805 1310magic_set(sv,mg)
1311SV* sv;
1312MAGIC* mg;
1313{
1314 register char *s;
1315 I32 i;
8990e307 1316 STRLEN len;
79072805 1317 switch (*mg->mg_ptr) {
748a9306 1318 case '\001': /* ^A */
1319 sv_setsv(bodytarget, sv);
1320 break;
79072805 1321 case '\004': /* ^D */
8990e307 1322 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805 1323 DEBUG_x(dump_all());
1324 break;
28f23441 1325 case '\005': /* ^E */
1326#ifdef VMS
1327 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1328#else
f86702cc 1329 /* will anyone ever use this? */
1330 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
28f23441 1331#endif
1332 break;
79072805 1333 case '\006': /* ^F */
463ee0b2 1334 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1335 break;
a0d0e21e 1336 case '\010': /* ^H */
1337 hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1338 break;
79072805 1339 case '\t': /* ^I */
1340 if (inplace)
1341 Safefree(inplace);
1342 if (SvOK(sv))
a0d0e21e 1343 inplace = savepv(SvPV(sv,na));
79072805 1344 else
1345 inplace = Nullch;
1346 break;
28f23441 1347 case '\017': /* ^O */
1348 if (osname)
1349 Safefree(osname);
1350 if (SvOK(sv))
1351 osname = savepv(SvPV(sv,na));
1352 else
1353 osname = Nullch;
1354 break;
79072805 1355 case '\020': /* ^P */
463ee0b2 1356 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1357 if (i != perldb) {
1358 if (perldb)
1359 oldlastpm = curpm;
1360 else
1361 curpm = oldlastpm;
1362 }
1363 perldb = i;
1364 break;
1365 case '\024': /* ^T */
88e89b8a 1366#ifdef BIG_TIME
1367 basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1368#else
85e6fe83 1369 basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1370#endif
79072805 1371 break;
1372 case '\027': /* ^W */
463ee0b2 1373 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 1374 break;
1375 case '.':
748a9306 1376 if (localizing) {
1377 if (localizing == 1)
1378 save_sptr((SV**)&last_in_gv);
1379 }
88e89b8a 1380 else if (SvOK(sv) && GvIO(last_in_gv))
a0d0e21e 1381 IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
79072805 1382 break;
1383 case '^':
a0d0e21e 1384 Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1385 IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1386 IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805 1387 break;
1388 case '~':
a0d0e21e 1389 Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1390 IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1391 IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805 1392 break;
1393 case '=':
a0d0e21e 1394 IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 1395 break;
1396 case '-':
a0d0e21e 1397 IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1398 if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1399 IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
79072805 1400 break;
1401 case '%':
a0d0e21e 1402 IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 1403 break;
1404 case '|':
4b65379b 1405 {
1406 IO *io = GvIOp(defoutgv);
1407 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1408 IoFLAGS(io) &= ~IOf_FLUSH;
1409 else {
1410 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1411 PerlIO *ofp = IoOFP(io);
1412 if (ofp)
1413 (void)PerlIO_flush(ofp);
1414 IoFLAGS(io) |= IOf_FLUSH;
1415 }
1416 }
79072805 1417 }
1418 break;
1419 case '*':
463ee0b2 1420 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1421 multiline = (i != 0);
1422 break;
1423 case '/':
c07a80fd 1424 SvREFCNT_dec(nrs);
1425 nrs = newSVsv(sv);
1426 SvREFCNT_dec(rs);
1427 rs = SvREFCNT_inc(nrs);
79072805 1428 break;
1429 case '\\':
1430 if (ors)
1431 Safefree(ors);
e3c19b7b 1432 if (SvOK(sv) || SvGMAGICAL(sv))
1433 ors = savepv(SvPV(sv,orslen));
1434 else {
1435 ors = Nullch;
1436 orslen = 0;
1437 }
79072805 1438 break;
1439 case ',':
1440 if (ofs)
1441 Safefree(ofs);
a0d0e21e 1442 ofs = savepv(SvPV(sv, ofslen));
79072805 1443 break;
1444 case '#':
1445 if (ofmt)
1446 Safefree(ofmt);
a0d0e21e 1447 ofmt = savepv(SvPV(sv,na));
79072805 1448 break;
1449 case '[':
a0d0e21e 1450 compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1451 break;
1452 case '?':
ff0cee69 1453#ifdef COMPLEX_STATUS
1454 if (localizing == 2) {
1455 statusvalue = LvTARGOFF(sv);
1456 statusvalue_vms = LvTARGLEN(sv);
1457 }
1458 else
1459#endif
1460#ifdef VMSISH_STATUS
1461 if (VMSISH_STATUS)
1462 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1463 else
1464#endif
1465 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805 1466 break;
1467 case '!':
f86702cc 1468 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
1469 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805 1470 break;
1471 case '<':
463ee0b2 1472 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1473 if (delaymagic) {
1474 delaymagic |= DM_RUID;
1475 break; /* don't do magic till later */
1476 }
1477#ifdef HAS_SETRUID
85e6fe83 1478 (void)setruid((Uid_t)uid);
79072805 1479#else
1480#ifdef HAS_SETREUID
85e6fe83 1481 (void)setreuid((Uid_t)uid, (Uid_t)-1);
748a9306 1482#else
85e6fe83 1483#ifdef HAS_SETRESUID
1484 (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
79072805 1485#else
1486 if (uid == euid) /* special case $< = $> */
1487 (void)setuid(uid);
a0d0e21e 1488 else {
1489 uid = (I32)getuid();
463ee0b2 1490 croak("setruid() not implemented");
a0d0e21e 1491 }
79072805 1492#endif
1493#endif
85e6fe83 1494#endif
748a9306 1495 uid = (I32)getuid();
4633a7c4 1496 tainting |= (uid && (euid != uid || egid != gid));
79072805 1497 break;
1498 case '>':
463ee0b2 1499 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1500 if (delaymagic) {
1501 delaymagic |= DM_EUID;
1502 break; /* don't do magic till later */
1503 }
1504#ifdef HAS_SETEUID
85e6fe83 1505 (void)seteuid((Uid_t)euid);
79072805 1506#else
1507#ifdef HAS_SETREUID
85e6fe83 1508 (void)setreuid((Uid_t)-1, (Uid_t)euid);
1509#else
1510#ifdef HAS_SETRESUID
1511 (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
79072805 1512#else
1513 if (euid == uid) /* special case $> = $< */
1514 setuid(euid);
a0d0e21e 1515 else {
1516 euid = (I32)geteuid();
463ee0b2 1517 croak("seteuid() not implemented");
a0d0e21e 1518 }
79072805 1519#endif
1520#endif
85e6fe83 1521#endif
79072805 1522 euid = (I32)geteuid();
4633a7c4 1523 tainting |= (uid && (euid != uid || egid != gid));
79072805 1524 break;
1525 case '(':
463ee0b2 1526 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1527 if (delaymagic) {
1528 delaymagic |= DM_RGID;
1529 break; /* don't do magic till later */
1530 }
1531#ifdef HAS_SETRGID
85e6fe83 1532 (void)setrgid((Gid_t)gid);
79072805 1533#else
1534#ifdef HAS_SETREGID
85e6fe83 1535 (void)setregid((Gid_t)gid, (Gid_t)-1);
1536#else
1537#ifdef HAS_SETRESGID
1538 (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
79072805 1539#else
1540 if (gid == egid) /* special case $( = $) */
1541 (void)setgid(gid);
748a9306 1542 else {
1543 gid = (I32)getgid();
463ee0b2 1544 croak("setrgid() not implemented");
748a9306 1545 }
79072805 1546#endif
1547#endif
85e6fe83 1548#endif
79072805 1549 gid = (I32)getgid();
4633a7c4 1550 tainting |= (uid && (euid != uid || egid != gid));
79072805 1551 break;
1552 case ')':
5cd24f17 1553#ifdef HAS_SETGROUPS
1554 {
1555 char *p = SvPV(sv, na);
1556 Groups_t gary[NGROUPS];
1557
1558 SET_NUMERIC_STANDARD();
1559 while (isSPACE(*p))
1560 ++p;
1561 egid = I_V(atof(p));
1562 for (i = 0; i < NGROUPS; ++i) {
1563 while (*p && !isSPACE(*p))
1564 ++p;
1565 while (isSPACE(*p))
1566 ++p;
1567 if (!*p)
1568 break;
1569 gary[i] = I_V(atof(p));
1570 }
8cc95fdb 1571 if (i)
1572 (void)setgroups(i, gary);
5cd24f17 1573 }
1574#else /* HAS_SETGROUPS */
463ee0b2 1575 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 1576#endif /* HAS_SETGROUPS */
79072805 1577 if (delaymagic) {
1578 delaymagic |= DM_EGID;
1579 break; /* don't do magic till later */
1580 }
1581#ifdef HAS_SETEGID
85e6fe83 1582 (void)setegid((Gid_t)egid);
79072805 1583#else
1584#ifdef HAS_SETREGID
85e6fe83 1585 (void)setregid((Gid_t)-1, (Gid_t)egid);
1586#else
1587#ifdef HAS_SETRESGID
1588 (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
79072805 1589#else
1590 if (egid == gid) /* special case $) = $( */
1591 (void)setgid(egid);
748a9306 1592 else {
1593 egid = (I32)getegid();
463ee0b2 1594 croak("setegid() not implemented");
748a9306 1595 }
79072805 1596#endif
1597#endif
85e6fe83 1598#endif
79072805 1599 egid = (I32)getegid();
4633a7c4 1600 tainting |= (uid && (euid != uid || egid != gid));
79072805 1601 break;
1602 case ':':
a0d0e21e 1603 chopset = SvPV_force(sv,na);
79072805 1604 break;
1605 case '0':
1606 if (!origalen) {
1607 s = origargv[0];
1608 s += strlen(s);
1609 /* See if all the arguments are contiguous in memory */
1610 for (i = 1; i < origargc; i++) {
1611 if (origargv[i] == s + 1)
1612 s += strlen(++s); /* this one is ok too */
1613 }
bbce6d69 1614 /* can grab env area too? */
1615 if (origenviron && origenviron[0] == s + 1) {
66b1d557 1616 my_setenv("NoNe SuCh", Nullch);
79072805 1617 /* force copy of environment */
1618 for (i = 0; origenviron[i]; i++)
1619 if (origenviron[i] == s + 1)
1620 s += strlen(++s);
1621 }
1622 origalen = s - origargv[0];
1623 }
a0d0e21e 1624 s = SvPV_force(sv,len);
8990e307 1625 i = len;
79072805 1626 if (i >= origalen) {
1627 i = origalen;
1628 SvCUR_set(sv, i);
1629 *SvEND(sv) = '\0';
1630 Copy(s, origargv[0], i, char);
1631 }
1632 else {
1633 Copy(s, origargv[0], i, char);
1634 s = origargv[0]+i;
1635 *s++ = '\0';
1636 while (++i < origalen)
8990e307 1637 *s++ = ' ';
1638 s = origargv[0]+i;
ed6116ce 1639 for (i = 1; i < origargc; i++)
8990e307 1640 origargv[i] = Nullch;
79072805 1641 }
1642 break;
1643 }
1644 return 0;
1645}
1646
1647I32
1648whichsig(sig)
1649char *sig;
1650{
1651 register char **sigv;
1652
1653 for (sigv = sig_name+1; *sigv; sigv++)
1654 if (strEQ(sig,*sigv))
8e07c86e 1655 return sig_num[sigv - sig_name];
79072805 1656#ifdef SIGCLD
1657 if (strEQ(sig,"CHLD"))
1658 return SIGCLD;
1659#endif
1660#ifdef SIGCHLD
1661 if (strEQ(sig,"CLD"))
1662 return SIGCHLD;
1663#endif
1664 return 0;
1665}
1666
ecfc5424 1667Signal_t
79072805 1668sighandler(sig)
a0d0e21e 1669int sig;
79072805 1670{
1671 dSP;
1672 GV *gv;
a0d0e21e 1673 HV *st;
79072805 1674 SV *sv;
1675 CV *cv;
79072805 1676 AV *oldstack;
ff0cee69 1677
1678 if (!psig_ptr[sig])
1679 die("Signal SIG%s received, but no signal handler set.\n",
1680 sig_name[sig]);
1681
88e89b8a 1682 cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
a0d0e21e 1683 if (!cv || !CvROOT(cv)) {
79072805 1684 if (dowarn)
1685 warn("SIG%s handler \"%s\" not defined.\n",
88e89b8a 1686 sig_name[sig], GvENAME(gv) );
79072805 1687 return;
1688 }
1689
88e89b8a 1690 oldstack = curstack;
1691 if (curstack != signalstack)
a0d0e21e 1692 AvFILL(signalstack) = 0;
88e89b8a 1693 SWITCHSTACK(curstack, signalstack);
79072805 1694
88e89b8a 1695 if(psig_name[sig])
1696 sv = SvREFCNT_inc(psig_name[sig]);
1697 else {
ff0cee69 1698 sv = sv_newmortal();
1699 sv_setpv(sv,sig_name[sig]);
88e89b8a 1700 }
a0d0e21e 1701 PUSHMARK(sp);
79072805 1702 PUSHs(sv);
79072805 1703 PUTBACK;
a0d0e21e 1704
1705 perl_call_sv((SV*)cv, G_DISCARD);
79072805 1706
1707 SWITCHSTACK(signalstack, oldstack);
4bf61a0f 1708
79072805 1709 return;
1710}