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