This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
I don't think it's sensible or portable to test the strtou*
[perl5.git] / pp.c
CommitLineData
a0d0e21e 1/* pp.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
79072805 4 *
a0d0e21e
LW
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
79072805 7 *
a0d0e21e
LW
8 */
9
10/*
11 * "It's a big house this, and very peculiar. Always a bit more to discover,
12 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
13 */
79072805
LW
14
15#include "EXTERN.h"
864dbfa3 16#define PERL_IN_PP_C
79072805
LW
17#include "perl.h"
18
36477c24 19/*
ef2d312d
TH
20 * The compiler on Concurrent CX/UX systems has a subtle bug which only
21 * seems to show up when compiling pp.c - it generates the wrong double
22 * precision constant value for (double)UV_MAX when used inline in the body
23 * of the code below, so this makes a static variable up front (which the
24 * compiler seems to get correct) and uses it in place of UV_MAX below.
25 */
26#ifdef CXUX_BROKEN_CONSTANT_CONVERT
27static double UV_MAX_cxux = ((double)UV_MAX);
8ec5e241 28#endif
ef2d312d
TH
29
30/*
96e4d5b1
PP
31 * Offset for integer pack/unpack.
32 *
33 * On architectures where I16 and I32 aren't really 16 and 32 bits,
34 * which for now are all Crays, pack and unpack have to play games.
35 */
36
37/*
38 * These values are required for portability of pack() output.
39 * If they're not right on your machine, then pack() and unpack()
40 * wouldn't work right anyway; you'll need to apply the Cray hack.
41 * (I'd like to check them with #if, but you can't use sizeof() in
dc45a647
MB
42 * the preprocessor.) --???
43 */
44/*
45 The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
46 defines are now in config.h. --Andy Dougherty April 1998
96e4d5b1
PP
47 */
48#define SIZE16 2
49#define SIZE32 4
50
9851f69c
JH
51/* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack().
52 --jhi Feb 1999 */
53
726ea183
JH
54#if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32
55# define PERL_NATINT_PACK
56#endif
57
0f9dfb06 58#if LONGSIZE > 4 && defined(_CRAY)
96e4d5b1
PP
59# if BYTEORDER == 0x12345678
60# define OFF16(p) (char*)(p)
61# define OFF32(p) (char*)(p)
62# else
63# if BYTEORDER == 0x87654321
64# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
65# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
66# else
67 }}}} bad cray byte order
68# endif
69# endif
70# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
71# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
ef54e1a4 72# define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char))
96e4d5b1
PP
73# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
74# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
75#else
76# define COPY16(s,p) Copy(s, p, SIZE16, char)
77# define COPY32(s,p) Copy(s, p, SIZE32, char)
ef54e1a4 78# define COPYNN(s,p,n) Copy(s, (char *)(p), n, char)
96e4d5b1
PP
79# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
80# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
81#endif
82
a0d0e21e 83/* variations on pp_null */
79072805 84
dfe9444c
AD
85/* XXX I can't imagine anyone who doesn't have this actually _needs_
86 it, since pid_t is an integral type.
87 --AD 2/20/1998
88*/
89#ifdef NEED_GETPID_PROTO
90extern Pid_t getpid (void);
8ac85365
NIS
91#endif
92
93a17b20
LW
93PP(pp_stub)
94{
4e35701f 95 djSP;
54310121 96 if (GIMME_V == G_SCALAR)
3280af22 97 XPUSHs(&PL_sv_undef);
93a17b20
LW
98 RETURN;
99}
100
79072805
LW
101PP(pp_scalar)
102{
103 return NORMAL;
104}
105
106/* Pushy stuff. */
107
93a17b20
LW
108PP(pp_padav)
109{
4e35701f 110 djSP; dTARGET;
533c011a
NIS
111 if (PL_op->op_private & OPpLVAL_INTRO)
112 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
85e6fe83 113 EXTEND(SP, 1);
533c011a 114 if (PL_op->op_flags & OPf_REF) {
85e6fe83 115 PUSHs(TARG);
93a17b20 116 RETURN;
85e6fe83
LW
117 }
118 if (GIMME == G_ARRAY) {
119 I32 maxarg = AvFILL((AV*)TARG) + 1;
120 EXTEND(SP, maxarg);
93965878
NIS
121 if (SvMAGICAL(TARG)) {
122 U32 i;
123 for (i=0; i < maxarg; i++) {
124 SV **svp = av_fetch((AV*)TARG, i, FALSE);
3280af22 125 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
93965878
NIS
126 }
127 }
128 else {
129 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
130 }
85e6fe83
LW
131 SP += maxarg;
132 }
133 else {
134 SV* sv = sv_newmortal();
135 I32 maxarg = AvFILL((AV*)TARG) + 1;
136 sv_setiv(sv, maxarg);
137 PUSHs(sv);
138 }
139 RETURN;
93a17b20
LW
140}
141
142PP(pp_padhv)
143{
4e35701f 144 djSP; dTARGET;
54310121
PP
145 I32 gimme;
146
93a17b20 147 XPUSHs(TARG);
533c011a
NIS
148 if (PL_op->op_private & OPpLVAL_INTRO)
149 SAVECLEARSV(PL_curpad[PL_op->op_targ]);
150 if (PL_op->op_flags & OPf_REF)
93a17b20 151 RETURN;
54310121
PP
152 gimme = GIMME_V;
153 if (gimme == G_ARRAY) {
cea2e8a9 154 RETURNOP(do_kv());
85e6fe83 155 }
54310121 156 else if (gimme == G_SCALAR) {
85e6fe83 157 SV* sv = sv_newmortal();
46fc3d4c 158 if (HvFILL((HV*)TARG))
cea2e8a9 159 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
46fc3d4c 160 (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
85e6fe83
LW
161 else
162 sv_setiv(sv, 0);
163 SETs(sv);
85e6fe83 164 }
54310121 165 RETURN;
93a17b20
LW
166}
167
ed6116ce
LW
168PP(pp_padany)
169{
cea2e8a9 170 DIE(aTHX_ "NOT IMPL LINE %d",__LINE__);
ed6116ce
LW
171}
172
79072805
LW
173/* Translations. */
174
175PP(pp_rv2gv)
176{
b13b2135 177 djSP; dTOPss;
8ec5e241 178
ed6116ce 179 if (SvROK(sv)) {
a0d0e21e 180 wasref:
f5284f61
IZ
181 tryAMAGICunDEREF(to_gv);
182
ed6116ce 183 sv = SvRV(sv);
b1dadf13
PP
184 if (SvTYPE(sv) == SVt_PVIO) {
185 GV *gv = (GV*) sv_newmortal();
186 gv_init(gv, 0, "", 0, 0);
187 GvIOp(gv) = (IO *)sv;
3e3baf6d 188 (void)SvREFCNT_inc(sv);
b1dadf13 189 sv = (SV*) gv;
ef54e1a4
JH
190 }
191 else if (SvTYPE(sv) != SVt_PVGV)
cea2e8a9 192 DIE(aTHX_ "Not a GLOB reference");
79072805
LW
193 }
194 else {
93a17b20 195 if (SvTYPE(sv) != SVt_PVGV) {
748a9306 196 char *sym;
c9d5ac95 197 STRLEN len;
748a9306 198
a0d0e21e
LW
199 if (SvGMAGICAL(sv)) {
200 mg_get(sv);
201 if (SvROK(sv))
202 goto wasref;
203 }
afd1915d 204 if (!SvOK(sv) && sv != &PL_sv_undef) {
b13b2135 205 /* If this is a 'my' scalar and flag is set then vivify
853846ea 206 * NI-S 1999/05/07
b13b2135 207 */
1d8d4d2a 208 if (PL_op->op_private & OPpDEREF) {
2c8ac474
GS
209 char *name;
210 GV *gv;
211 if (cUNOP->op_targ) {
212 STRLEN len;
213 SV *namesv = PL_curpad[cUNOP->op_targ];
214 name = SvPV(namesv, len);
2d6d9f7a 215 gv = (GV*)NEWSV(0,0);
2c8ac474
GS
216 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
217 }
218 else {
219 name = CopSTASHPV(PL_curcop);
220 gv = newGVgen(name);
1d8d4d2a 221 }
b13b2135
NIS
222 if (SvTYPE(sv) < SVt_RV)
223 sv_upgrade(sv, SVt_RV);
2c8ac474 224 SvRV(sv) = (SV*)gv;
853846ea 225 SvROK_on(sv);
1d8d4d2a 226 SvSETMAGIC(sv);
853846ea 227 goto wasref;
2c8ac474 228 }
533c011a
NIS
229 if (PL_op->op_flags & OPf_REF ||
230 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 231 DIE(aTHX_ PL_no_usym, "a symbol");
599cee73 232 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 233 report_uninit();
a0d0e21e
LW
234 RETSETUNDEF;
235 }
c9d5ac95 236 sym = SvPV(sv,len);
35cd451c
GS
237 if ((PL_op->op_flags & OPf_SPECIAL) &&
238 !(PL_op->op_flags & OPf_MOD))
239 {
240 sv = (SV*)gv_fetchpv(sym, FALSE, SVt_PVGV);
c9d5ac95
GS
241 if (!sv
242 && (!is_gv_magical(sym,len,0)
243 || !(sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV))))
244 {
35cd451c 245 RETSETUNDEF;
c9d5ac95 246 }
35cd451c
GS
247 }
248 else {
249 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 250 DIE(aTHX_ PL_no_symref, sym, "a symbol");
35cd451c
GS
251 sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
252 }
93a17b20 253 }
79072805 254 }
533c011a
NIS
255 if (PL_op->op_private & OPpLVAL_INTRO)
256 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
79072805
LW
257 SETs(sv);
258 RETURN;
259}
260
79072805
LW
261PP(pp_rv2sv)
262{
4e35701f 263 djSP; dTOPss;
79072805 264
ed6116ce 265 if (SvROK(sv)) {
a0d0e21e 266 wasref:
f5284f61
IZ
267 tryAMAGICunDEREF(to_sv);
268
ed6116ce 269 sv = SvRV(sv);
79072805
LW
270 switch (SvTYPE(sv)) {
271 case SVt_PVAV:
272 case SVt_PVHV:
273 case SVt_PVCV:
cea2e8a9 274 DIE(aTHX_ "Not a SCALAR reference");
79072805
LW
275 }
276 }
277 else {
f12c7020 278 GV *gv = (GV*)sv;
748a9306 279 char *sym;
c9d5ac95 280 STRLEN len;
748a9306 281
463ee0b2 282 if (SvTYPE(gv) != SVt_PVGV) {
a0d0e21e
LW
283 if (SvGMAGICAL(sv)) {
284 mg_get(sv);
285 if (SvROK(sv))
286 goto wasref;
287 }
288 if (!SvOK(sv)) {
533c011a
NIS
289 if (PL_op->op_flags & OPf_REF ||
290 PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 291 DIE(aTHX_ PL_no_usym, "a SCALAR");
599cee73 292 if (ckWARN(WARN_UNINITIALIZED))
b89fed5f 293 report_uninit();
a0d0e21e
LW
294 RETSETUNDEF;
295 }
c9d5ac95 296 sym = SvPV(sv, len);
35cd451c
GS
297 if ((PL_op->op_flags & OPf_SPECIAL) &&
298 !(PL_op->op_flags & OPf_MOD))
299 {
300 gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PV);
c9d5ac95
GS
301 if (!gv
302 && (!is_gv_magical(sym,len,0)
303 || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV))))
304 {
35cd451c 305 RETSETUNDEF;
c9d5ac95 306 }
35cd451c
GS
307 }
308 else {
309 if (PL_op->op_private & HINT_STRICT_REFS)
cea2e8a9 310 DIE(aTHX_ PL_no_symref, sym, "a SCALAR");
35cd451c
GS
311 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
312 }
463ee0b2
LW
313 }
314 sv = GvSV(gv);
a0d0e21e 315 }
533c011a
NIS
316 if (PL_op->op_flags & OPf_MOD) {
317 if (PL_op->op_private & OPpLVAL_INTRO)
a0d0e21e 318 sv = save_scalar((GV*)TOPs);
533c011a
NIS
319 else if (PL_op->op_private & OPpDEREF)
320 vivify_ref(sv, PL_op->op_private & OPpDEREF);
79072805 321 }
a0d0e21e 322 SETs(sv);
79072805
LW
323 RETURN;
324}
325
326PP(pp_av2arylen)
327{
4e35701f 328 djSP;
79072805
LW
329 AV *av = (AV*)TOPs;
330 SV *sv = AvARYLEN(av);
331 if (!sv) {
332 AvARYLEN(av) = sv = NEWSV(0,0);
333 sv_upgrade(sv, SVt_IV);
334 sv_magic(sv, (SV*)av, '#', Nullch, 0);
335 }
336 SETs(sv);
337 RETURN;
338}
339
a0d0e21e
LW
340PP(pp_pos)
341{
4e35701f 342 djSP; dTARGET; dPOPss;
8ec5e241 343
533c011a 344 if (PL_op->op_flags & OPf_MOD) {
5f05dabc
PP
345 if (SvTYPE(TARG) < SVt_PVLV) {
346 sv_upgrade(TARG, SVt_PVLV);
347 sv_magic(TARG, Nullsv, '.', Nullch, 0);
348 }
349
350 LvTYPE(TARG) = '.';
6ff81951
GS
351 if (LvTARG(TARG) != sv) {
352 if (LvTARG(TARG))
353 SvREFCNT_dec(LvTARG(TARG));
354 LvTARG(TARG) = SvREFCNT_inc(sv);
355 }
a0d0e21e
LW
356 PUSHs(TARG); /* no SvSETMAGIC */
357 RETURN;
358 }
359 else {
8ec5e241 360 MAGIC* mg;
a0d0e21e
LW
361
362 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
363 mg = mg_find(sv, 'g');
565764a8 364 if (mg && mg->mg_len >= 0) {
a0ed51b3 365 I32 i = mg->mg_len;
7e2040f0 366 if (DO_UTF8(sv))
a0ed51b3
LW
367 sv_pos_b2u(sv, &i);
368 PUSHi(i + PL_curcop->cop_arybase);
a0d0e21e
LW
369 RETURN;
370 }
371 }
372 RETPUSHUNDEF;
373 }
374}
375
79072805
LW
376PP(pp_rv2cv)
377{
4e35701f 378 djSP;
79072805
LW
379 GV *gv;
380 HV *stash;
8990e307 381
4633a7c4
LW
382 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
383 /* (But not in defined().) */
533c011a 384 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
07055b4c
CS
385 if (cv) {
386 if (CvCLONE(cv))
387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
cd06dffe 388 if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
d470f89e 389 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
07055b4c
CS
390 }
391 else
3280af22 392 cv = (CV*)&PL_sv_undef;
79072805
LW
393 SETs((SV*)cv);
394 RETURN;
395}
396
c07a80fd
PP
397PP(pp_prototype)
398{
4e35701f 399 djSP;
c07a80fd
PP
400 CV *cv;
401 HV *stash;
402 GV *gv;
403 SV *ret;
404
3280af22 405 ret = &PL_sv_undef;
b6c543e3
IZ
406 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
407 char *s = SvPVX(TOPs);
408 if (strnEQ(s, "CORE::", 6)) {
409 int code;
b13b2135 410
b6c543e3
IZ
411 code = keyword(s + 6, SvCUR(TOPs) - 6);
412 if (code < 0) { /* Overridable. */
413#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
414 int i = 0, n = 0, seen_question = 0;
415 I32 oa;
416 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
417
418 while (i < MAXO) { /* The slow way. */
22c35a8c
GS
419 if (strEQ(s + 6, PL_op_name[i])
420 || strEQ(s + 6, PL_op_desc[i]))
421 {
b6c543e3 422 goto found;
22c35a8c 423 }
b6c543e3
IZ
424 i++;
425 }
426 goto nonesuch; /* Should not happen... */
427 found:
22c35a8c 428 oa = PL_opargs[i] >> OASHIFT;
b6c543e3 429 while (oa) {
3012a639 430 if (oa & OA_OPTIONAL && !seen_question) {
b6c543e3
IZ
431 seen_question = 1;
432 str[n++] = ';';
ef54e1a4 433 }
b13b2135 434 else if (n && str[0] == ';' && seen_question)
b6c543e3 435 goto set; /* XXXX system, exec */
b13b2135 436 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
b6c543e3
IZ
437 && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
438 str[n++] = '\\';
439 }
440 /* What to do with R ((un)tie, tied, (sys)read, recv)? */
441 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
442 oa = oa >> 4;
443 }
444 str[n++] = '\0';
79cb57f6 445 ret = sv_2mortal(newSVpvn(str, n - 1));
ef54e1a4
JH
446 }
447 else if (code) /* Non-Overridable */
b6c543e3
IZ
448 goto set;
449 else { /* None such */
450 nonesuch:
d470f89e 451 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
b6c543e3
IZ
452 }
453 }
454 }
c07a80fd 455 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
5f05dabc 456 if (cv && SvPOK(cv))
79cb57f6 457 ret = sv_2mortal(newSVpvn(SvPVX(cv), SvCUR(cv)));
b6c543e3 458 set:
c07a80fd
PP
459 SETs(ret);
460 RETURN;
461}
462
a0d0e21e
LW
463PP(pp_anoncode)
464{
4e35701f 465 djSP;
533c011a 466 CV* cv = (CV*)PL_curpad[PL_op->op_targ];
a5f75d66 467 if (CvCLONE(cv))
b355b4e0 468 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
5f05dabc 469 EXTEND(SP,1);
748a9306 470 PUSHs((SV*)cv);
a0d0e21e
LW
471 RETURN;
472}
473
474PP(pp_srefgen)
79072805 475{
4e35701f 476 djSP;
71be2cbc 477 *SP = refto(*SP);
79072805 478 RETURN;
8ec5e241 479}
a0d0e21e
LW
480
481PP(pp_refgen)
482{
4e35701f 483 djSP; dMARK;
a0d0e21e 484 if (GIMME != G_ARRAY) {
5f0b1d4e
GS
485 if (++MARK <= SP)
486 *MARK = *SP;
487 else
3280af22 488 *MARK = &PL_sv_undef;
5f0b1d4e
GS
489 *MARK = refto(*MARK);
490 SP = MARK;
491 RETURN;
a0d0e21e 492 }
bbce6d69 493 EXTEND_MORTAL(SP - MARK);
71be2cbc
PP
494 while (++MARK <= SP)
495 *MARK = refto(*MARK);
a0d0e21e 496 RETURN;
79072805
LW
497}
498
76e3520e 499STATIC SV*
cea2e8a9 500S_refto(pTHX_ SV *sv)
71be2cbc
PP
501{
502 SV* rv;
503
504 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
505 if (LvTARGLEN(sv))
68dc0745
PP
506 vivify_defelem(sv);
507 if (!(sv = LvTARG(sv)))
3280af22 508 sv = &PL_sv_undef;
0dd88869 509 else
a6c40364 510 (void)SvREFCNT_inc(sv);
71be2cbc 511 }
d8b46c1b
GS
512 else if (SvTYPE(sv) == SVt_PVAV) {
513 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
514 av_reify((AV*)sv);
515 SvTEMP_off(sv);
516 (void)SvREFCNT_inc(sv);
517 }
71be2cbc
PP
518 else if (SvPADTMP(sv))
519 sv = newSVsv(sv);
520 else {
521 SvTEMP_off(sv);
522 (void)SvREFCNT_inc(sv);
523 }
524 rv = sv_newmortal();
525 sv_upgrade(rv, SVt_RV);
526 SvRV(rv) = sv;
527 SvROK_on(rv);
528 return rv;
529}
530
79072805
LW
531PP(pp_ref)
532{
4e35701f 533 djSP; dTARGET;
463ee0b2 534 SV *sv;
79072805
LW
535 char *pv;
536
a0d0e21e 537 sv = POPs;
f12c7020
PP
538
539 if (sv && SvGMAGICAL(sv))
8ec5e241 540 mg_get(sv);
f12c7020 541
a0d0e21e 542 if (!sv || !SvROK(sv))
4633a7c4 543 RETPUSHNO;
79072805 544
ed6116ce 545 sv = SvRV(sv);
a0d0e21e 546 pv = sv_reftype(sv,TRUE);
463ee0b2 547 PUSHp(pv, strlen(pv));
79072805
LW
548 RETURN;
549}
550
551PP(pp_bless)
552{
4e35701f 553 djSP;
463ee0b2 554 HV *stash;
79072805 555
463ee0b2 556 if (MAXARG == 1)
11faa288 557 stash = CopSTASH(PL_curcop);
7b8d334a
GS
558 else {
559 SV *ssv = POPs;
560 STRLEN len;
81689caa
HS
561 char *ptr;
562
016a42f3 563 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
81689caa
HS
564 Perl_croak(aTHX_ "Attempt to bless into a reference");
565 ptr = SvPV(ssv,len);
e476b1b5 566 if (ckWARN(WARN_MISC) && len == 0)
b13b2135 567 Perl_warner(aTHX_ WARN_MISC,
599cee73 568 "Explicit blessing to '' (assuming package main)");
7b8d334a
GS
569 stash = gv_stashpvn(ptr, len, TRUE);
570 }
a0d0e21e 571
5d3fdfeb 572 (void)sv_bless(TOPs, stash);
79072805
LW
573 RETURN;
574}
575
fb73857a
PP
576PP(pp_gelem)
577{
578 GV *gv;
579 SV *sv;
76e3520e 580 SV *tmpRef;
fb73857a 581 char *elem;
4e35701f 582 djSP;
2d8e6c8d 583 STRLEN n_a;
b13b2135 584
fb73857a 585 sv = POPs;
2d8e6c8d 586 elem = SvPV(sv, n_a);
fb73857a 587 gv = (GV*)POPs;
76e3520e 588 tmpRef = Nullsv;
fb73857a
PP
589 sv = Nullsv;
590 switch (elem ? *elem : '\0')
591 {
592 case 'A':
593 if (strEQ(elem, "ARRAY"))
76e3520e 594 tmpRef = (SV*)GvAV(gv);
fb73857a
PP
595 break;
596 case 'C':
597 if (strEQ(elem, "CODE"))
76e3520e 598 tmpRef = (SV*)GvCVu(gv);
fb73857a
PP
599 break;
600 case 'F':
601 if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
76e3520e 602 tmpRef = (SV*)GvIOp(gv);
f4d13ee9
JH
603 else
604 if (strEQ(elem, "FORMAT"))
605 tmpRef = (SV*)GvFORM(gv);
fb73857a
PP
606 break;
607 case 'G':
608 if (strEQ(elem, "GLOB"))
76e3520e 609 tmpRef = (SV*)gv;
fb73857a
PP
610 break;
611 case 'H':
612 if (strEQ(elem, "HASH"))
76e3520e 613 tmpRef = (SV*)GvHV(gv);
fb73857a
PP
614 break;
615 case 'I':
616 if (strEQ(elem, "IO"))
76e3520e 617 tmpRef = (SV*)GvIOp(gv);
fb73857a
PP
618 break;
619 case 'N':
620 if (strEQ(elem, "NAME"))
79cb57f6 621 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
fb73857a
PP
622 break;
623 case 'P':
624 if (strEQ(elem, "PACKAGE"))
625 sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
626 break;
627 case 'S':
628 if (strEQ(elem, "SCALAR"))
76e3520e 629 tmpRef = GvSV(gv);
fb73857a
PP
630 break;
631 }
76e3520e
GS
632 if (tmpRef)
633 sv = newRV(tmpRef);
fb73857a
PP
634 if (sv)
635 sv_2mortal(sv);
636 else
3280af22 637 sv = &PL_sv_undef;
fb73857a
PP
638 XPUSHs(sv);
639 RETURN;
640}
641
a0d0e21e 642/* Pattern matching */
79072805 643
a0d0e21e 644PP(pp_study)
79072805 645{
4e35701f 646 djSP; dPOPss;
a0d0e21e
LW
647 register unsigned char *s;
648 register I32 pos;
649 register I32 ch;
650 register I32 *sfirst;
651 register I32 *snext;
a0d0e21e
LW
652 STRLEN len;
653
3280af22 654 if (sv == PL_lastscream) {
1e422769
PP
655 if (SvSCREAM(sv))
656 RETPUSHYES;
657 }
c07a80fd 658 else {
3280af22
NIS
659 if (PL_lastscream) {
660 SvSCREAM_off(PL_lastscream);
661 SvREFCNT_dec(PL_lastscream);
c07a80fd 662 }
3280af22 663 PL_lastscream = SvREFCNT_inc(sv);
c07a80fd 664 }
1e422769
PP
665
666 s = (unsigned char*)(SvPV(sv, len));
667 pos = len;
668 if (pos <= 0)
669 RETPUSHNO;
3280af22
NIS
670 if (pos > PL_maxscream) {
671 if (PL_maxscream < 0) {
672 PL_maxscream = pos + 80;
673 New(301, PL_screamfirst, 256, I32);
674 New(302, PL_screamnext, PL_maxscream, I32);
79072805
LW
675 }
676 else {
3280af22
NIS
677 PL_maxscream = pos + pos / 4;
678 Renew(PL_screamnext, PL_maxscream, I32);
79072805 679 }
79072805 680 }
a0d0e21e 681
3280af22
NIS
682 sfirst = PL_screamfirst;
683 snext = PL_screamnext;
a0d0e21e
LW
684
685 if (!sfirst || !snext)
cea2e8a9 686 DIE(aTHX_ "do_study: out of memory");
a0d0e21e
LW
687
688 for (ch = 256; ch; --ch)
689 *sfirst++ = -1;
690 sfirst -= 256;
691
692 while (--pos >= 0) {
693 ch = s[pos];
694 if (sfirst[ch] >= 0)
695 snext[pos] = sfirst[ch] - pos;
696 else
697 snext[pos] = -pos;
698 sfirst[ch] = pos;
79072805
LW
699 }
700
c07a80fd 701 SvSCREAM_on(sv);
464e2e8a 702 sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
1e422769 703 RETPUSHYES;
79072805
LW
704}
705
a0d0e21e 706PP(pp_trans)
79072805 707{
4e35701f 708 djSP; dTARG;
a0d0e21e
LW
709 SV *sv;
710
533c011a 711 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e 712 sv = POPs;
79072805 713 else {
54b9620d 714 sv = DEFSV;
a0d0e21e 715 EXTEND(SP,1);
79072805 716 }
adbc6bb1 717 TARG = sv_newmortal();
4757a243 718 PUSHi(do_trans(sv));
a0d0e21e 719 RETURN;
79072805
LW
720}
721
a0d0e21e 722/* Lvalue operators. */
79072805 723
a0d0e21e
LW
724PP(pp_schop)
725{
4e35701f 726 djSP; dTARGET;
a0d0e21e
LW
727 do_chop(TARG, TOPs);
728 SETTARG;
729 RETURN;
79072805
LW
730}
731
a0d0e21e 732PP(pp_chop)
79072805 733{
4e35701f 734 djSP; dMARK; dTARGET;
a0d0e21e
LW
735 while (SP > MARK)
736 do_chop(TARG, POPs);
737 PUSHTARG;
738 RETURN;
79072805
LW
739}
740
a0d0e21e 741PP(pp_schomp)
79072805 742{
4e35701f 743 djSP; dTARGET;
a0d0e21e
LW
744 SETi(do_chomp(TOPs));
745 RETURN;
79072805
LW
746}
747
a0d0e21e 748PP(pp_chomp)
79072805 749{
4e35701f 750 djSP; dMARK; dTARGET;
a0d0e21e 751 register I32 count = 0;
8ec5e241 752
a0d0e21e
LW
753 while (SP > MARK)
754 count += do_chomp(POPs);
755 PUSHi(count);
756 RETURN;
79072805
LW
757}
758
a0d0e21e 759PP(pp_defined)
463ee0b2 760{
4e35701f 761 djSP;
a0d0e21e
LW
762 register SV* sv;
763
764 sv = POPs;
765 if (!sv || !SvANY(sv))
766 RETPUSHNO;
767 switch (SvTYPE(sv)) {
768 case SVt_PVAV:
6051dbdb 769 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW
770 RETPUSHYES;
771 break;
772 case SVt_PVHV:
6051dbdb 773 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
a0d0e21e
LW
774 RETPUSHYES;
775 break;
776 case SVt_PVCV:
777 if (CvROOT(sv) || CvXSUB(sv))
778 RETPUSHYES;
779 break;
780 default:
781 if (SvGMAGICAL(sv))
782 mg_get(sv);
783 if (SvOK(sv))
784 RETPUSHYES;
785 }
786 RETPUSHNO;
463ee0b2
LW
787}
788
a0d0e21e
LW
789PP(pp_undef)
790{
4e35701f 791 djSP;
a0d0e21e
LW
792 SV *sv;
793
533c011a 794 if (!PL_op->op_private) {
774d564b 795 EXTEND(SP, 1);
a0d0e21e 796 RETPUSHUNDEF;
774d564b 797 }
79072805 798
a0d0e21e
LW
799 sv = POPs;
800 if (!sv)
801 RETPUSHUNDEF;
85e6fe83 802
6fc92669
GS
803 if (SvTHINKFIRST(sv))
804 sv_force_normal(sv);
85e6fe83 805
a0d0e21e
LW
806 switch (SvTYPE(sv)) {
807 case SVt_NULL:
808 break;
809 case SVt_PVAV:
810 av_undef((AV*)sv);
811 break;
812 case SVt_PVHV:
813 hv_undef((HV*)sv);
814 break;
815 case SVt_PVCV:
e476b1b5
GS
816 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv))
817 Perl_warner(aTHX_ WARN_MISC, "Constant subroutine %s undefined",
54310121 818 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
9607fc9c
PP
819 /* FALL THROUGH */
820 case SVt_PVFM:
6fc92669
GS
821 {
822 /* let user-undef'd sub keep its identity */
823 GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
824 cv_undef((CV*)sv);
825 CvGV((CV*)sv) = gv;
826 }
a0d0e21e 827 break;
8e07c86e 828 case SVt_PVGV:
44a8e56a 829 if (SvFAKE(sv))
3280af22 830 SvSetMagicSV(sv, &PL_sv_undef);
20408e3c
GS
831 else {
832 GP *gp;
833 gp_free((GV*)sv);
834 Newz(602, gp, 1, GP);
835 GvGP(sv) = gp_ref(gp);
836 GvSV(sv) = NEWSV(72,0);
57843af0 837 GvLINE(sv) = CopLINE(PL_curcop);
20408e3c
GS
838 GvEGV(sv) = (GV*)sv;
839 GvMULTI_on(sv);
840 }
44a8e56a 841 break;
a0d0e21e 842 default:
1e422769 843 if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
4633a7c4
LW
844 (void)SvOOK_off(sv);
845 Safefree(SvPVX(sv));
846 SvPV_set(sv, Nullch);
847 SvLEN_set(sv, 0);
a0d0e21e 848 }
4633a7c4
LW
849 (void)SvOK_off(sv);
850 SvSETMAGIC(sv);
79072805 851 }
a0d0e21e
LW
852
853 RETPUSHUNDEF;
79072805
LW
854}
855
a0d0e21e 856PP(pp_predec)
79072805 857{
4e35701f 858 djSP;
68dc0745 859 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 860 DIE(aTHX_ PL_no_modify);
25da4f38 861 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
862 SvIVX(TOPs) != IV_MIN)
863 {
748a9306 864 --SvIVX(TOPs);
55497cff 865 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
866 }
867 else
868 sv_dec(TOPs);
a0d0e21e
LW
869 SvSETMAGIC(TOPs);
870 return NORMAL;
871}
79072805 872
a0d0e21e
LW
873PP(pp_postinc)
874{
4e35701f 875 djSP; dTARGET;
68dc0745 876 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 877 DIE(aTHX_ PL_no_modify);
a0d0e21e 878 sv_setsv(TARG, TOPs);
25da4f38 879 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
880 SvIVX(TOPs) != IV_MAX)
881 {
748a9306 882 ++SvIVX(TOPs);
55497cff 883 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
884 }
885 else
886 sv_inc(TOPs);
a0d0e21e
LW
887 SvSETMAGIC(TOPs);
888 if (!SvOK(TARG))
889 sv_setiv(TARG, 0);
890 SETs(TARG);
891 return NORMAL;
892}
79072805 893
a0d0e21e
LW
894PP(pp_postdec)
895{
4e35701f 896 djSP; dTARGET;
43192e07 897 if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
d470f89e 898 DIE(aTHX_ PL_no_modify);
a0d0e21e 899 sv_setsv(TARG, TOPs);
25da4f38 900 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
55497cff
PP
901 SvIVX(TOPs) != IV_MIN)
902 {
748a9306 903 --SvIVX(TOPs);
55497cff 904 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
748a9306
LW
905 }
906 else
907 sv_dec(TOPs);
a0d0e21e
LW
908 SvSETMAGIC(TOPs);
909 SETs(TARG);
910 return NORMAL;
911}
79072805 912
a0d0e21e
LW
913/* Ordinary operators. */
914
915PP(pp_pow)
916{
8ec5e241 917 djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
a0d0e21e
LW
918 {
919 dPOPTOPnnrl;
73b309ea 920 SETn( Perl_pow( left, right) );
a0d0e21e 921 RETURN;
93a17b20 922 }
a0d0e21e
LW
923}
924
925PP(pp_multiply)
926{
8ec5e241 927 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW
928 {
929 dPOPTOPnnrl;
930 SETn( left * right );
931 RETURN;
79072805 932 }
a0d0e21e
LW
933}
934
935PP(pp_divide)
936{
8ec5e241 937 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e 938 {
77676ba1 939 dPOPPOPnnrl;
65202027 940 NV value;
7a4c00b4 941 if (right == 0.0)
cea2e8a9 942 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
943#ifdef SLOPPYDIVIDE
944 /* insure that 20./5. == 4. */
945 {
7a4c00b4 946 IV k;
65202027
DS
947 if ((NV)I_V(left) == left &&
948 (NV)I_V(right) == right &&
7a4c00b4 949 (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
a0d0e21e 950 value = k;
ef54e1a4
JH
951 }
952 else {
7a4c00b4 953 value = left / right;
79072805 954 }
a0d0e21e
LW
955 }
956#else
7a4c00b4 957 value = left / right;
a0d0e21e
LW
958#endif
959 PUSHn( value );
960 RETURN;
79072805 961 }
a0d0e21e
LW
962}
963
964PP(pp_modulo)
965{
76e3520e 966 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
a0d0e21e 967 {
787eafbd
IZ
968 UV left;
969 UV right;
970 bool left_neg;
971 bool right_neg;
972 bool use_double = 0;
65202027
DS
973 NV dright;
974 NV dleft;
787eafbd 975
d658dc55 976 if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
787eafbd
IZ
977 IV i = SvIVX(POPs);
978 right = (right_neg = (i < 0)) ? -i : i;
979 }
980 else {
981 dright = POPn;
982 use_double = 1;
983 right_neg = dright < 0;
984 if (right_neg)
985 dright = -dright;
986 }
a0d0e21e 987
d658dc55 988 if (!use_double && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
787eafbd
IZ
989 IV i = SvIVX(POPs);
990 left = (left_neg = (i < 0)) ? -i : i;
991 }
992 else {
993 dleft = POPn;
994 if (!use_double) {
a1bd196e
GS
995 use_double = 1;
996 dright = right;
787eafbd
IZ
997 }
998 left_neg = dleft < 0;
999 if (left_neg)
1000 dleft = -dleft;
1001 }
68dc0745 1002
787eafbd 1003 if (use_double) {
65202027 1004 NV dans;
787eafbd
IZ
1005
1006#if 1
787eafbd
IZ
1007/* Somehow U_V is pessimized even if CASTFLAGS is 0 */
1008# if CASTFLAGS & 2
1009# define CAST_D2UV(d) U_V(d)
1010# else
1011# define CAST_D2UV(d) ((UV)(d))
1012# endif
a1bd196e
GS
1013 /* Tried to do this only in the case DOUBLESIZE <= UV_SIZE,
1014 * or, in other words, precision of UV more than of NV.
1015 * But in fact the approach below turned out to be an
1016 * optimization - floor() may be slow */
787eafbd
IZ
1017 if (dright <= UV_MAX && dleft <= UV_MAX) {
1018 right = CAST_D2UV(dright);
1019 left = CAST_D2UV(dleft);
1020 goto do_uv;
1021 }
1022#endif
1023
1024 /* Backward-compatibility clause: */
73b309ea
JH
1025 dright = Perl_floor(dright + 0.5);
1026 dleft = Perl_floor(dleft + 0.5);
787eafbd
IZ
1027
1028 if (!dright)
cea2e8a9 1029 DIE(aTHX_ "Illegal modulus zero");
787eafbd 1030
65202027 1031 dans = Perl_fmod(dleft, dright);
787eafbd
IZ
1032 if ((left_neg != right_neg) && dans)
1033 dans = dright - dans;
1034 if (right_neg)
1035 dans = -dans;
1036 sv_setnv(TARG, dans);
1037 }
1038 else {
1039 UV ans;
1040
1041 do_uv:
1042 if (!right)
cea2e8a9 1043 DIE(aTHX_ "Illegal modulus zero");
787eafbd
IZ
1044
1045 ans = left % right;
1046 if ((left_neg != right_neg) && ans)
1047 ans = right - ans;
1048 if (right_neg) {
1049 /* XXX may warn: unary minus operator applied to unsigned type */
1050 /* could change -foo to be (~foo)+1 instead */
1051 if (ans <= ~((UV)IV_MAX)+1)
1052 sv_setiv(TARG, ~ans+1);
1053 else
65202027 1054 sv_setnv(TARG, -(NV)ans);
787eafbd
IZ
1055 }
1056 else
1057 sv_setuv(TARG, ans);
1058 }
1059 PUSHTARG;
1060 RETURN;
79072805 1061 }
a0d0e21e 1062}
79072805 1063
a0d0e21e
LW
1064PP(pp_repeat)
1065{
4e35701f 1066 djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
748a9306 1067 {
467f0320 1068 register IV count = POPi;
533c011a 1069 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
a0d0e21e
LW
1070 dMARK;
1071 I32 items = SP - MARK;
1072 I32 max;
79072805 1073
a0d0e21e
LW
1074 max = items * count;
1075 MEXTEND(MARK, max);
1076 if (count > 1) {
1077 while (SP > MARK) {
1078 if (*SP)
1079 SvTEMP_off((*SP));
1080 SP--;
79072805 1081 }
a0d0e21e
LW
1082 MARK++;
1083 repeatcpy((char*)(MARK + items), (char*)MARK,
1084 items * sizeof(SV*), count - 1);
1085 SP += max;
79072805 1086 }
a0d0e21e
LW
1087 else if (count <= 0)
1088 SP -= items;
79072805 1089 }
a0d0e21e 1090 else { /* Note: mark already snarfed by pp_list */
dfcb284a 1091 SV *tmpstr = POPs;
a0d0e21e 1092 STRLEN len;
3aa33fe5 1093 bool isutf = DO_UTF8(tmpstr);
a0d0e21e 1094
a0d0e21e
LW
1095 SvSetSV(TARG, tmpstr);
1096 SvPV_force(TARG, len);
8ebc5c01
PP
1097 if (count != 1) {
1098 if (count < 1)
1099 SvCUR_set(TARG, 0);
1100 else {
1101 SvGROW(TARG, (count * len) + 1);
a0d0e21e 1102 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
8ebc5c01 1103 SvCUR(TARG) *= count;
7a4c00b4 1104 }
a0d0e21e 1105 *SvEND(TARG) = '\0';
a0d0e21e 1106 }
dfcb284a
GS
1107 if (isutf)
1108 (void)SvPOK_only_UTF8(TARG);
1109 else
1110 (void)SvPOK_only(TARG);
a0d0e21e 1111 PUSHTARG;
79072805 1112 }
a0d0e21e 1113 RETURN;
748a9306 1114 }
a0d0e21e 1115}
79072805 1116
a0d0e21e
LW
1117PP(pp_subtract)
1118{
98a29390 1119 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 1120 {
98a29390
JH
1121 dPOPTOPnnrl_ul;
1122 SETn( left - right );
1123 RETURN;
79072805 1124 }
a0d0e21e 1125}
79072805 1126
a0d0e21e
LW
1127PP(pp_left_shift)
1128{
8ec5e241 1129 djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
a0d0e21e 1130 {
972b05a9 1131 IV shift = POPi;
d0ba1bd2 1132 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1133 IV i = TOPi;
1134 SETi(i << shift);
d0ba1bd2
JH
1135 }
1136 else {
972b05a9
JH
1137 UV u = TOPu;
1138 SETu(u << shift);
d0ba1bd2 1139 }
55497cff 1140 RETURN;
79072805 1141 }
a0d0e21e 1142}
79072805 1143
a0d0e21e
LW
1144PP(pp_right_shift)
1145{
8ec5e241 1146 djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
a0d0e21e 1147 {
972b05a9 1148 IV shift = POPi;
d0ba1bd2 1149 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1150 IV i = TOPi;
1151 SETi(i >> shift);
d0ba1bd2
JH
1152 }
1153 else {
972b05a9
JH
1154 UV u = TOPu;
1155 SETu(u >> shift);
d0ba1bd2 1156 }
a0d0e21e 1157 RETURN;
93a17b20 1158 }
79072805
LW
1159}
1160
a0d0e21e 1161PP(pp_lt)
79072805 1162{
8ec5e241 1163 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW
1164 {
1165 dPOPnv;
54310121 1166 SETs(boolSV(TOPn < value));
a0d0e21e 1167 RETURN;
79072805 1168 }
a0d0e21e 1169}
79072805 1170
a0d0e21e
LW
1171PP(pp_gt)
1172{
8ec5e241 1173 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW
1174 {
1175 dPOPnv;
54310121 1176 SETs(boolSV(TOPn > value));
a0d0e21e 1177 RETURN;
79072805 1178 }
a0d0e21e
LW
1179}
1180
1181PP(pp_le)
1182{
8ec5e241 1183 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW
1184 {
1185 dPOPnv;
54310121 1186 SETs(boolSV(TOPn <= value));
a0d0e21e 1187 RETURN;
79072805 1188 }
a0d0e21e
LW
1189}
1190
1191PP(pp_ge)
1192{
8ec5e241 1193 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW
1194 {
1195 dPOPnv;
54310121 1196 SETs(boolSV(TOPn >= value));
a0d0e21e 1197 RETURN;
79072805 1198 }
a0d0e21e 1199}
79072805 1200
a0d0e21e
LW
1201PP(pp_ne)
1202{
8ec5e241 1203 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW
1204 {
1205 dPOPnv;
54310121 1206 SETs(boolSV(TOPn != value));
a0d0e21e
LW
1207 RETURN;
1208 }
79072805
LW
1209}
1210
a0d0e21e 1211PP(pp_ncmp)
79072805 1212{
8ec5e241 1213 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW
1214 {
1215 dPOPTOPnnrl;
1216 I32 value;
79072805 1217
a3540c92 1218#ifdef Perl_isnan
1ad04cfd
JH
1219 if (Perl_isnan(left) || Perl_isnan(right)) {
1220 SETs(&PL_sv_undef);
1221 RETURN;
1222 }
1223 value = (left > right) - (left < right);
1224#else
ff0cee69 1225 if (left == right)
a0d0e21e 1226 value = 0;
a0d0e21e
LW
1227 else if (left < right)
1228 value = -1;
44a8e56a
PP
1229 else if (left > right)
1230 value = 1;
1231 else {
3280af22 1232 SETs(&PL_sv_undef);
44a8e56a
PP
1233 RETURN;
1234 }
1ad04cfd 1235#endif
a0d0e21e
LW
1236 SETi(value);
1237 RETURN;
79072805 1238 }
a0d0e21e 1239}
79072805 1240
a0d0e21e
LW
1241PP(pp_slt)
1242{
8ec5e241 1243 djSP; tryAMAGICbinSET(slt,0);
a0d0e21e
LW
1244 {
1245 dPOPTOPssrl;
533c011a 1246 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1247 ? sv_cmp_locale(left, right)
1248 : sv_cmp(left, right));
54310121 1249 SETs(boolSV(cmp < 0));
a0d0e21e
LW
1250 RETURN;
1251 }
79072805
LW
1252}
1253
a0d0e21e 1254PP(pp_sgt)
79072805 1255{
8ec5e241 1256 djSP; tryAMAGICbinSET(sgt,0);
a0d0e21e
LW
1257 {
1258 dPOPTOPssrl;
533c011a 1259 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1260 ? sv_cmp_locale(left, right)
1261 : sv_cmp(left, right));
54310121 1262 SETs(boolSV(cmp > 0));
a0d0e21e
LW
1263 RETURN;
1264 }
1265}
79072805 1266
a0d0e21e
LW
1267PP(pp_sle)
1268{
8ec5e241 1269 djSP; tryAMAGICbinSET(sle,0);
a0d0e21e
LW
1270 {
1271 dPOPTOPssrl;
533c011a 1272 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1273 ? sv_cmp_locale(left, right)
1274 : sv_cmp(left, right));
54310121 1275 SETs(boolSV(cmp <= 0));
a0d0e21e 1276 RETURN;
79072805 1277 }
79072805
LW
1278}
1279
a0d0e21e
LW
1280PP(pp_sge)
1281{
8ec5e241 1282 djSP; tryAMAGICbinSET(sge,0);
a0d0e21e
LW
1283 {
1284 dPOPTOPssrl;
533c011a 1285 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1286 ? sv_cmp_locale(left, right)
1287 : sv_cmp(left, right));
54310121 1288 SETs(boolSV(cmp >= 0));
a0d0e21e
LW
1289 RETURN;
1290 }
1291}
79072805 1292
36477c24
PP
1293PP(pp_seq)
1294{
8ec5e241 1295 djSP; tryAMAGICbinSET(seq,0);
36477c24
PP
1296 {
1297 dPOPTOPssrl;
54310121 1298 SETs(boolSV(sv_eq(left, right)));
a0d0e21e
LW
1299 RETURN;
1300 }
1301}
79072805 1302
a0d0e21e 1303PP(pp_sne)
79072805 1304{
8ec5e241 1305 djSP; tryAMAGICbinSET(sne,0);
a0d0e21e
LW
1306 {
1307 dPOPTOPssrl;
54310121 1308 SETs(boolSV(!sv_eq(left, right)));
a0d0e21e 1309 RETURN;
463ee0b2 1310 }
79072805
LW
1311}
1312
a0d0e21e 1313PP(pp_scmp)
79072805 1314{
4e35701f 1315 djSP; dTARGET; tryAMAGICbin(scmp,0);
a0d0e21e
LW
1316 {
1317 dPOPTOPssrl;
533c011a 1318 int cmp = ((PL_op->op_private & OPpLOCALE)
bbce6d69
PP
1319 ? sv_cmp_locale(left, right)
1320 : sv_cmp(left, right));
1321 SETi( cmp );
a0d0e21e
LW
1322 RETURN;
1323 }
1324}
79072805 1325
55497cff
PP
1326PP(pp_bit_and)
1327{
8ec5e241 1328 djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
a0d0e21e
LW
1329 {
1330 dPOPTOPssrl;
4633a7c4 1331 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 1332 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1333 IV i = SvIV(left) & SvIV(right);
1334 SETi(i);
d0ba1bd2
JH
1335 }
1336 else {
972b05a9
JH
1337 UV u = SvUV(left) & SvUV(right);
1338 SETu(u);
d0ba1bd2 1339 }
a0d0e21e
LW
1340 }
1341 else {
533c011a 1342 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
1343 SETTARG;
1344 }
1345 RETURN;
1346 }
1347}
79072805 1348
a0d0e21e
LW
1349PP(pp_bit_xor)
1350{
8ec5e241 1351 djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
a0d0e21e
LW
1352 {
1353 dPOPTOPssrl;
4633a7c4 1354 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 1355 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1356 IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
1357 SETi(i);
d0ba1bd2
JH
1358 }
1359 else {
972b05a9
JH
1360 UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
1361 SETu(u);
d0ba1bd2 1362 }
a0d0e21e
LW
1363 }
1364 else {
533c011a 1365 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
1366 SETTARG;
1367 }
1368 RETURN;
1369 }
1370}
79072805 1371
a0d0e21e
LW
1372PP(pp_bit_or)
1373{
8ec5e241 1374 djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
a0d0e21e
LW
1375 {
1376 dPOPTOPssrl;
4633a7c4 1377 if (SvNIOKp(left) || SvNIOKp(right)) {
d0ba1bd2 1378 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1379 IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
1380 SETi(i);
d0ba1bd2
JH
1381 }
1382 else {
972b05a9
JH
1383 UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
1384 SETu(u);
d0ba1bd2 1385 }
a0d0e21e
LW
1386 }
1387 else {
533c011a 1388 do_vop(PL_op->op_type, TARG, left, right);
a0d0e21e
LW
1389 SETTARG;
1390 }
1391 RETURN;
79072805 1392 }
a0d0e21e 1393}
79072805 1394
a0d0e21e
LW
1395PP(pp_negate)
1396{
4e35701f 1397 djSP; dTARGET; tryAMAGICun(neg);
a0d0e21e
LW
1398 {
1399 dTOPss;
4633a7c4
LW
1400 if (SvGMAGICAL(sv))
1401 mg_get(sv);
98a29390 1402 if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv)) {
9b0e499b
GS
1403 if (SvIsUV(sv)) {
1404 if (SvIVX(sv) == IV_MIN) {
1405 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
1406 RETURN;
1407 }
1408 else if (SvUVX(sv) <= IV_MAX) {
beccb14c 1409 SETi(-SvIVX(sv));
9b0e499b
GS
1410 RETURN;
1411 }
1412 }
1413 else if (SvIVX(sv) != IV_MIN) {
1414 SETi(-SvIVX(sv));
1415 RETURN;
1416 }
1417 }
1418 if (SvNIOKp(sv))
a0d0e21e 1419 SETn(-SvNV(sv));
4633a7c4 1420 else if (SvPOKp(sv)) {
a0d0e21e
LW
1421 STRLEN len;
1422 char *s = SvPV(sv, len);
bbce6d69 1423 if (isIDFIRST(*s)) {
a0d0e21e
LW
1424 sv_setpvn(TARG, "-", 1);
1425 sv_catsv(TARG, sv);
79072805 1426 }
a0d0e21e
LW
1427 else if (*s == '+' || *s == '-') {
1428 sv_setsv(TARG, sv);
1429 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
79072805 1430 }
7e2040f0 1431 else if (DO_UTF8(sv) && *(U8*)s >= 0xc0 && isIDFIRST_utf8((U8*)s)) {
834a4ddd
LW
1432 sv_setpvn(TARG, "-", 1);
1433 sv_catsv(TARG, sv);
1434 }
98a29390
JH
1435 else
1436 sv_setnv(TARG, -SvNV(sv));
a0d0e21e 1437 SETTARG;
79072805 1438 }
4633a7c4
LW
1439 else
1440 SETn(-SvNV(sv));
79072805 1441 }
a0d0e21e 1442 RETURN;
79072805
LW
1443}
1444
a0d0e21e 1445PP(pp_not)
79072805 1446{
4e35701f 1447 djSP; tryAMAGICunSET(not);
3280af22 1448 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
a0d0e21e 1449 return NORMAL;
79072805
LW
1450}
1451
a0d0e21e 1452PP(pp_complement)
79072805 1453{
8ec5e241 1454 djSP; dTARGET; tryAMAGICun(compl);
a0d0e21e
LW
1455 {
1456 dTOPss;
4633a7c4 1457 if (SvNIOKp(sv)) {
d0ba1bd2 1458 if (PL_op->op_private & HINT_INTEGER) {
972b05a9
JH
1459 IV i = ~SvIV(sv);
1460 SETi(i);
d0ba1bd2
JH
1461 }
1462 else {
972b05a9
JH
1463 UV u = ~SvUV(sv);
1464 SETu(u);
d0ba1bd2 1465 }
a0d0e21e
LW
1466 }
1467 else {
51723571 1468 register U8 *tmps;
55497cff 1469 register I32 anum;
a0d0e21e
LW
1470 STRLEN len;
1471
1472 SvSetSV(TARG, sv);
51723571 1473 tmps = (U8*)SvPV_force(TARG, len);
a0d0e21e 1474 anum = len;
1d68d6cd 1475 if (SvUTF8(TARG)) {
a1ca4561 1476 /* Calculate exact length, let's not estimate. */
1d68d6cd
SC
1477 STRLEN targlen = 0;
1478 U8 *result;
51723571 1479 U8 *send;
ba210ebe 1480 STRLEN l;
a1ca4561
YST
1481 UV nchar = 0;
1482 UV nwide = 0;
1d68d6cd
SC
1483
1484 send = tmps + len;
1485 while (tmps < send) {
cc366d4b 1486 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
1d68d6cd 1487 tmps += UTF8SKIP(tmps);
5bbb0b5a 1488 targlen += UNISKIP(~c);
a1ca4561
YST
1489 nchar++;
1490 if (c > 0xff)
1491 nwide++;
1d68d6cd
SC
1492 }
1493
1494 /* Now rewind strings and write them. */
1495 tmps -= len;
a1ca4561
YST
1496
1497 if (nwide) {
1498 Newz(0, result, targlen + 1, U8);
1499 while (tmps < send) {
cc366d4b 1500 UV c = utf8_to_uv(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
a1ca4561
YST
1501 tmps += UTF8SKIP(tmps);
1502 result = uv_to_utf8(result, ~c);
1503 }
1504 *result = '\0';
1505 result -= targlen;
1506 sv_setpvn(TARG, (char*)result, targlen);
1507 SvUTF8_on(TARG);
1508 }
1509 else {
1510 Newz(0, result, nchar + 1, U8);
1511 while (tmps < send) {
1512 U8 c = (U8)utf8_to_uv(tmps, 0, &l, UTF8_ALLOW_ANY);
1513 tmps += UTF8SKIP(tmps);
1514 *result++ = ~c;
1515 }
1516 *result = '\0';
1517 result -= nchar;
1518 sv_setpvn(TARG, (char*)result, nchar);
1d68d6cd 1519 }
1d68d6cd
SC
1520 Safefree(result);
1521 SETs(TARG);
1522 RETURN;
1523 }
a0d0e21e 1524#ifdef LIBERAL
51723571
JH
1525 {
1526 register long *tmpl;
1527 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
1528 *tmps = ~*tmps;
1529 tmpl = (long*)tmps;
1530 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
1531 *tmpl = ~*tmpl;
1532 tmps = (U8*)tmpl;
1533 }
a0d0e21e
LW
1534#endif
1535 for ( ; anum > 0; anum--, tmps++)
1536 *tmps = ~*tmps;
1537
1538 SETs(TARG);
1539 }
1540 RETURN;
1541 }
79072805
LW
1542}
1543
a0d0e21e
LW
1544/* integer versions of some of the above */
1545
a0d0e21e 1546PP(pp_i_multiply)
79072805 1547{
8ec5e241 1548 djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
a0d0e21e
LW
1549 {
1550 dPOPTOPiirl;
1551 SETi( left * right );
1552 RETURN;
1553 }
79072805
LW
1554}
1555
a0d0e21e 1556PP(pp_i_divide)
79072805 1557{
8ec5e241 1558 djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
a0d0e21e
LW
1559 {
1560 dPOPiv;
1561 if (value == 0)
cea2e8a9 1562 DIE(aTHX_ "Illegal division by zero");
a0d0e21e
LW
1563 value = POPi / value;
1564 PUSHi( value );
1565 RETURN;
1566 }
79072805
LW
1567}
1568
a0d0e21e 1569PP(pp_i_modulo)
79072805 1570{
b13b2135 1571 djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
79072805 1572 {
a0d0e21e 1573 dPOPTOPiirl;
aa306039 1574 if (!right)
cea2e8a9 1575 DIE(aTHX_ "Illegal modulus zero");
a0d0e21e
LW
1576 SETi( left % right );
1577 RETURN;
79072805 1578 }
79072805
LW
1579}
1580
a0d0e21e 1581PP(pp_i_add)
79072805 1582{
8ec5e241 1583 djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
a0d0e21e 1584 {
5e66d4f1 1585 dPOPTOPiirl_ul;
a0d0e21e
LW
1586 SETi( left + right );
1587 RETURN;
79072805 1588 }
79072805
LW
1589}
1590
a0d0e21e 1591PP(pp_i_subtract)
79072805 1592{
8ec5e241 1593 djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
a0d0e21e 1594 {
5e66d4f1 1595 dPOPTOPiirl_ul;
a0d0e21e
LW
1596 SETi( left - right );
1597 RETURN;
79072805 1598 }
79072805
LW
1599}
1600
a0d0e21e 1601PP(pp_i_lt)
79072805 1602{
8ec5e241 1603 djSP; tryAMAGICbinSET(lt,0);
a0d0e21e
LW
1604 {
1605 dPOPTOPiirl;
54310121 1606 SETs(boolSV(left < right));
a0d0e21e
LW
1607 RETURN;
1608 }
79072805
LW
1609}
1610
a0d0e21e 1611PP(pp_i_gt)
79072805 1612{
8ec5e241 1613 djSP; tryAMAGICbinSET(gt,0);
a0d0e21e
LW
1614 {
1615 dPOPTOPiirl;
54310121 1616 SETs(boolSV(left > right));
a0d0e21e
LW
1617 RETURN;
1618 }
79072805
LW
1619}
1620
a0d0e21e 1621PP(pp_i_le)
79072805 1622{
8ec5e241 1623 djSP; tryAMAGICbinSET(le,0);
a0d0e21e
LW
1624 {
1625 dPOPTOPiirl;
54310121 1626 SETs(boolSV(left <= right));
a0d0e21e 1627 RETURN;
85e6fe83 1628 }
79072805
LW
1629}
1630
a0d0e21e 1631PP(pp_i_ge)
79072805 1632{
8ec5e241 1633 djSP; tryAMAGICbinSET(ge,0);
a0d0e21e
LW
1634 {
1635 dPOPTOPiirl;
54310121 1636 SETs(boolSV(left >= right));
a0d0e21e
LW
1637 RETURN;
1638 }
79072805
LW
1639}
1640
a0d0e21e 1641PP(pp_i_eq)
79072805 1642{
8ec5e241 1643 djSP; tryAMAGICbinSET(eq,0);
a0d0e21e
LW
1644 {
1645 dPOPTOPiirl;
54310121 1646 SETs(boolSV(left == right));
a0d0e21e
LW
1647 RETURN;
1648 }
79072805
LW
1649}
1650
a0d0e21e 1651PP(pp_i_ne)
79072805 1652{
8ec5e241 1653 djSP; tryAMAGICbinSET(ne,0);
a0d0e21e
LW
1654 {
1655 dPOPTOPiirl;
54310121 1656 SETs(boolSV(left != right));
a0d0e21e
LW
1657 RETURN;
1658 }
79072805
LW
1659}
1660
a0d0e21e 1661PP(pp_i_ncmp)
79072805 1662{
8ec5e241 1663 djSP; dTARGET; tryAMAGICbin(ncmp,0);
a0d0e21e
LW
1664 {
1665 dPOPTOPiirl;
1666 I32 value;
79072805 1667
a0d0e21e 1668 if (left > right)
79072805 1669 value = 1;
a0d0e21e 1670 else if (left < right)
79072805 1671 value = -1;
a0d0e21e 1672 else
79072805 1673 value = 0;
a0d0e21e
LW
1674 SETi(value);
1675 RETURN;
79072805 1676 }
85e6fe83
LW
1677}
1678
1679PP(pp_i_negate)
1680{
4e35701f 1681 djSP; dTARGET; tryAMAGICun(neg);
85e6fe83
LW
1682 SETi(-TOPi);
1683 RETURN;
1684}
1685
79072805
LW
1686/* High falutin' math. */
1687
1688PP(pp_atan2)
1689{
8ec5e241 1690 djSP; dTARGET; tryAMAGICbin(atan2,0);
a0d0e21e
LW
1691 {
1692 dPOPTOPnnrl;
65202027 1693 SETn(Perl_atan2(left, right));
a0d0e21e
LW
1694 RETURN;
1695 }
79072805
LW
1696}
1697
1698PP(pp_sin)
1699{
4e35701f 1700 djSP; dTARGET; tryAMAGICun(sin);
a0d0e21e 1701 {
65202027 1702 NV value;
a0d0e21e 1703 value = POPn;
65202027 1704 value = Perl_sin(value);
a0d0e21e
LW
1705 XPUSHn(value);
1706 RETURN;
1707 }
79072805
LW
1708}
1709
1710PP(pp_cos)
1711{
4e35701f 1712 djSP; dTARGET; tryAMAGICun(cos);
a0d0e21e 1713 {
65202027 1714 NV value;
a0d0e21e 1715 value = POPn;
65202027 1716 value = Perl_cos(value);
a0d0e21e
LW
1717 XPUSHn(value);
1718 RETURN;
1719 }
79072805
LW
1720}
1721
56cb0a1c
AD
1722/* Support Configure command-line overrides for rand() functions.
1723 After 5.005, perhaps we should replace this by Configure support
1724 for drand48(), random(), or rand(). For 5.005, though, maintain
1725 compatibility by calling rand() but allow the user to override it.
1726 See INSTALL for details. --Andy Dougherty 15 July 1998
1727*/
85ab1d1d
JH
1728/* Now it's after 5.005, and Configure supports drand48() and random(),
1729 in addition to rand(). So the overrides should not be needed any more.
1730 --Jarkko Hietaniemi 27 September 1998
1731 */
1732
1733#ifndef HAS_DRAND48_PROTO
20ce7b12 1734extern double drand48 (void);
56cb0a1c
AD
1735#endif
1736
79072805
LW
1737PP(pp_rand)
1738{
4e35701f 1739 djSP; dTARGET;
65202027 1740 NV value;
79072805
LW
1741 if (MAXARG < 1)
1742 value = 1.0;
1743 else
1744 value = POPn;
1745 if (value == 0.0)
1746 value = 1.0;
80252599 1747 if (!PL_srand_called) {
85ab1d1d 1748 (void)seedDrand01((Rand_seed_t)seed());
80252599 1749 PL_srand_called = TRUE;
93dc8474 1750 }
85ab1d1d 1751 value *= Drand01();
79072805
LW
1752 XPUSHn(value);
1753 RETURN;
1754}
1755
1756PP(pp_srand)
1757{
4e35701f 1758 djSP;
93dc8474
CS
1759 UV anum;
1760 if (MAXARG < 1)
1761 anum = seed();
79072805 1762 else
93dc8474 1763 anum = POPu;
85ab1d1d 1764 (void)seedDrand01((Rand_seed_t)anum);
80252599 1765 PL_srand_called = TRUE;
79072805
LW
1766 EXTEND(SP, 1);
1767 RETPUSHYES;
1768}
1769
76e3520e 1770STATIC U32
cea2e8a9 1771S_seed(pTHX)
93dc8474 1772{
54310121
PP
1773 /*
1774 * This is really just a quick hack which grabs various garbage
1775 * values. It really should be a real hash algorithm which
1776 * spreads the effect of every input bit onto every output bit,
85ab1d1d 1777 * if someone who knows about such things would bother to write it.
54310121 1778 * Might be a good idea to add that function to CORE as well.
85ab1d1d 1779 * No numbers below come from careful analysis or anything here,
54310121
PP
1780 * except they are primes and SEED_C1 > 1E6 to get a full-width
1781 * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
1782 * probably be bigger too.
1783 */
1784#if RANDBITS > 16
1785# define SEED_C1 1000003
1786#define SEED_C4 73819
1787#else
1788# define SEED_C1 25747
1789#define SEED_C4 20639
1790#endif
1791#define SEED_C2 3
1792#define SEED_C3 269
1793#define SEED_C5 26107
1794
73c60299
RS
1795#ifndef PERL_NO_DEV_RANDOM
1796 int fd;
1797#endif
93dc8474 1798 U32 u;
f12c7020
PP
1799#ifdef VMS
1800# include <starlet.h>
43c92808
HF
1801 /* when[] = (low 32 bits, high 32 bits) of time since epoch
1802 * in 100-ns units, typically incremented ever 10 ms. */
93dc8474 1803 unsigned int when[2];
73c60299
RS
1804#else
1805# ifdef HAS_GETTIMEOFDAY
1806 struct timeval when;
1807# else
1808 Time_t when;
1809# endif
1810#endif
1811
1812/* This test is an escape hatch, this symbol isn't set by Configure. */
1813#ifndef PERL_NO_DEV_RANDOM
1814#ifndef PERL_RANDOM_DEVICE
1815 /* /dev/random isn't used by default because reads from it will block
1816 * if there isn't enough entropy available. You can compile with
1817 * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
1818 * is enough real entropy to fill the seed. */
1819# define PERL_RANDOM_DEVICE "/dev/urandom"
1820#endif
1821 fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
1822 if (fd != -1) {
1823 if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
1824 u = 0;
1825 PerlLIO_close(fd);
1826 if (u)
1827 return u;
1828 }
1829#endif
1830
1831#ifdef VMS
93dc8474 1832 _ckvmssts(sys$gettim(when));
54310121 1833 u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
f12c7020 1834#else
5f05dabc 1835# ifdef HAS_GETTIMEOFDAY
93dc8474 1836 gettimeofday(&when,(struct timezone *) 0);
54310121 1837 u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
f12c7020 1838# else
93dc8474 1839 (void)time(&when);
54310121 1840 u = (U32)SEED_C1 * when;
f12c7020
PP
1841# endif
1842#endif
7766f137 1843 u += SEED_C3 * (U32)PerlProc_getpid();
56431972 1844 u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
54310121 1845#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
56431972 1846 u += SEED_C5 * (U32)PTR2UV(&when);
f12c7020 1847#endif
93dc8474 1848 return u;
79072805
LW
1849}
1850
1851PP(pp_exp)
1852{
4e35701f 1853 djSP; dTARGET; tryAMAGICun(exp);
a0d0e21e 1854 {
65202027 1855 NV value;
a0d0e21e 1856 value = POPn;
65202027 1857 value = Perl_exp(value);
a0d0e21e
LW
1858 XPUSHn(value);
1859 RETURN;
1860 }
79072805
LW
1861}
1862
1863PP(pp_log)
1864{
4e35701f 1865 djSP; dTARGET; tryAMAGICun(log);
a0d0e21e 1866 {
65202027 1867 NV value;
a0d0e21e 1868 value = POPn;
bbce6d69 1869 if (value <= 0.0) {
f93f4e46 1870 SET_NUMERIC_STANDARD();
cea2e8a9 1871 DIE(aTHX_ "Can't take log of %g", value);
bbce6d69 1872 }
65202027 1873 value = Perl_log(value);
a0d0e21e
LW
1874 XPUSHn(value);
1875 RETURN;
1876 }
79072805
LW
1877}
1878
1879PP(pp_sqrt)
1880{
4e35701f 1881 djSP; dTARGET; tryAMAGICun(sqrt);
a0d0e21e 1882 {
65202027 1883 NV value;
a0d0e21e 1884 value = POPn;
bbce6d69 1885 if (value < 0.0) {
f93f4e46 1886 SET_NUMERIC_STANDARD();
cea2e8a9 1887 DIE(aTHX_ "Can't take sqrt of %g", value);
bbce6d69 1888 }
65202027 1889 value = Perl_sqrt(value);
a0d0e21e
LW
1890 XPUSHn(value);
1891 RETURN;
1892 }
79072805
LW
1893}
1894
1895PP(pp_int)
1896{
4e35701f 1897 djSP; dTARGET;
774d564b 1898 {
98a29390
JH
1899 NV value = TOPn;
1900 IV iv;
1901
1902 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
1903 iv = SvIVX(TOPs);
1904 SETi(iv);
1905 }
1906 else {
1048ea30
JH
1907 if (value >= 0.0) {
1908#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
98a29390 1909 (void)Perl_modf(value, &value);
1048ea30 1910#else
98a29390
JH
1911 double tmp = (double)value;
1912 (void)Perl_modf(tmp, &tmp);
1913 value = (NV)tmp;
1048ea30
JH
1914#endif
1915 }
98a29390 1916 else {
1048ea30 1917#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
98a29390
JH
1918 (void)Perl_modf(-value, &value);
1919 value = -value;
1048ea30 1920#else
98a29390
JH
1921 double tmp = (double)value;
1922 (void)Perl_modf(-tmp, &tmp);
1923 value = -(NV)tmp;
1048ea30 1924#endif
98a29390
JH
1925 }
1926 iv = I_V(value);
1927 if (iv == value)
1928 SETi(iv);
1929 else
1930 SETn(value);
774d564b 1931 }
79072805 1932 }
79072805
LW
1933 RETURN;
1934}
1935
463ee0b2
LW
1936PP(pp_abs)
1937{
4e35701f 1938 djSP; dTARGET; tryAMAGICun(abs);
a0d0e21e 1939 {
98a29390
JH
1940 NV value = TOPn;
1941 IV iv;
1942
1943 if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
1944 (iv = SvIVX(TOPs)) != IV_MIN) {
1945 if (iv < 0)
1946 iv = -iv;
1947 SETi(iv);
1948 }
1949 else {
774d564b 1950 if (value < 0.0)
98a29390 1951 value = -value;
774d564b
PP
1952 SETn(value);
1953 }
a0d0e21e 1954 }
774d564b 1955 RETURN;
463ee0b2
LW
1956}
1957
79072805
LW
1958PP(pp_hex)
1959{
4e35701f 1960 djSP; dTARGET;
79072805 1961 char *tmps;
ba210ebe 1962 STRLEN argtype;
2d8e6c8d 1963 STRLEN n_a;
79072805 1964
2d8e6c8d 1965 tmps = POPpx;
b21ed0a9 1966 argtype = 1; /* allow underscores */
9e24b6e2 1967 XPUSHn(scan_hex(tmps, 99, &argtype));
79072805
LW
1968 RETURN;
1969}
1970
1971PP(pp_oct)
1972{
4e35701f 1973 djSP; dTARGET;
9e24b6e2 1974 NV value;
ba210ebe 1975 STRLEN argtype;
79072805 1976 char *tmps;
2d8e6c8d 1977 STRLEN n_a;
79072805 1978
2d8e6c8d 1979 tmps = POPpx;
464e2e8a
PP
1980 while (*tmps && isSPACE(*tmps))
1981 tmps++;
9e24b6e2
JH
1982 if (*tmps == '0')
1983 tmps++;
b21ed0a9 1984 argtype = 1; /* allow underscores */
9e24b6e2
JH
1985 if (*tmps == 'x')
1986 value = scan_hex(++tmps, 99, &argtype);
1987 else if (*tmps == 'b')
1988 value = scan_bin(++tmps, 99, &argtype);
464e2e8a 1989 else
9e24b6e2
JH
1990 value = scan_oct(tmps, 99, &argtype);
1991 XPUSHn(value);
79072805
LW
1992 RETURN;
1993}
1994
1995/* String stuff. */
1996
1997PP(pp_length)
1998{
4e35701f 1999 djSP; dTARGET;
7e2040f0 2000 SV *sv = TOPs;
a0ed51b3 2001
7e2040f0
GS
2002 if (DO_UTF8(sv))
2003 SETi(sv_len_utf8(sv));
2004 else
2005 SETi(sv_len(sv));
79072805
LW
2006 RETURN;
2007}
2008
2009PP(pp_substr)
2010{
4e35701f 2011 djSP; dTARGET;
79072805
LW
2012 SV *sv;
2013 I32 len;
463ee0b2 2014 STRLEN curlen;
a0ed51b3 2015 STRLEN utfcurlen;
79072805
LW
2016 I32 pos;
2017 I32 rem;
84902520 2018 I32 fail;
533c011a 2019 I32 lvalue = PL_op->op_flags & OPf_MOD;
79072805 2020 char *tmps;
3280af22 2021 I32 arybase = PL_curcop->cop_arybase;
7b8d334a
GS
2022 char *repl = 0;
2023 STRLEN repl_len;
79072805 2024
20408e3c 2025 SvTAINTED_off(TARG); /* decontaminate */
7e2040f0 2026 SvUTF8_off(TARG); /* decontaminate */
5d82c453
GA
2027 if (MAXARG > 2) {
2028 if (MAXARG > 3) {
2029 sv = POPs;
2030 repl = SvPV(sv, repl_len);
7b8d334a 2031 }
79072805 2032 len = POPi;
5d82c453 2033 }
84902520 2034 pos = POPi;
79072805 2035 sv = POPs;
849ca7ee 2036 PUTBACK;
a0d0e21e 2037 tmps = SvPV(sv, curlen);
7e2040f0 2038 if (DO_UTF8(sv)) {
a0ed51b3
LW
2039 utfcurlen = sv_len_utf8(sv);
2040 if (utfcurlen == curlen)
2041 utfcurlen = 0;
2042 else
2043 curlen = utfcurlen;
2044 }
d1c2b58a
LW
2045 else
2046 utfcurlen = 0;
a0ed51b3 2047
84902520
TB
2048 if (pos >= arybase) {
2049 pos -= arybase;
2050 rem = curlen-pos;
2051 fail = rem;
5d82c453
GA
2052 if (MAXARG > 2) {
2053 if (len < 0) {
2054 rem += len;
2055 if (rem < 0)
2056 rem = 0;
2057 }
2058 else if (rem > len)
2059 rem = len;
2060 }
68dc0745 2061 }
84902520 2062 else {
5d82c453
GA
2063 pos += curlen;
2064 if (MAXARG < 3)
2065 rem = curlen;
2066 else if (len >= 0) {
2067 rem = pos+len;
2068 if (rem > (I32)curlen)
2069 rem = curlen;
2070 }
2071 else {
2072 rem = curlen+len;
2073 if (rem < pos)
2074 rem = pos;
2075 }
2076 if (pos < 0)
2077 pos = 0;
2078 fail = rem;
2079 rem -= pos;
84902520
TB
2080 }
2081 if (fail < 0) {
e476b1b5
GS
2082 if (lvalue || repl)
2083 Perl_croak(aTHX_ "substr outside of string");
2084 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2085 Perl_warner(aTHX_ WARN_SUBSTR, "substr outside of string");
2304df62
AD
2086 RETPUSHUNDEF;
2087 }
79072805 2088 else {
7f66633b 2089 if (utfcurlen)
a0ed51b3 2090 sv_pos_u2b(sv, &pos, &rem);
79072805 2091 tmps += pos;
79072805 2092 sv_setpvn(TARG, tmps, rem);
7f66633b
GS
2093 if (utfcurlen)
2094 SvUTF8_on(TARG);
c8faf1c5
GS
2095 if (repl)
2096 sv_insert(sv, pos, rem, repl, repl_len);
2097 else if (lvalue) { /* it's an lvalue! */
dedeecda
PP
2098 if (!SvGMAGICAL(sv)) {
2099 if (SvROK(sv)) {
2d8e6c8d
GS
2100 STRLEN n_a;
2101 SvPV_force(sv,n_a);
599cee73 2102 if (ckWARN(WARN_SUBSTR))
cea2e8a9 2103 Perl_warner(aTHX_ WARN_SUBSTR,
599cee73 2104 "Attempt to use reference as lvalue in substr");
dedeecda
PP
2105 }
2106 if (SvOK(sv)) /* is it defined ? */
7f66633b 2107 (void)SvPOK_only_UTF8(sv);
dedeecda
PP
2108 else
2109 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
2110 }
5f05dabc 2111
a0d0e21e
LW
2112 if (SvTYPE(TARG) < SVt_PVLV) {
2113 sv_upgrade(TARG, SVt_PVLV);
2114 sv_magic(TARG, Nullsv, 'x', Nullch, 0);
ed6116ce 2115 }
a0d0e21e 2116
5f05dabc 2117 LvTYPE(TARG) = 'x';
6ff81951
GS
2118 if (LvTARG(TARG) != sv) {
2119 if (LvTARG(TARG))
2120 SvREFCNT_dec(LvTARG(TARG));
2121 LvTARG(TARG) = SvREFCNT_inc(sv);
2122 }
a0d0e21e 2123 LvTARGOFF(TARG) = pos;
8ec5e241 2124 LvTARGLEN(TARG) = rem;
79072805
LW
2125 }
2126 }
849ca7ee 2127 SPAGAIN;
79072805
LW
2128 PUSHs(TARG); /* avoid SvSETMAGIC here */
2129 RETURN;
2130}
2131
2132PP(pp_vec)
2133{
4e35701f 2134 djSP; dTARGET;
467f0320
JH
2135 register IV size = POPi;
2136 register IV offset = POPi;
79072805 2137 register SV *src = POPs;
533c011a 2138 I32 lvalue = PL_op->op_flags & OPf_MOD;
a0d0e21e 2139
81e118e0
JH
2140 SvTAINTED_off(TARG); /* decontaminate */
2141 if (lvalue) { /* it's an lvalue! */
2142 if (SvTYPE(TARG) < SVt_PVLV) {
2143 sv_upgrade(TARG, SVt_PVLV);
2144 sv_magic(TARG, Nullsv, 'v', Nullch, 0);
79072805 2145 }
81e118e0
JH
2146 LvTYPE(TARG) = 'v';
2147 if (LvTARG(TARG) != src) {
2148 if (LvTARG(TARG))
2149 SvREFCNT_dec(LvTARG(TARG));
2150 LvTARG(TARG) = SvREFCNT_inc(src);
79072805 2151 }
81e118e0
JH
2152 LvTARGOFF(TARG) = offset;
2153 LvTARGLEN(TARG) = size;
79072805
LW
2154 }
2155
81e118e0 2156 sv_setuv(TARG, do_vecget(src, offset, size));
79072805
LW
2157 PUSHs(TARG);
2158 RETURN;
2159}
2160
2161PP(pp_index)
2162{
4e35701f 2163 djSP; dTARGET;
79072805
LW
2164 SV *big;
2165 SV *little;
2166 I32 offset;
2167 I32 retval;
2168 char *tmps;
2169 char *tmps2;
463ee0b2 2170 STRLEN biglen;
3280af22 2171 I32 arybase = PL_curcop->cop_arybase;
79072805
LW
2172
2173 if (MAXARG < 3)
2174 offset = 0;
2175 else
2176 offset = POPi - arybase;
2177 little = POPs;
2178 big = POPs;
463ee0b2 2179 tmps = SvPV(big, biglen);
7e2040f0 2180 if (offset > 0 && DO_UTF8(big))
a0ed51b3 2181 sv_pos_u2b(big, &offset, 0);
79072805
LW
2182 if (offset < 0)
2183 offset = 0;
93a17b20
LW
2184 else if (offset > biglen)
2185 offset = biglen;
79072805 2186 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
411d5715 2187 (unsigned char*)tmps + biglen, little, 0)))
a0ed51b3 2188 retval = -1;
79072805 2189 else
a0ed51b3 2190 retval = tmps2 - tmps;
7e2040f0 2191 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW
2192 sv_pos_b2u(big, &retval);
2193 PUSHi(retval + arybase);
79072805
LW
2194 RETURN;
2195}
2196
2197PP(pp_rindex)
2198{
4e35701f 2199 djSP; dTARGET;
79072805
LW
2200 SV *big;
2201 SV *little;
463ee0b2
LW
2202 STRLEN blen;
2203 STRLEN llen;
79072805
LW
2204 I32 offset;
2205 I32 retval;
2206 char *tmps;
2207 char *tmps2;
3280af22 2208 I32 arybase = PL_curcop->cop_arybase;
79072805 2209
a0d0e21e 2210 if (MAXARG >= 3)
a0ed51b3 2211 offset = POPi;
79072805
LW
2212 little = POPs;
2213 big = POPs;
463ee0b2
LW
2214 tmps2 = SvPV(little, llen);
2215 tmps = SvPV(big, blen);
79072805 2216 if (MAXARG < 3)
463ee0b2 2217 offset = blen;
a0ed51b3 2218 else {
7e2040f0 2219 if (offset > 0 && DO_UTF8(big))
a0ed51b3
LW
2220 sv_pos_u2b(big, &offset, 0);
2221 offset = offset - arybase + llen;
2222 }
79072805
LW
2223 if (offset < 0)
2224 offset = 0;
463ee0b2
LW
2225 else if (offset > blen)
2226 offset = blen;
79072805 2227 if (!(tmps2 = rninstr(tmps, tmps + offset,
463ee0b2 2228 tmps2, tmps2 + llen)))
a0ed51b3 2229 retval = -1;
79072805 2230 else
a0ed51b3 2231 retval = tmps2 - tmps;
7e2040f0 2232 if (retval > 0 && DO_UTF8(big))
a0ed51b3
LW
2233 sv_pos_b2u(big, &retval);
2234 PUSHi(retval + arybase);
79072805
LW
2235 RETURN;
2236}
2237
2238PP(pp_sprintf)
2239{
4e35701f 2240 djSP; dMARK; dORIGMARK; dTARGET;
79072805 2241 do_sprintf(TARG, SP-MARK, MARK+1);
bbce6d69 2242 TAINT_IF(SvTAINTED(TARG));
79072805
LW
2243 SP = ORIGMARK;
2244 PUSHTARG;
2245 RETURN;
2246}
2247
79072805
LW
2248PP(pp_ord)
2249{
4e35701f 2250 djSP; dTARGET;
bdeef251 2251 UV value;
7e2040f0 2252 SV *tmpsv = POPs;
ba210ebe
JH
2253 STRLEN len;
2254 U8 *tmps = (U8*)SvPVx(tmpsv, len);
2255 STRLEN retlen;
79072805 2256
7e2040f0 2257 if ((*tmps & 0x80) && DO_UTF8(tmpsv))
dcad2880 2258 value = utf8_to_uv(tmps, len, &retlen, 0);
a0ed51b3 2259 else
bdeef251
GA
2260 value = (UV)(*tmps & 255);
2261 XPUSHu(value);
79072805
LW
2262 RETURN;
2263}
2264
463ee0b2
LW
2265PP(pp_chr)
2266{
4e35701f 2267 djSP; dTARGET;
463ee0b2 2268 char *tmps;
467f0320 2269 UV value = POPu;
463ee0b2 2270
748a9306 2271 (void)SvUPGRADE(TARG,SVt_PV);
a0ed51b3 2272
aaa68c4a 2273 if ((value > 255 && !IN_BYTE) || (value & 0x80 && PL_hints & HINT_UTF8) ) {
aa6ffa16 2274 SvGROW(TARG, UTF8_MAXLEN+1);
a0ed51b3 2275 tmps = SvPVX(TARG);
dfe13c55 2276 tmps = (char*)uv_to_utf8((U8*)tmps, (UV)value);
a0ed51b3
LW
2277 SvCUR_set(TARG, tmps - SvPVX(TARG));
2278 *tmps = '\0';
2279 (void)SvPOK_only(TARG);
aa6ffa16 2280 SvUTF8_on(TARG);
a0ed51b3
LW
2281 XPUSHs(TARG);
2282 RETURN;
2283 }
2284
748a9306 2285 SvGROW(TARG,2);
463ee0b2
LW
2286 SvCUR_set(TARG, 1);
2287 tmps = SvPVX(TARG);
a0ed51b3 2288 *tmps++ = value;
748a9306 2289 *tmps = '\0';
a0d0e21e 2290 (void)SvPOK_only(TARG);
463ee0b2
LW
2291 XPUSHs(TARG);
2292 RETURN;
2293}
2294
79072805
LW
2295PP(pp_crypt)
2296{
4e35701f 2297 djSP; dTARGET; dPOPTOPssrl;
2d8e6c8d 2298 STRLEN n_a;
79072805 2299#ifdef HAS_CRYPT
2d8e6c8d 2300 char *tmps = SvPV(left, n_a);
79072805 2301#ifdef FCRYPT
2d8e6c8d 2302 sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
79072805 2303#else
2d8e6c8d 2304 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
79072805
LW
2305#endif
2306#else
b13b2135 2307 DIE(aTHX_
79072805
LW
2308 "The crypt() function is unimplemented due to excessive paranoia.");
2309#endif
2310 SETs(TARG);
2311 RETURN;
2312}
2313
2314PP(pp_ucfirst)
2315{
4e35701f 2316 djSP;
79072805 2317 SV *sv = TOPs;
a0ed51b3
LW
2318 register U8 *s;
2319 STRLEN slen;
2320
7e2040f0 2321 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
ba210ebe 2322 STRLEN ulen;
ad391ad9 2323 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 2324 U8 *tend;
dcad2880 2325 UV uv = utf8_to_uv(s, slen, &ulen, 0);
a0ed51b3
LW
2326
2327 if (PL_op->op_private & OPpLOCALE) {
2328 TAINT;
2329 SvTAINTED_on(sv);
2330 uv = toTITLE_LC_uni(uv);
2331 }
2332 else
2333 uv = toTITLE_utf8(s);
2334
2335 tend = uv_to_utf8(tmpbuf, uv);
2336
014822e4 2337 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2338 dTARGET;
dfe13c55
GS
2339 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2340 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 2341 SvUTF8_on(TARG);
a0ed51b3
LW
2342 SETs(TARG);
2343 }
2344 else {
dfe13c55 2345 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
2346 Copy(tmpbuf, s, ulen, U8);
2347 }
a0ed51b3 2348 }
626727d5 2349 else {
014822e4 2350 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2351 dTARGET;
7e2040f0 2352 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
2353 sv_setsv(TARG, sv);
2354 sv = TARG;
2355 SETs(sv);
2356 }
2357 s = (U8*)SvPV_force(sv, slen);
2358 if (*s) {
2359 if (PL_op->op_private & OPpLOCALE) {
2360 TAINT;
2361 SvTAINTED_on(sv);
2362 *s = toUPPER_LC(*s);
2363 }
2364 else
2365 *s = toUPPER(*s);
bbce6d69 2366 }
bbce6d69 2367 }
31351b04
JS
2368 if (SvSMAGICAL(sv))
2369 mg_set(sv);
79072805
LW
2370 RETURN;
2371}
2372
2373PP(pp_lcfirst)
2374{
4e35701f 2375 djSP;
79072805 2376 SV *sv = TOPs;
a0ed51b3
LW
2377 register U8 *s;
2378 STRLEN slen;
2379
7e2040f0 2380 if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && (*s & 0xc0) == 0xc0) {
ba210ebe 2381 STRLEN ulen;
ad391ad9 2382 U8 tmpbuf[UTF8_MAXLEN+1];
a0ed51b3 2383 U8 *tend;
dcad2880 2384 UV uv = utf8_to_uv(s, slen, &ulen, 0);
a0ed51b3
LW
2385
2386 if (PL_op->op_private & OPpLOCALE) {
2387 TAINT;
2388 SvTAINTED_on(sv);
2389 uv = toLOWER_LC_uni(uv);
2390 }
2391 else
2392 uv = toLOWER_utf8(s);
2393
2394 tend = uv_to_utf8(tmpbuf, uv);
2395
014822e4 2396 if (!SvPADTMP(sv) || tend - tmpbuf != ulen || SvREADONLY(sv)) {
a0ed51b3 2397 dTARGET;
dfe13c55
GS
2398 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
2399 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
7e2040f0 2400 SvUTF8_on(TARG);
a0ed51b3
LW
2401 SETs(TARG);
2402 }
2403 else {
dfe13c55 2404 s = (U8*)SvPV_force(sv, slen);
a0ed51b3
LW
2405 Copy(tmpbuf, s, ulen, U8);
2406 }
a0ed51b3 2407 }
626727d5 2408 else {
014822e4 2409 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2410 dTARGET;
7e2040f0 2411 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
2412 sv_setsv(TARG, sv);
2413 sv = TARG;
2414 SETs(sv);
2415 }
2416 s = (U8*)SvPV_force(sv, slen);
2417 if (*s) {
2418 if (PL_op->op_private & OPpLOCALE) {
2419 TAINT;
2420 SvTAINTED_on(sv);
2421 *s = toLOWER_LC(*s);
2422 }
2423 else
2424 *s = toLOWER(*s);
bbce6d69 2425 }
bbce6d69 2426 }
31351b04
JS
2427 if (SvSMAGICAL(sv))
2428 mg_set(sv);
79072805
LW
2429 RETURN;
2430}
2431
2432PP(pp_uc)
2433{
4e35701f 2434 djSP;
79072805 2435 SV *sv = TOPs;
a0ed51b3 2436 register U8 *s;
463ee0b2 2437 STRLEN len;
79072805 2438
7e2040f0 2439 if (DO_UTF8(sv)) {
a0ed51b3 2440 dTARGET;
ba210ebe 2441 STRLEN ulen;
a0ed51b3
LW
2442 register U8 *d;
2443 U8 *send;
2444
dfe13c55 2445 s = (U8*)SvPV(sv,len);
a5a20234 2446 if (!len) {
7e2040f0 2447 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
2448 sv_setpvn(TARG, "", 0);
2449 SETs(TARG);
a0ed51b3
LW
2450 }
2451 else {
31351b04
JS
2452 (void)SvUPGRADE(TARG, SVt_PV);
2453 SvGROW(TARG, (len * 2) + 1);
2454 (void)SvPOK_only(TARG);
2455 d = (U8*)SvPVX(TARG);
2456 send = s + len;
2457 if (PL_op->op_private & OPpLOCALE) {
2458 TAINT;
2459 SvTAINTED_on(TARG);
2460 while (s < send) {
dcad2880 2461 d = uv_to_utf8(d, toUPPER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
31351b04
JS
2462 s += ulen;
2463 }
a0ed51b3 2464 }
31351b04
JS
2465 else {
2466 while (s < send) {
2467 d = uv_to_utf8(d, toUPPER_utf8( s ));
2468 s += UTF8SKIP(s);
2469 }
a0ed51b3 2470 }
31351b04 2471 *d = '\0';
7e2040f0 2472 SvUTF8_on(TARG);
31351b04
JS
2473 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2474 SETs(TARG);
a0ed51b3 2475 }
a0ed51b3 2476 }
626727d5 2477 else {
014822e4 2478 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2479 dTARGET;
7e2040f0 2480 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
2481 sv_setsv(TARG, sv);
2482 sv = TARG;
2483 SETs(sv);
2484 }
2485 s = (U8*)SvPV_force(sv, len);
2486 if (len) {
2487 register U8 *send = s + len;
2488
2489 if (PL_op->op_private & OPpLOCALE) {
2490 TAINT;
2491 SvTAINTED_on(sv);
2492 for (; s < send; s++)
2493 *s = toUPPER_LC(*s);
2494 }
2495 else {
2496 for (; s < send; s++)
2497 *s = toUPPER(*s);
2498 }
bbce6d69 2499 }
79072805 2500 }
31351b04
JS
2501 if (SvSMAGICAL(sv))
2502 mg_set(sv);
79072805
LW
2503 RETURN;
2504}
2505
2506PP(pp_lc)
2507{
4e35701f 2508 djSP;
79072805 2509 SV *sv = TOPs;
a0ed51b3 2510 register U8 *s;
463ee0b2 2511 STRLEN len;
79072805 2512
7e2040f0 2513 if (DO_UTF8(sv)) {
a0ed51b3 2514 dTARGET;
ba210ebe 2515 STRLEN ulen;
a0ed51b3
LW
2516 register U8 *d;
2517 U8 *send;
2518
dfe13c55 2519 s = (U8*)SvPV(sv,len);
a5a20234 2520 if (!len) {
7e2040f0 2521 SvUTF8_off(TARG); /* decontaminate */
a5a20234
LW
2522 sv_setpvn(TARG, "", 0);
2523 SETs(TARG);
a0ed51b3
LW
2524 }
2525 else {
31351b04
JS
2526 (void)SvUPGRADE(TARG, SVt_PV);
2527 SvGROW(TARG, (len * 2) + 1);
2528 (void)SvPOK_only(TARG);
2529 d = (U8*)SvPVX(TARG);
2530 send = s + len;
2531 if (PL_op->op_private & OPpLOCALE) {
2532 TAINT;
2533 SvTAINTED_on(TARG);
2534 while (s < send) {
dcad2880 2535 d = uv_to_utf8(d, toLOWER_LC_uni( utf8_to_uv(s, len, &ulen, 0)));
31351b04
JS
2536 s += ulen;
2537 }
a0ed51b3 2538 }
31351b04
JS
2539 else {
2540 while (s < send) {
2541 d = uv_to_utf8(d, toLOWER_utf8(s));
2542 s += UTF8SKIP(s);
2543 }
a0ed51b3 2544 }
31351b04 2545 *d = '\0';
7e2040f0 2546 SvUTF8_on(TARG);
31351b04
JS
2547 SvCUR_set(TARG, d - (U8*)SvPVX(TARG));
2548 SETs(TARG);
a0ed51b3 2549 }
79072805 2550 }
626727d5 2551 else {
014822e4 2552 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
31351b04 2553 dTARGET;
7e2040f0 2554 SvUTF8_off(TARG); /* decontaminate */
31351b04
JS
2555 sv_setsv(TARG, sv);
2556 sv = TARG;
2557 SETs(sv);
a0ed51b3 2558 }
bbce6d69 2559
31351b04
JS
2560 s = (U8*)SvPV_force(sv, len);
2561 if (len) {
2562 register U8 *send = s + len;
bbce6d69 2563
31351b04
JS
2564 if (PL_op->op_private & OPpLOCALE) {
2565 TAINT;
2566 SvTAINTED_on(sv);
2567 for (; s < send; s++)
2568 *s = toLOWER_LC(*s);
2569 }
2570 else {
2571 for (; s < send; s++)
2572 *s = toLOWER(*s);
2573 }
bbce6d69 2574 }
79072805 2575 }
31351b04
JS
2576 if (SvSMAGICAL(sv))
2577 mg_set(sv);
79072805
LW
2578 RETURN;
2579}
2580
a0d0e21e 2581PP(pp_quotemeta)
79072805 2582{
4e35701f 2583 djSP; dTARGET;
a0d0e21e
LW
2584 SV *sv = TOPs;
2585 STRLEN len;
2586 register char *s = SvPV(sv,len);
2587 register char *d;
79072805 2588
7e2040f0 2589 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e
LW
2590 if (len) {
2591 (void)SvUPGRADE(TARG, SVt_PV);
c07a80fd 2592 SvGROW(TARG, (len * 2) + 1);
a0d0e21e 2593 d = SvPVX(TARG);
7e2040f0 2594 if (DO_UTF8(sv)) {
0dd2cdef
LW
2595 while (len) {
2596 if (*s & 0x80) {
2597 STRLEN ulen = UTF8SKIP(s);
2598 if (ulen > len)
2599 ulen = len;
2600 len -= ulen;
2601 while (ulen--)
2602 *d++ = *s++;
2603 }
2604 else {
2605 if (!isALNUM(*s))
2606 *d++ = '\\';
2607 *d++ = *s++;
2608 len--;
2609 }
2610 }
7e2040f0 2611 SvUTF8_on(TARG);
0dd2cdef
LW
2612 }
2613 else {
2614 while (len--) {
2615 if (!isALNUM(*s))
2616 *d++ = '\\';
2617 *d++ = *s++;
2618 }
79072805 2619 }
a0d0e21e
LW
2620 *d = '\0';
2621 SvCUR_set(TARG, d - SvPVX(TARG));
3aa33fe5 2622 (void)SvPOK_only_UTF8(TARG);
79072805 2623 }
a0d0e21e
LW
2624 else
2625 sv_setpvn(TARG, s, len);
2626 SETs(TARG);
31351b04
JS
2627 if (SvSMAGICAL(TARG))
2628 mg_set(TARG);
79072805
LW
2629 RETURN;
2630}
2631
a0d0e21e 2632/* Arrays. */
79072805 2633
a0d0e21e 2634PP(pp_aslice)
79072805 2635{
4e35701f 2636 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2637 register SV** svp;
2638 register AV* av = (AV*)POPs;
533c011a 2639 register I32 lval = PL_op->op_flags & OPf_MOD;
3280af22 2640 I32 arybase = PL_curcop->cop_arybase;
748a9306 2641 I32 elem;
79072805 2642
a0d0e21e 2643 if (SvTYPE(av) == SVt_PVAV) {
533c011a 2644 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
748a9306 2645 I32 max = -1;
924508f0 2646 for (svp = MARK + 1; svp <= SP; svp++) {
748a9306
LW
2647 elem = SvIVx(*svp);
2648 if (elem > max)
2649 max = elem;
2650 }
2651 if (max > AvMAX(av))
2652 av_extend(av, max);
2653 }
a0d0e21e 2654 while (++MARK <= SP) {
748a9306 2655 elem = SvIVx(*MARK);
a0d0e21e 2656
748a9306
LW
2657 if (elem > 0)
2658 elem -= arybase;
a0d0e21e
LW
2659 svp = av_fetch(av, elem, lval);
2660 if (lval) {
3280af22 2661 if (!svp || *svp == &PL_sv_undef)
cea2e8a9 2662 DIE(aTHX_ PL_no_aelem, elem);
533c011a 2663 if (PL_op->op_private & OPpLVAL_INTRO)
161b7d16 2664 save_aelem(av, elem, svp);
79072805 2665 }
3280af22 2666 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
2667 }
2668 }
748a9306 2669 if (GIMME != G_ARRAY) {
a0d0e21e
LW
2670 MARK = ORIGMARK;
2671 *++MARK = *SP;
2672 SP = MARK;
2673 }
79072805
LW
2674 RETURN;
2675}
2676
2677/* Associative arrays. */
2678
2679PP(pp_each)
2680{
59af0135 2681 djSP;
79072805 2682 HV *hash = (HV*)POPs;
c07a80fd 2683 HE *entry;
54310121 2684 I32 gimme = GIMME_V;
c750a3ec 2685 I32 realhv = (SvTYPE(hash) == SVt_PVHV);
8ec5e241 2686
c07a80fd 2687 PUTBACK;
c750a3ec
MB
2688 /* might clobber stack_sp */
2689 entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
c07a80fd 2690 SPAGAIN;
79072805 2691
79072805
LW
2692 EXTEND(SP, 2);
2693 if (entry) {
54310121
PP
2694 PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
2695 if (gimme == G_ARRAY) {
59af0135 2696 SV *val;
c07a80fd 2697 PUTBACK;
c750a3ec 2698 /* might clobber stack_sp */
59af0135
GS
2699 val = realhv ?
2700 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 2701 SPAGAIN;
59af0135 2702 PUSHs(val);
79072805 2703 }
79072805 2704 }
54310121 2705 else if (gimme == G_SCALAR)
79072805
LW
2706 RETPUSHUNDEF;
2707
2708 RETURN;
2709}
2710
2711PP(pp_values)
2712{
cea2e8a9 2713 return do_kv();
79072805
LW
2714}
2715
2716PP(pp_keys)
2717{
cea2e8a9 2718 return do_kv();
79072805
LW
2719}
2720
2721PP(pp_delete)
2722{
4e35701f 2723 djSP;
54310121
PP
2724 I32 gimme = GIMME_V;
2725 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2726 SV *sv;
5f05dabc
PP
2727 HV *hv;
2728
533c011a 2729 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2730 dMARK; dORIGMARK;
97fcbf96 2731 U32 hvtype;
5f05dabc 2732 hv = (HV*)POPs;
97fcbf96 2733 hvtype = SvTYPE(hv);
01020589
GS
2734 if (hvtype == SVt_PVHV) { /* hash element */
2735 while (++MARK <= SP) {
ae77835f 2736 sv = hv_delete_ent(hv, *MARK, discard, 0);
01020589
GS
2737 *MARK = sv ? sv : &PL_sv_undef;
2738 }
5f05dabc 2739 }
01020589
GS
2740 else if (hvtype == SVt_PVAV) {
2741 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2742 while (++MARK <= SP) {
2743 sv = av_delete((AV*)hv, SvIV(*MARK), discard);
2744 *MARK = sv ? sv : &PL_sv_undef;
2745 }
2746 }
2747 else { /* pseudo-hash element */
2748 while (++MARK <= SP) {
2749 sv = avhv_delete_ent((AV*)hv, *MARK, discard, 0);
2750 *MARK = sv ? sv : &PL_sv_undef;
2751 }
2752 }
2753 }
2754 else
2755 DIE(aTHX_ "Not a HASH reference");
54310121
PP
2756 if (discard)
2757 SP = ORIGMARK;
2758 else if (gimme == G_SCALAR) {
5f05dabc
PP
2759 MARK = ORIGMARK;
2760 *++MARK = *SP;
2761 SP = MARK;
2762 }
2763 }
2764 else {
2765 SV *keysv = POPs;
2766 hv = (HV*)POPs;
97fcbf96
MB
2767 if (SvTYPE(hv) == SVt_PVHV)
2768 sv = hv_delete_ent(hv, keysv, discard, 0);
01020589
GS
2769 else if (SvTYPE(hv) == SVt_PVAV) {
2770 if (PL_op->op_flags & OPf_SPECIAL)
2771 sv = av_delete((AV*)hv, SvIV(keysv), discard);
2772 else
2773 sv = avhv_delete_ent((AV*)hv, keysv, discard, 0);
2774 }
97fcbf96 2775 else
cea2e8a9 2776 DIE(aTHX_ "Not a HASH reference");
5f05dabc 2777 if (!sv)
3280af22 2778 sv = &PL_sv_undef;
54310121
PP
2779 if (!discard)
2780 PUSHs(sv);
79072805 2781 }
79072805
LW
2782 RETURN;
2783}
2784
a0d0e21e 2785PP(pp_exists)
79072805 2786{
4e35701f 2787 djSP;
afebc493
GS
2788 SV *tmpsv;
2789 HV *hv;
2790
2791 if (PL_op->op_private & OPpEXISTS_SUB) {
2792 GV *gv;
2793 CV *cv;
2794 SV *sv = POPs;
2795 cv = sv_2cv(sv, &hv, &gv, FALSE);
2796 if (cv)
2797 RETPUSHYES;
2798 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
2799 RETPUSHYES;
2800 RETPUSHNO;
2801 }
2802 tmpsv = POPs;
2803 hv = (HV*)POPs;
c750a3ec 2804 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2805 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 2806 RETPUSHYES;
ef54e1a4
JH
2807 }
2808 else if (SvTYPE(hv) == SVt_PVAV) {
01020589
GS
2809 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
2810 if (av_exists((AV*)hv, SvIV(tmpsv)))
2811 RETPUSHYES;
2812 }
2813 else if (avhv_exists_ent((AV*)hv, tmpsv, 0)) /* pseudo-hash element */
c750a3ec 2814 RETPUSHYES;
ef54e1a4
JH
2815 }
2816 else {
cea2e8a9 2817 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 2818 }
a0d0e21e
LW
2819 RETPUSHNO;
2820}
79072805 2821
a0d0e21e
LW
2822PP(pp_hslice)
2823{
4e35701f 2824 djSP; dMARK; dORIGMARK;
a0d0e21e 2825 register HV *hv = (HV*)POPs;
533c011a 2826 register I32 lval = PL_op->op_flags & OPf_MOD;
c750a3ec 2827 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2828
0ebe0038 2829 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 2830 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 2831
c750a3ec 2832 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2833 while (++MARK <= SP) {
f12c7020 2834 SV *keysv = *MARK;
ae77835f 2835 SV **svp;
1f5346dc 2836 I32 preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
ae77835f 2837 if (realhv) {
800e9ae0 2838 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 2839 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH
2840 }
2841 else {
97fcbf96 2842 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2843 }
a0d0e21e 2844 if (lval) {
2d8e6c8d
GS
2845 if (!svp || *svp == &PL_sv_undef) {
2846 STRLEN n_a;
cea2e8a9 2847 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 2848 }
1f5346dc
SC
2849 if (PL_op->op_private & OPpLVAL_INTRO) {
2850 if (preeminent)
2851 save_helem(hv, keysv, svp);
2852 else {
2853 STRLEN keylen;
2854 char *key = SvPV(keysv, keylen);
2855 save_delete(hv, key, keylen);
2856 }
2857 }
93a17b20 2858 }
3280af22 2859 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW
2860 }
2861 }
a0d0e21e
LW
2862 if (GIMME != G_ARRAY) {
2863 MARK = ORIGMARK;
2864 *++MARK = *SP;
2865 SP = MARK;
79072805 2866 }
a0d0e21e
LW
2867 RETURN;
2868}
2869
2870/* List operators. */
2871
2872PP(pp_list)
2873{
4e35701f 2874 djSP; dMARK;
a0d0e21e
LW
2875 if (GIMME != G_ARRAY) {
2876 if (++MARK <= SP)
2877 *MARK = *SP; /* unwanted list, return last item */
8990e307 2878 else
3280af22 2879 *MARK = &PL_sv_undef;
a0d0e21e 2880 SP = MARK;
79072805 2881 }
a0d0e21e 2882 RETURN;
79072805
LW
2883}
2884
a0d0e21e 2885PP(pp_lslice)
79072805 2886{
4e35701f 2887 djSP;
3280af22
NIS
2888 SV **lastrelem = PL_stack_sp;
2889 SV **lastlelem = PL_stack_base + POPMARK;
2890 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2891 register SV **firstrelem = lastlelem + 1;
3280af22 2892 I32 arybase = PL_curcop->cop_arybase;
533c011a 2893 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2894 I32 is_something_there = lval;
79072805 2895
a0d0e21e
LW
2896 register I32 max = lastrelem - lastlelem;
2897 register SV **lelem;
2898 register I32 ix;
2899
2900 if (GIMME != G_ARRAY) {
748a9306
LW
2901 ix = SvIVx(*lastlelem);
2902 if (ix < 0)
2903 ix += max;
2904 else
2905 ix -= arybase;
a0d0e21e 2906 if (ix < 0 || ix >= max)
3280af22 2907 *firstlelem = &PL_sv_undef;
a0d0e21e
LW
2908 else
2909 *firstlelem = firstrelem[ix];
2910 SP = firstlelem;
2911 RETURN;
2912 }
2913
2914 if (max == 0) {
2915 SP = firstlelem - 1;
2916 RETURN;
2917 }
2918
2919 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2920 ix = SvIVx(*lelem);
c73bf8e3 2921 if (ix < 0)
a0d0e21e 2922 ix += max;
b13b2135 2923 else
748a9306 2924 ix -= arybase;
c73bf8e3
HS
2925 if (ix < 0 || ix >= max)
2926 *lelem = &PL_sv_undef;
2927 else {
2928 is_something_there = TRUE;
2929 if (!(*lelem = firstrelem[ix]))
3280af22 2930 *lelem = &PL_sv_undef;
748a9306 2931 }
79072805 2932 }
4633a7c4
LW
2933 if (is_something_there)
2934 SP = lastlelem;
2935 else
2936 SP = firstlelem - 1;
79072805
LW
2937 RETURN;
2938}
2939
a0d0e21e
LW
2940PP(pp_anonlist)
2941{
4e35701f 2942 djSP; dMARK; dORIGMARK;
a0d0e21e 2943 I32 items = SP - MARK;
44a8e56a
PP
2944 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2945 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2946 XPUSHs(av);
a0d0e21e
LW
2947 RETURN;
2948}
2949
2950PP(pp_anonhash)
79072805 2951{
4e35701f 2952 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2953 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2954
2955 while (MARK < SP) {
2956 SV* key = *++MARK;
a0d0e21e
LW
2957 SV *val = NEWSV(46, 0);
2958 if (MARK < SP)
2959 sv_setsv(val, *++MARK);
e476b1b5
GS
2960 else if (ckWARN(WARN_MISC))
2961 Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
f12c7020 2962 (void)hv_store_ent(hv,key,val,0);
79072805 2963 }
a0d0e21e
LW
2964 SP = ORIGMARK;
2965 XPUSHs((SV*)hv);
79072805
LW
2966 RETURN;
2967}
2968
a0d0e21e 2969PP(pp_splice)
79072805 2970{
4e35701f 2971 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
2972 register AV *ary = (AV*)*++MARK;
2973 register SV **src;
2974 register SV **dst;
2975 register I32 i;
2976 register I32 offset;
2977 register I32 length;
2978 I32 newlen;
2979 I32 after;
2980 I32 diff;
2981 SV **tmparyval = 0;
93965878
NIS
2982 MAGIC *mg;
2983
155aba94 2984 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 2985 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2986 PUSHMARK(MARK);
8ec5e241 2987 PUTBACK;
a60c0954 2988 ENTER;
864dbfa3 2989 call_method("SPLICE",GIMME_V);
a60c0954 2990 LEAVE;
93965878
NIS
2991 SPAGAIN;
2992 RETURN;
2993 }
79072805 2994
a0d0e21e 2995 SP++;
79072805 2996
a0d0e21e 2997 if (++MARK < SP) {
84902520 2998 offset = i = SvIVx(*MARK);
a0d0e21e 2999 if (offset < 0)
93965878 3000 offset += AvFILLp(ary) + 1;
a0d0e21e 3001 else
3280af22 3002 offset -= PL_curcop->cop_arybase;
84902520 3003 if (offset < 0)
cea2e8a9 3004 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW
3005 if (++MARK < SP) {
3006 length = SvIVx(*MARK++);
48cdf507
GA
3007 if (length < 0) {
3008 length += AvFILLp(ary) - offset + 1;
3009 if (length < 0)
3010 length = 0;
3011 }
79072805
LW
3012 }
3013 else
a0d0e21e 3014 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 3015 }
a0d0e21e
LW
3016 else {
3017 offset = 0;
3018 length = AvMAX(ary) + 1;
3019 }
93965878
NIS
3020 if (offset > AvFILLp(ary) + 1)
3021 offset = AvFILLp(ary) + 1;
3022 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW
3023 if (after < 0) { /* not that much array */
3024 length += after; /* offset+length now in array */
3025 after = 0;
3026 if (!AvALLOC(ary))
3027 av_extend(ary, 0);
3028 }
3029
3030 /* At this point, MARK .. SP-1 is our new LIST */
3031
3032 newlen = SP - MARK;
3033 diff = newlen - length;
13d7cbc1
GS
3034 if (newlen && !AvREAL(ary) && AvREIFY(ary))
3035 av_reify(ary);
a0d0e21e
LW
3036
3037 if (diff < 0) { /* shrinking the area */
3038 if (newlen) {
3039 New(451, tmparyval, newlen, SV*); /* so remember insertion */
3040 Copy(MARK, tmparyval, newlen, SV*);
79072805 3041 }
a0d0e21e
LW
3042
3043 MARK = ORIGMARK + 1;
3044 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3045 MEXTEND(MARK, length);
3046 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
3047 if (AvREAL(ary)) {
bbce6d69 3048 EXTEND_MORTAL(length);
36477c24 3049 for (i = length, dst = MARK; i; i--) {
d689ffdd 3050 sv_2mortal(*dst); /* free them eventualy */
36477c24
PP
3051 dst++;
3052 }
a0d0e21e
LW
3053 }
3054 MARK += length - 1;
79072805 3055 }
a0d0e21e
LW
3056 else {
3057 *MARK = AvARRAY(ary)[offset+length-1];
3058 if (AvREAL(ary)) {
d689ffdd 3059 sv_2mortal(*MARK);
a0d0e21e
LW
3060 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
3061 SvREFCNT_dec(*dst++); /* free them now */
79072805 3062 }
a0d0e21e 3063 }
93965878 3064 AvFILLp(ary) += diff;
a0d0e21e
LW
3065
3066 /* pull up or down? */
3067
3068 if (offset < after) { /* easier to pull up */
3069 if (offset) { /* esp. if nothing to pull */
3070 src = &AvARRAY(ary)[offset-1];
3071 dst = src - diff; /* diff is negative */
3072 for (i = offset; i > 0; i--) /* can't trust Copy */
3073 *dst-- = *src--;
79072805 3074 }
a0d0e21e
LW
3075 dst = AvARRAY(ary);
3076 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
3077 AvMAX(ary) += diff;
3078 }
3079 else {
3080 if (after) { /* anything to pull down? */
3081 src = AvARRAY(ary) + offset + length;
3082 dst = src + diff; /* diff is negative */
3083 Move(src, dst, after, SV*);
79072805 3084 }
93965878 3085 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW
3086 /* avoid later double free */
3087 }
3088 i = -diff;
3089 while (i)
3280af22 3090 dst[--i] = &PL_sv_undef;
a0d0e21e
LW
3091
3092 if (newlen) {
3093 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3094 newlen; newlen--) {
3095 *dst = NEWSV(46, 0);
3096 sv_setsv(*dst++, *src++);
79072805 3097 }
a0d0e21e
LW
3098 Safefree(tmparyval);
3099 }
3100 }
3101 else { /* no, expanding (or same) */
3102 if (length) {
3103 New(452, tmparyval, length, SV*); /* so remember deletion */
3104 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3105 }
3106
3107 if (diff > 0) { /* expanding */
3108
3109 /* push up or down? */
3110
3111 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3112 if (offset) {
3113 src = AvARRAY(ary);
3114 dst = src - diff;
3115 Move(src, dst, offset, SV*);
79072805 3116 }
a0d0e21e
LW
3117 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3118 AvMAX(ary) += diff;
93965878 3119 AvFILLp(ary) += diff;
79072805
LW
3120 }
3121 else {
93965878
NIS
3122 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3123 av_extend(ary, AvFILLp(ary) + diff);
3124 AvFILLp(ary) += diff;
a0d0e21e
LW
3125
3126 if (after) {
93965878 3127 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW
3128 src = dst - diff;
3129 for (i = after; i; i--) {
3130 *dst-- = *src--;
3131 }
79072805
LW
3132 }
3133 }
a0d0e21e
LW
3134 }
3135
3136 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3137 *dst = NEWSV(46, 0);
3138 sv_setsv(*dst++, *src++);
3139 }
3140 MARK = ORIGMARK + 1;
3141 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3142 if (length) {
3143 Copy(tmparyval, MARK, length, SV*);
3144 if (AvREAL(ary)) {
bbce6d69 3145 EXTEND_MORTAL(length);
36477c24 3146 for (i = length, dst = MARK; i; i--) {
d689ffdd 3147 sv_2mortal(*dst); /* free them eventualy */
36477c24
PP
3148 dst++;
3149 }
79072805 3150 }
a0d0e21e 3151 Safefree(tmparyval);
79072805 3152 }
a0d0e21e
LW
3153 MARK += length - 1;
3154 }
3155 else if (length--) {
3156 *MARK = tmparyval[length];
3157 if (AvREAL(ary)) {
d689ffdd 3158 sv_2mortal(*MARK);
a0d0e21e
LW
3159 while (length-- > 0)
3160 SvREFCNT_dec(tmparyval[length]);
79072805 3161 }
a0d0e21e 3162 Safefree(tmparyval);
79072805 3163 }
a0d0e21e 3164 else
3280af22 3165 *MARK = &PL_sv_undef;
79072805 3166 }
a0d0e21e 3167 SP = MARK;
79072805
LW
3168 RETURN;
3169}
3170
a0d0e21e 3171PP(pp_push)
79072805 3172{
4e35701f 3173 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3174 register AV *ary = (AV*)*++MARK;
3280af22 3175 register SV *sv = &PL_sv_undef;
93965878 3176 MAGIC *mg;
79072805 3177
155aba94 3178 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 3179 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS
3180 PUSHMARK(MARK);
3181 PUTBACK;
a60c0954 3182 ENTER;
864dbfa3 3183 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 3184 LEAVE;
93965878 3185 SPAGAIN;
93965878 3186 }
a60c0954
NIS
3187 else {
3188 /* Why no pre-extend of ary here ? */
3189 for (++MARK; MARK <= SP; MARK++) {
3190 sv = NEWSV(51, 0);
3191 if (*MARK)
3192 sv_setsv(sv, *MARK);
3193 av_push(ary, sv);
3194 }
79072805
LW
3195 }
3196 SP = ORIGMARK;
a0d0e21e 3197 PUSHi( AvFILL(ary) + 1 );
79072805
LW
3198 RETURN;
3199}
3200
a0d0e21e 3201PP(pp_pop)
79072805 3202{
4e35701f 3203 djSP;
a0d0e21e
LW
3204 AV *av = (AV*)POPs;
3205 SV *sv = av_pop(av);
d689ffdd 3206 if (AvREAL(av))
a0d0e21e
LW
3207 (void)sv_2mortal(sv);
3208 PUSHs(sv);
79072805 3209 RETURN;
79072805
LW
3210}
3211
a0d0e21e 3212PP(pp_shift)
79072805 3213{
4e35701f 3214 djSP;
a0d0e21e
LW
3215 AV *av = (AV*)POPs;
3216 SV *sv = av_shift(av);
79072805 3217 EXTEND(SP, 1);
a0d0e21e 3218 if (!sv)
79072805 3219 RETPUSHUNDEF;
d689ffdd 3220 if (AvREAL(av))
a0d0e21e
LW
3221 (void)sv_2mortal(sv);
3222 PUSHs(sv);
79072805 3223 RETURN;
79072805
LW
3224}
3225
a0d0e21e 3226PP(pp_unshift)
79072805 3227{
4e35701f 3228 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
3229 register AV *ary = (AV*)*++MARK;
3230 register SV *sv;
3231 register I32 i = 0;
93965878
NIS
3232 MAGIC *mg;
3233
155aba94 3234 if ((mg = SvTIED_mg((SV*)ary, 'P'))) {
33c27489 3235 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 3236 PUSHMARK(MARK);
93965878 3237 PUTBACK;
a60c0954 3238 ENTER;
864dbfa3 3239 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 3240 LEAVE;
93965878 3241 SPAGAIN;
93965878 3242 }
a60c0954
NIS
3243 else {
3244 av_unshift(ary, SP - MARK);
3245 while (MARK < SP) {
3246 sv = NEWSV(27, 0);
3247 sv_setsv(sv, *++MARK);
3248 (void)av_store(ary, i++, sv);
3249 }
79072805 3250 }
a0d0e21e
LW
3251 SP = ORIGMARK;
3252 PUSHi( AvFILL(ary) + 1 );
79072805 3253 RETURN;
79072805
LW
3254}
3255
a0d0e21e 3256PP(pp_reverse)
79072805 3257{
4e35701f 3258 djSP; dMARK;
a0d0e21e
LW
3259 register SV *tmp;
3260 SV **oldsp = SP;
79072805 3261
a0d0e21e
LW
3262 if (GIMME == G_ARRAY) {
3263 MARK++;
3264 while (MARK < SP) {
3265 tmp = *MARK;
3266 *MARK++ = *SP;
3267 *SP-- = tmp;
3268 }
dd58a1ab 3269 /* safe as long as stack cannot get extended in the above */
a0d0e21e 3270 SP = oldsp;
79072805
LW
3271 }
3272 else {
a0d0e21e
LW
3273 register char *up;
3274 register char *down;
3275 register I32 tmp;
3276 dTARGET;
3277 STRLEN len;
79072805 3278
7e2040f0 3279 SvUTF8_off(TARG); /* decontaminate */
a0d0e21e 3280 if (SP - MARK > 1)
3280af22 3281 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 3282 else
54b9620d 3283 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW
3284 up = SvPV_force(TARG, len);
3285 if (len > 1) {
7e2040f0 3286 if (DO_UTF8(TARG)) { /* first reverse each character */
dfe13c55
GS
3287 U8* s = (U8*)SvPVX(TARG);
3288 U8* send = (U8*)(s + len);
a0ed51b3
LW
3289 while (s < send) {
3290 if (*s < 0x80) {
3291 s++;
3292 continue;
3293 }
3294 else {
dfe13c55 3295 up = (char*)s;
a0ed51b3 3296 s += UTF8SKIP(s);
dfe13c55 3297 down = (char*)(s - 1);
f248d071
GS
3298 if (s > send || !((*down & 0xc0) == 0x80)) {
3299 if (ckWARN_d(WARN_UTF8))
3300 Perl_warner(aTHX_ WARN_UTF8,
3301 "Malformed UTF-8 character");
a0ed51b3
LW
3302 break;
3303 }
3304 while (down > up) {
3305 tmp = *up;
3306 *up++ = *down;
3307 *down-- = tmp;
3308 }
3309 }
3310 }
3311 up = SvPVX(TARG);
3312 }
a0d0e21e
LW
3313 down = SvPVX(TARG) + len - 1;
3314 while (down > up) {
3315 tmp = *up;
3316 *up++ = *down;
3317 *down-- = tmp;
3318 }
3aa33fe5 3319 (void)SvPOK_only_UTF8(TARG);
79072805 3320 }
a0d0e21e
LW
3321 SP = MARK + 1;
3322 SETTARG;
79072805 3323 }
a0d0e21e 3324 RETURN;
79072805
LW
3325}
3326
864dbfa3 3327STATIC SV *
cea2e8a9 3328S_mul128(pTHX_ SV *sv, U8 m)
55497cff
PP
3329{
3330 STRLEN len;
3331 char *s = SvPV(sv, len);
3332 char *t;
3333 U32 i = 0;
3334
3335 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
79cb57f6 3336 SV *tmpNew = newSVpvn("0000000000", 10);
55497cff 3337
09b7f37c 3338 sv_catsv(tmpNew, sv);
55497cff 3339 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 3340 sv = tmpNew;
55497cff
PP
3341 s = SvPV(sv, len);
3342 }
3343 t = s + len - 1;
3344 while (!*t) /* trailing '\0'? */
3345 t--;
3346 while (t > s) {
3347 i = ((*t - '0') << 7) + m;
3348 *(t--) = '0' + (i % 10);
3349 m = i / 10;
3350 }
3351 return (sv);
3352}
3353
a0d0e21e
LW
3354/* Explosives and implosives. */
3355
9d116dd7
JH
3356#if 'I' == 73 && 'J' == 74
3357/* On an ASCII/ISO kind of system */
ba1ac976 3358#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH
3359#else
3360/*
3361 Some other sort of character set - use memchr() so we don't match
3362 the null byte.
3363 */
80252599 3364#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
9d116dd7
JH
3365#endif
3366
a0d0e21e 3367PP(pp_unpack)
79072805 3368{
4e35701f 3369 djSP;
a0d0e21e 3370 dPOPPOPssrl;
dd58a1ab 3371 I32 start_sp_offset = SP - PL_stack_base;
54310121 3372 I32 gimme = GIMME_V;
ed6116ce 3373 SV *sv;
a0d0e21e
LW
3374 STRLEN llen;
3375 STRLEN rlen;
3376 register char *pat = SvPV(left, llen);
3377 register char *s = SvPV(right, rlen);
3378 char *strend = s + rlen;
3379 char *strbeg = s;
3380 register char *patend = pat + llen;
3381 I32 datumtype;
3382 register I32 len;
3383 register I32 bits;
abdc5761 3384 register char *str;
79072805 3385
a0d0e21e 3386 /* These must not be in registers: */
43ea6eee 3387 short ashort;
a0d0e21e 3388 int aint;
43ea6eee 3389 long along;
6b8eaf93 3390#ifdef HAS_QUAD
ecfc5424 3391 Quad_t aquad;
a0d0e21e
LW
3392#endif
3393 U16 aushort;
3394 unsigned int auint;
3395 U32 aulong;
6b8eaf93 3396#ifdef HAS_QUAD
e862df63 3397 Uquad_t auquad;
a0d0e21e
LW
3398#endif
3399 char *aptr;
3400 float afloat;
3401 double adouble;
3402 I32 checksum = 0;
3403 register U32 culong;
65202027 3404 NV cdouble;
fb73857a 3405 int commas = 0;
4b5b2118 3406 int star;
726ea183 3407#ifdef PERL_NATINT_PACK
ef54e1a4
JH
3408 int natint; /* native integer */
3409 int unatint; /* unsigned native integer */
726ea183 3410#endif
79072805 3411
54310121 3412 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW
3413 /*SUPPRESS 530*/
3414 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
5a929a98 3415 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW
3416 patend++;
3417 while (isDIGIT(*patend) || *patend == '*')
3418 patend++;
3419 }
3420 else
3421 patend++;
79072805 3422 }
a0d0e21e
LW
3423 while (pat < patend) {
3424 reparse:
bbdab043 3425 datumtype = *pat++ & 0xFF;
726ea183 3426#ifdef PERL_NATINT_PACK
ef54e1a4 3427 natint = 0;
726ea183 3428#endif
bbdab043
CS
3429 if (isSPACE(datumtype))
3430 continue;
17f4a12d
IZ
3431 if (datumtype == '#') {
3432 while (pat < patend && *pat != '\n')
3433 pat++;
3434 continue;
3435 }
f61d411c 3436 if (*pat == '!') {
ef54e1a4
JH
3437 char *natstr = "sSiIlL";
3438
3439 if (strchr(natstr, datumtype)) {
726ea183 3440#ifdef PERL_NATINT_PACK
ef54e1a4 3441 natint = 1;
726ea183 3442#endif
ef54e1a4
JH
3443 pat++;
3444 }
3445 else
d470f89e 3446 DIE(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 3447 }
4b5b2118 3448 star = 0;
a0d0e21e
LW
3449 if (pat >= patend)
3450 len = 1;
3451 else if (*pat == '*') {
3452 len = strend - strbeg; /* long enough */
3453 pat++;
4b5b2118 3454 star = 1;
a0d0e21e
LW
3455 }
3456 else if (isDIGIT(*pat)) {
3457 len = *pat++ - '0';
06387354 3458 while (isDIGIT(*pat)) {
a0d0e21e 3459 len = (len * 10) + (*pat++ - '0');
06387354 3460 if (len < 0)
d470f89e 3461 DIE(aTHX_ "Repeat count in unpack overflows");
06387354 3462 }
a0d0e21e
LW
3463 }
3464 else
3465 len = (datumtype != '@');
4b5b2118 3466 redo_switch:
a0d0e21e
LW
3467 switch(datumtype) {
3468 default:
d470f89e 3469 DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3470 case ',': /* grandfather in commas but with a warning */
e476b1b5
GS
3471 if (commas++ == 0 && ckWARN(WARN_UNPACK))
3472 Perl_warner(aTHX_ WARN_UNPACK,
d470f89e 3473 "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3474 break;
a0d0e21e
LW
3475 case '%':
3476 if (len == 1 && pat[-1] != '1')
3477 len = 16;
3478 checksum = len;
3479 culong = 0;
3480 cdouble = 0;
3481 if (pat < patend)
3482 goto reparse;
3483 break;
3484 case '@':
3485 if (len > strend - strbeg)
cea2e8a9 3486 DIE(aTHX_ "@ outside of string");
a0d0e21e
LW
3487 s = strbeg + len;
3488 break;
3489 case 'X':
3490 if (len > s - strbeg)
cea2e8a9 3491 DIE(aTHX_ "X outside of string");
a0d0e21e
LW
3492 s -= len;
3493 break;
3494 case 'x':
3495 if (len > strend - s)
cea2e8a9 3496 DIE(aTHX_ "x outside of string");
a0d0e21e
LW
3497 s += len;
3498 break;
17f4a12d 3499 case '/':
dd58a1ab 3500 if (start_sp_offset >= SP - PL_stack_base)
17f4a12d 3501 DIE(aTHX_ "/ must follow a numeric type");
43192e07
IP
3502 datumtype = *pat++;
3503 if (*pat == '*')
3504 pat++; /* ignore '*' for compatibility with pack */
3505 if (isDIGIT(*pat))
17f4a12d 3506 DIE(aTHX_ "/ cannot take a count" );
43192e07 3507 len = POPi;
4b5b2118
GS
3508 star = 0;
3509 goto redo_switch;
a0d0e21e 3510 case 'A':
5a929a98 3511 case 'Z':
a0d0e21e
LW
3512 case 'a':
3513 if (len > strend - s)
3514 len = strend - s;
3515 if (checksum)
3516 goto uchar_checksum;
3517 sv = NEWSV(35, len);
3518 sv_setpvn(sv, s, len);
3519 s += len;
5a929a98 3520 if (datumtype == 'A' || datumtype == 'Z') {
a0d0e21e 3521 aptr = s; /* borrow register */
5a929a98
VU
3522 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3523 s = SvPVX(sv);
3524 while (*s)
3525 s++;
3526 }
3527 else { /* 'A' strips both nulls and spaces */
3528 s = SvPVX(sv) + len - 1;
3529 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3530 s--;
3531 *++s = '\0';
3532 }
a0d0e21e
LW
3533 SvCUR_set(sv, s - SvPVX(sv));
3534 s = aptr; /* unborrow register */
3535 }
3536 XPUSHs(sv_2mortal(sv));
3537 break;
3538 case 'B':
3539 case 'b':
4b5b2118 3540 if (star || len > (strend - s) * 8)
a0d0e21e
LW
3541 len = (strend - s) * 8;
3542 if (checksum) {
80252599
GS
3543 if (!PL_bitcount) {
3544 Newz(601, PL_bitcount, 256, char);
a0d0e21e 3545 for (bits = 1; bits < 256; bits++) {
80252599
GS
3546 if (bits & 1) PL_bitcount[bits]++;
3547 if (bits & 2) PL_bitcount[bits]++;
3548 if (bits & 4) PL_bitcount[bits]++;
3549 if (bits & 8) PL_bitcount[bits]++;
3550 if (bits & 16) PL_bitcount[bits]++;
3551 if (bits & 32) PL_bitcount[bits]++;
3552 if (bits & 64) PL_bitcount[bits]++;
3553 if (bits & 128) PL_bitcount[bits]++;
a0d0e21e
LW
3554 }
3555 }
3556 while (len >= 8) {
80252599 3557 culong += PL_bitcount[*(unsigned char*)s++];
a0d0e21e
LW
3558 len -= 8;
3559 }
3560 if (len) {
3561 bits = *s;
3562 if (datumtype == 'b') {
3563 while (len-- > 0) {
3564 if (bits & 1) culong++;
3565 bits >>= 1;
3566 }
3567 }
3568 else {
3569 while (len-- > 0) {
3570 if (bits & 128) culong++;
3571 bits <<= 1;
3572 }
3573 }
3574 }
79072805
LW
3575 break;
3576 }
a0d0e21e
LW
3577 sv = NEWSV(35, len + 1);
3578 SvCUR_set(sv, len);
3579 SvPOK_on(sv);
abdc5761 3580 str = SvPVX(sv);
a0d0e21e
LW
3581 if (datumtype == 'b') {
3582 aint = len;
3583 for (len = 0; len < aint; len++) {
3584 if (len & 7) /*SUPPRESS 595*/
3585 bits >>= 1;
3586 else
3587 bits = *s++;
abdc5761 3588 *str++ = '0' + (bits & 1);
a0d0e21e
LW
3589 }
3590 }
3591 else {
3592 aint = len;
3593 for (len = 0; len < aint; len++) {
3594 if (len & 7)
3595 bits <<= 1;
3596 else
3597 bits = *s++;
abdc5761 3598 *str++ = '0' + ((bits & 128) != 0);
a0d0e21e
LW
3599 }
3600 }
abdc5761 3601 *str = '\0';
a0d0e21e
LW
3602 XPUSHs(sv_2mortal(sv));
3603 break;
3604 case 'H':
3605 case 'h':
4b5b2118 3606 if (star || len > (strend - s) * 2)