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