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