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