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