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