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