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
Warning fix to change #3922.
[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;
43192e07 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;
9e24b6e2 1888 XPUSHn(scan_hex(tmps, 99, &argtype));
79072805
LW		 1889 RETURN;
1890}
1891
1892PP(pp_oct)
1893{
4e35701f 1894 djSP; dTARGET;
9e24b6e2 1895 NV 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++;
9e24b6e2
JH		 1903 if (*tmps == '0')
1904 tmps++;
1905 if (*tmps == 'x')
1906 value = scan_hex(++tmps, 99, &argtype);
1907 else if (*tmps == 'b')
1908 value = scan_bin(++tmps, 99, &argtype);
464e2e8a 1909 else
9e24b6e2
JH		 1910 value = scan_oct(tmps, 99, &argtype);
1911 XPUSHn(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{
59af0135 2634 djSP;
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) {
59af0135 2649 SV *val;
c07a80fd 2650 PUTBACK;
c750a3ec 2651 /* might clobber stack_sp */
59af0135
GS		 2652 val = realhv ?
2653 hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry);
c07a80fd 2654 SPAGAIN;
59af0135 2655 PUSHs(val);
79072805 2656 }
79072805 2657 }
54310121 2658 else if (gimme == G_SCALAR)
79072805
LW		 2659 RETPUSHUNDEF;
2660
2661 RETURN;
2662}
2663
2664PP(pp_values)
2665{
cea2e8a9 2666 return do_kv();
79072805
LW		 2667}
2668
2669PP(pp_keys)
2670{
cea2e8a9 2671 return do_kv();
79072805
LW		 2672}
2673
2674PP(pp_delete)
2675{
4e35701f 2676 djSP;
54310121 2677 I32 gimme = GIMME_V;
2678 I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
79072805 2679 SV *sv;
5f05dabc 2680 HV *hv;
2681
533c011a 2682 if (PL_op->op_private & OPpSLICE) {
5f05dabc 2683 dMARK; dORIGMARK;
97fcbf96 2684 U32 hvtype;
5f05dabc 2685 hv = (HV*)POPs;
97fcbf96 2686 hvtype = SvTYPE(hv);
5f05dabc 2687 while (++MARK <= SP) {
ae77835f
MB		 2688 if (hvtype == SVt_PVHV)
2689 sv = hv_delete_ent(hv, *MARK, discard, 0);
ae77835f 2690 else
cea2e8a9 2691 DIE(aTHX_ "Not a HASH reference");
3280af22 2692 *MARK = sv ? sv : &PL_sv_undef;
5f05dabc 2693 }
54310121 2694 if (discard)
2695 SP = ORIGMARK;
2696 else if (gimme == G_SCALAR) {
5f05dabc 2697 MARK = ORIGMARK;
2698 *++MARK = *SP;
2699 SP = MARK;
2700 }
2701 }
2702 else {
2703 SV *keysv = POPs;
2704 hv = (HV*)POPs;
97fcbf96
MB		 2705 if (SvTYPE(hv) == SVt_PVHV)
2706 sv = hv_delete_ent(hv, keysv, discard, 0);
97fcbf96 2707 else
cea2e8a9 2708 DIE(aTHX_ "Not a HASH reference");
5f05dabc 2709 if (!sv)
3280af22 2710 sv = &PL_sv_undef;
54310121 2711 if (!discard)
2712 PUSHs(sv);
79072805 2713 }
79072805
LW		 2714 RETURN;
2715}
2716
a0d0e21e 2717PP(pp_exists)
79072805 2718{
4e35701f 2719 djSP;
a0d0e21e
LW		 2720 SV *tmpsv = POPs;
2721 HV *hv = (HV*)POPs;
c750a3ec 2722 if (SvTYPE(hv) == SVt_PVHV) {
ae77835f 2723 if (hv_exists_ent(hv, tmpsv, 0))
c750a3ec 2724 RETPUSHYES;
ef54e1a4
JH		 2725 }
2726 else if (SvTYPE(hv) == SVt_PVAV) {
ae77835f 2727 if (avhv_exists_ent((AV*)hv, tmpsv, 0))
c750a3ec 2728 RETPUSHYES;
ef54e1a4
JH		 2729 }
2730 else {
cea2e8a9 2731 DIE(aTHX_ "Not a HASH reference");
a0d0e21e 2732 }
a0d0e21e
LW		 2733 RETPUSHNO;
2734}
79072805 2735
a0d0e21e
LW		 2736PP(pp_hslice)
2737{
4e35701f 2738 djSP; dMARK; dORIGMARK;
a0d0e21e 2739 register HV *hv = (HV*)POPs;
533c011a 2740 register I32 lval = PL_op->op_flags & OPf_MOD;
c750a3ec 2741 I32 realhv = (SvTYPE(hv) == SVt_PVHV);
79072805 2742
0ebe0038 2743 if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
cea2e8a9 2744 DIE(aTHX_ "Can't localize pseudo-hash element");
0ebe0038 2745
c750a3ec 2746 if (realhv || SvTYPE(hv) == SVt_PVAV) {
a0d0e21e 2747 while (++MARK <= SP) {
f12c7020 2748 SV *keysv = *MARK;
ae77835f
MB		 2749 SV **svp;
2750 if (realhv) {
800e9ae0 2751 HE *he = hv_fetch_ent(hv, keysv, lval, 0);
ae77835f 2752 svp = he ? &HeVAL(he) : 0;
ef54e1a4
JH		 2753 }
2754 else {
97fcbf96 2755 svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
ae77835f 2756 }
a0d0e21e 2757 if (lval) {
2d8e6c8d
GS		 2758 if (!svp || *svp == &PL_sv_undef) {
2759 STRLEN n_a;
cea2e8a9 2760 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
2d8e6c8d 2761 }
533c011a 2762 if (PL_op->op_private & OPpLVAL_INTRO)
800e9ae0 2763 save_helem(hv, keysv, svp);
93a17b20 2764 }
3280af22 2765 *MARK = svp ? *svp : &PL_sv_undef;
79072805
LW		 2766 }
2767 }
a0d0e21e
LW		 2768 if (GIMME != G_ARRAY) {
2769 MARK = ORIGMARK;
2770 *++MARK = *SP;
2771 SP = MARK;
79072805 2772 }
a0d0e21e
LW		 2773 RETURN;
2774}
2775
2776/* List operators. */
2777
2778PP(pp_list)
2779{
4e35701f 2780 djSP; dMARK;
a0d0e21e
LW		 2781 if (GIMME != G_ARRAY) {
2782 if (++MARK <= SP)
2783 *MARK = *SP; /* unwanted list, return last item */
8990e307 2784 else
3280af22 2785 *MARK = &PL_sv_undef;
a0d0e21e 2786 SP = MARK;
79072805 2787 }
a0d0e21e 2788 RETURN;
79072805
LW		 2789}
2790
a0d0e21e 2791PP(pp_lslice)
79072805 2792{
4e35701f 2793 djSP;
3280af22
NIS		 2794 SV **lastrelem = PL_stack_sp;
2795 SV **lastlelem = PL_stack_base + POPMARK;
2796 SV **firstlelem = PL_stack_base + POPMARK + 1;
a0d0e21e 2797 register SV **firstrelem = lastlelem + 1;
3280af22 2798 I32 arybase = PL_curcop->cop_arybase;
533c011a 2799 I32 lval = PL_op->op_flags & OPf_MOD;
4633a7c4 2800 I32 is_something_there = lval;
79072805 2801
a0d0e21e
LW		 2802 register I32 max = lastrelem - lastlelem;
2803 register SV **lelem;
2804 register I32 ix;
2805
2806 if (GIMME != G_ARRAY) {
748a9306
LW		 2807 ix = SvIVx(*lastlelem);
2808 if (ix < 0)
2809 ix += max;
2810 else
2811 ix -= arybase;
a0d0e21e 2812 if (ix < 0 || ix >= max)
3280af22 2813 *firstlelem = &PL_sv_undef;
a0d0e21e
LW		 2814 else
2815 *firstlelem = firstrelem[ix];
2816 SP = firstlelem;
2817 RETURN;
2818 }
2819
2820 if (max == 0) {
2821 SP = firstlelem - 1;
2822 RETURN;
2823 }
2824
2825 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
748a9306 2826 ix = SvIVx(*lelem);
c73bf8e3 2827 if (ix < 0)
a0d0e21e 2828 ix += max;
c73bf8e3 2829 else
748a9306 2830 ix -= arybase;
c73bf8e3
HS		 2831 if (ix < 0 || ix >= max)
2832 *lelem = &PL_sv_undef;
2833 else {
2834 is_something_there = TRUE;
2835 if (!(*lelem = firstrelem[ix]))
3280af22 2836 *lelem = &PL_sv_undef;
748a9306 2837 }
79072805 2838 }
4633a7c4
LW		 2839 if (is_something_there)
2840 SP = lastlelem;
2841 else
2842 SP = firstlelem - 1;
79072805
LW		 2843 RETURN;
2844}
2845
a0d0e21e
LW		 2846PP(pp_anonlist)
2847{
4e35701f 2848 djSP; dMARK; dORIGMARK;
a0d0e21e 2849 I32 items = SP - MARK;
44a8e56a 2850 SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
2851 SP = ORIGMARK; /* av_make() might realloc stack_sp */
2852 XPUSHs(av);
a0d0e21e
LW		 2853 RETURN;
2854}
2855
2856PP(pp_anonhash)
79072805 2857{
4e35701f 2858 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2859 HV* hv = (HV*)sv_2mortal((SV*)newHV());
2860
2861 while (MARK < SP) {
2862 SV* key = *++MARK;
a0d0e21e
LW		 2863 SV *val = NEWSV(46, 0);
2864 if (MARK < SP)
2865 sv_setsv(val, *++MARK);
599cee73 2866 else if (ckWARN(WARN_UNSAFE))
cea2e8a9 2867 Perl_warner(aTHX_ WARN_UNSAFE, "Odd number of elements in hash assignment");
f12c7020 2868 (void)hv_store_ent(hv,key,val,0);
79072805 2869 }
a0d0e21e
LW		 2870 SP = ORIGMARK;
2871 XPUSHs((SV*)hv);
79072805
LW		 2872 RETURN;
2873}
2874
a0d0e21e 2875PP(pp_splice)
79072805 2876{
4e35701f 2877 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 2878 register AV *ary = (AV*)*++MARK;
2879 register SV **src;
2880 register SV **dst;
2881 register I32 i;
2882 register I32 offset;
2883 register I32 length;
2884 I32 newlen;
2885 I32 after;
2886 I32 diff;
2887 SV **tmparyval = 0;
93965878
NIS		 2888 MAGIC *mg;
2889
33c27489
GS		 2890 if (mg = SvTIED_mg((SV*)ary, 'P')) {
2891 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878 2892 PUSHMARK(MARK);
8ec5e241 2893 PUTBACK;
a60c0954 2894 ENTER;
864dbfa3 2895 call_method("SPLICE",GIMME_V);
a60c0954 2896 LEAVE;
93965878
NIS		 2897 SPAGAIN;
2898 RETURN;
2899 }
79072805 2900
a0d0e21e 2901 SP++;
79072805 2902
a0d0e21e 2903 if (++MARK < SP) {
84902520 2904 offset = i = SvIVx(*MARK);
a0d0e21e 2905 if (offset < 0)
93965878 2906 offset += AvFILLp(ary) + 1;
a0d0e21e 2907 else
3280af22 2908 offset -= PL_curcop->cop_arybase;
84902520 2909 if (offset < 0)
cea2e8a9 2910 DIE(aTHX_ PL_no_aelem, i);
a0d0e21e
LW		 2911 if (++MARK < SP) {
2912 length = SvIVx(*MARK++);
48cdf507
GA		 2913 if (length < 0) {
2914 length += AvFILLp(ary) - offset + 1;
2915 if (length < 0)
2916 length = 0;
2917 }
79072805
LW		 2918 }
2919 else
a0d0e21e 2920 length = AvMAX(ary) + 1; /* close enough to infinity */
79072805 2921 }
a0d0e21e
LW		 2922 else {
2923 offset = 0;
2924 length = AvMAX(ary) + 1;
2925 }
93965878
NIS		 2926 if (offset > AvFILLp(ary) + 1)
2927 offset = AvFILLp(ary) + 1;
2928 after = AvFILLp(ary) + 1 - (offset + length);
a0d0e21e
LW		 2929 if (after < 0) { /* not that much array */
2930 length += after; /* offset+length now in array */
2931 after = 0;
2932 if (!AvALLOC(ary))
2933 av_extend(ary, 0);
2934 }
2935
2936 /* At this point, MARK .. SP-1 is our new LIST */
2937
2938 newlen = SP - MARK;
2939 diff = newlen - length;
13d7cbc1
GS		 2940 if (newlen && !AvREAL(ary) && AvREIFY(ary))
2941 av_reify(ary);
a0d0e21e
LW		 2942
2943 if (diff < 0) { /* shrinking the area */
2944 if (newlen) {
2945 New(451, tmparyval, newlen, SV*); /* so remember insertion */
2946 Copy(MARK, tmparyval, newlen, SV*);
79072805 2947 }
a0d0e21e
LW		 2948
2949 MARK = ORIGMARK + 1;
2950 if (GIMME == G_ARRAY) { /* copy return vals to stack */
2951 MEXTEND(MARK, length);
2952 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
2953 if (AvREAL(ary)) {
bbce6d69 2954 EXTEND_MORTAL(length);
36477c24 2955 for (i = length, dst = MARK; i; i--) {
d689ffdd 2956 sv_2mortal(*dst); /* free them eventualy */
36477c24 2957 dst++;
2958 }
a0d0e21e
LW		 2959 }
2960 MARK += length - 1;
79072805 2961 }
a0d0e21e
LW		 2962 else {
2963 *MARK = AvARRAY(ary)[offset+length-1];
2964 if (AvREAL(ary)) {
d689ffdd 2965 sv_2mortal(*MARK);
a0d0e21e
LW		 2966 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
2967 SvREFCNT_dec(*dst++); /* free them now */
79072805 2968 }
a0d0e21e 2969 }
93965878 2970 AvFILLp(ary) += diff;
a0d0e21e
LW		 2971
2972 /* pull up or down? */
2973
2974 if (offset < after) { /* easier to pull up */
2975 if (offset) { /* esp. if nothing to pull */
2976 src = &AvARRAY(ary)[offset-1];
2977 dst = src - diff; /* diff is negative */
2978 for (i = offset; i > 0; i--) /* can't trust Copy */
2979 *dst-- = *src--;
79072805 2980 }
a0d0e21e
LW		 2981 dst = AvARRAY(ary);
2982 SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
2983 AvMAX(ary) += diff;
2984 }
2985 else {
2986 if (after) { /* anything to pull down? */
2987 src = AvARRAY(ary) + offset + length;
2988 dst = src + diff; /* diff is negative */
2989 Move(src, dst, after, SV*);
79072805 2990 }
93965878 2991 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
a0d0e21e
LW		 2992 /* avoid later double free */
2993 }
2994 i = -diff;
2995 while (i)
3280af22 2996 dst[--i] = &PL_sv_undef;
a0d0e21e
LW		 2997
2998 if (newlen) {
2999 for (src = tmparyval, dst = AvARRAY(ary) + offset;
3000 newlen; newlen--) {
3001 *dst = NEWSV(46, 0);
3002 sv_setsv(*dst++, *src++);
79072805 3003 }
a0d0e21e
LW		 3004 Safefree(tmparyval);
3005 }
3006 }
3007 else { /* no, expanding (or same) */
3008 if (length) {
3009 New(452, tmparyval, length, SV*); /* so remember deletion */
3010 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
3011 }
3012
3013 if (diff > 0) { /* expanding */
3014
3015 /* push up or down? */
3016
3017 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
3018 if (offset) {
3019 src = AvARRAY(ary);
3020 dst = src - diff;
3021 Move(src, dst, offset, SV*);
79072805 3022 }
a0d0e21e
LW		 3023 SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
3024 AvMAX(ary) += diff;
93965878 3025 AvFILLp(ary) += diff;
79072805
LW		 3026 }
3027 else {
93965878
NIS		 3028 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
3029 av_extend(ary, AvFILLp(ary) + diff);
3030 AvFILLp(ary) += diff;
a0d0e21e
LW		 3031
3032 if (after) {
93965878 3033 dst = AvARRAY(ary) + AvFILLp(ary);
a0d0e21e
LW		 3034 src = dst - diff;
3035 for (i = after; i; i--) {
3036 *dst-- = *src--;
3037 }
79072805
LW		 3038 }
3039 }
a0d0e21e
LW		 3040 }
3041
3042 for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
3043 *dst = NEWSV(46, 0);
3044 sv_setsv(*dst++, *src++);
3045 }
3046 MARK = ORIGMARK + 1;
3047 if (GIMME == G_ARRAY) { /* copy return vals to stack */
3048 if (length) {
3049 Copy(tmparyval, MARK, length, SV*);
3050 if (AvREAL(ary)) {
bbce6d69 3051 EXTEND_MORTAL(length);
36477c24 3052 for (i = length, dst = MARK; i; i--) {
d689ffdd 3053 sv_2mortal(*dst); /* free them eventualy */
36477c24 3054 dst++;
3055 }
79072805 3056 }
a0d0e21e 3057 Safefree(tmparyval);
79072805 3058 }
a0d0e21e
LW		 3059 MARK += length - 1;
3060 }
3061 else if (length--) {
3062 *MARK = tmparyval[length];
3063 if (AvREAL(ary)) {
d689ffdd 3064 sv_2mortal(*MARK);
a0d0e21e
LW		 3065 while (length-- > 0)
3066 SvREFCNT_dec(tmparyval[length]);
79072805 3067 }
a0d0e21e 3068 Safefree(tmparyval);
79072805 3069 }
a0d0e21e 3070 else
3280af22 3071 *MARK = &PL_sv_undef;
79072805 3072 }
a0d0e21e 3073 SP = MARK;
79072805
LW		 3074 RETURN;
3075}
3076
a0d0e21e 3077PP(pp_push)
79072805 3078{
4e35701f 3079 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3080 register AV *ary = (AV*)*++MARK;
3280af22 3081 register SV *sv = &PL_sv_undef;
93965878 3082 MAGIC *mg;
79072805 3083
33c27489
GS		 3084 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3085 *MARK-- = SvTIED_obj((SV*)ary, mg);
93965878
NIS		 3086 PUSHMARK(MARK);
3087 PUTBACK;
a60c0954 3088 ENTER;
864dbfa3 3089 call_method("PUSH",G_SCALAR|G_DISCARD);
a60c0954 3090 LEAVE;
93965878 3091 SPAGAIN;
93965878 3092 }
a60c0954
NIS		 3093 else {
3094 /* Why no pre-extend of ary here ? */
3095 for (++MARK; MARK <= SP; MARK++) {
3096 sv = NEWSV(51, 0);
3097 if (*MARK)
3098 sv_setsv(sv, *MARK);
3099 av_push(ary, sv);
3100 }
79072805
LW		 3101 }
3102 SP = ORIGMARK;
a0d0e21e 3103 PUSHi( AvFILL(ary) + 1 );
79072805
LW		 3104 RETURN;
3105}
3106
a0d0e21e 3107PP(pp_pop)
79072805 3108{
4e35701f 3109 djSP;
a0d0e21e
LW		 3110 AV *av = (AV*)POPs;
3111 SV *sv = av_pop(av);
d689ffdd 3112 if (AvREAL(av))
a0d0e21e
LW		 3113 (void)sv_2mortal(sv);
3114 PUSHs(sv);
79072805 3115 RETURN;
79072805
LW		 3116}
3117
a0d0e21e 3118PP(pp_shift)
79072805 3119{
4e35701f 3120 djSP;
a0d0e21e
LW		 3121 AV *av = (AV*)POPs;
3122 SV *sv = av_shift(av);
79072805 3123 EXTEND(SP, 1);
a0d0e21e 3124 if (!sv)
79072805 3125 RETPUSHUNDEF;
d689ffdd 3126 if (AvREAL(av))
a0d0e21e
LW		 3127 (void)sv_2mortal(sv);
3128 PUSHs(sv);
79072805 3129 RETURN;
79072805
LW		 3130}
3131
a0d0e21e 3132PP(pp_unshift)
79072805 3133{
4e35701f 3134 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 3135 register AV *ary = (AV*)*++MARK;
3136 register SV *sv;
3137 register I32 i = 0;
93965878
NIS		 3138 MAGIC *mg;
3139
33c27489
GS		 3140 if (mg = SvTIED_mg((SV*)ary, 'P')) {
3141 *MARK-- = SvTIED_obj((SV*)ary, mg);
7fd66d9d 3142 PUSHMARK(MARK);
93965878 3143 PUTBACK;
a60c0954 3144 ENTER;
864dbfa3 3145 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
a60c0954 3146 LEAVE;
93965878 3147 SPAGAIN;
93965878 3148 }
a60c0954
NIS		 3149 else {
3150 av_unshift(ary, SP - MARK);
3151 while (MARK < SP) {
3152 sv = NEWSV(27, 0);
3153 sv_setsv(sv, *++MARK);
3154 (void)av_store(ary, i++, sv);
3155 }
79072805 3156 }
a0d0e21e
LW		 3157 SP = ORIGMARK;
3158 PUSHi( AvFILL(ary) + 1 );
79072805 3159 RETURN;
79072805
LW		 3160}
3161
a0d0e21e 3162PP(pp_reverse)
79072805 3163{
4e35701f 3164 djSP; dMARK;
a0d0e21e
LW		 3165 register SV *tmp;
3166 SV **oldsp = SP;
79072805 3167
a0d0e21e
LW		 3168 if (GIMME == G_ARRAY) {
3169 MARK++;
3170 while (MARK < SP) {
3171 tmp = *MARK;
3172 *MARK++ = *SP;
3173 *SP-- = tmp;
3174 }
3175 SP = oldsp;
79072805
LW		 3176 }
3177 else {
a0d0e21e
LW		 3178 register char *up;
3179 register char *down;
3180 register I32 tmp;
3181 dTARGET;
3182 STRLEN len;
79072805 3183
a0d0e21e 3184 if (SP - MARK > 1)
3280af22 3185 do_join(TARG, &PL_sv_no, MARK, SP);
a0d0e21e 3186 else
54b9620d 3187 sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
a0d0e21e
LW		 3188 up = SvPV_force(TARG, len);
3189 if (len > 1) {
a0ed51b3 3190 if (IN_UTF8) { /* first reverse each character */
dfe13c55
GS		 3191 U8* s = (U8*)SvPVX(TARG);
3192 U8* send = (U8*)(s + len);
a0ed51b3
LW		 3193 while (s < send) {
3194 if (*s < 0x80) {
3195 s++;
3196 continue;
3197 }
3198 else {
dfe13c55 3199 up = (char*)s;
a0ed51b3 3200 s += UTF8SKIP(s);
dfe13c55 3201 down = (char*)(s - 1);
f248d071
GS		 3202 if (s > send || !((*down & 0xc0) == 0x80)) {
3203 if (ckWARN_d(WARN_UTF8))
3204 Perl_warner(aTHX_ WARN_UTF8,
3205 "Malformed UTF-8 character");
a0ed51b3
LW		 3206 break;
3207 }
3208 while (down > up) {
3209 tmp = *up;
3210 *up++ = *down;
3211 *down-- = tmp;
3212 }
3213 }
3214 }
3215 up = SvPVX(TARG);
3216 }
a0d0e21e
LW		 3217 down = SvPVX(TARG) + len - 1;
3218 while (down > up) {
3219 tmp = *up;
3220 *up++ = *down;
3221 *down-- = tmp;
3222 }
3223 (void)SvPOK_only(TARG);
79072805 3224 }
a0d0e21e
LW		 3225 SP = MARK + 1;
3226 SETTARG;
79072805 3227 }
a0d0e21e 3228 RETURN;
79072805
LW		 3229}
3230
864dbfa3 3231STATIC SV *
cea2e8a9 3232S_mul128(pTHX_ SV *sv, U8 m)
55497cff 3233{
3234 STRLEN len;
3235 char *s = SvPV(sv, len);
3236 char *t;
3237 U32 i = 0;
3238
3239 if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
79cb57f6 3240 SV *tmpNew = newSVpvn("0000000000", 10);
55497cff 3241
09b7f37c 3242 sv_catsv(tmpNew, sv);
55497cff 3243 SvREFCNT_dec(sv); /* free old sv */
09b7f37c 3244 sv = tmpNew;
55497cff 3245 s = SvPV(sv, len);
3246 }
3247 t = s + len - 1;
3248 while (!*t) /* trailing '\0'? */
3249 t--;
3250 while (t > s) {
3251 i = ((*t - '0') << 7) + m;
3252 *(t--) = '0' + (i % 10);
3253 m = i / 10;
3254 }
3255 return (sv);
3256}
3257
a0d0e21e
LW		 3258/* Explosives and implosives. */
3259
9d116dd7
JH		 3260#if 'I' == 73 && 'J' == 74
3261/* On an ASCII/ISO kind of system */
ba1ac976 3262#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
9d116dd7
JH		 3263#else
3264/*
3265 Some other sort of character set - use memchr() so we don't match
3266 the null byte.
3267 */
80252599 3268#define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ')
9d116dd7
JH		 3269#endif
3270
a0d0e21e 3271PP(pp_unpack)
79072805 3272{
4e35701f 3273 djSP;
a0d0e21e 3274 dPOPPOPssrl;
924508f0 3275 SV **oldsp = SP;
54310121 3276 I32 gimme = GIMME_V;
ed6116ce 3277 SV *sv;
a0d0e21e
LW		 3278 STRLEN llen;
3279 STRLEN rlen;
3280 register char *pat = SvPV(left, llen);
3281 register char *s = SvPV(right, rlen);
3282 char *strend = s + rlen;
3283 char *strbeg = s;
3284 register char *patend = pat + llen;
3285 I32 datumtype;
3286 register I32 len;
3287 register I32 bits;
79072805 3288
a0d0e21e
LW		 3289 /* These must not be in registers: */
3290 I16 ashort;
3291 int aint;
3292 I32 along;
ecfc5424
AD		 3293#ifdef HAS_QUAD
3294 Quad_t aquad;
a0d0e21e
LW		 3295#endif
3296 U16 aushort;
3297 unsigned int auint;
3298 U32 aulong;
ecfc5424 3299#ifdef HAS_QUAD
e862df63 3300 Uquad_t auquad;
a0d0e21e
LW		 3301#endif
3302 char *aptr;
3303 float afloat;
3304 double adouble;
3305 I32 checksum = 0;
3306 register U32 culong;
65202027 3307 NV cdouble;
fb73857a 3308 int commas = 0;
726ea183 3309#ifdef PERL_NATINT_PACK
ef54e1a4
JH		 3310 int natint; /* native integer */
3311 int unatint; /* unsigned native integer */
726ea183 3312#endif
79072805 3313
54310121 3314 if (gimme != G_ARRAY) { /* arrange to do first one only */
a0d0e21e
LW		 3315 /*SUPPRESS 530*/
3316 for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
5a929a98 3317 if (strchr("aAZbBhHP", *patend) || *pat == '%') {
a0d0e21e
LW		 3318 patend++;
3319 while (isDIGIT(*patend) || *patend == '*')
3320 patend++;
3321 }
3322 else
3323 patend++;
79072805 3324 }
a0d0e21e
LW		 3325 while (pat < patend) {
3326 reparse:
bbdab043 3327 datumtype = *pat++ & 0xFF;
726ea183 3328#ifdef PERL_NATINT_PACK
ef54e1a4 3329 natint = 0;
726ea183 3330#endif
bbdab043
CS		 3331 if (isSPACE(datumtype))
3332 continue;
f61d411c 3333 if (*pat == '!') {
ef54e1a4
JH		 3334 char *natstr = "sSiIlL";
3335
3336 if (strchr(natstr, datumtype)) {
726ea183 3337#ifdef PERL_NATINT_PACK
ef54e1a4 3338 natint = 1;
726ea183 3339#endif
ef54e1a4
JH		 3340 pat++;
3341 }
3342 else
cea2e8a9 3343 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 3344 }
a0d0e21e
LW		 3345 if (pat >= patend)
3346 len = 1;
3347 else if (*pat == '*') {
3348 len = strend - strbeg; /* long enough */
3349 pat++;
3350 }
3351 else if (isDIGIT(*pat)) {
3352 len = *pat++ - '0';
3353 while (isDIGIT(*pat))
3354 len = (len * 10) + (*pat++ - '0');
3355 }
3356 else
3357 len = (datumtype != '@');
3358 switch(datumtype) {
3359 default:
cea2e8a9 3360 Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3361 case ',': /* grandfather in commas but with a warning */
599cee73 3362 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
cea2e8a9 3363 Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
fb73857a 3364 break;
a0d0e21e
LW		 3365 case '%':
3366 if (len == 1 && pat[-1] != '1')
3367 len = 16;
3368 checksum = len;
3369 culong = 0;
3370 cdouble = 0;
3371 if (pat < patend)
3372 goto reparse;
3373 break;
3374 case '@':
3375 if (len > strend - strbeg)
cea2e8a9 3376 DIE(aTHX_ "@ outside of string");
a0d0e21e
LW		 3377 s = strbeg + len;
3378 break;
3379 case 'X':
3380 if (len > s - strbeg)
cea2e8a9 3381 DIE(aTHX_ "X outside of string");
a0d0e21e
LW		 3382 s -= len;
3383 break;
3384 case 'x':
3385 if (len > strend - s)
cea2e8a9 3386 DIE(aTHX_ "x outside of string");
a0d0e21e
LW		 3387 s += len;
3388 break;
43192e07
IP		 3389 case '#':
3390 if (oldsp >= SP)
3391 DIE(aTHX_ "# must follow a numeric type");
3392 if (*pat != 'a' && *pat != 'A' && *pat != 'Z')
3393 DIE(aTHX_ "# must be followed by a, A or Z");
3394 datumtype = *pat++;
3395 if (*pat == '*')
3396 pat++; /* ignore '*' for compatibility with pack */
3397 if (isDIGIT(*pat))
3398 DIE(aTHX_ "# cannot take a count" );
3399 len = POPi;
3400 /* drop through */
a0d0e21e 3401 case 'A':
5a929a98 3402 case 'Z':
a0d0e21e
LW		 3403 case 'a':
3404 if (len > strend - s)
3405 len = strend - s;
3406 if (checksum)
3407 goto uchar_checksum;
3408 sv = NEWSV(35, len);
3409 sv_setpvn(sv, s, len);
3410 s += len;
5a929a98 3411 if (datumtype == 'A' || datumtype == 'Z') {
a0d0e21e 3412 aptr = s; /* borrow register */
5a929a98
VU		 3413 if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
3414 s = SvPVX(sv);
3415 while (*s)
3416 s++;
3417 }
3418 else { /* 'A' strips both nulls and spaces */
3419 s = SvPVX(sv) + len - 1;
3420 while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
3421 s--;
3422 *++s = '\0';
3423 }
a0d0e21e
LW		 3424 SvCUR_set(sv, s - SvPVX(sv));
3425 s = aptr; /* unborrow register */
3426 }
3427 XPUSHs(sv_2mortal(sv));
3428 break;
3429 case 'B':
3430 case 'b':
3431 if (pat[-1] == '*' || len > (strend - s) * 8)
3432 len = (strend - s) * 8;
3433 if (checksum) {
80252599
GS		 3434 if (!PL_bitcount) {
3435 Newz(601, PL_bitcount, 256, char);
a0d0e21e 3436 for (bits = 1; bits < 256; bits++) {
80252599
GS		 3437 if (bits & 1) PL_bitcount[bits]++;
3438 if (bits & 2) PL_bitcount[bits]++;
3439 if (bits & 4) PL_bitcount[bits]++;
3440 if (bits & 8) PL_bitcount[bits]++;
3441 if (bits & 16) PL_bitcount[bits]++;
3442 if (bits & 32) PL_bitcount[bits]++;
3443 if (bits & 64) PL_bitcount[bits]++;
3444 if (bits & 128) PL_bitcount[bits]++;
a0d0e21e
LW		 3445 }
3446 }
3447 while (len >= 8) {
80252599 3448 culong += PL_bitcount[*(unsigned char*)s++];
a0d0e21e
LW		 3449 len -= 8;
3450 }
3451 if (len) {
3452 bits = *s;
3453 if (datumtype == 'b') {
3454 while (len-- > 0) {
3455 if (bits & 1) culong++;
3456 bits >>= 1;
3457 }
3458 }
3459 else {
3460 while (len-- > 0) {
3461 if (bits & 128) culong++;
3462 bits <<= 1;
3463 }
3464 }
3465 }
79072805
LW		 3466 break;
3467 }
a0d0e21e
LW		 3468 sv = NEWSV(35, len + 1);
3469 SvCUR_set(sv, len);
3470 SvPOK_on(sv);
3471 aptr = pat; /* borrow register */
3472 pat = SvPVX(sv);
3473 if (datumtype == 'b') {
3474 aint = len;
3475 for (len = 0; len < aint; len++) {
3476 if (len & 7) /*SUPPRESS 595*/
3477 bits >>= 1;
3478 else
3479 bits = *s++;
3480 *pat++ = '0' + (bits & 1);
3481 }
3482 }
3483 else {
3484 aint = len;
3485 for (len = 0; len < aint; len++) {
3486 if (len & 7)
3487 bits <<= 1;
3488 else
3489 bits = *s++;
3490 *pat++ = '0' + ((bits & 128) != 0);
3491 }
3492 }
3493 *pat = '\0';
3494 pat = aptr; /* unborrow register */
3495 XPUSHs(sv_2mortal(sv));
3496 break;
3497 case 'H':
3498 case 'h':
3499 if (pat[-1] == '*' || len > (strend - s) * 2)
3500 len = (strend - s) * 2;
3501 sv = NEWSV(35, len + 1);
3502 SvCUR_set(sv, len);
3503 SvPOK_on(sv);
3504 aptr = pat; /* borrow register */
3505 pat = SvPVX(sv);
3506 if (datumtype == 'h') {
3507 aint = len;
3508 for (len = 0; len < aint; len++) {
3509 if (len & 1)
3510 bits >>= 4;
3511 else
3512 bits = *s++;
3280af22 3513 *pat++ = PL_hexdigit[bits & 15];
a0d0e21e
LW		 3514 }
3515 }
3516 else {
3517 aint = len;
3518 for (len = 0; len < aint; len++) {
3519 if (len & 1)
3520 bits <<= 4;
3521 else
3522 bits = *s++;
3280af22 3523 *pat++ = PL_hexdigit[(bits >> 4) & 15];
a0d0e21e
LW		 3524 }
3525 }
3526 *pat = '\0';
3527 pat = aptr; /* unborrow register */
3528 XPUSHs(sv_2mortal(sv));
3529 break;
3530 case 'c':
3531 if (len > strend - s)
3532 len = strend - s;
3533 if (checksum) {
3534 while (len-- > 0) {
3535 aint = *s++;
3536 if (aint >= 128) /* fake up signed chars */
3537 aint -= 256;
3538 culong += aint;
3539 }
3540 }
3541 else {
3542 EXTEND(SP, len);
bbce6d69 3543 EXTEND_MORTAL(len);
a0d0e21e
LW		 3544 while (len-- > 0) {
3545 aint = *s++;
3546 if (aint >= 128) /* fake up signed chars */
3547 aint -= 256;
3548 sv = NEWSV(36, 0);
1e422769 3549 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3550 PUSHs(sv_2mortal(sv));
3551 }
3552 }
3553 break;
3554 case 'C':
3555 if (len > strend - s)
3556 len = strend - s;
3557 if (checksum) {
3558 uchar_checksum:
3559 while (len-- > 0) {
3560 auint = *s++ & 255;
3561 culong += auint;
3562 }
3563 }
3564 else {
3565 EXTEND(SP, len);
bbce6d69 3566 EXTEND_MORTAL(len);
a0d0e21e
LW		 3567 while (len-- > 0) {
3568 auint = *s++ & 255;
3569 sv = NEWSV(37, 0);
1e422769 3570 sv_setiv(sv, (IV)auint);
a0d0e21e
LW		 3571 PUSHs(sv_2mortal(sv));
3572 }
3573 }
3574 break;
a0ed51b3
LW		 3575 case 'U':
3576 if (len > strend - s)
3577 len = strend - s;
3578 if (checksum) {
3579 while (len-- > 0 && s < strend) {
dfe13c55 3580 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3 3581 s += along;
32d8b6e5 3582 if (checksum > 32)
65202027 3583 cdouble += (NV)auint;
32d8b6e5
GA		 3584 else
3585 culong += auint;
a0ed51b3
LW		 3586 }
3587 }
3588 else {
3589 EXTEND(SP, len);
3590 EXTEND_MORTAL(len);
3591 while (len-- > 0 && s < strend) {
dfe13c55 3592 auint = utf8_to_uv((U8*)s, &along);
a0ed51b3
LW		 3593 s += along;
3594 sv = NEWSV(37, 0);
bdeef251 3595 sv_setuv(sv, (UV)auint);
a0ed51b3
LW		 3596 PUSHs(sv_2mortal(sv));
3597 }
3598 }
3599 break;
a0d0e21e 3600 case 's':
726ea183
JH		 3601#if SHORTSIZE == SIZE16
3602 along = (strend - s) / SIZE16;
3603#else
ef54e1a4 3604 along = (strend - s) / (natint ? sizeof(short) : SIZE16);
726ea183 3605#endif
a0d0e21e
LW		 3606 if (len > along)
3607 len = along;
3608 if (checksum) {
726ea183 3609#if SHORTSIZE != SIZE16
ef54e1a4
JH		 3610 if (natint) {
3611 while (len-- > 0) {
3612 COPYNN(s, &ashort, sizeof(short));
3613 s += sizeof(short);
3614 culong += ashort;
3615
3616 }
3617 }
726ea183
JH		 3618 else
3619#endif
3620 {
ef54e1a4
JH		 3621 while (len-- > 0) {
3622 COPY16(s, &ashort);
c67712b2
JH		 3623#if SHORTSIZE > SIZE16
3624 if (ashort > 32767)
3625 ashort -= 65536;
3626#endif
ef54e1a4
JH		 3627 s += SIZE16;
3628 culong += ashort;
3629 }
a0d0e21e
LW		 3630 }
3631 }
3632 else {
3633 EXTEND(SP, len);
bbce6d69 3634 EXTEND_MORTAL(len);
726ea183 3635#if SHORTSIZE != SIZE16
ef54e1a4
JH		 3636 if (natint) {
3637 while (len-- > 0) {
3638 COPYNN(s, &ashort, sizeof(short));
3639 s += sizeof(short);
3640 sv = NEWSV(38, 0);
3641 sv_setiv(sv, (IV)ashort);
3642 PUSHs(sv_2mortal(sv));
3643 }
3644 }
726ea183
JH		 3645 else
3646#endif
3647 {
ef54e1a4
JH		 3648 while (len-- > 0) {
3649 COPY16(s, &ashort);
c67712b2
JH		 3650#if SHORTSIZE > SIZE16
3651 if (ashort > 32767)
3652 ashort -= 65536;
3653#endif
ef54e1a4
JH		 3654 s += SIZE16;
3655 sv = NEWSV(38, 0);
3656 sv_setiv(sv, (IV)ashort);
3657 PUSHs(sv_2mortal(sv));
3658 }
a0d0e21e
LW		 3659 }
3660 }
3661 break;
3662 case 'v':
3663 case 'n':
3664 case 'S':
726ea183
JH		 3665#if SHORTSIZE == SIZE16
3666 along = (strend - s) / SIZE16;
3667#else
ef54e1a4
JH		 3668 unatint = natint && datumtype == 'S';
3669 along = (strend - s) / (unatint ? sizeof(unsigned short) : SIZE16);
726ea183 3670#endif
a0d0e21e
LW		 3671 if (len > along)
3672 len = along;
3673 if (checksum) {
726ea183 3674#if SHORTSIZE != SIZE16
ef54e1a4
JH		 3675 if (unatint) {
3676 while (len-- > 0) {
3677 COPYNN(s, &aushort, sizeof(unsigned short));
3678 s += sizeof(unsigned short);
3679 culong += aushort;
3680 }
3681 }
726ea183
JH		 3682 else
3683#endif
3684 {
ef54e1a4
JH		 3685 while (len-- > 0) {
3686 COPY16(s, &aushort);
3687 s += SIZE16;
a0d0e21e 3688#ifdef HAS_NTOHS
ef54e1a4
JH		 3689 if (datumtype == 'n')
3690 aushort = PerlSock_ntohs(aushort);
79072805 3691#endif
a0d0e21e 3692#ifdef HAS_VTOHS
ef54e1a4
JH		 3693 if (datumtype == 'v')
3694 aushort = vtohs(aushort);
79072805 3695#endif
ef54e1a4
JH		 3696 culong += aushort;
3697 }
a0d0e21e
LW		 3698 }
3699 }
3700 else {
3701 EXTEND(SP, len);
bbce6d69 3702 EXTEND_MORTAL(len);
726ea183 3703#if SHORTSIZE != SIZE16
ef54e1a4
JH		 3704 if (unatint) {
3705 while (len-- > 0) {
3706 COPYNN(s, &aushort, sizeof(unsigned short));
3707 s += sizeof(unsigned short);
3708 sv = NEWSV(39, 0);
726ea183 3709 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH		 3710 PUSHs(sv_2mortal(sv));
3711 }
3712 }
726ea183
JH		 3713 else
3714#endif
3715 {
ef54e1a4
JH		 3716 while (len-- > 0) {
3717 COPY16(s, &aushort);
3718 s += SIZE16;
3719 sv = NEWSV(39, 0);
a0d0e21e 3720#ifdef HAS_NTOHS
ef54e1a4
JH		 3721 if (datumtype == 'n')
3722 aushort = PerlSock_ntohs(aushort);
79072805 3723#endif
a0d0e21e 3724#ifdef HAS_VTOHS
ef54e1a4
JH		 3725 if (datumtype == 'v')
3726 aushort = vtohs(aushort);
79072805 3727#endif
726ea183 3728 sv_setiv(sv, (UV)aushort);
ef54e1a4
JH		 3729 PUSHs(sv_2mortal(sv));
3730 }
a0d0e21e
LW		 3731 }
3732 }
3733 break;
3734 case 'i':
3735 along = (strend - s) / sizeof(int);
3736 if (len > along)
3737 len = along;
3738 if (checksum) {
3739 while (len-- > 0) {
3740 Copy(s, &aint, 1, int);
3741 s += sizeof(int);
3742 if (checksum > 32)
65202027 3743 cdouble += (NV)aint;
a0d0e21e
LW		 3744 else
3745 culong += aint;
3746 }
3747 }
3748 else {
3749 EXTEND(SP, len);
bbce6d69 3750 EXTEND_MORTAL(len);
a0d0e21e
LW		 3751 while (len-- > 0) {
3752 Copy(s, &aint, 1, int);
3753 s += sizeof(int);
3754 sv = NEWSV(40, 0);
20408e3c
GS		 3755#ifdef __osf__
3756 /* Without the dummy below unpack("i", pack("i",-1))
3757 * return 0xFFffFFff instead of -1 for Digital Unix V4.0
13476c87
JH		 3758 * cc with optimization turned on.
3759 *
3760 * The bug was detected in
3761 * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E)
3762 * with optimization (-O4) turned on.
3763 * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B)
3764 * does not have this problem even with -O4.
3765 *
3766 * This bug was reported as DECC_BUGS 1431
3767 * and tracked internally as GEM_BUGS 7775.
3768 *
3769 * The bug is fixed in
3770 * Tru64 UNIX V5.0: Compaq C V6.1-006 or later
3771 * UNIX V4.0F support: DEC C V5.9-006 or later
3772 * UNIX V4.0E support: DEC C V5.8-011 or later
3773 * and also in DTK.
3774 *
3775 * See also few lines later for the same bug.
3776 */
20408e3c
GS		 3777 (aint) ?
3778 sv_setiv(sv, (IV)aint) :
3779#endif
1e422769 3780 sv_setiv(sv, (IV)aint);
a0d0e21e
LW		 3781 PUSHs(sv_2mortal(sv));
3782 }
3783 }
3784 break;
3785 case 'I':
3786 along = (strend - s) / sizeof(unsigned int);
3787 if (len > along)
3788 len = along;
3789 if (checksum) {
3790 while (len-- > 0) {
3791 Copy(s, &auint, 1, unsigned int);
3792 s += sizeof(unsigned int);
3793 if (checksum > 32)
65202027 3794 cdouble += (NV)auint;
a0d0e21e
LW		 3795 else
3796 culong += auint;
3797 }
3798 }
3799 else {
3800 EXTEND(SP, len);
bbce6d69 3801 EXTEND_MORTAL(len);
a0d0e21e
LW		 3802 while (len-- > 0) {
3803 Copy(s, &auint, 1, unsigned int);
3804 s += sizeof(unsigned int);
3805 sv = NEWSV(41, 0);
9d645a59
AB		 3806#ifdef __osf__
3807 /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
13476c87
JH		 3808 * returns 1.84467440737096e+19 instead of 0xFFFFFFFF.
3809 * See details few lines earlier. */
9d645a59
AB		 3810 (auint) ?
3811 sv_setuv(sv, (UV)auint) :
3812#endif
1e422769 3813 sv_setuv(sv, (UV)auint);
a0d0e21e
LW		 3814 PUSHs(sv_2mortal(sv));
3815 }
3816 }
3817 break;
3818 case 'l':
726ea183
JH		 3819#if LONGSIZE == SIZE32
3820 along = (strend - s) / SIZE32;
3821#else
ef54e1a4 3822 along = (strend - s) / (natint ? sizeof(long) : SIZE32);
726ea183 3823#endif
a0d0e21e
LW		 3824 if (len > along)
3825 len = along;
3826 if (checksum) {
726ea183 3827#if LONGSIZE != SIZE32
ef54e1a4
JH		 3828 if (natint) {
3829 while (len-- > 0) {
3830 COPYNN(s, &along, sizeof(long));
3831 s += sizeof(long);
3832 if (checksum > 32)
65202027 3833 cdouble += (NV)along;
ef54e1a4
JH		 3834 else
3835 culong += along;
3836 }
3837 }
726ea183
JH		 3838 else
3839#endif
3840 {
ef54e1a4
JH		 3841 while (len-- > 0) {
3842 COPY32(s, &along);
c67712b2
JH		 3843#if LONGSIZE > SIZE32
3844 if (along > 2147483647)
3845 along -= 4294967296;
3846#endif
ef54e1a4
JH		 3847 s += SIZE32;
3848 if (checksum > 32)
65202027 3849 cdouble += (NV)along;
ef54e1a4
JH		 3850 else
3851 culong += along;
3852 }
a0d0e21e
LW		 3853 }
3854 }
3855 else {
3856 EXTEND(SP, len);
bbce6d69 3857 EXTEND_MORTAL(len);
726ea183 3858#if LONGSIZE != SIZE32
ef54e1a4
JH		 3859 if (natint) {
3860 while (len-- > 0) {
3861 COPYNN(s, &along, sizeof(long));
3862 s += sizeof(long);
3863 sv = NEWSV(42, 0);
3864 sv_setiv(sv, (IV)along);
3865 PUSHs(sv_2mortal(sv));
3866 }
3867 }
726ea183
JH		 3868 else
3869#endif
3870 {
ef54e1a4
JH		 3871 while (len-- > 0) {
3872 COPY32(s, &along);
c67712b2
JH		 3873#if LONGSIZE > SIZE32
3874 if (along > 2147483647)
3875 along -= 4294967296;
3876#endif
ef54e1a4
JH		 3877 s += SIZE32;
3878 sv = NEWSV(42, 0);
3879 sv_setiv(sv, (IV)along);
3880 PUSHs(sv_2mortal(sv));
3881 }
a0d0e21e 3882 }
79072805 3883 }
a0d0e21e
LW		 3884 break;
3885 case 'V':
3886 case 'N':
3887 case 'L':
726ea183
JH		 3888#if LONGSIZE == SIZE32
3889 along = (strend - s) / SIZE32;
3890#else
3891 unatint = natint && datumtype == 'L';
ef54e1a4 3892 along = (strend - s) / (unatint ? sizeof(unsigned long) : SIZE32);
726ea183 3893#endif
a0d0e21e
LW		 3894 if (len > along)
3895 len = along;
3896 if (checksum) {
726ea183 3897#if LONGSIZE != SIZE32
ef54e1a4
JH		 3898 if (unatint) {
3899 while (len-- > 0) {
3900 COPYNN(s, &aulong, sizeof(unsigned long));
3901 s += sizeof(unsigned long);
3902 if (checksum > 32)
65202027 3903 cdouble += (NV)aulong;
ef54e1a4
JH		 3904 else
3905 culong += aulong;
3906 }
3907 }
726ea183
JH		 3908 else
3909#endif
3910 {
ef54e1a4
JH		 3911 while (len-- > 0) {
3912 COPY32(s, &aulong);
3913 s += SIZE32;
a0d0e21e 3914#ifdef HAS_NTOHL
ef54e1a4
JH		 3915 if (datumtype == 'N')
3916 aulong = PerlSock_ntohl(aulong);
79072805 3917#endif
a0d0e21e 3918#ifdef HAS_VTOHL
ef54e1a4
JH		 3919 if (datumtype == 'V')
3920 aulong = vtohl(aulong);
79072805 3921#endif
ef54e1a4 3922 if (checksum > 32)
65202027 3923 cdouble += (NV)aulong;
ef54e1a4
JH		 3924 else
3925 culong += aulong;
3926 }
a0d0e21e
LW		 3927 }
3928 }
3929 else {
3930 EXTEND(SP, len);
bbce6d69 3931 EXTEND_MORTAL(len);
726ea183 3932#if LONGSIZE != SIZE32
ef54e1a4
JH		 3933 if (unatint) {
3934 while (len-- > 0) {
3935 COPYNN(s, &aulong, sizeof(unsigned long));
3936 s += sizeof(unsigned long);
3937 sv = NEWSV(43, 0);
3938 sv_setuv(sv, (UV)aulong);
3939 PUSHs(sv_2mortal(sv));
3940 }
3941 }
726ea183
JH		 3942 else
3943#endif
3944 {
ef54e1a4
JH		 3945 while (len-- > 0) {
3946 COPY32(s, &aulong);
3947 s += SIZE32;
a0d0e21e 3948#ifdef HAS_NTOHL
ef54e1a4
JH		 3949 if (datumtype == 'N')
3950 aulong = PerlSock_ntohl(aulong);
79072805 3951#endif
a0d0e21e 3952#ifdef HAS_VTOHL
ef54e1a4
JH		 3953 if (datumtype == 'V')
3954 aulong = vtohl(aulong);
79072805 3955#endif
ef54e1a4
JH		 3956 sv = NEWSV(43, 0);
3957 sv_setuv(sv, (UV)aulong);
3958 PUSHs(sv_2mortal(sv));
3959 }
a0d0e21e
LW		 3960 }
3961 }
3962 break;
3963 case 'p':
3964 along = (strend - s) / sizeof(char*);
3965 if (len > along)
3966 len = along;
3967 EXTEND(SP, len);
bbce6d69 3968 EXTEND_MORTAL(len);
a0d0e21e
LW		 3969 while (len-- > 0) {
3970 if (sizeof(char*) > strend - s)
3971 break;
3972 else {
3973 Copy(s, &aptr, 1, char*);
3974 s += sizeof(char*);
3975 }
3976 sv = NEWSV(44, 0);
3977 if (aptr)
3978 sv_setpv(sv, aptr);
3979 PUSHs(sv_2mortal(sv));
3980 }
3981 break;
def98dd4 3982 case 'w':
def98dd4 3983 EXTEND(SP, len);
bbce6d69 3984 EXTEND_MORTAL(len);
8ec5e241 3985 {
bbce6d69 3986 UV auv = 0;
3987 U32 bytes = 0;
3988
3989 while ((len > 0) && (s < strend)) {
3990 auv = (auv << 7) | (*s & 0x7f);
3991 if (!(*s++ & 0x80)) {
3992 bytes = 0;
3993 sv = NEWSV(40, 0);
3994 sv_setuv(sv, auv);
3995 PUSHs(sv_2mortal(sv));
3996 len--;
3997 auv = 0;
3998 }
3999 else if (++bytes >= sizeof(UV)) { /* promote to string */
bbce6d69 4000 char *t;
2d8e6c8d 4001 STRLEN n_a;
bbce6d69 4002
cea2e8a9 4003 sv = Perl_newSVpvf(aTHX_ "%.*Vu", (int)TYPE_DIGITS(UV), auv);
bbce6d69 4004 while (s < strend) {
4005 sv = mul128(sv, *s & 0x7f);
4006 if (!(*s++ & 0x80)) {
4007 bytes = 0;
4008 break;
4009 }
4010 }
2d8e6c8d 4011 t = SvPV(sv, n_a);
bbce6d69 4012 while (*t == '0')
4013 t++;
4014 sv_chop(sv, t);
4015 PUSHs(sv_2mortal(sv));
4016 len--;
4017 auv = 0;
4018 }
4019 }
4020 if ((s >= strend) && bytes)
cea2e8a9 4021 Perl_croak(aTHX_ "Unterminated compressed integer");
bbce6d69 4022 }
def98dd4 4023 break;
a0d0e21e
LW		 4024 case 'P':
4025 EXTEND(SP, 1);
4026 if (sizeof(char*) > strend - s)
4027 break;
4028 else {
4029 Copy(s, &aptr, 1, char*);
4030 s += sizeof(char*);
4031 }
4032 sv = NEWSV(44, 0);
4033 if (aptr)
4034 sv_setpvn(sv, aptr, len);
4035 PUSHs(sv_2mortal(sv));
4036 break;
ecfc5424 4037#ifdef HAS_QUAD
a0d0e21e 4038 case 'q':
d4217c7e
JH		 4039 along = (strend - s) / sizeof(Quad_t);
4040 if (len > along)
4041 len = along;
a0d0e21e 4042 EXTEND(SP, len);
bbce6d69 4043 EXTEND_MORTAL(len);
a0d0e21e 4044 while (len-- > 0) {
ecfc5424 4045 if (s + sizeof(Quad_t) > strend)
a0d0e21e
LW		 4046 aquad = 0;
4047 else {
ecfc5424
AD		 4048 Copy(s, &aquad, 1, Quad_t);
4049 s += sizeof(Quad_t);
a0d0e21e
LW		 4050 }
4051 sv = NEWSV(42, 0);
96e4d5b1 4052 if (aquad >= IV_MIN && aquad <= IV_MAX)
4053 sv_setiv(sv, (IV)aquad);
4054 else
65202027 4055 sv_setnv(sv, (NV)aquad);
a0d0e21e
LW		 4056 PUSHs(sv_2mortal(sv));
4057 }
4058 break;
4059 case 'Q':
d4217c7e
JH		 4060 along = (strend - s) / sizeof(Quad_t);
4061 if (len > along)
4062 len = along;
a0d0e21e 4063 EXTEND(SP, len);
bbce6d69 4064 EXTEND_MORTAL(len);
a0d0e21e 4065 while (len-- > 0) {
e862df63 4066 if (s + sizeof(Uquad_t) > strend)
a0d0e21e
LW		 4067 auquad = 0;
4068 else {
e862df63
HB		 4069 Copy(s, &auquad, 1, Uquad_t);
4070 s += sizeof(Uquad_t);
a0d0e21e
LW		 4071 }
4072 sv = NEWSV(43, 0);
27612d38 4073 if (auquad <= UV_MAX)
96e4d5b1 4074 sv_setuv(sv, (UV)auquad);
4075 else
65202027 4076 sv_setnv(sv, (NV)auquad);
a0d0e21e
LW		 4077 PUSHs(sv_2mortal(sv));
4078 }
4079 break;
79072805 4080#endif
a0d0e21e
LW		 4081 /* float and double added gnb@melba.bby.oz.au 22/11/89 */
4082 case 'f':
4083 case 'F':
4084 along = (strend - s) / sizeof(float);
4085 if (len > along)
4086 len = along;
4087 if (checksum) {
4088 while (len-- > 0) {
4089 Copy(s, &afloat, 1, float);
4090 s += sizeof(float);
4091 cdouble += afloat;
4092 }
4093 }
4094 else {
4095 EXTEND(SP, len);
bbce6d69 4096 EXTEND_MORTAL(len);
a0d0e21e
LW		 4097 while (len-- > 0) {
4098 Copy(s, &afloat, 1, float);
4099 s += sizeof(float);
4100 sv = NEWSV(47, 0);
65202027 4101 sv_setnv(sv, (NV)afloat);
a0d0e21e
LW		 4102 PUSHs(sv_2mortal(sv));
4103 }
4104 }
4105 break;
4106 case 'd':
4107 case 'D':
4108 along = (strend - s) / sizeof(double);
4109 if (len > along)
4110 len = along;
4111 if (checksum) {
4112 while (len-- > 0) {
4113 Copy(s, &adouble, 1, double);
4114 s += sizeof(double);
4115 cdouble += adouble;
4116 }
4117 }
4118 else {
4119 EXTEND(SP, len);
bbce6d69 4120 EXTEND_MORTAL(len);
a0d0e21e
LW		 4121 while (len-- > 0) {
4122 Copy(s, &adouble, 1, double);
4123 s += sizeof(double);
4124 sv = NEWSV(48, 0);
65202027 4125 sv_setnv(sv, (NV)adouble);
a0d0e21e
LW		 4126 PUSHs(sv_2mortal(sv));
4127 }
4128 }
4129 break;
4130 case 'u':
9d116dd7
JH		 4131 /* MKS:
4132 * Initialise the decode mapping. By using a table driven
4133 * algorithm, the code will be character-set independent
4134 * (and just as fast as doing character arithmetic)
4135 */
80252599 4136 if (PL_uudmap['M'] == 0) {
9d116dd7
JH		 4137 int i;
4138
80252599
GS		 4139 for (i = 0; i < sizeof(PL_uuemap); i += 1)
4140 PL_uudmap[PL_uuemap[i]] = i;
9d116dd7
JH		 4141 /*
4142 * Because ' ' and '`' map to the same value,
4143 * we need to decode them both the same.
4144 */
80252599 4145 PL_uudmap[' '] = 0;
9d116dd7
JH		 4146 }
4147
a0d0e21e
LW		 4148 along = (strend - s) * 3 / 4;
4149 sv = NEWSV(42, along);
f12c7020 4150 if (along)
4151 SvPOK_on(sv);
9d116dd7 4152 while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
a0d0e21e
LW		 4153 I32 a, b, c, d;
4154 char hunk[4];
79072805 4155
a0d0e21e 4156 hunk[3] = '\0';
80252599 4157 len = PL_uudmap[*s++] & 077;
a0d0e21e 4158 while (len > 0) {
9d116dd7 4159 if (s < strend && ISUUCHAR(*s))
80252599 4160 a = PL_uudmap[*s++] & 077;
9d116dd7
JH		 4161 else
4162 a = 0;
4163 if (s < strend && ISUUCHAR(*s))
80252599 4164 b = PL_uudmap[*s++] & 077;
9d116dd7
JH		 4165 else
4166 b = 0;
4167 if (s < strend && ISUUCHAR(*s))
80252599 4168 c = PL_uudmap[*s++] & 077;
9d116dd7
JH		 4169 else
4170 c = 0;
4171 if (s < strend && ISUUCHAR(*s))
80252599 4172 d = PL_uudmap[*s++] & 077;
a0d0e21e
LW		 4173 else
4174 d = 0;
4e35701f
NIS		 4175 hunk[0] = (a << 2) | (b >> 4);
4176 hunk[1] = (b << 4) | (c >> 2);
4177 hunk[2] = (c << 6) | d;
4178 sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
a0d0e21e
LW		 4179 len -= 3;
4180 }
4181 if (*s == '\n')
4182 s++;
4183 else if (s[1] == '\n') /* possible checksum byte */
4184 s += 2;
79072805 4185 }
a0d0e21e
LW		 4186 XPUSHs(sv_2mortal(sv));
4187 break;
79072805 4188 }
a0d0e21e
LW		 4189 if (checksum) {
4190 sv = NEWSV(42, 0);
4191 if (strchr("fFdD", datumtype) ||
32d8b6e5 4192 (checksum > 32 && strchr("iIlLNU", datumtype)) ) {
65202027 4193 NV trouble;
79072805 4194
a0d0e21e
LW		 4195 adouble = 1.0;
4196 while (checksum >= 16) {
4197 checksum -= 16;
4198 adouble *= 65536.0;
4199 }
4200 while (checksum >= 4) {
4201 checksum -= 4;
4202 adouble *= 16.0;
4203 }
4204 while (checksum--)
4205 adouble *= 2.0;
4206 along = (1 << checksum) - 1;
4207 while (cdouble < 0.0)
4208 cdouble += adouble;
65202027 4209 cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
a0d0e21e
LW		 4210 sv_setnv(sv, cdouble);
4211 }
4212 else {
4213 if (checksum < 32) {
96e4d5b1 4214 aulong = (1 << checksum) - 1;
4215 culong &= aulong;
a0d0e21e 4216 }
96e4d5b1 4217 sv_setuv(sv, (UV)culong);
a0d0e21e
LW		 4218 }
4219 XPUSHs(sv_2mortal(sv));
4220 checksum = 0;
79072805 4221 }
79072805 4222 }
924508f0 4223 if (SP == oldsp && gimme == G_SCALAR)
3280af22 4224 PUSHs(&PL_sv_undef);
79072805 4225 RETURN;
79072805
LW		 4226}
4227
76e3520e 4228STATIC void
cea2e8a9 4229S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len)
79072805 4230{
a0d0e21e 4231 char hunk[5];
79072805 4232
80252599 4233 *hunk = PL_uuemap[len];
a0d0e21e
LW		 4234 sv_catpvn(sv, hunk, 1);
4235 hunk[4] = '\0';
f264d472 4236 while (len > 2) {
80252599
GS		 4237 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4238 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
4239 hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
4240 hunk[3] = PL_uuemap[(077 & (s[2] & 077))];
a0d0e21e
LW		 4241 sv_catpvn(sv, hunk, 4);
4242 s += 3;
4243 len -= 3;
4244 }
f264d472
GS		 4245 if (len > 0) {
4246 char r = (len > 1 ? s[1] : '\0');
80252599
GS		 4247 hunk[0] = PL_uuemap[(077 & (*s >> 2))];
4248 hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
4249 hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))];
4250 hunk[3] = PL_uuemap[0];
f264d472 4251 sv_catpvn(sv, hunk, 4);
a0d0e21e
LW		 4252 }
4253 sv_catpvn(sv, "\n", 1);
79072805
LW		 4254}
4255
79cb57f6 4256STATIC SV *
cea2e8a9 4257S_is_an_int(pTHX_ char *s, STRLEN l)
55497cff 4258{
2d8e6c8d 4259 STRLEN n_a;
79cb57f6 4260 SV *result = newSVpvn(s, l);
2d8e6c8d 4261 char *result_c = SvPV(result, n_a); /* convenience */
55497cff 4262 char *out = result_c;
4263 bool skip = 1;
4264 bool ignore = 0;
4265
4266 while (*s) {
4267 switch (*s) {
4268 case ' ':
4269 break;
4270 case '+':
4271 if (!skip) {
4272 SvREFCNT_dec(result);
4273 return (NULL);
4274 }
4275 break;
4276 case '0':
4277 case '1':
4278 case '2':
4279 case '3':
4280 case '4':
4281 case '5':
4282 case '6':
4283 case '7':
4284 case '8':
4285 case '9':
4286 skip = 0;
4287 if (!ignore) {
4288 *(out++) = *s;
4289 }
4290 break;
4291 case '.':
4292 ignore = 1;
4293 break;
4294 default:
4295 SvREFCNT_dec(result);
4296 return (NULL);
4297 }
4298 s++;
4299 }
4300 *(out++) = '\0';
4301 SvCUR_set(result, out - result_c);
4302 return (result);
4303}
4304
864dbfa3 4305/* pnum must be '\0' terminated */
76e3520e 4306STATIC int
cea2e8a9 4307S_div128(pTHX_ SV *pnum, bool *done)
55497cff 4308{
4309 STRLEN len;
4310 char *s = SvPV(pnum, len);
4311 int m = 0;
4312 int r = 0;
4313 char *t = s;
4314
4315 *done = 1;
4316 while (*t) {
4317 int i;
4318
4319 i = m * 10 + (*t - '0');
4320 m = i & 0x7F;
4321 r = (i >> 7); /* r < 10 */
4322 if (r) {
4323 *done = 0;
4324 }
4325 *(t++) = '0' + r;
4326 }
4327 *(t++) = '\0';
4328 SvCUR_set(pnum, (STRLEN) (t - s));
4329 return (m);
4330}
4331
4332
a0d0e21e 4333PP(pp_pack)
79072805 4334{
4e35701f 4335 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4336 register SV *cat = TARG;
4337 register I32 items;
4338 STRLEN fromlen;
4339 register char *pat = SvPVx(*++MARK, fromlen);
4340 register char *patend = pat + fromlen;
4341 register I32 len;
4342 I32 datumtype;
4343 SV *fromstr;
4344 /*SUPPRESS 442*/
4345 static char null10[] = {0,0,0,0,0,0,0,0,0,0};
4346 static char *space10 = " ";
79072805 4347
a0d0e21e
LW		 4348 /* These must not be in registers: */
4349 char achar;
4350 I16 ashort;
4351 int aint;
4352 unsigned int auint;
4353 I32 along;
4354 U32 aulong;
ecfc5424
AD		 4355#ifdef HAS_QUAD
4356 Quad_t aquad;
e862df63 4357 Uquad_t auquad;
79072805 4358#endif
a0d0e21e
LW		 4359 char *aptr;
4360 float afloat;
4361 double adouble;
fb73857a 4362 int commas = 0;
726ea183 4363#ifdef PERL_NATINT_PACK
ef54e1a4 4364 int natint; /* native integer */
726ea183 4365#endif
79072805 4366
a0d0e21e
LW		 4367 items = SP - MARK;
4368 MARK++;
4369 sv_setpvn(cat, "", 0);
4370 while (pat < patend) {
43192e07
IP		 4371 SV *lengthcode = Nullsv;
4372#define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
bbdab043 4373 datumtype = *pat++ & 0xFF;
726ea183 4374#ifdef PERL_NATINT_PACK
ef54e1a4 4375 natint = 0;
726ea183 4376#endif
bbdab043
CS		 4377 if (isSPACE(datumtype))
4378 continue;
f61d411c 4379 if (*pat == '!') {
ef54e1a4
JH		 4380 char *natstr = "sSiIlL";
4381
4382 if (strchr(natstr, datumtype)) {
726ea183 4383#ifdef PERL_NATINT_PACK
ef54e1a4 4384 natint = 1;
726ea183 4385#endif
ef54e1a4
JH		 4386 pat++;
4387 }
4388 else
cea2e8a9 4389 Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
ef54e1a4 4390 }
a0d0e21e
LW		 4391 if (*pat == '*') {
4392 len = strchr("@Xxu", datumtype) ? 0 : items;
4393 pat++;
4394 }
4395 else if (isDIGIT(*pat)) {
4396 len = *pat++ - '0';
4397 while (isDIGIT(*pat))
4398 len = (len * 10) + (*pat++ - '0');
4399 }
4400 else
4401 len = 1;
43192e07
IP		 4402 if (*pat == '#') {
4403 ++pat;
4404 if (*pat != 'a' && *pat != 'A' && *pat != 'Z' || pat[1] != '*')
4405 DIE(aTHX_ "# must be followed by a*, A* or Z*");
4406 lengthcode = sv_2mortal(newSViv(sv_len(items > 0
4407 ? *MARK : &PL_sv_no)));
4408 }
a0d0e21e
LW		 4409 switch(datumtype) {
4410 default:
cea2e8a9 4411 Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
fb73857a 4412 case ',': /* grandfather in commas but with a warning */
599cee73 4413 if (commas++ == 0 && ckWARN(WARN_UNSAFE))
43192e07
IP		 4414 Perl_warner(aTHX_ WARN_UNSAFE,
4415 "Invalid type in pack: '%c'", (int)datumtype);
fb73857a 4416 break;
a0d0e21e 4417 case '%':
cea2e8a9 4418 DIE(aTHX_ "%% may only be used in unpack");
a0d0e21e
LW		 4419 case '@':
4420 len -= SvCUR(cat);
4421 if (len > 0)
4422 goto grow;
4423 len = -len;
4424 if (len > 0)
4425 goto shrink;
4426 break;
4427 case 'X':
4428 shrink:
4429 if (SvCUR(cat) < len)
cea2e8a9 4430 DIE(aTHX_ "X outside of string");
a0d0e21e
LW		 4431 SvCUR(cat) -= len;
4432 *SvEND(cat) = '\0';
4433 break;
4434 case 'x':
4435 grow:
4436 while (len >= 10) {
4437 sv_catpvn(cat, null10, 10);
4438 len -= 10;
4439 }
4440 sv_catpvn(cat, null10, len);
4441 break;
4442 case 'A':
5a929a98 4443 case 'Z':
a0d0e21e
LW		 4444 case 'a':
4445 fromstr = NEXTFROM;
4446 aptr = SvPV(fromstr, fromlen);
4447 if (pat[-1] == '*')
4448 len = fromlen;
4449 if (fromlen > len)
4450 sv_catpvn(cat, aptr, len);
4451 else {
4452 sv_catpvn(cat, aptr, fromlen);
4453 len -= fromlen;
4454 if (datumtype == 'A') {
4455 while (len >= 10) {
4456 sv_catpvn(cat, space10, 10);
4457 len -= 10;
4458 }
4459 sv_catpvn(cat, space10, len);
4460 }
4461 else {
4462 while (len >= 10) {
4463 sv_catpvn(cat, null10, 10);
4464 len -= 10;
4465 }
4466 sv_catpvn(cat, null10, len);
4467 }
4468 }
4469 break;
4470 case 'B':
4471 case 'b':
4472 {
4473 char *savepat = pat;
4474 I32 saveitems;
79072805 4475
a0d0e21e
LW		 4476 fromstr = NEXTFROM;
4477 saveitems = items;
4478 aptr = SvPV(fromstr, fromlen);
4479 if (pat[-1] == '*')
4480 len = fromlen;
4481 pat = aptr;
4482 aint = SvCUR(cat);
4483 SvCUR(cat) += (len+7)/8;
4484 SvGROW(cat, SvCUR(cat) + 1);
4485 aptr = SvPVX(cat) + aint;
4486 if (len > fromlen)
4487 len = fromlen;
4488 aint = len;
4489 items = 0;
4490 if (datumtype == 'B') {
4491 for (len = 0; len++ < aint;) {
4492 items |= *pat++ & 1;
4493 if (len & 7)
4494 items <<= 1;
4495 else {
4496 *aptr++ = items & 0xff;
4497 items = 0;
4498 }
4499 }
4500 }
4501 else {
4502 for (len = 0; len++ < aint;) {
4503 if (*pat++ & 1)
4504 items |= 128;
4505 if (len & 7)
4506 items >>= 1;
4507 else {
4508 *aptr++ = items & 0xff;
4509 items = 0;
4510 }
4511 }
4512 }
4513 if (aint & 7) {
4514 if (datumtype == 'B')
4515 items <<= 7 - (aint & 7);
4516 else
4517 items >>= 7 - (aint & 7);
4518 *aptr++ = items & 0xff;
4519 }
4520 pat = SvPVX(cat) + SvCUR(cat);
4521 while (aptr <= pat)
4522 *aptr++ = '\0';
79072805 4523
a0d0e21e
LW		 4524 pat = savepat;
4525 items = saveitems;
4526 }
4527 break;
4528 case 'H':
4529 case 'h':
4530 {
4531 char *savepat = pat;
4532 I32 saveitems;
79072805 4533
a0d0e21e
LW		 4534 fromstr = NEXTFROM;
4535 saveitems = items;
4536 aptr = SvPV(fromstr, fromlen);
4537 if (pat[-1] == '*')
4538 len = fromlen;
4539 pat = aptr;
4540 aint = SvCUR(cat);
4541 SvCUR(cat) += (len+1)/2;
4542 SvGROW(cat, SvCUR(cat) + 1);
4543 aptr = SvPVX(cat) + aint;
4544 if (len > fromlen)
4545 len = fromlen;
4546 aint = len;
4547 items = 0;
4548 if (datumtype == 'H') {
4549 for (len = 0; len++ < aint;) {
4550 if (isALPHA(*pat))
4551 items |= ((*pat++ & 15) + 9) & 15;
4552 else
4553 items |= *pat++ & 15;
4554 if (len & 1)
4555 items <<= 4;
4556 else {
4557 *aptr++ = items & 0xff;
4558 items = 0;
4559 }
4560 }
4561 }
4562 else {
4563 for (len = 0; len++ < aint;) {
4564 if (isALPHA(*pat))
4565 items |= (((*pat++ & 15) + 9) & 15) << 4;
4566 else
4567 items |= (*pat++ & 15) << 4;
4568 if (len & 1)
4569 items >>= 4;
4570 else {
4571 *aptr++ = items & 0xff;
4572 items = 0;
4573 }
4574 }
4575 }
4576 if (aint & 1)
4577 *aptr++ = items & 0xff;
4578 pat = SvPVX(cat) + SvCUR(cat);
4579 while (aptr <= pat)
4580 *aptr++ = '\0';
79072805 4581
a0d0e21e
LW		 4582 pat = savepat;
4583 items = saveitems;
4584 }
4585 break;
4586 case 'C':
4587 case 'c':
4588 while (len-- > 0) {
4589 fromstr = NEXTFROM;
4590 aint = SvIV(fromstr);
4591 achar = aint;
4592 sv_catpvn(cat, &achar, sizeof(char));
4593 }
4594 break;
a0ed51b3
LW		 4595 case 'U':
4596 while (len-- > 0) {
4597 fromstr = NEXTFROM;
4598 auint = SvUV(fromstr);
4599 SvGROW(cat, SvCUR(cat) + 10);
dfe13c55
GS		 4600 SvCUR_set(cat, (char*)uv_to_utf8((U8*)SvEND(cat),auint)
4601 - SvPVX(cat));
a0ed51b3
LW		 4602 }
4603 *SvEND(cat) = '\0';
4604 break;
a0d0e21e
LW		 4605 /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
4606 case 'f':
4607 case 'F':
4608 while (len-- > 0) {
4609 fromstr = NEXTFROM;
4610 afloat = (float)SvNV(fromstr);
4611 sv_catpvn(cat, (char *)&afloat, sizeof (float));
4612 }
4613 break;
4614 case 'd':
4615 case 'D':
4616 while (len-- > 0) {
4617 fromstr = NEXTFROM;
4618 adouble = (double)SvNV(fromstr);
4619 sv_catpvn(cat, (char *)&adouble, sizeof (double));
4620 }
4621 break;
4622 case 'n':
4623 while (len-- > 0) {
4624 fromstr = NEXTFROM;
4625 ashort = (I16)SvIV(fromstr);
4626#ifdef HAS_HTONS
6ad3d225 4627 ashort = PerlSock_htons(ashort);
79072805 4628#endif
96e4d5b1 4629 CAT16(cat, &ashort);
a0d0e21e
LW		 4630 }
4631 break;
4632 case 'v':
4633 while (len-- > 0) {
4634 fromstr = NEXTFROM;
4635 ashort = (I16)SvIV(fromstr);
4636#ifdef HAS_HTOVS
4637 ashort = htovs(ashort);
79072805 4638#endif
96e4d5b1 4639 CAT16(cat, &ashort);
a0d0e21e
LW		 4640 }
4641 break;
4642 case 'S':
726ea183 4643#if SHORTSIZE != SIZE16
ef54e1a4
JH		 4644 if (natint) {
4645 unsigned short aushort;
4646
4647 while (len-- > 0) {
4648 fromstr = NEXTFROM;
4649 aushort = SvUV(fromstr);
4650 sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short));
4651 }
4652 }
726ea183
JH		 4653 else
4654#endif
4655 {
ef54e1a4
JH		 4656 U16 aushort;
4657
4658 while (len-- > 0) {
4659 fromstr = NEXTFROM;
726ea183 4660 aushort = (U16)SvUV(fromstr);
ef54e1a4
JH		 4661 CAT16(cat, &aushort);
4662 }
726ea183 4663
ef54e1a4
JH		 4664 }
4665 break;
a0d0e21e 4666 case 's':
c67712b2 4667#if SHORTSIZE != SIZE16
ef54e1a4
JH		 4668 if (natint) {
4669 while (len-- > 0) {
4670 fromstr = NEXTFROM;
4671 ashort = SvIV(fromstr);
4672 sv_catpvn(cat, (char *)&ashort, sizeof(short));
4673 }
4674 }
726ea183
JH		 4675 else
4676#endif
4677 {
ef54e1a4
JH		 4678 while (len-- > 0) {
4679 fromstr = NEXTFROM;
4680 ashort = (I16)SvIV(fromstr);
4681 CAT16(cat, &ashort);
4682 }
a0d0e21e
LW		 4683 }
4684 break;
4685 case 'I':
4686 while (len-- > 0) {
4687 fromstr = NEXTFROM;
96e4d5b1 4688 auint = SvUV(fromstr);
a0d0e21e
LW		 4689 sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
4690 }
4691 break;
def98dd4
UP		 4692 case 'w':
4693 while (len-- > 0) {
bbce6d69 4694 fromstr = NEXTFROM;
65202027 4695 adouble = Perl_floor(SvNV(fromstr));
bbce6d69 4696
4697 if (adouble < 0)
cea2e8a9 4698 Perl_croak(aTHX_ "Cannot compress negative numbers");
bbce6d69 4699
46fc3d4c 4700 if (
4701#ifdef BW_BITS
4702 adouble <= BW_MASK
4703#else
ef2d312d
TH		 4704#ifdef CXUX_BROKEN_CONSTANT_CONVERT
4705 adouble <= UV_MAX_cxux
4706#else
46fc3d4c 4707 adouble <= UV_MAX
4708#endif
ef2d312d 4709#endif
46fc3d4c 4710 )
4711 {
bbce6d69 4712 char buf[1 + sizeof(UV)];
4713 char *in = buf + sizeof(buf);
db7c17d7 4714 UV auv = U_V(adouble);
bbce6d69 4715
4716 do {
4717 *--in = (auv & 0x7f) | 0x80;
4718 auv >>= 7;
4719 } while (auv);
4720 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4721 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4722 }
4723 else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
4724 char *from, *result, *in;
4725 SV *norm;
4726 STRLEN len;
4727 bool done;
8ec5e241 4728
bbce6d69 4729 /* Copy string and check for compliance */
4730 from = SvPV(fromstr, len);
4731 if ((norm = is_an_int(from, len)) == NULL)
cea2e8a9 4732 Perl_croak(aTHX_ "can compress only unsigned integer");
bbce6d69 4733
4734 New('w', result, len, char);
4735 in = result + len;
4736 done = FALSE;
4737 while (!done)
4738 *--in = div128(norm, &done) | 0x80;
4739 result[len - 1] &= 0x7F; /* clear continue bit */
4740 sv_catpvn(cat, in, (result + len) - in);
5f05dabc 4741 Safefree(result);
bbce6d69 4742 SvREFCNT_dec(norm); /* free norm */
def98dd4 4743 }
bbce6d69 4744 else if (SvNOKp(fromstr)) {
4745 char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
4746 char *in = buf + sizeof(buf);
4747
4748 do {
4749 double next = floor(adouble / 128);
4750 *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
4751 if (--in < buf) /* this cannot happen ;-) */
cea2e8a9 4752 Perl_croak(aTHX_ "Cannot compress integer");
bbce6d69 4753 adouble = next;
4754 } while (adouble > 0);
4755 buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
4756 sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
4757 }
4758 else
cea2e8a9 4759 Perl_croak(aTHX_ "Cannot compress non integer");
bbce6d69 4760 }
def98dd4 4761 break;
a0d0e21e
LW		 4762 case 'i':
4763 while (len-- > 0) {
4764 fromstr = NEXTFROM;
4765 aint = SvIV(fromstr);
4766 sv_catpvn(cat, (char*)&aint, sizeof(int));
4767 }
4768 break;
4769 case 'N':
4770 while (len-- > 0) {
4771 fromstr = NEXTFROM;
96e4d5b1 4772 aulong = SvUV(fromstr);
a0d0e21e 4773#ifdef HAS_HTONL
6ad3d225 4774 aulong = PerlSock_htonl(aulong);
79072805 4775#endif
96e4d5b1 4776 CAT32(cat, &aulong);
a0d0e21e
LW		 4777 }
4778 break;
4779 case 'V':
4780 while (len-- > 0) {
4781 fromstr = NEXTFROM;
96e4d5b1 4782 aulong = SvUV(fromstr);
a0d0e21e
LW		 4783#ifdef HAS_HTOVL
4784 aulong = htovl(aulong);
79072805 4785#endif
96e4d5b1 4786 CAT32(cat, &aulong);
a0d0e21e
LW		 4787 }
4788 break;
4789 case 'L':
726ea183 4790#if LONGSIZE != SIZE32
ef54e1a4
JH		 4791 if (natint) {
4792 while (len-- > 0) {
4793 fromstr = NEXTFROM;
4794 aulong = SvUV(fromstr);
4795 sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long));
4796 }
4797 }
726ea183
JH		 4798 else
4799#endif
4800 {
ef54e1a4
JH		 4801 while (len-- > 0) {
4802 fromstr = NEXTFROM;
4803 aulong = SvUV(fromstr);
4804 CAT32(cat, &aulong);
4805 }
a0d0e21e
LW		 4806 }
4807 break;
4808 case 'l':
726ea183 4809#if LONGSIZE != SIZE32
ef54e1a4
JH		 4810 if (natint) {
4811 while (len-- > 0) {
4812 fromstr = NEXTFROM;
4813 along = SvIV(fromstr);
4814 sv_catpvn(cat, (char *)&along, sizeof(long));
4815 }
4816 }
726ea183
JH		 4817 else
4818#endif
4819 {
ef54e1a4
JH		 4820 while (len-- > 0) {
4821 fromstr = NEXTFROM;
4822 along = SvIV(fromstr);
4823 CAT32(cat, &along);
4824 }
a0d0e21e
LW		 4825 }
4826 break;
ecfc5424 4827#ifdef HAS_QUAD
a0d0e21e
LW		 4828 case 'Q':
4829 while (len-- > 0) {
4830 fromstr = NEXTFROM;
e862df63
HB		 4831 auquad = (Uquad_t)SvIV(fromstr);
4832 sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
a0d0e21e
LW		 4833 }
4834 break;
4835 case 'q':
4836 while (len-- > 0) {
4837 fromstr = NEXTFROM;
ecfc5424
AD		 4838 aquad = (Quad_t)SvIV(fromstr);
4839 sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
a0d0e21e
LW		 4840 }
4841 break;
ecfc5424 4842#endif /* HAS_QUAD */
a0d0e21e
LW		 4843 case 'P':
4844 len = 1; /* assume SV is correct length */
4845 /* FALL THROUGH */
4846 case 'p':
4847 while (len-- > 0) {
4848 fromstr = NEXTFROM;
3280af22 4849 if (fromstr == &PL_sv_undef)
84902520 4850 aptr = NULL;
72dbcb4b 4851 else {
2d8e6c8d 4852 STRLEN n_a;
84902520
TB		 4853 /* XXX better yet, could spirit away the string to
4854 * a safe spot and hang on to it until the result
4855 * of pack() (and all copies of the result) are
4856 * gone.
4857 */
599cee73 4858 if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
cea2e8a9 4859 Perl_warner(aTHX_ WARN_UNSAFE,
599cee73 4860 "Attempt to pack pointer to temporary value");
84902520 4861 if (SvPOK(fromstr) || SvNIOK(fromstr))
2d8e6c8d 4862 aptr = SvPV(fromstr,n_a);
84902520 4863 else
2d8e6c8d 4864 aptr = SvPV_force(fromstr,n_a);
72dbcb4b 4865 }
a0d0e21e
LW		 4866 sv_catpvn(cat, (char*)&aptr, sizeof(char*));
4867 }
4868 break;
4869 case 'u':
4870 fromstr = NEXTFROM;
4871 aptr = SvPV(fromstr, fromlen);
4872 SvGROW(cat, fromlen * 4 / 3);
4873 if (len <= 1)
4874 len = 45;
4875 else
4876 len = len / 3 * 3;
4877 while (fromlen > 0) {
4878 I32 todo;
79072805 4879
a0d0e21e
LW		 4880 if (fromlen > len)
4881 todo = len;
4882 else
4883 todo = fromlen;
4884 doencodes(cat, aptr, todo);
4885 fromlen -= todo;
4886 aptr += todo;
4887 }
4888 break;
4889 }
4890 }
4891 SvSETMAGIC(cat);
4892 SP = ORIGMARK;
4893 PUSHs(cat);
4894 RETURN;
79072805 4895}
a0d0e21e 4896#undef NEXTFROM
79072805 4897
8ec5e241 4898
a0d0e21e 4899PP(pp_split)
79072805 4900{
4e35701f 4901 djSP; dTARG;
a0d0e21e
LW		 4902 AV *ary;
4903 register I32 limit = POPi; /* note, negative is forever */
4904 SV *sv = POPs;
4905 STRLEN len;
4906 register char *s = SvPV(sv, len);
4907 char *strend = s + len;
44a8e56a 4908 register PMOP *pm;
d9f97599 4909 register REGEXP *rx;
a0d0e21e
LW		 4910 register SV *dstr;
4911 register char *m;
4912 I32 iters = 0;
4913 I32 maxiters = (strend - s) + 10;
4914 I32 i;
4915 char *orig;
4916 I32 origlimit = limit;
4917 I32 realarray = 0;
4918 I32 base;
3280af22 4919 AV *oldstack = PL_curstack;
54310121 4920 I32 gimme = GIMME_V;
3280af22 4921 I32 oldsave = PL_savestack_ix;
8ec5e241
NIS		 4922 I32 make_mortal = 1;
4923 MAGIC *mg = (MAGIC *) NULL;
79072805 4924
44a8e56a 4925#ifdef DEBUGGING
4926 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4927#else
4928 pm = (PMOP*)POPs;
4929#endif
a0d0e21e 4930 if (!pm || !s)
cea2e8a9 4931 DIE(aTHX_ "panic: do_split");
d9f97599 4932 rx = pm->op_pmregexp;
bbce6d69 4933
4934 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4935 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4936
a0d0e21e
LW		 4937 if (pm->op_pmreplroot)
4938 ary = GvAVn((GV*)pm->op_pmreplroot);
4939 else if (gimme != G_ARRAY)
6d4ff0d2 4940#ifdef USE_THREADS
533c011a 4941 ary = (AV*)PL_curpad[0];
6d4ff0d2 4942#else
3280af22 4943 ary = GvAVn(PL_defgv);
6d4ff0d2 4944#endif /* USE_THREADS */
79072805 4945 else
a0d0e21e
LW		 4946 ary = Nullav;
4947 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4948 realarray = 1;
8ec5e241 4949 PUTBACK;
a0d0e21e
LW		 4950 av_extend(ary,0);
4951 av_clear(ary);
8ec5e241 4952 SPAGAIN;
33c27489 4953 if (mg = SvTIED_mg((SV*)ary, 'P')) {
8ec5e241 4954 PUSHMARK(SP);
33c27489 4955 XPUSHs(SvTIED_obj((SV*)ary, mg));
8ec5e241
NIS		 4956 }
4957 else {
1c0b011c
NIS		 4958 if (!AvREAL(ary)) {
4959 AvREAL_on(ary);
4960 for (i = AvFILLp(ary); i >= 0; i--)
3280af22 4961 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
1c0b011c
NIS		 4962 }
4963 /* temporarily switch stacks */
3280af22 4964 SWITCHSTACK(PL_curstack, ary);
8ec5e241 4965 make_mortal = 0;
1c0b011c 4966 }
79072805 4967 }
3280af22 4968 base = SP - PL_stack_base;
a0d0e21e
LW		 4969 orig = s;
4970 if (pm->op_pmflags & PMf_SKIPWHITE) {
bbce6d69 4971 if (pm->op_pmflags & PMf_LOCALE) {
4972 while (isSPACE_LC(*s))
4973 s++;
4974 }
4975 else {
4976 while (isSPACE(*s))
4977 s++;
4978 }
a0d0e21e 4979 }
c07a80fd 4980 if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
3280af22
NIS		 4981 SAVEINT(PL_multiline);
4982 PL_multiline = pm->op_pmflags & PMf_MULTILINE;
c07a80fd 4983 }
4984
a0d0e21e
LW		 4985 if (!limit)
4986 limit = maxiters + 2;
4987 if (pm->op_pmflags & PMf_WHITE) {
4988 while (--limit) {
bbce6d69 4989 m = s;
4990 while (m < strend &&
4991 !((pm->op_pmflags & PMf_LOCALE)
4992 ? isSPACE_LC(*m) : isSPACE(*m)))
4993 ++m;
a0d0e21e
LW		 4994 if (m >= strend)
4995 break;
bbce6d69 4996
a0d0e21e
LW		 4997 dstr = NEWSV(30, m-s);
4998 sv_setpvn(dstr, s, m-s);
8ec5e241 4999 if (make_mortal)
a0d0e21e
LW		 5000 sv_2mortal(dstr);
5001 XPUSHs(dstr);
bbce6d69 5002
5003 s = m + 1;
5004 while (s < strend &&
5005 ((pm->op_pmflags & PMf_LOCALE)
5006 ? isSPACE_LC(*s) : isSPACE(*s)))
5007 ++s;
79072805
LW		 5008 }
5009 }
2cdd06f7
IZ		 5010 else if (rx->prelen == 1 && *rx->precomp == '^') {
5011 if (!(pm->op_pmflags & PMf_MULTILINE)
5012 && !(pm->op_pmregexp->reganch & ROPT_WARNED)) {
46a8fef3
PM		 5013 if (ckWARN_d(WARN_DEPRECATED))
5014 Perl_warner(aTHX_ WARN_DEPRECATED,
5015 "split /^/ better written as split /^/m");
2cdd06f7
IZ		 5016 pm->op_pmregexp->reganch |= ROPT_WARNED;
5017 }
a0d0e21e
LW		 5018 while (--limit) {
5019 /*SUPPRESS 530*/
5020 for (m = s; m < strend && *m != '\n'; m++) ;
5021 m++;
5022 if (m >= strend)
5023 break;
5024 dstr = NEWSV(30, m-s);
5025 sv_setpvn(dstr, s, m-s);
8ec5e241 5026 if (make_mortal)
a0d0e21e
LW		 5027 sv_2mortal(dstr);
5028 XPUSHs(dstr);
5029 s = m;
5030 }
5031 }
f722798b 5032 else if ((rx->reganch & RE_USE_INTUIT) && !rx->nparens
d9f97599
GS		 5033 && (rx->reganch & ROPT_CHECK_ALL)
5034 && !(rx->reganch & ROPT_ANCH)) {
f722798b
IZ		 5035 int tail = (rx->reganch & RE_INTUIT_TAIL);
5036 SV *csv = CALLREG_INTUIT_STRING(aTHX_ rx);
5037 char c;
cf93c79d 5038
ca5b42cb
GS		 5039 len = rx->minlen;
5040 if (len == 1 && !tail) {
5041 c = *SvPV(csv,len);
a0d0e21e 5042 while (--limit) {
bbce6d69 5043 /*SUPPRESS 530*/
f722798b 5044 for (m = s; m < strend && *m != c; m++) ;
a0d0e21e
LW		 5045 if (m >= strend)
5046 break;
5047 dstr = NEWSV(30, m-s);
5048 sv_setpvn(dstr, s, m-s);
8ec5e241 5049 if (make_mortal)
a0d0e21e
LW		 5050 sv_2mortal(dstr);
5051 XPUSHs(dstr);
5052 s = m + 1;
5053 }
5054 }
5055 else {
5056#ifndef lint
5057 while (s < strend && --limit &&
f722798b
IZ		 5058 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5059 csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
79072805 5060#endif
a0d0e21e
LW		 5061 {
5062 dstr = NEWSV(31, m-s);
5063 sv_setpvn(dstr, s, m-s);
8ec5e241 5064 if (make_mortal)
a0d0e21e
LW		 5065 sv_2mortal(dstr);
5066 XPUSHs(dstr);
ca5b42cb 5067 s = m + len; /* Fake \n at the end */
a0d0e21e 5068 }
463ee0b2 5069 }
463ee0b2 5070 }
a0d0e21e 5071 else {
d9f97599 5072 maxiters += (strend - s) * rx->nparens;
f722798b
IZ		 5073 while (s < strend && --limit
5074/* && (!rx->check_substr
5075 || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
5076 0, NULL))))
5077*/ && CALLREGEXEC(aTHX_ rx, s, strend, orig,
5078 1 /* minend */, sv, NULL, 0))
bbce6d69 5079 {
d9f97599 5080 TAINT_IF(RX_MATCH_TAINTED(rx));
cf93c79d 5081 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
a0d0e21e
LW		 5082 m = s;
5083 s = orig;
cf93c79d 5084 orig = rx->subbeg;
a0d0e21e
LW		 5085 s = orig + (m - s);
5086 strend = s + (strend - m);
5087 }
cf93c79d 5088 m = rx->startp[0] + orig;
a0d0e21e
LW		 5089 dstr = NEWSV(32, m-s);
5090 sv_setpvn(dstr, s, m-s);
8ec5e241 5091 if (make_mortal)
a0d0e21e
LW		 5092 sv_2mortal(dstr);
5093 XPUSHs(dstr);
d9f97599
GS		 5094 if (rx->nparens) {
5095 for (i = 1; i <= rx->nparens; i++) {
cf93c79d
IZ		 5096 s = rx->startp[i] + orig;
5097 m = rx->endp[i] + orig;
748a9306
LW		 5098 if (m && s) {
5099 dstr = NEWSV(33, m-s);
5100 sv_setpvn(dstr, s, m-s);
5101 }
5102 else
5103 dstr = NEWSV(33, 0);
8ec5e241 5104 if (make_mortal)
a0d0e21e
LW		 5105 sv_2mortal(dstr);
5106 XPUSHs(dstr);
5107 }
5108 }
cf93c79d 5109 s = rx->endp[0] + orig;
a0d0e21e 5110 }
79072805 5111 }
8ec5e241 5112
c07a80fd 5113 LEAVE_SCOPE(oldsave);
3280af22 5114 iters = (SP - PL_stack_base) - base;
a0d0e21e 5115 if (iters > maxiters)
cea2e8a9 5116 DIE(aTHX_ "Split loop");
8ec5e241 5117
a0d0e21e
LW		 5118 /* keep field after final delim? */
5119 if (s < strend || (iters && origlimit)) {
5120 dstr = NEWSV(34, strend-s);
5121 sv_setpvn(dstr, s, strend-s);
8ec5e241 5122 if (make_mortal)
a0d0e21e
LW		 5123 sv_2mortal(dstr);
5124 XPUSHs(dstr);
5125 iters++;
79072805 5126 }
a0d0e21e 5127 else if (!origlimit) {
b1dadf13 5128 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
a0d0e21e
LW		 5129 iters--, SP--;
5130 }
8ec5e241 5131
a0d0e21e 5132 if (realarray) {
8ec5e241 5133 if (!mg) {
1c0b011c
NIS		 5134 SWITCHSTACK(ary, oldstack);
5135 if (SvSMAGICAL(ary)) {
5136 PUTBACK;
5137 mg_set((SV*)ary);
5138 SPAGAIN;
5139 }
5140 if (gimme == G_ARRAY) {
5141 EXTEND(SP, iters);
5142 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5143 SP += iters;
5144 RETURN;
5145 }
8ec5e241 5146 }
1c0b011c 5147 else {
fb73857a 5148 PUTBACK;
8ec5e241 5149 ENTER;
864dbfa3 5150 call_method("PUSH",G_SCALAR|G_DISCARD);
8ec5e241 5151 LEAVE;
fb73857a 5152 SPAGAIN;
8ec5e241
NIS		 5153 if (gimme == G_ARRAY) {
5154 /* EXTEND should not be needed - we just popped them */
5155 EXTEND(SP, iters);
5156 for (i=0; i < iters; i++) {
5157 SV **svp = av_fetch(ary, i, FALSE);
3280af22 5158 PUSHs((svp) ? *svp : &PL_sv_undef);
8ec5e241 5159 }
1c0b011c
NIS		 5160 RETURN;
5161 }
a0d0e21e
LW		 5162 }
5163 }
5164 else {
5165 if (gimme == G_ARRAY)
5166 RETURN;
5167 }
5168 if (iters || !pm->op_pmreplroot) {
5169 GETTARGET;
5170 PUSHi(iters);
5171 RETURN;
5172 }
5173 RETPUSHUNDEF;
79072805 5174}
85e6fe83 5175
c0329465 5176#ifdef USE_THREADS
77a005ab 5177void
864dbfa3 5178Perl_unlock_condpair(pTHX_ void *svv)
c0329465
MB		 5179{
5180 dTHR;
5181 MAGIC *mg = mg_find((SV*)svv, 'm');
8ec5e241 5182
c0329465 5183 if (!mg)
cea2e8a9 5184 Perl_croak(aTHX_ "panic: unlock_condpair unlocking non-mutex");
c0329465
MB		 5185 MUTEX_LOCK(MgMUTEXP(mg));
5186 if (MgOWNER(mg) != thr)
cea2e8a9 5187 Perl_croak(aTHX_ "panic: unlock_condpair unlocking mutex that we don't own");
c0329465
MB		 5188 MgOWNER(mg) = 0;
5189 COND_SIGNAL(MgOWNERCONDP(mg));
8b73bbec 5190 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
bc1f4c86 5191 (unsigned long)thr, (unsigned long)svv);)
c0329465
MB		 5192 MUTEX_UNLOCK(MgMUTEXP(mg));
5193}
5194#endif /* USE_THREADS */
5195
5196PP(pp_lock)
5197{
4e35701f 5198 djSP;
c0329465 5199 dTOPss;
e55aaa0e
MB		 5200 SV *retsv = sv;
5201#ifdef USE_THREADS
c0329465 5202 MAGIC *mg;
8ec5e241 5203
c0329465
MB		 5204 if (SvROK(sv))
5205 sv = SvRV(sv);
5206
5207 mg = condpair_magic(sv);
5208 MUTEX_LOCK(MgMUTEXP(mg));
5209 if (MgOWNER(mg) == thr)
5210 MUTEX_UNLOCK(MgMUTEXP(mg));
5211 else {
5212 while (MgOWNER(mg))
5213 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
5214 MgOWNER(mg) = thr;
8b73bbec 5215 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
bc1f4c86 5216 (unsigned long)thr, (unsigned long)sv);)
c0329465 5217 MUTEX_UNLOCK(MgMUTEXP(mg));
51371543 5218 SAVEDESTRUCTOR(Perl_unlock_condpair, sv);
c0329465
MB		 5219 }
5220#endif /* USE_THREADS */
e55aaa0e
MB		 5221 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5222 || SvTYPE(retsv) == SVt_PVCV) {
5223 retsv = refto(retsv);
5224 }
5225 SETs(retsv);
c0329465
MB		 5226 RETURN;
5227}
a863c7d1 5228
2faa37cc 5229PP(pp_threadsv)
a863c7d1 5230{
12f917ad 5231 djSP;
57d3b86d 5232#ifdef USE_THREADS
924508f0 5233 EXTEND(SP, 1);
533c011a
NIS		 5234 if (PL_op->op_private & OPpLVAL_INTRO)
5235 PUSHs(*save_threadsv(PL_op->op_targ));
554b3eca 5236 else
533c011a 5237 PUSHs(THREADSV(PL_op->op_targ));
fdb47d66 5238 RETURN;
a863c7d1 5239#else
cea2e8a9 5240 DIE(aTHX_ "tried to access per-thread data in non-threaded perl");
a863c7d1 5241#endif /* USE_THREADS */
a863c7d1 5242}
Unnamed repository; edit this file 'description' to name the repository.