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