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