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