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