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