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
Add libscheck for IRIX.
[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);
e476b1b5
GS		 588 if (ckWARN(WARN_MISC) && len == 0)
589 Perl_warner(aTHX_ WARN_MISC,
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:
e476b1b5
GS		 835 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
836 Perl_warner(aTHX_ WARN_MISC, "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) {
e476b1b5
GS		 2015 if (lvalue || repl)
2016 Perl_croak(aTHX_ "substr outside of string");
2017 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2018 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2304df62
AD		 2019 RETPUSHUNDEF;
2020 }
79072805 2021 else {
7e2040f0 2022 if (utfcurlen) {
a0ed51b3 2023 sv_pos_u2b(sv, &pos, &rem);
7e2040f0
GS		 2024 SvUTF8_on(TARG);
2025 }
79072805 2026 tmps += pos;
79072805 2027 sv_setpvn(TARG, tmps, rem);
c8faf1c5
GS		 2028 if (repl)
2029 sv_insert(sv, pos, rem, repl, repl_len);
2030 else if (lvalue) { /* it's an lvalue! */
dedeecda 2031 if (!SvGMAGICAL(sv)) {
2032 if (SvROK(sv)) {
2d8e6c8d
GS		 2033 STRLEN n_a;
2034 SvPV_force(sv,n_a);
599cee73 2035 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2036 Perl_warner(aTHX_ WARN_SUBSTR,
599cee73 2037 "Attempt to use reference as lvalue in substr");
dedeecda 2038 }
2039 if (SvOK(sv)) /* is it defined ? */
2040 (void)SvPOK_only(sv);
2041 else
2042 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2043 }
5f05dabc 2044
a0d0e21e
LW		 2045 if (SvTYPE(TARG) < SVt_PVLV) {
2046 sv_upgrade(TARG, SVt_PVLV);
2047 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 2048 }
a0d0e21e 2049
5f05dabc 2050 LvTYPE(TARG) = 'x';
6ff81951
GS		 2051 if (LvTARG(TARG) != sv) {
2052 if (LvTARG(TARG))
2053 SvREFCNT_dec(LvTARG(TARG));
2054 LvTARG(TARG) = SvREFCNT_inc(sv);
2055 }
a0d0e21e 2056 LvTARGOFF(TARG) = pos;
8ec5e241 2057 LvTARGLEN(TARG) = rem;
79072805
LW		 2058 }
2059 }
849ca7ee 2060 SPAGAIN;
79072805
LW		 2061 PUSHs(TARG); /* avoid SvSETMAGIC here */
2062 RETURN;
2063}
2064
2065PP(pp_vec)
2066{
4e35701f 2067 djSP; dTARGET;
79072805
LW		 2068 register I32 size = POPi;
2069 register I32 offset = POPi;
2070 register SV *src = POPs;
533c011a 2071 I32 lvalue = PL_op->op_flags & OPf_MOD;
a0d0e21e 2072
81e118e0
JH		 2073 SvTAINTED_off(TARG); /* decontaminate */
2074 if (lvalue) { /* it's an lvalue! */
2075 if (SvTYPE(TARG) < SVt_PVLV) {
2076 sv_upgrade(TARG, SVt_PVLV);
2077 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
79072805 2078 }
81e118e0
JH		 2079 LvTYPE(TARG) = 'v';
2080 if (LvTARG(TARG) != src) {
2081 if (LvTARG(TARG))
2082 SvREFCNT_dec(LvTARG(TARG));
2083 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 2084 }
81e118e0
JH		 2085 LvTARGOFF(TARG) = offset;
2086 LvTARGLEN(TARG) = size;
79072805
LW		 2087 }
2088
81e118e0 2089 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW		 2090 PUSHs(TARG);
2091 RETURN;
2092}
2093
2094PP(pp_index)
2095{
4e35701f 2096 djSP; dTARGET;
79072805
LW		 2097 SV *big;
2098 SV *little;
2099 I32 offset;
2100 I32 retval;
2101 char *tmps;
2102 char *tmps2;
463ee0b2 2103 STRLEN biglen;
3280af22 2104 I32 arybase = PL_curcop->cop_arybase;
79072805
LW		 2105
2106 if (MAXARG < 3)
2107 offset = 0;
2108 else
2109 offset = POPi - arybase;
2110 little = POPs;
2111 big = POPs;
463ee0b2 2112 tmps = SvPV(big, biglen);
7e2040f0 2113 if (offset > 0 && DO_UTF8(big))
a0ed51b3 2114 sv_pos_u2b(big, &offset, 0);
79072805
LW		 2115 if (offset < 0)
2116 offset = 0;
93a17b20
LW		 2117 else if (offset > biglen)
2118 offset = biglen;
79072805 2119 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2120 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 2121 retval = -1;
79072805 2122 else
a0ed51b3 2123 retval = tmps2 - tmps;
7e2040f0 2124 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 2125 sv_pos_b2u(big, &retval);
2126 PUSHi(retval + arybase);
79072805
LW		 2127 RETURN;
2128}
2129
2130PP(pp_rindex)
2131{
4e35701f 2132 djSP; dTARGET;
79072805
LW		 2133 SV *big;
2134 SV *little;
463ee0b2
LW		 2135 STRLEN blen;
2136 STRLEN llen;
79072805
LW		 2137 I32 offset;
2138 I32 retval;
2139 char *tmps;
2140 char *tmps2;
3280af22 2141 I32 arybase = PL_curcop->cop_arybase;
79072805 2142
a0d0e21e 2143 if (MAXARG >= 3)
a0ed51b3 2144 offset = POPi;
79072805
LW		 2145 little = POPs;
2146 big = POPs;
463ee0b2
LW		 2147 tmps2 = SvPV(little, llen);
2148 tmps = SvPV(big, blen);
79072805 2149 if (MAXARG < 3)
463ee0b2 2150 offset = blen;
a0ed51b3 2151 else {
7e2040f0 2152 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW		 2153 sv_pos_u2b(big, &offset, 0);
2154 offset = offset - arybase + llen;
2155 }
79072805
LW		 2156 if (offset < 0)
2157 offset = 0;
463ee0b2
LW		 2158 else if (offset > blen)
2159 offset = blen;
79072805 2160 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2161 tmps2, tmps2 + llen)))
a0ed51b3 2162 retval = -1;
79072805 2163 else
a0ed51b3 2164 retval = tmps2 - tmps;
7e2040f0 2165 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW		 2166 sv_pos_b2u(big, &retval);
2167 PUSHi(retval + arybase);
79072805
LW		 2168 RETURN;
2169}
2170
2171PP(pp_sprintf)
2172{
4e35701f 2173 djSP; dMARK; dORIGMARK; dTARGET;
79072805 2174 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2175 TAINT_IF(SvTAINTED(TARG));
79072805
LW		 2176 SP = ORIGMARK;
2177 PUSHTARG;
2178 RETURN;
2179}
2180
79072805
LW		 2181PP(pp_ord)
2182{
4e35701f 2183 djSP; dTARGET;
bdeef251 2184 UV value;
2d8e6c8d 2185 STRLEN n_a;
7e2040f0
GS		 2186 SV *tmpsv = POPs;
2187 U8 *tmps = (U8*)SvPVx(tmpsv,n_a);
a0ed51b3 2188 I32 retlen;
79072805 2189
7e2040f0 2190 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
bdeef251 2191 value = utf8_to_uv(tmps, &retlen);
a0ed51b3 2192 else
bdeef251
GA		 2193 value = (UV)(*tmps & 255);
2194 XPUSHu(value);
79072805
LW		 2195 RETURN;
2196}
2197
463ee0b2
LW		 2198PP(pp_chr)
2199{
4e35701f 2200 djSP; dTARGET;
463ee0b2 2201 char *tmps;
3b9be786 2202 U32 value = POPu;
463ee0b2 2203
748a9306 2204 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 2205
3969a896 2206 if (value > 255 && !IN_BYTE) {
aa6ffa16 2207 SvGROW(TARG, UTF8_MAXLEN+1);
a0ed51b3 2208 tmps = SvPVX(TARG);
dfe13c55 2209 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
a0ed51b3
LW		 2210 SvCUR_set(TARG, tmps - SvPVX(TARG));
2211 *tmps = '\0';
2212 (void)SvPOK_only(TARG);
aa6ffa16 2213 SvUTF8_on(TARG);
a0ed51b3
LW		 2214 XPUSHs(TARG);
2215 RETURN;
2216 }
2217
748a9306 2218 SvGROW(TARG,2);
463ee0b2
LW		 2219 SvCUR_set(TARG, 1);
2220 tmps = SvPVX(TARG);
a0ed51b3 2221 *tmps++ = value;
748a9306 2222 *tmps = '\0';
3969a896 2223 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 2224 (void)SvPOK_only(TARG);
463ee0b2
LW		 2225 XPUSHs(TARG);
2226 RETURN;
2227}
2228
79072805
LW		 2229PP(pp_crypt)
2230{
4e35701f 2231 djSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 2232 STRLEN n_a;
79072805 2233#ifdef HAS_CRYPT
2d8e6c8d 2234 char *tmps = SvPV(left, n_a);
79072805 2235#ifdef FCRYPT
2d8e6c8d 2236 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 2237#else
2d8e6c8d 2238 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW		 2239#endif
2240#else
cea2e8a9 2241 DIE(aTHX_
79072805
LW		 2242 "The crypt() function is unimplemented due to excessive paranoia.");
2243#endif
2244 SETs(TARG);
2245 RETURN;
2246}
2247
2248PP(pp_ucfirst)
2249{
4e35701f 2250 djSP;
79072805 2251 SV *sv = TOPs;
a0ed51b3
LW		 2252 register U8 *s;
2253 STRLEN slen;
2254
7e2040f0 2255 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
a0ed51b3 2256 I32 ulen;
806e7201 2257 U8 tmpbuf[UTF8_MAXLEN];
a0ed51b3
LW		 2258 U8 *tend;
2259 UV uv = utf8_to_uv(s, &ulen);
2260
2261 if (PL_op->op_private & OPpLOCALE) {
2262 TAINT;
2263 SvTAINTED_on(sv);
2264 uv = toTITLE_LC_uni(uv);
2265 }
2266 else
2267 uv = toTITLE_utf8(s);
2268
2269 tend = uv_to_utf8(tmpbuf, uv);
2270
014822e4 2271 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2272 dTARGET;
dfe13c55
GS		 2273 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2274 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 2275 SvUTF8_on(TARG);
a0ed51b3
LW		 2276 SETs(TARG);
2277 }
2278 else {
dfe13c55 2279 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW		 2280 Copy(tmpbuf, s, ulen, U8);
2281 }
a0ed51b3 2282 }
626727d5 2283 else {
014822e4 2284 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2285 dTARGET;
7e2040f0 2286 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2287 sv_setsv(TARG, sv);
2288 sv = TARG;
2289 SETs(sv);
2290 }
2291 s = (U8*)SvPV_force(sv, slen);
2292 if (*s) {
2293 if (PL_op->op_private & OPpLOCALE) {
2294 TAINT;
2295 SvTAINTED_on(sv);
2296 *s = toUPPER_LC(*s);
2297 }
2298 else
2299 *s = toUPPER(*s);
bbce6d69 2300 }
bbce6d69 2301 }
31351b04
JS		 2302 if (SvSMAGICAL(sv))
2303 mg_set(sv);
79072805
LW		 2304 RETURN;
2305}
2306
2307PP(pp_lcfirst)
2308{
4e35701f 2309 djSP;
79072805 2310 SV *sv = TOPs;
a0ed51b3
LW		 2311 register U8 *s;
2312 STRLEN slen;
2313
7e2040f0 2314 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
a0ed51b3 2315 I32 ulen;
806e7201 2316 U8 tmpbuf[UTF8_MAXLEN];
a0ed51b3
LW		 2317 U8 *tend;
2318 UV uv = utf8_to_uv(s, &ulen);
2319
2320 if (PL_op->op_private & OPpLOCALE) {
2321 TAINT;
2322 SvTAINTED_on(sv);
2323 uv = toLOWER_LC_uni(uv);
2324 }
2325 else
2326 uv = toLOWER_utf8(s);
2327
2328 tend = uv_to_utf8(tmpbuf, uv);
2329
014822e4 2330 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2331 dTARGET;
dfe13c55
GS		 2332 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2333 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 2334 SvUTF8_on(TARG);
a0ed51b3
LW		 2335 SETs(TARG);
2336 }
2337 else {
dfe13c55 2338 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW		 2339 Copy(tmpbuf, s, ulen, U8);
2340 }
a0ed51b3 2341 }
626727d5 2342 else {
014822e4 2343 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2344 dTARGET;
7e2040f0 2345 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2346 sv_setsv(TARG, sv);
2347 sv = TARG;
2348 SETs(sv);
2349 }
2350 s = (U8*)SvPV_force(sv, slen);
2351 if (*s) {
2352 if (PL_op->op_private & OPpLOCALE) {
2353 TAINT;
2354 SvTAINTED_on(sv);
2355 *s = toLOWER_LC(*s);
2356 }
2357 else
2358 *s = toLOWER(*s);
bbce6d69 2359 }
bbce6d69 2360 }
31351b04
JS		 2361 if (SvSMAGICAL(sv))
2362 mg_set(sv);
79072805
LW		 2363 RETURN;
2364}
2365
2366PP(pp_uc)
2367{
4e35701f 2368 djSP;
79072805 2369 SV *sv = TOPs;
a0ed51b3 2370 register U8 *s;
463ee0b2 2371 STRLEN len;
79072805 2372
7e2040f0 2373 if (DO_UTF8(sv)) {
a0ed51b3
LW		 2374 dTARGET;
2375 I32 ulen;
2376 register U8 *d;
2377 U8 *send;
2378
dfe13c55 2379 s = (U8*)SvPV(sv,len);
a5a20234 2380 if (!len) {
7e2040f0 2381 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 2382 sv_setpvn(TARG, "", 0);
2383 SETs(TARG);
a0ed51b3
LW		 2384 }
2385 else {
31351b04
JS		 2386 (void)SvUPGRADE(TARG, SVt_PV);
2387 SvGROW(TARG, (len * 2) + 1);
2388 (void)SvPOK_only(TARG);
2389 d = (U8*)SvPVX(TARG);
2390 send = s + len;
2391 if (PL_op->op_private & OPpLOCALE) {
2392 TAINT;
2393 SvTAINTED_on(TARG);
2394 while (s < send) {
2395 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, &ulen)));
2396 s += ulen;
2397 }
a0ed51b3 2398 }
31351b04
JS		 2399 else {
2400 while (s < send) {
2401 d = uv_to_utf8(d, toUPPER_utf8( s ));
2402 s += UTF8SKIP(s);
2403 }
a0ed51b3 2404 }
31351b04 2405 *d = '\0';
7e2040f0 2406 SvUTF8_on(TARG);
31351b04
JS		 2407 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2408 SETs(TARG);
a0ed51b3 2409 }
a0ed51b3 2410 }
626727d5 2411 else {
014822e4 2412 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2413 dTARGET;
7e2040f0 2414 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2415 sv_setsv(TARG, sv);
2416 sv = TARG;
2417 SETs(sv);
2418 }
2419 s = (U8*)SvPV_force(sv, len);
2420 if (len) {
2421 register U8 *send = s + len;
2422
2423 if (PL_op->op_private & OPpLOCALE) {
2424 TAINT;
2425 SvTAINTED_on(sv);
2426 for (; s < send; s++)
2427 *s = toUPPER_LC(*s);
2428 }
2429 else {
2430 for (; s < send; s++)
2431 *s = toUPPER(*s);
2432 }
bbce6d69 2433 }
79072805 2434 }
31351b04
JS		 2435 if (SvSMAGICAL(sv))
2436 mg_set(sv);
79072805
LW		 2437 RETURN;
2438}
2439
2440PP(pp_lc)
2441{
4e35701f 2442 djSP;
79072805 2443 SV *sv = TOPs;
a0ed51b3 2444 register U8 *s;
463ee0b2 2445 STRLEN len;
79072805 2446
7e2040f0 2447 if (DO_UTF8(sv)) {
a0ed51b3
LW		 2448 dTARGET;
2449 I32 ulen;
2450 register U8 *d;
2451 U8 *send;
2452
dfe13c55 2453 s = (U8*)SvPV(sv,len);
a5a20234 2454 if (!len) {
7e2040f0 2455 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW		 2456 sv_setpvn(TARG, "", 0);
2457 SETs(TARG);
a0ed51b3
LW		 2458 }
2459 else {
31351b04
JS		 2460 (void)SvUPGRADE(TARG, SVt_PV);
2461 SvGROW(TARG, (len * 2) + 1);
2462 (void)SvPOK_only(TARG);
2463 d = (U8*)SvPVX(TARG);
2464 send = s + len;
2465 if (PL_op->op_private & OPpLOCALE) {
2466 TAINT;
2467 SvTAINTED_on(TARG);
2468 while (s < send) {
2469 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, &ulen)));
2470 s += ulen;
2471 }
a0ed51b3 2472 }
31351b04
JS		 2473 else {
2474 while (s < send) {
2475 d = uv_to_utf8(d, toLOWER_utf8(s));
2476 s += UTF8SKIP(s);
2477 }
a0ed51b3 2478 }
31351b04 2479 *d = '\0';
7e2040f0 2480 SvUTF8_on(TARG);
31351b04
JS		 2481 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2482 SETs(TARG);
a0ed51b3 2483 }
79072805 2484 }
626727d5 2485 else {
014822e4 2486 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2487 dTARGET;
7e2040f0 2488 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS		 2489 sv_setsv(TARG, sv);
2490 sv = TARG;
2491 SETs(sv);
a0ed51b3 2492 }
bbce6d69 2493
31351b04
JS		 2494 s = (U8*)SvPV_force(sv, len);
2495 if (len) {
2496 register U8 *send = s + len;
bbce6d69 2497
31351b04
JS		 2498 if (PL_op->op_private & OPpLOCALE) {
2499 TAINT;
2500 SvTAINTED_on(sv);
2501 for (; s < send; s++)
2502 *s = toLOWER_LC(*s);
2503 }
2504 else {
2505 for (; s < send; s++)
2506 *s = toLOWER(*s);
2507 }
bbce6d69 2508 }
79072805 2509 }
31351b04
JS		 2510 if (SvSMAGICAL(sv))
2511 mg_set(sv);
79072805
LW		 2512 RETURN;
2513}
2514
a0d0e21e 2515PP(pp_quotemeta)
79072805 2516{
4e35701f 2517 djSP; dTARGET;
a0d0e21e
LW		 2518 SV *sv = TOPs;
2519 STRLEN len;
2520 register char *s = SvPV(sv,len);
2521 register char *d;
79072805 2522
7e2040f0 2523 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW		 2524 if (len) {
2525 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2526 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 2527 d = SvPVX(TARG);
7e2040f0 2528 if (DO_UTF8(sv)) {
0dd2cdef
LW		 2529 while (len) {
2530 if (*s & 0x80) {
2531 STRLEN ulen = UTF8SKIP(s);
2532 if (ulen > len)
2533 ulen = len;
2534 len -= ulen;
2535 while (ulen--)
2536 *d++ = *s++;
2537 }
2538 else {
2539 if (!isALNUM(*s))
2540 *d++ = '\\';
2541 *d++ = *s++;
2542 len--;
2543 }
2544 }
7e2040f0 2545 SvUTF8_on(TARG);
0dd2cdef
LW		 2546 }
2547 else {
2548 while (len--) {
2549 if (!isALNUM(*s))
2550 *d++ = '\\';
2551 *d++ = *s++;
2552 }
79072805 2553 }
a0d0e21e
LW		 2554 *d = '\0';
2555 SvCUR_set(TARG, d - SvPVX(TARG));
2556 (void)SvPOK_only(TARG);
79072805 2557 }
a0d0e21e
LW		 2558 else
2559 sv_setpvn(TARG, s, len);
2560 SETs(TARG);
31351b04
JS		 2561 if (SvSMAGICAL(TARG))
2562 mg_set(TARG);
79072805
LW		 2563 RETURN;
2564}
2565
a0d0e21e 2566/* Arrays. */
79072805 2567
a0d0e21e 2568PP(pp_aslice)
79072805 2569{
4e35701f 2570 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2571 register SV** svp;
2572 register AV* av = (AV*)POPs;
533c011a 2573 register I32 lval = PL_op->op_flags & OPf_MOD;
3280af22 2574 I32 arybase = PL_curcop->cop_arybase;
748a9306 2575 I32 elem;
79072805 2576
a0d0e21e 2577 if (SvTYPE(av) == SVt_PVAV) {
533c011a 2578 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 2579 I32 max = -1;
924508f0 2580 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW		 2581 elem = SvIVx(*svp);
2582 if (elem > max)
2583 max = elem;
2584 }
2585 if (max > AvMAX(av))
2586 av_extend(av, max);
2587 }
a0d0e21e 2588 while (++MARK <= SP) {
748a9306 2589 elem = SvIVx(*MARK);
a0d0e21e 2590
748a9306
LW		 2591 if (elem > 0)
2592 elem -= arybase;
a0d0e21e
LW		 2593 svp = av_fetch(av, elem, lval);
2594 if (lval) {
3280af22 2595 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 2596 DIE(aTHX_ PL_no_aelem, elem);
533c011a 2597 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2598 save_aelem(av, elem, svp);
79072805 2599 }
3280af22 2600 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2601 }
2602 }
748a9306 2603 if (GIMME != G_ARRAY) {
a0d0e21e
LW		 2604 MARK = ORIGMARK;
2605 *++MARK = *SP;
2606 SP = MARK;
2607 }
79072805
LW		 2608 RETURN;
2609}
2610
2611/* Associative arrays. */
2612
2613PP(pp_each)
2614{
59af0135 2615 djSP;
79072805 2616 HV *hash = (HV*)POPs;
c07a80fd 2617 HE *entry;
54310121 2618 I32 gimme = GIMME_V;
c750a3ec 2619 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2620
c07a80fd 2621 PUTBACK;
c750a3ec
MB		 2622 /* might clobber stack_sp */
2623 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2624 SPAGAIN;
79072805 2625
79072805
LW		 2626 EXTEND(SP, 2);
2627 if (entry) {
54310121 2628 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2629 if (gimme == G_ARRAY) {
59af0135 2630 SV *val;
c07a80fd 2631 PUTBACK;
c750a3ec 2632 /* might clobber stack_sp */
59af0135
GS		 2633 val = realhv ?
2634 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 2635 SPAGAIN;
59af0135 2636 PUSHs(val);
79072805 2637 }
79072805 2638 }
54310121 2639 else if (gimme == G_SCALAR)
79072805
LW		 2640 RETPUSHUNDEF;
2641
2642 RETURN;
2643}
2644
2645PP(pp_values)
2646{
cea2e8a9 2647 return do_kv();
79072805
LW		 2648}
2649
2650PP(pp_keys)
2651{
cea2e8a9 2652 return do_kv();
79072805
LW		 2653}
2654
2655PP(pp_delete)
2656{
4e35701f 2657 djSP;
54310121 2658 I32 gimme = GIMME_V;
2659 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2660 SV *sv;
5f05dabc 2661 HV *hv;
2662
533c011a 2663 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2664 dMARK; dORIGMARK;
97fcbf96 2665 U32 hvtype;
5f05dabc 2666 hv = (HV*)POPs;
97fcbf96 2667 hvtype = SvTYPE(hv);
01020589
GS		 2668 if (hvtype == SVt_PVHV) { /* hash element */
2669 while (++MARK <= SP) {
ae77835f 2670 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS		 2671 *MARK = sv ? sv : &PL_sv_undef;
2672 }
5f05dabc 2673 }
01020589
GS		 2674 else if (hvtype == SVt_PVAV) {
2675 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2676 while (++MARK <= SP) {
2677 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2678 *MARK = sv ? sv : &PL_sv_undef;
2679 }
2680 }
2681 else { /* pseudo-hash element */
2682 while (++MARK <= SP) {
2683 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2684 *MARK = sv ? sv : &PL_sv_undef;
2685 }
2686 }
2687 }
2688 else
2689 DIE(aTHX_ "Not a HASH reference");
54310121 2690 if (discard)
2691 SP = ORIGMARK;
2692 else if (gimme == G_SCALAR) {
5f05dabc 2693 MARK = ORIGMARK;
2694 *++MARK = *SP;
2695 SP = MARK;
2696 }
2697 }
2698 else {
2699 SV *keysv = POPs;
2700 hv = (HV*)POPs;
97fcbf96
MB		 2701 if (SvTYPE(hv) == SVt_PVHV)
2702 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS		 2703 else if (SvTYPE(hv) == SVt_PVAV) {
2704 if (PL_op->op_flags & OPf_SPECIAL)
2705 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2706 else
2707 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2708 }
97fcbf96 2709 else
cea2e8a9 2710 DIE(aTHX_ "Not a HASH reference");
5f05dabc 2711 if (!sv)
3280af22 2712 sv = &PL_sv_undef;
54310121 2713 if (!discard)
2714 PUSHs(sv);
79072805 2715 }
79072805
LW		 2716 RETURN;
2717}
2718
a0d0e21e 2719PP(pp_exists)
79072805 2720{
4e35701f 2721 djSP;
afebc493
GS		 2722 SV *tmpsv;
2723 HV *hv;
2724
2725 if (PL_op->op_private & OPpEXISTS_SUB) {
2726 GV *gv;
2727 CV *cv;
2728 SV *sv = POPs;
2729 cv = sv_2cv(sv, &hv, &gv, FALSE);
2730 if (cv)
2731 RETPUSHYES;
2732 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2733 RETPUSHYES;
2734 RETPUSHNO;
2735 }
2736 tmpsv = POPs;
2737 hv = (HV*)POPs;
c750a3ec 2738 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2739 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 2740 RETPUSHYES;
ef54e1a4
JH		 2741 }
2742 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS		 2743 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2744 if (av_exists((AV*)hv, SvIV(tmpsv)))
2745 RETPUSHYES;
2746 }
2747 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
c750a3ec 2748 RETPUSHYES;
ef54e1a4
JH		 2749 }
2750 else {
cea2e8a9 2751 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 2752 }
a0d0e21e
LW		 2753 RETPUSHNO;
2754}
79072805 2755
a0d0e21e
LW		 2756PP(pp_hslice)
2757{
4e35701f 2758 djSP; dMARK; dORIGMARK;
a0d0e21e 2759 register HV *hv = (HV*)POPs;
533c011a 2760 register I32 lval = PL_op->op_flags & OPf_MOD;
c750a3ec 2761 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2762
0ebe0038 2763 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 2764 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 2765
c750a3ec 2766 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2767 while (++MARK <= SP) {
f12c7020 2768 SV *keysv = *MARK;
ae77835f
MB		 2769 SV **svp;
2770 if (realhv) {
800e9ae0 2771 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 2772 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH		 2773 }
2774 else {
97fcbf96 2775 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2776 }
a0d0e21e 2777 if (lval) {
2d8e6c8d
GS		 2778 if (!svp || *svp == &PL_sv_undef) {
2779 STRLEN n_a;
cea2e8a9 2780 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 2781 }
533c011a 2782 if (PL_op->op_private & OPpLVAL_INTRO)
800e9ae0 2783 save_helem(hv, keysv, svp);
93a17b20 2784 }
3280af22 2785 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2786 }
2787 }
a0d0e21e
LW		 2788 if (GIMME != G_ARRAY) {
2789 MARK = ORIGMARK;
2790 *++MARK = *SP;
2791 SP = MARK;
79072805 2792 }
a0d0e21e
LW		 2793 RETURN;
2794}
2795
2796/* List operators. */
2797
2798PP(pp_list)
2799{
4e35701f 2800 djSP; dMARK;
a0d0e21e
LW		 2801 if (GIMME != G_ARRAY) {
2802 if (++MARK <= SP)
2803 *MARK = *SP; /* unwanted list, return last item */
8990e307 2804 else
3280af22 2805 *MARK = &PL_sv_undef;
a0d0e21e 2806 SP = MARK;
79072805 2807 }
a0d0e21e 2808 RETURN;
79072805
LW		 2809}
2810
a0d0e21e 2811PP(pp_lslice)
79072805 2812{
4e35701f 2813 djSP;
3280af22
NIS		 2814 SV **lastrelem = PL_stack_sp;
2815 SV **lastlelem = PL_stack_base + POPMARK;
2816 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2817 register SV **firstrelem = lastlelem + 1;
3280af22 2818 I32 arybase = PL_curcop->cop_arybase;
533c011a 2819 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2820 I32 is_something_there = lval;
79072805 2821
a0d0e21e
LW		 2822 register I32 max = lastrelem - lastlelem;
2823 register SV **lelem;
2824 register I32 ix;
2825
2826 if (GIMME != G_ARRAY) {
748a9306
LW		 2827 ix = SvIVx(*lastlelem);
2828 if (ix < 0)
2829 ix += max;
2830 else
2831 ix -= arybase;
a0d0e21e 2832 if (ix < 0 || ix >= max)
3280af22 2833 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 2834 else
2835 *firstlelem = firstrelem[ix];
2836 SP = firstlelem;
2837 RETURN;
2838 }
2839
2840 if (max == 0) {
2841 SP = firstlelem - 1;
2842 RETURN;
2843 }
2844
2845 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2846 ix = SvIVx(*lelem);
c73bf8e3 2847 if (ix < 0)
a0d0e21e 2848 ix += max;
c73bf8e3 2849 else
748a9306 2850 ix -= arybase;
c73bf8e3
HS		 2851 if (ix < 0 || ix >= max)
2852 *lelem = &PL_sv_undef;
2853 else {
2854 is_something_there = TRUE;
2855 if (!(*lelem = firstrelem[ix]))
3280af22 2856 *lelem = &PL_sv_undef;
748a9306 2857 }
79072805 2858 }
4633a7c4
LW		 2859 if (is_something_there)
2860 SP = lastlelem;
2861 else
2862 SP = firstlelem - 1;
79072805
LW		 2863 RETURN;
2864}
2865
a0d0e21e
LW		 2866PP(pp_anonlist)
2867{
4e35701f 2868 djSP; dMARK; dORIGMARK;
a0d0e21e 2869 I32 items = SP - MARK;
44a8e56a 2870 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2871 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2872 XPUSHs(av);
a0d0e21e
LW		 2873 RETURN;
2874}
2875
2876PP(pp_anonhash)
79072805 2877{
4e35701f 2878 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2879 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2880
2881 while (MARK < SP) {
2882 SV* key = *++MARK;
a0d0e21e
LW		 2883 SV *val = NEWSV(46, 0);
2884 if (MARK < SP)
2885 sv_setsv(val, *++MARK);
e476b1b5
GS		 2886 else if (ckWARN(WARN_MISC))
2887 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
f12c7020 2888 (void)hv_store_ent(hv,key,val,0);
79072805 2889 }
a0d0e21e
LW		 2890 SP = ORIGMARK;
2891 XPUSHs((SV*)hv);
79072805
LW		 2892 RETURN;
2893}
2894
a0d0e21e 2895PP(pp_splice)
79072805 2896{
4e35701f 2897 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2898 register AV *ary = (AV*)*++MARK;
2899 register SV **src;
2900 register SV **dst;
2901 register I32 i;
2902 register I32 offset;
2903 register I32 length;
2904 I32 newlen;
2905 I32 after;
2906 I32 diff;
2907 SV **tmparyval = 0;
93965878
NIS		 2908 MAGIC *mg;
2909
33c27489
GS		 2910 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2911 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2912 PUSHMARK(MARK);
8ec5e241 2913 PUTBACK;
a60c0954 2914 ENTER;
864dbfa3 2915 call_method("SPLICE",GIMME_V);
a60c0954 2916 LEAVE;
93965878
NIS		 2917 SPAGAIN;
2918 RETURN;
2919 }
79072805 2920
a0d0e21e 2921 SP++;
79072805 2922
a0d0e21e 2923 if (++MARK < SP) {
84902520 2924 offset = i = SvIVx(*MARK);
a0d0e21e 2925 if (offset < 0)
93965878 2926 offset += AvFILLp(ary) + 1;
a0d0e21e 2927 else
3280af22 2928 offset -= PL_curcop->cop_arybase;
84902520 2929 if (offset < 0)
cea2e8a9 2930 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 2931 if (++MARK < SP) {
2932 length = SvIVx(*MARK++);
48cdf507
GA		 2933 if (length < 0) {
2934 length += AvFILLp(ary) - offset + 1;
2935 if (length < 0)
2936 length = 0;
2937 }
79072805
LW		 2938 }
2939 else
a0d0e21e 2940 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2941 }
a0d0e21e
LW		 2942 else {
2943 offset = 0;
2944 length = AvMAX(ary) + 1;
2945 }
93965878
NIS		 2946 if (offset > AvFILLp(ary) + 1)
2947 offset = AvFILLp(ary) + 1;
2948 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 2949 if (after < 0) { /* not that much array */
2950 length += after; /* offset+length now in array */
2951 after = 0;
2952 if (!AvALLOC(ary))
2953 av_extend(ary, 0);
2954 }
2955
2956 /* At this point, MARK .. SP-1 is our new LIST */
2957
2958 newlen = SP - MARK;
2959 diff = newlen - length;
13d7cbc1
GS		 2960 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2961 av_reify(ary);
a0d0e21e
LW		 2962
2963 if (diff < 0) { /* shrinking the area */
2964 if (newlen) {
2965 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2966 Copy(MARK, tmparyval, newlen, SV*);
79072805 2967 }
a0d0e21e
LW		 2968
2969 MARK = ORIGMARK + 1;
2970 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2971 MEXTEND(MARK, length);
2972 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2973 if (AvREAL(ary)) {
bbce6d69 2974 EXTEND_MORTAL(length);
36477c24 2975 for (i = length, dst = MARK; i; i--) {
d689ffdd 2976 sv_2mortal(*dst); /* free them eventualy */
36477c24 2977 dst++;
2978 }
a0d0e21e
LW		 2979 }
2980 MARK += length - 1;
79072805 2981 }
a0d0e21e
LW		 2982 else {
2983 *MARK = AvARRAY(ary)[offset+length-1];
2984 if (AvREAL(ary)) {
d689ffdd 2985 sv_2mortal(*MARK);
a0d0e21e
LW		 2986 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2987 SvREFCNT_dec(*dst++); /* free them now */
79072805 2988 }
a0d0e21e 2989 }
93965878 2990 AvFILLp(ary) += diff;
a0d0e21e
LW		 2991
2992 /* pull up or down? */
2993
2994 if (offset < after) { /* easier to pull up */
2995 if (offset) { /* esp. if nothing to pull */
2996 src = &AvARRAY(ary)[offset-1];
2997 dst = src - diff; /* diff is negative */
2998 for (i = offset; i > 0; i--) /* can't trust Copy */
2999 *dst-- = *src--;
79072805 3000 }
a0d0e21e
LW		 3001 dst = AvARRAY(ary);
3002 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3003 AvMAX(ary) += diff;
3004 }
3005 else {
3006 if (after) { /* anything to pull down? */
3007 src = AvARRAY(ary) + offset + length;
3008 dst = src + diff; /* diff is negative */
3009 Move(src, dst, after, SV*);
79072805 3010 }
93965878 3011 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 3012 /* avoid later double free */
3013 }
3014 i = -diff;
3015 while (i)
3280af22 3016 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 3017
3018 if (newlen) {
3019 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3020 newlen; newlen--) {
3021 *dst = NEWSV(46, 0);
3022 sv_setsv(*dst++, *src++);
79072805 3023 }
a0d0e21e
LW		 3024 Safefree(tmparyval);
3025 }
3026 }
3027 else { /* no, expanding (or same) */
3028 if (length) {
3029 New(452, tmparyval, length, SV*); /* so remember deletion */
3030 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3031 }
3032
3033 if (diff > 0) { /* expanding */
3034
3035 /* push up or down? */
3036
3037 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3038 if (offset) {
3039 src = AvARRAY(ary);
3040 dst = src - diff;
3041 Move(src, dst, offset, SV*);
79072805 3042 }
a0d0e21e
LW		 3043 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3044 AvMAX(ary) += diff;
93965878 3045 AvFILLp(ary) += diff;
79072805
LW		 3046 }
3047 else {
93965878
NIS		 3048 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3049 av_extend(ary, AvFILLp(ary) + diff);
3050 AvFILLp(ary) += diff;
a0d0e21e
LW		 3051
3052 if (after) {
93965878 3053 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 3054 src = dst - diff;
3055 for (i = after; i; i--) {
3056 *dst-- = *src--;
3057 }
79072805
LW		 3058 }
3059 }
a0d0e21e
LW		 3060 }
3061
3062 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3063 *dst = NEWSV(46, 0);
3064 sv_setsv(*dst++, *src++);
3065 }
3066 MARK = ORIGMARK + 1;
3067 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3068 if (length) {
3069 Copy(tmparyval, MARK, length, SV*);
3070 if (AvREAL(ary)) {
bbce6d69 3071 EXTEND_MORTAL(length);
36477c24 3072 for (i = length, dst = MARK; i; i--) {
d689ffdd 3073 sv_2mortal(*dst); /* free them eventualy */
36477c24 3074 dst++;
3075 }
79072805 3076 }
a0d0e21e 3077 Safefree(tmparyval);
79072805 3078 }
a0d0e21e
LW		 3079 MARK += length - 1;
3080 }
3081 else if (length--) {
3082 *MARK = tmparyval[length];
3083 if (AvREAL(ary)) {
d689ffdd 3084 sv_2mortal(*MARK);
a0d0e21e
LW		 3085 while (length-- > 0)
3086 SvREFCNT_dec(tmparyval[length]);
79072805 3087 }
a0d0e21e 3088 Safefree(tmparyval);
79072805 3089 }
a0d0e21e 3090 else
3280af22 3091 *MARK = &PL_sv_undef;
79072805 3092 }
a0d0e21e 3093 SP = MARK;
79072805
LW		 3094 RETURN;
3095}
3096
a0d0e21e 3097PP(pp_push)
79072805 3098{
4e35701f 3099 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3100 register AV *ary = (AV*)*++MARK;
3280af22 3101 register SV *sv = &PL_sv_undef;
93965878 3102 MAGIC *mg;
79072805 3103
33c27489
GS		 3104 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3105 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 3106 PUSHMARK(MARK);
3107 PUTBACK;
a60c0954 3108 ENTER;
864dbfa3 3109 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 3110 LEAVE;
93965878 3111 SPAGAIN;
93965878 3112 }
a60c0954
NIS		 3113 else {
3114 /* Why no pre-extend of ary here ? */
3115 for (++MARK; MARK <= SP; MARK++) {
3116 sv = NEWSV(51, 0);
3117 if (*MARK)
3118 sv_setsv(sv, *MARK);
3119 av_push(ary, sv);
3120 }
79072805
LW		 3121 }
3122 SP = ORIGMARK;
a0d0e21e 3123 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 3124 RETURN;
3125}
3126
a0d0e21e 3127PP(pp_pop)
79072805 3128{
4e35701f 3129 djSP;
a0d0e21e
LW		 3130 AV *av = (AV*)POPs;
3131 SV *sv = av_pop(av);
d689ffdd 3132 if (AvREAL(av))
a0d0e21e
LW		 3133 (void)sv_2mortal(sv);
3134 PUSHs(sv);
79072805 3135 RETURN;
79072805
LW		 3136}
3137
a0d0e21e 3138PP(pp_shift)
79072805 3139{
4e35701f 3140 djSP;
a0d0e21e
LW		 3141 AV *av = (AV*)POPs;
3142 SV *sv = av_shift(av);
79072805 3143 EXTEND(SP, 1);
a0d0e21e 3144 if (!sv)
79072805 3145 RETPUSHUNDEF;
d689ffdd 3146 if (AvREAL(av))
a0d0e21e
LW		 3147 (void)sv_2mortal(sv);
3148 PUSHs(sv);
79072805 3149 RETURN;
79072805
LW		 3150}
3151
a0d0e21e 3152PP(pp_unshift)
79072805 3153{
4e35701f 3154 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3155 register AV *ary = (AV*)*++MARK;
3156 register SV *sv;
3157 register I32 i = 0;
93965878
NIS		 3158 MAGIC *mg;
3159
33c27489
GS		 3160 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3161 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 3162 PUSHMARK(MARK);
93965878 3163 PUTBACK;
a60c0954 3164 ENTER;
864dbfa3 3165 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 3166 LEAVE;
93965878 3167 SPAGAIN;
93965878 3168 }
a60c0954
NIS		 3169 else {
3170 av_unshift(ary, SP - MARK);
3171 while (MARK < SP) {
3172 sv = NEWSV(27, 0);
3173 sv_setsv(sv, *++MARK);
3174 (void)av_store(ary, i++, sv);
3175 }
79072805 3176 }
a0d0e21e
LW		 3177 SP = ORIGMARK;
3178 PUSHi( AvFILL(ary) + 1 );
79072805 3179 RETURN;
79072805
LW		 3180}
3181
a0d0e21e 3182PP(pp_reverse)
79072805 3183{
4e35701f 3184 djSP; dMARK;
a0d0e21e
LW		 3185 register SV *tmp;
3186 SV **oldsp = SP;
79072805 3187
a0d0e21e
LW		 3188 if (GIMME == G_ARRAY) {
3189 MARK++;
3190 while (MARK < SP) {
3191 tmp = *MARK;
3192 *MARK++ = *SP;
3193 *SP-- = tmp;
3194 }
dd58a1ab 3195 /* safe as long as stack cannot get extended in the above */
a0d0e21e 3196 SP = oldsp;
79072805
LW		 3197 }
3198 else {
a0d0e21e
LW		 3199 register char *up;
3200 register char *down;
3201 register I32 tmp;
3202 dTARGET;
3203 STRLEN len;
79072805 3204
7e2040f0 3205 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 3206 if (SP - MARK > 1)
3280af22 3207 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 3208 else
54b9620d 3209 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 3210 up = SvPV_force(TARG, len);
3211 if (len > 1) {
7e2040f0 3212 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS		 3213 U8* s = (U8*)SvPVX(TARG);
3214 U8* send = (U8*)(s + len);
a0ed51b3
LW		 3215 while (s < send) {
3216 if (*s < 0x80) {
3217 s++;
3218 continue;
3219 }
3220 else {
dfe13c55 3221 up = (char*)s;
a0ed51b3 3222 s += UTF8SKIP(s);
dfe13c55 3223 down = (char*)(s - 1);
f248d071
GS		 3224 if (s > send || !((*down & 0xc0) == 0x80)) {
3225 if (ckWARN_d(WARN_UTF8))
3226 Perl_warner(aTHX_ WARN_UTF8,
3227 "Malformed UTF-8 character");
a0ed51b3
LW		 3228 break;
3229 }
3230 while (down > up) {
3231 tmp = *up;
3232 *up++ = *down;
3233 *down-- = tmp;
3234 }
3235 }
3236 }
3237 up = SvPVX(TARG);
3238 }
a0d0e21e
LW		 3239 down = SvPVX(TARG) + len - 1;
3240 while (down > up) {
3241 tmp = *up;
3242 *up++ = *down;
3243 *down-- = tmp;
3244 }
3245 (void)SvPOK_only(TARG);
79072805 3246 }
a0d0e21e
LW		 3247 SP = MARK + 1;
3248 SETTARG;
79072805 3249 }
a0d0e21e 3250 RETURN;
79072805
LW		 3251}
3252
864dbfa3 3253STATIC SV *
cea2e8a9 3254S_mul128(pTHX_ SV *sv, U8 m)
55497cff 3255{
3256 STRLEN len;
3257 char *s = SvPV(sv, len);
3258 char *t;
3259 U32 i = 0;
3260
3261 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
79cb57f6 3262 SV *tmpNew = newSVpvn("0000000000", 10);
55497cff 3263
09b7f37c 3264 sv_catsv(tmpNew, sv);
55497cff 3265 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 3266 sv = tmpNew;
55497cff 3267 s = SvPV(sv, len);
3268 }
3269 t = s + len - 1;
3270 while (!*t) /* trailing '\0'? */
3271 t--;
3272 while (t > s) {
3273 i = ((*t - '0') << 7) + m;
3274 *(t--) = '0' + (i % 10);
3275 m = i / 10;
3276 }
3277 return (sv);
3278}
3279
a0d0e21e
LW		 3280/* Explosives and implosives. */
3281
9d116dd7
JH		 3282#if 'I' == 73 && 'J' == 74
3283/* On an ASCII/ISO kind of system */
ba1ac976 3284#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH		 3285#else
3286/*
3287 Some other sort of character set - use memchr() so we don't match
3288 the null byte.
3289 */
80252599 3290#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
9d116dd7
JH		 3291#endif
3292
a0d0e21e 3293PP(pp_unpack)
79072805 3294{
4e35701f 3295 djSP;
a0d0e21e 3296 dPOPPOPssrl;
dd58a1ab 3297 I32 start_sp_offset = SP - PL_stack_base;
54310121 3298 I32 gimme = GIMME_V;
ed6116ce 3299 SV *sv;
a0d0e21e
LW		 3300 STRLEN llen;
3301 STRLEN rlen;
3302 register char *pat = SvPV(left, llen);
3303 register char *s = SvPV(right, rlen);
3304 char *strend = s + rlen;
3305 char *strbeg = s;
3306 register char *patend = pat + llen;
3307 I32 datumtype;
3308 register I32 len;
3309 register I32 bits;
abdc5761 3310 register char *str;
79072805 3311
a0d0e21e
LW		 3312 /* These must not be in registers: */
3313 I16 ashort;
3314 int aint;
3315 I32 along;
6b8eaf93 3316#ifdef HAS_QUAD
ecfc5424 3317 Quad_t aquad;
a0d0e21e
LW		 3318#endif
3319 U16 aushort;
3320 unsigned int auint;
3321 U32 aulong;
6b8eaf93 3322#ifdef HAS_QUAD
e862df63 3323 Uquad_t auquad;
a0d0e21e
LW		 3324#endif
3325 char *aptr;
3326 float afloat;
3327 double adouble;
3328 I32 checksum = 0;
3329 register U32 culong;
65202027 3330 NV cdouble;
fb73857a 3331 int commas = 0;
4b5b2118 3332 int star;
726ea183 3333#ifdef PERL_NATINT_PACK
ef54e1a4
JH		 3334 int natint; /* native integer */
3335 int unatint; /* unsigned native integer */
726ea183 3336#endif
79072805 3337
54310121 3338 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW		 3339 /*SUPPRESS 530*/
3340 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
5a929a98 3341 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW		 3342 patend++;
3343 while (isDIGIT(*patend) || *patend == '*')
3344 patend++;
3345 }
3346 else
3347 patend++;
79072805 3348 }
a0d0e21e
LW		 3349 while (pat < patend) {
3350 reparse:
bbdab043 3351 datumtype = *pat++ & 0xFF;
726ea183 3352#ifdef PERL_NATINT_PACK
ef54e1a4 3353 natint = 0;
726ea183 3354#endif
bbdab043
CS		 3355 if (isSPACE(datumtype))
3356 continue;
17f4a12d
IZ		 3357 if (datumtype == '#') {
3358 while (pat < patend && *pat != '\n')
3359 pat++;
3360 continue;
3361 }
f61d411c 3362 if (*pat == '!') {
ef54e1a4
JH		 3363 char *natstr = "sSiIlL";
3364
3365 if (strchr(natstr, datumtype)) {
726ea183 3366#ifdef PERL_NATINT_PACK
ef54e1a4 3367 natint = 1;
726ea183 3368#endif
ef54e1a4
JH		 3369 pat++;
3370 }
3371 else
d470f89e 3372 DIE(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 3373 }
4b5b2118 3374 star = 0;
a0d0e21e
LW		 3375 if (pat >= patend)
3376 len = 1;
3377 else if (*pat == '*') {
3378 len = strend - strbeg; /* long enough */
3379 pat++;
4b5b2118 3380 star = 1;
a0d0e21e
LW		 3381 }
3382 else if (isDIGIT(*pat)) {
3383 len = *pat++ - '0';
06387354 3384 while (isDIGIT(*pat)) {
a0d0e21e 3385 len = (len * 10) + (*pat++ - '0');
06387354 3386 if (len < 0)
d470f89e 3387 DIE(aTHX_ "Repeat count in unpack overflows");
06387354 3388 }
a0d0e21e
LW		 3389 }
3390 else
3391 len = (datumtype != '@');
4b5b2118 3392 redo_switch:
a0d0e21e
LW		 3393 switch(datumtype) {
3394 default:
d470f89e 3395 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3396 case ',': /* grandfather in commas but with a warning */
e476b1b5
GS		 3397 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3398 Perl_warner(aTHX_ WARN_UNPACK,
d470f89e 3399 "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3400 break;
a0d0e21e
LW		 3401 case '%':
3402 if (len == 1 && pat[-1] != '1')
3403 len = 16;
3404 checksum = len;
3405 culong = 0;
3406 cdouble = 0;
3407 if (pat < patend)
3408 goto reparse;
3409 break;
3410 case '@':
3411 if (len > strend - strbeg)
cea2e8a9 3412 DIE(aTHX_ "@ outside of string");
a0d0e21e
LW		 3413 s = strbeg + len;
3414 break;
3415 case 'X':
3416 if (len > s - strbeg)
cea2e8a9 3417 DIE(aTHX_ "X outside of string");
a0d0e21e
LW		 3418 s -= len;
3419 break;
3420 case 'x':
3421 if (len > strend - s)
cea2e8a9 3422 DIE(aTHX_ "x outside of string");
a0d0e21e
LW		 3423 s += len;
3424 break;
17f4a12d 3425 case '/':
dd58a1ab 3426 if (start_sp_offset >= SP - PL_stack_base)
17f4a12d 3427 DIE(aTHX_ "/ must follow a numeric type");
43192e07
IP		 3428 datumtype = *pat++;
3429 if (*pat == '*')
3430 pat++; /* ignore '*' for compatibility with pack */
3431 if (isDIGIT(*pat))
17f4a12d 3432 DIE(aTHX_ "/ cannot take a count" );
43192e07 3433 len = POPi;
4b5b2118
GS		 3434 star = 0;
3435 goto redo_switch;
a0d0e21e 3436 case 'A':
5a929a98 3437 case 'Z':
a0d0e21e
LW		 3438 case 'a':
3439 if (len > strend - s)
3440 len = strend - s;
3441 if (checksum)
3442 goto uchar_checksum;
3443 sv = NEWSV(35, len);
3444 sv_setpvn(sv, s, len);
3445 s += len;
5a929a98 3446 if (datumtype == 'A' || datumtype == 'Z') {
a0d0e21e 3447 aptr = s; /* borrow register */
5a929a98
VU		 3448 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3449 s = SvPVX(sv);
3450 while (*s)
3451 s++;
3452 }
3453 else { /* 'A' strips both nulls and spaces */
3454 s = SvPVX(sv) + len - 1;
3455 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3456 s--;
3457 *++s = '\0';
3458 }
a0d0e21e
LW		 3459 SvCUR_set(sv, s - SvPVX(sv));
3460 s = aptr; /* unborrow register */
3461 }
3462 XPUSHs(sv_2mortal(sv));
3463 break;
3464 case 'B':
3465 case 'b':
4b5b2118 3466 if (star || len > (strend - s) * 8)
a0d0e21e
LW		 3467 len = (strend - s) * 8;
3468 if (checksum) {
80252599
GS		 3469 if (!PL_bitcount) {
3470 Newz(601, PL_bitcount, 256, char);
a0d0e21e 3471 for (bits = 1; bits < 256; bits++) {
80252599
GS		 3472 if (bits & 1) PL_bitcount[bits]++;
3473 if (bits & 2) PL_bitcount[bits]++;
3474 if (bits & 4) PL_bitcount[bits]++;
3475 if (bits & 8) PL_bitcount[bits]++;
3476 if (bits & 16) PL_bitcount[bits]++;
3477 if (bits & 32) PL_bitcount[bits]++;
3478 if (bits & 64) PL_bitcount[bits]++;
3479 if (bits & 128) PL_bitcount[bits]++;
a0d0e21e
LW		 3480 }
3481 }
3482 while (len >= 8) {
80252599 3483 culong += PL_bitcount[*(unsigned char*)s++];
a0d0e21e
LW		 3484 len -= 8;
3485 }
3486 if (len) {
3487 bits = *s;
3488 if (datumtype == 'b') {
3489 while (len-- > 0) {
3490 if (bits & 1) culong++;
3491 bits >>= 1;
3492 }
3493 }
3494 else {
3495 while (len-- > 0) {
3496 if (bits & 128) culong++;
3497 bits <<= 1;
3498 }
3499 }
3500 }
79072805
LW		 3501 break;
3502 }
a0d0e21e
LW		 3503 sv = NEWSV(35, len + 1);
3504 SvCUR_set(sv, len);
3505 SvPOK_on(sv);
abdc5761 3506 str = SvPVX(sv);
a0d0e21e
LW		 3507 if (datumtype == 'b') {
3508 aint = len;
3509 for (len = 0; len < aint; len++) {
3510 if (len & 7) /*SUPPRESS 595*/
3511 bits >>= 1;
3512 else
3513 bits = *s++;
abdc5761 3514 *str++ = '0' + (bits & 1);
a0d0e21e
LW		 3515 }
3516 }
3517 else {
3518 aint = len;
3519 for (len = 0; len < aint; len++) {
3520 if (len & 7)
3521 bits <<= 1;
3522 else
3523 bits = *s++;
abdc5761 3524 *str++ = '0' + ((bits & 128) != 0);
a0d0e21e
LW		 3525 }
3526 }
abdc5761 3527 *str = '\0';
a0d0e21e
LW		 3528 XPUSHs(sv_2mortal(sv));
3529 break;
3530 case 'H':
3531 case 'h':
4b5b2118 3532 if (star || len > (strend - s) * 2)
a0d0e21e
LW		 3533 len = (strend - s) * 2;
3534 sv = NEWSV(35, len + 1);
3535 SvCUR_set(sv, len);
3536 SvPOK_on(sv);
abdc5761 3537 str = SvPVX(sv);
a0d0e21e
LW		 3538 if (datumtype == 'h') {
3539 aint = len;
3540 for (len = 0; len < aint; len++) {
3541 if (len & 1)
3542 bits >>= 4;
3543 else
3544 bits = *s++;
abdc5761 3545 *str++ = PL_hexdigit[bits & 15];
a0d0e21e
LW		 3546 }
3547 }
3548 else {
3549 aint = len;
3550 for (len = 0; len < aint; len++) {
3551 if (len & 1)
3552 bits <<= 4;
3553 else
3554 bits = *s++;
abdc5761 3555 *str++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW		 3556 }
3557 }
abdc5761 3558 *str = '\0';
a0d0e21e
LW		 3559 XPUSHs(sv_2mortal(sv));
3560 break;
3561 case 'c':
3562 if (len > strend - s)
3563 len = strend - s;
3564 if (checksum) {
3565 while (len-- > 0) {
3566 aint = *s++;
3567 if (aint >= 128) /* fake up signed chars */
3568 aint -= 256;
3569 culong += aint;
3570 }
3571 }
3572 else {
3573 EXTEND(SP, len);
bbce6d69 3574 EXTEND_MORTAL(len);
a0d0e21e
LW		 3575 while (len-- > 0) {
3576 aint = *s++;
3577 if (aint >= 128) /* fake up signed chars */
3578 aint -= 256;
3579 sv = NEWSV(36, 0);
1e422769 3580 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3581 PUSHs(sv_2mortal(sv));
3582 }
3583 }
3584 break;
3585 case 'C':
3586 if (len > strend - s)
3587 len = strend - s;
3588 if (checksum) {
3589 uchar_checksum:
3590 while (len-- > 0) {
3591 auint = *s++ & 255;
3592 culong += auint;
3593 }
3594 }
3595 else {
3596 EXTEND(SP, len);
bbce6d69 3597 EXTEND_MORTAL(len);
a0d0e21e
LW		 3598 while (len-- > 0) {
3599 auint = *s++ & 255;
3600 sv = NEWSV(37, 0);
1e422769 3601 sv_setiv(sv, (IV)auint);
a0d0e21e
LW		 3602 PUSHs(sv_2mortal(sv));
3603 }
3604 }
3605 break;
a0ed51b3
LW		 3606 case 'U':
3607 if (len > strend - s)
3608 len = strend - s;
3609 if (checksum) {
3610 while (len-- > 0 && s < strend) {
dfe13c55 3611 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3 3612 s += along;
32d8b6e5 3613 if (checksum > 32)
65202027 3614 cdouble += (NV)auint;
32d8b6e5
GA		 3615 else
3616 culong += auint;
a0ed51b3
LW		 3617 }
3618 }
3619 else {
3620 EXTEND(SP, len);
3621 EXTEND_MORTAL(len);
3622 while (len-- > 0 && s < strend) {
dfe13c55 3623 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3
LW		 3624 s += along;
3625 sv = NEWSV(37, 0);
bdeef251 3626 sv_setuv(sv, (UV)auint);
a0ed51b3
LW		 3627 PUSHs(sv_2mortal(sv));
3628 }
3629 }
3630 break;
a0d0e21e 3631 case 's':
726ea183
JH		 3632#if SHORTSIZE == SIZE16
3633 along = (strend - s) / SIZE16;
3634#else
ef54e1a4 3635 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
726ea183 3636#endif
a0d0e21e
LW		 3637 if (len > along)
3638 len = along;
3639 if (checksum) {
726ea183 3640#if SHORTSIZE != SIZE16
ef54e1a4 3641 if (natint) {
bf9315bb 3642 short ashort;
ef54e1a4
JH		 3643 while (len-- > 0) {
3644 COPYNN(s, &ashort, sizeof(short));
3645 s += sizeof(short);
3646 culong += ashort;
3647
3648 }
3649 }
726ea183
JH		 3650 else
3651#endif
3652 {
ef54e1a4
JH		 3653 while (len-- > 0) {
3654 COPY16(s, &ashort);
c67712b2
JH		 3655#if SHORTSIZE > SIZE16
3656 if (ashort > 32767)
3657 ashort -= 65536;
3658#endif
ef54e1a4
JH		 3659 s += SIZE16;
3660 culong += ashort;
3661 }
a0d0e21e
LW		 3662 }
3663 }
3664 else {
3665 EXTEND(SP, len);
bbce6d69 3666 EXTEND_MORTAL(len);
726ea183 3667#if SHORTSIZE != SIZE16
ef54e1a4 3668 if (natint) {
bf9315bb 3669 short ashort;
ef54e1a4
JH		 3670 while (len-- > 0) {
3671 COPYNN(s, &ashort, sizeof(short));
3672 s += sizeof(short);
3673 sv = NEWSV(38, 0);
3674 sv_setiv(sv, (IV)ashort);
3675 PUSHs(sv_2mortal(sv));
3676 }
3677 }
726ea183
JH		 3678 else
3679#endif
3680 {
ef54e1a4
JH		 3681 while (len-- > 0) {
3682 COPY16(s, &ashort);
c67712b2
JH		 3683#if SHORTSIZE > SIZE16
3684 if (ashort > 32767)
3685 ashort -= 65536;
3686#endif
ef54e1a4
JH		 3687 s += SIZE16;
3688 sv = NEWSV(38, 0);
3689 sv_setiv(sv, (IV)ashort);
3690 PUSHs(sv_2mortal(sv));
3691 }
a0d0e21e
LW		 3692 }
3693 }
3694 break;
3695 case 'v':
3696 case 'n':
3697 case 'S':
726ea183
JH		 3698#if SHORTSIZE == SIZE16
3699 along = (strend - s) / SIZE16;
3700#else
ef54e1a4
JH		 3701 unatint = natint && datumtype == 'S';
3702 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
726ea183 3703#endif
a0d0e21e
LW		 3704 if (len > along)
3705 len = along;
3706 if (checksum) {
726ea183 3707#if SHORTSIZE != SIZE16
ef54e1a4 3708 if (unatint) {
bf9315bb 3709 unsigned short aushort;
ef54e1a4
JH		 3710 while (len-- > 0) {
3711 COPYNN(s, &aushort, sizeof(unsigned short));
3712 s += sizeof(unsigned short);
3713 culong += aushort;
3714 }
3715 }
726ea183
JH		 3716 else
3717#endif
3718 {
ef54e1a4
JH		 3719 while (len-- > 0) {
3720 COPY16(s, &aushort);
3721 s += SIZE16;
a0d0e21e 3722#ifdef HAS_NTOHS
ef54e1a4
JH		 3723 if (datumtype == 'n')
3724 aushort = PerlSock_ntohs(aushort);
79072805 3725#endif
a0d0e21e 3726#ifdef HAS_VTOHS
ef54e1a4
JH		 3727 if (datumtype == 'v')
3728 aushort = vtohs(aushort);
79072805 3729#endif
ef54e1a4
JH		 3730 culong += aushort;
3731 }
a0d0e21e
LW		 3732 }
3733 }
3734 else {
3735 EXTEND(SP, len);
bbce6d69 3736 EXTEND_MORTAL(len);
726ea183 3737#if SHORTSIZE != SIZE16
ef54e1a4 3738 if (unatint) {
bf9315bb 3739 unsigned short aushort;
ef54e1a4
JH		 3740 while (len-- > 0) {
3741 COPYNN(s, &aushort, sizeof(unsigned short));
3742 s += sizeof(unsigned short);
3743 sv = NEWSV(39, 0);
726ea183 3744 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH		 3745 PUSHs(sv_2mortal(sv));
3746 }
3747 }
726ea183
JH		 3748 else
3749#endif
3750 {
ef54e1a4
JH		 3751 while (len-- > 0) {
3752 COPY16(s, &aushort);
3753 s += SIZE16;
3754 sv = NEWSV(39, 0);
a0d0e21e 3755#ifdef HAS_NTOHS
ef54e1a4
JH		 3756 if (datumtype == 'n')
3757 aushort = PerlSock_ntohs(aushort);
79072805 3758#endif
a0d0e21e 3759#ifdef HAS_VTOHS
ef54e1a4
JH		 3760 if (datumtype == 'v')
3761 aushort = vtohs(aushort);
79072805 3762#endif
726ea183 3763 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH		 3764 PUSHs(sv_2mortal(sv));
3765 }
a0d0e21e
LW		 3766 }
3767 }
3768 break;
3769 case 'i':
3770 along = (strend - s) / sizeof(int);
3771 if (len > along)
3772 len = along;
3773 if (checksum) {
3774 while (len-- > 0) {
3775 Copy(s, &aint, 1, int);
3776 s += sizeof(int);
3777 if (checksum > 32)
65202027 3778 cdouble += (NV)aint;
a0d0e21e
LW		 3779 else
3780 culong += aint;
3781 }
3782 }
3783 else {
3784 EXTEND(SP, len);
bbce6d69 3785 EXTEND_MORTAL(len);
a0d0e21e
LW		 3786 while (len-- > 0) {
3787 Copy(s, &aint, 1, int);
3788 s += sizeof(int);
3789 sv = NEWSV(40, 0);
20408e3c
GS		 3790#ifdef __osf__
3791 /* Without the dummy below unpack("i", pack("i",-1))
3792 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
13476c87
JH		 3793 * cc with optimization turned on.
3794 *
3795 * The bug was detected in
3796 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3797 * with optimization (-O4) turned on.
3798 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3799 * does not have this problem even with -O4.
3800 *
3801 * This bug was reported as DECC_BUGS 1431
3802 * and tracked internally as GEM_BUGS 7775.
3803 *
3804 * The bug is fixed in
3805 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3806 * UNIX V4.0F support: DEC C V5.9-006 or later
3807 * UNIX V4.0E support: DEC C V5.8-011 or later
3808 * and also in DTK.
3809 *
3810 * See also few lines later for the same bug.
3811 */
20408e3c
GS		 3812 (aint) ?
3813 sv_setiv(sv, (IV)aint) :
3814#endif
1e422769 3815 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3816 PUSHs(sv_2mortal(sv));
3817 }
3818 }
3819 break;
3820 case 'I':
3821 along = (strend - s) / sizeof(unsigned int);
3822 if (len > along)
3823 len = along;
3824 if (checksum) {
3825 while (len-- > 0) {
3826 Copy(s, &auint, 1, unsigned int);
3827 s += sizeof(unsigned int);
3828 if (checksum > 32)
65202027 3829 cdouble += (NV)auint;
a0d0e21e
LW		 3830 else
3831 culong += auint;
3832 }
3833 }
3834 else {
3835 EXTEND(SP, len);
bbce6d69 3836 EXTEND_MORTAL(len);
a0d0e21e
LW		 3837 while (len-- > 0) {
3838 Copy(s, &auint, 1, unsigned int);
3839 s += sizeof(unsigned int);
3840 sv = NEWSV(41, 0);
9d645a59
AB		 3841#ifdef __osf__
3842 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
13476c87
JH		 3843 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3844 * See details few lines earlier. */
9d645a59
AB		 3845 (auint) ?
3846 sv_setuv(sv, (UV)auint) :
3847#endif
1e422769 3848 sv_setuv(sv, (UV)auint);
a0d0e21e
LW		 3849 PUSHs(sv_2mortal(sv));
3850 }
3851 }
3852 break;
3853 case 'l':
726ea183
JH		 3854#if LONGSIZE == SIZE32
3855 along = (strend - s) / SIZE32;
3856#else
ef54e1a4 3857 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
726ea183 3858#endif
a0d0e21e
LW		 3859 if (len > along)
3860 len = along;
3861 if (checksum) {
726ea183 3862#if LONGSIZE != SIZE32
ef54e1a4 3863 if (natint) {
bf9315bb 3864 long along;
ef54e1a4
JH		 3865 while (len-- > 0) {
3866 COPYNN(s, &along, sizeof(long));
3867 s += sizeof(long);
3868 if (checksum > 32)
65202027 3869 cdouble += (NV)along;
ef54e1a4
JH		 3870 else
3871 culong += along;
3872 }
3873 }
726ea183
JH		 3874 else
3875#endif
3876 {
ef54e1a4
JH		 3877 while (len-- > 0) {
3878 COPY32(s, &along);
c67712b2
JH		 3879#if LONGSIZE > SIZE32
3880 if (along > 2147483647)
3881 along -= 4294967296;
3882#endif
ef54e1a4
JH		 3883 s += SIZE32;
3884 if (checksum > 32)
65202027 3885 cdouble += (NV)along;
ef54e1a4
JH		 3886 else
3887 culong += along;
3888 }
a0d0e21e
LW		 3889 }
3890 }
3891 else {
3892 EXTEND(SP, len);
bbce6d69 3893 EXTEND_MORTAL(len);
726ea183 3894#if LONGSIZE != SIZE32
ef54e1a4 3895 if (natint) {
bf9315bb 3896 long along;
ef54e1a4
JH		 3897 while (len-- > 0) {
3898 COPYNN(s, &along, sizeof(long));
3899 s += sizeof(long);
3900 sv = NEWSV(42, 0);
3901 sv_setiv(sv, (IV)along);
3902 PUSHs(sv_2mortal(sv));
3903 }
3904 }
726ea183
JH		 3905 else
3906#endif
3907 {
ef54e1a4
JH		 3908 while (len-- > 0) {
3909 COPY32(s, &along);
c67712b2
JH		 3910#if LONGSIZE > SIZE32
3911 if (along > 2147483647)
3912 along -= 4294967296;
3913#endif
ef54e1a4
JH		 3914 s += SIZE32;
3915 sv = NEWSV(42, 0);
3916 sv_setiv(sv, (IV)along);
3917 PUSHs(sv_2mortal(sv));
3918 }
a0d0e21e 3919 }
79072805 3920 }
a0d0e21e
LW		 3921 break;
3922 case 'V':
3923 case 'N':
3924 case 'L':
726ea183
JH		 3925#if LONGSIZE == SIZE32
3926 along = (strend - s) / SIZE32;
3927#else
3928 unatint = natint && datumtype == 'L';
ef54e1a4 3929 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
726ea183 3930#endif
a0d0e21e
LW		 3931 if (len > along)
3932 len = along;
3933 if (checksum) {
726ea183 3934#if LONGSIZE != SIZE32
ef54e1a4 3935 if (unatint) {
bf9315bb 3936 unsigned long aulong;
ef54e1a4
JH		 3937 while (len-- > 0) {
3938 COPYNN(s, &aulong, sizeof(unsigned long));
3939 s += sizeof(unsigned long);
3940 if (checksum > 32)
65202027 3941 cdouble += (NV)aulong;
ef54e1a4
JH		 3942 else
3943 culong += aulong;
3944 }
3945 }
726ea183
JH		 3946 else
3947#endif
3948 {
ef54e1a4
JH		 3949 while (len-- > 0) {
3950 COPY32(s, &aulong);
3951 s += SIZE32;
a0d0e21e 3952#ifdef HAS_NTOHL
ef54e1a4
JH		 3953 if (datumtype == 'N')
3954 aulong = PerlSock_ntohl(aulong);
79072805 3955#endif
a0d0e21e 3956#ifdef HAS_VTOHL
ef54e1a4
JH		 3957 if (datumtype == 'V')
3958 aulong = vtohl(aulong);
79072805 3959#endif
ef54e1a4 3960 if (checksum > 32)
65202027 3961 cdouble += (NV)aulong;
ef54e1a4
JH		 3962 else
3963 culong += aulong;
3964 }
a0d0e21e
LW		 3965 }
3966 }
3967 else {
3968 EXTEND(SP, len);
bbce6d69 3969 EXTEND_MORTAL(len);
726ea183 3970#if LONGSIZE != SIZE32
ef54e1a4 3971 if (unatint) {
bf9315bb 3972 unsigned long aulong;
ef54e1a4
JH		 3973 while (len-- > 0) {
3974 COPYNN(s, &aulong, sizeof(unsigned long));
3975 s += sizeof(unsigned long);
3976 sv = NEWSV(43, 0);
3977 sv_setuv(sv, (UV)aulong);
3978 PUSHs(sv_2mortal(sv));
3979 }
3980 }
726ea183
JH		 3981 else
3982#endif
3983 {
ef54e1a4
JH		 3984 while (len-- > 0) {
3985 COPY32(s, &aulong);
3986 s += SIZE32;
a0d0e21e 3987#ifdef HAS_NTOHL
ef54e1a4
JH		 3988 if (datumtype == 'N')
3989 aulong = PerlSock_ntohl(aulong);
79072805 3990#endif
a0d0e21e 3991#ifdef HAS_VTOHL
ef54e1a4
JH		 3992 if (datumtype == 'V')
3993 aulong = vtohl(aulong);
79072805 3994#endif
ef54e1a4
JH		 3995 sv = NEWSV(43, 0);
3996 sv_setuv(sv, (UV)aulong);
3997 PUSHs(sv_2mortal(sv));
3998 }
a0d0e21e
LW		 3999 }
4000 }
4001 break;
4002 case 'p':
4003 along = (strend - s) / sizeof(char*);
4004 if (len > along)
4005 len = along;
4006 EXTEND(SP, len);
bbce6d69 4007 EXTEND_MORTAL(len);
a0d0e21e
LW		 4008 while (len-- > 0) {
4009 if (sizeof(char*) > strend - s)
4010 break;
4011 else {
4012 Copy(s, &aptr, 1, char*);
4013 s += sizeof(char*);
4014 }
4015 sv = NEWSV(44, 0);
4016 if (aptr)
4017 sv_setpv(sv, aptr);
4018 PUSHs(sv_2mortal(sv));
4019 }
4020 break;
def98dd4 4021 case 'w':
def98dd4 4022 EXTEND(SP, len);
bbce6d69 4023 EXTEND_MORTAL(len);
8ec5e241 4024 {
bbce6d69 4025 UV auv = 0;
4026 U32 bytes = 0;
4027
4028 while ((len > 0) && (s < strend)) {
4029 auv = (auv << 7) | (*s & 0x7f);
4030 if (!(*s++ & 0x80)) {
4031 bytes = 0;
4032 sv = NEWSV(40, 0);
4033 sv_setuv(sv, auv);
4034 PUSHs(sv_2mortal(sv));
4035 len--;
4036 auv = 0;
4037 }
4038 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69 4039 char *t;
2d8e6c8d 4040 STRLEN n_a;
bbce6d69 4041
cea2e8a9 4042 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
bbce6d69 4043 while (s < strend) {
4044 sv = mul128(sv, *s & 0x7f);
4045 if (!(*s++ & 0x80)) {
4046 bytes = 0;
4047 break;
4048 }
4049 }
2d8e6c8d 4050 t = SvPV(sv, n_a);
bbce6d69 4051 while (*t == '0')
4052 t++;
4053 sv_chop(sv, t);
4054 PUSHs(sv_2mortal(sv));
4055 len--;
4056 auv = 0;
4057 }
4058 }
4059 if ((s >= strend) && bytes)
d470f89e 4060 DIE(aTHX_ "Unterminated compressed integer");
bbce6d69 4061 }
def98dd4 4062 break;
a0d0e21e
LW		 4063 case 'P':
4064 EXTEND(SP, 1);
4065 if (sizeof(char*) > strend - s)
4066 break;
4067 else {
4068 Copy(s, &aptr, 1, char*);
4069 s += sizeof(char*);
4070 }
4071 sv = NEWSV(44, 0);
4072 if (aptr)
4073 sv_setpvn(sv, aptr, len);
4074 PUSHs(sv_2mortal(sv));
4075 break;
6b8eaf93 4076#ifdef HAS_QUAD
a0d0e21e 4077 case 'q':
d4217c7e
JH		 4078 along = (strend - s) / sizeof(Quad_t);
4079 if (len > along)
4080 len = along;
a0d0e21e 4081 EXTEND(SP, len);
bbce6d69 4082 EXTEND_MORTAL(len);
a0d0e21e 4083 while (len-- > 0) {
ecfc5424 4084 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW		 4085 aquad = 0;
4086 else {
ecfc5424
AD		 4087 Copy(s, &aquad, 1, Quad_t);
4088 s += sizeof(Quad_t);
a0d0e21e
LW		 4089 }
4090 sv = NEWSV(42, 0);
96e4d5b1 4091 if (aquad >= IV_MIN && aquad <= IV_MAX)
4092 sv_setiv(sv, (IV)aquad);
4093 else
65202027 4094 sv_setnv(sv, (NV)aquad);
a0d0e21e
LW		 4095 PUSHs(sv_2mortal(sv));
4096 }
4097 break;
4098 case 'Q':
d4217c7e
JH		 4099 along = (strend - s) / sizeof(Quad_t);
4100 if (len > along)
4101 len = along;
a0d0e21e 4102 EXTEND(SP, len);
bbce6d69 4103 EXTEND_MORTAL(len);
a0d0e21e 4104 while (len-- > 0) {
e862df63 4105 if (s + sizeof(Uquad_t) > strend)
a0d0e21e
LW		 4106 auquad = 0;
4107 else {
e862df63
HB		 4108 Copy(s, &auquad, 1, Uquad_t);
4109 s += sizeof(Uquad_t);
a0d0e21e
LW		 4110 }
4111 sv = NEWSV(43, 0);
27612d38 4112 if (auquad <= UV_MAX)
96e4d5b1 4113 sv_setuv(sv, (UV)auquad);
4114 else
65202027 4115 sv_setnv(sv, (NV)auquad);
a0d0e21e
LW		 4116 PUSHs(sv_2mortal(sv));
4117 }
4118 break;
79072805 4119#endif
a0d0e21e
LW		 4120 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4121 case 'f':
4122 case 'F':
4123 along = (strend - s) / sizeof(float);
4124 if (len > along)
4125 len = along;
4126 if (checksum) {
4127 while (len-- > 0) {
4128 Copy(s, &afloat, 1, float);
4129 s += sizeof(float);
4130 cdouble += afloat;
4131 }
4132 }
4133 else {
4134 EXTEND(SP, len);
bbce6d69 4135 EXTEND_MORTAL(len);
a0d0e21e
LW		 4136 while (len-- > 0) {
4137 Copy(s, &afloat, 1, float);
4138 s += sizeof(float);
4139 sv = NEWSV(47, 0);
65202027 4140 sv_setnv(sv, (NV)afloat);
a0d0e21e
LW		 4141 PUSHs(sv_2mortal(sv));
4142 }
4143 }
4144 break;
4145 case 'd':
4146 case 'D':
4147 along = (strend - s) / sizeof(double);
4148 if (len > along)
4149 len = along;
4150 if (checksum) {
4151 while (len-- > 0) {
4152 Copy(s, &adouble, 1, double);
4153 s += sizeof(double);
4154 cdouble += adouble;
4155 }
4156 }
4157 else {
4158 EXTEND(SP, len);
bbce6d69 4159 EXTEND_MORTAL(len);
a0d0e21e
LW		 4160 while (len-- > 0) {
4161 Copy(s, &adouble, 1, double);
4162 s += sizeof(double);
4163 sv = NEWSV(48, 0);
65202027 4164 sv_setnv(sv, (NV)adouble);
a0d0e21e
LW		 4165 PUSHs(sv_2mortal(sv));
4166 }
4167 }
4168 break;
4169 case 'u':
9d116dd7
JH		 4170 /* MKS:
4171 * Initialise the decode mapping. By using a table driven
4172 * algorithm, the code will be character-set independent
4173 * (and just as fast as doing character arithmetic)
4174 */
80252599 4175 if (PL_uudmap['M'] == 0) {
9d116dd7
JH		 4176 int i;
4177
80252599
GS		 4178 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4179 PL_uudmap[PL_uuemap[i]] = i;
9d116dd7
JH		 4180 /*
4181 * Because ' ' and '`' map to the same value,
4182 * we need to decode them both the same.
4183 */
80252599 4184 PL_uudmap[' '] = 0;
9d116dd7
JH		 4185 }
4186
a0d0e21e
LW		 4187 along = (strend - s) * 3 / 4;
4188 sv = NEWSV(42, along);
f12c7020 4189 if (along)
4190 SvPOK_on(sv);
9d116dd7 4191 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
a0d0e21e
LW		 4192 I32 a, b, c, d;
4193 char hunk[4];
79072805 4194
a0d0e21e 4195 hunk[3] = '\0';
80252599 4196 len = PL_uudmap[*s++] & 077;
a0d0e21e 4197 while (len > 0) {
9d116dd7 4198 if (s < strend && ISUUCHAR(*s))
80252599 4199 a = PL_uudmap[*s++] & 077;
9d116dd7
JH		 4200 else
4201 a = 0;
4202 if (s < strend && ISUUCHAR(*s))
80252599 4203 b = PL_uudmap[*s++] & 077;
9d116dd7
JH		 4204 else
4205 b = 0;
4206 if (s < strend && ISUUCHAR(*s))
80252599 4207 c = PL_uudmap[*s++] & 077;
9d116dd7
JH		 4208 else
4209 c = 0;
4210 if (s < strend && ISUUCHAR(*s))
80252599 4211 d = PL_uudmap[*s++] & 077;
a0d0e21e
LW		 4212 else
4213 d = 0;
4e35701f
NIS		 4214 hunk[0] = (a << 2) | (b >> 4);
4215 hunk[1] = (b << 4) | (c >> 2);
4216 hunk[2] = (c << 6) | d;
4217 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
a0d0e21e
LW		 4218 len -= 3;
4219 }
4220 if (*s == '\n')
4221 s++;
4222 else if (s[1] == '\n') /* possible checksum byte */
4223 s += 2;
79072805 4224 }
a0d0e21e
LW		 4225 XPUSHs(sv_2mortal(sv));
4226 break;
79072805 4227 }
a0d0e21e
LW		 4228 if (checksum) {
4229 sv = NEWSV(42, 0);
4230 if (strchr("fFdD", datumtype) ||
32d8b6e5 4231 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
65202027 4232 NV trouble;
79072805 4233
a0d0e21e
LW		 4234 adouble = 1.0;
4235 while (checksum >= 16) {
4236 checksum -= 16;
4237 adouble *= 65536.0;
4238 }
4239 while (checksum >= 4) {
4240 checksum -= 4;
4241 adouble *= 16.0;
4242 }
4243 while (checksum--)
4244 adouble *= 2.0;
4245 along = (1 << checksum) - 1;
4246 while (cdouble < 0.0)
4247 cdouble += adouble;
65202027 4248 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
a0d0e21e
LW		 4249 sv_setnv(sv, cdouble);
4250 }
4251 else {
4252 if (checksum < 32) {
96e4d5b1 4253 aulong = (1 << checksum) - 1;
4254 culong &= aulong;
a0d0e21e 4255 }
96e4d5b1 4256 sv_setuv(sv, (UV)culong);
a0d0e21e
LW		 4257 }
4258 XPUSHs(sv_2mortal(sv));
4259 checksum = 0;
79072805 4260 }
79072805 4261 }
dd58a1ab 4262 if (SP - PL_stack_base == start_sp_offset && gimme == G_SCALAR)
3280af22 4263 PUSHs(&PL_sv_undef);
79072805 4264 RETURN;
79072805
LW		 4265}
4266
76e3520e 4267STATIC void
cea2e8a9 4268S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
79072805 4269{
a0d0e21e 4270 char hunk[5];
79072805 4271
80252599 4272 *hunk = PL_uuemap[len];
a0d0e21e
LW		 4273 sv_catpvn(sv, hunk, 1);
4274 hunk[4] = '\0';
f264d472 4275 while (len > 2) {
80252599
GS		 4276 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4277 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4278 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4279 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
a0d0e21e
LW		 4280 sv_catpvn(sv, hunk, 4);
4281 s += 3;
4282 len -= 3;
4283 }
f264d472
GS		 4284 if (len > 0) {
4285 char r = (len > 1 ? s[1] : '\0');
80252599
GS		 4286 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4287 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4288 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4289 hunk[3] = PL_uuemap[0];
f264d472 4290 sv_catpvn(sv, hunk, 4);
a0d0e21e
LW		 4291 }
4292 sv_catpvn(sv, "\n", 1);
79072805
LW		 4293}
4294
79cb57f6 4295STATIC SV *
cea2e8a9 4296S_is_an_int(pTHX_ char *s, STRLEN l)
55497cff 4297{
2d8e6c8d 4298 STRLEN n_a;
79cb57f6 4299 SV *result = newSVpvn(s, l);
2d8e6c8d 4300 char *result_c = SvPV(result, n_a); /* convenience */
55497cff 4301 char *out = result_c;
4302 bool skip = 1;
4303 bool ignore = 0;
4304
4305 while (*s) {
4306 switch (*s) {
4307 case ' ':
4308 break;
4309 case '+':
4310 if (!skip) {
4311 SvREFCNT_dec(result);
4312 return (NULL);
4313 }
4314 break;
4315 case '0':
4316 case '1':
4317 case '2':
4318 case '3':
4319 case '4':
4320 case '5':
4321 case '6':
4322 case '7':
4323 case '8':
4324 case '9':
4325 skip = 0;
4326 if (!ignore) {
4327 *(out++) = *s;
4328 }
4329 break;
4330 case '.':
4331 ignore = 1;
4332 break;
4333 default:
4334 SvREFCNT_dec(result);
4335 return (NULL);
4336 }
4337 s++;
4338 }
4339 *(out++) = '\0';
4340 SvCUR_set(result, out - result_c);
4341 return (result);
4342}
4343
864dbfa3 4344/* pnum must be '\0' terminated */
76e3520e 4345STATIC int
cea2e8a9 4346S_div128(pTHX_ SV *pnum, bool *done)
55497cff 4347{
4348 STRLEN len;
4349 char *s = SvPV(pnum, len);
4350 int m = 0;
4351 int r = 0;
4352 char *t = s;
4353
4354 *done = 1;
4355 while (*t) {
4356 int i;
4357
4358 i = m * 10 + (*t - '0');
4359 m = i & 0x7F;
4360 r = (i >> 7); /* r < 10 */
4361 if (r) {
4362 *done = 0;
4363 }
4364 *(t++) = '0' + r;
4365 }
4366 *(t++) = '\0';
4367 SvCUR_set(pnum, (STRLEN) (t - s));
4368 return (m);
4369}
4370
4371
a0d0e21e 4372PP(pp_pack)
79072805 4373{
4e35701f 4374 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4375 register SV *cat = TARG;
4376 register I32 items;
4377 STRLEN fromlen;
4378 register char *pat = SvPVx(*++MARK, fromlen);
4379 register char *patend = pat + fromlen;
4380 register I32 len;
4381 I32 datumtype;
4382 SV *fromstr;
4383 /*SUPPRESS 442*/
4384 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4385 static char *space10 = " ";
79072805 4386
a0d0e21e
LW		 4387 /* These must not be in registers: */
4388 char achar;
4389 I16 ashort;
4390 int aint;
4391 unsigned int auint;
4392 I32 along;
4393 U32 aulong;
6b8eaf93 4394#ifdef HAS_QUAD
ecfc5424 4395 Quad_t aquad;
e862df63 4396 Uquad_t auquad;
79072805 4397#endif
a0d0e21e
LW		 4398 char *aptr;
4399 float afloat;
4400 double adouble;
fb73857a 4401 int commas = 0;
726ea183 4402#ifdef PERL_NATINT_PACK
ef54e1a4 4403 int natint; /* native integer */
726ea183 4404#endif
79072805 4405
a0d0e21e
LW		 4406 items = SP - MARK;
4407 MARK++;
4408 sv_setpvn(cat, "", 0);
4409 while (pat < patend) {
43192e07
IP		 4410 SV *lengthcode = Nullsv;
4411#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
bbdab043 4412 datumtype = *pat++ & 0xFF;
726ea183 4413#ifdef PERL_NATINT_PACK
ef54e1a4 4414 natint = 0;
726ea183 4415#endif
bbdab043
CS		 4416 if (isSPACE(datumtype))
4417 continue;
17f4a12d
IZ		 4418 if (datumtype == '#') {
4419 while (pat < patend && *pat != '\n')
4420 pat++;
4421 continue;
4422 }
f61d411c 4423 if (*pat == '!') {
ef54e1a4
JH		 4424 char *natstr = "sSiIlL";
4425
4426 if (strchr(natstr, datumtype)) {
726ea183 4427#ifdef PERL_NATINT_PACK
ef54e1a4 4428 natint = 1;
726ea183 4429#endif
ef54e1a4
JH		 4430 pat++;
4431 }
4432 else
d470f89e 4433 DIE(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 4434 }
a0d0e21e
LW		 4435 if (*pat == '*') {
4436 len = strchr("@Xxu", datumtype) ? 0 : items;
4437 pat++;
4438 }
4439 else if (isDIGIT(*pat)) {
4440 len = *pat++ - '0';
06387354 4441 while (isDIGIT(*pat)) {
a0d0e21e 4442 len = (len * 10) + (*pat++ - '0');
06387354 4443 if (len < 0)
d470f89e 4444 DIE(aTHX_ "Repeat count in pack overflows");
06387354 4445 }
a0d0e21e
LW		 4446 }
4447 else
4448 len = 1;
17f4a12d 4449 if (*pat == '/') {
43192e07
IP		 4450 ++pat;
4451 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
17f4a12d 4452 DIE(aTHX_ "/ must be followed by a*, A* or Z*");
43192e07
IP		 4453 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4454 ? *MARK : &PL_sv_no)));
4455 }
a0d0e21e
LW		 4456 switch(datumtype) {
4457 default:
d470f89e 4458 DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
fb73857a 4459 case ',': /* grandfather in commas but with a warning */
e476b1b5
GS		 4460 if (commas++ == 0 && ckWARN(WARN_PACK))
4461 Perl_warner(aTHX_ WARN_PACK,
43192e07 4462 "Invalid type in pack: '%c'", (int)datumtype);
fb73857a 4463 break;
a0d0e21e 4464 case '%':
cea2e8a9 4465 DIE(aTHX_ "%% may only be used in unpack");
a0d0e21e
LW		 4466 case '@':
4467 len -= SvCUR(cat);
4468 if (len > 0)
4469 goto grow;
4470 len = -len;
4471 if (len > 0)
4472 goto shrink;
4473 break;
4474 case 'X':
4475 shrink:
4476 if (SvCUR(cat) < len)
cea2e8a9 4477 DIE(aTHX_ "X outside of string");
a0d0e21e
LW		 4478 SvCUR(cat) -= len;
4479 *SvEND(cat) = '\0';
4480 break;
4481 case 'x':
4482 grow:
4483 while (len >= 10) {
4484 sv_catpvn(cat, null10, 10);
4485 len -= 10;
4486 }
4487 sv_catpvn(cat, null10, len);
4488 break;
4489 case 'A':
5a929a98 4490 case 'Z':
a0d0e21e
LW		 4491 case 'a':
4492 fromstr = NEXTFROM;
4493 aptr = SvPV(fromstr, fromlen);
2b6c5635 4494 if (pat[-1] == '*') {
a0d0e21e 4495 len = fromlen;
2b6c5635
GS		 4496 if (datumtype == 'Z')
4497 ++len;
4498 }
4499 if (fromlen >= len) {
a0d0e21e 4500 sv_catpvn(cat, aptr, len);
2b6c5635
GS		 4501 if (datumtype == 'Z')
4502 *(SvEND(cat)-1) = '\0';
4503 }
a0d0e21e
LW		 4504 else {
4505 sv_catpvn(cat, aptr, fromlen);
4506 len -= fromlen;
4507 if (datumtype == 'A') {
4508 while (len >= 10) {
4509 sv_catpvn(cat, space10, 10);
4510 len -= 10;
4511 }
4512 sv_catpvn(cat, space10, len);
4513 }
4514 else {
4515 while (len >= 10) {
4516 sv_catpvn(cat, null10, 10);
4517 len -= 10;
4518 }
4519 sv_catpvn(cat, null10, len);
4520 }
4521 }
4522 break;
4523 case 'B':
4524 case 'b':
4525 {
abdc5761 4526 register char *str;
a0d0e21e 4527 I32 saveitems;
79072805 4528
a0d0e21e
LW		 4529 fromstr = NEXTFROM;
4530 saveitems = items;
abdc5761 4531 str = SvPV(fromstr, fromlen);
a0d0e21e
LW		 4532 if (pat[-1] == '*')
4533 len = fromlen;
a0d0e21e
LW		 4534 aint = SvCUR(cat);
4535 SvCUR(cat) += (len+7)/8;
4536 SvGROW(cat, SvCUR(cat) + 1);
4537 aptr = SvPVX(cat) + aint;
4538 if (len > fromlen)
4539 len = fromlen;
4540 aint = len;
4541 items = 0;
4542 if (datumtype == 'B') {
4543 for (len = 0; len++ < aint;) {
abdc5761 4544 items |= *str++ & 1;
a0d0e21e
LW		 4545 if (len & 7)
4546 items <<= 1;
4547 else {
4548 *aptr++ = items & 0xff;
4549 items = 0;
4550 }
4551 }
4552 }
4553 else {
4554 for (len = 0; len++ < aint;) {
abdc5761 4555 if (*str++ & 1)
a0d0e21e
LW		 4556 items |= 128;
4557 if (len & 7)
4558 items >>= 1;
4559 else {
4560 *aptr++ = items & 0xff;
4561 items = 0;
4562 }
4563 }
4564 }
4565 if (aint & 7) {
4566 if (datumtype == 'B')
4567 items <<= 7 - (aint & 7);
4568 else
4569 items >>= 7 - (aint & 7);
4570 *aptr++ = items & 0xff;
4571 }
abdc5761
GS		 4572 str = SvPVX(cat) + SvCUR(cat);
4573 while (aptr <= str)
a0d0e21e 4574 *aptr++ = '\0';
79072805 4575
a0d0e21e
LW		 4576 items = saveitems;
4577 }
4578 break;
4579 case 'H':
4580 case 'h':
4581 {
abdc5761 4582 register char *str;
a0d0e21e 4583 I32 saveitems;
79072805 4584
a0d0e21e
LW		 4585 fromstr = NEXTFROM;
4586 saveitems = items;
abdc5761 4587 str = SvPV(fromstr, fromlen);
a0d0e21e
LW		 4588 if (pat[-1] == '*')
4589 len = fromlen;
a0d0e21e
LW		 4590 aint = SvCUR(cat);
4591 SvCUR(cat) += (len+1)/2;
4592 SvGROW(cat, SvCUR(cat) + 1);
4593 aptr = SvPVX(cat) + aint;
4594 if (len > fromlen)
4595 len = fromlen;
4596 aint = len;
4597 items = 0;
4598 if (datumtype == 'H') {
4599 for (len = 0; len++ < aint;) {
abdc5761
GS		 4600 if (isALPHA(*str))
4601 items |= ((*str++ & 15) + 9) & 15;
a0d0e21e 4602 else
abdc5761 4603 items |= *str++ & 15;
a0d0e21e
LW		 4604 if (len & 1)
4605 items <<= 4;
4606 else {
4607 *aptr++ = items & 0xff;
4608 items = 0;
4609 }
4610 }
4611 }
4612 else {
4613 for (len = 0; len++ < aint;) {
abdc5761
GS		 4614 if (isALPHA(*str))
4615 items |= (((*str++ & 15) + 9) & 15) << 4;
a0d0e21e 4616 else
abdc5761 4617 items |= (*str++ & 15) << 4;
a0d0e21e
LW		 4618 if (len & 1)
4619 items >>= 4;
4620 else {
4621 *aptr++ = items & 0xff;
4622 items = 0;
4623 }
4624 }
4625 }
4626 if (aint & 1)
4627 *aptr++ = items & 0xff;
abdc5761
GS		 4628 str = SvPVX(cat) + SvCUR(cat);
4629 while (aptr <= str)
a0d0e21e 4630 *aptr++ = '\0';
79072805 4631
a0d0e21e
LW		 4632 items = saveitems;
4633 }
4634 break;
4635 case 'C':
4636 case 'c':
4637 while (len-- > 0) {
4638 fromstr = NEXTFROM;
4639 aint = SvIV(fromstr);
4640 achar = aint;
4641 sv_catpvn(cat, &achar, sizeof(char));
4642 }
4643 break;
a0ed51b3
LW		 4644 case 'U':
4645 while (len-- > 0) {
4646 fromstr = NEXTFROM;
4647 auint = SvUV(fromstr);
806e7201 4648 SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN);
dfe13c55
GS		 4649 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4650 - SvPVX(cat));
a0ed51b3
LW		 4651 }
4652 *SvEND(cat) = '\0';
4653 break;
a0d0e21e
LW		 4654 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4655 case 'f':
4656 case 'F':
4657 while (len-- > 0) {
4658 fromstr = NEXTFROM;
4659 afloat = (float)SvNV(fromstr);
4660 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4661 }
4662 break;
4663 case 'd':
4664 case 'D':
4665 while (len-- > 0) {
4666 fromstr = NEXTFROM;
4667 adouble = (double)SvNV(fromstr);
4668 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4669 }
4670 break;
4671 case 'n':
4672 while (len-- > 0) {
4673 fromstr = NEXTFROM;
4674 ashort = (I16)SvIV(fromstr);
4675#ifdef HAS_HTONS
6ad3d225 4676 ashort = PerlSock_htons(ashort);
79072805 4677#endif
96e4d5b1 4678 CAT16(cat, &ashort);
a0d0e21e
LW		 4679 }
4680 break;
4681 case 'v':
4682 while (len-- > 0) {
4683 fromstr = NEXTFROM;
4684 ashort = (I16)SvIV(fromstr);
4685#ifdef HAS_HTOVS
4686 ashort = htovs(ashort);
79072805 4687#endif
96e4d5b1 4688 CAT16(cat, &ashort);
a0d0e21e
LW		 4689 }
4690 break;
4691 case 'S':
726ea183 4692#if SHORTSIZE != SIZE16
ef54e1a4
JH		 4693 if (natint) {
4694 unsigned short aushort;
4695
4696 while (len-- > 0) {
4697 fromstr = NEXTFROM;
4698 aushort = SvUV(fromstr);
4699 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4700 }
4701 }
726ea183
JH		 4702 else
4703#endif
4704 {
ef54e1a4
JH		 4705 U16 aushort;
4706
4707 while (len-- > 0) {
4708 fromstr = NEXTFROM;
726ea183 4709 aushort = (U16)SvUV(fromstr);
ef54e1a4
JH		 4710 CAT16(cat, &aushort);
4711 }
726ea183 4712
ef54e1a4
JH		 4713 }
4714 break;
a0d0e21e 4715 case 's':
c67712b2 4716#if SHORTSIZE != SIZE16
ef54e1a4 4717 if (natint) {
bf9315bb
GS		 4718 short ashort;
4719
ef54e1a4
JH		 4720 while (len-- > 0) {
4721 fromstr = NEXTFROM;
4722 ashort = SvIV(fromstr);
4723 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4724 }
4725 }
726ea183
JH		 4726 else
4727#endif
4728 {
ef54e1a4
JH		 4729 while (len-- > 0) {
4730 fromstr = NEXTFROM;
4731 ashort = (I16)SvIV(fromstr);
4732 CAT16(cat, &ashort);
4733 }
a0d0e21e
LW		 4734 }
4735 break;
4736 case 'I':
4737 while (len-- > 0) {
4738 fromstr = NEXTFROM;
96e4d5b1 4739 auint = SvUV(fromstr);
a0d0e21e
LW		 4740 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4741 }
4742 break;
def98dd4
UP		 4743 case 'w':
4744 while (len-- > 0) {
bbce6d69 4745 fromstr = NEXTFROM;
65202027 4746 adouble = Perl_floor(SvNV(fromstr));
bbce6d69 4747
4748 if (adouble < 0)
d470f89e 4749 DIE(aTHX_ "Cannot compress negative numbers");
bbce6d69 4750
46fc3d4c 4751 if (
4752#ifdef BW_BITS
4753 adouble <= BW_MASK
4754#else
ef2d312d
TH		 4755#ifdef CXUX_BROKEN_CONSTANT_CONVERT
4756 adouble <= UV_MAX_cxux
4757#else
46fc3d4c 4758 adouble <= UV_MAX
4759#endif
ef2d312d 4760#endif
46fc3d4c 4761 )
4762 {
bbce6d69 4763 char buf[1 + sizeof(UV)];
4764 char *in = buf + sizeof(buf);
db7c17d7 4765 UV auv = U_V(adouble);
bbce6d69 4766
4767 do {
4768 *--in = (auv & 0x7f) | 0x80;
4769 auv >>= 7;
4770 } while (auv);
4771 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4772 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4773 }
4774 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4775 char *from, *result, *in;
4776 SV *norm;
4777 STRLEN len;
4778 bool done;
8ec5e241 4779
bbce6d69 4780 /* Copy string and check for compliance */
4781 from = SvPV(fromstr, len);
4782 if ((norm = is_an_int(from, len)) == NULL)
d470f89e 4783 DIE(aTHX_ "can compress only unsigned integer");
bbce6d69 4784
4785 New('w', result, len, char);
4786 in = result + len;
4787 done = FALSE;
4788 while (!done)
4789 *--in = div128(norm, &done) | 0x80;
4790 result[len - 1] &= 0x7F; /* clear continue bit */
4791 sv_catpvn(cat, in, (result + len) - in);
5f05dabc 4792 Safefree(result);
bbce6d69 4793 SvREFCNT_dec(norm); /* free norm */
def98dd4 4794 }
bbce6d69 4795 else if (SvNOKp(fromstr)) {
4796 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4797 char *in = buf + sizeof(buf);
4798
4799 do {
4800 double next = floor(adouble / 128);
4801 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4802 if (--in < buf) /* this cannot happen ;-) */
d470f89e 4803 DIE(aTHX_ "Cannot compress integer");
bbce6d69 4804 adouble = next;
4805 } while (adouble > 0);
4806 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4807 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4808 }
4809 else
d470f89e 4810 DIE(aTHX_ "Cannot compress non integer");
bbce6d69 4811 }
def98dd4 4812 break;
a0d0e21e
LW		 4813 case 'i':
4814 while (len-- > 0) {
4815 fromstr = NEXTFROM;
4816 aint = SvIV(fromstr);
4817 sv_catpvn(cat, (char*)&aint, sizeof(int));
4818 }
4819 break;
4820 case 'N':
4821 while (len-- > 0) {
4822 fromstr = NEXTFROM;
96e4d5b1 4823 aulong = SvUV(fromstr);
a0d0e21e 4824#ifdef HAS_HTONL
6ad3d225 4825 aulong = PerlSock_htonl(aulong);
79072805 4826#endif
96e4d5b1 4827 CAT32(cat, &aulong);
a0d0e21e
LW		 4828 }
4829 break;
4830 case 'V':
4831 while (len-- > 0) {
4832 fromstr = NEXTFROM;
96e4d5b1 4833 aulong = SvUV(fromstr);
a0d0e21e
LW		 4834#ifdef HAS_HTOVL
4835 aulong = htovl(aulong);
79072805 4836#endif
96e4d5b1 4837 CAT32(cat, &aulong);
a0d0e21e
LW		 4838 }
4839 break;
4840 case 'L':
726ea183 4841#if LONGSIZE != SIZE32
ef54e1a4 4842 if (natint) {
bf9315bb
GS		 4843 unsigned long aulong;
4844
ef54e1a4
JH		 4845 while (len-- > 0) {
4846 fromstr = NEXTFROM;
4847 aulong = SvUV(fromstr);
4848 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4849 }
4850 }
726ea183
JH		 4851 else
4852#endif
4853 {
ef54e1a4
JH		 4854 while (len-- > 0) {
4855 fromstr = NEXTFROM;
4856 aulong = SvUV(fromstr);
4857 CAT32(cat, &aulong);
4858 }
a0d0e21e
LW		 4859 }
4860 break;
4861 case 'l':
726ea183 4862#if LONGSIZE != SIZE32
ef54e1a4 4863 if (natint) {
bf9315bb
GS		 4864 long along;
4865
ef54e1a4
JH		 4866 while (len-- > 0) {
4867 fromstr = NEXTFROM;
4868 along = SvIV(fromstr);
4869 sv_catpvn(cat, (char *)&along, sizeof(long));
4870 }
4871 }
726ea183
JH		 4872 else
4873#endif
4874 {
ef54e1a4
JH		 4875 while (len-- > 0) {
4876 fromstr = NEXTFROM;
4877 along = SvIV(fromstr);
4878 CAT32(cat, &along);
4879 }
a0d0e21e
LW		 4880 }
4881 break;
6b8eaf93 4882#ifdef HAS_QUAD
a0d0e21e
LW		 4883 case 'Q':
4884 while (len-- > 0) {
4885 fromstr = NEXTFROM;
bf9315bb 4886 auquad = (Uquad_t)SvUV(fromstr);
e862df63 4887 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
a0d0e21e
LW		 4888 }
4889 break;
4890 case 'q':
4891 while (len-- > 0) {
4892 fromstr = NEXTFROM;
ecfc5424
AD		 4893 aquad = (Quad_t)SvIV(fromstr);
4894 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW		 4895 }
4896 break;
1b8cd678 4897#endif
a0d0e21e
LW		 4898 case 'P':
4899 len = 1; /* assume SV is correct length */
4900 /* FALL THROUGH */
4901 case 'p':
4902 while (len-- > 0) {
4903 fromstr = NEXTFROM;
3280af22 4904 if (fromstr == &PL_sv_undef)
84902520 4905 aptr = NULL;
72dbcb4b 4906 else {
2d8e6c8d 4907 STRLEN n_a;
84902520
TB		 4908 /* XXX better yet, could spirit away the string to
4909 * a safe spot and hang on to it until the result
4910 * of pack() (and all copies of the result) are
4911 * gone.
4912 */
e476b1b5 4913 if (ckWARN(WARN_PACK) && (SvTEMP(fromstr)
014822e4
GS		 4914 || (SvPADTMP(fromstr)
4915 && !SvREADONLY(fromstr))))
4916 {
e476b1b5 4917 Perl_warner(aTHX_ WARN_PACK,
599cee73 4918 "Attempt to pack pointer to temporary value");
014822e4 4919 }
84902520 4920 if (SvPOK(fromstr) || SvNIOK(fromstr))
2d8e6c8d 4921 aptr = SvPV(fromstr,n_a);
84902520 4922 else
2d8e6c8d 4923 aptr = SvPV_force(fromstr,n_a);
72dbcb4b 4924 }
a0d0e21e
LW		 4925 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4926 }
4927 break;
4928 case 'u':
4929 fromstr = NEXTFROM;
4930 aptr = SvPV(fromstr, fromlen);
4931 SvGROW(cat, fromlen * 4 / 3);
4932 if (len <= 1)
4933 len = 45;
4934 else
4935 len = len / 3 * 3;
4936 while (fromlen > 0) {
4937 I32 todo;
79072805 4938
a0d0e21e
LW		 4939 if (fromlen > len)
4940 todo = len;
4941 else
4942 todo = fromlen;
4943 doencodes(cat, aptr, todo);
4944 fromlen -= todo;
4945 aptr += todo;
4946 }
4947 break;
4948 }
4949 }
4950 SvSETMAGIC(cat);
4951 SP = ORIGMARK;
4952 PUSHs(cat);
4953 RETURN;
79072805 4954}
a0d0e21e 4955#undef NEXTFROM
79072805 4956
8ec5e241 4957
a0d0e21e 4958PP(pp_split)
79072805 4959{
4e35701f 4960 djSP; dTARG;
a0d0e21e
LW		 4961 AV *ary;
4962 register I32 limit = POPi; /* note, negative is forever */
4963 SV *sv = POPs;
4964 STRLEN len;
4965 register char *s = SvPV(sv, len);
4966 char *strend = s + len;
44a8e56a 4967 register PMOP *pm;
d9f97599 4968 register REGEXP *rx;
a0d0e21e
LW		 4969 register SV *dstr;
4970 register char *m;
4971 I32 iters = 0;
4972 I32 maxiters = (strend - s) + 10;
4973 I32 i;
4974 char *orig;
4975 I32 origlimit = limit;
4976 I32 realarray = 0;
4977 I32 base;
3280af22 4978 AV *oldstack = PL_curstack;
54310121 4979 I32 gimme = GIMME_V;
3280af22 4980 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4981 I32 make_mortal = 1;
4982 MAGIC *mg = (MAGIC *) NULL;
79072805 4983
44a8e56a 4984#ifdef DEBUGGING
4985 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4986#else
4987 pm = (PMOP*)POPs;
4988#endif
a0d0e21e 4989 if (!pm || !s)
cea2e8a9 4990 DIE(aTHX_ "panic: do_split");
d9f97599 4991 rx = pm->op_pmregexp;
bbce6d69 4992
4993 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4994 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4995
971a9dd3
GS		 4996 if (pm->op_pmreplroot) {
4997#ifdef USE_ITHREADS
4998 ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
4999#else
a0d0e21e 5000 ary = GvAVn((GV*)pm->op_pmreplroot);
971a9dd3
GS		 5001#endif
5002 }
a0d0e21e 5003 else if (gimme != G_ARRAY)
6d4ff0d2 5004#ifdef USE_THREADS
533c011a 5005 ary = (AV*)PL_curpad[0];
6d4ff0d2 5006#else
3280af22 5007 ary = GvAVn(PL_defgv);
6d4ff0d2 5008#endif /* USE_THREADS */
79072805 5009 else
a0d0e21e
LW		 5010 ary = Nullav;
5011 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5012 realarray = 1;
8ec5e241 5013 PUTBACK;
a0d0e21e
LW		 5014 av_extend(ary,0);
5015 av_clear(ary);
8ec5e241 5016 SPAGAIN;
33c27489 5017 if (mg = SvTIED_mg((SV*)ary, 'P')) {
8ec5e241 5018 PUSHMARK(SP);
33c27489 5019 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 5020 }
5021 else {
1c0b011c
NIS		 5022 if (!AvREAL(ary)) {
5023 AvREAL_on(ary);
abff13bb 5024 AvREIFY_off(ary);
1c0b011c 5025 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 5026 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 5027 }
5028 /* temporarily switch stacks */
3280af22 5029 SWITCHSTACK(PL_curstack, ary);
8ec5e241 5030 make_mortal = 0;
1c0b011c 5031 }
79072805 5032 }
3280af22 5033 base = SP - PL_stack_base;
a0d0e21e
LW		 5034 orig = s;
5035 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 5036 if (pm->op_pmflags & PMf_LOCALE) {
5037 while (isSPACE_LC(*s))
5038 s++;
5039 }
5040 else {
5041 while (isSPACE(*s))
5042 s++;
5043 }
a0d0e21e 5044 }
c07a80fd 5045 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS		 5046 SAVEINT(PL_multiline);
5047 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 5048 }
5049
a0d0e21e
LW		 5050 if (!limit)
5051 limit = maxiters + 2;
5052 if (pm->op_pmflags & PMf_WHITE) {
5053 while (--limit) {
bbce6d69 5054 m = s;
5055 while (m < strend &&
5056 !((pm->op_pmflags & PMf_LOCALE)
5057 ? isSPACE_LC(*m) : isSPACE(*m)))
5058 ++m;
a0d0e21e
LW		 5059 if (m >= strend)
5060 break;
bbce6d69 5061
a0d0e21e
LW		 5062 dstr = NEWSV(30, m-s);
5063 sv_setpvn(dstr, s, m-s);
8ec5e241 5064 if (make_mortal)
a0d0e21e
LW		 5065 sv_2mortal(dstr);
5066 XPUSHs(dstr);
bbce6d69 5067
5068 s = m + 1;
5069 while (s < strend &&
5070 ((pm->op_pmflags & PMf_LOCALE)
5071 ? isSPACE_LC(*s) : isSPACE(*s)))
5072 ++s;
79072805
LW		 5073 }
5074 }
f4091fba 5075 else if (strEQ("^", rx->precomp)) {
a0d0e21e
LW		 5076 while (--limit) {
5077 /*SUPPRESS 530*/
5078 for (m = s; m < strend && *m != '\n'; m++) ;
5079 m++;
5080 if (m >= strend)
5081 break;
5082 dstr = NEWSV(30, m-s);
5083 sv_setpvn(dstr, s, m-s);
8ec5e241 5084 if (make_mortal)
a0d0e21e
LW		 5085 sv_2mortal(dstr);
5086 XPUSHs(dstr);
5087 s = m;
5088 }
5089 }
f722798b 5090 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 5091 && (rx->reganch & ROPT_CHECK_ALL)
5092 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 5093 int tail = (rx->reganch & RE_INTUIT_TAIL);
5094 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5095 char c;
cf93c79d 5096
ca5b42cb
GS		 5097 len = rx->minlen;
5098 if (len == 1 && !tail) {
5099 c = *SvPV(csv,len);
a0d0e21e 5100 while (--limit) {
bbce6d69 5101 /*SUPPRESS 530*/
f722798b 5102 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 5103 if (m >= strend)
5104 break;
5105 dstr = NEWSV(30, m-s);
5106 sv_setpvn(dstr, s, m-s);
8ec5e241 5107 if (make_mortal)
a0d0e21e
LW		 5108 sv_2mortal(dstr);
5109 XPUSHs(dstr);
5110 s = m + 1;
5111 }
5112 }
5113 else {
5114#ifndef lint
5115 while (s < strend && --limit &&
f722798b
IZ		 5116 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5117 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 5118#endif
a0d0e21e
LW		 5119 {
5120 dstr = NEWSV(31, m-s);
5121 sv_setpvn(dstr, s, m-s);
8ec5e241 5122 if (make_mortal)
a0d0e21e
LW		 5123 sv_2mortal(dstr);
5124 XPUSHs(dstr);
ca5b42cb 5125 s = m + len; /* Fake \n at the end */
a0d0e21e 5126 }
463ee0b2 5127 }
463ee0b2 5128 }
a0d0e21e 5129 else {
d9f97599 5130 maxiters += (strend - s) * rx->nparens;
f722798b
IZ		 5131 while (s < strend && --limit
5132/* && (!rx->check_substr
5133 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5134 0, NULL))))
5135*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5136 1 /* minend */, sv, NULL, 0))
bbce6d69 5137 {
d9f97599 5138 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 5139 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 5140 m = s;
5141 s = orig;
cf93c79d 5142 orig = rx->subbeg;
a0d0e21e
LW		 5143 s = orig + (m - s);
5144 strend = s + (strend - m);
5145 }
cf93c79d 5146 m = rx->startp[0] + orig;
a0d0e21e
LW		 5147 dstr = NEWSV(32, m-s);
5148 sv_setpvn(dstr, s, m-s);
8ec5e241 5149 if (make_mortal)
a0d0e21e
LW		 5150 sv_2mortal(dstr);
5151 XPUSHs(dstr);
d9f97599
GS		 5152 if (rx->nparens) {
5153 for (i = 1; i <= rx->nparens; i++) {
cf93c79d
IZ		 5154 s = rx->startp[i] + orig;
5155 m = rx->endp[i] + orig;
748a9306
LW		 5156 if (m && s) {
5157 dstr = NEWSV(33, m-s);
5158 sv_setpvn(dstr, s, m-s);
5159 }
5160 else
5161 dstr = NEWSV(33, 0);
8ec5e241 5162 if (make_mortal)
a0d0e21e
LW		 5163 sv_2mortal(dstr);
5164 XPUSHs(dstr);
5165 }
5166 }
cf93c79d 5167 s = rx->endp[0] + orig;
a0d0e21e 5168 }
79072805 5169 }
8ec5e241 5170
c07a80fd 5171 LEAVE_SCOPE(oldsave);
3280af22 5172 iters = (SP - PL_stack_base) - base;
a0d0e21e 5173 if (iters > maxiters)
cea2e8a9 5174 DIE(aTHX_ "Split loop");
8ec5e241 5175
a0d0e21e
LW		 5176 /* keep field after final delim? */
5177 if (s < strend || (iters && origlimit)) {
5178 dstr = NEWSV(34, strend-s);
5179 sv_setpvn(dstr, s, strend-s);
8ec5e241 5180 if (make_mortal)
a0d0e21e
LW		 5181 sv_2mortal(dstr);
5182 XPUSHs(dstr);
5183 iters++;
79072805 5184 }
a0d0e21e 5185 else if (!origlimit) {
b1dadf13 5186 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
a0d0e21e
LW		 5187 iters--, SP--;
5188 }
8ec5e241 5189
a0d0e21e 5190 if (realarray) {
8ec5e241 5191 if (!mg) {
1c0b011c
NIS		 5192 SWITCHSTACK(ary, oldstack);
5193 if (SvSMAGICAL(ary)) {
5194 PUTBACK;
5195 mg_set((SV*)ary);
5196 SPAGAIN;
5197 }
5198 if (gimme == G_ARRAY) {
5199 EXTEND(SP, iters);
5200 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5201 SP += iters;
5202 RETURN;
5203 }
8ec5e241 5204 }
1c0b011c 5205 else {
fb73857a 5206 PUTBACK;
8ec5e241 5207 ENTER;
864dbfa3 5208 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 5209 LEAVE;
fb73857a 5210 SPAGAIN;
8ec5e241
NIS		 5211 if (gimme == G_ARRAY) {
5212 /* EXTEND should not be needed - we just popped them */
5213 EXTEND(SP, iters);
5214 for (i=0; i < iters; i++) {
5215 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5216 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5217 }
1c0b011c
NIS		 5218 RETURN;
5219 }
a0d0e21e
LW		 5220 }
5221 }
5222 else {
5223 if (gimme == G_ARRAY)
5224 RETURN;
5225 }
5226 if (iters || !pm->op_pmreplroot) {
5227 GETTARGET;
5228 PUSHi(iters);
5229 RETURN;
5230 }
5231 RETPUSHUNDEF;
79072805 5232}
85e6fe83 5233
c0329465 5234#ifdef USE_THREADS
77a005ab 5235void
864dbfa3 5236Perl_unlock_condpair(pTHX_ void *svv)
c0329465
MB		 5237{
5238 dTHR;
5239 MAGIC *mg = mg_find((SV*)svv, 'm');
8ec5e241 5240
c0329465 5241 if (!mg)
cea2e8a9 5242 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
c0329465
MB		 5243 MUTEX_LOCK(MgMUTEXP(mg));
5244 if (MgOWNER(mg) != thr)
cea2e8a9 5245 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
c0329465
MB		 5246 MgOWNER(mg) = 0;
5247 COND_SIGNAL(MgOWNERCONDP(mg));
b900a521
JH		 5248 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": unlock 0x%"UVxf"\n",
5249 PTR2UV(thr), PTR2UV(svv));)
c0329465
MB		 5250 MUTEX_UNLOCK(MgMUTEXP(mg));
5251}
5252#endif /* USE_THREADS */
5253
5254PP(pp_lock)
5255{
4e35701f 5256 djSP;
c0329465 5257 dTOPss;
e55aaa0e
MB		 5258 SV *retsv = sv;
5259#ifdef USE_THREADS
c0329465 5260 MAGIC *mg;
8ec5e241 5261
c0329465
MB		 5262 if (SvROK(sv))
5263 sv = SvRV(sv);
5264
5265 mg = condpair_magic(sv);
5266 MUTEX_LOCK(MgMUTEXP(mg));
5267 if (MgOWNER(mg) == thr)
5268 MUTEX_UNLOCK(MgMUTEXP(mg));
5269 else {
5270 while (MgOWNER(mg))
5271 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5272 MgOWNER(mg) = thr;
b900a521
JH		 5273 DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": pp_lock lock 0x%"UVxf"\n",
5274 PTR2UV(thr), PTR2UV(sv));)
c0329465 5275 MUTEX_UNLOCK(MgMUTEXP(mg));
c76ac1ee 5276 SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
c0329465
MB		 5277 }
5278#endif /* USE_THREADS */
e55aaa0e
MB		 5279 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5280 || SvTYPE(retsv) == SVt_PVCV) {
5281 retsv = refto(retsv);
5282 }
5283 SETs(retsv);
c0329465
MB		 5284 RETURN;
5285}
a863c7d1 5286
2faa37cc 5287PP(pp_threadsv)
a863c7d1 5288{
12f917ad 5289 djSP;
57d3b86d 5290#ifdef USE_THREADS
924508f0 5291 EXTEND(SP, 1);
533c011a
NIS		 5292 if (PL_op->op_private & OPpLVAL_INTRO)
5293 PUSHs(*save_threadsv(PL_op->op_targ));
554b3eca 5294 else
533c011a 5295 PUSHs(THREADSV(PL_op->op_targ));
fdb47d66 5296 RETURN;
a863c7d1 5297#else
cea2e8a9 5298 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 5299#endif /* USE_THREADS */
a863c7d1 5300}
Unnamed repository; edit this file 'description' to name the repository.