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