This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.002gamma: utils/h2xs.PL
[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 '!':
464 sv_setnv(sv,(double)errno);
2304df62 465 sv_setpv(sv, errno ? Strerror(errno) : "");
79072805
LW
466 SvNOK_on(sv); /* what a wonderful hack! */
467 break;
468 case '<':
469 sv_setiv(sv,(I32)uid);
470 break;
471 case '>':
472 sv_setiv(sv,(I32)euid);
473 break;
474 case '(':
475 s = buf;
476 (void)sprintf(s,"%d",(int)gid);
477 goto add_groups;
478 case ')':
479 s = buf;
480 (void)sprintf(s,"%d",(int)egid);
481 add_groups:
482 while (*s) s++;
483#ifdef HAS_GETGROUPS
484#ifndef NGROUPS
485#define NGROUPS 32
486#endif
487 {
a0d0e21e 488 Groups_t gary[NGROUPS];
79072805
LW
489
490 i = getgroups(NGROUPS,gary);
491 while (--i >= 0) {
492 (void)sprintf(s," %ld", (long)gary[i]);
493 while (*s) s++;
494 }
495 }
496#endif
497 sv_setpv(sv,buf);
498 break;
499 case '*':
500 break;
501 case '0':
502 break;
503 }
a0d0e21e 504 return 0;
79072805
LW
505}
506
507int
508magic_getuvar(sv, mg)
509SV *sv;
510MAGIC *mg;
511{
512 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
513
514 if (uf && uf->uf_val)
515 (*uf->uf_val)(uf->uf_index, sv);
516 return 0;
517}
518
519int
520magic_setenv(sv,mg)
521SV* sv;
522MAGIC* mg;
523{
524 register char *s;
a0d0e21e
LW
525 STRLEN len;
526 I32 i;
527 s = SvPV(sv,len);
79072805 528 my_setenv(mg->mg_ptr,s);
a0d0e21e
LW
529#ifdef DYNAMIC_ENV_FETCH
530 /* We just undefd an environment var. Is a replacement */
531 /* waiting in the wings? */
532 if (!len) {
533 SV **envsvp;
534 if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE))
535 s = SvPV(*envsvp,len);
536 }
537#endif
79072805
LW
538 /* And you'll never guess what the dog had */
539 /* in its mouth... */
463ee0b2
LW
540 if (tainting) {
541 if (s && strEQ(mg->mg_ptr,"PATH")) {
a0d0e21e 542 char *strend = s + len;
463ee0b2
LW
543
544 while (s < strend) {
545 s = cpytill(tokenbuf,s,strend,':',&i);
546 s++;
547 if (*tokenbuf != '/'
a0d0e21e 548 || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
8990e307 549 MgTAINTEDDIR_on(mg);
463ee0b2 550 }
79072805
LW
551 }
552 }
79072805
LW
553 return 0;
554}
555
556int
85e6fe83
LW
557magic_clearenv(sv,mg)
558SV* sv;
559MAGIC* mg;
560{
561 my_setenv(mg->mg_ptr,Nullch);
562 return 0;
563}
564
3d37d572
PP
565#ifdef HAS_SIGACTION
566/* set up reliable signal() clone */
567
568typedef void (*Sigfunc) _((int));
569
570static
571Sigfunc rsignal(signo,handler)
572int signo;
573Sigfunc handler;
574{
575 struct sigaction act,oact;
576
577 act.sa_handler = handler;
578 sigemptyset(&act.sa_mask);
579 act.sa_flags = 0;
580#ifdef SIGALRM
581 if (signo == SIGALRM) {
582#else
583 if (0) {
584#endif
585#ifdef SA_INTERRUPT
586 act.sa_flags |= SA_INTERRUPT; /* SunOS */
587#endif
588 } else {
589#ifdef SA_RESTART
590 act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
591#endif
592 }
593 if (sigaction(signo, &act, &oact) < 0)
594 return(SIG_ERR);
595 else
596 return(oact.sa_handler);
597}
598
599#else
600
601/* ah well, so much for reliability */
602
603#define rsignal(x,y) signal(x,y)
604
605#endif
606
607
85e6fe83 608int
79072805
LW
609magic_setsig(sv,mg)
610SV* sv;
611MAGIC* mg;
612{
613 register char *s;
614 I32 i;
748a9306 615 SV** svp;
a0d0e21e 616
748a9306
LW
617 s = mg->mg_ptr;
618 if (*s == '_') {
619 if (strEQ(s,"__DIE__"))
620 svp = &diehook;
621 else if (strEQ(s,"__WARN__"))
622 svp = &warnhook;
623 else if (strEQ(s,"__PARSE__"))
624 svp = &parsehook;
625 else
626 croak("No such hook: %s", s);
627 i = 0;
4633a7c4
LW
628 if (*svp) {
629 SvREFCNT_dec(*svp);
630 *svp = 0;
631 }
748a9306
LW
632 }
633 else {
634 i = whichsig(s); /* ...no, a brick */
635 if (!i) {
636 if (dowarn || strEQ(s,"ALARM"))
637 warn("No such signal: SIG%s", s);
638 return 0;
639 }
640 }
a0d0e21e 641 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 642 if (i)
3d37d572 643 (void)rsignal(i,sighandler);
748a9306
LW
644 else
645 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
646 return 0;
647 }
648 s = SvPV_force(sv,na);
748a9306
LW
649 if (strEQ(s,"IGNORE")) {
650 if (i)
3d37d572 651 (void)rsignal(i,SIG_IGN);
748a9306
LW
652 else
653 *svp = 0;
654 }
655 else if (strEQ(s,"DEFAULT") || !*s) {
656 if (i)
3d37d572 657 (void)rsignal(i,SIG_DFL);
748a9306
LW
658 else
659 *svp = 0;
660 }
79072805 661 else {
2304df62
AD
662 if (!strchr(s,':') && !strchr(s,'\'')) {
663 sprintf(tokenbuf, "main::%s",s);
79072805
LW
664 sv_setpv(sv,tokenbuf);
665 }
748a9306 666 if (i)
3d37d572 667 (void)rsignal(i,sighandler);
748a9306
LW
668 else
669 *svp = SvREFCNT_inc(sv);
79072805
LW
670 }
671 return 0;
672}
673
674int
463ee0b2 675magic_setisa(sv,mg)
79072805
LW
676SV* sv;
677MAGIC* mg;
678{
463ee0b2
LW
679 sub_generation++;
680 return 0;
681}
682
a0d0e21e
LW
683#ifdef OVERLOAD
684
463ee0b2 685int
a0d0e21e 686magic_setamagic(sv,mg)
463ee0b2
LW
687SV* sv;
688MAGIC* mg;
689{
a0d0e21e
LW
690 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
691 amagic_generation++;
463ee0b2 692
a0d0e21e
LW
693 return 0;
694}
695#endif /* OVERLOAD */
463ee0b2 696
a0d0e21e
LW
697static int
698magic_methpack(sv,mg,meth)
699SV* sv;
700MAGIC* mg;
701char *meth;
702{
703 dSP;
463ee0b2 704
a0d0e21e
LW
705 ENTER;
706 SAVETMPS;
707 PUSHMARK(sp);
708 EXTEND(sp, 2);
709 PUSHs(mg->mg_obj);
463ee0b2 710 if (mg->mg_ptr)
a0d0e21e
LW
711 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
712 else if (mg->mg_type == 'p')
713 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
463ee0b2
LW
714 PUTBACK;
715
a0d0e21e
LW
716 if (perl_call_method(meth, G_SCALAR))
717 sv_setsv(sv, *stack_sp--);
463ee0b2 718
a0d0e21e
LW
719 FREETMPS;
720 LEAVE;
721 return 0;
722}
463ee0b2 723
a0d0e21e
LW
724int
725magic_getpack(sv,mg)
726SV* sv;
727MAGIC* mg;
728{
729 magic_methpack(sv,mg,"FETCH");
730 if (mg->mg_ptr)
731 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
732 return 0;
733}
734
735int
736magic_setpack(sv,mg)
737SV* sv;
738MAGIC* mg;
739{
463ee0b2 740 dSP;
463ee0b2 741
a0d0e21e
LW
742 PUSHMARK(sp);
743 EXTEND(sp, 3);
744 PUSHs(mg->mg_obj);
463ee0b2 745 if (mg->mg_ptr)
a0d0e21e
LW
746 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
747 else if (mg->mg_type == 'p')
748 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
463ee0b2
LW
749 PUSHs(sv);
750 PUTBACK;
751
a0d0e21e 752 perl_call_method("STORE", G_SCALAR|G_DISCARD);
463ee0b2
LW
753
754 return 0;
755}
756
757int
758magic_clearpack(sv,mg)
759SV* sv;
760MAGIC* mg;
761{
a0d0e21e
LW
762 return magic_methpack(sv,mg,"DELETE");
763}
463ee0b2 764
a0d0e21e
LW
765int magic_wipepack(sv,mg)
766SV* sv;
767MAGIC* mg;
768{
769 dSP;
463ee0b2 770
a0d0e21e
LW
771 PUSHMARK(sp);
772 XPUSHs(mg->mg_obj);
463ee0b2 773 PUTBACK;
463ee0b2 774
a0d0e21e 775 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
463ee0b2
LW
776
777 return 0;
778}
779
780int
781magic_nextpack(sv,mg,key)
782SV* sv;
783MAGIC* mg;
784SV* key;
785{
463ee0b2 786 dSP;
a0d0e21e 787 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
788
789 ENTER;
a0d0e21e
LW
790 SAVETMPS;
791 PUSHMARK(sp);
792 EXTEND(sp, 2);
793 PUSHs(mg->mg_obj);
463ee0b2
LW
794 if (SvOK(key))
795 PUSHs(key);
796 PUTBACK;
797
a0d0e21e
LW
798 if (perl_call_method(meth, G_SCALAR))
799 sv_setsv(key, *stack_sp--);
463ee0b2 800
a0d0e21e
LW
801 FREETMPS;
802 LEAVE;
79072805
LW
803 return 0;
804}
805
806int
a0d0e21e
LW
807magic_existspack(sv,mg)
808SV* sv;
809MAGIC* mg;
810{
811 return magic_methpack(sv,mg,"EXISTS");
812}
813
814int
79072805
LW
815magic_setdbline(sv,mg)
816SV* sv;
817MAGIC* mg;
818{
819 OP *o;
820 I32 i;
821 GV* gv;
822 SV** svp;
823
824 gv = DBline;
825 i = SvTRUE(sv);
826 svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
8990e307 827 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
93a17b20 828 o->op_private = i;
79072805
LW
829 else
830 warn("Can't break at that line\n");
831 return 0;
832}
833
834int
835magic_getarylen(sv,mg)
836SV* sv;
837MAGIC* mg;
838{
a0d0e21e 839 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
79072805
LW
840 return 0;
841}
842
843int
844magic_setarylen(sv,mg)
845SV* sv;
846MAGIC* mg;
847{
a0d0e21e
LW
848 av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
849 return 0;
850}
851
852int
853magic_getpos(sv,mg)
854SV* sv;
855MAGIC* mg;
856{
857 SV* lsv = LvTARG(sv);
858
859 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
860 mg = mg_find(lsv, 'g');
861 if (mg && mg->mg_len >= 0) {
862 sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
863 return 0;
864 }
865 }
866 (void)SvOK_off(sv);
867 return 0;
868}
869
870int
871magic_setpos(sv,mg)
872SV* sv;
873MAGIC* mg;
874{
875 SV* lsv = LvTARG(sv);
876 SSize_t pos;
877 STRLEN len;
878
879 mg = 0;
880
881 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
882 mg = mg_find(lsv, 'g');
883 if (!mg) {
884 if (!SvOK(sv))
885 return 0;
886 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
887 mg = mg_find(lsv, 'g');
888 }
889 else if (!SvOK(sv)) {
890 mg->mg_len = -1;
891 return 0;
892 }
893 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
894
895 pos = SvIV(sv) - curcop->cop_arybase;
896 if (pos < 0) {
897 pos += len;
898 if (pos < 0)
899 pos = 0;
900 }
901 else if (pos > len)
902 pos = len;
903 mg->mg_len = pos;
904
79072805
LW
905 return 0;
906}
907
908int
909magic_getglob(sv,mg)
910SV* sv;
911MAGIC* mg;
912{
913 gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
914 return 0;
915}
916
917int
918magic_setglob(sv,mg)
919SV* sv;
920MAGIC* mg;
921{
922 register char *s;
923 GV* gv;
924
925 if (!SvOK(sv))
926 return 0;
463ee0b2 927 s = SvPV(sv, na);
79072805
LW
928 if (*s == '*' && s[1])
929 s++;
85e6fe83 930 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
931 if (sv == (SV*)gv)
932 return 0;
933 if (GvGP(sv))
934 gp_free(sv);
935 GvGP(sv) = gp_ref(GvGP(gv));
936 if (!GvAV(gv))
937 gv_AVadd(gv);
938 if (!GvHV(gv))
939 gv_HVadd(gv);
a0d0e21e
LW
940 if (!GvIOp(gv))
941 GvIOp(gv) = newIO();
79072805
LW
942 return 0;
943}
944
945int
946magic_setsubstr(sv,mg)
947SV* sv;
948MAGIC* mg;
949{
8990e307
LW
950 STRLEN len;
951 char *tmps = SvPV(sv,len);
952 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
79072805
LW
953 return 0;
954}
955
956int
463ee0b2
LW
957magic_gettaint(sv,mg)
958SV* sv;
959MAGIC* mg;
960{
748a9306
LW
961 if (mg->mg_len & 1)
962 tainted = TRUE;
963 else if (mg->mg_len & 2 && mg->mg_obj == sv) /* kludge */
964 tainted = TRUE;
463ee0b2
LW
965 return 0;
966}
967
968int
969magic_settaint(sv,mg)
970SV* sv;
971MAGIC* mg;
972{
748a9306
LW
973 if (localizing) {
974 if (localizing == 1)
975 mg->mg_len <<= 1;
976 else
977 mg->mg_len >>= 1;
a0d0e21e 978 }
748a9306
LW
979 else if (tainted)
980 mg->mg_len |= 1;
981 else
982 mg->mg_len &= ~1;
463ee0b2
LW
983 return 0;
984}
985
986int
79072805
LW
987magic_setvec(sv,mg)
988SV* sv;
989MAGIC* mg;
990{
991 do_vecset(sv); /* XXX slurp this routine */
992 return 0;
993}
994
995int
93a17b20
LW
996magic_setmglob(sv,mg)
997SV* sv;
998MAGIC* mg;
999{
a0d0e21e 1000 mg->mg_len = -1;
c6496cc7 1001 SvSCREAM_off(sv);
93a17b20
LW
1002 return 0;
1003}
1004
1005int
79072805
LW
1006magic_setbm(sv,mg)
1007SV* sv;
1008MAGIC* mg;
1009{
463ee0b2 1010 sv_unmagic(sv, 'B');
79072805
LW
1011 SvVALID_off(sv);
1012 return 0;
1013}
1014
1015int
1016magic_setuvar(sv,mg)
1017SV* sv;
1018MAGIC* mg;
1019{
1020 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1021
1022 if (uf && uf->uf_set)
1023 (*uf->uf_set)(uf->uf_index, sv);
1024 return 0;
1025}
1026
1027int
1028magic_set(sv,mg)
1029SV* sv;
1030MAGIC* mg;
1031{
1032 register char *s;
1033 I32 i;
8990e307 1034 STRLEN len;
79072805 1035 switch (*mg->mg_ptr) {
748a9306
LW
1036 case '\001': /* ^A */
1037 sv_setsv(bodytarget, sv);
1038 break;
79072805 1039 case '\004': /* ^D */
8990e307 1040 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805
LW
1041 DEBUG_x(dump_all());
1042 break;
1043 case '\006': /* ^F */
463ee0b2 1044 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1045 break;
a0d0e21e
LW
1046 case '\010': /* ^H */
1047 hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1048 break;
79072805
LW
1049 case '\t': /* ^I */
1050 if (inplace)
1051 Safefree(inplace);
1052 if (SvOK(sv))
a0d0e21e 1053 inplace = savepv(SvPV(sv,na));
79072805
LW
1054 else
1055 inplace = Nullch;
1056 break;
1057 case '\020': /* ^P */
463ee0b2 1058 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1059 if (i != perldb) {
1060 if (perldb)
1061 oldlastpm = curpm;
1062 else
1063 curpm = oldlastpm;
1064 }
1065 perldb = i;
1066 break;
1067 case '\024': /* ^T */
85e6fe83 1068 basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1069 break;
1070 case '\027': /* ^W */
463ee0b2 1071 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1072 break;
1073 case '.':
748a9306
LW
1074 if (localizing) {
1075 if (localizing == 1)
1076 save_sptr((SV**)&last_in_gv);
1077 }
2304df62 1078 else if (SvOK(sv))
a0d0e21e 1079 IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
79072805
LW
1080 break;
1081 case '^':
a0d0e21e
LW
1082 Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1083 IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1084 IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1085 break;
1086 case '~':
a0d0e21e
LW
1087 Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1088 IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1089 IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1090 break;
1091 case '=':
a0d0e21e 1092 IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1093 break;
1094 case '-':
a0d0e21e
LW
1095 IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1096 if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1097 IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
79072805
LW
1098 break;
1099 case '%':
a0d0e21e 1100 IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1101 break;
1102 case '|':
a0d0e21e 1103 IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
463ee0b2 1104 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
a0d0e21e 1105 IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
79072805
LW
1106 }
1107 break;
1108 case '*':
463ee0b2 1109 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1110 multiline = (i != 0);
1111 break;
1112 case '/':
c07a80fd
PP
1113 SvREFCNT_dec(nrs);
1114 nrs = newSVsv(sv);
1115 SvREFCNT_dec(rs);
1116 rs = SvREFCNT_inc(nrs);
79072805
LW
1117 break;
1118 case '\\':
1119 if (ors)
1120 Safefree(ors);
a0d0e21e 1121 ors = savepv(SvPV(sv,orslen));
79072805
LW
1122 break;
1123 case ',':
1124 if (ofs)
1125 Safefree(ofs);
a0d0e21e 1126 ofs = savepv(SvPV(sv, ofslen));
79072805
LW
1127 break;
1128 case '#':
1129 if (ofmt)
1130 Safefree(ofmt);
a0d0e21e 1131 ofmt = savepv(SvPV(sv,na));
79072805
LW
1132 break;
1133 case '[':
a0d0e21e 1134 compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1135 break;
1136 case '?':
748a9306 1137 statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1138 break;
1139 case '!':
748a9306 1140 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT); /* will anyone ever use this? */
79072805
LW
1141 break;
1142 case '<':
463ee0b2 1143 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1144 if (delaymagic) {
1145 delaymagic |= DM_RUID;
1146 break; /* don't do magic till later */
1147 }
1148#ifdef HAS_SETRUID
85e6fe83 1149 (void)setruid((Uid_t)uid);
79072805
LW
1150#else
1151#ifdef HAS_SETREUID
85e6fe83 1152 (void)setreuid((Uid_t)uid, (Uid_t)-1);
748a9306 1153#else
85e6fe83
LW
1154#ifdef HAS_SETRESUID
1155 (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
79072805
LW
1156#else
1157 if (uid == euid) /* special case $< = $> */
1158 (void)setuid(uid);
a0d0e21e
LW
1159 else {
1160 uid = (I32)getuid();
463ee0b2 1161 croak("setruid() not implemented");
a0d0e21e 1162 }
79072805
LW
1163#endif
1164#endif
85e6fe83 1165#endif
748a9306 1166 uid = (I32)getuid();
4633a7c4 1167 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1168 break;
1169 case '>':
463ee0b2 1170 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1171 if (delaymagic) {
1172 delaymagic |= DM_EUID;
1173 break; /* don't do magic till later */
1174 }
1175#ifdef HAS_SETEUID
85e6fe83 1176 (void)seteuid((Uid_t)euid);
79072805
LW
1177#else
1178#ifdef HAS_SETREUID
85e6fe83
LW
1179 (void)setreuid((Uid_t)-1, (Uid_t)euid);
1180#else
1181#ifdef HAS_SETRESUID
1182 (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
79072805
LW
1183#else
1184 if (euid == uid) /* special case $> = $< */
1185 setuid(euid);
a0d0e21e
LW
1186 else {
1187 euid = (I32)geteuid();
463ee0b2 1188 croak("seteuid() not implemented");
a0d0e21e 1189 }
79072805
LW
1190#endif
1191#endif
85e6fe83 1192#endif
79072805 1193 euid = (I32)geteuid();
4633a7c4 1194 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1195 break;
1196 case '(':
463ee0b2 1197 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1198 if (delaymagic) {
1199 delaymagic |= DM_RGID;
1200 break; /* don't do magic till later */
1201 }
1202#ifdef HAS_SETRGID
85e6fe83 1203 (void)setrgid((Gid_t)gid);
79072805
LW
1204#else
1205#ifdef HAS_SETREGID
85e6fe83
LW
1206 (void)setregid((Gid_t)gid, (Gid_t)-1);
1207#else
1208#ifdef HAS_SETRESGID
1209 (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
79072805
LW
1210#else
1211 if (gid == egid) /* special case $( = $) */
1212 (void)setgid(gid);
748a9306
LW
1213 else {
1214 gid = (I32)getgid();
463ee0b2 1215 croak("setrgid() not implemented");
748a9306 1216 }
79072805
LW
1217#endif
1218#endif
85e6fe83 1219#endif
79072805 1220 gid = (I32)getgid();
4633a7c4 1221 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1222 break;
1223 case ')':
463ee0b2 1224 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1225 if (delaymagic) {
1226 delaymagic |= DM_EGID;
1227 break; /* don't do magic till later */
1228 }
1229#ifdef HAS_SETEGID
85e6fe83 1230 (void)setegid((Gid_t)egid);
79072805
LW
1231#else
1232#ifdef HAS_SETREGID
85e6fe83
LW
1233 (void)setregid((Gid_t)-1, (Gid_t)egid);
1234#else
1235#ifdef HAS_SETRESGID
1236 (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
79072805
LW
1237#else
1238 if (egid == gid) /* special case $) = $( */
1239 (void)setgid(egid);
748a9306
LW
1240 else {
1241 egid = (I32)getegid();
463ee0b2 1242 croak("setegid() not implemented");
748a9306 1243 }
79072805
LW
1244#endif
1245#endif
85e6fe83 1246#endif
79072805 1247 egid = (I32)getegid();
4633a7c4 1248 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1249 break;
1250 case ':':
a0d0e21e 1251 chopset = SvPV_force(sv,na);
79072805
LW
1252 break;
1253 case '0':
1254 if (!origalen) {
1255 s = origargv[0];
1256 s += strlen(s);
1257 /* See if all the arguments are contiguous in memory */
1258 for (i = 1; i < origargc; i++) {
1259 if (origargv[i] == s + 1)
1260 s += strlen(++s); /* this one is ok too */
1261 }
1262 if (origenviron[0] == s + 1) { /* can grab env area too? */
1263 my_setenv("NoNeSuCh", Nullch);
1264 /* force copy of environment */
1265 for (i = 0; origenviron[i]; i++)
1266 if (origenviron[i] == s + 1)
1267 s += strlen(++s);
1268 }
1269 origalen = s - origargv[0];
1270 }
a0d0e21e 1271 s = SvPV_force(sv,len);
8990e307 1272 i = len;
79072805
LW
1273 if (i >= origalen) {
1274 i = origalen;
1275 SvCUR_set(sv, i);
1276 *SvEND(sv) = '\0';
1277 Copy(s, origargv[0], i, char);
1278 }
1279 else {
1280 Copy(s, origargv[0], i, char);
1281 s = origargv[0]+i;
1282 *s++ = '\0';
1283 while (++i < origalen)
8990e307
LW
1284 *s++ = ' ';
1285 s = origargv[0]+i;
ed6116ce 1286 for (i = 1; i < origargc; i++)
8990e307 1287 origargv[i] = Nullch;
79072805
LW
1288 }
1289 break;
1290 }
1291 return 0;
1292}
1293
1294I32
1295whichsig(sig)
1296char *sig;
1297{
1298 register char **sigv;
1299
1300 for (sigv = sig_name+1; *sigv; sigv++)
1301 if (strEQ(sig,*sigv))
8e07c86e 1302 return sig_num[sigv - sig_name];
79072805
LW
1303#ifdef SIGCLD
1304 if (strEQ(sig,"CHLD"))
1305 return SIGCLD;
1306#endif
1307#ifdef SIGCHLD
1308 if (strEQ(sig,"CLD"))
1309 return SIGCHLD;
1310#endif
1311 return 0;
1312}
1313
ecfc5424 1314Signal_t
79072805 1315sighandler(sig)
a0d0e21e 1316int sig;
79072805
LW
1317{
1318 dSP;
1319 GV *gv;
a0d0e21e 1320 HV *st;
79072805
LW
1321 SV *sv;
1322 CV *cv;
79072805 1323 AV *oldstack;
8e07c86e 1324 char *signame;
79072805
LW
1325
1326#ifdef OS2 /* or anybody else who requires SIG_ACK */
1327 signal(sig, SIG_ACK);
1328#endif
1329
4633a7c4 1330 signame = sig_name[sig];
8e07c86e 1331 cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame),
a0d0e21e
LW
1332 TRUE),
1333 &st, &gv, TRUE);
1334 if (!cv || !CvROOT(cv) &&
8e07c86e 1335 *signame == 'C' && instr(signame,"LD")) {
a0d0e21e 1336
8e07c86e 1337 if (signame[1] == 'H')
a0d0e21e
LW
1338 cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
1339 &st, &gv, TRUE);
79072805 1340 else
a0d0e21e
LW
1341 cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
1342 &st, &gv, TRUE);
1343 /* gag */
79072805 1344 }
a0d0e21e 1345 if (!cv || !CvROOT(cv)) {
79072805
LW
1346 if (dowarn)
1347 warn("SIG%s handler \"%s\" not defined.\n",
8e07c86e 1348 signame, GvENAME(gv) );
79072805
LW
1349 return;
1350 }
1351
1352 oldstack = stack;
a0d0e21e
LW
1353 if (stack != signalstack)
1354 AvFILL(signalstack) = 0;
79072805
LW
1355 SWITCHSTACK(stack, signalstack);
1356
8990e307 1357 sv = sv_newmortal();
8e07c86e 1358 sv_setpv(sv,signame);
a0d0e21e 1359 PUSHMARK(sp);
79072805 1360 PUSHs(sv);
79072805 1361 PUTBACK;
a0d0e21e
LW
1362
1363 perl_call_sv((SV*)cv, G_DISCARD);
79072805
LW
1364
1365 SWITCHSTACK(signalstack, oldstack);
79072805
LW
1366
1367 return;
1368}