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