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