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