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