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