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