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