This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
back out changes#9012,9010,9009 and parts of change#9016
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
79072805 4 *
a0d0e21e
LW		 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.
79072805 7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
13 */
79072805
LW		 14
15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_PP_C
79072805
LW		 17#include "perl.h"
18
36477c24 19/*
ef2d312d
TH		 20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 */
26#ifdef CXUX_BROKEN_CONSTANT_CONVERT
27static double UV_MAX_cxux = ((double)UV_MAX);
8ec5e241 28#endif
ef2d312d
TH		 29
30/*
96e4d5b1 31 * Offset for integer pack/unpack.
32 *
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
35 */
36
37/*
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
dc45a647
MB		 42 * the preprocessor.) --???
43 */
44/*
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
96e4d5b1 47 */
48#define SIZE16 2
49#define SIZE32 4
50
9851f69c
JH		 51/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
52 --jhi Feb 1999 */
53
726ea183
JH		 54#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55# define PERL_NATINT_PACK
56#endif
57
0f9dfb06 58#if LONGSIZE > 4 && defined(_CRAY)
96e4d5b1 59# if BYTEORDER == 0x12345678
60# define OFF16(p) (char*)(p)
61# define OFF32(p) (char*)(p)
62# else
63# if BYTEORDER == 0x87654321
64# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
66# else
67 }}}} bad cray byte order
68# endif
69# endif
70# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
ef54e1a4 72# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
96e4d5b1 73# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
75#else
76# define COPY16(s,p) Copy(s, p, SIZE16, char)
77# define COPY32(s,p) Copy(s, p, SIZE32, char)
ef54e1a4 78# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
96e4d5b1 79# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
81#endif
82
a0d0e21e 83/* variations on pp_null */
79072805 84
dfe9444c
AD		 85/* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
87 --AD 2/20/1998
88*/
89#ifdef NEED_GETPID_PROTO
90extern Pid_t getpid (void);
8ac85365
NIS		 91#endif
92
93a17b20
LW		 93PP(pp_stub)
94{
4e35701f 95 djSP;
54310121 96 if (GIMME_V == G_SCALAR)
3280af22 97 XPUSHs(&PL_sv_undef);
93a17b20
LW		 98 RETURN;
99}
100
79072805
LW		 101PP(pp_scalar)
102{
103 return NORMAL;
104}
105
106/* Pushy stuff. */
107
93a17b20
LW		 108PP(pp_padav)
109{
4e35701f 110 djSP; dTARGET;
533c011a
NIS		 111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
85e6fe83 113 EXTEND(SP, 1);
533c011a 114 if (PL_op->op_flags & OPf_REF) {
85e6fe83 115 PUSHs(TARG);
93a17b20 116 RETURN;
84615ddc
GS		 117 } else if (LVRET) {
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
120 PUSHs(TARG);
121 RETURN;
85e6fe83
LW		 122 }
123 if (GIMME == G_ARRAY) {
124 I32 maxarg = AvFILL((AV*)TARG) + 1;
125 EXTEND(SP, maxarg);
93965878
NIS		 126 if (SvMAGICAL(TARG)) {
127 U32 i;
128 for (i=0; i < maxarg; i++) {
129 SV **svp = av_fetch((AV*)TARG, i, FALSE);
3280af22 130 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS		 131 }
132 }
133 else {
134 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
135 }
85e6fe83
LW		 136 SP += maxarg;
137 }
138 else {
139 SV* sv = sv_newmortal();
140 I32 maxarg = AvFILL((AV*)TARG) + 1;
141 sv_setiv(sv, maxarg);
142 PUSHs(sv);
143 }
144 RETURN;
93a17b20
LW		 145}
146
147PP(pp_padhv)
148{
4e35701f 149 djSP; dTARGET;
54310121 150 I32 gimme;
151
93a17b20 152 XPUSHs(TARG);
533c011a
NIS		 153 if (PL_op->op_private & OPpLVAL_INTRO)
154 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
155 if (PL_op->op_flags & OPf_REF)
93a17b20 156 RETURN;
84615ddc
GS		 157 else if (LVRET) {
158 if (GIMME == G_SCALAR)
159 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
160 RETURN;
161 }
54310121 162 gimme = GIMME_V;
163 if (gimme == G_ARRAY) {
cea2e8a9 164 RETURNOP(do_kv());
85e6fe83 165 }
54310121 166 else if (gimme == G_SCALAR) {
85e6fe83 167 SV* sv = sv_newmortal();
46fc3d4c 168 if (HvFILL((HV*)TARG))
cea2e8a9 169 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
46fc3d4c 170 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW		 171 else
172 sv_setiv(sv, 0);
173 SETs(sv);
85e6fe83 174 }
54310121 175 RETURN;
93a17b20
LW		 176}
177
ed6116ce
LW		 178PP(pp_padany)
179{
cea2e8a9 180 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
ed6116ce
LW		 181}
182
79072805
LW		 183/* Translations. */
184
185PP(pp_rv2gv)
186{
853846ea 187 djSP; dTOPss;
8ec5e241 188
ed6116ce 189 if (SvROK(sv)) {
a0d0e21e 190 wasref:
f5284f61
IZ		 191 tryAMAGICunDEREF(to_gv);
192
ed6116ce 193 sv = SvRV(sv);
b1dadf13 194 if (SvTYPE(sv) == SVt_PVIO) {
195 GV *gv = (GV*) sv_newmortal();
196 gv_init(gv, 0, "", 0, 0);
197 GvIOp(gv) = (IO *)sv;
3e3baf6d 198 (void)SvREFCNT_inc(sv);
b1dadf13 199 sv = (SV*) gv;
ef54e1a4
JH		 200 }
201 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 202 DIE(aTHX_ "Not a GLOB reference");
79072805
LW		 203 }
204 else {
93a17b20 205 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 206 char *sym;
c9d5ac95 207 STRLEN len;
748a9306 208
a0d0e21e
LW		 209 if (SvGMAGICAL(sv)) {
210 mg_get(sv);
211 if (SvROK(sv))
212 goto wasref;
213 }
afd1915d 214 if (!SvOK(sv) && sv != &PL_sv_undef) {
853846ea
NIS		 215 /* If this is a 'my' scalar and flag is set then vivify
216 * NI-S 1999/05/07
217 */
1d8d4d2a 218 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS		 219 char *name;
220 GV *gv;
221 if (cUNOP->op_targ) {
222 STRLEN len;
223 SV *namesv = PL_curpad[cUNOP->op_targ];
224 name = SvPV(namesv, len);
2d6d9f7a 225 gv = (GV*)NEWSV(0,0);
2c8ac474
GS		 226 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
227 }
228 else {
229 name = CopSTASHPV(PL_curcop);
230 gv = newGVgen(name);
1d8d4d2a 231 }
853846ea 232 sv_upgrade(sv, SVt_RV);
2c8ac474 233 SvRV(sv) = (SV*)gv;
853846ea 234 SvROK_on(sv);
1d8d4d2a 235 SvSETMAGIC(sv);
853846ea 236 goto wasref;
2c8ac474 237 }
533c011a
NIS		 238 if (PL_op->op_flags & OPf_REF ||
239 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 240 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 241 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 242 report_uninit();
a0d0e21e
LW		 243 RETSETUNDEF;
244 }
c9d5ac95 245 sym = SvPV(sv,len);
35cd451c
GS		 246 if ((PL_op->op_flags & OPf_SPECIAL) &&
247 !(PL_op->op_flags & OPf_MOD))
248 {
249 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
c9d5ac95
GS		 250 if (!sv
251 && (!is_gv_magical(sym,len,0)
252 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
253 {
35cd451c 254 RETSETUNDEF;
c9d5ac95 255 }
35cd451c
GS		 256 }
257 else {
258 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 259 DIE(aTHX_ PL_no_symref, sym, "a symbol");
35cd451c
GS		 260 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
261 }
93a17b20 262 }
79072805 263 }
533c011a
NIS		 264 if (PL_op->op_private & OPpLVAL_INTRO)
265 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW		 266 SETs(sv);
267 RETURN;
268}
269
79072805
LW		 270PP(pp_rv2sv)
271{
4e35701f 272 djSP; dTOPss;
79072805 273
ed6116ce 274 if (SvROK(sv)) {
a0d0e21e 275 wasref:
f5284f61
IZ		 276 tryAMAGICunDEREF(to_sv);
277
ed6116ce 278 sv = SvRV(sv);
79072805
LW		 279 switch (SvTYPE(sv)) {
280 case SVt_PVAV:
281 case SVt_PVHV:
282 case SVt_PVCV:
cea2e8a9 283 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW		 284 }
285 }
286 else {
f12c7020 287 GV *gv = (GV*)sv;
748a9306 288 char *sym;
c9d5ac95 289 STRLEN len;
748a9306 290
463ee0b2 291 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW		 292 if (SvGMAGICAL(sv)) {
293 mg_get(sv);
294 if (SvROK(sv))
295 goto wasref;
296 }
297 if (!SvOK(sv)) {
533c011a
NIS		 298 if (PL_op->op_flags & OPf_REF ||
299 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 300 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 301 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 302 report_uninit();
a0d0e21e
LW		 303 RETSETUNDEF;
304 }
c9d5ac95 305 sym = SvPV(sv, len);
35cd451c
GS		 306 if ((PL_op->op_flags & OPf_SPECIAL) &&
307 !(PL_op->op_flags & OPf_MOD))
308 {
309 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
c9d5ac95
GS		 310 if (!gv
311 && (!is_gv_magical(sym,len,0)
312 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
313 {
35cd451c 314 RETSETUNDEF;
c9d5ac95 315 }
35cd451c
GS		 316 }
317 else {
318 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 319 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
35cd451c
GS		 320 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
321 }
463ee0b2
LW		 322 }
323 sv = GvSV(gv);
a0d0e21e 324 }
533c011a
NIS		 325 if (PL_op->op_flags & OPf_MOD) {
326 if (PL_op->op_private & OPpLVAL_INTRO)
a0d0e21e 327 sv = save_scalar((GV*)TOPs);
533c011a
NIS		 328 else if (PL_op->op_private & OPpDEREF)
329 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 330 }
a0d0e21e 331 SETs(sv);
79072805
LW		 332 RETURN;
333}
334
335PP(pp_av2arylen)
336{
4e35701f 337 djSP;
79072805
LW		 338 AV *av = (AV*)TOPs;
339 SV *sv = AvARYLEN(av);
340 if (!sv) {
341 AvARYLEN(av) = sv = NEWSV(0,0);
342 sv_upgrade(sv, SVt_IV);
343 sv_magic(sv, (SV*)av, '#', Nullch, 0);
344 }
345 SETs(sv);
346 RETURN;
347}
348
a0d0e21e
LW		 349PP(pp_pos)
350{
4e35701f 351 djSP; dTARGET; dPOPss;
8ec5e241 352
84615ddc 353 if (PL_op->op_flags & OPf_MOD || LVRET) {
5f05dabc 354 if (SvTYPE(TARG) < SVt_PVLV) {
355 sv_upgrade(TARG, SVt_PVLV);
356 sv_magic(TARG, Nullsv, '.', Nullch, 0);
357 }
358
359 LvTYPE(TARG) = '.';
6ff81951
GS		 360 if (LvTARG(TARG) != sv) {
361 if (LvTARG(TARG))
362 SvREFCNT_dec(LvTARG(TARG));
363 LvTARG(TARG) = SvREFCNT_inc(sv);
364 }
a0d0e21e
LW		 365 PUSHs(TARG); /* no SvSETMAGIC */
366 RETURN;
367 }
368 else {
8ec5e241 369 MAGIC* mg;
a0d0e21e
LW		 370
371 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
372 mg = mg_find(sv, 'g');
565764a8 373 if (mg && mg->mg_len >= 0) {
a0ed51b3 374 I32 i = mg->mg_len;
7e2040f0 375 if (DO_UTF8(sv))
a0ed51b3
LW		 376 sv_pos_b2u(sv, &i);
377 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW		 378 RETURN;
379 }
380 }
381 RETPUSHUNDEF;
382 }
383}
384
79072805
LW		 385PP(pp_rv2cv)
386{
4e35701f 387 djSP;
79072805
LW		 388 GV *gv;
389 HV *stash;
8990e307 390
4633a7c4
LW		 391 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
392 /* (But not in defined().) */
533c011a 393 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS		 394 if (cv) {
395 if (CvCLONE(cv))
396 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
84615ddc
GS		 397 if ((PL_op->op_private & OPpLVAL_INTRO)) {
398 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
399 cv = GvCV(gv);
400 if (!CvLVALUE(cv))
401 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
402 }
07055b4c
CS		 403 }
404 else
3280af22 405 cv = (CV*)&PL_sv_undef;
79072805
LW		 406 SETs((SV*)cv);
407 RETURN;
408}
409
c07a80fd 410PP(pp_prototype)
411{
4e35701f 412 djSP;
c07a80fd 413 CV *cv;
414 HV *stash;
415 GV *gv;
416 SV *ret;
417
3280af22 418 ret = &PL_sv_undef;
b6c543e3
IZ		 419 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
420 char *s = SvPVX(TOPs);
421 if (strnEQ(s, "CORE::", 6)) {
422 int code;
423
424 code = keyword(s + 6, SvCUR(TOPs) - 6);
425 if (code < 0) { /* Overridable. */
426#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
427 int i = 0, n = 0, seen_question = 0;
428 I32 oa;
429 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
430
431 while (i < MAXO) { /* The slow way. */
22c35a8c
GS		 432 if (strEQ(s + 6, PL_op_name[i])
433 || strEQ(s + 6, PL_op_desc[i]))
434 {
b6c543e3 435 goto found;
22c35a8c 436 }
b6c543e3
IZ		 437 i++;
438 }
439 goto nonesuch; /* Should not happen... */
440 found:
22c35a8c 441 oa = PL_opargs[i] >> OASHIFT;
b6c543e3
IZ		 442 while (oa) {
443 if (oa & OA_OPTIONAL) {
444 seen_question = 1;
445 str[n++] = ';';
ef54e1a4 446 }
1c1fc3ea 447 else if (n && str[0] == ';' && seen_question)
b6c543e3
IZ		 448 goto set; /* XXXX system, exec */
449 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
450 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
451 str[n++] = '\\';
452 }
453 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
454 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
455 oa = oa >> 4;
456 }
457 str[n++] = '\0';
79cb57f6 458 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH		 459 }
460 else if (code) /* Non-Overridable */
b6c543e3
IZ		 461 goto set;
462 else { /* None such */
463 nonesuch:
d470f89e 464 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ		 465 }
466 }
467 }
c07a80fd 468 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 469 if (cv && SvPOK(cv))
79cb57f6 470 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
b6c543e3 471 set:
c07a80fd 472 SETs(ret);
473 RETURN;
474}
475
a0d0e21e
LW		 476PP(pp_anoncode)
477{
4e35701f 478 djSP;
533c011a 479 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
a5f75d66 480 if (CvCLONE(cv))
b355b4e0 481 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 482 EXTEND(SP,1);
748a9306 483 PUSHs((SV*)cv);
a0d0e21e
LW		 484 RETURN;
485}
486
487PP(pp_srefgen)
79072805 488{
4e35701f 489 djSP;
71be2cbc 490 *SP = refto(*SP);
79072805 491 RETURN;
8ec5e241 492}
a0d0e21e
LW		 493
494PP(pp_refgen)
495{
4e35701f 496 djSP; dMARK;
a0d0e21e 497 if (GIMME != G_ARRAY) {
5f0b1d4e
GS		 498 if (++MARK <= SP)
499 *MARK = *SP;
500 else
3280af22 501 *MARK = &PL_sv_undef;
5f0b1d4e
GS		 502 *MARK = refto(*MARK);
503 SP = MARK;
504 RETURN;
a0d0e21e 505 }
bbce6d69 506 EXTEND_MORTAL(SP - MARK);
71be2cbc 507 while (++MARK <= SP)
508 *MARK = refto(*MARK);
a0d0e21e 509 RETURN;
79072805
LW		 510}
511
76e3520e 512STATIC SV*
cea2e8a9 513S_refto(pTHX_ SV *sv)
71be2cbc 514{
515 SV* rv;
516
517 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
518 if (LvTARGLEN(sv))
68dc0745 519 vivify_defelem(sv);
520 if (!(sv = LvTARG(sv)))
3280af22 521 sv = &PL_sv_undef;
0dd88869 522 else
a6c40364 523 (void)SvREFCNT_inc(sv);
71be2cbc 524 }
d8b46c1b
GS		 525 else if (SvTYPE(sv) == SVt_PVAV) {
526 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
527 av_reify((AV*)sv);
528 SvTEMP_off(sv);
529 (void)SvREFCNT_inc(sv);
530 }
71be2cbc 531 else if (SvPADTMP(sv))
532 sv = newSVsv(sv);
533 else {
534 SvTEMP_off(sv);
535 (void)SvREFCNT_inc(sv);
536 }
537 rv = sv_newmortal();
538 sv_upgrade(rv, SVt_RV);
539 SvRV(rv) = sv;
540 SvROK_on(rv);
541 return rv;
542}
543
79072805
LW		 544PP(pp_ref)
545{
4e35701f 546 djSP; dTARGET;
463ee0b2 547 SV *sv;
79072805
LW		 548 char *pv;
549
a0d0e21e 550 sv = POPs;
f12c7020 551
552 if (sv && SvGMAGICAL(sv))
8ec5e241 553 mg_get(sv);
f12c7020 554
a0d0e21e 555 if (!sv || !SvROK(sv))
4633a7c4 556 RETPUSHNO;
79072805 557
ed6116ce 558 sv = SvRV(sv);
a0d0e21e 559 pv = sv_reftype(sv,TRUE);
463ee0b2 560 PUSHp(pv, strlen(pv));
79072805
LW		 561 RETURN;
562}
563
564PP(pp_bless)
565{
4e35701f 566 djSP;
463ee0b2 567 HV *stash;
79072805 568
463ee0b2 569 if (MAXARG == 1)
11faa288 570 stash = CopSTASH(PL_curcop);
7b8d334a
GS		 571 else {
572 SV *ssv = POPs;
573 STRLEN len;
574 char *ptr = SvPV(ssv,len);
e476b1b5
GS		 575 if (ckWARN(WARN_MISC) && len == 0)
576 Perl_warner(aTHX_ WARN_MISC,
599cee73 577 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS		 578 stash = gv_stashpvn(ptr, len, TRUE);
579 }
a0d0e21e 580
5d3fdfeb 581 (void)sv_bless(TOPs, stash);
79072805
LW		 582 RETURN;
583}
584
fb73857a 585PP(pp_gelem)
586{
587 GV *gv;
588 SV *sv;
76e3520e 589 SV *tmpRef;
fb73857a 590 char *elem;
4e35701f 591 djSP;
2d8e6c8d
GS		 592 STRLEN n_a;
593
fb73857a 594 sv = POPs;
2d8e6c8d 595 elem = SvPV(sv, n_a);
fb73857a 596 gv = (GV*)POPs;
76e3520e 597 tmpRef = Nullsv;
fb73857a 598 sv = Nullsv;
599 switch (elem ? *elem : '\0')
600 {
601 case 'A':
602 if (strEQ(elem, "ARRAY"))
76e3520e 603 tmpRef = (SV*)GvAV(gv);
fb73857a 604 break;
605 case 'C':
606 if (strEQ(elem, "CODE"))
76e3520e 607 tmpRef = (SV*)GvCVu(gv);
fb73857a 608 break;
609 case 'F':
610 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 611 tmpRef = (SV*)GvIOp(gv);
fb73857a 612 break;
613 case 'G':
614 if (strEQ(elem, "GLOB"))
76e3520e 615 tmpRef = (SV*)gv;
fb73857a 616 break;
617 case 'H':
618 if (strEQ(elem, "HASH"))
76e3520e 619 tmpRef = (SV*)GvHV(gv);
fb73857a 620 break;
621 case 'I':
622 if (strEQ(elem, "IO"))
76e3520e 623 tmpRef = (SV*)GvIOp(gv);
fb73857a 624 break;
625 case 'N':
626 if (strEQ(elem, "NAME"))
79cb57f6 627 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a 628 break;
629 case 'P':
630 if (strEQ(elem, "PACKAGE"))
631 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
632 break;
633 case 'S':
634 if (strEQ(elem, "SCALAR"))
76e3520e 635 tmpRef = GvSV(gv);
fb73857a 636 break;
637 }
76e3520e
GS		 638 if (tmpRef)
639 sv = newRV(tmpRef);
fb73857a 640 if (sv)
641 sv_2mortal(sv);
642 else
3280af22 643 sv = &PL_sv_undef;
fb73857a 644 XPUSHs(sv);
645 RETURN;
646}
647
a0d0e21e 648/* Pattern matching */
79072805 649
a0d0e21e 650PP(pp_study)
79072805 651{
4e35701f 652 djSP; dPOPss;
a0d0e21e
LW		 653 register unsigned char *s;
654 register I32 pos;
655 register I32 ch;
656 register I32 *sfirst;
657 register I32 *snext;
a0d0e21e
LW		 658 STRLEN len;
659
3280af22 660 if (sv == PL_lastscream) {
1e422769 661 if (SvSCREAM(sv))
662 RETPUSHYES;
663 }
c07a80fd 664 else {
3280af22
NIS		 665 if (PL_lastscream) {
666 SvSCREAM_off(PL_lastscream);
667 SvREFCNT_dec(PL_lastscream);
c07a80fd 668 }
3280af22 669 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 670 }
1e422769 671
672 s = (unsigned char*)(SvPV(sv, len));
673 pos = len;
674 if (pos <= 0)
675 RETPUSHNO;
3280af22
NIS		 676 if (pos > PL_maxscream) {
677 if (PL_maxscream < 0) {
678 PL_maxscream = pos + 80;
679 New(301, PL_screamfirst, 256, I32);
680 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW		 681 }
682 else {
3280af22
NIS		 683 PL_maxscream = pos + pos / 4;
684 Renew(PL_screamnext, PL_maxscream, I32);
79072805 685 }
79072805 686 }
a0d0e21e 687
3280af22
NIS		 688 sfirst = PL_screamfirst;
689 snext = PL_screamnext;
a0d0e21e
LW		 690
691 if (!sfirst || !snext)
cea2e8a9 692 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW		 693
694 for (ch = 256; ch; --ch)
695 *sfirst++ = -1;
696 sfirst -= 256;
697
698 while (--pos >= 0) {
699 ch = s[pos];
700 if (sfirst[ch] >= 0)
701 snext[pos] = sfirst[ch] - pos;
702 else
703 snext[pos] = -pos;
704 sfirst[ch] = pos;
79072805
LW		 705 }
706
c07a80fd 707 SvSCREAM_on(sv);
464e2e8a 708 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
1e422769 709 RETPUSHYES;
79072805
LW		 710}
711
a0d0e21e 712PP(pp_trans)
79072805 713{
4e35701f 714 djSP; dTARG;
a0d0e21e
LW		 715 SV *sv;
716
533c011a 717 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 718 sv = POPs;
79072805 719 else {
54b9620d 720 sv = DEFSV;
a0d0e21e 721 EXTEND(SP,1);
79072805 722 }
adbc6bb1 723 TARG = sv_newmortal();
4757a243 724 PUSHi(do_trans(sv));
a0d0e21e 725 RETURN;
79072805
LW		 726}
727
a0d0e21e 728/* Lvalue operators. */
79072805 729
a0d0e21e
LW		 730PP(pp_schop)
731{
4e35701f 732 djSP; dTARGET;
a0d0e21e
LW		 733 do_chop(TARG, TOPs);
734 SETTARG;
735 RETURN;
79072805
LW		 736}
737
a0d0e21e 738PP(pp_chop)
79072805 739{
4e35701f 740 djSP; dMARK; dTARGET;
a0d0e21e
LW		 741 while (SP > MARK)
742 do_chop(TARG, POPs);
743 PUSHTARG;
744 RETURN;
79072805
LW		 745}
746
a0d0e21e 747PP(pp_schomp)
79072805 748{
4e35701f 749 djSP; dTARGET;
a0d0e21e
LW		 750 SETi(do_chomp(TOPs));
751 RETURN;
79072805
LW		 752}
753
a0d0e21e 754PP(pp_chomp)
79072805 755{
4e35701f 756 djSP; dMARK; dTARGET;
a0d0e21e 757 register I32 count = 0;
8ec5e241 758
a0d0e21e
LW		 759 while (SP > MARK)
760 count += do_chomp(POPs);
761 PUSHi(count);
762 RETURN;
79072805
LW		 763}
764
a0d0e21e 765PP(pp_defined)
463ee0b2 766{
4e35701f 767 djSP;
a0d0e21e
LW		 768 register SV* sv;
769
770 sv = POPs;
771 if (!sv || !SvANY(sv))
772 RETPUSHNO;
773 switch (SvTYPE(sv)) {
774 case SVt_PVAV:
6051dbdb 775 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW		 776 RETPUSHYES;
777 break;
778 case SVt_PVHV:
6051dbdb 779 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW		 780 RETPUSHYES;
781 break;
782 case SVt_PVCV:
783 if (CvROOT(sv) || CvXSUB(sv))
784 RETPUSHYES;
785 break;
786 default:
787 if (SvGMAGICAL(sv))
788 mg_get(sv);
789 if (SvOK(sv))
790 RETPUSHYES;
791 }
792 RETPUSHNO;
463ee0b2
LW		 793}
794
a0d0e21e
LW		 795PP(pp_undef)
796{
4e35701f 797 djSP;
a0d0e21e
LW		 798 SV *sv;
799
533c011a 800 if (!PL_op->op_private) {
774d564b 801 EXTEND(SP, 1);
a0d0e21e 802 RETPUSHUNDEF;
774d564b 803 }
79072805 804
a0d0e21e
LW		 805 sv = POPs;
806 if (!sv)
807 RETPUSHUNDEF;
85e6fe83 808
6fc92669
GS		 809 if (SvTHINKFIRST(sv))
810 sv_force_normal(sv);
85e6fe83 811
a0d0e21e
LW		 812 switch (SvTYPE(sv)) {
813 case SVt_NULL:
814 break;
815 case SVt_PVAV:
816 av_undef((AV*)sv);
817 break;
818 case SVt_PVHV:
819 hv_undef((HV*)sv);
820 break;
821 case SVt_PVCV:
e476b1b5
GS		 822 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
823 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
54310121 824 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c 825 /* FALL THROUGH */
826 case SVt_PVFM:
6fc92669
GS		 827 {
828 /* let user-undef'd sub keep its identity */
4d40626c 829 GV* gv = CvGV((CV*)sv);
6fc92669
GS		 830 cv_undef((CV*)sv);
831 CvGV((CV*)sv) = gv;
832 }
a0d0e21e 833 break;
8e07c86e 834 case SVt_PVGV:
44a8e56a 835 if (SvFAKE(sv))
3280af22 836 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS		 837 else {
838 GP *gp;
839 gp_free((GV*)sv);
840 Newz(602, gp, 1, GP);
841 GvGP(sv) = gp_ref(gp);
842 GvSV(sv) = NEWSV(72,0);
57843af0 843 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS		 844 GvEGV(sv) = (GV*)sv;
845 GvMULTI_on(sv);
846 }
44a8e56a 847 break;
a0d0e21e 848 default:
1e422769 849 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW		 850 (void)SvOOK_off(sv);
851 Safefree(SvPVX(sv));
852 SvPV_set(sv, Nullch);
853 SvLEN_set(sv, 0);
a0d0e21e 854 }
4633a7c4
LW		 855 (void)SvOK_off(sv);
856 SvSETMAGIC(sv);
79072805 857 }
a0d0e21e
LW		 858
859 RETPUSHUNDEF;
79072805
LW		 860}
861
a0d0e21e 862PP(pp_predec)
79072805 863{
4e35701f 864 djSP;
68dc0745 865 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 866 DIE(aTHX_ PL_no_modify);
25da4f38 867 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 868 SvIVX(TOPs) != IV_MIN)
869 {
748a9306 870 --SvIVX(TOPs);
55497cff 871 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 872 }
873 else
874 sv_dec(TOPs);
a0d0e21e
LW		 875 SvSETMAGIC(TOPs);
876 return NORMAL;
877}
79072805 878
a0d0e21e
LW		 879PP(pp_postinc)
880{
4e35701f 881 djSP; dTARGET;
68dc0745 882 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 883 DIE(aTHX_ PL_no_modify);
a0d0e21e 884 sv_setsv(TARG, TOPs);
25da4f38 885 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 886 SvIVX(TOPs) != IV_MAX)
887 {
748a9306 888 ++SvIVX(TOPs);
55497cff 889 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 890 }
891 else
892 sv_inc(TOPs);
a0d0e21e
LW		 893 SvSETMAGIC(TOPs);
894 if (!SvOK(TARG))
895 sv_setiv(TARG, 0);
896 SETs(TARG);
897 return NORMAL;
898}
79072805 899
a0d0e21e
LW		 900PP(pp_postdec)
901{
4e35701f 902 djSP; dTARGET;
43192e07 903 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 904 DIE(aTHX_ PL_no_modify);
a0d0e21e 905 sv_setsv(TARG, TOPs);
25da4f38 906 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff 907 SvIVX(TOPs) != IV_MIN)
908 {
748a9306 909 --SvIVX(TOPs);
55497cff 910 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW		 911 }
912 else
913 sv_dec(TOPs);
a0d0e21e
LW		 914 SvSETMAGIC(TOPs);
915 SETs(TARG);
916 return NORMAL;
917}
79072805 918
a0d0e21e
LW		 919/* Ordinary operators. */
920
921PP(pp_pow)
922{
8ec5e241 923 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
a0d0e21e
LW		 924 {
925 dPOPTOPnnrl;
73b309ea 926 SETn( Perl_pow( left, right) );
a0d0e21e 927 RETURN;
93a17b20 928 }
a0d0e21e
LW		 929}
930
931PP(pp_multiply)
932{
8ec5e241 933 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 934 {
935 dPOPTOPnnrl;
936 SETn( left * right );
937 RETURN;
79072805 938 }
a0d0e21e
LW		 939}
940
941PP(pp_divide)
942{
8ec5e241 943 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e 944 {
77676ba1 945 dPOPPOPnnrl;
65202027 946 NV value;
7a4c00b4 947 if (right == 0.0)
cea2e8a9 948 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 949#ifdef SLOPPYDIVIDE
950 /* insure that 20./5. == 4. */
951 {
7a4c00b4 952 IV k;
65202027
DS		 953 if ((NV)I_V(left) == left &&
954 (NV)I_V(right) == right &&
7a4c00b4 955 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
a0d0e21e 956 value = k;
ef54e1a4
JH		 957 }
958 else {
7a4c00b4 959 value = left / right;
79072805 960 }
a0d0e21e
LW		 961 }
962#else
7a4c00b4 963 value = left / right;
a0d0e21e
LW		 964#endif
965 PUSHn( value );
966 RETURN;
79072805 967 }
a0d0e21e
LW		 968}
969
970PP(pp_modulo)
971{
76e3520e 972 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 973 {
787eafbd
IZ		 974 UV left;
975 UV right;
976 bool left_neg;
977 bool right_neg;
978 bool use_double = 0;
65202027
DS		 979 NV dright;
980 NV dleft;
787eafbd 981
d658dc55 982 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
787eafbd
IZ		 983 IV i = SvIVX(POPs);
984 right = (right_neg = (i < 0)) ? -i : i;
985 }
986 else {
987 dright = POPn;
988 use_double = 1;
989 right_neg = dright < 0;
990 if (right_neg)
991 dright = -dright;
992 }
a0d0e21e 993
d658dc55 994 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
787eafbd
IZ		 995 IV i = SvIVX(POPs);
996 left = (left_neg = (i < 0)) ? -i : i;
997 }
998 else {
999 dleft = POPn;
1000 if (!use_double) {
a1bd196e
GS		 1001 use_double = 1;
1002 dright = right;
787eafbd
IZ		 1003 }
1004 left_neg = dleft < 0;
1005 if (left_neg)
1006 dleft = -dleft;
1007 }
68dc0745 1008
787eafbd 1009 if (use_double) {
65202027 1010 NV dans;
787eafbd
IZ		 1011
1012#if 1
787eafbd
IZ		 1013/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1014# if CASTFLAGS & 2
1015# define CAST_D2UV(d) U_V(d)
1016# else
1017# define CAST_D2UV(d) ((UV)(d))
1018# endif
a1bd196e
GS		 1019 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1020 * or, in other words, precision of UV more than of NV.
1021 * But in fact the approach below turned out to be an
1022 * optimization - floor() may be slow */
787eafbd
IZ		 1023 if (dright <= UV_MAX && dleft <= UV_MAX) {
1024 right = CAST_D2UV(dright);
1025 left = CAST_D2UV(dleft);
1026 goto do_uv;
1027 }
1028#endif
1029
1030 /* Backward-compatibility clause: */
73b309ea
JH		 1031 dright = Perl_floor(dright + 0.5);
1032 dleft = Perl_floor(dleft + 0.5);
787eafbd
IZ		 1033
1034 if (!dright)
cea2e8a9 1035 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1036
65202027 1037 dans = Perl_fmod(dleft, dright);
787eafbd
IZ		 1038 if ((left_neg != right_neg) && dans)
1039 dans = dright - dans;
1040 if (right_neg)
1041 dans = -dans;
1042 sv_setnv(TARG, dans);
1043 }
1044 else {
1045 UV ans;
1046
1047 do_uv:
1048 if (!right)
cea2e8a9 1049 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ		 1050
1051 ans = left % right;
1052 if ((left_neg != right_neg) && ans)
1053 ans = right - ans;
1054 if (right_neg) {
1055 /* XXX may warn: unary minus operator applied to unsigned type */
1056 /* could change -foo to be (~foo)+1 instead */
1057 if (ans <= ~((UV)IV_MAX)+1)
1058 sv_setiv(TARG, ~ans+1);
1059 else
65202027 1060 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ		 1061 }
1062 else
1063 sv_setuv(TARG, ans);
1064 }
1065 PUSHTARG;
1066 RETURN;
79072805 1067 }
a0d0e21e 1068}
79072805 1069
a0d0e21e
LW		 1070PP(pp_repeat)
1071{
4e35701f 1072 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1073 {
e2439105 1074 register IV count = POPi;
533c011a 1075 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW		 1076 dMARK;
1077 I32 items = SP - MARK;
1078 I32 max;
79072805 1079
a0d0e21e
LW		 1080 max = items * count;
1081 MEXTEND(MARK, max);
1082 if (count > 1) {
1083 while (SP > MARK) {
1084 if (*SP)
1085 SvTEMP_off((*SP));
1086 SP--;
79072805 1087 }
a0d0e21e
LW		 1088 MARK++;
1089 repeatcpy((char*)(MARK + items), (char*)MARK,
1090 items * sizeof(SV*), count - 1);
1091 SP += max;
79072805 1092 }
a0d0e21e
LW		 1093 else if (count <= 0)
1094 SP -= items;
79072805 1095 }
a0d0e21e 1096 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1097 SV *tmpstr = POPs;
a0d0e21e 1098 STRLEN len;
a8ae6a0b 1099 bool isutf;
a0d0e21e 1100
a0d0e21e
LW		 1101 SvSetSV(TARG, tmpstr);
1102 SvPV_force(TARG, len);
a8ae6a0b 1103 isutf = DO_UTF8(TARG);
8ebc5c01 1104 if (count != 1) {
1105 if (count < 1)
1106 SvCUR_set(TARG, 0);
1107 else {
1108 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1109 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1110 SvCUR(TARG) *= count;
7a4c00b4 1111 }
a0d0e21e 1112 *SvEND(TARG) = '\0';
a0d0e21e 1113 }
dfcb284a
GS		 1114 if (isutf)
1115 (void)SvPOK_only_UTF8(TARG);
1116 else
1117 (void)SvPOK_only(TARG);
a0d0e21e 1118 PUSHTARG;
79072805 1119 }
a0d0e21e 1120 RETURN;
748a9306 1121 }
a0d0e21e 1122}
79072805 1123
a0d0e21e
LW		 1124PP(pp_subtract)
1125{
8ec5e241 1126 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 1127 {
7a4c00b4 1128 dPOPTOPnnrl_ul;
a0d0e21e
LW		 1129 SETn( left - right );
1130 RETURN;
79072805 1131 }
a0d0e21e 1132}
79072805 1133
a0d0e21e
LW		 1134PP(pp_left_shift)
1135{
8ec5e241 1136 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1137 {
972b05a9 1138 IV shift = POPi;
d0ba1bd2 1139 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1140 IV i = TOPi;
1141 SETi(i << shift);
d0ba1bd2
JH		 1142 }
1143 else {
972b05a9
JH		 1144 UV u = TOPu;
1145 SETu(u << shift);
d0ba1bd2 1146 }
55497cff 1147 RETURN;
79072805 1148 }
a0d0e21e 1149}
79072805 1150
a0d0e21e
LW		 1151PP(pp_right_shift)
1152{
8ec5e241 1153 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1154 {
972b05a9 1155 IV shift = POPi;
d0ba1bd2 1156 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1157 IV i = TOPi;
1158 SETi(i >> shift);
d0ba1bd2
JH		 1159 }
1160 else {
972b05a9
JH		 1161 UV u = TOPu;
1162 SETu(u >> shift);
d0ba1bd2 1163 }
a0d0e21e 1164 RETURN;
93a17b20 1165 }
79072805
LW		 1166}
1167
a0d0e21e 1168PP(pp_lt)
79072805 1169{
8ec5e241 1170 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 1171 {
1172 dPOPnv;
54310121 1173 SETs(boolSV(TOPn < value));
a0d0e21e 1174 RETURN;
79072805 1175 }
a0d0e21e 1176}
79072805 1177
a0d0e21e
LW		 1178PP(pp_gt)
1179{
8ec5e241 1180 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 1181 {
1182 dPOPnv;
54310121 1183 SETs(boolSV(TOPn > value));
a0d0e21e 1184 RETURN;
79072805 1185 }
a0d0e21e
LW		 1186}
1187
1188PP(pp_le)
1189{
8ec5e241 1190 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 1191 {
1192 dPOPnv;
54310121 1193 SETs(boolSV(TOPn <= value));
a0d0e21e 1194 RETURN;
79072805 1195 }
a0d0e21e
LW		 1196}
1197
1198PP(pp_ge)
1199{
8ec5e241 1200 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 1201 {
1202 dPOPnv;
54310121 1203 SETs(boolSV(TOPn >= value));
a0d0e21e 1204 RETURN;
79072805 1205 }
a0d0e21e 1206}
79072805 1207
a0d0e21e
LW		 1208PP(pp_ne)
1209{
8ec5e241 1210 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 1211 {
1212 dPOPnv;
54310121 1213 SETs(boolSV(TOPn != value));
a0d0e21e
LW		 1214 RETURN;
1215 }
79072805
LW		 1216}
1217
a0d0e21e 1218PP(pp_ncmp)
79072805 1219{
8ec5e241 1220 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 1221 {
1222 dPOPTOPnnrl;
1223 I32 value;
79072805 1224
a3540c92 1225#ifdef Perl_isnan
1ad04cfd
JH		 1226 if (Perl_isnan(left) || Perl_isnan(right)) {
1227 SETs(&PL_sv_undef);
1228 RETURN;
1229 }
1230 value = (left > right) - (left < right);
1231#else
ff0cee69 1232 if (left == right)
a0d0e21e 1233 value = 0;
a0d0e21e
LW		 1234 else if (left < right)
1235 value = -1;
44a8e56a 1236 else if (left > right)
1237 value = 1;
1238 else {
3280af22 1239 SETs(&PL_sv_undef);
44a8e56a 1240 RETURN;
1241 }
1ad04cfd 1242#endif
a0d0e21e
LW		 1243 SETi(value);
1244 RETURN;
79072805 1245 }
a0d0e21e 1246}
79072805 1247
a0d0e21e
LW		 1248PP(pp_slt)
1249{
8ec5e241 1250 djSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW		 1251 {
1252 dPOPTOPssrl;
533c011a 1253 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1254 ? sv_cmp_locale(left, right)
1255 : sv_cmp(left, right));
54310121 1256 SETs(boolSV(cmp < 0));
a0d0e21e
LW		 1257 RETURN;
1258 }
79072805
LW		 1259}
1260
a0d0e21e 1261PP(pp_sgt)
79072805 1262{
8ec5e241 1263 djSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW		 1264 {
1265 dPOPTOPssrl;
533c011a 1266 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1267 ? sv_cmp_locale(left, right)
1268 : sv_cmp(left, right));
54310121 1269 SETs(boolSV(cmp > 0));
a0d0e21e
LW		 1270 RETURN;
1271 }
1272}
79072805 1273
a0d0e21e
LW		 1274PP(pp_sle)
1275{
8ec5e241 1276 djSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW		 1277 {
1278 dPOPTOPssrl;
533c011a 1279 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1280 ? sv_cmp_locale(left, right)
1281 : sv_cmp(left, right));
54310121 1282 SETs(boolSV(cmp <= 0));
a0d0e21e 1283 RETURN;
79072805 1284 }
79072805
LW		 1285}
1286
a0d0e21e
LW		 1287PP(pp_sge)
1288{
8ec5e241 1289 djSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW		 1290 {
1291 dPOPTOPssrl;
533c011a 1292 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1293 ? sv_cmp_locale(left, right)
1294 : sv_cmp(left, right));
54310121 1295 SETs(boolSV(cmp >= 0));
a0d0e21e
LW		 1296 RETURN;
1297 }
1298}
79072805 1299
36477c24 1300PP(pp_seq)
1301{
8ec5e241 1302 djSP; tryAMAGICbinSET(seq,0);
36477c24 1303 {
1304 dPOPTOPssrl;
54310121 1305 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW		 1306 RETURN;
1307 }
1308}
79072805 1309
a0d0e21e 1310PP(pp_sne)
79072805 1311{
8ec5e241 1312 djSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW		 1313 {
1314 dPOPTOPssrl;
54310121 1315 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 1316 RETURN;
463ee0b2 1317 }
79072805
LW		 1318}
1319
a0d0e21e 1320PP(pp_scmp)
79072805 1321{
4e35701f 1322 djSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW		 1323 {
1324 dPOPTOPssrl;
533c011a 1325 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69 1326 ? sv_cmp_locale(left, right)
1327 : sv_cmp(left, right));
1328 SETi( cmp );
a0d0e21e
LW		 1329 RETURN;
1330 }
1331}
79072805 1332
55497cff 1333PP(pp_bit_and)
1334{
8ec5e241 1335 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW		 1336 {
1337 dPOPTOPssrl;
4633a7c4 1338 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 1339 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1340 IV i = SvIV(left) & SvIV(right);
1341 SETi(i);
d0ba1bd2
JH		 1342 }
1343 else {
972b05a9
JH		 1344 UV u = SvUV(left) & SvUV(right);
1345 SETu(u);
d0ba1bd2 1346 }
a0d0e21e
LW		 1347 }
1348 else {
533c011a 1349 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 1350 SETTARG;
1351 }
1352 RETURN;
1353 }
1354}
79072805 1355
a0d0e21e
LW		 1356PP(pp_bit_xor)
1357{
8ec5e241 1358 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW		 1359 {
1360 dPOPTOPssrl;
4633a7c4 1361 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 1362 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1363 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1364 SETi(i);
d0ba1bd2
JH		 1365 }
1366 else {
972b05a9
JH		 1367 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1368 SETu(u);
d0ba1bd2 1369 }
a0d0e21e
LW		 1370 }
1371 else {
533c011a 1372 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 1373 SETTARG;
1374 }
1375 RETURN;
1376 }
1377}
79072805 1378
a0d0e21e
LW		 1379PP(pp_bit_or)
1380{
8ec5e241 1381 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW		 1382 {
1383 dPOPTOPssrl;
4633a7c4 1384 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 1385 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1386 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1387 SETi(i);
d0ba1bd2
JH		 1388 }
1389 else {
972b05a9
JH		 1390 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1391 SETu(u);
d0ba1bd2 1392 }
a0d0e21e
LW		 1393 }
1394 else {
533c011a 1395 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW		 1396 SETTARG;
1397 }
1398 RETURN;
79072805 1399 }
a0d0e21e 1400}
79072805 1401
a0d0e21e
LW		 1402PP(pp_negate)
1403{
4e35701f 1404 djSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW		 1405 {
1406 dTOPss;
4633a7c4
LW		 1407 if (SvGMAGICAL(sv))
1408 mg_get(sv);
9b0e499b
GS		 1409 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
1410 if (SvIsUV(sv)) {
1411 if (SvIVX(sv) == IV_MIN) {
1412 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1413 RETURN;
1414 }
1415 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 1416 SETi(-SvIVX(sv));
9b0e499b
GS		 1417 RETURN;
1418 }
1419 }
1420 else if (SvIVX(sv) != IV_MIN) {
1421 SETi(-SvIVX(sv));
1422 RETURN;
1423 }
1424 }
1425 if (SvNIOKp(sv))
a0d0e21e 1426 SETn(-SvNV(sv));
4633a7c4 1427 else if (SvPOKp(sv)) {
a0d0e21e
LW		 1428 STRLEN len;
1429 char *s = SvPV(sv, len);
bbce6d69 1430 if (isIDFIRST(*s)) {
a0d0e21e
LW		 1431 sv_setpvn(TARG, "-", 1);
1432 sv_catsv(TARG, sv);
79072805 1433 }
a0d0e21e
LW		 1434 else if (*s == '+' || *s == '-') {
1435 sv_setsv(TARG, sv);
1436 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 1437 }
f3efa21a 1438 else if (DO_UTF8(sv) && UTF8_IS_START(*s) && isIDFIRST_utf8((U8*)s)) {
834a4ddd
LW		 1439 sv_setpvn(TARG, "-", 1);
1440 sv_catsv(TARG, sv);
1441 }
79072805 1442 else
a0d0e21e
LW		 1443 sv_setnv(TARG, -SvNV(sv));
1444 SETTARG;
79072805 1445 }
4633a7c4
LW		 1446 else
1447 SETn(-SvNV(sv));
79072805 1448 }
a0d0e21e 1449 RETURN;
79072805
LW		 1450}
1451
a0d0e21e 1452PP(pp_not)
79072805 1453{
4e35701f 1454 djSP; tryAMAGICunSET(not);
3280af22 1455 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 1456 return NORMAL;
79072805
LW		 1457}
1458
a0d0e21e 1459PP(pp_complement)
79072805 1460{
8ec5e241 1461 djSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW		 1462 {
1463 dTOPss;
4633a7c4 1464 if (SvNIOKp(sv)) {
d0ba1bd2 1465 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH		 1466 IV i = ~SvIV(sv);
1467 SETi(i);
d0ba1bd2
JH		 1468 }
1469 else {
972b05a9
JH		 1470 UV u = ~SvUV(sv);
1471 SETu(u);
d0ba1bd2 1472 }
a0d0e21e
LW		 1473 }
1474 else {
e2439105 1475 register U8 *tmps;
55497cff 1476 register I32 anum;
a0d0e21e
LW		 1477 STRLEN len;
1478
1479 SvSetSV(TARG, sv);
e2439105 1480 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 1481 anum = len;
e2439105 1482 if (SvUTF8(TARG)) {
bb2c2f1d 1483 /* Calculate exact length, let's not estimate. */
e2439105
GS		 1484 STRLEN targlen = 0;
1485 U8 *result;
1486 U8 *send;
a4bf32d5 1487 STRLEN l;
bb2c2f1d
GS		 1488 UV nchar = 0;
1489 UV nwide = 0;
e2439105
GS		 1490
1491 send = tmps + len;
1492 while (tmps < send) {
bb2c2f1d 1493 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
e2439105 1494 tmps += UTF8SKIP(tmps);
a4bf32d5 1495 targlen += UNISKIP(~c);
bb2c2f1d
GS		 1496 nchar++;
1497 if (c > 0xff)
1498 nwide++;
e2439105
GS		 1499 }
1500
1501 /* Now rewind strings and write them. */
1502 tmps -= len;
bb2c2f1d
GS		 1503
1504 if (nwide) {
1505 Newz(0, result, targlen + 1, U8);
1506 while (tmps < send) {
1507 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1508 tmps += UTF8SKIP(tmps);
1509 result = uv_to_utf8(result, ~c);
1510 }
1511 *result = '\0';
1512 result -= targlen;
1513 sv_setpvn(TARG, (char*)result, targlen);
1514 SvUTF8_on(TARG);
1515 }
1516 else {
1517 Newz(0, result, nchar + 1, U8);
1518 while (tmps < send) {
1519 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
1520 tmps += UTF8SKIP(tmps);
1521 *result++ = ~c;
1522 }
1523 *result = '\0';
1524 result -= nchar;
1525 sv_setpvn(TARG, (char*)result, nchar);
e2439105 1526 }
e2439105
GS		 1527 Safefree(result);
1528 SETs(TARG);
1529 RETURN;
1530 }
a0d0e21e 1531#ifdef LIBERAL
e2439105
GS		 1532 {
1533 register long *tmpl;
1534 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1535 *tmps = ~*tmps;
1536 tmpl = (long*)tmps;
1537 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1538 *tmpl = ~*tmpl;
1539 tmps = (U8*)tmpl;
1540 }
a0d0e21e
LW		 1541#endif
1542 for ( ; anum > 0; anum--, tmps++)
1543 *tmps = ~*tmps;
1544
1545 SETs(TARG);
1546 }
1547 RETURN;
1548 }
79072805
LW		 1549}
1550
a0d0e21e
LW		 1551/* integer versions of some of the above */
1552
a0d0e21e 1553PP(pp_i_multiply)
79072805 1554{
8ec5e241 1555 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW		 1556 {
1557 dPOPTOPiirl;
1558 SETi( left * right );
1559 RETURN;
1560 }
79072805
LW		 1561}
1562
a0d0e21e 1563PP(pp_i_divide)
79072805 1564{
8ec5e241 1565 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW		 1566 {
1567 dPOPiv;
1568 if (value == 0)
cea2e8a9 1569 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW		 1570 value = POPi / value;
1571 PUSHi( value );
1572 RETURN;
1573 }
79072805
LW		 1574}
1575
a0d0e21e 1576PP(pp_i_modulo)
79072805 1577{
76e3520e 1578 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
79072805 1579 {
a0d0e21e 1580 dPOPTOPiirl;
aa306039 1581 if (!right)
cea2e8a9 1582 DIE(aTHX_ "Illegal modulus zero");
a0d0e21e
LW		 1583 SETi( left % right );
1584 RETURN;
79072805 1585 }
79072805
LW		 1586}
1587
a0d0e21e 1588PP(pp_i_add)
79072805 1589{
8ec5e241 1590 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 1591 {
7f8989c3 1592 dPOPTOPiirl_ul;
a0d0e21e
LW		 1593 SETi( left + right );
1594 RETURN;
79072805 1595 }
79072805
LW		 1596}
1597
a0d0e21e 1598PP(pp_i_subtract)
79072805 1599{
8ec5e241 1600 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 1601 {
7f8989c3 1602 dPOPTOPiirl_ul;
a0d0e21e
LW		 1603 SETi( left - right );
1604 RETURN;
79072805 1605 }
79072805
LW		 1606}
1607
a0d0e21e 1608PP(pp_i_lt)
79072805 1609{
8ec5e241 1610 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW		 1611 {
1612 dPOPTOPiirl;
54310121 1613 SETs(boolSV(left < right));
a0d0e21e
LW		 1614 RETURN;
1615 }
79072805
LW		 1616}
1617
a0d0e21e 1618PP(pp_i_gt)
79072805 1619{
8ec5e241 1620 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW		 1621 {
1622 dPOPTOPiirl;
54310121 1623 SETs(boolSV(left > right));
a0d0e21e
LW		 1624 RETURN;
1625 }
79072805
LW		 1626}
1627
a0d0e21e 1628PP(pp_i_le)
79072805 1629{
8ec5e241 1630 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW		 1631 {
1632 dPOPTOPiirl;
54310121 1633 SETs(boolSV(left <= right));
a0d0e21e 1634 RETURN;
85e6fe83 1635 }
79072805
LW		 1636}
1637
a0d0e21e 1638PP(pp_i_ge)
79072805 1639{
8ec5e241 1640 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW		 1641 {
1642 dPOPTOPiirl;
54310121 1643 SETs(boolSV(left >= right));
a0d0e21e
LW		 1644 RETURN;
1645 }
79072805
LW		 1646}
1647
a0d0e21e 1648PP(pp_i_eq)
79072805 1649{
8ec5e241 1650 djSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW		 1651 {
1652 dPOPTOPiirl;
54310121 1653 SETs(boolSV(left == right));
a0d0e21e
LW		 1654 RETURN;
1655 }
79072805
LW		 1656}
1657
a0d0e21e 1658PP(pp_i_ne)
79072805 1659{
8ec5e241 1660 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW		 1661 {
1662 dPOPTOPiirl;
54310121 1663 SETs(boolSV(left != right));
a0d0e21e
LW		 1664 RETURN;
1665 }
79072805
LW		 1666}
1667
a0d0e21e 1668PP(pp_i_ncmp)
79072805 1669{
8ec5e241 1670 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW		 1671 {
1672 dPOPTOPiirl;
1673 I32 value;
79072805 1674
a0d0e21e 1675 if (left > right)
79072805 1676 value = 1;
a0d0e21e 1677 else if (left < right)
79072805 1678 value = -1;
a0d0e21e 1679 else
79072805 1680 value = 0;
a0d0e21e
LW		 1681 SETi(value);
1682 RETURN;
79072805 1683 }
85e6fe83
LW		 1684}
1685
1686PP(pp_i_negate)
1687{
4e35701f 1688 djSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW		 1689 SETi(-TOPi);
1690 RETURN;
1691}
1692
79072805
LW		 1693/* High falutin' math. */
1694
1695PP(pp_atan2)
1696{
8ec5e241 1697 djSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW		 1698 {
1699 dPOPTOPnnrl;
65202027 1700 SETn(Perl_atan2(left, right));
a0d0e21e
LW		 1701 RETURN;
1702 }
79072805
LW		 1703}
1704
1705PP(pp_sin)
1706{
4e35701f 1707 djSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 1708 {
65202027 1709 NV value;
a0d0e21e 1710 value = POPn;
65202027 1711 value = Perl_sin(value);
a0d0e21e
LW		 1712 XPUSHn(value);
1713 RETURN;
1714 }
79072805
LW		 1715}
1716
1717PP(pp_cos)
1718{
4e35701f 1719 djSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 1720 {
65202027 1721 NV value;
a0d0e21e 1722 value = POPn;
65202027 1723 value = Perl_cos(value);
a0d0e21e
LW		 1724 XPUSHn(value);
1725 RETURN;
1726 }
79072805
LW		 1727}
1728
56cb0a1c
AD		 1729/* Support Configure command-line overrides for rand() functions.
1730 After 5.005, perhaps we should replace this by Configure support
1731 for drand48(), random(), or rand(). For 5.005, though, maintain
1732 compatibility by calling rand() but allow the user to override it.
1733 See INSTALL for details. --Andy Dougherty 15 July 1998
1734*/
85ab1d1d
JH		 1735/* Now it's after 5.005, and Configure supports drand48() and random(),
1736 in addition to rand(). So the overrides should not be needed any more.
1737 --Jarkko Hietaniemi 27 September 1998
1738 */
1739
1740#ifndef HAS_DRAND48_PROTO
20ce7b12 1741extern double drand48 (void);
56cb0a1c
AD		 1742#endif
1743
79072805
LW		 1744PP(pp_rand)
1745{
4e35701f 1746 djSP; dTARGET;
65202027 1747 NV value;
79072805
LW		 1748 if (MAXARG < 1)
1749 value = 1.0;
1750 else
1751 value = POPn;
1752 if (value == 0.0)
1753 value = 1.0;
80252599 1754 if (!PL_srand_called) {
85ab1d1d 1755 (void)seedDrand01((Rand_seed_t)seed());
80252599 1756 PL_srand_called = TRUE;
93dc8474 1757 }
85ab1d1d 1758 value *= Drand01();
79072805
LW		 1759 XPUSHn(value);
1760 RETURN;
1761}
1762
1763PP(pp_srand)
1764{
4e35701f 1765 djSP;
93dc8474
CS		 1766 UV anum;
1767 if (MAXARG < 1)
1768 anum = seed();
79072805 1769 else
93dc8474 1770 anum = POPu;
85ab1d1d 1771 (void)seedDrand01((Rand_seed_t)anum);
80252599 1772 PL_srand_called = TRUE;
79072805
LW		 1773 EXTEND(SP, 1);
1774 RETPUSHYES;
1775}
1776
76e3520e 1777STATIC U32
cea2e8a9 1778S_seed(pTHX)
93dc8474 1779{
54310121 1780 /*
1781 * This is really just a quick hack which grabs various garbage
1782 * values. It really should be a real hash algorithm which
1783 * spreads the effect of every input bit onto every output bit,
85ab1d1d 1784 * if someone who knows about such things would bother to write it.
54310121 1785 * Might be a good idea to add that function to CORE as well.
85ab1d1d 1786 * No numbers below come from careful analysis or anything here,
54310121 1787 * except they are primes and SEED_C1 > 1E6 to get a full-width
1788 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1789 * probably be bigger too.
1790 */
1791#if RANDBITS > 16
1792# define SEED_C1 1000003
1793#define SEED_C4 73819
1794#else
1795# define SEED_C1 25747
1796#define SEED_C4 20639
1797#endif
1798#define SEED_C2 3
1799#define SEED_C3 269
1800#define SEED_C5 26107
1801
73c60299
RS		 1802#ifndef PERL_NO_DEV_RANDOM
1803 int fd;
1804#endif
93dc8474 1805 U32 u;
f12c7020 1806#ifdef VMS
1807# include <starlet.h>
43c92808
HF		 1808 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1809 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474 1810 unsigned int when[2];
73c60299
RS		 1811#else
1812# ifdef HAS_GETTIMEOFDAY
1813 struct timeval when;
1814# else
1815 Time_t when;
1816# endif
1817#endif
1818
1819/* This test is an escape hatch, this symbol isn't set by Configure. */
1820#ifndef PERL_NO_DEV_RANDOM
1821#ifndef PERL_RANDOM_DEVICE
1822 /* /dev/random isn't used by default because reads from it will block
1823 * if there isn't enough entropy available. You can compile with
1824 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1825 * is enough real entropy to fill the seed. */
1826# define PERL_RANDOM_DEVICE "/dev/urandom"
1827#endif
1828 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1829 if (fd != -1) {
1830 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1831 u = 0;
1832 PerlLIO_close(fd);
1833 if (u)
1834 return u;
1835 }
1836#endif
1837
1838#ifdef VMS
93dc8474 1839 _ckvmssts(sys$gettim(when));
54310121 1840 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 1841#else
5f05dabc 1842# ifdef HAS_GETTIMEOFDAY
93dc8474 1843 gettimeofday(&when,(struct timezone *) 0);
54310121 1844 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 1845# else
93dc8474 1846 (void)time(&when);
54310121 1847 u = (U32)SEED_C1 * when;
f12c7020 1848# endif
1849#endif
7766f137 1850 u += SEED_C3 * (U32)PerlProc_getpid();
56431972 1851 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
54310121 1852#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
56431972 1853 u += SEED_C5 * (U32)PTR2UV(&when);
f12c7020 1854#endif
93dc8474 1855 return u;
79072805
LW		 1856}
1857
1858PP(pp_exp)
1859{
4e35701f 1860 djSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 1861 {
65202027 1862 NV value;
a0d0e21e 1863 value = POPn;
65202027 1864 value = Perl_exp(value);
a0d0e21e
LW		 1865 XPUSHn(value);
1866 RETURN;
1867 }
79072805
LW		 1868}
1869
1870PP(pp_log)
1871{
4e35701f 1872 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e 1873 {
65202027 1874 NV value;
a0d0e21e 1875 value = POPn;
bbce6d69 1876 if (value <= 0.0) {
5e1047cb 1877 SET_NUMERIC_STANDARD();
cea2e8a9 1878 DIE(aTHX_ "Can't take log of %g", value);
bbce6d69 1879 }
65202027 1880 value = Perl_log(value);
a0d0e21e
LW		 1881 XPUSHn(value);
1882 RETURN;
1883 }
79072805
LW		 1884}
1885
1886PP(pp_sqrt)
1887{
4e35701f 1888 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 1889 {
65202027 1890 NV value;
a0d0e21e 1891 value = POPn;
bbce6d69 1892 if (value < 0.0) {
5e1047cb 1893 SET_NUMERIC_STANDARD();
cea2e8a9 1894 DIE(aTHX_ "Can't take sqrt of %g", value);
bbce6d69 1895 }
65202027 1896 value = Perl_sqrt(value);
a0d0e21e
LW		 1897 XPUSHn(value);
1898 RETURN;
1899 }
79072805
LW		 1900}
1901
1902PP(pp_int)
1903{
4e35701f 1904 djSP; dTARGET;
774d564b 1905 {
65202027 1906 NV value = TOPn;
774d564b 1907 IV iv;
1908
1909 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1910 iv = SvIVX(TOPs);
1911 SETi(iv);
1912 }
1913 else {
e2439105
GS		 1914 if (value >= 0.0) {
1915#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1916 (void)Perl_modf(value, &value);
1917#else
1918 double tmp = (double)value;
1919 (void)Perl_modf(tmp, &tmp);
1920 value = (NV)tmp;
1921#endif
1922 }
774d564b 1923 else {
e2439105
GS		 1924#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
1925 (void)Perl_modf(-value, &value);
1926 value = -value;
1927#else
1928 double tmp = (double)value;
1929 (void)Perl_modf(-tmp, &tmp);
1930 value = -(NV)tmp;
1931#endif
774d564b 1932 }
1933 iv = I_V(value);
1934 if (iv == value)
1935 SETi(iv);
1936 else
1937 SETn(value);
1938 }
79072805 1939 }
79072805
LW		 1940 RETURN;
1941}
1942
463ee0b2
LW		 1943PP(pp_abs)
1944{
4e35701f 1945 djSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 1946 {
65202027 1947 NV value = TOPn;
774d564b 1948 IV iv;
463ee0b2 1949
774d564b 1950 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1951 (iv = SvIVX(TOPs)) != IV_MIN) {
1952 if (iv < 0)
1953 iv = -iv;
1954 SETi(iv);
1955 }
1956 else {
1957 if (value < 0.0)
1958 value = -value;
1959 SETn(value);
1960 }
a0d0e21e 1961 }
774d564b 1962 RETURN;
463ee0b2
LW		 1963}
1964
79072805
LW		 1965PP(pp_hex)
1966{
4e35701f 1967 djSP; dTARGET;
79072805 1968 char *tmps;
a4bf32d5 1969 STRLEN argtype;
2d8e6c8d 1970 STRLEN n_a;
79072805 1971
2d8e6c8d 1972 tmps = POPpx;
b21ed0a9 1973 argtype = 1; /* allow underscores */
9e24b6e2 1974 XPUSHn(scan_hex(tmps, 99, &argtype));
79072805
LW		 1975 RETURN;
1976}
1977
1978PP(pp_oct)
1979{
4e35701f 1980 djSP; dTARGET;
9e24b6e2 1981 NV value;
a4bf32d5 1982 STRLEN argtype;
79072805 1983 char *tmps;
2d8e6c8d 1984 STRLEN n_a;
79072805 1985
2d8e6c8d 1986 tmps = POPpx;
464e2e8a 1987 while (*tmps && isSPACE(*tmps))
1988 tmps++;
9e24b6e2
JH		 1989 if (*tmps == '0')
1990 tmps++;
b21ed0a9 1991 argtype = 1; /* allow underscores */
9e24b6e2
JH		 1992 if (*tmps == 'x')
1993 value = scan_hex(++tmps, 99, &argtype);
1994 else if (*tmps == 'b')
1995 value = scan_bin(++tmps, 99, &argtype);
464e2e8a 1996 else
9e24b6e2
JH		 1997 value = scan_oct(tmps, 99, &argtype);
1998 XPUSHn(value);
79072805
LW		 1999 RETURN;
2000}
2001
2002/* String stuff. */
2003
2004PP(pp_length)
2005{
4e35701f 2006 djSP; dTARGET;
7e2040f0 2007 SV *sv = TOPs;
a0ed51b3 2008
7e2040f0
GS		 2009 if (DO_UTF8(sv))
2010 SETi(sv_len_utf8(sv));
2011 else
2012 SETi(sv_len(sv));
79072805
LW		 2013 RETURN;
2014}
2015
2016PP(pp_substr)
2017{
4e35701f 2018 djSP; dTARGET;
79072805
LW		 2019 SV *sv;
2020 I32 len;
463ee0b2 2021 STRLEN curlen;
a0ed51b3 2022 STRLEN utfcurlen;
79072805
LW		 2023 I32 pos;
2024 I32 rem;
84902520 2025 I32 fail;
84615ddc 2026 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
79072805 2027 char *tmps;
3280af22 2028 I32 arybase = PL_curcop->cop_arybase;
7b8d334a
GS		 2029 char *repl = 0;
2030 STRLEN repl_len;
84615ddc 2031 int num_args = PL_op->op_private & 7;
79072805 2032
20408e3c 2033 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2034 SvUTF8_off(TARG); /* decontaminate */
84615ddc
GS		 2035 if (num_args > 2) {
2036 if (num_args > 3) {
5d82c453
GA		 2037 sv = POPs;
2038 repl = SvPV(sv, repl_len);
7b8d334a 2039 }
79072805 2040 len = POPi;
5d82c453 2041 }
84902520 2042 pos = POPi;
79072805 2043 sv = POPs;
849ca7ee 2044 PUTBACK;
a0d0e21e 2045 tmps = SvPV(sv, curlen);
7e2040f0 2046 if (DO_UTF8(sv)) {
a0ed51b3
LW		 2047 utfcurlen = sv_len_utf8(sv);
2048 if (utfcurlen == curlen)
2049 utfcurlen = 0;
2050 else
2051 curlen = utfcurlen;
2052 }
d1c2b58a
LW		 2053 else
2054 utfcurlen = 0;
a0ed51b3 2055
84902520
TB		 2056 if (pos >= arybase) {
2057 pos -= arybase;
2058 rem = curlen-pos;
2059 fail = rem;
84615ddc 2060 if (num_args > 2) {
5d82c453
GA		 2061 if (len < 0) {
2062 rem += len;
2063 if (rem < 0)
2064 rem = 0;
2065 }
2066 else if (rem > len)
2067 rem = len;
2068 }
68dc0745 2069 }
84902520 2070 else {
5d82c453 2071 pos += curlen;
84615ddc 2072 if (num_args < 3)
5d82c453
GA		 2073 rem = curlen;
2074 else if (len >= 0) {
2075 rem = pos+len;
2076 if (rem > (I32)curlen)
2077 rem = curlen;
2078 }
2079 else {
2080 rem = curlen+len;
2081 if (rem < pos)
2082 rem = pos;
2083 }
2084 if (pos < 0)
2085 pos = 0;
2086 fail = rem;
2087 rem -= pos;
84902520
TB		 2088 }
2089 if (fail < 0) {
e476b1b5
GS		 2090 if (lvalue || repl)
2091 Perl_croak(aTHX_ "substr outside of string");
2092 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2093 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2304df62
AD		 2094 RETPUSHUNDEF;
2095 }
79072805 2096 else {
99cafcc8
JH		 2097 I32 upos = pos;
2098 I32 urem = rem;
7f66633b 2099 if (utfcurlen)
a0ed51b3 2100 sv_pos_u2b(sv, &pos, &rem);
79072805 2101 tmps += pos;
79072805 2102 sv_setpvn(TARG, tmps, rem);
7f66633b
GS		 2103 if (utfcurlen)
2104 SvUTF8_on(TARG);
c8faf1c5
GS		 2105 if (repl)
2106 sv_insert(sv, pos, rem, repl, repl_len);
2107 else if (lvalue) { /* it's an lvalue! */
dedeecda 2108 if (!SvGMAGICAL(sv)) {
2109 if (SvROK(sv)) {
2d8e6c8d
GS		 2110 STRLEN n_a;
2111 SvPV_force(sv,n_a);
599cee73 2112 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2113 Perl_warner(aTHX_ WARN_SUBSTR,
599cee73 2114 "Attempt to use reference as lvalue in substr");
dedeecda 2115 }
2116 if (SvOK(sv)) /* is it defined ? */
7f66633b 2117 (void)SvPOK_only_UTF8(sv);
dedeecda 2118 else
2119 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2120 }
5f05dabc 2121
a0d0e21e
LW		 2122 if (SvTYPE(TARG) < SVt_PVLV) {
2123 sv_upgrade(TARG, SVt_PVLV);
2124 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 2125 }
a0d0e21e 2126
5f05dabc 2127 LvTYPE(TARG) = 'x';
6ff81951
GS		 2128 if (LvTARG(TARG) != sv) {
2129 if (LvTARG(TARG))
2130 SvREFCNT_dec(LvTARG(TARG));
2131 LvTARG(TARG) = SvREFCNT_inc(sv);
2132 }
99cafcc8
JH		 2133 LvTARGOFF(TARG) = upos;
2134 LvTARGLEN(TARG) = urem;
79072805
LW		 2135 }
2136 }
849ca7ee 2137 SPAGAIN;
79072805
LW		 2138 PUSHs(TARG); /* avoid SvSETMAGIC here */
2139 RETURN;
2140}
2141
2142PP(pp_vec)
2143{
4e35701f 2144 djSP; dTARGET;
e2439105
GS		 2145 register IV size = POPi;
2146 register IV offset = POPi;
79072805 2147 register SV *src = POPs;
84615ddc 2148 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
a0d0e21e 2149
81e118e0
JH		 2150 SvTAINTED_off(TARG); /* decontaminate */
2151 if (lvalue) { /* it's an lvalue! */
2152 if (SvTYPE(TARG) < SVt_PVLV) {
2153 sv_upgrade(TARG, SVt_PVLV);
2154 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
79072805 2155 }
81e118e0
JH		 2156 LvTYPE(TARG) = 'v';
2157 if (LvTARG(TARG) != src) {
2158 if (LvTARG(TARG))
2159 SvREFCNT_dec(LvTARG(TARG));
2160 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 2161 }
81e118e0
JH		 2162 LvTARGOFF(TARG) = offset;
2163 LvTARGLEN(TARG) = size;
79072805
LW		 2164 }
2165
81e118e0 2166 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 2167 PUSHs(TARG);
2168 RETURN;
2169}
2170
2171PP(pp_index)
2172{
4e35701f 2173 djSP; dTARGET;
79072805
LW		 2174 SV *big;
2175 SV *little;
2176 I32 offset;
2177 I32 retval;
2178 char *tmps;
2179 char *tmps2;
463ee0b2 2180 STRLEN biglen;
3280af22 2181 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 2182
2183 if (MAXARG < 3)
2184 offset = 0;
2185 else
2186 offset = POPi - arybase;
2187 little = POPs;
2188 big = POPs;
463ee0b2 2189 tmps = SvPV(big, biglen);
7e2040f0 2190 if (offset > 0 && DO_UTF8(big))
a0ed51b3 2191 sv_pos_u2b(big, &offset, 0);
79072805
LW		 2192 if (offset < 0)
2193 offset = 0;
93a17b20
LW		 2194 else if (offset > biglen)
2195 offset = biglen;
79072805 2196 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2197 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 2198 retval = -1;
79072805 2199 else
a0ed51b3 2200 retval = tmps2 - tmps;
7e2040f0 2201 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 2202 sv_pos_b2u(big, &retval);
2203 PUSHi(retval + arybase);
79072805
LW		 2204 RETURN;
2205}
2206
2207PP(pp_rindex)
2208{
4e35701f 2209 djSP; dTARGET;
79072805
LW		 2210 SV *big;
2211 SV *little;
463ee0b2
LW		 2212 STRLEN blen;
2213 STRLEN llen;
79072805
LW		 2214 I32 offset;
2215 I32 retval;
2216 char *tmps;
2217 char *tmps2;
3280af22 2218 I32 arybase = PL_curcop->cop_arybase;
79072805 2219
a0d0e21e 2220 if (MAXARG >= 3)
a0ed51b3 2221 offset = POPi;
79072805
LW		 2222 little = POPs;
2223 big = POPs;
463ee0b2
LW		 2224 tmps2 = SvPV(little, llen);
2225 tmps = SvPV(big, blen);
79072805 2226 if (MAXARG < 3)
463ee0b2 2227 offset = blen;
a0ed51b3 2228 else {
7e2040f0 2229 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 2230 sv_pos_u2b(big, &offset, 0);
2231 offset = offset - arybase + llen;
2232 }
79072805
LW		 2233 if (offset < 0)
2234 offset = 0;
463ee0b2
LW		 2235 else if (offset > blen)
2236 offset = blen;
79072805 2237 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2238 tmps2, tmps2 + llen)))
a0ed51b3 2239 retval = -1;
79072805 2240 else
a0ed51b3 2241 retval = tmps2 - tmps;
7e2040f0 2242 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 2243 sv_pos_b2u(big, &retval);
2244 PUSHi(retval + arybase);
79072805
LW		 2245 RETURN;
2246}
2247
2248PP(pp_sprintf)
2249{
4e35701f 2250 djSP; dMARK; dORIGMARK; dTARGET;
79072805 2251 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2252 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 2253 SP = ORIGMARK;
2254 PUSHTARG;
2255 RETURN;
2256}
2257
79072805
LW		 2258PP(pp_ord)
2259{
4e35701f 2260 djSP; dTARGET;
1145892d 2261 SV *argsv = POPs;
a4bf32d5 2262 STRLEN len;
1145892d 2263 U8 *s = (U8*)SvPVx(argsv, len);
79072805 2264
1145892d 2265 XPUSHu(DO_UTF8(argsv) ? utf8_to_uv_simple(s, 0) : (*s & 0xff));
79072805
LW		 2266 RETURN;
2267}
2268
463ee0b2
LW		 2269PP(pp_chr)
2270{
4e35701f 2271 djSP; dTARGET;
463ee0b2 2272 char *tmps;
e2439105 2273 UV value = POPu;
463ee0b2 2274
748a9306 2275 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 2276
c2a11925 2277 if (value > 255 && !IN_BYTE) {
aa6ffa16 2278 SvGROW(TARG, UTF8_MAXLEN+1);
a0ed51b3 2279 tmps = SvPVX(TARG);
dfe13c55 2280 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
a0ed51b3
LW		 2281 SvCUR_set(TARG, tmps - SvPVX(TARG));
2282 *tmps = '\0';
2283 (void)SvPOK_only(TARG);
aa6ffa16 2284 SvUTF8_on(TARG);
a0ed51b3
LW		 2285 XPUSHs(TARG);
2286 RETURN;
2287 }
2288
748a9306 2289 SvGROW(TARG,2);
463ee0b2
LW		 2290 SvCUR_set(TARG, 1);
2291 tmps = SvPVX(TARG);
a0ed51b3 2292 *tmps++ = value;
748a9306 2293 *tmps = '\0';
a0d0e21e 2294 (void)SvPOK_only(TARG);
463ee0b2
LW		 2295 XPUSHs(TARG);
2296 RETURN;
2297}
2298
79072805
LW		 2299PP(pp_crypt)
2300{
4e35701f 2301 djSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 2302 STRLEN n_a;
79072805 2303#ifdef HAS_CRYPT
2d8e6c8d 2304 char *tmps = SvPV(left, n_a);
79072805 2305#ifdef FCRYPT
2d8e6c8d 2306 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 2307#else
2d8e6c8d 2308 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW		 2309#endif
2310#else
cea2e8a9 2311 DIE(aTHX_
79072805
LW		 2312 "The crypt() function is unimplemented due to excessive paranoia.");
2313#endif
2314 SETs(TARG);
2315 RETURN;
2316}
2317
2318PP(pp_ucfirst)
2319{
4e35701f 2320 djSP;
79072805 2321 SV *sv = TOPs;
a0ed51b3
LW		 2322 register U8 *s;
2323 STRLEN slen;
2324
f3efa21a 2325 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
a4bf32d5 2326 STRLEN ulen;
feb4a48f 2327 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 2328 U8 *tend;
a4bf32d5 2329 UV uv = utf8_to_uv(s, slen, &ulen, 0);
a0ed51b3
LW		 2330
2331 if (PL_op->op_private & OPpLOCALE) {
2332 TAINT;
2333 SvTAINTED_on(sv);
2334 uv = toTITLE_LC_uni(uv);
2335 }
2336 else
2337 uv = toTITLE_utf8(s);
2338
2339 tend = uv_to_utf8(tmpbuf, uv);
2340
014822e4 2341 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2342 dTARGET;
dfe13c55
GS		 2343 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2344 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 2345 SvUTF8_on(TARG);
a0ed51b3
LW		 2346 SETs(TARG);
2347 }
2348 else {
dfe13c55 2349 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW		 2350 Copy(tmpbuf, s, ulen, U8);
2351 }
a0ed51b3 2352 }
626727d5 2353 else {
014822e4 2354 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2355 dTARGET;
7e2040f0 2356 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2357 sv_setsv(TARG, sv);
2358 sv = TARG;
2359 SETs(sv);
2360 }
2361 s = (U8*)SvPV_force(sv, slen);
2362 if (*s) {
2363 if (PL_op->op_private & OPpLOCALE) {
2364 TAINT;
2365 SvTAINTED_on(sv);
2366 *s = toUPPER_LC(*s);
2367 }
2368 else
2369 *s = toUPPER(*s);
bbce6d69 2370 }
bbce6d69 2371 }
31351b04
JS		 2372 if (SvSMAGICAL(sv))
2373 mg_set(sv);
79072805
LW		 2374 RETURN;
2375}
2376
2377PP(pp_lcfirst)
2378{
4e35701f 2379 djSP;
79072805 2380 SV *sv = TOPs;
a0ed51b3
LW		 2381 register U8 *s;
2382 STRLEN slen;
2383
f3efa21a 2384 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
a4bf32d5 2385 STRLEN ulen;
feb4a48f 2386 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 2387 U8 *tend;
a4bf32d5 2388 UV uv = utf8_to_uv(s, slen, &ulen, 0);
a0ed51b3
LW		 2389
2390 if (PL_op->op_private & OPpLOCALE) {
2391 TAINT;
2392 SvTAINTED_on(sv);
2393 uv = toLOWER_LC_uni(uv);
2394 }
2395 else
2396 uv = toLOWER_utf8(s);
2397
2398 tend = uv_to_utf8(tmpbuf, uv);
2399
014822e4 2400 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2401 dTARGET;
dfe13c55
GS		 2402 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2403 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 2404 SvUTF8_on(TARG);
a0ed51b3
LW		 2405 SETs(TARG);
2406 }
2407 else {
dfe13c55 2408 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW		 2409 Copy(tmpbuf, s, ulen, U8);
2410 }
a0ed51b3 2411 }
626727d5 2412 else {
014822e4 2413 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2414 dTARGET;
7e2040f0 2415 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2416 sv_setsv(TARG, sv);
2417 sv = TARG;
2418 SETs(sv);
2419 }
2420 s = (U8*)SvPV_force(sv, slen);
2421 if (*s) {
2422 if (PL_op->op_private & OPpLOCALE) {
2423 TAINT;
2424 SvTAINTED_on(sv);
2425 *s = toLOWER_LC(*s);
2426 }
2427 else
2428 *s = toLOWER(*s);
bbce6d69 2429 }
bbce6d69 2430 }
31351b04
JS		 2431 if (SvSMAGICAL(sv))
2432 mg_set(sv);
79072805
LW		 2433 RETURN;
2434}
2435
2436PP(pp_uc)
2437{
4e35701f 2438 djSP;
79072805 2439 SV *sv = TOPs;
a0ed51b3 2440 register U8 *s;
463ee0b2 2441 STRLEN len;
79072805 2442
7e2040f0 2443 if (DO_UTF8(sv)) {
a0ed51b3 2444 dTARGET;
a4bf32d5 2445 STRLEN ulen;
a0ed51b3
LW		 2446 register U8 *d;
2447 U8 *send;
2448
dfe13c55 2449 s = (U8*)SvPV(sv,len);
a5a20234 2450 if (!len) {
7e2040f0 2451 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 2452 sv_setpvn(TARG, "", 0);
2453 SETs(TARG);
a0ed51b3
LW		 2454 }
2455 else {
31351b04
JS		 2456 (void)SvUPGRADE(TARG, SVt_PV);
2457 SvGROW(TARG, (len * 2) + 1);
2458 (void)SvPOK_only(TARG);
2459 d = (U8*)SvPVX(TARG);
2460 send = s + len;
2461 if (PL_op->op_private & OPpLOCALE) {
2462 TAINT;
2463 SvTAINTED_on(TARG);
2464 while (s < send) {
a4bf32d5 2465 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
31351b04
JS		 2466 s += ulen;
2467 }
a0ed51b3 2468 }
31351b04
JS		 2469 else {
2470 while (s < send) {
2471 d = uv_to_utf8(d, toUPPER_utf8( s ));
2472 s += UTF8SKIP(s);
2473 }
a0ed51b3 2474 }
31351b04 2475 *d = '\0';
7e2040f0 2476 SvUTF8_on(TARG);
31351b04
JS		 2477 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2478 SETs(TARG);
a0ed51b3 2479 }
a0ed51b3 2480 }
626727d5 2481 else {
014822e4 2482 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2483 dTARGET;
7e2040f0 2484 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2485 sv_setsv(TARG, sv);
2486 sv = TARG;
2487 SETs(sv);
2488 }
2489 s = (U8*)SvPV_force(sv, len);
2490 if (len) {
2491 register U8 *send = s + len;
2492
2493 if (PL_op->op_private & OPpLOCALE) {
2494 TAINT;
2495 SvTAINTED_on(sv);
2496 for (; s < send; s++)
2497 *s = toUPPER_LC(*s);
2498 }
2499 else {
2500 for (; s < send; s++)
2501 *s = toUPPER(*s);
2502 }
bbce6d69 2503 }
79072805 2504 }
31351b04
JS		 2505 if (SvSMAGICAL(sv))
2506 mg_set(sv);
79072805
LW		 2507 RETURN;
2508}
2509
2510PP(pp_lc)
2511{
4e35701f 2512 djSP;
79072805 2513 SV *sv = TOPs;
a0ed51b3 2514 register U8 *s;
463ee0b2 2515 STRLEN len;
79072805 2516
7e2040f0 2517 if (DO_UTF8(sv)) {
a0ed51b3 2518 dTARGET;
a4bf32d5 2519 STRLEN ulen;
a0ed51b3
LW		 2520 register U8 *d;
2521 U8 *send;
2522
dfe13c55 2523 s = (U8*)SvPV(sv,len);
a5a20234 2524 if (!len) {
7e2040f0 2525 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 2526 sv_setpvn(TARG, "", 0);
2527 SETs(TARG);
a0ed51b3
LW		 2528 }
2529 else {
31351b04
JS		 2530 (void)SvUPGRADE(TARG, SVt_PV);
2531 SvGROW(TARG, (len * 2) + 1);
2532 (void)SvPOK_only(TARG);
2533 d = (U8*)SvPVX(TARG);
2534 send = s + len;
2535 if (PL_op->op_private & OPpLOCALE) {
2536 TAINT;
2537 SvTAINTED_on(TARG);
2538 while (s < send) {
a4bf32d5 2539 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
31351b04
JS		 2540 s += ulen;
2541 }
a0ed51b3 2542 }
31351b04
JS		 2543 else {
2544 while (s < send) {
2545 d = uv_to_utf8(d, toLOWER_utf8(s));
2546 s += UTF8SKIP(s);
2547 }
a0ed51b3 2548 }
31351b04 2549 *d = '\0';
7e2040f0 2550 SvUTF8_on(TARG);
31351b04
JS		 2551 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2552 SETs(TARG);
a0ed51b3 2553 }
79072805 2554 }
626727d5 2555 else {
014822e4 2556 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2557 dTARGET;
7e2040f0 2558 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2559 sv_setsv(TARG, sv);
2560 sv = TARG;
2561 SETs(sv);
a0ed51b3 2562 }
bbce6d69 2563
31351b04
JS		 2564 s = (U8*)SvPV_force(sv, len);
2565 if (len) {
2566 register U8 *send = s + len;
bbce6d69 2567
31351b04
JS		 2568 if (PL_op->op_private & OPpLOCALE) {
2569 TAINT;
2570 SvTAINTED_on(sv);
2571 for (; s < send; s++)
2572 *s = toLOWER_LC(*s);
2573 }
2574 else {
2575 for (; s < send; s++)
2576 *s = toLOWER(*s);
2577 }
bbce6d69 2578 }
79072805 2579 }
31351b04
JS		 2580 if (SvSMAGICAL(sv))
2581 mg_set(sv);
79072805
LW		 2582 RETURN;
2583}
2584
a0d0e21e 2585PP(pp_quotemeta)
79072805 2586{
4e35701f 2587 djSP; dTARGET;
a0d0e21e
LW		 2588 SV *sv = TOPs;
2589 STRLEN len;
2590 register char *s = SvPV(sv,len);
2591 register char *d;
79072805 2592
7e2040f0 2593 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 2594 if (len) {
2595 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2596 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 2597 d = SvPVX(TARG);
7e2040f0 2598 if (DO_UTF8(sv)) {
0dd2cdef 2599 while (len) {
f3efa21a 2600 if (UTF8_IS_CONTINUED(*s)) {
0dd2cdef
LW		 2601 STRLEN ulen = UTF8SKIP(s);
2602 if (ulen > len)
2603 ulen = len;
2604 len -= ulen;
2605 while (ulen--)
2606 *d++ = *s++;
2607 }
2608 else {
2609 if (!isALNUM(*s))
2610 *d++ = '\\';
2611 *d++ = *s++;
2612 len--;
2613 }
2614 }
7e2040f0 2615 SvUTF8_on(TARG);
0dd2cdef
LW		 2616 }
2617 else {
2618 while (len--) {
2619 if (!isALNUM(*s))
2620 *d++ = '\\';
2621 *d++ = *s++;
2622 }
79072805 2623 }
a0d0e21e
LW		 2624 *d = '\0';
2625 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 2626 (void)SvPOK_only_UTF8(TARG);
79072805 2627 }
a0d0e21e
LW		 2628 else
2629 sv_setpvn(TARG, s, len);
2630 SETs(TARG);
31351b04
JS		 2631 if (SvSMAGICAL(TARG))
2632 mg_set(TARG);
79072805
LW		 2633 RETURN;
2634}
2635
a0d0e21e 2636/* Arrays. */
79072805 2637
a0d0e21e 2638PP(pp_aslice)
79072805 2639{
4e35701f 2640 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2641 register SV** svp;
2642 register AV* av = (AV*)POPs;
84615ddc 2643 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3280af22 2644 I32 arybase = PL_curcop->cop_arybase;
748a9306 2645 I32 elem;
79072805 2646
a0d0e21e 2647 if (SvTYPE(av) == SVt_PVAV) {
533c011a 2648 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 2649 I32 max = -1;
924508f0 2650 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 2651 elem = SvIVx(*svp);
2652 if (elem > max)
2653 max = elem;
2654 }
2655 if (max > AvMAX(av))
2656 av_extend(av, max);
2657 }
a0d0e21e 2658 while (++MARK <= SP) {
748a9306 2659 elem = SvIVx(*MARK);
a0d0e21e 2660
748a9306
LW		 2661 if (elem > 0)
2662 elem -= arybase;
a0d0e21e
LW		 2663 svp = av_fetch(av, elem, lval);
2664 if (lval) {
3280af22 2665 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 2666 DIE(aTHX_ PL_no_aelem, elem);
533c011a 2667 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2668 save_aelem(av, elem, svp);
79072805 2669 }
3280af22 2670 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2671 }
2672 }
748a9306 2673 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 2674 MARK = ORIGMARK;
2675 *++MARK = *SP;
2676 SP = MARK;
2677 }
79072805
LW		 2678 RETURN;
2679}
2680
2681/* Associative arrays. */
2682
2683PP(pp_each)
2684{
59af0135 2685 djSP;
79072805 2686 HV *hash = (HV*)POPs;
c07a80fd 2687 HE *entry;
54310121 2688 I32 gimme = GIMME_V;
c750a3ec 2689 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2690
c07a80fd 2691 PUTBACK;
c750a3ec
MB		 2692 /* might clobber stack_sp */
2693 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2694 SPAGAIN;
79072805 2695
79072805
LW		 2696 EXTEND(SP, 2);
2697 if (entry) {
54310121 2698 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2699 if (gimme == G_ARRAY) {
59af0135 2700 SV *val;
c07a80fd 2701 PUTBACK;
c750a3ec 2702 /* might clobber stack_sp */
59af0135
GS		 2703 val = realhv ?
2704 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 2705 SPAGAIN;
59af0135 2706 PUSHs(val);
79072805 2707 }
79072805 2708 }
54310121 2709 else if (gimme == G_SCALAR)
79072805
LW		 2710 RETPUSHUNDEF;
2711
2712 RETURN;
2713}
2714
2715PP(pp_values)
2716{
cea2e8a9 2717 return do_kv();
79072805
LW		 2718}
2719
2720PP(pp_keys)
2721{
cea2e8a9 2722 return do_kv();
79072805
LW		 2723}
2724
2725PP(pp_delete)
2726{
4e35701f 2727 djSP;
54310121 2728 I32 gimme = GIMME_V;
2729 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2730 SV *sv;
5f05dabc 2731 HV *hv;
2732
533c011a 2733 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2734 dMARK; dORIGMARK;
97fcbf96 2735 U32 hvtype;
5f05dabc 2736 hv = (HV*)POPs;
97fcbf96 2737 hvtype = SvTYPE(hv);
01020589
GS		 2738 if (hvtype == SVt_PVHV) { /* hash element */
2739 while (++MARK <= SP) {
ae77835f 2740 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 2741 *MARK = sv ? sv : &PL_sv_undef;
2742 }
5f05dabc 2743 }
01020589
GS		 2744 else if (hvtype == SVt_PVAV) {
2745 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2746 while (++MARK <= SP) {
2747 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2748 *MARK = sv ? sv : &PL_sv_undef;
2749 }
2750 }
2751 else { /* pseudo-hash element */
2752 while (++MARK <= SP) {
2753 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2754 *MARK = sv ? sv : &PL_sv_undef;
2755 }
2756 }
2757 }
2758 else
2759 DIE(aTHX_ "Not a HASH reference");
54310121 2760 if (discard)
2761 SP = ORIGMARK;
2762 else if (gimme == G_SCALAR) {
5f05dabc 2763 MARK = ORIGMARK;
2764 *++MARK = *SP;
2765 SP = MARK;
2766 }
2767 }
2768 else {
2769 SV *keysv = POPs;
2770 hv = (HV*)POPs;
97fcbf96
MB		 2771 if (SvTYPE(hv) == SVt_PVHV)
2772 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 2773 else if (SvTYPE(hv) == SVt_PVAV) {
2774 if (PL_op->op_flags & OPf_SPECIAL)
2775 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2776 else
2777 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2778 }
97fcbf96 2779 else
cea2e8a9 2780 DIE(aTHX_ "Not a HASH reference");
5f05dabc 2781 if (!sv)
3280af22 2782 sv = &PL_sv_undef;
54310121 2783 if (!discard)
2784 PUSHs(sv);
79072805 2785 }
79072805
LW		 2786 RETURN;
2787}
2788
a0d0e21e 2789PP(pp_exists)
79072805 2790{
4e35701f 2791 djSP;
afebc493
GS		 2792 SV *tmpsv;
2793 HV *hv;
2794
2795 if (PL_op->op_private & OPpEXISTS_SUB) {
2796 GV *gv;
2797 CV *cv;
2798 SV *sv = POPs;
2799 cv = sv_2cv(sv, &hv, &gv, FALSE);
2800 if (cv)
2801 RETPUSHYES;
2802 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2803 RETPUSHYES;
2804 RETPUSHNO;
2805 }
2806 tmpsv = POPs;
2807 hv = (HV*)POPs;
c750a3ec 2808 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2809 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 2810 RETPUSHYES;
ef54e1a4
JH		 2811 }
2812 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 2813 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2814 if (av_exists((AV*)hv, SvIV(tmpsv)))
2815 RETPUSHYES;
2816 }
2817 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
c750a3ec 2818 RETPUSHYES;
ef54e1a4
JH		 2819 }
2820 else {
cea2e8a9 2821 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 2822 }
a0d0e21e
LW		 2823 RETPUSHNO;
2824}
79072805 2825
a0d0e21e
LW		 2826PP(pp_hslice)
2827{
4e35701f 2828 djSP; dMARK; dORIGMARK;
a0d0e21e 2829 register HV *hv = (HV*)POPs;
84615ddc 2830 register I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
c750a3ec 2831 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2832
0ebe0038 2833 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 2834 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 2835
c750a3ec 2836 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2837 while (++MARK <= SP) {
f12c7020 2838 SV *keysv = *MARK;
ae77835f
MB		 2839 SV **svp;
2840 if (realhv) {
800e9ae0 2841 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 2842 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH		 2843 }
2844 else {
97fcbf96 2845 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2846 }
a0d0e21e 2847 if (lval) {
2d8e6c8d
GS		 2848 if (!svp || *svp == &PL_sv_undef) {
2849 STRLEN n_a;
cea2e8a9 2850 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 2851 }
533c011a 2852 if (PL_op->op_private & OPpLVAL_INTRO)
800e9ae0 2853 save_helem(hv, keysv, svp);
93a17b20 2854 }
3280af22 2855 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2856 }
2857 }
a0d0e21e
LW		 2858 if (GIMME != G_ARRAY) {
2859 MARK = ORIGMARK;
2860 *++MARK = *SP;
2861 SP = MARK;
79072805 2862 }
a0d0e21e
LW		 2863 RETURN;
2864}
2865
2866/* List operators. */
2867
2868PP(pp_list)
2869{
4e35701f 2870 djSP; dMARK;
a0d0e21e
LW		 2871 if (GIMME != G_ARRAY) {
2872 if (++MARK <= SP)
2873 *MARK = *SP; /* unwanted list, return last item */
8990e307 2874 else
3280af22 2875 *MARK = &PL_sv_undef;
a0d0e21e 2876 SP = MARK;
79072805 2877 }
a0d0e21e 2878 RETURN;
79072805
LW		 2879}
2880
a0d0e21e 2881PP(pp_lslice)
79072805 2882{
4e35701f 2883 djSP;
3280af22
NIS		 2884 SV **lastrelem = PL_stack_sp;
2885 SV **lastlelem = PL_stack_base + POPMARK;
2886 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2887 register SV **firstrelem = lastlelem + 1;
3280af22 2888 I32 arybase = PL_curcop->cop_arybase;
533c011a 2889 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2890 I32 is_something_there = lval;
79072805 2891
a0d0e21e
LW		 2892 register I32 max = lastrelem - lastlelem;
2893 register SV **lelem;
2894 register I32 ix;
2895
2896 if (GIMME != G_ARRAY) {
748a9306
LW		 2897 ix = SvIVx(*lastlelem);
2898 if (ix < 0)
2899 ix += max;
2900 else
2901 ix -= arybase;
a0d0e21e 2902 if (ix < 0 || ix >= max)
3280af22 2903 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 2904 else
2905 *firstlelem = firstrelem[ix];
2906 SP = firstlelem;
2907 RETURN;
2908 }
2909
2910 if (max == 0) {
2911 SP = firstlelem - 1;
2912 RETURN;
2913 }
2914
2915 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2916 ix = SvIVx(*lelem);
c73bf8e3 2917 if (ix < 0)
a0d0e21e 2918 ix += max;
c73bf8e3 2919 else
748a9306 2920 ix -= arybase;
c73bf8e3
HS		 2921 if (ix < 0 || ix >= max)
2922 *lelem = &PL_sv_undef;
2923 else {
2924 is_something_there = TRUE;
2925 if (!(*lelem = firstrelem[ix]))
3280af22 2926 *lelem = &PL_sv_undef;
748a9306 2927 }
79072805 2928 }
4633a7c4
LW		 2929 if (is_something_there)
2930 SP = lastlelem;
2931 else
2932 SP = firstlelem - 1;
79072805
LW		 2933 RETURN;
2934}
2935
a0d0e21e
LW		 2936PP(pp_anonlist)
2937{
4e35701f 2938 djSP; dMARK; dORIGMARK;
a0d0e21e 2939 I32 items = SP - MARK;
44a8e56a 2940 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2941 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2942 XPUSHs(av);
a0d0e21e
LW		 2943 RETURN;
2944}
2945
2946PP(pp_anonhash)
79072805 2947{
4e35701f 2948 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2949 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2950
2951 while (MARK < SP) {
2952 SV* key = *++MARK;
a0d0e21e
LW		 2953 SV *val = NEWSV(46, 0);
2954 if (MARK < SP)
2955 sv_setsv(val, *++MARK);
e476b1b5
GS		 2956 else if (ckWARN(WARN_MISC))
2957 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
f12c7020 2958 (void)hv_store_ent(hv,key,val,0);
79072805 2959 }
a0d0e21e
LW		 2960 SP = ORIGMARK;
2961 XPUSHs((SV*)hv);
79072805
LW		 2962 RETURN;
2963}
2964
a0d0e21e 2965PP(pp_splice)
79072805 2966{
4e35701f 2967 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2968 register AV *ary = (AV*)*++MARK;
2969 register SV **src;
2970 register SV **dst;
2971 register I32 i;
2972 register I32 offset;
2973 register I32 length;
2974 I32 newlen;
2975 I32 after;
2976 I32 diff;
2977 SV **tmparyval = 0;
93965878
NIS		 2978 MAGIC *mg;
2979
155aba94 2980 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 2981 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2982 PUSHMARK(MARK);
8ec5e241 2983 PUTBACK;
a60c0954 2984 ENTER;
864dbfa3 2985 call_method("SPLICE",GIMME_V);
a60c0954 2986 LEAVE;
93965878
NIS		 2987 SPAGAIN;
2988 RETURN;
2989 }
79072805 2990
a0d0e21e 2991 SP++;
79072805 2992
a0d0e21e 2993 if (++MARK < SP) {
84902520 2994 offset = i = SvIVx(*MARK);
a0d0e21e 2995 if (offset < 0)
93965878 2996 offset += AvFILLp(ary) + 1;
a0d0e21e 2997 else
3280af22 2998 offset -= PL_curcop->cop_arybase;
84902520 2999 if (offset < 0)
cea2e8a9 3000 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 3001 if (++MARK < SP) {
3002 length = SvIVx(*MARK++);
48cdf507
GA		 3003 if (length < 0) {
3004 length += AvFILLp(ary) - offset + 1;
3005 if (length < 0)
3006 length = 0;
3007 }
79072805
LW		 3008 }
3009 else
a0d0e21e 3010 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 3011 }
a0d0e21e
LW		 3012 else {
3013 offset = 0;
3014 length = AvMAX(ary) + 1;
3015 }
93965878
NIS		 3016 if (offset > AvFILLp(ary) + 1)
3017 offset = AvFILLp(ary) + 1;
3018 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 3019 if (after < 0) { /* not that much array */
3020 length += after; /* offset+length now in array */
3021 after = 0;
3022 if (!AvALLOC(ary))
3023 av_extend(ary, 0);
3024 }
3025
3026 /* At this point, MARK .. SP-1 is our new LIST */
3027
3028 newlen = SP - MARK;
3029 diff = newlen - length;
13d7cbc1
GS		 3030 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3031 av_reify(ary);
a0d0e21e
LW		 3032
3033 if (diff < 0) { /* shrinking the area */
3034 if (newlen) {
3035 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3036 Copy(MARK, tmparyval, newlen, SV*);
79072805 3037 }
a0d0e21e
LW		 3038
3039 MARK = ORIGMARK + 1;
3040 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3041 MEXTEND(MARK, length);
3042 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3043 if (AvREAL(ary)) {
bbce6d69 3044 EXTEND_MORTAL(length);
36477c24 3045 for (i = length, dst = MARK; i; i--) {
d689ffdd 3046 sv_2mortal(*dst); /* free them eventualy */
36477c24 3047 dst++;
3048 }
a0d0e21e
LW		 3049 }
3050 MARK += length - 1;
79072805 3051 }
a0d0e21e
LW		 3052 else {
3053 *MARK = AvARRAY(ary)[offset+length-1];
3054 if (AvREAL(ary)) {
d689ffdd 3055 sv_2mortal(*MARK);
a0d0e21e
LW		 3056 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3057 SvREFCNT_dec(*dst++); /* free them now */
79072805 3058 }
a0d0e21e 3059 }
93965878 3060 AvFILLp(ary) += diff;
a0d0e21e
LW		 3061
3062 /* pull up or down? */
3063
3064 if (offset < after) { /* easier to pull up */
3065 if (offset) { /* esp. if nothing to pull */
3066 src = &AvARRAY(ary)[offset-1];
3067 dst = src - diff; /* diff is negative */
3068 for (i = offset; i > 0; i--) /* can't trust Copy */
3069 *dst-- = *src--;
79072805 3070 }
a0d0e21e
LW		 3071 dst = AvARRAY(ary);
3072 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3073 AvMAX(ary) += diff;
3074 }
3075 else {
3076 if (after) { /* anything to pull down? */
3077 src = AvARRAY(ary) + offset + length;
3078 dst = src + diff; /* diff is negative */
3079 Move(src, dst, after, SV*);
79072805 3080 }
93965878 3081 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 3082 /* avoid later double free */
3083 }
3084 i = -diff;
3085 while (i)
3280af22 3086 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 3087
3088 if (newlen) {
3089 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3090 newlen; newlen--) {
3091 *dst = NEWSV(46, 0);
3092 sv_setsv(*dst++, *src++);
79072805 3093 }
a0d0e21e
LW		 3094 Safefree(tmparyval);
3095 }
3096 }
3097 else { /* no, expanding (or same) */
3098 if (length) {
3099 New(452, tmparyval, length, SV*); /* so remember deletion */
3100 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3101 }
3102
3103 if (diff > 0) { /* expanding */
3104
3105 /* push up or down? */
3106
3107 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3108 if (offset) {
3109 src = AvARRAY(ary);
3110 dst = src - diff;
3111 Move(src, dst, offset, SV*);
79072805 3112 }
a0d0e21e
LW		 3113 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3114 AvMAX(ary) += diff;
93965878 3115 AvFILLp(ary) += diff;
79072805
LW		 3116 }
3117 else {
93965878
NIS		 3118 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3119 av_extend(ary, AvFILLp(ary) + diff);
3120 AvFILLp(ary) += diff;
a0d0e21e
LW		 3121
3122 if (after) {
93965878 3123 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 3124 src = dst - diff;
3125 for (i = after; i; i--) {
3126 *dst-- = *src--;
3127 }
79072805
LW		 3128 }
3129 }
a0d0e21e
LW		 3130 }
3131
3132 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3133 *dst = NEWSV(46, 0);
3134 sv_setsv(*dst++, *src++);
3135 }
3136 MARK = ORIGMARK + 1;
3137 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3138 if (length) {
3139 Copy(tmparyval, MARK, length, SV*);
3140 if (AvREAL(ary)) {
bbce6d69 3141 EXTEND_MORTAL(length);
36477c24 3142 for (i = length, dst = MARK; i; i--) {
d689ffdd 3143 sv_2mortal(*dst); /* free them eventualy */
36477c24 3144 dst++;
3145 }
79072805 3146 }
a0d0e21e 3147 Safefree(tmparyval);
79072805 3148 }
a0d0e21e
LW		 3149 MARK += length - 1;
3150 }
3151 else if (length--) {
3152 *MARK = tmparyval[length];
3153 if (AvREAL(ary)) {
d689ffdd 3154 sv_2mortal(*MARK);
a0d0e21e
LW		 3155 while (length-- > 0)
3156 SvREFCNT_dec(tmparyval[length]);
79072805 3157 }
a0d0e21e 3158 Safefree(tmparyval);
79072805 3159 }
a0d0e21e 3160 else
3280af22 3161 *MARK = &PL_sv_undef;
79072805 3162 }
a0d0e21e 3163 SP = MARK;
79072805
LW		 3164 RETURN;
3165}
3166
a0d0e21e 3167PP(pp_push)
79072805 3168{
4e35701f 3169 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3170 register AV *ary = (AV*)*++MARK;
3280af22 3171 register SV *sv = &PL_sv_undef;
93965878 3172 MAGIC *mg;
79072805 3173
155aba94 3174 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 3175 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 3176 PUSHMARK(MARK);
3177 PUTBACK;
a60c0954 3178 ENTER;
864dbfa3 3179 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 3180 LEAVE;
93965878 3181 SPAGAIN;
93965878 3182 }
a60c0954
NIS		 3183 else {
3184 /* Why no pre-extend of ary here ? */
3185 for (++MARK; MARK <= SP; MARK++) {
3186 sv = NEWSV(51, 0);
3187 if (*MARK)
3188 sv_setsv(sv, *MARK);
3189 av_push(ary, sv);
3190 }
79072805
LW		 3191 }
3192 SP = ORIGMARK;
a0d0e21e 3193 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 3194 RETURN;
3195}
3196
a0d0e21e 3197PP(pp_pop)
79072805 3198{
4e35701f 3199 djSP;
a0d0e21e
LW		 3200 AV *av = (AV*)POPs;
3201 SV *sv = av_pop(av);
d689ffdd 3202 if (AvREAL(av))
a0d0e21e
LW		 3203 (void)sv_2mortal(sv);
3204 PUSHs(sv);
79072805 3205 RETURN;
79072805
LW		 3206}
3207
a0d0e21e 3208PP(pp_shift)
79072805 3209{
4e35701f 3210 djSP;
a0d0e21e
LW		 3211 AV *av = (AV*)POPs;
3212 SV *sv = av_shift(av);
79072805 3213 EXTEND(SP, 1);
a0d0e21e 3214 if (!sv)
79072805 3215 RETPUSHUNDEF;
d689ffdd 3216 if (AvREAL(av))
a0d0e21e
LW		 3217 (void)sv_2mortal(sv);
3218 PUSHs(sv);
79072805 3219 RETURN;
79072805
LW		 3220}
3221
a0d0e21e 3222PP(pp_unshift)
79072805 3223{
4e35701f 3224 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3225 register AV *ary = (AV*)*++MARK;
3226 register SV *sv;
3227 register I32 i = 0;
93965878
NIS		 3228 MAGIC *mg;
3229
155aba94 3230 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 3231 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 3232 PUSHMARK(MARK);
93965878 3233 PUTBACK;
a60c0954 3234 ENTER;
864dbfa3 3235 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 3236 LEAVE;
93965878 3237 SPAGAIN;
93965878 3238 }
a60c0954
NIS		 3239 else {
3240 av_unshift(ary, SP - MARK);
3241 while (MARK < SP) {
3242 sv = NEWSV(27, 0);
3243 sv_setsv(sv, *++MARK);
3244 (void)av_store(ary, i++, sv);
3245 }
79072805 3246 }
a0d0e21e
LW		 3247 SP = ORIGMARK;
3248 PUSHi( AvFILL(ary) + 1 );
79072805 3249 RETURN;
79072805
LW		 3250}
3251
a0d0e21e 3252PP(pp_reverse)
79072805 3253{
4e35701f 3254 djSP; dMARK;
a0d0e21e
LW		 3255 register SV *tmp;
3256 SV **oldsp = SP;
79072805 3257
a0d0e21e
LW		 3258 if (GIMME == G_ARRAY) {
3259 MARK++;
3260 while (MARK < SP) {
3261 tmp = *MARK;
3262 *MARK++ = *SP;
3263 *SP-- = tmp;
3264 }
dd58a1ab 3265 /* safe as long as stack cannot get extended in the above */
a0d0e21e 3266 SP = oldsp;
79072805
LW		 3267 }
3268 else {
a0d0e21e
LW		 3269 register char *up;
3270 register char *down;
3271 register I32 tmp;
3272 dTARGET;
3273 STRLEN len;
79072805 3274
7e2040f0 3275 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 3276 if (SP - MARK > 1)
3280af22 3277 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 3278 else
54b9620d 3279 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 3280 up = SvPV_force(TARG, len);
3281 if (len > 1) {
7e2040f0 3282 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 3283 U8* s = (U8*)SvPVX(TARG);
3284 U8* send = (U8*)(s + len);
a0ed51b3 3285 while (s < send) {
0da47da8 3286 if (UTF8_IS_ASCII(*s)) {
a0ed51b3
LW		 3287 s++;
3288 continue;
3289 }
3290 else {
0da47da8
JH		 3291 if (!utf8_to_uv_simple(s, 0))
3292 break;
dfe13c55 3293 up = (char*)s;
a0ed51b3 3294 s += UTF8SKIP(s);
dfe13c55 3295 down = (char*)(s - 1);
0da47da8 3296 /* reverse this character */
a0ed51b3
LW		 3297 while (down > up) {
3298 tmp = *up;
3299 *up++ = *down;
3300 *down-- = tmp;
3301 }
3302 }
3303 }
3304 up = SvPVX(TARG);
3305 }
a0d0e21e
LW		 3306 down = SvPVX(TARG) + len - 1;
3307 while (down > up) {
3308 tmp = *up;
3309 *up++ = *down;
3310 *down-- = tmp;
3311 }
3aa33fe5 3312 (void)SvPOK_only_UTF8(TARG);
79072805 3313 }
a0d0e21e
LW		 3314 SP = MARK + 1;
3315 SETTARG;
79072805 3316 }
a0d0e21e 3317 RETURN;
79072805
LW		 3318}
3319
864dbfa3 3320STATIC SV *
cea2e8a9 3321S_mul128(pTHX_ SV *sv, U8 m)
55497cff 3322{
3323 STRLEN len;
3324 char *s = SvPV(sv, len);
3325 char *t;
3326 U32 i = 0;
3327
3328 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
79cb57f6 3329 SV *tmpNew = newSVpvn("0000000000", 10);
55497cff 3330
09b7f37c 3331 sv_catsv(tmpNew, sv);
55497cff 3332 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 3333 sv = tmpNew;
55497cff 3334 s = SvPV(sv, len);
3335 }
3336 t = s + len - 1;
3337 while (!*t) /* trailing '\0'? */
3338 t--;
3339 while (t > s) {
3340 i = ((*t - '0') << 7) + m;
3341 *(t--) = '0' + (i % 10);
3342 m = i / 10;
3343 }
3344 return (sv);
3345}
3346
a0d0e21e
LW		 3347/* Explosives and implosives. */
3348
9d116dd7
JH		 3349#if 'I' == 73 && 'J' == 74
3350/* On an ASCII/ISO kind of system */
ba1ac976 3351#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH		 3352#else
3353/*
3354 Some other sort of character set - use memchr() so we don't match
3355 the null byte.
3356 */
80252599 3357#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
9d116dd7
JH		 3358#endif
3359
a0d0e21e 3360PP(pp_unpack)
79072805 3361{
4e35701f 3362 djSP;
a0d0e21e 3363 dPOPPOPssrl;
dd58a1ab 3364 I32 start_sp_offset = SP - PL_stack_base;
54310121 3365 I32 gimme = GIMME_V;
ed6116ce 3366 SV *sv;
a0d0e21e
LW		 3367 STRLEN llen;
3368 STRLEN rlen;
3369 register char *pat = SvPV(left, llen);
3370 register char *s = SvPV(right, rlen);
3371 char *strend = s + rlen;
3372 char *strbeg = s;
3373 register char *patend = pat + llen;
3374 I32 datumtype;
3375 register I32 len;
3376 register I32 bits;
abdc5761 3377 register char *str;
79072805 3378
a0d0e21e 3379 /* These must not be in registers: */
a4bf32d5 3380 short ashort;
a0d0e21e 3381 int aint;
a4bf32d5 3382 long along;
6b8eaf93 3383#ifdef HAS_QUAD
ecfc5424 3384 Quad_t aquad;
a0d0e21e
LW		 3385#endif
3386 U16 aushort;
3387 unsigned int auint;
3388 U32 aulong;
6b8eaf93 3389#ifdef HAS_QUAD
e862df63 3390 Uquad_t auquad;
a0d0e21e
LW		 3391#endif
3392 char *aptr;
3393 float afloat;
3394 double adouble;
3395 I32 checksum = 0;
3396 register U32 culong;
65202027 3397 NV cdouble;
fb73857a 3398 int commas = 0;
4b5b2118 3399 int star;
726ea183 3400#ifdef PERL_NATINT_PACK
ef54e1a4
JH		 3401 int natint; /* native integer */
3402 int unatint; /* unsigned native integer */
726ea183 3403#endif
79072805 3404
54310121 3405 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW		 3406 /*SUPPRESS 530*/
3407 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
5a929a98 3408 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW		 3409 patend++;
3410 while (isDIGIT(*patend) || *patend == '*')
3411 patend++;
3412 }
3413 else
3414 patend++;
79072805 3415 }
a0d0e21e
LW		 3416 while (pat < patend) {
3417 reparse:
bbdab043 3418 datumtype = *pat++ & 0xFF;
726ea183 3419#ifdef PERL_NATINT_PACK
ef54e1a4 3420 natint = 0;
726ea183 3421#endif
bbdab043
CS		 3422 if (isSPACE(datumtype))
3423 continue;
17f4a12d
IZ		 3424 if (datumtype == '#') {
3425 while (pat < patend && *pat != '\n')
3426 pat++;
3427 continue;
3428 }
f61d411c 3429 if (*pat == '!') {
ef54e1a4
JH		 3430 char *natstr = "sSiIlL";
3431
3432 if (strchr(natstr, datumtype)) {
726ea183 3433#ifdef PERL_NATINT_PACK
ef54e1a4 3434 natint = 1;
726ea183 3435#endif
ef54e1a4
JH		 3436 pat++;
3437 }
3438 else
d470f89e 3439 DIE(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 3440 }
4b5b2118 3441 star = 0;
a0d0e21e
LW		 3442 if (pat >= patend)
3443 len = 1;
3444 else if (*pat == '*') {
3445 len = strend - strbeg; /* long enough */
3446 pat++;
4b5b2118 3447 star = 1;
a0d0e21e
LW		 3448 }
3449 else if (isDIGIT(*pat)) {
3450 len = *pat++ - '0';
06387354 3451 while (isDIGIT(*pat)) {
a0d0e21e 3452 len = (len * 10) + (*pat++ - '0');
06387354 3453 if (len < 0)
d470f89e 3454 DIE(aTHX_ "Repeat count in unpack overflows");
06387354 3455 }
a0d0e21e
LW		 3456 }
3457 else
3458 len = (datumtype != '@');
4b5b2118 3459 redo_switch:
a0d0e21e
LW		 3460 switch(datumtype) {
3461 default:
d470f89e 3462 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3463 case ',': /* grandfather in commas but with a warning */
e476b1b5
GS		 3464 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3465 Perl_warner(aTHX_ WARN_UNPACK,
d470f89e 3466 "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3467 break;
a0d0e21e
LW		 3468 case '%':
3469 if (len == 1 && pat[-1] != '1')
3470 len = 16;
3471 checksum = len;
3472 culong = 0;
3473 cdouble = 0;
3474 if (pat < patend)
3475 goto reparse;
3476 break;
3477 case '@':
3478 if (len > strend - strbeg)
cea2e8a9 3479 DIE(aTHX_ "@ outside of string");
a0d0e21e
LW		 3480 s = strbeg + len;
3481 break;
3482 case 'X':
3483 if (len > s - strbeg)
cea2e8a9 3484 DIE(aTHX_ "X outside of string");
a0d0e21e
LW		 3485 s -= len;
3486 break;
3487 case 'x':
3488 if (len > strend - s)
cea2e8a9 3489 DIE(aTHX_ "x outside of string");
a0d0e21e
LW		 3490 s += len;
3491 break;
17f4a12d 3492 case '/':
dd58a1ab 3493 if (start_sp_offset >= SP - PL_stack_base)
17f4a12d 3494 DIE(aTHX_ "/ must follow a numeric type");
43192e07
IP		 3495 datumtype = *pat++;
3496 if (*pat == '*')
3497 pat++; /* ignore '*' for compatibility with pack */
3498 if (isDIGIT(*pat))
17f4a12d 3499 DIE(aTHX_ "/ cannot take a count" );
43192e07 3500 len = POPi;
4b5b2118
GS		 3501 star = 0;
3502 goto redo_switch;
a0d0e21e 3503 case 'A':
5a929a98 3504 case 'Z':
a0d0e21e
LW		 3505 case 'a':
3506 if (len > strend - s)
3507 len = strend - s;
3508 if (checksum)
3509 goto uchar_checksum;
3510 sv = NEWSV(35, len);
3511 sv_setpvn(sv, s, len);
3512 s += len;
5a929a98 3513 if (datumtype == 'A' || datumtype == 'Z') {
a0d0e21e 3514 aptr = s; /* borrow register */
5a929a98
VU		 3515 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3516 s = SvPVX(sv);
3517 while (*s)
3518 s++;
3519 }
3520 else { /* 'A' strips both nulls and spaces */
3521 s = SvPVX(sv) + len - 1;
3522 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3523 s--;
3524 *++s = '\0';
3525 }
a0d0e21e
LW		 3526 SvCUR_set(sv, s - SvPVX(sv));
3527 s = aptr; /* unborrow register */
3528 }
3529 XPUSHs(sv_2mortal(sv));
3530 break;
3531 case 'B':
3532 case 'b':
4b5b2118 3533 if (star || len > (strend - s) * 8)
a0d0e21e
LW		 3534 len = (strend - s) * 8;
3535 if (checksum) {
80252599
GS		 3536 if (!PL_bitcount) {
3537 Newz(601, PL_bitcount, 256, char);
a0d0e21e 3538 for (bits = 1; bits < 256; bits++) {
80252599
GS		 3539 if (bits & 1) PL_bitcount[bits]++;
3540 if (bits & 2) PL_bitcount[bits]++;
3541 if (bits & 4) PL_bitcount[bits]++;
3542 if (bits & 8) PL_bitcount[bits]++;
3543 if (bits & 16) PL_bitcount[bits]++;
3544 if (bits & 32) PL_bitcount[bits]++;
3545 if (bits & 64) PL_bitcount[bits]++;
3546 if (bits & 128) PL_bitcount[bits]++;
a0d0e21e
LW		 3547 }
3548 }
3549 while (len >= 8) {
80252599 3550 culong += PL_bitcount[*(unsigned char*)s++];
a0d0e21e
LW		 3551 len -= 8;
3552 }
3553 if (len) {
3554 bits = *s;
3555 if (datumtype == 'b') {
3556 while (len-- > 0) {
3557 if (bits & 1) culong++;
3558 bits >>= 1;
3559 }
3560 }
3561 else {
3562 while (len-- > 0) {
3563 if (bits & 128) culong++;
3564 bits <<= 1;
3565 }
3566 }
3567 }
79072805
LW		 3568 break;
3569 }
a0d0e21e
LW		 3570 sv = NEWSV(35, len + 1);
3571 SvCUR_set(sv, len);
3572 SvPOK_on(sv);
abdc5761 3573 str = SvPVX(sv);
a0d0e21e
LW		 3574 if (datumtype == 'b') {
3575 aint = len;
3576 for (len = 0; len < aint; len++) {
3577 if (len & 7) /*SUPPRESS 595*/
3578 bits >>= 1;
3579 else
3580 bits = *s++;
abdc5761 3581 *str++ = '0' + (bits & 1);
a0d0e21e
LW		 3582 }
3583 }
3584 else {
3585 aint = len;
3586 for (len = 0; len < aint; len++) {
3587 if (len & 7)
3588 bits <<= 1;
3589 else
3590 bits = *s++;
abdc5761 3591 *str++ = '0' + ((bits & 128) != 0);
a0d0e21e
LW		 3592 }
3593 }
abdc5761 3594 *str = '\0';
a0d0e21e
LW		 3595 XPUSHs(sv_2mortal(sv));
3596 break;
3597 case 'H':
3598 case 'h':
4b5b2118 3599 if (star || len > (strend - s) * 2)
a0d0e21e
LW		 3600 len = (strend - s) * 2;
3601 sv = NEWSV(35, len + 1);
3602 SvCUR_set(sv, len);
3603 SvPOK_on(sv);
abdc5761 3604 str = SvPVX(sv);
a0d0e21e
LW		 3605 if (datumtype == 'h') {
3606 aint = len;
3607 for (len = 0; len < aint; len++) {
3608 if (len & 1)
3609 bits >>= 4;
3610 else
3611 bits = *s++;
abdc5761 3612 *str++ = PL_hexdigit[bits & 15];
a0d0e21e
LW		 3613 }
3614 }
3615 else {
3616 aint = len;
3617 for (len = 0; len < aint; len++) {
3618 if (len & 1)
3619 bits <<= 4;
3620 else
3621 bits = *s++;
abdc5761 3622 *str++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW		 3623 }
3624 }
abdc5761 3625 *str = '\0';
a0d0e21e
LW		 3626 XPUSHs(sv_2mortal(sv));
3627 break;
3628 case 'c':
3629 if (len > strend - s)
3630 len = strend - s;
3631 if (checksum) {
3632 while (len-- > 0) {
3633 aint = *s++;
3634 if (aint >= 128) /* fake up signed chars */
3635 aint -= 256;
3636 culong += aint;
3637 }
3638 }
3639 else {
3640 EXTEND(SP, len);
bbce6d69 3641 EXTEND_MORTAL(len);
a0d0e21e
LW		 3642 while (len-- > 0) {
3643 aint = *s++;
3644 if (aint >= 128) /* fake up signed chars */
3645 aint -= 256;
3646 sv = NEWSV(36, 0);
1e422769 3647 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3648 PUSHs(sv_2mortal(sv));
3649 }
3650 }
3651 break;
3652 case 'C':
3653 if (len > strend - s)
3654 len = strend - s;
3655 if (checksum) {
3656 uchar_checksum:
3657 while (len-- > 0) {
3658 auint = *s++ & 255;
3659 culong += auint;
3660 }
3661 }
3662 else {
3663 EXTEND(SP, len);
bbce6d69 3664 EXTEND_MORTAL(len);
a0d0e21e
LW		 3665 while (len-- > 0) {
3666 auint = *s++ & 255;
3667 sv = NEWSV(37, 0);
1e422769 3668 sv_setiv(sv, (IV)auint);
a0d0e21e
LW		 3669 PUSHs(sv_2mortal(sv));
3670 }
3671 }
3672 break;
a0ed51b3
LW		 3673 case 'U':
3674 if (len > strend - s)
3675 len = strend - s;
3676 if (checksum) {
3677 while (len-- > 0 && s < strend) {
a4bf32d5
A		 3678 STRLEN alen;
3679 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3680 along = alen;
a0ed51b3 3681 s += along;
32d8b6e5 3682 if (checksum > 32)
65202027 3683 cdouble += (NV)auint;
32d8b6e5
GA		 3684 else
3685 culong += auint;
a0ed51b3
LW		 3686 }
3687 }
3688 else {
3689 EXTEND(SP, len);
3690 EXTEND_MORTAL(len);
3691 while (len-- > 0 && s < strend) {
a4bf32d5
A		 3692 STRLEN alen;
3693 auint = utf8_to_uv((U8*)s, strend - s, &alen, 0);
3694 along = alen;
a0ed51b3
LW		 3695 s += along;
3696 sv = NEWSV(37, 0);
bdeef251 3697 sv_setuv(sv, (UV)auint);
a0ed51b3
LW		 3698 PUSHs(sv_2mortal(sv));
3699 }
3700 }
3701 break;
a0d0e21e 3702 case 's':
726ea183
JH		 3703#if SHORTSIZE == SIZE16
3704 along = (strend - s) / SIZE16;
3705#else
ef54e1a4 3706 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
726ea183 3707#endif
a0d0e21e
LW		 3708 if (len > along)
3709 len = along;
3710 if (checksum) {
726ea183 3711#if SHORTSIZE != SIZE16
ef54e1a4 3712 if (natint) {
bf9315bb 3713 short ashort;
ef54e1a4
JH		 3714 while (len-- > 0) {
3715 COPYNN(s, &ashort, sizeof(short));
3716 s += sizeof(short);
3717 culong += ashort;
3718
3719 }
3720 }
726ea183
JH		 3721 else
3722#endif
3723 {
ef54e1a4
JH		 3724 while (len-- > 0) {
3725 COPY16(s, &ashort);
c67712b2
JH		 3726#if SHORTSIZE > SIZE16
3727 if (ashort > 32767)
3728 ashort -= 65536;
3729#endif
ef54e1a4
JH		 3730 s += SIZE16;
3731 culong += ashort;
3732 }
a0d0e21e
LW		 3733 }
3734 }
3735 else {
3736 EXTEND(SP, len);
bbce6d69 3737 EXTEND_MORTAL(len);
726ea183 3738#if SHORTSIZE != SIZE16
ef54e1a4 3739 if (natint) {
bf9315bb 3740 short ashort;
ef54e1a4
JH		 3741 while (len-- > 0) {
3742 COPYNN(s, &ashort, sizeof(short));
3743 s += sizeof(short);
3744 sv = NEWSV(38, 0);
3745 sv_setiv(sv, (IV)ashort);
3746 PUSHs(sv_2mortal(sv));
3747 }
3748 }
726ea183
JH		 3749 else
3750#endif
3751 {
ef54e1a4
JH		 3752 while (len-- > 0) {
3753 COPY16(s, &ashort);
c67712b2
JH		 3754#if SHORTSIZE > SIZE16
3755 if (ashort > 32767)
3756 ashort -= 65536;
3757#endif
ef54e1a4
JH		 3758 s += SIZE16;
3759 sv = NEWSV(38, 0);
3760 sv_setiv(sv, (IV)ashort);
3761 PUSHs(sv_2mortal(sv));
3762 }
a0d0e21e
LW		 3763 }
3764 }
3765 break;
3766 case 'v':
3767 case 'n':
3768 case 'S':
726ea183
JH		 3769#if SHORTSIZE == SIZE16
3770 along = (strend - s) / SIZE16;
3771#else
ef54e1a4
JH		 3772 unatint = natint && datumtype == 'S';
3773 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
726ea183 3774#endif
a0d0e21e
LW		 3775 if (len > along)
3776 len = along;
3777 if (checksum) {
726ea183 3778#if SHORTSIZE != SIZE16
ef54e1a4 3779 if (unatint) {
bf9315bb 3780 unsigned short aushort;
ef54e1a4
JH		 3781 while (len-- > 0) {
3782 COPYNN(s, &aushort, sizeof(unsigned short));
3783 s += sizeof(unsigned short);
3784 culong += aushort;
3785 }
3786 }
726ea183
JH		 3787 else
3788#endif
3789 {
ef54e1a4
JH		 3790 while (len-- > 0) {
3791 COPY16(s, &aushort);
3792 s += SIZE16;
a0d0e21e 3793#ifdef HAS_NTOHS
ef54e1a4
JH		 3794 if (datumtype == 'n')
3795 aushort = PerlSock_ntohs(aushort);
79072805 3796#endif
a0d0e21e 3797#ifdef HAS_VTOHS
ef54e1a4
JH		 3798 if (datumtype == 'v')
3799 aushort = vtohs(aushort);
79072805 3800#endif
ef54e1a4
JH		 3801 culong += aushort;
3802 }
a0d0e21e
LW		 3803 }
3804 }
3805 else {
3806 EXTEND(SP, len);
bbce6d69 3807 EXTEND_MORTAL(len);
726ea183 3808#if SHORTSIZE != SIZE16
ef54e1a4 3809 if (unatint) {
bf9315bb 3810 unsigned short aushort;
ef54e1a4
JH		 3811 while (len-- > 0) {
3812 COPYNN(s, &aushort, sizeof(unsigned short));
3813 s += sizeof(unsigned short);
3814 sv = NEWSV(39, 0);
726ea183 3815 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH		 3816 PUSHs(sv_2mortal(sv));
3817 }
3818 }
726ea183
JH		 3819 else
3820#endif
3821 {
ef54e1a4
JH		 3822 while (len-- > 0) {
3823 COPY16(s, &aushort);
3824 s += SIZE16;
3825 sv = NEWSV(39, 0);
a0d0e21e 3826#ifdef HAS_NTOHS
ef54e1a4
JH		 3827 if (datumtype == 'n')
3828 aushort = PerlSock_ntohs(aushort);
79072805 3829#endif
a0d0e21e 3830#ifdef HAS_VTOHS
ef54e1a4
JH		 3831 if (datumtype == 'v')
3832 aushort = vtohs(aushort);
79072805 3833#endif
726ea183 3834 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH		 3835 PUSHs(sv_2mortal(sv));
3836 }
a0d0e21e
LW		 3837 }
3838 }
3839 break;
3840 case 'i':
3841 along = (strend - s) / sizeof(int);
3842 if (len > along)
3843 len = along;
3844 if (checksum) {
3845 while (len-- > 0) {
3846 Copy(s, &aint, 1, int);
3847 s += sizeof(int);
3848 if (checksum > 32)
65202027 3849 cdouble += (NV)aint;
a0d0e21e
LW		 3850 else
3851 culong += aint;
3852 }
3853 }
3854 else {
3855 EXTEND(SP, len);
bbce6d69 3856 EXTEND_MORTAL(len);
a0d0e21e
LW		 3857 while (len-- > 0) {
3858 Copy(s, &aint, 1, int);
3859 s += sizeof(int);
3860 sv = NEWSV(40, 0);
20408e3c
GS		 3861#ifdef __osf__
3862 /* Without the dummy below unpack("i", pack("i",-1))
3863 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
13476c87
JH		 3864 * cc with optimization turned on.
3865 *
3866 * The bug was detected in
3867 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3868 * with optimization (-O4) turned on.
3869 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3870 * does not have this problem even with -O4.
3871 *
3872 * This bug was reported as DECC_BUGS 1431
3873 * and tracked internally as GEM_BUGS 7775.
3874 *
3875 * The bug is fixed in
3876 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3877 * UNIX V4.0F support: DEC C V5.9-006 or later
3878 * UNIX V4.0E support: DEC C V5.8-011 or later
3879 * and also in DTK.
3880 *
3881 * See also few lines later for the same bug.
3882 */
20408e3c
GS		 3883 (aint) ?
3884 sv_setiv(sv, (IV)aint) :
3885#endif
1e422769 3886 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3887 PUSHs(sv_2mortal(sv));
3888 }
3889 }
3890 break;
3891 case 'I':
3892 along = (strend - s) / sizeof(unsigned int);
3893 if (len > along)
3894 len = along;
3895 if (checksum) {
3896 while (len-- > 0) {
3897 Copy(s, &auint, 1, unsigned int);
3898 s += sizeof(unsigned int);
3899 if (checksum > 32)
65202027 3900 cdouble += (NV)auint;
a0d0e21e
LW		 3901 else
3902 culong += auint;
3903 }
3904 }
3905 else {
3906 EXTEND(SP, len);
bbce6d69 3907 EXTEND_MORTAL(len);
a0d0e21e
LW		 3908 while (len-- > 0) {
3909 Copy(s, &auint, 1, unsigned int);
3910 s += sizeof(unsigned int);
3911 sv = NEWSV(41, 0);
9d645a59
AB		 3912#ifdef __osf__
3913 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
13476c87
JH		 3914 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3915 * See details few lines earlier. */
9d645a59
AB		 3916 (auint) ?
3917 sv_setuv(sv, (UV)auint) :
3918#endif
1e422769 3919 sv_setuv(sv, (UV)auint);
a0d0e21e
LW		 3920 PUSHs(sv_2mortal(sv));
3921 }
3922 }
3923 break;
3924 case 'l':
726ea183
JH		 3925#if LONGSIZE == SIZE32
3926 along = (strend - s) / SIZE32;
3927#else
ef54e1a4 3928 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
726ea183 3929#endif
a0d0e21e
LW		 3930 if (len > along)
3931 len = along;
3932 if (checksum) {
726ea183 3933#if LONGSIZE != SIZE32
ef54e1a4
JH		 3934 if (natint) {
3935 while (len-- > 0) {
3936 COPYNN(s, &along, sizeof(long));
3937 s += sizeof(long);
3938 if (checksum > 32)
65202027 3939 cdouble += (NV)along;
ef54e1a4
JH		 3940 else
3941 culong += along;
3942 }
3943 }
726ea183
JH		 3944 else
3945#endif
3946 {
ef54e1a4 3947 while (len-- > 0) {
91da3df4
JH		 3948#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3949 I32 along;
3950#endif
ef54e1a4 3951 COPY32(s, &along);
c67712b2
JH		 3952#if LONGSIZE > SIZE32
3953 if (along > 2147483647)
3954 along -= 4294967296;
3955#endif
ef54e1a4
JH		 3956 s += SIZE32;
3957 if (checksum > 32)
65202027 3958 cdouble += (NV)along;
ef54e1a4
JH		 3959 else
3960 culong += along;
3961 }
a0d0e21e
LW		 3962 }
3963 }
3964 else {
3965 EXTEND(SP, len);
bbce6d69 3966 EXTEND_MORTAL(len);
726ea183 3967#if LONGSIZE != SIZE32
ef54e1a4
JH		 3968 if (natint) {
3969 while (len-- > 0) {
3970 COPYNN(s, &along, sizeof(long));
3971 s += sizeof(long);
3972 sv = NEWSV(42, 0);
3973 sv_setiv(sv, (IV)along);
3974 PUSHs(sv_2mortal(sv));
3975 }
3976 }
726ea183
JH		 3977 else
3978#endif
3979 {
ef54e1a4 3980 while (len-- > 0) {
91da3df4
JH		 3981#if LONGSIZE > SIZE32 && INTSIZE == SIZE32
3982 I32 along;
3983#endif
ef54e1a4 3984 COPY32(s, &along);
c67712b2
JH		 3985#if LONGSIZE > SIZE32
3986 if (along > 2147483647)
3987 along -= 4294967296;
3988#endif
ef54e1a4
JH		 3989 s += SIZE32;
3990 sv = NEWSV(42, 0);
3991 sv_setiv(sv, (IV)along);
3992 PUSHs(sv_2mortal(sv));
3993 }
a0d0e21e 3994 }
79072805 3995 }
a0d0e21e
LW		 3996 break;
3997 case 'V':
3998 case 'N':
3999 case 'L':
726ea183
JH		 4000#if LONGSIZE == SIZE32
4001 along = (strend - s) / SIZE32;
4002#else
4003 unatint = natint && datumtype == 'L';
ef54e1a4 4004 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
726ea183 4005#endif
a0d0e21e
LW		 4006 if (len > along)
4007 len = along;
4008 if (checksum) {
726ea183 4009#if LONGSIZE != SIZE32
ef54e1a4 4010 if (unatint) {
bf9315bb 4011 unsigned long aulong;
ef54e1a4
JH		 4012 while (len-- > 0) {
4013 COPYNN(s, &aulong, sizeof(unsigned long));
4014 s += sizeof(unsigned long);
4015 if (checksum > 32)
65202027 4016 cdouble += (NV)aulong;
ef54e1a4
JH		 4017 else
4018 culong += aulong;
4019 }
4020 }
726ea183
JH		 4021 else
4022#endif
4023 {
ef54e1a4
JH		 4024 while (len-- > 0) {
4025 COPY32(s, &aulong);
4026 s += SIZE32;
a0d0e21e 4027#ifdef HAS_NTOHL
ef54e1a4
JH		 4028 if (datumtype == 'N')
4029 aulong = PerlSock_ntohl(aulong);
79072805 4030#endif
a0d0e21e 4031#ifdef HAS_VTOHL
ef54e1a4
JH		 4032 if (datumtype == 'V')
4033 aulong = vtohl(aulong);
79072805 4034#endif
ef54e1a4 4035 if (checksum > 32)
65202027 4036 cdouble += (NV)aulong;
ef54e1a4
JH		 4037 else
4038 culong += aulong;
4039 }
a0d0e21e
LW		 4040 }
4041 }
4042 else {
4043 EXTEND(SP, len);
bbce6d69 4044 EXTEND_MORTAL(len);
726ea183 4045#if LONGSIZE != SIZE32
ef54e1a4 4046 if (unatint) {
bf9315bb 4047 unsigned long aulong;
ef54e1a4
JH		 4048 while (len-- > 0) {
4049 COPYNN(s, &aulong, sizeof(unsigned long));
4050 s += sizeof(unsigned long);
4051 sv = NEWSV(43, 0);
4052 sv_setuv(sv, (UV)aulong);
4053 PUSHs(sv_2mortal(sv));
4054 }
4055 }
726ea183
JH		 4056 else
4057#endif
4058 {
ef54e1a4
JH		 4059 while (len-- > 0) {
4060 COPY32(s, &aulong);
4061 s += SIZE32;
a0d0e21e 4062#ifdef HAS_NTOHL
ef54e1a4
JH		 4063 if (datumtype == 'N')
4064 aulong = PerlSock_ntohl(aulong);
79072805 4065#endif
a0d0e21e 4066#ifdef HAS_VTOHL
ef54e1a4
JH		 4067 if (datumtype == 'V')
4068 aulong = vtohl(aulong);
79072805 4069#endif
ef54e1a4
JH		 4070 sv = NEWSV(43, 0);
4071 sv_setuv(sv, (UV)aulong);
4072 PUSHs(sv_2mortal(sv));
4073 }
a0d0e21e
LW		 4074 }
4075 }
4076 break;
4077 case 'p':
4078 along = (strend - s) / sizeof(char*);
4079 if (len > along)
4080 len = along;
4081 EXTEND(SP, len);
bbce6d69 4082 EXTEND_MORTAL(len);
a0d0e21e
LW		 4083 while (len-- > 0) {
4084 if (sizeof(char*) > strend - s)
4085 break;
4086 else {
4087 Copy(s, &aptr, 1, char*);
4088 s += sizeof(char*);
4089 }
4090 sv = NEWSV(44, 0);
4091 if (aptr)
4092 sv_setpv(sv, aptr);
4093 PUSHs(sv_2mortal(sv));
4094 }
4095 break;
def98dd4 4096 case 'w':
def98dd4 4097 EXTEND(SP, len);
bbce6d69 4098 EXTEND_MORTAL(len);
8ec5e241 4099 {
bbce6d69 4100 UV auv = 0;
4101 U32 bytes = 0;
4102
4103 while ((len > 0) && (s < strend)) {
4104 auv = (auv << 7) | (*s & 0x7f);
f3efa21a 4105 if (UTF8_IS_ASCII(*s++)) {
bbce6d69 4106 bytes = 0;
4107 sv = NEWSV(40, 0);
4108 sv_setuv(sv, auv);
4109 PUSHs(sv_2mortal(sv));
4110 len--;
4111 auv = 0;
4112 }
4113 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69 4114 char *t;
2d8e6c8d 4115 STRLEN n_a;
bbce6d69 4116
72d299db 4117 sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv);
bbce6d69 4118 while (s < strend) {
4119 sv = mul128(sv, *s & 0x7f);
4120 if (!(*s++ & 0x80)) {
4121 bytes = 0;
4122 break;
4123 }
4124 }
2d8e6c8d 4125 t = SvPV(sv, n_a);
bbce6d69 4126 while (*t == '0')
4127 t++;
4128 sv_chop(sv, t);
4129 PUSHs(sv_2mortal(sv));
4130 len--;
4131 auv = 0;
4132 }
4133 }
4134 if ((s >= strend) && bytes)
d470f89e 4135 DIE(aTHX_ "Unterminated compressed integer");
bbce6d69 4136 }
def98dd4 4137 break;
a0d0e21e
LW		 4138 case 'P':
4139 EXTEND(SP, 1);
4140 if (sizeof(char*) > strend - s)
4141 break;
4142 else {
4143 Copy(s, &aptr, 1, char*);
4144 s += sizeof(char*);
4145 }
4146 sv = NEWSV(44, 0);
4147 if (aptr)
4148 sv_setpvn(sv, aptr, len);
4149 PUSHs(sv_2mortal(sv));
4150 break;
6b8eaf93 4151#ifdef HAS_QUAD
a0d0e21e 4152 case 'q':
d4217c7e
JH		 4153 along = (strend - s) / sizeof(Quad_t);
4154 if (len > along)
4155 len = along;
a0d0e21e 4156 EXTEND(SP, len);
bbce6d69 4157 EXTEND_MORTAL(len);
a0d0e21e 4158 while (len-- > 0) {
ecfc5424 4159 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW		 4160 aquad = 0;
4161 else {
ecfc5424
AD		 4162 Copy(s, &aquad, 1, Quad_t);
4163 s += sizeof(Quad_t);
a0d0e21e
LW		 4164 }
4165 sv = NEWSV(42, 0);
96e4d5b1 4166 if (aquad >= IV_MIN && aquad <= IV_MAX)
4167 sv_setiv(sv, (IV)aquad);
4168 else
65202027 4169 sv_setnv(sv, (NV)aquad);
a0d0e21e
LW		 4170 PUSHs(sv_2mortal(sv));
4171 }
4172 break;
4173 case 'Q':
d4217c7e
JH		 4174 along = (strend - s) / sizeof(Quad_t);
4175 if (len > along)
4176 len = along;
a0d0e21e 4177 EXTEND(SP, len);
bbce6d69 4178 EXTEND_MORTAL(len);
a0d0e21e 4179 while (len-- > 0) {
e862df63 4180 if (s + sizeof(Uquad_t) > strend)
a0d0e21e
LW		 4181 auquad = 0;
4182 else {
e862df63
HB		 4183 Copy(s, &auquad, 1, Uquad_t);
4184 s += sizeof(Uquad_t);
a0d0e21e
LW		 4185 }
4186 sv = NEWSV(43, 0);
27612d38 4187 if (auquad <= UV_MAX)
96e4d5b1 4188 sv_setuv(sv, (UV)auquad);
4189 else
65202027 4190 sv_setnv(sv, (NV)auquad);
a0d0e21e
LW		 4191 PUSHs(sv_2mortal(sv));
4192 }
4193 break;
79072805 4194#endif
a0d0e21e
LW		 4195 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4196 case 'f':
4197 case 'F':
4198 along = (strend - s) / sizeof(float);
4199 if (len > along)
4200 len = along;
4201 if (checksum) {
4202 while (len-- > 0) {
4203 Copy(s, &afloat, 1, float);
4204 s += sizeof(float);
4205 cdouble += afloat;
4206 }
4207 }
4208 else {
4209 EXTEND(SP, len);
bbce6d69 4210 EXTEND_MORTAL(len);
a0d0e21e
LW		 4211 while (len-- > 0) {
4212 Copy(s, &afloat, 1, float);
4213 s += sizeof(float);
4214 sv = NEWSV(47, 0);
65202027 4215 sv_setnv(sv, (NV)afloat);
a0d0e21e
LW		 4216 PUSHs(sv_2mortal(sv));
4217 }
4218 }
4219 break;
4220 case 'd':
4221 case 'D':
4222 along = (strend - s) / sizeof(double);
4223 if (len > along)
4224 len = along;
4225 if (checksum) {
4226 while (len-- > 0) {
4227 Copy(s, &adouble, 1, double);
4228 s += sizeof(double);
4229 cdouble += adouble;
4230 }
4231 }
4232 else {
4233 EXTEND(SP, len);
bbce6d69 4234 EXTEND_MORTAL(len);
a0d0e21e
LW		 4235 while (len-- > 0) {
4236 Copy(s, &adouble, 1, double);
4237 s += sizeof(double);
4238 sv = NEWSV(48, 0);
65202027 4239 sv_setnv(sv, (NV)adouble);
a0d0e21e
LW		 4240 PUSHs(sv_2mortal(sv));
4241 }
4242 }
4243 break;
4244 case 'u':
9d116dd7
JH		 4245 /* MKS:
4246 * Initialise the decode mapping. By using a table driven
4247 * algorithm, the code will be character-set independent
4248 * (and just as fast as doing character arithmetic)
4249 */
80252599 4250 if (PL_uudmap['M'] == 0) {
9d116dd7
JH		 4251 int i;
4252
80252599 4253 for (i = 0; i < sizeof(PL_uuemap); i += 1)
155aba94 4254 PL_uudmap[(U8)PL_uuemap[i]] = i;
9d116dd7
JH		 4255 /*
4256 * Because ' ' and '`' map to the same value,
4257 * we need to decode them both the same.
4258 */
80252599 4259 PL_uudmap[' '] = 0;
9d116dd7
JH		 4260 }
4261
a0d0e21e
LW		 4262 along = (strend - s) * 3 / 4;
4263 sv = NEWSV(42, along);
f12c7020 4264 if (along)
4265 SvPOK_on(sv);
9d116dd7 4266 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
a0d0e21e
LW		 4267 I32 a, b, c, d;
4268 char hunk[4];
79072805 4269
a0d0e21e 4270 hunk[3] = '\0';
155aba94 4271 len = PL_uudmap[*(U8*)s++] & 077;
a0d0e21e 4272 while (len > 0) {
9d116dd7 4273 if (s < strend && ISUUCHAR(*s))
155aba94 4274 a = PL_uudmap[*(U8*)s++] & 077;
9d116dd7
JH		 4275 else
4276 a = 0;
4277 if (s < strend && ISUUCHAR(*s))
155aba94 4278 b = PL_uudmap[*(U8*)s++] & 077;
9d116dd7
JH		 4279 else
4280 b = 0;
4281 if (s < strend && ISUUCHAR(*s))
155aba94 4282 c = PL_uudmap[*(U8*)s++] & 077;
9d116dd7
JH		 4283 else
4284 c = 0;
4285 if (s < strend && ISUUCHAR(*s))
155aba94 4286 d = PL_uudmap[*(U8*)s++] & 077;
a0d0e21e
LW		 4287 else
4288 d = 0;
4e35701f
NIS		 4289 hunk[0] = (a << 2) | (b >> 4);
4290 hunk[1] = (b << 4) | (c >> 2);
4291 hunk[2] = (c << 6) | d;
4292 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
a0d0e21e
LW		 4293 len -= 3;
4294 }
4295 if (*s == '\n')
4296 s++;
4297 else if (s[1] == '\n') /* possible checksum byte */
4298 s += 2;
79072805 4299 }
a0d0e21e
LW		 4300 XPUSHs(sv_2mortal(sv));
4301 break;
79072805 4302 }
a0d0e21e
LW		 4303 if (checksum) {
4304 sv = NEWSV(42, 0);
4305 if (strchr("fFdD", datumtype) ||
32d8b6e5 4306 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
65202027 4307 NV trouble;
79072805 4308
a0d0e21e
LW		 4309 adouble = 1.0;
4310 while (checksum >= 16) {
4311 checksum -= 16;
4312 adouble *= 65536.0;
4313 }
4314 while (checksum >= 4) {
4315 checksum -= 4;
4316 adouble *= 16.0;
4317 }
4318 while (checksum--)
4319 adouble *= 2.0;
4320 along = (1 << checksum) - 1;
4321 while (cdouble < 0.0)
4322 cdouble += adouble;
65202027 4323 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
a0d0e21e
LW		 4324 sv_setnv(sv, cdouble);
4325 }
4326 else {
4327 if (checksum < 32) {
96e4d5b1 4328 aulong = (1 << checksum) - 1;
4329 culong &= aulong;
a0d0e21e 4330 }
96e4d5b1 4331 sv_setuv(sv, (UV)culong);
a0d0e21e
LW		 4332 }
4333 XPUSHs(sv_2mortal(sv));
4334 checksum = 0;
79072805 4335 }
79072805 4336 }
dd58a1ab 4337 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
3280af22 4338 PUSHs(&PL_sv_undef);
79072805 4339 RETURN;
79072805
LW		 4340}
4341
76e3520e 4342STATIC void
cea2e8a9 4343S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
79072805 4344{
a0d0e21e 4345 char hunk[5];
79072805 4346
80252599 4347 *hunk = PL_uuemap[len];
a0d0e21e
LW		 4348 sv_catpvn(sv, hunk, 1);
4349 hunk[4] = '\0';
f264d472 4350 while (len > 2) {
80252599
GS		 4351 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4352 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4353 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4354 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
a0d0e21e
LW		 4355 sv_catpvn(sv, hunk, 4);
4356 s += 3;
4357 len -= 3;
4358 }
f264d472
GS		 4359 if (len > 0) {
4360 char r = (len > 1 ? s[1] : '\0');
80252599
GS		 4361 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4362 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4363 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4364 hunk[3] = PL_uuemap[0];
f264d472 4365 sv_catpvn(sv, hunk, 4);
a0d0e21e
LW		 4366 }
4367 sv_catpvn(sv, "\n", 1);
79072805
LW		 4368}
4369
79cb57f6 4370STATIC SV *
cea2e8a9 4371S_is_an_int(pTHX_ char *s, STRLEN l)
55497cff 4372{
2d8e6c8d 4373 STRLEN n_a;
79cb57f6 4374 SV *result = newSVpvn(s, l);
2d8e6c8d 4375 char *result_c = SvPV(result, n_a); /* convenience */
55497cff 4376 char *out = result_c;
4377 bool skip = 1;
4378 bool ignore = 0;
4379
4380 while (*s) {
4381 switch (*s) {
4382 case ' ':
4383 break;
4384 case '+':
4385 if (!skip) {
4386 SvREFCNT_dec(result);
4387 return (NULL);
4388 }
4389 break;
4390 case '0':
4391 case '1':
4392 case '2':
4393 case '3':
4394 case '4':
4395 case '5':
4396 case '6':
4397 case '7':
4398 case '8':
4399 case '9':
4400 skip = 0;
4401 if (!ignore) {
4402 *(out++) = *s;
4403 }
4404 break;
4405 case '.':
4406 ignore = 1;
4407 break;
4408 default:
4409 SvREFCNT_dec(result);
4410 return (NULL);
4411 }
4412 s++;
4413 }
4414 *(out++) = '\0';
4415 SvCUR_set(result, out - result_c);
4416 return (result);
4417}
4418
864dbfa3 4419/* pnum must be '\0' terminated */
76e3520e 4420STATIC int
cea2e8a9 4421S_div128(pTHX_ SV *pnum, bool *done)
55497cff 4422{
4423 STRLEN len;
4424 char *s = SvPV(pnum, len);
4425 int m = 0;
4426 int r = 0;
4427 char *t = s;
4428
4429 *done = 1;
4430 while (*t) {
4431 int i;
4432
4433 i = m * 10 + (*t - '0');
4434 m = i & 0x7F;
4435 r = (i >> 7); /* r < 10 */
4436 if (r) {
4437 *done = 0;
4438 }
4439 *(t++) = '0' + r;
4440 }
4441 *(t++) = '\0';
4442 SvCUR_set(pnum, (STRLEN) (t - s));
4443 return (m);
4444}
4445
4446
a0d0e21e 4447PP(pp_pack)
79072805 4448{
4e35701f 4449 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4450 register SV *cat = TARG;
4451 register I32 items;
4452 STRLEN fromlen;
4453 register char *pat = SvPVx(*++MARK, fromlen);
b1fb3988 4454 char *patcopy;
a0d0e21e
LW		 4455 register char *patend = pat + fromlen;
4456 register I32 len;
4457 I32 datumtype;
4458 SV *fromstr;
4459 /*SUPPRESS 442*/
4460 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4461 static char *space10 = " ";
79072805 4462
a0d0e21e
LW		 4463 /* These must not be in registers: */
4464 char achar;
4465 I16 ashort;
4466 int aint;
4467 unsigned int auint;
4468 I32 along;
4469 U32 aulong;
6b8eaf93 4470#ifdef HAS_QUAD
ecfc5424 4471 Quad_t aquad;
e862df63 4472 Uquad_t auquad;
79072805 4473#endif
a0d0e21e
LW		 4474 char *aptr;
4475 float afloat;
4476 double adouble;
fb73857a 4477 int commas = 0;
726ea183 4478#ifdef PERL_NATINT_PACK
ef54e1a4 4479 int natint; /* native integer */
726ea183 4480#endif
79072805 4481
a0d0e21e
LW		 4482 items = SP - MARK;
4483 MARK++;
4484 sv_setpvn(cat, "", 0);
b1fb3988 4485 patcopy = pat;
a0d0e21e 4486 while (pat < patend) {
43192e07
IP		 4487 SV *lengthcode = Nullsv;
4488#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
bbdab043 4489 datumtype = *pat++ & 0xFF;
726ea183 4490#ifdef PERL_NATINT_PACK
ef54e1a4 4491 natint = 0;
726ea183 4492#endif
b1fb3988
GS		 4493 if (isSPACE(datumtype)) {
4494 patcopy++;
bbdab043 4495 continue;
b1fb3988 4496 }
67368f91 4497 if (datumtype == 'U' && pat == patcopy+1)
b1fb3988 4498 SvUTF8_on(cat);
17f4a12d
IZ		 4499 if (datumtype == '#') {
4500 while (pat < patend && *pat != '\n')
4501 pat++;
4502 continue;
4503 }
f61d411c 4504 if (*pat == '!') {
ef54e1a4
JH		 4505 char *natstr = "sSiIlL";
4506
4507 if (strchr(natstr, datumtype)) {
726ea183 4508#ifdef PERL_NATINT_PACK
ef54e1a4 4509 natint = 1;
726ea183 4510#endif
ef54e1a4
JH		 4511 pat++;
4512 }
4513 else
d470f89e 4514 DIE(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 4515 }
a0d0e21e
LW		 4516 if (*pat == '*') {
4517 len = strchr("@Xxu", datumtype) ? 0 : items;
4518 pat++;
4519 }
4520 else if (isDIGIT(*pat)) {
4521 len = *pat++ - '0';
06387354 4522 while (isDIGIT(*pat)) {
a0d0e21e 4523 len = (len * 10) + (*pat++ - '0');
06387354 4524 if (len < 0)
d470f89e 4525 DIE(aTHX_ "Repeat count in pack overflows");
06387354 4526 }
a0d0e21e
LW		 4527 }
4528 else
4529 len = 1;
17f4a12d 4530 if (*pat == '/') {
43192e07 4531 ++pat;
155aba94 4532 if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
17f4a12d 4533 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
43192e07 4534 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
3399f041
GS		 4535 ? *MARK : &PL_sv_no)
4536 + (*pat == 'Z' ? 1 : 0)));
43192e07 4537 }
a0d0e21e
LW		 4538 switch(datumtype) {
4539 default:
d470f89e 4540 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
fb73857a 4541 case ',': /* grandfather in commas but with a warning */
e476b1b5
GS		 4542 if (commas++ == 0 && ckWARN(WARN_PACK))
4543 Perl_warner(aTHX_ WARN_PACK,
43192e07 4544 "Invalid type in pack: '%c'", (int)datumtype);
fb73857a 4545 break;
a0d0e21e 4546 case '%':
cea2e8a9 4547 DIE(aTHX_ "%% may only be used in unpack");
a0d0e21e
LW		 4548 case '@':
4549 len -= SvCUR(cat);
4550 if (len > 0)
4551 goto grow;
4552 len = -len;
4553 if (len > 0)
4554 goto shrink;
4555 break;
4556 case 'X':
4557 shrink:
4558 if (SvCUR(cat) < len)
cea2e8a9 4559 DIE(aTHX_ "X outside of string");
a0d0e21e
LW		 4560 SvCUR(cat) -= len;
4561 *SvEND(cat) = '\0';
4562 break;
4563 case 'x':
4564 grow:
4565 while (len >= 10) {
4566 sv_catpvn(cat, null10, 10);
4567 len -= 10;
4568 }
4569 sv_catpvn(cat, null10, len);
4570 break;
4571 case 'A':
5a929a98 4572 case 'Z':
a0d0e21e
LW		 4573 case 'a':
4574 fromstr = NEXTFROM;
4575 aptr = SvPV(fromstr, fromlen);
2b6c5635 4576 if (pat[-1] == '*') {
a0d0e21e 4577 len = fromlen;
2b6c5635
GS		 4578 if (datumtype == 'Z')
4579 ++len;
4580 }
4581 if (fromlen >= len) {
a0d0e21e 4582 sv_catpvn(cat, aptr, len);
2b6c5635
GS		 4583 if (datumtype == 'Z')
4584 *(SvEND(cat)-1) = '\0';
4585 }
a0d0e21e
LW		 4586 else {
4587 sv_catpvn(cat, aptr, fromlen);
4588 len -= fromlen;
4589 if (datumtype == 'A') {
4590 while (len >= 10) {
4591 sv_catpvn(cat, space10, 10);
4592 len -= 10;
4593 }
4594 sv_catpvn(cat, space10, len);
4595 }
4596 else {
4597 while (len >= 10) {
4598 sv_catpvn(cat, null10, 10);
4599 len -= 10;
4600 }
4601 sv_catpvn(cat, null10, len);
4602 }
4603 }
4604 break;
4605 case 'B':
4606 case 'b':
4607 {
abdc5761 4608 register char *str;
a0d0e21e 4609 I32 saveitems;
79072805 4610
a0d0e21e
LW		 4611 fromstr = NEXTFROM;
4612 saveitems = items;
abdc5761 4613 str = SvPV(fromstr, fromlen);
a0d0e21e
LW		 4614 if (pat[-1] == '*')
4615 len = fromlen;
a0d0e21e
LW		 4616 aint = SvCUR(cat);
4617 SvCUR(cat) += (len+7)/8;
4618 SvGROW(cat, SvCUR(cat) + 1);
4619 aptr = SvPVX(cat) + aint;
4620 if (len > fromlen)
4621 len = fromlen;
4622 aint = len;
4623 items = 0;
4624 if (datumtype == 'B') {
4625 for (len = 0; len++ < aint;) {
abdc5761 4626 items |= *str++ & 1;
a0d0e21e
LW		 4627 if (len & 7)
4628 items <<= 1;
4629 else {
4630 *aptr++ = items & 0xff;
4631 items = 0;
4632 }
4633 }
4634 }
4635 else {
4636 for (len = 0; len++ < aint;) {
abdc5761 4637 if (*str++ & 1)
a0d0e21e
LW		 4638 items |= 128;
4639 if (len & 7)
4640 items >>= 1;
4641 else {
4642 *aptr++ = items & 0xff;
4643 items = 0;
4644 }
4645 }
4646 }
4647 if (aint & 7) {
4648 if (datumtype == 'B')
4649 items <<= 7 - (aint & 7);
4650 else
4651 items >>= 7 - (aint & 7);
4652 *aptr++ = items & 0xff;
4653 }
abdc5761
GS		 4654 str = SvPVX(cat) + SvCUR(cat);
4655 while (aptr <= str)
a0d0e21e 4656 *aptr++ = '\0';
79072805 4657
a0d0e21e
LW		 4658 items = saveitems;
4659 }
4660 break;
4661 case 'H':
4662 case 'h':
4663 {
abdc5761 4664 register char *str;
a0d0e21e 4665 I32 saveitems;
79072805 4666
a0d0e21e
LW		 4667 fromstr = NEXTFROM;
4668 saveitems = items;
abdc5761 4669 str = SvPV(fromstr, fromlen);
a0d0e21e
LW		 4670 if (pat[-1] == '*')
4671 len = fromlen;
a0d0e21e
LW		 4672 aint = SvCUR(cat);
4673 SvCUR(cat) += (len+1)/2;
4674 SvGROW(cat, SvCUR(cat) + 1);
4675 aptr = SvPVX(cat) + aint;
4676 if (len > fromlen)
4677 len = fromlen;
4678 aint = len;
4679 items = 0;
4680 if (datumtype == 'H') {
4681 for (len = 0; len++ < aint;) {
abdc5761
GS		 4682 if (isALPHA(*str))
4683 items |= ((*str++ & 15) + 9) & 15;
a0d0e21e 4684 else
abdc5761 4685 items |= *str++ & 15;
a0d0e21e
LW		 4686 if (len & 1)
4687 items <<= 4;
4688 else {
4689 *aptr++ = items & 0xff;
4690 items = 0;
4691 }
4692 }
4693 }
4694 else {
4695 for (len = 0; len++ < aint;) {
abdc5761
GS		 4696 if (isALPHA(*str))
4697 items |= (((*str++ & 15) + 9) & 15) << 4;
a0d0e21e 4698 else
abdc5761 4699 items |= (*str++ & 15) << 4;
a0d0e21e
LW		 4700 if (len & 1)
4701 items >>= 4;
4702 else {
4703 *aptr++ = items & 0xff;
4704 items = 0;
4705 }
4706 }
4707 }
4708 if (aint & 1)
4709 *aptr++ = items & 0xff;
abdc5761
GS		 4710 str = SvPVX(cat) + SvCUR(cat);
4711 while (aptr <= str)
a0d0e21e 4712 *aptr++ = '\0';
79072805 4713
a0d0e21e
LW		 4714 items = saveitems;
4715 }
4716 break;
4717 case 'C':
4718 case 'c':
4719 while (len-- > 0) {
4720 fromstr = NEXTFROM;
4721 aint = SvIV(fromstr);
4722 achar = aint;
4723 sv_catpvn(cat, &achar, sizeof(char));
4724 }
4725 break;
a0ed51b3
LW		 4726 case 'U':
4727 while (len-- > 0) {
4728 fromstr = NEXTFROM;
4729 auint = SvUV(fromstr);
feb4a48f 4730 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1);
dfe13c55
GS		 4731 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4732 - SvPVX(cat));
a0ed51b3
LW		 4733 }
4734 *SvEND(cat) = '\0';
4735 break;
a0d0e21e
LW		 4736 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4737 case 'f':
4738 case 'F':
4739 while (len-- > 0) {
4740 fromstr = NEXTFROM;
4741 afloat = (float)SvNV(fromstr);
4742 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4743 }
4744 break;
4745 case 'd':
4746 case 'D':
4747 while (len-- > 0) {
4748 fromstr = NEXTFROM;
4749 adouble = (double)SvNV(fromstr);
4750 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4751 }
4752 break;
4753 case 'n':
4754 while (len-- > 0) {
4755 fromstr = NEXTFROM;
4756 ashort = (I16)SvIV(fromstr);
4757#ifdef HAS_HTONS
6ad3d225 4758 ashort = PerlSock_htons(ashort);
79072805 4759#endif
96e4d5b1 4760 CAT16(cat, &ashort);
a0d0e21e
LW		 4761 }
4762 break;
4763 case 'v':
4764 while (len-- > 0) {
4765 fromstr = NEXTFROM;
4766 ashort = (I16)SvIV(fromstr);
4767#ifdef HAS_HTOVS
4768 ashort = htovs(ashort);
79072805 4769#endif
96e4d5b1 4770 CAT16(cat, &ashort);
a0d0e21e
LW		 4771 }
4772 break;
4773 case 'S':
726ea183 4774#if SHORTSIZE != SIZE16
ef54e1a4
JH		 4775 if (natint) {
4776 unsigned short aushort;
4777
4778 while (len-- > 0) {
4779 fromstr = NEXTFROM;
4780 aushort = SvUV(fromstr);
4781 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4782 }
4783 }
726ea183
JH		 4784 else
4785#endif
4786 {
ef54e1a4
JH		 4787 U16 aushort;
4788
4789 while (len-- > 0) {
4790 fromstr = NEXTFROM;
726ea183 4791 aushort = (U16)SvUV(fromstr);
ef54e1a4
JH		 4792 CAT16(cat, &aushort);
4793 }
726ea183 4794
ef54e1a4
JH		 4795 }
4796 break;
a0d0e21e 4797 case 's':
c67712b2 4798#if SHORTSIZE != SIZE16
ef54e1a4 4799 if (natint) {
bf9315bb
GS		 4800 short ashort;
4801
ef54e1a4
JH		 4802 while (len-- > 0) {
4803 fromstr = NEXTFROM;
4804 ashort = SvIV(fromstr);
4805 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4806 }
4807 }
726ea183
JH		 4808 else
4809#endif
4810 {
ef54e1a4
JH		 4811 while (len-- > 0) {
4812 fromstr = NEXTFROM;
4813 ashort = (I16)SvIV(fromstr);
4814 CAT16(cat, &ashort);
4815 }
a0d0e21e
LW		 4816 }
4817 break;
4818 case 'I':
4819 while (len-- > 0) {
4820 fromstr = NEXTFROM;
96e4d5b1 4821 auint = SvUV(fromstr);
a0d0e21e
LW		 4822 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4823 }
4824 break;
def98dd4
UP		 4825 case 'w':
4826 while (len-- > 0) {
bbce6d69 4827 fromstr = NEXTFROM;
65202027 4828 adouble = Perl_floor(SvNV(fromstr));
bbce6d69 4829
4830 if (adouble < 0)
d470f89e 4831 DIE(aTHX_ "Cannot compress negative numbers");
bbce6d69 4832
46fc3d4c 4833 if (
8bda1795
ML		 4834#if UVSIZE > 4 && UVSIZE >= NVSIZE
4835 adouble <= 0xffffffff
ef2d312d 4836#else
8bda1795
ML		 4837# ifdef CXUX_BROKEN_CONSTANT_CONVERT
4838 adouble <= UV_MAX_cxux
4839# else
46fc3d4c 4840 adouble <= UV_MAX
8bda1795 4841# endif
46fc3d4c 4842#endif
4843 )
4844 {
bbce6d69 4845 char buf[1 + sizeof(UV)];
4846 char *in = buf + sizeof(buf);
db7c17d7 4847 UV auv = U_V(adouble);
bbce6d69 4848
4849 do {
4850 *--in = (auv & 0x7f) | 0x80;
4851 auv >>= 7;
4852 } while (auv);
4853 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4854 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4855 }
4856 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4857 char *from, *result, *in;
4858 SV *norm;
4859 STRLEN len;
4860 bool done;
8ec5e241 4861
bbce6d69 4862 /* Copy string and check for compliance */
4863 from = SvPV(fromstr, len);
4864 if ((norm = is_an_int(from, len)) == NULL)
d470f89e 4865 DIE(aTHX_ "can compress only unsigned integer");
bbce6d69 4866
4867 New('w', result, len, char);
4868 in = result + len;
4869 done = FALSE;
4870 while (!done)
4871 *--in = div128(norm, &done) | 0x80;
4872 result[len - 1] &= 0x7F; /* clear continue bit */
4873 sv_catpvn(cat, in, (result + len) - in);
5f05dabc 4874 Safefree(result);
bbce6d69 4875 SvREFCNT_dec(norm); /* free norm */
def98dd4 4876 }
bbce6d69 4877 else if (SvNOKp(fromstr)) {
4878 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4879 char *in = buf + sizeof(buf);
4880
4881 do {
4882 double next = floor(adouble / 128);
4883 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
e2439105 4884 if (in <= buf) /* this cannot happen ;-) */
d470f89e 4885 DIE(aTHX_ "Cannot compress integer");
e2439105 4886 in--;
bbce6d69 4887 adouble = next;
4888 } while (adouble > 0);
4889 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4890 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4891 }
4892 else
d470f89e 4893 DIE(aTHX_ "Cannot compress non integer");
bbce6d69 4894 }
def98dd4 4895 break;
a0d0e21e
LW		 4896 case 'i':
4897 while (len-- > 0) {
4898 fromstr = NEXTFROM;
4899 aint = SvIV(fromstr);
4900 sv_catpvn(cat, (char*)&aint, sizeof(int));
4901 }
4902 break;
4903 case 'N':
4904 while (len-- > 0) {
4905 fromstr = NEXTFROM;
96e4d5b1 4906 aulong = SvUV(fromstr);
a0d0e21e 4907#ifdef HAS_HTONL
6ad3d225 4908 aulong = PerlSock_htonl(aulong);
79072805 4909#endif
96e4d5b1 4910 CAT32(cat, &aulong);
a0d0e21e
LW		 4911 }
4912 break;
4913 case 'V':
4914 while (len-- > 0) {
4915 fromstr = NEXTFROM;
96e4d5b1 4916 aulong = SvUV(fromstr);
a0d0e21e
LW		 4917#ifdef HAS_HTOVL
4918 aulong = htovl(aulong);
79072805 4919#endif
96e4d5b1 4920 CAT32(cat, &aulong);
a0d0e21e
LW		 4921 }
4922 break;
4923 case 'L':
726ea183 4924#if LONGSIZE != SIZE32
ef54e1a4 4925 if (natint) {
bf9315bb
GS		 4926 unsigned long aulong;
4927
ef54e1a4
JH		 4928 while (len-- > 0) {
4929 fromstr = NEXTFROM;
4930 aulong = SvUV(fromstr);
4931 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4932 }
4933 }
726ea183
JH		 4934 else
4935#endif
4936 {
ef54e1a4
JH		 4937 while (len-- > 0) {
4938 fromstr = NEXTFROM;
4939 aulong = SvUV(fromstr);
4940 CAT32(cat, &aulong);
4941 }
a0d0e21e
LW		 4942 }
4943 break;
4944 case 'l':
726ea183 4945#if LONGSIZE != SIZE32
ef54e1a4 4946 if (natint) {
bf9315bb
GS		 4947 long along;
4948
ef54e1a4
JH		 4949 while (len-- > 0) {
4950 fromstr = NEXTFROM;
4951 along = SvIV(fromstr);
4952 sv_catpvn(cat, (char *)&along, sizeof(long));
4953 }
4954 }
726ea183
JH		 4955 else
4956#endif
4957 {
ef54e1a4
JH		 4958 while (len-- > 0) {
4959 fromstr = NEXTFROM;
4960 along = SvIV(fromstr);
4961 CAT32(cat, &along);
4962 }
a0d0e21e
LW		 4963 }
4964 break;
6b8eaf93 4965#ifdef HAS_QUAD
a0d0e21e
LW		 4966 case 'Q':
4967 while (len-- > 0) {
4968 fromstr = NEXTFROM;
bf9315bb 4969 auquad = (Uquad_t)SvUV(fromstr);
e862df63 4970 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
a0d0e21e
LW		 4971 }
4972 break;
4973 case 'q':
4974 while (len-- > 0) {
4975 fromstr = NEXTFROM;
ecfc5424
AD		 4976 aquad = (Quad_t)SvIV(fromstr);
4977 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW		 4978 }
4979 break;
1b8cd678 4980#endif
a0d0e21e
LW		 4981 case 'P':
4982 len = 1; /* assume SV is correct length */
4983 /* FALL THROUGH */
4984 case 'p':
4985 while (len-- > 0) {
4986 fromstr = NEXTFROM;
3280af22 4987 if (fromstr == &PL_sv_undef)
84902520 4988 aptr = NULL;
72dbcb4b 4989 else {
2d8e6c8d 4990 STRLEN n_a;
84902520
TB		 4991 /* XXX better yet, could spirit away the string to
4992 * a safe spot and hang on to it until the result
4993 * of pack() (and all copies of the result) are
4994 * gone.
4995 */
e476b1b5 4996 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
014822e4
GS		 4997 || (SvPADTMP(fromstr)
4998 && !SvREADONLY(fromstr))))
4999 {
e476b1b5 5000 Perl_warner(aTHX_ WARN_PACK,
599cee73 5001 "Attempt to pack pointer to temporary value");
014822e4 5002 }
84902520 5003 if (SvPOK(fromstr) || SvNIOK(fromstr))
2d8e6c8d 5004 aptr = SvPV(fromstr,n_a);
84902520 5005 else
2d8e6c8d 5006 aptr = SvPV_force(fromstr,n_a);
72dbcb4b 5007 }
a0d0e21e
LW		 5008 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
5009 }
5010 break;
5011 case 'u':
5012 fromstr = NEXTFROM;
5013 aptr = SvPV(fromstr, fromlen);
5014 SvGROW(cat, fromlen * 4 / 3);
5015 if (len <= 1)
5016 len = 45;
5017 else
5018 len = len / 3 * 3;
5019 while (fromlen > 0) {
5020 I32 todo;
79072805 5021
a0d0e21e
LW		 5022 if (fromlen > len)
5023 todo = len;
5024 else
5025 todo = fromlen;
5026 doencodes(cat, aptr, todo);
5027 fromlen -= todo;
5028 aptr += todo;
5029 }
5030 break;
5031 }
5032 }
5033 SvSETMAGIC(cat);
5034 SP = ORIGMARK;
5035 PUSHs(cat);
5036 RETURN;
79072805 5037}
a0d0e21e 5038#undef NEXTFROM
79072805 5039
8ec5e241 5040
a0d0e21e 5041PP(pp_split)
79072805 5042{
4e35701f 5043 djSP; dTARG;
a0d0e21e 5044 AV *ary;
e2439105 5045 register IV limit = POPi; /* note, negative is forever */
a0d0e21e
LW		 5046 SV *sv = POPs;
5047 STRLEN len;
5048 register char *s = SvPV(sv, len);
0da47da8 5049 bool do_utf8 = DO_UTF8(sv);
a0d0e21e 5050 char *strend = s + len;
44a8e56a 5051 register PMOP *pm;
d9f97599 5052 register REGEXP *rx;
a0d0e21e
LW		 5053 register SV *dstr;
5054 register char *m;
5055 I32 iters = 0;
1145892d
JH		 5056 STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
5057 I32 maxiters = slen + 10;
a0d0e21e
LW		 5058 I32 i;
5059 char *orig;
5060 I32 origlimit = limit;
5061 I32 realarray = 0;
5062 I32 base;
3280af22 5063 AV *oldstack = PL_curstack;
54310121 5064 I32 gimme = GIMME_V;
3280af22 5065 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 5066 I32 make_mortal = 1;
5067 MAGIC *mg = (MAGIC *) NULL;
79072805 5068
44a8e56a 5069#ifdef DEBUGGING
5070 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5071#else
5072 pm = (PMOP*)POPs;
5073#endif
a0d0e21e 5074 if (!pm || !s)
feb4a48f 5075 DIE(aTHX_ "panic: pp_split");
d9f97599 5076 rx = pm->op_pmregexp;
bbce6d69 5077
5078 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
5079 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
5080
971a9dd3
GS		 5081 if (pm->op_pmreplroot) {
5082#ifdef USE_ITHREADS
5083 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
5084#else
a0d0e21e 5085 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 5086#endif
5087 }
a0d0e21e 5088 else if (gimme != G_ARRAY)
6d4ff0d2 5089#ifdef USE_THREADS
533c011a 5090 ary = (AV*)PL_curpad[0];
6d4ff0d2 5091#else
3280af22 5092 ary = GvAVn(PL_defgv);
6d4ff0d2 5093#endif /* USE_THREADS */
79072805 5094 else
a0d0e21e
LW		 5095 ary = Nullav;
5096 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5097 realarray = 1;
8ec5e241 5098 PUTBACK;
a0d0e21e
LW		 5099 av_extend(ary,0);
5100 av_clear(ary);
8ec5e241 5101 SPAGAIN;
155aba94 5102 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
8ec5e241 5103 PUSHMARK(SP);
33c27489 5104 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 5105 }
5106 else {
1c0b011c
NIS		 5107 if (!AvREAL(ary)) {
5108 AvREAL_on(ary);
abff13bb 5109 AvREIFY_off(ary);
1c0b011c 5110 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 5111 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5112 }
5113 /* temporarily switch stacks */
3280af22 5114 SWITCHSTACK(PL_curstack, ary);
8ec5e241 5115 make_mortal = 0;
1c0b011c 5116 }
79072805 5117 }
3280af22 5118 base = SP - PL_stack_base;
a0d0e21e
LW		 5119 orig = s;
5120 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 5121 if (pm->op_pmflags & PMf_LOCALE) {
5122 while (isSPACE_LC(*s))
5123 s++;
5124 }
5125 else {
5126 while (isSPACE(*s))
5127 s++;
5128 }
a0d0e21e 5129 }
c07a80fd 5130 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS		 5131 SAVEINT(PL_multiline);
5132 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 5133 }
5134
a0d0e21e
LW		 5135 if (!limit)
5136 limit = maxiters + 2;
5137 if (pm->op_pmflags & PMf_WHITE) {
5138 while (--limit) {
bbce6d69 5139 m = s;
5140 while (m < strend &&
5141 !((pm->op_pmflags & PMf_LOCALE)
5142 ? isSPACE_LC(*m) : isSPACE(*m)))
5143 ++m;
a0d0e21e
LW		 5144 if (m >= strend)
5145 break;
bbce6d69 5146
a0d0e21e
LW		 5147 dstr = NEWSV(30, m-s);
5148 sv_setpvn(dstr, s, m-s);
8ec5e241 5149 if (make_mortal)
a0d0e21e 5150 sv_2mortal(dstr);
1145892d 5151 if (do_utf8)
72d299db 5152 (void)SvUTF8_on(dstr);
a0d0e21e 5153 XPUSHs(dstr);
bbce6d69 5154
5155 s = m + 1;
5156 while (s < strend &&
5157 ((pm->op_pmflags & PMf_LOCALE)
5158 ? isSPACE_LC(*s) : isSPACE(*s)))
5159 ++s;
79072805
LW		 5160 }
5161 }
f4091fba 5162 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 5163 while (--limit) {
5164 /*SUPPRESS 530*/
5165 for (m = s; m < strend && *m != '\n'; m++) ;
5166 m++;
5167 if (m >= strend)
5168 break;
5169 dstr = NEWSV(30, m-s);
5170 sv_setpvn(dstr, s, m-s);
8ec5e241 5171 if (make_mortal)
a0d0e21e 5172 sv_2mortal(dstr);
1145892d 5173 if (do_utf8)
72d299db 5174 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 5175 XPUSHs(dstr);
5176 s = m;
5177 }
5178 }
f722798b 5179 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 5180 && (rx->reganch & ROPT_CHECK_ALL)
5181 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 5182 int tail = (rx->reganch & RE_INTUIT_TAIL);
5183 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
cf93c79d 5184
ca5b42cb 5185 len = rx->minlen;
0da47da8 5186 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
e2439105
GS		 5187 STRLEN n_a;
5188 char c = *SvPV(csv, n_a);
a0d0e21e 5189 while (--limit) {
bbce6d69 5190 /*SUPPRESS 530*/
f722798b 5191 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 5192 if (m >= strend)
5193 break;
5194 dstr = NEWSV(30, m-s);
5195 sv_setpvn(dstr, s, m-s);
8ec5e241 5196 if (make_mortal)
a0d0e21e 5197 sv_2mortal(dstr);
1145892d 5198 if (do_utf8)
72d299db 5199 (void)SvUTF8_on(dstr);
a0d0e21e 5200 XPUSHs(dstr);
e2439105
GS		 5201 /* The rx->minlen is in characters but we want to step
5202 * s ahead by bytes. */
0da47da8
JH		 5203 if (do_utf8)
5204 s = (char*)utf8_hop((U8*)m, len);
5205 else
5206 s = m + len; /* Fake \n at the end */
a0d0e21e
LW		 5207 }
5208 }
5209 else {
5210#ifndef lint
5211 while (s < strend && --limit &&
f722798b
IZ		 5212 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5213 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 5214#endif
a0d0e21e
LW		 5215 {
5216 dstr = NEWSV(31, m-s);
5217 sv_setpvn(dstr, s, m-s);
8ec5e241 5218 if (make_mortal)
a0d0e21e 5219 sv_2mortal(dstr);
1145892d 5220 if (do_utf8)
72d299db 5221 (void)SvUTF8_on(dstr);
a0d0e21e 5222 XPUSHs(dstr);
e2439105
GS		 5223 /* The rx->minlen is in characters but we want to step
5224 * s ahead by bytes. */
0da47da8
JH		 5225 if (do_utf8)
5226 s = (char*)utf8_hop((U8*)m, len);
5227 else
5228 s = m + len; /* Fake \n at the end */
a0d0e21e 5229 }
463ee0b2 5230 }
463ee0b2 5231 }
a0d0e21e 5232 else {
1145892d 5233 maxiters += slen * rx->nparens;
f722798b
IZ		 5234 while (s < strend && --limit
5235/* && (!rx->check_substr
5236 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5237 0, NULL))))
5238*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5239 1 /* minend */, sv, NULL, 0))
bbce6d69 5240 {
d9f97599 5241 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 5242 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 5243 m = s;
5244 s = orig;
cf93c79d 5245 orig = rx->subbeg;
a0d0e21e
LW		 5246 s = orig + (m - s);
5247 strend = s + (strend - m);
5248 }
cf93c79d 5249 m = rx->startp[0] + orig;
a0d0e21e
LW		 5250 dstr = NEWSV(32, m-s);
5251 sv_setpvn(dstr, s, m-s);
8ec5e241 5252 if (make_mortal)
a0d0e21e 5253 sv_2mortal(dstr);
1145892d 5254 if (do_utf8)
72d299db 5255 (void)SvUTF8_on(dstr);
a0d0e21e 5256 XPUSHs(dstr);
d9f97599
GS		 5257 if (rx->nparens) {
5258 for (i = 1; i <= rx->nparens; i++) {
cf93c79d
IZ		 5259 s = rx->startp[i] + orig;
5260 m = rx->endp[i] + orig;
748a9306
LW		 5261 if (m && s) {
5262 dstr = NEWSV(33, m-s);
5263 sv_setpvn(dstr, s, m-s);
5264 }
5265 else
5266 dstr = NEWSV(33, 0);
8ec5e241 5267 if (make_mortal)
a0d0e21e 5268 sv_2mortal(dstr);
1145892d 5269 if (do_utf8)
72d299db 5270 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 5271 XPUSHs(dstr);
5272 }
5273 }
cf93c79d 5274 s = rx->endp[0] + orig;
a0d0e21e 5275 }
79072805 5276 }
8ec5e241 5277
c07a80fd 5278 LEAVE_SCOPE(oldsave);
3280af22 5279 iters = (SP - PL_stack_base) - base;
a0d0e21e 5280 if (iters > maxiters)
cea2e8a9 5281 DIE(aTHX_ "Split loop");
8ec5e241 5282
a0d0e21e
LW		 5283 /* keep field after final delim? */
5284 if (s < strend || (iters && origlimit)) {
e2439105
GS		 5285 STRLEN l = strend - s;
5286 dstr = NEWSV(34, l);
5287 sv_setpvn(dstr, s, l);
8ec5e241 5288 if (make_mortal)
a0d0e21e 5289 sv_2mortal(dstr);
1145892d 5290 if (do_utf8)
72d299db 5291 (void)SvUTF8_on(dstr);
a0d0e21e
LW		 5292 XPUSHs(dstr);
5293 iters++;
79072805 5294 }
a0d0e21e 5295 else if (!origlimit) {
b1dadf13 5296 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
a0d0e21e
LW		 5297 iters--, SP--;
5298 }
8ec5e241 5299
a0d0e21e 5300 if (realarray) {
8ec5e241 5301 if (!mg) {
1c0b011c
NIS		 5302 SWITCHSTACK(ary, oldstack);
5303 if (SvSMAGICAL(ary)) {
5304 PUTBACK;
5305 mg_set((SV*)ary);
5306 SPAGAIN;
5307 }
5308 if (gimme == G_ARRAY) {
5309 EXTEND(SP, iters);
5310 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5311 SP += iters;
5312 RETURN;
5313 }
8ec5e241 5314 }
1c0b011c 5315 else {
fb73857a 5316 PUTBACK;
8ec5e241 5317 ENTER;
864dbfa3 5318 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 5319 LEAVE;
fb73857a 5320 SPAGAIN;
8ec5e241
NIS		 5321 if (gimme == G_ARRAY) {
5322 /* EXTEND should not be needed - we just popped them */
5323 EXTEND(SP, iters);
5324 for (i=0; i < iters; i++) {
5325 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5326 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5327 }
1c0b011c
NIS		 5328 RETURN;
5329 }
a0d0e21e
LW		 5330 }
5331 }
5332 else {
5333 if (gimme == G_ARRAY)
5334 RETURN;
5335 }
5336 if (iters || !pm->op_pmreplroot) {
5337 GETTARGET;
5338 PUSHi(iters);
5339 RETURN;
5340 }
5341 RETPUSHUNDEF;
79072805 5342}
85e6fe83 5343
c0329465 5344#ifdef USE_THREADS
77a005ab 5345void
864dbfa3 5346Perl_unlock_condpair(pTHX_ void *svv)
c0329465 5347{
c0329465 5348 MAGIC *mg = mg_find((SV*)svv, 'm');
8ec5e241 5349
c0329465 5350 if (!mg)
cea2e8a9 5351 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
c0329465
MB		 5352 MUTEX_LOCK(MgMUTEXP(mg));
5353 if (MgOWNER(mg) != thr)
cea2e8a9 5354 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
c0329465
MB		 5355 MgOWNER(mg) = 0;
5356 COND_SIGNAL(MgOWNERCONDP(mg));
b900a521
JH		 5357 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5358 PTR2UV(thr), PTR2UV(svv));)
c0329465
MB		 5359 MUTEX_UNLOCK(MgMUTEXP(mg));
5360}
5361#endif /* USE_THREADS */
5362
5363PP(pp_lock)
5364{
4e35701f 5365 djSP;
c0329465 5366 dTOPss;
e55aaa0e
MB		 5367 SV *retsv = sv;
5368#ifdef USE_THREADS
1cb75286 5369 sv_lock(sv);
c0329465 5370#endif /* USE_THREADS */
e55aaa0e
MB		 5371 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5372 || SvTYPE(retsv) == SVt_PVCV) {
5373 retsv = refto(retsv);
5374 }
5375 SETs(retsv);
c0329465
MB		 5376 RETURN;
5377}
a863c7d1 5378
2faa37cc 5379PP(pp_threadsv)
a863c7d1 5380{
57d3b86d 5381#ifdef USE_THREADS
155aba94 5382 djSP;
924508f0 5383 EXTEND(SP, 1);
533c011a
NIS		 5384 if (PL_op->op_private & OPpLVAL_INTRO)
5385 PUSHs(*save_threadsv(PL_op->op_targ));
554b3eca 5386 else
533c011a 5387 PUSHs(THREADSV(PL_op->op_targ));
fdb47d66 5388 RETURN;
a863c7d1 5389#else
cea2e8a9 5390 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 5391#endif /* USE_THREADS */
a863c7d1 5392}
Unnamed repository; edit this file 'description' to name the repository.