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