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