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