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