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