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