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