This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Debugging output for lock handling.
[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
5cd24f17 23#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221
CS
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 289 case '+':
bbce6d69
PP
290 if (curpm && (rx = curpm->op_pmregexp)) {
291 paren = rx->lastparen;
13f57bf8
CS
292 if (paren)
293 goto getparen;
93a17b20 294 }
748a9306 295 return 0;
93a17b20 296 case '`':
bbce6d69 297 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 298 if ((s = rx->subbeg) && rx->startp[0]) {
bbce6d69 299 i = rx->startp[0] - s;
71be2cbc 300 if (i >= 0)
93a17b20 301 return i;
93a17b20 302 }
93a17b20 303 }
748a9306 304 return 0;
93a17b20 305 case '\'':
bbce6d69 306 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8
CS
307 if (rx->subend && (s = rx->endp[0])) {
308 i = rx->subend - s;
309 if (i >= 0)
5cd24f17 310 return i;
93a17b20 311 }
93a17b20 312 }
748a9306 313 return 0;
93a17b20
LW
314 case ',':
315 return (STRLEN)ofslen;
316 case '\\':
317 return (STRLEN)orslen;
318 }
319 magic_get(sv,mg);
320 if (!SvPOK(sv) && SvNIOK(sv))
463ee0b2 321 sv_2pv(sv, &na);
93a17b20
LW
322 if (SvPOK(sv))
323 return SvCUR(sv);
324 return 0;
325}
326
79072805
LW
327int
328magic_get(sv, mg)
329SV *sv;
330MAGIC *mg;
331{
332 register I32 paren;
333 register char *s;
334 register I32 i;
bbce6d69 335 register REGEXP *rx;
748a9306 336 char *t;
79072805
LW
337
338 switch (*mg->mg_ptr) {
748a9306
LW
339 case '\001': /* ^A */
340 sv_setsv(sv, bodytarget);
341 break;
79072805 342 case '\004': /* ^D */
188ea221 343 sv_setiv(sv, (IV)(debug & 32767));
79072805 344 break;
28f23441
PP
345 case '\005': /* ^E */
346#ifdef VMS
347 {
348# include <descrip.h>
349# include <starlet.h>
350 char msg[255];
351 $DESCRIPTOR(msgdsc,msg);
946ec16e 352 sv_setnv(sv,(double) vaxc$errno);
28f23441
PP
353 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
354 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
355 else
356 sv_setpv(sv,"");
357 }
358#else
88e89b8a 359#ifdef OS2
946ec16e 360 sv_setnv(sv, (double)Perl_rc);
88e89b8a
PP
361 sv_setpv(sv, os2error(Perl_rc));
362#else
946ec16e 363 sv_setnv(sv, (double)errno);
28f23441
PP
364 sv_setpv(sv, errno ? Strerror(errno) : "");
365#endif
88e89b8a 366#endif
946ec16e 367 SvNOK_on(sv); /* what a wonderful hack! */
28f23441 368 break;
79072805 369 case '\006': /* ^F */
188ea221 370 sv_setiv(sv, (IV)maxsysfd);
79072805 371 break;
a0d0e21e 372 case '\010': /* ^H */
188ea221 373 sv_setiv(sv, (IV)hints);
a0d0e21e 374 break;
79072805
LW
375 case '\t': /* ^I */
376 if (inplace)
377 sv_setpv(sv, inplace);
378 else
188ea221 379 sv_setsv(sv, &sv_undef);
79072805 380 break;
28f23441 381 case '\017': /* ^O */
188ea221 382 sv_setpv(sv, osname);
28f23441 383 break;
79072805 384 case '\020': /* ^P */
188ea221 385 sv_setiv(sv, (IV)perldb);
79072805
LW
386 break;
387 case '\024': /* ^T */
88e89b8a 388#ifdef BIG_TIME
188ea221 389 sv_setnv(sv, basetime);
88e89b8a 390#else
188ea221 391 sv_setiv(sv, (IV)basetime);
88e89b8a 392#endif
79072805
LW
393 break;
394 case '\027': /* ^W */
188ea221 395 sv_setiv(sv, (IV)dowarn);
79072805
LW
396 break;
397 case '1': case '2': case '3': case '4':
398 case '5': case '6': case '7': case '8': case '9': case '&':
bbce6d69 399 if (curpm && (rx = curpm->op_pmregexp)) {
88e89b8a 400 paren = atoi(GvENAME((GV*)mg->mg_obj));
79072805 401 getparen:
bbce6d69
PP
402 if (paren <= rx->nparens &&
403 (s = rx->startp[paren]) &&
404 (t = rx->endp[paren]))
405 {
748a9306 406 i = t - s;
13f57bf8 407 getrx:
748a9306 408 if (i >= 0) {
13f57bf8
CS
409 bool was_tainted;
410 if (tainting) {
411 was_tainted = tainted;
412 tainted = FALSE;
413 }
79072805 414 sv_setpvn(sv,s,i);
13f57bf8
CS
415 if (tainting)
416 tainted = was_tainted || rx->exec_tainted;
748a9306
LW
417 break;
418 }
79072805 419 }
79072805 420 }
748a9306 421 sv_setsv(sv,&sv_undef);
79072805
LW
422 break;
423 case '+':
bbce6d69
PP
424 if (curpm && (rx = curpm->op_pmregexp)) {
425 paren = rx->lastparen;
a0d0e21e
LW
426 if (paren)
427 goto getparen;
79072805 428 }
748a9306 429 sv_setsv(sv,&sv_undef);
79072805
LW
430 break;
431 case '`':
bbce6d69 432 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8 433 if ((s = rx->subbeg) && rx->startp[0]) {
bbce6d69 434 i = rx->startp[0] - s;
13f57bf8 435 goto getrx;
79072805 436 }
79072805 437 }
748a9306 438 sv_setsv(sv,&sv_undef);
79072805
LW
439 break;
440 case '\'':
bbce6d69 441 if (curpm && (rx = curpm->op_pmregexp)) {
13f57bf8
CS
442 if (rx->subend && (s = rx->endp[0])) {
443 i = rx->subend - s;
444 goto getrx;
79072805 445 }
79072805 446 }
748a9306 447 sv_setsv(sv,&sv_undef);
79072805
LW
448 break;
449 case '.':
450#ifndef lint
a0d0e21e 451 if (GvIO(last_in_gv)) {
188ea221 452 sv_setiv(sv, (IV)IoLINES(GvIO(last_in_gv)));
79072805
LW
453 }
454#endif
455 break;
456 case '?':
ff0cee69
PP
457 sv_setiv(sv, (IV)STATUS_CURRENT);
458#ifdef COMPLEX_STATUS
459 LvTARGOFF(sv) = statusvalue;
460 LvTARGLEN(sv) = statusvalue_vms;
461#endif
79072805
LW
462 break;
463 case '^':
a0d0e21e 464 s = IoTOP_NAME(GvIOp(defoutgv));
79072805
LW
465 if (s)
466 sv_setpv(sv,s);
467 else {
468 sv_setpv(sv,GvENAME(defoutgv));
469 sv_catpv(sv,"_TOP");
470 }
471 break;
472 case '~':
a0d0e21e 473 s = IoFMT_NAME(GvIOp(defoutgv));
79072805
LW
474 if (!s)
475 s = GvENAME(defoutgv);
476 sv_setpv(sv,s);
477 break;
478#ifndef lint
479 case '=':
188ea221 480 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(defoutgv)));
79072805
LW
481 break;
482 case '-':
188ea221 483 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(defoutgv)));
79072805
LW
484 break;
485 case '%':
188ea221 486 sv_setiv(sv, (IV)IoPAGE(GvIOp(defoutgv)));
79072805
LW
487 break;
488#endif
489 case ':':
490 break;
491 case '/':
492 break;
493 case '[':
0f15f207 494 WITH_THR(sv_setiv(sv, (IV)curcop->cop_arybase));
79072805
LW
495 break;
496 case '|':
188ea221 497 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
498 break;
499 case ',':
500 sv_setpvn(sv,ofs,ofslen);
501 break;
502 case '\\':
503 sv_setpvn(sv,ors,orslen);
504 break;
505 case '#':
506 sv_setpv(sv,ofmt);
507 break;
508 case '!':
a5f75d66 509#ifdef VMS
946ec16e 510 sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 511 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 512#else
88e89b8a
PP
513 {
514 int saveerrno = errno;
946ec16e 515 sv_setnv(sv, (double)errno);
88e89b8a
PP
516#ifdef OS2
517 if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
518 else
a5f75d66 519#endif
2304df62 520 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
521 errno = saveerrno;
522 }
523#endif
946ec16e 524 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
525 break;
526 case '<':
188ea221 527 sv_setiv(sv, (IV)uid);
79072805
LW
528 break;
529 case '>':
188ea221 530 sv_setiv(sv, (IV)euid);
79072805
LW
531 break;
532 case '(':
188ea221 533 sv_setiv(sv, (IV)gid);
fc36a67e 534 sv_setpvf(sv, "%Vd", (IV)gid);
79072805
LW
535 goto add_groups;
536 case ')':
188ea221 537 sv_setiv(sv, (IV)egid);
fc36a67e 538 sv_setpvf(sv, "%Vd", (IV)egid);
79072805 539 add_groups:
79072805 540#ifdef HAS_GETGROUPS
79072805 541 {
a0d0e21e 542 Groups_t gary[NGROUPS];
79072805 543 i = getgroups(NGROUPS,gary);
46fc3d4c 544 while (--i >= 0)
fc36a67e 545 sv_catpvf(sv, " %Vd", (IV)gary[i]);
79072805
LW
546 }
547#endif
29355cf7 548 SvIOK_on(sv); /* what a wonderful hack! */
79072805
LW
549 break;
550 case '*':
551 break;
552 case '0':
553 break;
554 }
a0d0e21e 555 return 0;
79072805
LW
556}
557
558int
559magic_getuvar(sv, mg)
560SV *sv;
561MAGIC *mg;
562{
563 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
564
565 if (uf && uf->uf_val)
566 (*uf->uf_val)(uf->uf_index, sv);
567 return 0;
568}
569
570int
571magic_setenv(sv,mg)
572SV* sv;
573MAGIC* mg;
574{
575 register char *s;
88e89b8a 576 char *ptr;
5aabfad6 577 STRLEN len, klen;
a0d0e21e 578 I32 i;
1e422769 579
a0d0e21e 580 s = SvPV(sv,len);
5aabfad6 581 ptr = MgPV(mg,klen);
88e89b8a 582 my_setenv(ptr, s);
1e422769 583
a0d0e21e
LW
584#ifdef DYNAMIC_ENV_FETCH
585 /* We just undefd an environment var. Is a replacement */
586 /* waiting in the wings? */
587 if (!len) {
5aabfad6
PP
588 SV **valp;
589 if ((valp = hv_fetch(GvHVn(envgv), ptr, klen, FALSE)))
590 s = SvPV(*valp, len);
a0d0e21e
LW
591 }
592#endif
1e422769 593
68dc0745 594#if !defined(OS2) && !defined(AMIGAOS) && !defined(_WIN32)
79072805
LW
595 /* And you'll never guess what the dog had */
596 /* in its mouth... */
463ee0b2 597 if (tainting) {
1e422769
PP
598 MgTAINTEDDIR_off(mg);
599#ifdef VMS
5aabfad6 600 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769
PP
601 char pathbuf[256], eltbuf[256], *cp, *elt = s;
602 struct stat sbuf;
603 int i = 0, j = 0;
604
605 do { /* DCL$PATH may be a search list */
606 while (1) { /* as may dev portion of any element */
607 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
608 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
609 cando_by_name(S_IWUSR,0,elt) ) {
610 MgTAINTEDDIR_on(mg);
611 return 0;
612 }
613 }
614 if ((cp = strchr(elt, ':')) != Nullch)
615 *cp = '\0';
616 if (my_trnlnm(elt, eltbuf, j++))
617 elt = eltbuf;
618 else
619 break;
620 }
621 j = 0;
622 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
623 }
624#endif /* VMS */
5aabfad6 625 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 626 char *strend = s + len;
463ee0b2
LW
627
628 while (s < strend) {
1e422769 629 struct stat st;
fc36a67e
PP
630 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf,
631 s, strend, ':', &i);
463ee0b2 632 s++;
fc36a67e
PP
633 if (i >= sizeof tokenbuf /* too long -- assume the worst */
634 || *tokenbuf != '/'
1e422769 635 || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 636 MgTAINTEDDIR_on(mg);
1e422769
PP
637 return 0;
638 }
463ee0b2 639 }
79072805
LW
640 }
641 }
68dc0745 642#endif /* neither OS2 nor AMIGAOS nor _WIN32 */
1e422769 643
79072805
LW
644 return 0;
645}
646
647int
85e6fe83
LW
648magic_clearenv(sv,mg)
649SV* sv;
650MAGIC* mg;
651{
5aabfad6 652 my_setenv(MgPV(mg,na),Nullch);
85e6fe83
LW
653 return 0;
654}
655
88e89b8a
PP
656int
657magic_getsig(sv,mg)
658SV* sv;
659MAGIC* mg;
660{
661 I32 i;
662 /* Are we fetching a signal entry? */
5aabfad6 663 i = whichsig(MgPV(mg,na));
88e89b8a
PP
664 if (i) {
665 if(psig_ptr[i])
666 sv_setsv(sv,psig_ptr[i]);
667 else {
e858de61 668 dTHR; /* just for SvREFCNT_inc */
ff68c719
PP
669 Sighandler_t sigstate = rsignal_state(i);
670
88e89b8a 671 /* cache state so we don't fetch it again */
ff68c719 672 if(sigstate == SIG_IGN)
88e89b8a
PP
673 sv_setpv(sv,"IGNORE");
674 else
675 sv_setsv(sv,&sv_undef);
676 psig_ptr[i] = SvREFCNT_inc(sv);
677 SvTEMP_off(sv);
678 }
679 }
680 return 0;
681}
682int
683magic_clearsig(sv,mg)
684SV* sv;
685MAGIC* mg;
686{
687 I32 i;
688 /* Are we clearing a signal entry? */
5aabfad6 689 i = whichsig(MgPV(mg,na));
88e89b8a
PP
690 if (i) {
691 if(psig_ptr[i]) {
692 SvREFCNT_dec(psig_ptr[i]);
693 psig_ptr[i]=0;
694 }
695 if(psig_name[i]) {
696 SvREFCNT_dec(psig_name[i]);
697 psig_name[i]=0;
698 }
699 }
700 return 0;
701}
3d37d572 702
85e6fe83 703int
79072805
LW
704magic_setsig(sv,mg)
705SV* sv;
706MAGIC* mg;
707{
11343788 708 dTHR;
79072805
LW
709 register char *s;
710 I32 i;
748a9306 711 SV** svp;
a0d0e21e 712
5aabfad6 713 s = MgPV(mg,na);
748a9306
LW
714 if (*s == '_') {
715 if (strEQ(s,"__DIE__"))
716 svp = &diehook;
717 else if (strEQ(s,"__WARN__"))
718 svp = &warnhook;
719 else if (strEQ(s,"__PARSE__"))
720 svp = &parsehook;
721 else
722 croak("No such hook: %s", s);
723 i = 0;
4633a7c4
LW
724 if (*svp) {
725 SvREFCNT_dec(*svp);
726 *svp = 0;
727 }
748a9306
LW
728 }
729 else {
730 i = whichsig(s); /* ...no, a brick */
731 if (!i) {
732 if (dowarn || strEQ(s,"ALARM"))
733 warn("No such signal: SIG%s", s);
734 return 0;
735 }
ff0cee69
PP
736 SvREFCNT_dec(psig_name[i]);
737 SvREFCNT_dec(psig_ptr[i]);
88e89b8a 738 psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 739 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
ff0cee69 740 psig_name[i] = newSVpv(s, strlen(s));
88e89b8a 741 SvREADONLY_on(psig_name[i]);
748a9306 742 }
a0d0e21e 743 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
748a9306 744 if (i)
ff68c719 745 (void)rsignal(i, sighandler);
748a9306
LW
746 else
747 *svp = SvREFCNT_inc(sv);
a0d0e21e
LW
748 return 0;
749 }
750 s = SvPV_force(sv,na);
748a9306
LW
751 if (strEQ(s,"IGNORE")) {
752 if (i)
ff68c719 753 (void)rsignal(i, SIG_IGN);
748a9306
LW
754 else
755 *svp = 0;
756 }
757 else if (strEQ(s,"DEFAULT") || !*s) {
758 if (i)
ff68c719 759 (void)rsignal(i, SIG_DFL);
748a9306
LW
760 else
761 *svp = 0;
762 }
79072805 763 else {
5aabfad6
PP
764 /*
765 * We should warn if HINT_STRICT_REFS, but without
766 * access to a known hint bit in a known OP, we can't
767 * tell whether HINT_STRICT_REFS is in force or not.
768 */
46fc3d4c
PP
769 if (!strchr(s,':') && !strchr(s,'\''))
770 sv_setpv(sv, form("main::%s", s));
748a9306 771 if (i)
ff68c719 772 (void)rsignal(i, sighandler);
748a9306
LW
773 else
774 *svp = SvREFCNT_inc(sv);
79072805
LW
775 }
776 return 0;
777}
778
779int
463ee0b2 780magic_setisa(sv,mg)
79072805
LW
781SV* sv;
782MAGIC* mg;
783{
463ee0b2
LW
784 sub_generation++;
785 return 0;
786}
787
a0d0e21e
LW
788#ifdef OVERLOAD
789
463ee0b2 790int
a0d0e21e 791magic_setamagic(sv,mg)
463ee0b2
LW
792SV* sv;
793MAGIC* mg;
794{
a0d0e21e
LW
795 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
796 amagic_generation++;
463ee0b2 797
a0d0e21e
LW
798 return 0;
799}
800#endif /* OVERLOAD */
463ee0b2 801
946ec16e
PP
802int
803magic_setnkeys(sv,mg)
804SV* sv;
805MAGIC* mg;
806{
807 if (LvTARG(sv)) {
808 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
809 LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */
810 }
811 return 0;
812}
813
a0d0e21e
LW
814static int
815magic_methpack(sv,mg,meth)
816SV* sv;
817MAGIC* mg;
818char *meth;
819{
11343788 820 dTHR;
a0d0e21e 821 dSP;
463ee0b2 822
a0d0e21e
LW
823 ENTER;
824 SAVETMPS;
825 PUSHMARK(sp);
826 EXTEND(sp, 2);
827 PUSHs(mg->mg_obj);
88e89b8a
PP
828 if (mg->mg_ptr) {
829 if (mg->mg_len >= 0)
830 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
831 else if (mg->mg_len == HEf_SVKEY)
832 PUSHs((SV*)mg->mg_ptr);
833 }
a0d0e21e
LW
834 else if (mg->mg_type == 'p')
835 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
463ee0b2
LW
836 PUTBACK;
837
a0d0e21e
LW
838 if (perl_call_method(meth, G_SCALAR))
839 sv_setsv(sv, *stack_sp--);
463ee0b2 840
a0d0e21e
LW
841 FREETMPS;
842 LEAVE;
843 return 0;
844}
463ee0b2 845
a0d0e21e
LW
846int
847magic_getpack(sv,mg)
848SV* sv;
849MAGIC* mg;
850{
851 magic_methpack(sv,mg,"FETCH");
852 if (mg->mg_ptr)
853 mg->mg_flags |= MGf_GSKIP;
463ee0b2
LW
854 return 0;
855}
856
857int
858magic_setpack(sv,mg)
859SV* sv;
860MAGIC* mg;
861{
11343788 862 dTHR;
463ee0b2 863 dSP;
463ee0b2 864
a0d0e21e
LW
865 PUSHMARK(sp);
866 EXTEND(sp, 3);
867 PUSHs(mg->mg_obj);
88e89b8a
PP
868 if (mg->mg_ptr) {
869 if (mg->mg_len >= 0)
870 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
871 else if (mg->mg_len == HEf_SVKEY)
872 PUSHs((SV*)mg->mg_ptr);
873 }
a0d0e21e
LW
874 else if (mg->mg_type == 'p')
875 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
463ee0b2
LW
876 PUSHs(sv);
877 PUTBACK;
878
a0d0e21e 879 perl_call_method("STORE", G_SCALAR|G_DISCARD);
463ee0b2
LW
880
881 return 0;
882}
883
884int
885magic_clearpack(sv,mg)
886SV* sv;
887MAGIC* mg;
888{
a0d0e21e
LW
889 return magic_methpack(sv,mg,"DELETE");
890}
463ee0b2 891
a0d0e21e
LW
892int magic_wipepack(sv,mg)
893SV* sv;
894MAGIC* mg;
895{
11343788 896 dTHR;
a0d0e21e 897 dSP;
463ee0b2 898
a0d0e21e
LW
899 PUSHMARK(sp);
900 XPUSHs(mg->mg_obj);
463ee0b2 901 PUTBACK;
463ee0b2 902
a0d0e21e 903 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
463ee0b2
LW
904
905 return 0;
906}
907
908int
909magic_nextpack(sv,mg,key)
910SV* sv;
911MAGIC* mg;
912SV* key;
913{
11343788 914 dTHR;
463ee0b2 915 dSP;
a0d0e21e 916 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
917
918 ENTER;
a0d0e21e
LW
919 SAVETMPS;
920 PUSHMARK(sp);
921 EXTEND(sp, 2);
922 PUSHs(mg->mg_obj);
463ee0b2
LW
923 if (SvOK(key))
924 PUSHs(key);
925 PUTBACK;
926
a0d0e21e
LW
927 if (perl_call_method(meth, G_SCALAR))
928 sv_setsv(key, *stack_sp--);
463ee0b2 929
a0d0e21e
LW
930 FREETMPS;
931 LEAVE;
79072805
LW
932 return 0;
933}
934
935int
a0d0e21e
LW
936magic_existspack(sv,mg)
937SV* sv;
938MAGIC* mg;
939{
940 return magic_methpack(sv,mg,"EXISTS");
941}
942
943int
79072805
LW
944magic_setdbline(sv,mg)
945SV* sv;
946MAGIC* mg;
947{
11343788 948 dTHR;
79072805
LW
949 OP *o;
950 I32 i;
951 GV* gv;
952 SV** svp;
953
954 gv = DBline;
955 i = SvTRUE(sv);
188ea221 956 svp = av_fetch(GvAV(gv),
5aabfad6 957 atoi(MgPV(mg,na)), FALSE);
8990e307 958 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
93a17b20 959 o->op_private = i;
79072805
LW
960 else
961 warn("Can't break at that line\n");
962 return 0;
963}
964
965int
966magic_getarylen(sv,mg)
967SV* sv;
968MAGIC* mg;
969{
0f15f207 970 dTHR;
a0d0e21e 971 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
79072805
LW
972 return 0;
973}
974
975int
976magic_setarylen(sv,mg)
977SV* sv;
978MAGIC* mg;
979{
0f15f207 980 dTHR;
a0d0e21e
LW
981 av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
982 return 0;
983}
984
985int
986magic_getpos(sv,mg)
987SV* sv;
988MAGIC* mg;
989{
990 SV* lsv = LvTARG(sv);
991
992 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
993 mg = mg_find(lsv, 'g');
994 if (mg && mg->mg_len >= 0) {
0f15f207 995 dTHR;
a0d0e21e
LW
996 sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
997 return 0;
998 }
999 }
1000 (void)SvOK_off(sv);
1001 return 0;
1002}
1003
1004int
1005magic_setpos(sv,mg)
1006SV* sv;
1007MAGIC* mg;
1008{
1009 SV* lsv = LvTARG(sv);
1010 SSize_t pos;
1011 STRLEN len;
1012
1013 mg = 0;
1014
1015 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1016 mg = mg_find(lsv, 'g');
1017 if (!mg) {
1018 if (!SvOK(sv))
1019 return 0;
1020 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1021 mg = mg_find(lsv, 'g');
1022 }
1023 else if (!SvOK(sv)) {
1024 mg->mg_len = -1;
1025 return 0;
1026 }
1027 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1028
0f15f207 1029 WITH_THR(pos = SvIV(sv) - curcop->cop_arybase);
a0d0e21e
LW
1030 if (pos < 0) {
1031 pos += len;
1032 if (pos < 0)
1033 pos = 0;
1034 }
1035 else if (pos > len)
1036 pos = len;
1037 mg->mg_len = pos;
71be2cbc 1038 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1039
79072805
LW
1040 return 0;
1041}
1042
1043int
1044magic_getglob(sv,mg)
1045SV* sv;
1046MAGIC* mg;
1047{
8646b087
PP
1048 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1049 SvFAKE_off(sv);
946ec16e 1050 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1051 SvFAKE_on(sv);
1052 }
1053 else
946ec16e 1054 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1055 return 0;
1056}
1057
1058int
1059magic_setglob(sv,mg)
1060SV* sv;
1061MAGIC* mg;
1062{
1063 register char *s;
1064 GV* gv;
1065
1066 if (!SvOK(sv))
1067 return 0;
463ee0b2 1068 s = SvPV(sv, na);
79072805
LW
1069 if (*s == '*' && s[1])
1070 s++;
85e6fe83 1071 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
79072805
LW
1072 if (sv == (SV*)gv)
1073 return 0;
1074 if (GvGP(sv))
88e89b8a 1075 gp_free((GV*)sv);
79072805 1076 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1077 return 0;
1078}
1079
1080int
1081magic_setsubstr(sv,mg)
1082SV* sv;
1083MAGIC* mg;
1084{
8990e307
LW
1085 STRLEN len;
1086 char *tmps = SvPV(sv,len);
1087 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
79072805
LW
1088 return 0;
1089}
1090
1091int
463ee0b2
LW
1092magic_gettaint(sv,mg)
1093SV* sv;
1094MAGIC* mg;
1095{
bbce6d69
PP
1096 TAINT_IF((mg->mg_len & 1) ||
1097 (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
463ee0b2
LW
1098 return 0;
1099}
1100
1101int
1102magic_settaint(sv,mg)
1103SV* sv;
1104MAGIC* mg;
1105{
11343788 1106 dTHR;
748a9306
LW
1107 if (localizing) {
1108 if (localizing == 1)
1109 mg->mg_len <<= 1;
1110 else
1111 mg->mg_len >>= 1;
a0d0e21e 1112 }
748a9306
LW
1113 else if (tainted)
1114 mg->mg_len |= 1;
1115 else
1116 mg->mg_len &= ~1;
463ee0b2
LW
1117 return 0;
1118}
1119
1120int
79072805
LW
1121magic_setvec(sv,mg)
1122SV* sv;
1123MAGIC* mg;
1124{
1125 do_vecset(sv); /* XXX slurp this routine */
1126 return 0;
1127}
1128
1129int
68dc0745 1130magic_getdefelem(sv,mg)
5f05dabc
PP
1131SV* sv;
1132MAGIC* mg;
1133{
71be2cbc 1134 SV *targ = Nullsv;
5f05dabc 1135 if (LvTARGLEN(sv)) {
68dc0745
PP
1136 if (mg->mg_obj) {
1137 HV* hv = (HV*)LvTARG(sv);
1138 HE* he = hv_fetch_ent(hv, mg->mg_obj, FALSE, 0);
1139 if (he)
1140 targ = HeVAL(he);
1141 }
1142 else {
1143 AV* av = (AV*)LvTARG(sv);
1144 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1145 targ = AvARRAY(av)[LvTARGOFF(sv)];
1146 }
1147 if (targ && targ != &sv_undef) {
e858de61 1148 dTHR; /* just for SvREFCNT_dec */
68dc0745
PP
1149 /* somebody else defined it for us */
1150 SvREFCNT_dec(LvTARG(sv));
1151 LvTARG(sv) = SvREFCNT_inc(targ);
1152 LvTARGLEN(sv) = 0;
1153 SvREFCNT_dec(mg->mg_obj);
1154 mg->mg_obj = Nullsv;
1155 mg->mg_flags &= ~MGf_REFCOUNTED;
1156 }
5f05dabc 1157 }
71be2cbc
PP
1158 else
1159 targ = LvTARG(sv);
1160 sv_setsv(sv, targ ? targ : &sv_undef);
1161 return 0;
1162}
1163
1164int
68dc0745 1165magic_setdefelem(sv,mg)
71be2cbc
PP
1166SV* sv;
1167MAGIC* mg;
1168{
1169 if (LvTARGLEN(sv))
68dc0745
PP
1170 vivify_defelem(sv);
1171 if (LvTARG(sv)) {
5f05dabc 1172 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1173 SvSETMAGIC(LvTARG(sv));
1174 }
5f05dabc
PP
1175 return 0;
1176}
1177
1178int
68dc0745 1179magic_freedefelem(sv,mg)
5f05dabc
PP
1180SV* sv;
1181MAGIC* mg;
1182{
1183 SvREFCNT_dec(LvTARG(sv));
71be2cbc
PP
1184 return 0;
1185}
1186
1187void
68dc0745 1188vivify_defelem(sv)
71be2cbc
PP
1189SV* sv;
1190{
e858de61 1191 dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
68dc0745
PP
1192 MAGIC* mg;
1193 SV* value;
71be2cbc 1194
68dc0745 1195 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
71be2cbc 1196 return;
68dc0745
PP
1197 if (mg->mg_obj) {
1198 HV* hv = (HV*)LvTARG(sv);
1199 HE* he = hv_fetch_ent(hv, mg->mg_obj, TRUE, 0);
1200 if (!he || (value = HeVAL(he)) == &sv_undef)
1201 croak(no_helem, SvPV(mg->mg_obj, na));
71be2cbc 1202 }
68dc0745
PP
1203 else {
1204 AV* av = (AV*)LvTARG(sv);
5aabfad6 1205 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1206 LvTARG(sv) = Nullsv; /* array can't be extended */
1207 else {
1208 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1209 if (!svp || (value = *svp) == &sv_undef)
1210 croak(no_aelem, (I32)LvTARGOFF(sv));
1211 }
1212 }
1213 SvREFCNT_inc(value);
1214 SvREFCNT_dec(LvTARG(sv));
1215 LvTARG(sv) = value;
71be2cbc 1216 LvTARGLEN(sv) = 0;
68dc0745
PP
1217 SvREFCNT_dec(mg->mg_obj);
1218 mg->mg_obj = Nullsv;
1219 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1220}
1221
1222int
93a17b20
LW
1223magic_setmglob(sv,mg)
1224SV* sv;
1225MAGIC* mg;
1226{
a0d0e21e 1227 mg->mg_len = -1;
c6496cc7 1228 SvSCREAM_off(sv);
93a17b20
LW
1229 return 0;
1230}
1231
1232int
79072805
LW
1233magic_setbm(sv,mg)
1234SV* sv;
1235MAGIC* mg;
1236{
463ee0b2 1237 sv_unmagic(sv, 'B');
79072805
LW
1238 SvVALID_off(sv);
1239 return 0;
1240}
1241
1242int
55497cff
PP
1243magic_setfm(sv,mg)
1244SV* sv;
1245MAGIC* mg;
1246{
1247 sv_unmagic(sv, 'f');
1248 SvCOMPILED_off(sv);
1249 return 0;
1250}
1251
1252int
79072805
LW
1253magic_setuvar(sv,mg)
1254SV* sv;
1255MAGIC* mg;
1256{
1257 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1258
1259 if (uf && uf->uf_set)
1260 (*uf->uf_set)(uf->uf_index, sv);
1261 return 0;
1262}
1263
7a4c00b4 1264#ifdef USE_LOCALE_COLLATE
79072805 1265int
bbce6d69
PP
1266magic_setcollxfrm(sv,mg)
1267SV* sv;
1268MAGIC* mg;
1269{
1270 /*
1271 * René Descartes said "I think not."
1272 * and vanished with a faint plop.
1273 */
7a4c00b4
PP
1274 if (mg->mg_ptr) {
1275 Safefree(mg->mg_ptr);
1276 mg->mg_ptr = NULL;
1277 mg->mg_len = -1;
1278 }
bbce6d69
PP
1279 return 0;
1280}
7a4c00b4 1281#endif /* USE_LOCALE_COLLATE */
bbce6d69
PP
1282
1283int
79072805
LW
1284magic_set(sv,mg)
1285SV* sv;
1286MAGIC* mg;
1287{
11343788 1288 dTHR;
79072805
LW
1289 register char *s;
1290 I32 i;
8990e307 1291 STRLEN len;
79072805 1292 switch (*mg->mg_ptr) {
748a9306
LW
1293 case '\001': /* ^A */
1294 sv_setsv(bodytarget, sv);
1295 break;
79072805 1296 case '\004': /* ^D */
8990e307 1297 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
79072805
LW
1298 DEBUG_x(dump_all());
1299 break;
28f23441
PP
1300 case '\005': /* ^E */
1301#ifdef VMS
1302 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1303#else
f86702cc
PP
1304 /* will anyone ever use this? */
1305 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
28f23441
PP
1306#endif
1307 break;
79072805 1308 case '\006': /* ^F */
463ee0b2 1309 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 1310 break;
a0d0e21e
LW
1311 case '\010': /* ^H */
1312 hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1313 break;
79072805
LW
1314 case '\t': /* ^I */
1315 if (inplace)
1316 Safefree(inplace);
1317 if (SvOK(sv))
a0d0e21e 1318 inplace = savepv(SvPV(sv,na));
79072805
LW
1319 else
1320 inplace = Nullch;
1321 break;
28f23441
PP
1322 case '\017': /* ^O */
1323 if (osname)
1324 Safefree(osname);
1325 if (SvOK(sv))
1326 osname = savepv(SvPV(sv,na));
1327 else
1328 osname = Nullch;
1329 break;
79072805 1330 case '\020': /* ^P */
463ee0b2 1331 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1332 if (i != perldb) {
1333 if (perldb)
1334 oldlastpm = curpm;
1335 else
1336 curpm = oldlastpm;
1337 }
1338 perldb = i;
1339 break;
1340 case '\024': /* ^T */
88e89b8a
PP
1341#ifdef BIG_TIME
1342 basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1343#else
85e6fe83 1344 basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 1345#endif
79072805
LW
1346 break;
1347 case '\027': /* ^W */
463ee0b2 1348 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1349 break;
1350 case '.':
748a9306
LW
1351 if (localizing) {
1352 if (localizing == 1)
1353 save_sptr((SV**)&last_in_gv);
1354 }
88e89b8a 1355 else if (SvOK(sv) && GvIO(last_in_gv))
a0d0e21e 1356 IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
79072805
LW
1357 break;
1358 case '^':
a0d0e21e
LW
1359 Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1360 IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1361 IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1362 break;
1363 case '~':
a0d0e21e
LW
1364 Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1365 IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1366 IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
79072805
LW
1367 break;
1368 case '=':
a0d0e21e 1369 IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1370 break;
1371 case '-':
a0d0e21e
LW
1372 IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1373 if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1374 IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
79072805
LW
1375 break;
1376 case '%':
a0d0e21e 1377 IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1378 break;
1379 case '|':
4b65379b
CS
1380 {
1381 IO *io = GvIOp(defoutgv);
1382 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1383 IoFLAGS(io) &= ~IOf_FLUSH;
1384 else {
1385 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1386 PerlIO *ofp = IoOFP(io);
1387 if (ofp)
1388 (void)PerlIO_flush(ofp);
1389 IoFLAGS(io) |= IOf_FLUSH;
1390 }
1391 }
79072805
LW
1392 }
1393 break;
1394 case '*':
463ee0b2 1395 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1396 multiline = (i != 0);
1397 break;
1398 case '/':
c07a80fd
PP
1399 SvREFCNT_dec(nrs);
1400 nrs = newSVsv(sv);
1401 SvREFCNT_dec(rs);
1402 rs = SvREFCNT_inc(nrs);
79072805
LW
1403 break;
1404 case '\\':
1405 if (ors)
1406 Safefree(ors);
e3c19b7b
CS
1407 if (SvOK(sv) || SvGMAGICAL(sv))
1408 ors = savepv(SvPV(sv,orslen));
1409 else {
1410 ors = Nullch;
1411 orslen = 0;
1412 }
79072805
LW
1413 break;
1414 case ',':
1415 if (ofs)
1416 Safefree(ofs);
a0d0e21e 1417 ofs = savepv(SvPV(sv, ofslen));
79072805
LW
1418 break;
1419 case '#':
1420 if (ofmt)
1421 Safefree(ofmt);
a0d0e21e 1422 ofmt = savepv(SvPV(sv,na));
79072805
LW
1423 break;
1424 case '[':
a0d0e21e 1425 compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1426 break;
1427 case '?':
ff0cee69
PP
1428#ifdef COMPLEX_STATUS
1429 if (localizing == 2) {
1430 statusvalue = LvTARGOFF(sv);
1431 statusvalue_vms = LvTARGLEN(sv);
1432 }
1433 else
1434#endif
1435#ifdef VMSISH_STATUS
1436 if (VMSISH_STATUS)
1437 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1438 else
1439#endif
1440 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
1441 break;
1442 case '!':
f86702cc
PP
1443 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
1444 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
79072805
LW
1445 break;
1446 case '<':
463ee0b2 1447 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1448 if (delaymagic) {
1449 delaymagic |= DM_RUID;
1450 break; /* don't do magic till later */
1451 }
1452#ifdef HAS_SETRUID
85e6fe83 1453 (void)setruid((Uid_t)uid);
79072805
LW
1454#else
1455#ifdef HAS_SETREUID
85e6fe83 1456 (void)setreuid((Uid_t)uid, (Uid_t)-1);
748a9306 1457#else
85e6fe83
LW
1458#ifdef HAS_SETRESUID
1459 (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
79072805
LW
1460#else
1461 if (uid == euid) /* special case $< = $> */
1462 (void)setuid(uid);
a0d0e21e
LW
1463 else {
1464 uid = (I32)getuid();
463ee0b2 1465 croak("setruid() not implemented");
a0d0e21e 1466 }
79072805
LW
1467#endif
1468#endif
85e6fe83 1469#endif
748a9306 1470 uid = (I32)getuid();
4633a7c4 1471 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1472 break;
1473 case '>':
463ee0b2 1474 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1475 if (delaymagic) {
1476 delaymagic |= DM_EUID;
1477 break; /* don't do magic till later */
1478 }
1479#ifdef HAS_SETEUID
85e6fe83 1480 (void)seteuid((Uid_t)euid);
79072805
LW
1481#else
1482#ifdef HAS_SETREUID
85e6fe83
LW
1483 (void)setreuid((Uid_t)-1, (Uid_t)euid);
1484#else
1485#ifdef HAS_SETRESUID
1486 (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
79072805
LW
1487#else
1488 if (euid == uid) /* special case $> = $< */
1489 setuid(euid);
a0d0e21e
LW
1490 else {
1491 euid = (I32)geteuid();
463ee0b2 1492 croak("seteuid() not implemented");
a0d0e21e 1493 }
79072805
LW
1494#endif
1495#endif
85e6fe83 1496#endif
79072805 1497 euid = (I32)geteuid();
4633a7c4 1498 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1499 break;
1500 case '(':
463ee0b2 1501 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
1502 if (delaymagic) {
1503 delaymagic |= DM_RGID;
1504 break; /* don't do magic till later */
1505 }
1506#ifdef HAS_SETRGID
85e6fe83 1507 (void)setrgid((Gid_t)gid);
79072805
LW
1508#else
1509#ifdef HAS_SETREGID
85e6fe83
LW
1510 (void)setregid((Gid_t)gid, (Gid_t)-1);
1511#else
1512#ifdef HAS_SETRESGID
1513 (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
79072805
LW
1514#else
1515 if (gid == egid) /* special case $( = $) */
1516 (void)setgid(gid);
748a9306
LW
1517 else {
1518 gid = (I32)getgid();
463ee0b2 1519 croak("setrgid() not implemented");
748a9306 1520 }
79072805
LW
1521#endif
1522#endif
85e6fe83 1523#endif
79072805 1524 gid = (I32)getgid();
4633a7c4 1525 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1526 break;
1527 case ')':
5cd24f17
PP
1528#ifdef HAS_SETGROUPS
1529 {
1530 char *p = SvPV(sv, na);
1531 Groups_t gary[NGROUPS];
1532
1533 SET_NUMERIC_STANDARD();
1534 while (isSPACE(*p))
1535 ++p;
1536 egid = I_V(atof(p));
1537 for (i = 0; i < NGROUPS; ++i) {
1538 while (*p && !isSPACE(*p))
1539 ++p;
1540 while (isSPACE(*p))
1541 ++p;
1542 if (!*p)
1543 break;
1544 gary[i] = I_V(atof(p));
1545 }
8cc95fdb
PP
1546 if (i)
1547 (void)setgroups(i, gary);
5cd24f17
PP
1548 }
1549#else /* HAS_SETGROUPS */
463ee0b2 1550 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 1551#endif /* HAS_SETGROUPS */
79072805
LW
1552 if (delaymagic) {
1553 delaymagic |= DM_EGID;
1554 break; /* don't do magic till later */
1555 }
1556#ifdef HAS_SETEGID
85e6fe83 1557 (void)setegid((Gid_t)egid);
79072805
LW
1558#else
1559#ifdef HAS_SETREGID
85e6fe83
LW
1560 (void)setregid((Gid_t)-1, (Gid_t)egid);
1561#else
1562#ifdef HAS_SETRESGID
1563 (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
79072805
LW
1564#else
1565 if (egid == gid) /* special case $) = $( */
1566 (void)setgid(egid);
748a9306
LW
1567 else {
1568 egid = (I32)getegid();
463ee0b2 1569 croak("setegid() not implemented");
748a9306 1570 }
79072805
LW
1571#endif
1572#endif
85e6fe83 1573#endif
79072805 1574 egid = (I32)getegid();
4633a7c4 1575 tainting |= (uid && (euid != uid || egid != gid));
79072805
LW
1576 break;
1577 case ':':
a0d0e21e 1578 chopset = SvPV_force(sv,na);
79072805
LW
1579 break;
1580 case '0':
1581 if (!origalen) {
1582 s = origargv[0];
1583 s += strlen(s);
1584 /* See if all the arguments are contiguous in memory */
1585 for (i = 1; i < origargc; i++) {
1586 if (origargv[i] == s + 1)
1587 s += strlen(++s); /* this one is ok too */
1588 }
bbce6d69
PP
1589 /* can grab env area too? */
1590 if (origenviron && origenviron[0] == s + 1) {
79072805
LW
1591 my_setenv("NoNeSuCh", Nullch);
1592 /* force copy of environment */
1593 for (i = 0; origenviron[i]; i++)
1594 if (origenviron[i] == s + 1)
1595 s += strlen(++s);
1596 }
1597 origalen = s - origargv[0];
1598 }
a0d0e21e 1599 s = SvPV_force(sv,len);
8990e307 1600 i = len;
79072805
LW
1601 if (i >= origalen) {
1602 i = origalen;
1603 SvCUR_set(sv, i);
1604 *SvEND(sv) = '\0';
1605 Copy(s, origargv[0], i, char);
1606 }
1607 else {
1608 Copy(s, origargv[0], i, char);
1609 s = origargv[0]+i;
1610 *s++ = '\0';
1611 while (++i < origalen)
8990e307
LW
1612 *s++ = ' ';
1613 s = origargv[0]+i;
ed6116ce 1614 for (i = 1; i < origargc; i++)
8990e307 1615 origargv[i] = Nullch;
79072805
LW
1616 }
1617 break;
1618 }
1619 return 0;
1620}
1621
f93b4edd
MB
1622#ifdef USE_THREADS
1623int
1624magic_mutexfree(sv, mg)
1625SV *sv;
1626MAGIC *mg;
1627{
1628 dTHR;
bc1f4c86
MB
1629 DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
1630 (unsigned long)thr, (unsigned long)sv);)
f93b4edd
MB
1631 if (MgOWNER(mg))
1632 croak("panic: magic_mutexfree");
1633 MUTEX_DESTROY(MgMUTEXP(mg));
1634 COND_DESTROY(MgCONDP(mg));
1635 return 0;
1636}
1637#endif /* USE_THREADS */
1638
79072805
LW
1639I32
1640whichsig(sig)
1641char *sig;
1642{
1643 register char **sigv;
1644
1645 for (sigv = sig_name+1; *sigv; sigv++)
1646 if (strEQ(sig,*sigv))
8e07c86e 1647 return sig_num[sigv - sig_name];
79072805
LW
1648#ifdef SIGCLD
1649 if (strEQ(sig,"CHLD"))
1650 return SIGCLD;
1651#endif
1652#ifdef SIGCHLD
1653 if (strEQ(sig,"CLD"))
1654 return SIGCHLD;
1655#endif
1656 return 0;
1657}
1658
ecfc5424 1659Signal_t
79072805 1660sighandler(sig)
a0d0e21e 1661int sig;
79072805 1662{
11343788 1663 dTHR;
79072805
LW
1664 dSP;
1665 GV *gv;
a0d0e21e 1666 HV *st;
79072805
LW
1667 SV *sv;
1668 CV *cv;
79072805 1669 AV *oldstack;
ff0cee69
PP
1670
1671 if (!psig_ptr[sig])
1672 die("Signal SIG%s received, but no signal handler set.\n",
1673 sig_name[sig]);
1674
88e89b8a 1675 cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
a0d0e21e 1676 if (!cv || !CvROOT(cv)) {
79072805
LW
1677 if (dowarn)
1678 warn("SIG%s handler \"%s\" not defined.\n",
88e89b8a 1679 sig_name[sig], GvENAME(gv) );
79072805
LW
1680 return;
1681 }
1682
88e89b8a
PP
1683 oldstack = curstack;
1684 if (curstack != signalstack)
a0d0e21e 1685 AvFILL(signalstack) = 0;
88e89b8a 1686 SWITCHSTACK(curstack, signalstack);
79072805 1687
88e89b8a
PP
1688 if(psig_name[sig])
1689 sv = SvREFCNT_inc(psig_name[sig]);
1690 else {
ff0cee69
PP
1691 sv = sv_newmortal();
1692 sv_setpv(sv,sig_name[sig]);
88e89b8a 1693 }
a0d0e21e 1694 PUSHMARK(sp);
79072805 1695 PUSHs(sv);
79072805 1696 PUTBACK;
a0d0e21e
LW
1697
1698 perl_call_sv((SV*)cv, G_DISCARD);
79072805
LW
1699
1700 SWITCHSTACK(signalstack, oldstack);
4bf61a0f 1701
79072805
LW
1702 return;
1703}