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