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