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