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