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