4637 lines
90 KiB
C
4637 lines
90 KiB
C
/* pp.c
|
|
*
|
|
* Copyright (c) 1991-1999, Larry Wall
|
|
*
|
|
* You may distribute under the terms of either the GNU General Public
|
|
* License or the Artistic License, as specified in the README file.
|
|
*
|
|
*/
|
|
|
|
/*
|
|
* "It's a big house this, and very peculiar. Always a bit more to discover,
|
|
* and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
|
|
*/
|
|
|
|
#include "EXTERN.h"
|
|
#include "perl.h"
|
|
|
|
/*
|
|
* The compiler on Concurrent CX/UX systems has a subtle bug which only
|
|
* seems to show up when compiling pp.c - it generates the wrong double
|
|
* precision constant value for (double)UV_MAX when used inline in the body
|
|
* of the code below, so this makes a static variable up front (which the
|
|
* compiler seems to get correct) and uses it in place of UV_MAX below.
|
|
*/
|
|
#ifdef CXUX_BROKEN_CONSTANT_CONVERT
|
|
static double UV_MAX_cxux = ((double)UV_MAX);
|
|
#endif
|
|
|
|
/*
|
|
* Types used in bitwise operations.
|
|
*
|
|
* Normally we'd just use IV and UV. However, some hardware and
|
|
* software combinations (e.g. Alpha and current OSF/1) don't have a
|
|
* floating-point type to use for NV that has adequate bits to fully
|
|
* hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
|
|
*
|
|
* It just so happens that "int" is the right size almost everywhere.
|
|
*/
|
|
typedef int IBW;
|
|
typedef unsigned UBW;
|
|
|
|
/*
|
|
* Mask used after bitwise operations.
|
|
*
|
|
* There is at least one realm (Cray word machines) that doesn't
|
|
* have an integral type (except char) small enough to be represented
|
|
* in a double without loss; that is, it has no 32-bit type.
|
|
*/
|
|
#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
|
|
# define BW_BITS 32
|
|
# define BW_MASK ((1 << BW_BITS) - 1)
|
|
# define BW_SIGN (1 << (BW_BITS - 1))
|
|
# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
|
|
# define BWu(u) ((u) & BW_MASK)
|
|
#else
|
|
# define BWi(i) (i)
|
|
# define BWu(u) (u)
|
|
#endif
|
|
|
|
/*
|
|
* Offset for integer pack/unpack.
|
|
*
|
|
* On architectures where I16 and I32 aren't really 16 and 32 bits,
|
|
* which for now are all Crays, pack and unpack have to play games.
|
|
*/
|
|
|
|
/*
|
|
* These values are required for portability of pack() output.
|
|
* If they're not right on your machine, then pack() and unpack()
|
|
* wouldn't work right anyway; you'll need to apply the Cray hack.
|
|
* (I'd like to check them with #if, but you can't use sizeof() in
|
|
* the preprocessor.) --???
|
|
*/
|
|
/*
|
|
The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
|
|
defines are now in config.h. --Andy Dougherty April 1998
|
|
*/
|
|
#define SIZE16 2
|
|
#define SIZE32 4
|
|
|
|
#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
|
|
# if BYTEORDER == 0x12345678
|
|
# define OFF16(p) (char*)(p)
|
|
# define OFF32(p) (char*)(p)
|
|
# else
|
|
# if BYTEORDER == 0x87654321
|
|
# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
|
|
# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
|
|
# else
|
|
}}}} bad cray byte order
|
|
# endif
|
|
# endif
|
|
# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
|
|
# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
|
|
# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
|
|
# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
|
|
#else
|
|
# define COPY16(s,p) Copy(s, p, SIZE16, char)
|
|
# define COPY32(s,p) Copy(s, p, SIZE32, char)
|
|
# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
|
|
# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
|
|
#endif
|
|
|
|
#ifndef PERL_OBJECT
|
|
static void doencodes _((SV* sv, char* s, I32 len));
|
|
static SV* refto _((SV* sv));
|
|
static U32 seed _((void));
|
|
static bool srand_called = FALSE;
|
|
#endif
|
|
|
|
|
|
/* variations on pp_null */
|
|
|
|
#ifdef I_UNISTD
|
|
#include <unistd.h>
|
|
#endif
|
|
|
|
/* XXX I can't imagine anyone who doesn't have this actually _needs_
|
|
it, since pid_t is an integral type.
|
|
--AD 2/20/1998
|
|
*/
|
|
#ifdef NEED_GETPID_PROTO
|
|
extern Pid_t getpid (void);
|
|
#endif
|
|
|
|
PP(pp_stub)
|
|
{
|
|
djSP;
|
|
if (GIMME_V == G_SCALAR)
|
|
XPUSHs(&PL_sv_undef);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_scalar)
|
|
{
|
|
return NORMAL;
|
|
}
|
|
|
|
/* Pushy stuff. */
|
|
|
|
PP(pp_padav)
|
|
{
|
|
djSP; dTARGET;
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
SAVECLEARSV(PL_curpad[PL_op->op_targ]);
|
|
EXTEND(SP, 1);
|
|
if (PL_op->op_flags & OPf_REF) {
|
|
PUSHs(TARG);
|
|
RETURN;
|
|
}
|
|
if (GIMME == G_ARRAY) {
|
|
I32 maxarg = AvFILL((AV*)TARG) + 1;
|
|
EXTEND(SP, maxarg);
|
|
if (SvMAGICAL(TARG)) {
|
|
U32 i;
|
|
for (i=0; i < maxarg; i++) {
|
|
SV **svp = av_fetch((AV*)TARG, i, FALSE);
|
|
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
|
|
}
|
|
}
|
|
else {
|
|
Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
|
|
}
|
|
SP += maxarg;
|
|
}
|
|
else {
|
|
SV* sv = sv_newmortal();
|
|
I32 maxarg = AvFILL((AV*)TARG) + 1;
|
|
sv_setiv(sv, maxarg);
|
|
PUSHs(sv);
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_padhv)
|
|
{
|
|
djSP; dTARGET;
|
|
I32 gimme;
|
|
|
|
XPUSHs(TARG);
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
SAVECLEARSV(PL_curpad[PL_op->op_targ]);
|
|
if (PL_op->op_flags & OPf_REF)
|
|
RETURN;
|
|
gimme = GIMME_V;
|
|
if (gimme == G_ARRAY) {
|
|
RETURNOP(do_kv(ARGS));
|
|
}
|
|
else if (gimme == G_SCALAR) {
|
|
SV* sv = sv_newmortal();
|
|
if (HvFILL((HV*)TARG))
|
|
sv_setpvf(sv, "%ld/%ld",
|
|
(long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
|
|
else
|
|
sv_setiv(sv, 0);
|
|
SETs(sv);
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_padany)
|
|
{
|
|
DIE("NOT IMPL LINE %d",__LINE__);
|
|
}
|
|
|
|
/* Translations. */
|
|
|
|
PP(pp_rv2gv)
|
|
{
|
|
djSP; dTOPss;
|
|
|
|
if (SvROK(sv)) {
|
|
wasref:
|
|
sv = SvRV(sv);
|
|
if (SvTYPE(sv) == SVt_PVIO) {
|
|
GV *gv = (GV*) sv_newmortal();
|
|
gv_init(gv, 0, "", 0, 0);
|
|
GvIOp(gv) = (IO *)sv;
|
|
(void)SvREFCNT_inc(sv);
|
|
sv = (SV*) gv;
|
|
} else if (SvTYPE(sv) != SVt_PVGV)
|
|
DIE("Not a GLOB reference");
|
|
}
|
|
else {
|
|
if (SvTYPE(sv) != SVt_PVGV) {
|
|
char *sym;
|
|
STRLEN n_a;
|
|
|
|
if (SvGMAGICAL(sv)) {
|
|
mg_get(sv);
|
|
if (SvROK(sv))
|
|
goto wasref;
|
|
}
|
|
if (!SvOK(sv)) {
|
|
if (PL_op->op_flags & OPf_REF ||
|
|
PL_op->op_private & HINT_STRICT_REFS)
|
|
DIE(no_usym, "a symbol");
|
|
if (PL_dowarn)
|
|
warn(warn_uninit);
|
|
RETSETUNDEF;
|
|
}
|
|
sym = SvPV(sv, n_a);
|
|
if (PL_op->op_private & HINT_STRICT_REFS)
|
|
DIE(no_symref, sym, "a symbol");
|
|
sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
|
|
}
|
|
}
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
|
|
SETs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_rv2sv)
|
|
{
|
|
djSP; dTOPss;
|
|
|
|
if (SvROK(sv)) {
|
|
wasref:
|
|
sv = SvRV(sv);
|
|
switch (SvTYPE(sv)) {
|
|
case SVt_PVAV:
|
|
case SVt_PVHV:
|
|
case SVt_PVCV:
|
|
DIE("Not a SCALAR reference");
|
|
}
|
|
}
|
|
else {
|
|
GV *gv = (GV*)sv;
|
|
char *sym;
|
|
STRLEN n_a;
|
|
|
|
if (SvTYPE(gv) != SVt_PVGV) {
|
|
if (SvGMAGICAL(sv)) {
|
|
mg_get(sv);
|
|
if (SvROK(sv))
|
|
goto wasref;
|
|
}
|
|
if (!SvOK(sv)) {
|
|
if (PL_op->op_flags & OPf_REF ||
|
|
PL_op->op_private & HINT_STRICT_REFS)
|
|
DIE(no_usym, "a SCALAR");
|
|
if (PL_dowarn)
|
|
warn(warn_uninit);
|
|
RETSETUNDEF;
|
|
}
|
|
sym = SvPV(sv, n_a);
|
|
if (PL_op->op_private & HINT_STRICT_REFS)
|
|
DIE(no_symref, sym, "a SCALAR");
|
|
gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
|
|
}
|
|
sv = GvSV(gv);
|
|
}
|
|
if (PL_op->op_flags & OPf_MOD) {
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
sv = save_scalar((GV*)TOPs);
|
|
else if (PL_op->op_private & OPpDEREF)
|
|
vivify_ref(sv, PL_op->op_private & OPpDEREF);
|
|
}
|
|
SETs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_av2arylen)
|
|
{
|
|
djSP;
|
|
AV *av = (AV*)TOPs;
|
|
SV *sv = AvARYLEN(av);
|
|
if (!sv) {
|
|
AvARYLEN(av) = sv = NEWSV(0,0);
|
|
sv_upgrade(sv, SVt_IV);
|
|
sv_magic(sv, (SV*)av, '#', Nullch, 0);
|
|
}
|
|
SETs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_pos)
|
|
{
|
|
djSP; dTARGET; dPOPss;
|
|
|
|
if (PL_op->op_flags & OPf_MOD) {
|
|
if (SvTYPE(TARG) < SVt_PVLV) {
|
|
sv_upgrade(TARG, SVt_PVLV);
|
|
sv_magic(TARG, Nullsv, '.', Nullch, 0);
|
|
}
|
|
|
|
LvTYPE(TARG) = '.';
|
|
if (LvTARG(TARG) != sv) {
|
|
if (LvTARG(TARG))
|
|
SvREFCNT_dec(LvTARG(TARG));
|
|
LvTARG(TARG) = SvREFCNT_inc(sv);
|
|
}
|
|
PUSHs(TARG); /* no SvSETMAGIC */
|
|
RETURN;
|
|
}
|
|
else {
|
|
MAGIC* mg;
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
|
|
mg = mg_find(sv, 'g');
|
|
if (mg && mg->mg_len >= 0) {
|
|
PUSHi(mg->mg_len + PL_curcop->cop_arybase);
|
|
RETURN;
|
|
}
|
|
}
|
|
RETPUSHUNDEF;
|
|
}
|
|
}
|
|
|
|
PP(pp_rv2cv)
|
|
{
|
|
djSP;
|
|
GV *gv;
|
|
HV *stash;
|
|
|
|
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
|
|
/* (But not in defined().) */
|
|
CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
|
|
if (cv) {
|
|
if (CvCLONE(cv))
|
|
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
|
|
}
|
|
else
|
|
cv = (CV*)&PL_sv_undef;
|
|
SETs((SV*)cv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_prototype)
|
|
{
|
|
djSP;
|
|
CV *cv;
|
|
HV *stash;
|
|
GV *gv;
|
|
SV *ret;
|
|
|
|
ret = &PL_sv_undef;
|
|
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
|
|
char *s = SvPVX(TOPs);
|
|
if (strnEQ(s, "CORE::", 6)) {
|
|
int code;
|
|
|
|
code = keyword(s + 6, SvCUR(TOPs) - 6);
|
|
if (code < 0) { /* Overridable. */
|
|
#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
|
|
int i = 0, n = 0, seen_question = 0;
|
|
I32 oa;
|
|
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
|
|
|
|
while (i < MAXO) { /* The slow way. */
|
|
if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
|
|
goto found;
|
|
i++;
|
|
}
|
|
goto nonesuch; /* Should not happen... */
|
|
found:
|
|
oa = opargs[i] >> OASHIFT;
|
|
while (oa) {
|
|
if (oa & OA_OPTIONAL) {
|
|
seen_question = 1;
|
|
str[n++] = ';';
|
|
} else if (seen_question)
|
|
goto set; /* XXXX system, exec */
|
|
if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
|
|
&& (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
|
|
str[n++] = '\\';
|
|
}
|
|
/* What to do with R ((un)tie, tied, (sys)read, recv)? */
|
|
str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
|
|
oa = oa >> 4;
|
|
}
|
|
str[n++] = '\0';
|
|
ret = sv_2mortal(newSVpv(str, n - 1));
|
|
} else if (code) /* Non-Overridable */
|
|
goto set;
|
|
else { /* None such */
|
|
nonesuch:
|
|
croak("Cannot find an opnumber for \"%s\"", s+6);
|
|
}
|
|
}
|
|
}
|
|
cv = sv_2cv(TOPs, &stash, &gv, FALSE);
|
|
if (cv && SvPOK(cv))
|
|
ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
|
|
set:
|
|
SETs(ret);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_anoncode)
|
|
{
|
|
djSP;
|
|
CV* cv = (CV*)PL_curpad[PL_op->op_targ];
|
|
if (CvCLONE(cv))
|
|
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
|
|
EXTEND(SP,1);
|
|
PUSHs((SV*)cv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_srefgen)
|
|
{
|
|
djSP;
|
|
*SP = refto(*SP);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_refgen)
|
|
{
|
|
djSP; dMARK;
|
|
if (GIMME != G_ARRAY) {
|
|
if (++MARK <= SP)
|
|
*MARK = *SP;
|
|
else
|
|
*MARK = &PL_sv_undef;
|
|
*MARK = refto(*MARK);
|
|
SP = MARK;
|
|
RETURN;
|
|
}
|
|
EXTEND_MORTAL(SP - MARK);
|
|
while (++MARK <= SP)
|
|
*MARK = refto(*MARK);
|
|
RETURN;
|
|
}
|
|
|
|
STATIC SV*
|
|
refto(SV *sv)
|
|
{
|
|
SV* rv;
|
|
|
|
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
|
|
if (LvTARGLEN(sv))
|
|
vivify_defelem(sv);
|
|
if (!(sv = LvTARG(sv)))
|
|
sv = &PL_sv_undef;
|
|
}
|
|
else if (SvPADTMP(sv))
|
|
sv = newSVsv(sv);
|
|
else {
|
|
SvTEMP_off(sv);
|
|
(void)SvREFCNT_inc(sv);
|
|
}
|
|
rv = sv_newmortal();
|
|
sv_upgrade(rv, SVt_RV);
|
|
SvRV(rv) = sv;
|
|
SvROK_on(rv);
|
|
return rv;
|
|
}
|
|
|
|
PP(pp_ref)
|
|
{
|
|
djSP; dTARGET;
|
|
SV *sv;
|
|
char *pv;
|
|
|
|
sv = POPs;
|
|
|
|
if (sv && SvGMAGICAL(sv))
|
|
mg_get(sv);
|
|
|
|
if (!sv || !SvROK(sv))
|
|
RETPUSHNO;
|
|
|
|
sv = SvRV(sv);
|
|
pv = sv_reftype(sv,TRUE);
|
|
PUSHp(pv, strlen(pv));
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_bless)
|
|
{
|
|
djSP;
|
|
HV *stash;
|
|
|
|
if (MAXARG == 1)
|
|
stash = PL_curcop->cop_stash;
|
|
else {
|
|
SV *ssv = POPs;
|
|
STRLEN len;
|
|
char *ptr = SvPV(ssv,len);
|
|
if (PL_dowarn && len == 0)
|
|
warn("Explicit blessing to '' (assuming package main)");
|
|
stash = gv_stashpvn(ptr, len, TRUE);
|
|
}
|
|
|
|
(void)sv_bless(TOPs, stash);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_gelem)
|
|
{
|
|
GV *gv;
|
|
SV *sv;
|
|
SV *tmpRef;
|
|
char *elem;
|
|
djSP;
|
|
STRLEN n_a;
|
|
|
|
sv = POPs;
|
|
elem = SvPV(sv, n_a);
|
|
gv = (GV*)POPs;
|
|
tmpRef = Nullsv;
|
|
sv = Nullsv;
|
|
switch (elem ? *elem : '\0')
|
|
{
|
|
case 'A':
|
|
if (strEQ(elem, "ARRAY"))
|
|
tmpRef = (SV*)GvAV(gv);
|
|
break;
|
|
case 'C':
|
|
if (strEQ(elem, "CODE"))
|
|
tmpRef = (SV*)GvCVu(gv);
|
|
break;
|
|
case 'F':
|
|
if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
|
|
tmpRef = (SV*)GvIOp(gv);
|
|
break;
|
|
case 'G':
|
|
if (strEQ(elem, "GLOB"))
|
|
tmpRef = (SV*)gv;
|
|
break;
|
|
case 'H':
|
|
if (strEQ(elem, "HASH"))
|
|
tmpRef = (SV*)GvHV(gv);
|
|
break;
|
|
case 'I':
|
|
if (strEQ(elem, "IO"))
|
|
tmpRef = (SV*)GvIOp(gv);
|
|
break;
|
|
case 'N':
|
|
if (strEQ(elem, "NAME"))
|
|
sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
|
|
break;
|
|
case 'P':
|
|
if (strEQ(elem, "PACKAGE"))
|
|
sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
|
|
break;
|
|
case 'S':
|
|
if (strEQ(elem, "SCALAR"))
|
|
tmpRef = GvSV(gv);
|
|
break;
|
|
}
|
|
if (tmpRef)
|
|
sv = newRV(tmpRef);
|
|
if (sv)
|
|
sv_2mortal(sv);
|
|
else
|
|
sv = &PL_sv_undef;
|
|
XPUSHs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
/* Pattern matching */
|
|
|
|
PP(pp_study)
|
|
{
|
|
djSP; dPOPss;
|
|
register UNOP *unop = cUNOP;
|
|
register unsigned char *s;
|
|
register I32 pos;
|
|
register I32 ch;
|
|
register I32 *sfirst;
|
|
register I32 *snext;
|
|
STRLEN len;
|
|
|
|
if (sv == PL_lastscream) {
|
|
if (SvSCREAM(sv))
|
|
RETPUSHYES;
|
|
}
|
|
else {
|
|
if (PL_lastscream) {
|
|
SvSCREAM_off(PL_lastscream);
|
|
SvREFCNT_dec(PL_lastscream);
|
|
}
|
|
PL_lastscream = SvREFCNT_inc(sv);
|
|
}
|
|
|
|
s = (unsigned char*)(SvPV(sv, len));
|
|
pos = len;
|
|
if (pos <= 0)
|
|
RETPUSHNO;
|
|
if (pos > PL_maxscream) {
|
|
if (PL_maxscream < 0) {
|
|
PL_maxscream = pos + 80;
|
|
New(301, PL_screamfirst, 256, I32);
|
|
New(302, PL_screamnext, PL_maxscream, I32);
|
|
}
|
|
else {
|
|
PL_maxscream = pos + pos / 4;
|
|
Renew(PL_screamnext, PL_maxscream, I32);
|
|
}
|
|
}
|
|
|
|
sfirst = PL_screamfirst;
|
|
snext = PL_screamnext;
|
|
|
|
if (!sfirst || !snext)
|
|
DIE("do_study: out of memory");
|
|
|
|
for (ch = 256; ch; --ch)
|
|
*sfirst++ = -1;
|
|
sfirst -= 256;
|
|
|
|
while (--pos >= 0) {
|
|
ch = s[pos];
|
|
if (sfirst[ch] >= 0)
|
|
snext[pos] = sfirst[ch] - pos;
|
|
else
|
|
snext[pos] = -pos;
|
|
sfirst[ch] = pos;
|
|
}
|
|
|
|
SvSCREAM_on(sv);
|
|
sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
|
|
RETPUSHYES;
|
|
}
|
|
|
|
PP(pp_trans)
|
|
{
|
|
djSP; dTARG;
|
|
SV *sv;
|
|
|
|
if (PL_op->op_flags & OPf_STACKED)
|
|
sv = POPs;
|
|
else {
|
|
sv = DEFSV;
|
|
EXTEND(SP,1);
|
|
}
|
|
TARG = sv_newmortal();
|
|
PUSHi(do_trans(sv, PL_op));
|
|
RETURN;
|
|
}
|
|
|
|
/* Lvalue operators. */
|
|
|
|
PP(pp_schop)
|
|
{
|
|
djSP; dTARGET;
|
|
do_chop(TARG, TOPs);
|
|
SETTARG;
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_chop)
|
|
{
|
|
djSP; dMARK; dTARGET;
|
|
while (SP > MARK)
|
|
do_chop(TARG, POPs);
|
|
PUSHTARG;
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_schomp)
|
|
{
|
|
djSP; dTARGET;
|
|
SETi(do_chomp(TOPs));
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_chomp)
|
|
{
|
|
djSP; dMARK; dTARGET;
|
|
register I32 count = 0;
|
|
|
|
while (SP > MARK)
|
|
count += do_chomp(POPs);
|
|
PUSHi(count);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_defined)
|
|
{
|
|
djSP;
|
|
register SV* sv;
|
|
|
|
sv = POPs;
|
|
if (!sv || !SvANY(sv))
|
|
RETPUSHNO;
|
|
switch (SvTYPE(sv)) {
|
|
case SVt_PVAV:
|
|
if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
|
|
RETPUSHYES;
|
|
break;
|
|
case SVt_PVHV:
|
|
if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv,'P')))
|
|
RETPUSHYES;
|
|
break;
|
|
case SVt_PVCV:
|
|
if (CvROOT(sv) || CvXSUB(sv))
|
|
RETPUSHYES;
|
|
break;
|
|
default:
|
|
if (SvGMAGICAL(sv))
|
|
mg_get(sv);
|
|
if (SvOK(sv))
|
|
RETPUSHYES;
|
|
}
|
|
RETPUSHNO;
|
|
}
|
|
|
|
PP(pp_undef)
|
|
{
|
|
djSP;
|
|
SV *sv;
|
|
|
|
if (!PL_op->op_private) {
|
|
EXTEND(SP, 1);
|
|
RETPUSHUNDEF;
|
|
}
|
|
|
|
sv = POPs;
|
|
if (!sv)
|
|
RETPUSHUNDEF;
|
|
|
|
if (SvTHINKFIRST(sv)) {
|
|
if (SvREADONLY(sv)) {
|
|
dTHR;
|
|
if (PL_curcop != &PL_compiling)
|
|
croak(no_modify);
|
|
}
|
|
if (SvROK(sv))
|
|
sv_unref(sv);
|
|
}
|
|
|
|
switch (SvTYPE(sv)) {
|
|
case SVt_NULL:
|
|
break;
|
|
case SVt_PVAV:
|
|
av_undef((AV*)sv);
|
|
break;
|
|
case SVt_PVHV:
|
|
hv_undef((HV*)sv);
|
|
break;
|
|
case SVt_PVCV:
|
|
if (PL_dowarn && cv_const_sv((CV*)sv))
|
|
warn("Constant subroutine %s undefined",
|
|
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
|
|
/* FALL THROUGH */
|
|
case SVt_PVFM:
|
|
{ GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
|
|
cv_undef((CV*)sv);
|
|
CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
|
|
break;
|
|
case SVt_PVGV:
|
|
if (SvFAKE(sv))
|
|
SvSetMagicSV(sv, &PL_sv_undef);
|
|
else {
|
|
GP *gp;
|
|
gp_free((GV*)sv);
|
|
Newz(602, gp, 1, GP);
|
|
GvGP(sv) = gp_ref(gp);
|
|
GvSV(sv) = NEWSV(72,0);
|
|
GvLINE(sv) = PL_curcop->cop_line;
|
|
GvEGV(sv) = (GV*)sv;
|
|
GvMULTI_on(sv);
|
|
}
|
|
break;
|
|
default:
|
|
if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
|
|
(void)SvOOK_off(sv);
|
|
Safefree(SvPVX(sv));
|
|
SvPV_set(sv, Nullch);
|
|
SvLEN_set(sv, 0);
|
|
}
|
|
(void)SvOK_off(sv);
|
|
SvSETMAGIC(sv);
|
|
}
|
|
|
|
RETPUSHUNDEF;
|
|
}
|
|
|
|
PP(pp_predec)
|
|
{
|
|
djSP;
|
|
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
|
|
croak(no_modify);
|
|
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
|
|
SvIVX(TOPs) != IV_MIN)
|
|
{
|
|
--SvIVX(TOPs);
|
|
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
|
|
}
|
|
else
|
|
sv_dec(TOPs);
|
|
SvSETMAGIC(TOPs);
|
|
return NORMAL;
|
|
}
|
|
|
|
PP(pp_postinc)
|
|
{
|
|
djSP; dTARGET;
|
|
if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
|
|
croak(no_modify);
|
|
sv_setsv(TARG, TOPs);
|
|
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
|
|
SvIVX(TOPs) != IV_MAX)
|
|
{
|
|
++SvIVX(TOPs);
|
|
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
|
|
}
|
|
else
|
|
sv_inc(TOPs);
|
|
SvSETMAGIC(TOPs);
|
|
if (!SvOK(TARG))
|
|
sv_setiv(TARG, 0);
|
|
SETs(TARG);
|
|
return NORMAL;
|
|
}
|
|
|
|
PP(pp_postdec)
|
|
{
|
|
djSP; dTARGET;
|
|
if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
|
|
croak(no_modify);
|
|
sv_setsv(TARG, TOPs);
|
|
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
|
|
SvIVX(TOPs) != IV_MIN)
|
|
{
|
|
--SvIVX(TOPs);
|
|
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
|
|
}
|
|
else
|
|
sv_dec(TOPs);
|
|
SvSETMAGIC(TOPs);
|
|
SETs(TARG);
|
|
return NORMAL;
|
|
}
|
|
|
|
/* Ordinary operators. */
|
|
|
|
PP(pp_pow)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
|
|
{
|
|
dPOPTOPnnrl;
|
|
SETn( pow( left, right) );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_multiply)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
|
|
{
|
|
dPOPTOPnnrl;
|
|
SETn( left * right );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_divide)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
|
|
{
|
|
dPOPPOPnnrl;
|
|
double value;
|
|
if (right == 0.0)
|
|
DIE("Illegal division by zero");
|
|
#ifdef SLOPPYDIVIDE
|
|
/* insure that 20./5. == 4. */
|
|
{
|
|
IV k;
|
|
if ((double)I_V(left) == left &&
|
|
(double)I_V(right) == right &&
|
|
(k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
|
|
value = k;
|
|
} else {
|
|
value = left / right;
|
|
}
|
|
}
|
|
#else
|
|
value = left / right;
|
|
#endif
|
|
PUSHn( value );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_modulo)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
|
|
{
|
|
UV left;
|
|
UV right;
|
|
bool left_neg;
|
|
bool right_neg;
|
|
UV ans;
|
|
|
|
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
|
|
IV i = SvIVX(POPs);
|
|
right = (right_neg = (i < 0)) ? -i : i;
|
|
}
|
|
else {
|
|
double n = POPn;
|
|
right = U_V((right_neg = (n < 0)) ? -n : n);
|
|
}
|
|
|
|
if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
|
|
IV i = SvIVX(POPs);
|
|
left = (left_neg = (i < 0)) ? -i : i;
|
|
}
|
|
else {
|
|
double n = POPn;
|
|
left = U_V((left_neg = (n < 0)) ? -n : n);
|
|
}
|
|
|
|
if (!right)
|
|
DIE("Illegal modulus zero");
|
|
|
|
ans = left % right;
|
|
if ((left_neg != right_neg) && ans)
|
|
ans = right - ans;
|
|
if (right_neg) {
|
|
/* XXX may warn: unary minus operator applied to unsigned type */
|
|
/* could change -foo to be (~foo)+1 instead */
|
|
if (ans <= ~((UV)IV_MAX)+1)
|
|
sv_setiv(TARG, ~ans+1);
|
|
else
|
|
sv_setnv(TARG, -(double)ans);
|
|
}
|
|
else
|
|
sv_setuv(TARG, ans);
|
|
PUSHTARG;
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_repeat)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
|
|
{
|
|
register I32 count = POPi;
|
|
if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
|
|
dMARK;
|
|
I32 items = SP - MARK;
|
|
I32 max;
|
|
|
|
max = items * count;
|
|
MEXTEND(MARK, max);
|
|
if (count > 1) {
|
|
while (SP > MARK) {
|
|
if (*SP)
|
|
SvTEMP_off((*SP));
|
|
SP--;
|
|
}
|
|
MARK++;
|
|
repeatcpy((char*)(MARK + items), (char*)MARK,
|
|
items * sizeof(SV*), count - 1);
|
|
SP += max;
|
|
}
|
|
else if (count <= 0)
|
|
SP -= items;
|
|
}
|
|
else { /* Note: mark already snarfed by pp_list */
|
|
SV *tmpstr;
|
|
STRLEN len;
|
|
|
|
tmpstr = POPs;
|
|
if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
|
|
if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
|
|
DIE("Can't x= to readonly value");
|
|
if (SvROK(tmpstr))
|
|
sv_unref(tmpstr);
|
|
}
|
|
SvSetSV(TARG, tmpstr);
|
|
SvPV_force(TARG, len);
|
|
if (count != 1) {
|
|
if (count < 1)
|
|
SvCUR_set(TARG, 0);
|
|
else {
|
|
SvGROW(TARG, (count * len) + 1);
|
|
repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
|
|
SvCUR(TARG) *= count;
|
|
}
|
|
*SvEND(TARG) = '\0';
|
|
}
|
|
(void)SvPOK_only(TARG);
|
|
PUSHTARG;
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_subtract)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
|
|
{
|
|
dPOPTOPnnrl_ul;
|
|
SETn( left - right );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_left_shift)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
|
|
{
|
|
IBW shift = POPi;
|
|
if (PL_op->op_private & HINT_INTEGER) {
|
|
IBW i = TOPi;
|
|
i = BWi(i) << shift;
|
|
SETi(BWi(i));
|
|
}
|
|
else {
|
|
UBW u = TOPu;
|
|
u <<= shift;
|
|
SETu(BWu(u));
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_right_shift)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
|
|
{
|
|
IBW shift = POPi;
|
|
if (PL_op->op_private & HINT_INTEGER) {
|
|
IBW i = TOPi;
|
|
i = BWi(i) >> shift;
|
|
SETi(BWi(i));
|
|
}
|
|
else {
|
|
UBW u = TOPu;
|
|
u >>= shift;
|
|
SETu(BWu(u));
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_lt)
|
|
{
|
|
djSP; tryAMAGICbinSET(lt,0);
|
|
{
|
|
dPOPnv;
|
|
SETs(boolSV(TOPn < value));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_gt)
|
|
{
|
|
djSP; tryAMAGICbinSET(gt,0);
|
|
{
|
|
dPOPnv;
|
|
SETs(boolSV(TOPn > value));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_le)
|
|
{
|
|
djSP; tryAMAGICbinSET(le,0);
|
|
{
|
|
dPOPnv;
|
|
SETs(boolSV(TOPn <= value));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_ge)
|
|
{
|
|
djSP; tryAMAGICbinSET(ge,0);
|
|
{
|
|
dPOPnv;
|
|
SETs(boolSV(TOPn >= value));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_ne)
|
|
{
|
|
djSP; tryAMAGICbinSET(ne,0);
|
|
{
|
|
dPOPnv;
|
|
SETs(boolSV(TOPn != value));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_ncmp)
|
|
{
|
|
djSP; dTARGET; tryAMAGICbin(ncmp,0);
|
|
{
|
|
dPOPTOPnnrl;
|
|
I32 value;
|
|
|
|
if (left == right)
|
|
value = 0;
|
|
else if (left < right)
|
|
value = -1;
|
|
else if (left > right)
|
|
value = 1;
|
|
else {
|
|
SETs(&PL_sv_undef);
|
|
RETURN;
|
|
}
|
|
SETi(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_slt)
|
|
{
|
|
djSP; tryAMAGICbinSET(slt,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
int cmp = ((PL_op->op_private & OPpLOCALE)
|
|
? sv_cmp_locale(left, right)
|
|
: sv_cmp(left, right));
|
|
SETs(boolSV(cmp < 0));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_sgt)
|
|
{
|
|
djSP; tryAMAGICbinSET(sgt,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
int cmp = ((PL_op->op_private & OPpLOCALE)
|
|
? sv_cmp_locale(left, right)
|
|
: sv_cmp(left, right));
|
|
SETs(boolSV(cmp > 0));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_sle)
|
|
{
|
|
djSP; tryAMAGICbinSET(sle,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
int cmp = ((PL_op->op_private & OPpLOCALE)
|
|
? sv_cmp_locale(left, right)
|
|
: sv_cmp(left, right));
|
|
SETs(boolSV(cmp <= 0));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_sge)
|
|
{
|
|
djSP; tryAMAGICbinSET(sge,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
int cmp = ((PL_op->op_private & OPpLOCALE)
|
|
? sv_cmp_locale(left, right)
|
|
: sv_cmp(left, right));
|
|
SETs(boolSV(cmp >= 0));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_seq)
|
|
{
|
|
djSP; tryAMAGICbinSET(seq,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
SETs(boolSV(sv_eq(left, right)));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_sne)
|
|
{
|
|
djSP; tryAMAGICbinSET(sne,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
SETs(boolSV(!sv_eq(left, right)));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_scmp)
|
|
{
|
|
djSP; dTARGET; tryAMAGICbin(scmp,0);
|
|
{
|
|
dPOPTOPssrl;
|
|
int cmp = ((PL_op->op_private & OPpLOCALE)
|
|
? sv_cmp_locale(left, right)
|
|
: sv_cmp(left, right));
|
|
SETi( cmp );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_bit_and)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
|
|
{
|
|
dPOPTOPssrl;
|
|
if (SvNIOKp(left) || SvNIOKp(right)) {
|
|
if (PL_op->op_private & HINT_INTEGER) {
|
|
IBW value = SvIV(left) & SvIV(right);
|
|
SETi(BWi(value));
|
|
}
|
|
else {
|
|
UBW value = SvUV(left) & SvUV(right);
|
|
SETu(BWu(value));
|
|
}
|
|
}
|
|
else {
|
|
do_vop(PL_op->op_type, TARG, left, right);
|
|
SETTARG;
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_bit_xor)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
|
|
{
|
|
dPOPTOPssrl;
|
|
if (SvNIOKp(left) || SvNIOKp(right)) {
|
|
if (PL_op->op_private & HINT_INTEGER) {
|
|
IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
|
|
SETi(BWi(value));
|
|
}
|
|
else {
|
|
UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
|
|
SETu(BWu(value));
|
|
}
|
|
}
|
|
else {
|
|
do_vop(PL_op->op_type, TARG, left, right);
|
|
SETTARG;
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_bit_or)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
|
|
{
|
|
dPOPTOPssrl;
|
|
if (SvNIOKp(left) || SvNIOKp(right)) {
|
|
if (PL_op->op_private & HINT_INTEGER) {
|
|
IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
|
|
SETi(BWi(value));
|
|
}
|
|
else {
|
|
UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
|
|
SETu(BWu(value));
|
|
}
|
|
}
|
|
else {
|
|
do_vop(PL_op->op_type, TARG, left, right);
|
|
SETTARG;
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_negate)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(neg);
|
|
{
|
|
dTOPss;
|
|
if (SvGMAGICAL(sv))
|
|
mg_get(sv);
|
|
if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
|
|
SETi(-SvIVX(sv));
|
|
else if (SvNIOKp(sv))
|
|
SETn(-SvNV(sv));
|
|
else if (SvPOKp(sv)) {
|
|
STRLEN len;
|
|
char *s = SvPV(sv, len);
|
|
if (isIDFIRST(*s)) {
|
|
sv_setpvn(TARG, "-", 1);
|
|
sv_catsv(TARG, sv);
|
|
}
|
|
else if (*s == '+' || *s == '-') {
|
|
sv_setsv(TARG, sv);
|
|
*SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
|
|
}
|
|
else
|
|
sv_setnv(TARG, -SvNV(sv));
|
|
SETTARG;
|
|
}
|
|
else
|
|
SETn(-SvNV(sv));
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_not)
|
|
{
|
|
#ifdef OVERLOAD
|
|
djSP; tryAMAGICunSET(not);
|
|
#endif /* OVERLOAD */
|
|
*PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
|
|
return NORMAL;
|
|
}
|
|
|
|
PP(pp_complement)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(compl);
|
|
{
|
|
dTOPss;
|
|
if (SvNIOKp(sv)) {
|
|
if (PL_op->op_private & HINT_INTEGER) {
|
|
IBW value = ~SvIV(sv);
|
|
SETi(BWi(value));
|
|
}
|
|
else {
|
|
UBW value = ~SvUV(sv);
|
|
SETu(BWu(value));
|
|
}
|
|
}
|
|
else {
|
|
register char *tmps;
|
|
register long *tmpl;
|
|
register I32 anum;
|
|
STRLEN len;
|
|
|
|
SvSetSV(TARG, sv);
|
|
tmps = SvPV_force(TARG, len);
|
|
anum = len;
|
|
#ifdef LIBERAL
|
|
for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
|
|
*tmps = ~*tmps;
|
|
tmpl = (long*)tmps;
|
|
for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
|
|
*tmpl = ~*tmpl;
|
|
tmps = (char*)tmpl;
|
|
#endif
|
|
for ( ; anum > 0; anum--, tmps++)
|
|
*tmps = ~*tmps;
|
|
|
|
SETs(TARG);
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
/* integer versions of some of the above */
|
|
|
|
PP(pp_i_multiply)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETi( left * right );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_divide)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
|
|
{
|
|
dPOPiv;
|
|
if (value == 0)
|
|
DIE("Illegal division by zero");
|
|
value = POPi / value;
|
|
PUSHi( value );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_modulo)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
|
|
{
|
|
dPOPTOPiirl;
|
|
if (!right)
|
|
DIE("Illegal modulus zero");
|
|
SETi( left % right );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_add)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETi( left + right );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_subtract)
|
|
{
|
|
djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETi( left - right );
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_lt)
|
|
{
|
|
djSP; tryAMAGICbinSET(lt,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETs(boolSV(left < right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_gt)
|
|
{
|
|
djSP; tryAMAGICbinSET(gt,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETs(boolSV(left > right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_le)
|
|
{
|
|
djSP; tryAMAGICbinSET(le,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETs(boolSV(left <= right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_ge)
|
|
{
|
|
djSP; tryAMAGICbinSET(ge,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETs(boolSV(left >= right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_eq)
|
|
{
|
|
djSP; tryAMAGICbinSET(eq,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETs(boolSV(left == right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_ne)
|
|
{
|
|
djSP; tryAMAGICbinSET(ne,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
SETs(boolSV(left != right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_ncmp)
|
|
{
|
|
djSP; dTARGET; tryAMAGICbin(ncmp,0);
|
|
{
|
|
dPOPTOPiirl;
|
|
I32 value;
|
|
|
|
if (left > right)
|
|
value = 1;
|
|
else if (left < right)
|
|
value = -1;
|
|
else
|
|
value = 0;
|
|
SETi(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_i_negate)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(neg);
|
|
SETi(-TOPi);
|
|
RETURN;
|
|
}
|
|
|
|
/* High falutin' math. */
|
|
|
|
PP(pp_atan2)
|
|
{
|
|
djSP; dTARGET; tryAMAGICbin(atan2,0);
|
|
{
|
|
dPOPTOPnnrl;
|
|
SETn(atan2(left, right));
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_sin)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(sin);
|
|
{
|
|
double value;
|
|
value = POPn;
|
|
value = sin(value);
|
|
XPUSHn(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_cos)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(cos);
|
|
{
|
|
double value;
|
|
value = POPn;
|
|
value = cos(value);
|
|
XPUSHn(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
/* Support Configure command-line overrides for rand() functions.
|
|
After 5.005, perhaps we should replace this by Configure support
|
|
for drand48(), random(), or rand(). For 5.005, though, maintain
|
|
compatibility by calling rand() but allow the user to override it.
|
|
See INSTALL for details. --Andy Dougherty 15 July 1998
|
|
*/
|
|
#ifndef my_rand
|
|
# define my_rand rand
|
|
#endif
|
|
#ifndef my_srand
|
|
# define my_srand srand
|
|
#endif
|
|
|
|
PP(pp_rand)
|
|
{
|
|
djSP; dTARGET;
|
|
double value;
|
|
if (MAXARG < 1)
|
|
value = 1.0;
|
|
else
|
|
value = POPn;
|
|
if (value == 0.0)
|
|
value = 1.0;
|
|
if (!srand_called) {
|
|
(void)my_srand((unsigned)seed());
|
|
srand_called = TRUE;
|
|
}
|
|
#if RANDBITS == 31
|
|
value = my_rand() * value / 2147483648.0;
|
|
#else
|
|
#if RANDBITS == 16
|
|
value = my_rand() * value / 65536.0;
|
|
#else
|
|
#if RANDBITS == 15
|
|
value = my_rand() * value / 32768.0;
|
|
#else
|
|
value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
|
|
#endif
|
|
#endif
|
|
#endif
|
|
XPUSHn(value);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_srand)
|
|
{
|
|
djSP;
|
|
UV anum;
|
|
if (MAXARG < 1)
|
|
anum = seed();
|
|
else
|
|
anum = POPu;
|
|
(void)my_srand((unsigned)anum);
|
|
srand_called = TRUE;
|
|
EXTEND(SP, 1);
|
|
RETPUSHYES;
|
|
}
|
|
|
|
STATIC U32
|
|
seed(void)
|
|
{
|
|
/*
|
|
* This is really just a quick hack which grabs various garbage
|
|
* values. It really should be a real hash algorithm which
|
|
* spreads the effect of every input bit onto every output bit,
|
|
* if someone who knows about such tings would bother to write it.
|
|
* Might be a good idea to add that function to CORE as well.
|
|
* No numbers below come from careful analysis or anyting here,
|
|
* except they are primes and SEED_C1 > 1E6 to get a full-width
|
|
* value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
|
|
* probably be bigger too.
|
|
*/
|
|
#if RANDBITS > 16
|
|
# define SEED_C1 1000003
|
|
#define SEED_C4 73819
|
|
#else
|
|
# define SEED_C1 25747
|
|
#define SEED_C4 20639
|
|
#endif
|
|
#define SEED_C2 3
|
|
#define SEED_C3 269
|
|
#define SEED_C5 26107
|
|
|
|
dTHR;
|
|
#ifndef PERL_NO_DEV_RANDOM
|
|
int fd;
|
|
#endif
|
|
U32 u;
|
|
#ifdef VMS
|
|
# include <starlet.h>
|
|
/* when[] = (low 32 bits, high 32 bits) of time since epoch
|
|
* in 100-ns units, typically incremented ever 10 ms. */
|
|
unsigned int when[2];
|
|
#else
|
|
# ifdef HAS_GETTIMEOFDAY
|
|
struct timeval when;
|
|
# else
|
|
Time_t when;
|
|
# endif
|
|
#endif
|
|
|
|
/* This test is an escape hatch, this symbol isn't set by Configure. */
|
|
#ifndef PERL_NO_DEV_RANDOM
|
|
#ifndef PERL_RANDOM_DEVICE
|
|
/* /dev/random isn't used by default because reads from it will block
|
|
* if there isn't enough entropy available. You can compile with
|
|
* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
|
|
* is enough real entropy to fill the seed. */
|
|
# define PERL_RANDOM_DEVICE "/dev/urandom"
|
|
#endif
|
|
fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
|
|
if (fd != -1) {
|
|
if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
|
|
u = 0;
|
|
PerlLIO_close(fd);
|
|
if (u)
|
|
return u;
|
|
}
|
|
#endif
|
|
|
|
#ifdef VMS
|
|
_ckvmssts(sys$gettim(when));
|
|
u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
|
|
#else
|
|
# ifdef HAS_GETTIMEOFDAY
|
|
gettimeofday(&when,(struct timezone *) 0);
|
|
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
|
|
# else
|
|
(void)time(&when);
|
|
u = (U32)SEED_C1 * when;
|
|
# endif
|
|
#endif
|
|
u += SEED_C3 * (U32)getpid();
|
|
u += SEED_C4 * (U32)(UV)PL_stack_sp;
|
|
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
|
|
u += SEED_C5 * (U32)(UV)&when;
|
|
#endif
|
|
return u;
|
|
}
|
|
|
|
PP(pp_exp)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(exp);
|
|
{
|
|
double value;
|
|
value = POPn;
|
|
value = exp(value);
|
|
XPUSHn(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_log)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(log);
|
|
{
|
|
double value;
|
|
value = POPn;
|
|
if (value <= 0.0) {
|
|
SET_NUMERIC_STANDARD();
|
|
DIE("Can't take log of %g", value);
|
|
}
|
|
value = log(value);
|
|
XPUSHn(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_sqrt)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(sqrt);
|
|
{
|
|
double value;
|
|
value = POPn;
|
|
if (value < 0.0) {
|
|
SET_NUMERIC_STANDARD();
|
|
DIE("Can't take sqrt of %g", value);
|
|
}
|
|
value = sqrt(value);
|
|
XPUSHn(value);
|
|
RETURN;
|
|
}
|
|
}
|
|
|
|
PP(pp_int)
|
|
{
|
|
djSP; dTARGET;
|
|
{
|
|
double value = TOPn;
|
|
IV iv;
|
|
|
|
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
|
|
iv = SvIVX(TOPs);
|
|
SETi(iv);
|
|
}
|
|
else {
|
|
if (value >= 0.0)
|
|
(void)modf(value, &value);
|
|
else {
|
|
(void)modf(-value, &value);
|
|
value = -value;
|
|
}
|
|
iv = I_V(value);
|
|
if (iv == value)
|
|
SETi(iv);
|
|
else
|
|
SETn(value);
|
|
}
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_abs)
|
|
{
|
|
djSP; dTARGET; tryAMAGICun(abs);
|
|
{
|
|
double value = TOPn;
|
|
IV iv;
|
|
|
|
if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
|
|
(iv = SvIVX(TOPs)) != IV_MIN) {
|
|
if (iv < 0)
|
|
iv = -iv;
|
|
SETi(iv);
|
|
}
|
|
else {
|
|
if (value < 0.0)
|
|
value = -value;
|
|
SETn(value);
|
|
}
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_hex)
|
|
{
|
|
djSP; dTARGET;
|
|
char *tmps;
|
|
I32 argtype;
|
|
STRLEN n_a;
|
|
|
|
tmps = POPpx;
|
|
XPUSHu(scan_hex(tmps, 99, &argtype));
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_oct)
|
|
{
|
|
djSP; dTARGET;
|
|
UV value;
|
|
I32 argtype;
|
|
char *tmps;
|
|
STRLEN n_a;
|
|
|
|
tmps = POPpx;
|
|
while (*tmps && isSPACE(*tmps))
|
|
tmps++;
|
|
if (*tmps == '0')
|
|
tmps++;
|
|
if (*tmps == 'x')
|
|
value = scan_hex(++tmps, 99, &argtype);
|
|
else
|
|
value = scan_oct(tmps, 99, &argtype);
|
|
XPUSHu(value);
|
|
RETURN;
|
|
}
|
|
|
|
/* String stuff. */
|
|
|
|
PP(pp_length)
|
|
{
|
|
djSP; dTARGET;
|
|
SETi( sv_len(TOPs) );
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_substr)
|
|
{
|
|
djSP; dTARGET;
|
|
SV *sv;
|
|
I32 len;
|
|
STRLEN curlen;
|
|
I32 pos;
|
|
I32 rem;
|
|
I32 fail;
|
|
I32 lvalue = PL_op->op_flags & OPf_MOD;
|
|
char *tmps;
|
|
I32 arybase = PL_curcop->cop_arybase;
|
|
char *repl = 0;
|
|
STRLEN repl_len;
|
|
|
|
SvTAINTED_off(TARG); /* decontaminate */
|
|
if (MAXARG > 2) {
|
|
if (MAXARG > 3) {
|
|
sv = POPs;
|
|
repl = SvPV(sv, repl_len);
|
|
}
|
|
len = POPi;
|
|
}
|
|
pos = POPi;
|
|
sv = POPs;
|
|
PUTBACK;
|
|
tmps = SvPV(sv, curlen);
|
|
if (pos >= arybase) {
|
|
pos -= arybase;
|
|
rem = curlen-pos;
|
|
fail = rem;
|
|
if (MAXARG > 2) {
|
|
if (len < 0) {
|
|
rem += len;
|
|
if (rem < 0)
|
|
rem = 0;
|
|
}
|
|
else if (rem > len)
|
|
rem = len;
|
|
}
|
|
}
|
|
else {
|
|
pos += curlen;
|
|
if (MAXARG < 3)
|
|
rem = curlen;
|
|
else if (len >= 0) {
|
|
rem = pos+len;
|
|
if (rem > (I32)curlen)
|
|
rem = curlen;
|
|
}
|
|
else {
|
|
rem = curlen+len;
|
|
if (rem < pos)
|
|
rem = pos;
|
|
}
|
|
if (pos < 0)
|
|
pos = 0;
|
|
fail = rem;
|
|
rem -= pos;
|
|
}
|
|
if (fail < 0) {
|
|
if (PL_dowarn || lvalue || repl)
|
|
warn("substr outside of string");
|
|
RETPUSHUNDEF;
|
|
}
|
|
else {
|
|
tmps += pos;
|
|
sv_setpvn(TARG, tmps, rem);
|
|
if (lvalue) { /* it's an lvalue! */
|
|
if (!SvGMAGICAL(sv)) {
|
|
if (SvROK(sv)) {
|
|
STRLEN n_a;
|
|
SvPV_force(sv,n_a);
|
|
if (PL_dowarn)
|
|
warn("Attempt to use reference as lvalue in substr");
|
|
}
|
|
if (SvOK(sv)) /* is it defined ? */
|
|
(void)SvPOK_only(sv);
|
|
else
|
|
sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
|
|
}
|
|
|
|
if (SvTYPE(TARG) < SVt_PVLV) {
|
|
sv_upgrade(TARG, SVt_PVLV);
|
|
sv_magic(TARG, Nullsv, 'x', Nullch, 0);
|
|
}
|
|
|
|
LvTYPE(TARG) = 'x';
|
|
if (LvTARG(TARG) != sv) {
|
|
if (LvTARG(TARG))
|
|
SvREFCNT_dec(LvTARG(TARG));
|
|
LvTARG(TARG) = SvREFCNT_inc(sv);
|
|
}
|
|
LvTARGOFF(TARG) = pos;
|
|
LvTARGLEN(TARG) = rem;
|
|
}
|
|
else if (repl)
|
|
sv_insert(sv, pos, rem, repl, repl_len);
|
|
}
|
|
SPAGAIN;
|
|
PUSHs(TARG); /* avoid SvSETMAGIC here */
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_vec)
|
|
{
|
|
djSP; dTARGET;
|
|
register I32 size = POPi;
|
|
register I32 offset = POPi;
|
|
register SV *src = POPs;
|
|
I32 lvalue = PL_op->op_flags & OPf_MOD;
|
|
STRLEN srclen;
|
|
unsigned char *s = (unsigned char*)SvPV(src, srclen);
|
|
unsigned long retnum;
|
|
I32 len;
|
|
|
|
SvTAINTED_off(TARG); /* decontaminate */
|
|
offset *= size; /* turn into bit offset */
|
|
len = (offset + size + 7) / 8;
|
|
if (offset < 0 || size < 1)
|
|
retnum = 0;
|
|
else {
|
|
if (lvalue) { /* it's an lvalue! */
|
|
if (SvTYPE(TARG) < SVt_PVLV) {
|
|
sv_upgrade(TARG, SVt_PVLV);
|
|
sv_magic(TARG, Nullsv, 'v', Nullch, 0);
|
|
}
|
|
|
|
LvTYPE(TARG) = 'v';
|
|
if (LvTARG(TARG) != src) {
|
|
if (LvTARG(TARG))
|
|
SvREFCNT_dec(LvTARG(TARG));
|
|
LvTARG(TARG) = SvREFCNT_inc(src);
|
|
}
|
|
LvTARGOFF(TARG) = offset;
|
|
LvTARGLEN(TARG) = size;
|
|
}
|
|
if (len > srclen) {
|
|
if (size <= 8)
|
|
retnum = 0;
|
|
else {
|
|
offset >>= 3;
|
|
if (size == 16) {
|
|
if (offset >= srclen)
|
|
retnum = 0;
|
|
else
|
|
retnum = (unsigned long) s[offset] << 8;
|
|
}
|
|
else if (size == 32) {
|
|
if (offset >= srclen)
|
|
retnum = 0;
|
|
else if (offset + 1 >= srclen)
|
|
retnum = (unsigned long) s[offset] << 24;
|
|
else if (offset + 2 >= srclen)
|
|
retnum = ((unsigned long) s[offset] << 24) +
|
|
((unsigned long) s[offset + 1] << 16);
|
|
else
|
|
retnum = ((unsigned long) s[offset] << 24) +
|
|
((unsigned long) s[offset + 1] << 16) +
|
|
(s[offset + 2] << 8);
|
|
}
|
|
}
|
|
}
|
|
else if (size < 8)
|
|
retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
|
|
else {
|
|
offset >>= 3;
|
|
if (size == 8)
|
|
retnum = s[offset];
|
|
else if (size == 16)
|
|
retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
|
|
else if (size == 32)
|
|
retnum = ((unsigned long) s[offset] << 24) +
|
|
((unsigned long) s[offset + 1] << 16) +
|
|
(s[offset + 2] << 8) + s[offset+3];
|
|
}
|
|
}
|
|
|
|
sv_setuv(TARG, (UV)retnum);
|
|
PUSHs(TARG);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_index)
|
|
{
|
|
djSP; dTARGET;
|
|
SV *big;
|
|
SV *little;
|
|
I32 offset;
|
|
I32 retval;
|
|
char *tmps;
|
|
char *tmps2;
|
|
STRLEN biglen;
|
|
I32 arybase = PL_curcop->cop_arybase;
|
|
|
|
if (MAXARG < 3)
|
|
offset = 0;
|
|
else
|
|
offset = POPi - arybase;
|
|
little = POPs;
|
|
big = POPs;
|
|
tmps = SvPV(big, biglen);
|
|
if (offset < 0)
|
|
offset = 0;
|
|
else if (offset > biglen)
|
|
offset = biglen;
|
|
if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
|
|
(unsigned char*)tmps + biglen, little, 0)))
|
|
retval = -1 + arybase;
|
|
else
|
|
retval = tmps2 - tmps + arybase;
|
|
PUSHi(retval);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_rindex)
|
|
{
|
|
djSP; dTARGET;
|
|
SV *big;
|
|
SV *little;
|
|
STRLEN blen;
|
|
STRLEN llen;
|
|
SV *offstr;
|
|
I32 offset;
|
|
I32 retval;
|
|
char *tmps;
|
|
char *tmps2;
|
|
I32 arybase = PL_curcop->cop_arybase;
|
|
|
|
if (MAXARG >= 3)
|
|
offstr = POPs;
|
|
little = POPs;
|
|
big = POPs;
|
|
tmps2 = SvPV(little, llen);
|
|
tmps = SvPV(big, blen);
|
|
if (MAXARG < 3)
|
|
offset = blen;
|
|
else
|
|
offset = SvIV(offstr) - arybase + llen;
|
|
if (offset < 0)
|
|
offset = 0;
|
|
else if (offset > blen)
|
|
offset = blen;
|
|
if (!(tmps2 = rninstr(tmps, tmps + offset,
|
|
tmps2, tmps2 + llen)))
|
|
retval = -1 + arybase;
|
|
else
|
|
retval = tmps2 - tmps + arybase;
|
|
PUSHi(retval);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_sprintf)
|
|
{
|
|
djSP; dMARK; dORIGMARK; dTARGET;
|
|
#ifdef USE_LOCALE_NUMERIC
|
|
if (PL_op->op_private & OPpLOCALE)
|
|
SET_NUMERIC_LOCAL();
|
|
else
|
|
SET_NUMERIC_STANDARD();
|
|
#endif
|
|
do_sprintf(TARG, SP-MARK, MARK+1);
|
|
TAINT_IF(SvTAINTED(TARG));
|
|
SP = ORIGMARK;
|
|
PUSHTARG;
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_ord)
|
|
{
|
|
djSP; dTARGET;
|
|
I32 value;
|
|
char *tmps;
|
|
STRLEN n_a;
|
|
|
|
#ifndef I286
|
|
tmps = POPpx;
|
|
value = (I32) (*tmps & 255);
|
|
#else
|
|
I32 anum;
|
|
tmps = POPpx;
|
|
anum = (I32) *tmps;
|
|
value = (I32) (anum & 255);
|
|
#endif
|
|
XPUSHi(value);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_chr)
|
|
{
|
|
djSP; dTARGET;
|
|
char *tmps;
|
|
|
|
(void)SvUPGRADE(TARG,SVt_PV);
|
|
SvGROW(TARG,2);
|
|
SvCUR_set(TARG, 1);
|
|
tmps = SvPVX(TARG);
|
|
*tmps++ = POPi;
|
|
*tmps = '\0';
|
|
(void)SvPOK_only(TARG);
|
|
XPUSHs(TARG);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_crypt)
|
|
{
|
|
djSP; dTARGET; dPOPTOPssrl;
|
|
STRLEN n_a;
|
|
#ifdef HAS_CRYPT
|
|
char *tmps = SvPV(left, n_a);
|
|
#ifdef FCRYPT
|
|
sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
|
|
#else
|
|
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
|
|
#endif
|
|
#else
|
|
DIE(
|
|
"The crypt() function is unimplemented due to excessive paranoia.");
|
|
#endif
|
|
SETs(TARG);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_ucfirst)
|
|
{
|
|
djSP;
|
|
SV *sv = TOPs;
|
|
register char *s;
|
|
STRLEN n_a;
|
|
|
|
if (!SvPADTMP(sv)) {
|
|
dTARGET;
|
|
sv_setsv(TARG, sv);
|
|
sv = TARG;
|
|
SETs(sv);
|
|
}
|
|
s = SvPV_force(sv, n_a);
|
|
if (*s) {
|
|
if (PL_op->op_private & OPpLOCALE) {
|
|
TAINT;
|
|
SvTAINTED_on(sv);
|
|
*s = toUPPER_LC(*s);
|
|
}
|
|
else
|
|
*s = toUPPER(*s);
|
|
}
|
|
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_lcfirst)
|
|
{
|
|
djSP;
|
|
SV *sv = TOPs;
|
|
register char *s;
|
|
STRLEN n_a;
|
|
|
|
if (!SvPADTMP(sv)) {
|
|
dTARGET;
|
|
sv_setsv(TARG, sv);
|
|
sv = TARG;
|
|
SETs(sv);
|
|
}
|
|
s = SvPV_force(sv, n_a);
|
|
if (*s) {
|
|
if (PL_op->op_private & OPpLOCALE) {
|
|
TAINT;
|
|
SvTAINTED_on(sv);
|
|
*s = toLOWER_LC(*s);
|
|
}
|
|
else
|
|
*s = toLOWER(*s);
|
|
}
|
|
|
|
SETs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_uc)
|
|
{
|
|
djSP;
|
|
SV *sv = TOPs;
|
|
register char *s;
|
|
STRLEN len;
|
|
|
|
if (!SvPADTMP(sv)) {
|
|
dTARGET;
|
|
sv_setsv(TARG, sv);
|
|
sv = TARG;
|
|
SETs(sv);
|
|
}
|
|
|
|
s = SvPV_force(sv, len);
|
|
if (len) {
|
|
register char *send = s + len;
|
|
|
|
if (PL_op->op_private & OPpLOCALE) {
|
|
TAINT;
|
|
SvTAINTED_on(sv);
|
|
for (; s < send; s++)
|
|
*s = toUPPER_LC(*s);
|
|
}
|
|
else {
|
|
for (; s < send; s++)
|
|
*s = toUPPER(*s);
|
|
}
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_lc)
|
|
{
|
|
djSP;
|
|
SV *sv = TOPs;
|
|
register char *s;
|
|
STRLEN len;
|
|
|
|
if (!SvPADTMP(sv)) {
|
|
dTARGET;
|
|
sv_setsv(TARG, sv);
|
|
sv = TARG;
|
|
SETs(sv);
|
|
}
|
|
|
|
s = SvPV_force(sv, len);
|
|
if (len) {
|
|
register char *send = s + len;
|
|
|
|
if (PL_op->op_private & OPpLOCALE) {
|
|
TAINT;
|
|
SvTAINTED_on(sv);
|
|
for (; s < send; s++)
|
|
*s = toLOWER_LC(*s);
|
|
}
|
|
else {
|
|
for (; s < send; s++)
|
|
*s = toLOWER(*s);
|
|
}
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_quotemeta)
|
|
{
|
|
djSP; dTARGET;
|
|
SV *sv = TOPs;
|
|
STRLEN len;
|
|
register char *s = SvPV(sv,len);
|
|
register char *d;
|
|
|
|
if (len) {
|
|
(void)SvUPGRADE(TARG, SVt_PV);
|
|
SvGROW(TARG, (len * 2) + 1);
|
|
d = SvPVX(TARG);
|
|
while (len--) {
|
|
if (!isALNUM(*s))
|
|
*d++ = '\\';
|
|
*d++ = *s++;
|
|
}
|
|
*d = '\0';
|
|
SvCUR_set(TARG, d - SvPVX(TARG));
|
|
(void)SvPOK_only(TARG);
|
|
}
|
|
else
|
|
sv_setpvn(TARG, s, len);
|
|
SETs(TARG);
|
|
RETURN;
|
|
}
|
|
|
|
/* Arrays. */
|
|
|
|
PP(pp_aslice)
|
|
{
|
|
djSP; dMARK; dORIGMARK;
|
|
register SV** svp;
|
|
register AV* av = (AV*)POPs;
|
|
register I32 lval = PL_op->op_flags & OPf_MOD;
|
|
I32 arybase = PL_curcop->cop_arybase;
|
|
I32 elem;
|
|
|
|
if (SvTYPE(av) == SVt_PVAV) {
|
|
if (lval && PL_op->op_private & OPpLVAL_INTRO) {
|
|
I32 max = -1;
|
|
for (svp = MARK + 1; svp <= SP; svp++) {
|
|
elem = SvIVx(*svp);
|
|
if (elem > max)
|
|
max = elem;
|
|
}
|
|
if (max > AvMAX(av))
|
|
av_extend(av, max);
|
|
}
|
|
while (++MARK <= SP) {
|
|
elem = SvIVx(*MARK);
|
|
|
|
if (elem > 0)
|
|
elem -= arybase;
|
|
svp = av_fetch(av, elem, lval);
|
|
if (lval) {
|
|
if (!svp || *svp == &PL_sv_undef)
|
|
DIE(no_aelem, elem);
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
save_aelem(av, elem, svp);
|
|
}
|
|
*MARK = svp ? *svp : &PL_sv_undef;
|
|
}
|
|
}
|
|
if (GIMME != G_ARRAY) {
|
|
MARK = ORIGMARK;
|
|
*++MARK = *SP;
|
|
SP = MARK;
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
/* Associative arrays. */
|
|
|
|
PP(pp_each)
|
|
{
|
|
djSP; dTARGET;
|
|
HV *hash = (HV*)POPs;
|
|
HE *entry;
|
|
I32 gimme = GIMME_V;
|
|
I32 realhv = (SvTYPE(hash) == SVt_PVHV);
|
|
|
|
PUTBACK;
|
|
/* might clobber stack_sp */
|
|
entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
|
|
SPAGAIN;
|
|
|
|
EXTEND(SP, 2);
|
|
if (entry) {
|
|
PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
|
|
if (gimme == G_ARRAY) {
|
|
PUTBACK;
|
|
/* might clobber stack_sp */
|
|
sv_setsv(TARG, realhv ?
|
|
hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
|
|
SPAGAIN;
|
|
PUSHs(TARG);
|
|
}
|
|
}
|
|
else if (gimme == G_SCALAR)
|
|
RETPUSHUNDEF;
|
|
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_values)
|
|
{
|
|
return do_kv(ARGS);
|
|
}
|
|
|
|
PP(pp_keys)
|
|
{
|
|
return do_kv(ARGS);
|
|
}
|
|
|
|
PP(pp_delete)
|
|
{
|
|
djSP;
|
|
I32 gimme = GIMME_V;
|
|
I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
|
|
SV *sv;
|
|
HV *hv;
|
|
|
|
if (PL_op->op_private & OPpSLICE) {
|
|
dMARK; dORIGMARK;
|
|
U32 hvtype;
|
|
hv = (HV*)POPs;
|
|
hvtype = SvTYPE(hv);
|
|
while (++MARK <= SP) {
|
|
if (hvtype == SVt_PVHV)
|
|
sv = hv_delete_ent(hv, *MARK, discard, 0);
|
|
else
|
|
DIE("Not a HASH reference");
|
|
*MARK = sv ? sv : &PL_sv_undef;
|
|
}
|
|
if (discard)
|
|
SP = ORIGMARK;
|
|
else if (gimme == G_SCALAR) {
|
|
MARK = ORIGMARK;
|
|
*++MARK = *SP;
|
|
SP = MARK;
|
|
}
|
|
}
|
|
else {
|
|
SV *keysv = POPs;
|
|
hv = (HV*)POPs;
|
|
if (SvTYPE(hv) == SVt_PVHV)
|
|
sv = hv_delete_ent(hv, keysv, discard, 0);
|
|
else
|
|
DIE("Not a HASH reference");
|
|
if (!sv)
|
|
sv = &PL_sv_undef;
|
|
if (!discard)
|
|
PUSHs(sv);
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_exists)
|
|
{
|
|
djSP;
|
|
SV *tmpsv = POPs;
|
|
HV *hv = (HV*)POPs;
|
|
if (SvTYPE(hv) == SVt_PVHV) {
|
|
if (hv_exists_ent(hv, tmpsv, 0))
|
|
RETPUSHYES;
|
|
} else if (SvTYPE(hv) == SVt_PVAV) {
|
|
if (avhv_exists_ent((AV*)hv, tmpsv, 0))
|
|
RETPUSHYES;
|
|
} else {
|
|
DIE("Not a HASH reference");
|
|
}
|
|
RETPUSHNO;
|
|
}
|
|
|
|
PP(pp_hslice)
|
|
{
|
|
djSP; dMARK; dORIGMARK;
|
|
register HV *hv = (HV*)POPs;
|
|
register I32 lval = PL_op->op_flags & OPf_MOD;
|
|
I32 realhv = (SvTYPE(hv) == SVt_PVHV);
|
|
|
|
if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
|
|
DIE("Can't localize pseudo-hash element");
|
|
|
|
if (realhv || SvTYPE(hv) == SVt_PVAV) {
|
|
while (++MARK <= SP) {
|
|
SV *keysv = *MARK;
|
|
SV **svp;
|
|
if (realhv) {
|
|
HE *he = hv_fetch_ent(hv, keysv, lval, 0);
|
|
svp = he ? &HeVAL(he) : 0;
|
|
} else {
|
|
svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
|
|
}
|
|
if (lval) {
|
|
if (!svp || *svp == &PL_sv_undef) {
|
|
STRLEN n_a;
|
|
DIE(no_helem, SvPV(keysv, n_a));
|
|
}
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
save_helem(hv, keysv, svp);
|
|
}
|
|
*MARK = svp ? *svp : &PL_sv_undef;
|
|
}
|
|
}
|
|
if (GIMME != G_ARRAY) {
|
|
MARK = ORIGMARK;
|
|
*++MARK = *SP;
|
|
SP = MARK;
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
/* List operators. */
|
|
|
|
PP(pp_list)
|
|
{
|
|
djSP; dMARK;
|
|
if (GIMME != G_ARRAY) {
|
|
if (++MARK <= SP)
|
|
*MARK = *SP; /* unwanted list, return last item */
|
|
else
|
|
*MARK = &PL_sv_undef;
|
|
SP = MARK;
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_lslice)
|
|
{
|
|
djSP;
|
|
SV **lastrelem = PL_stack_sp;
|
|
SV **lastlelem = PL_stack_base + POPMARK;
|
|
SV **firstlelem = PL_stack_base + POPMARK + 1;
|
|
register SV **firstrelem = lastlelem + 1;
|
|
I32 arybase = PL_curcop->cop_arybase;
|
|
I32 lval = PL_op->op_flags & OPf_MOD;
|
|
I32 is_something_there = lval;
|
|
|
|
register I32 max = lastrelem - lastlelem;
|
|
register SV **lelem;
|
|
register I32 ix;
|
|
|
|
if (GIMME != G_ARRAY) {
|
|
ix = SvIVx(*lastlelem);
|
|
if (ix < 0)
|
|
ix += max;
|
|
else
|
|
ix -= arybase;
|
|
if (ix < 0 || ix >= max)
|
|
*firstlelem = &PL_sv_undef;
|
|
else
|
|
*firstlelem = firstrelem[ix];
|
|
SP = firstlelem;
|
|
RETURN;
|
|
}
|
|
|
|
if (max == 0) {
|
|
SP = firstlelem - 1;
|
|
RETURN;
|
|
}
|
|
|
|
for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
|
|
ix = SvIVx(*lelem);
|
|
if (ix < 0) {
|
|
ix += max;
|
|
if (ix < 0)
|
|
*lelem = &PL_sv_undef;
|
|
else if (!(*lelem = firstrelem[ix]))
|
|
*lelem = &PL_sv_undef;
|
|
}
|
|
else {
|
|
ix -= arybase;
|
|
if (ix >= max || !(*lelem = firstrelem[ix]))
|
|
*lelem = &PL_sv_undef;
|
|
}
|
|
if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
|
|
is_something_there = TRUE;
|
|
}
|
|
if (is_something_there)
|
|
SP = lastlelem;
|
|
else
|
|
SP = firstlelem - 1;
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_anonlist)
|
|
{
|
|
djSP; dMARK; dORIGMARK;
|
|
I32 items = SP - MARK;
|
|
SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
|
|
SP = ORIGMARK; /* av_make() might realloc stack_sp */
|
|
XPUSHs(av);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_anonhash)
|
|
{
|
|
djSP; dMARK; dORIGMARK;
|
|
HV* hv = (HV*)sv_2mortal((SV*)newHV());
|
|
|
|
while (MARK < SP) {
|
|
SV* key = *++MARK;
|
|
SV *val = NEWSV(46, 0);
|
|
if (MARK < SP)
|
|
sv_setsv(val, *++MARK);
|
|
else if (PL_dowarn)
|
|
warn("Odd number of elements in hash assignment");
|
|
(void)hv_store_ent(hv,key,val,0);
|
|
}
|
|
SP = ORIGMARK;
|
|
XPUSHs((SV*)hv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_splice)
|
|
{
|
|
djSP; dMARK; dORIGMARK;
|
|
register AV *ary = (AV*)*++MARK;
|
|
register SV **src;
|
|
register SV **dst;
|
|
register I32 i;
|
|
register I32 offset;
|
|
register I32 length;
|
|
I32 newlen;
|
|
I32 after;
|
|
I32 diff;
|
|
SV **tmparyval = 0;
|
|
MAGIC *mg;
|
|
|
|
if (mg = SvTIED_mg((SV*)ary, 'P')) {
|
|
*MARK-- = SvTIED_obj((SV*)ary, mg);
|
|
PUSHMARK(MARK);
|
|
PUTBACK;
|
|
ENTER;
|
|
perl_call_method("SPLICE",GIMME_V);
|
|
LEAVE;
|
|
SPAGAIN;
|
|
RETURN;
|
|
}
|
|
|
|
SP++;
|
|
|
|
if (++MARK < SP) {
|
|
offset = i = SvIVx(*MARK);
|
|
if (offset < 0)
|
|
offset += AvFILLp(ary) + 1;
|
|
else
|
|
offset -= PL_curcop->cop_arybase;
|
|
if (offset < 0)
|
|
DIE(no_aelem, i);
|
|
if (++MARK < SP) {
|
|
length = SvIVx(*MARK++);
|
|
if (length < 0) {
|
|
length += AvFILLp(ary) - offset + 1;
|
|
if (length < 0)
|
|
length = 0;
|
|
}
|
|
}
|
|
else
|
|
length = AvMAX(ary) + 1; /* close enough to infinity */
|
|
}
|
|
else {
|
|
offset = 0;
|
|
length = AvMAX(ary) + 1;
|
|
}
|
|
if (offset > AvFILLp(ary) + 1)
|
|
offset = AvFILLp(ary) + 1;
|
|
after = AvFILLp(ary) + 1 - (offset + length);
|
|
if (after < 0) { /* not that much array */
|
|
length += after; /* offset+length now in array */
|
|
after = 0;
|
|
if (!AvALLOC(ary))
|
|
av_extend(ary, 0);
|
|
}
|
|
|
|
/* At this point, MARK .. SP-1 is our new LIST */
|
|
|
|
newlen = SP - MARK;
|
|
diff = newlen - length;
|
|
if (newlen && !AvREAL(ary)) {
|
|
if (AvREIFY(ary))
|
|
av_reify(ary);
|
|
else
|
|
assert(AvREAL(ary)); /* would leak, so croak */
|
|
}
|
|
|
|
if (diff < 0) { /* shrinking the area */
|
|
if (newlen) {
|
|
New(451, tmparyval, newlen, SV*); /* so remember insertion */
|
|
Copy(MARK, tmparyval, newlen, SV*);
|
|
}
|
|
|
|
MARK = ORIGMARK + 1;
|
|
if (GIMME == G_ARRAY) { /* copy return vals to stack */
|
|
MEXTEND(MARK, length);
|
|
Copy(AvARRAY(ary)+offset, MARK, length, SV*);
|
|
if (AvREAL(ary)) {
|
|
EXTEND_MORTAL(length);
|
|
for (i = length, dst = MARK; i; i--) {
|
|
sv_2mortal(*dst); /* free them eventualy */
|
|
dst++;
|
|
}
|
|
}
|
|
MARK += length - 1;
|
|
}
|
|
else {
|
|
*MARK = AvARRAY(ary)[offset+length-1];
|
|
if (AvREAL(ary)) {
|
|
sv_2mortal(*MARK);
|
|
for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
|
|
SvREFCNT_dec(*dst++); /* free them now */
|
|
}
|
|
}
|
|
AvFILLp(ary) += diff;
|
|
|
|
/* pull up or down? */
|
|
|
|
if (offset < after) { /* easier to pull up */
|
|
if (offset) { /* esp. if nothing to pull */
|
|
src = &AvARRAY(ary)[offset-1];
|
|
dst = src - diff; /* diff is negative */
|
|
for (i = offset; i > 0; i--) /* can't trust Copy */
|
|
*dst-- = *src--;
|
|
}
|
|
dst = AvARRAY(ary);
|
|
SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
|
|
AvMAX(ary) += diff;
|
|
}
|
|
else {
|
|
if (after) { /* anything to pull down? */
|
|
src = AvARRAY(ary) + offset + length;
|
|
dst = src + diff; /* diff is negative */
|
|
Move(src, dst, after, SV*);
|
|
}
|
|
dst = &AvARRAY(ary)[AvFILLp(ary)+1];
|
|
/* avoid later double free */
|
|
}
|
|
i = -diff;
|
|
while (i)
|
|
dst[--i] = &PL_sv_undef;
|
|
|
|
if (newlen) {
|
|
for (src = tmparyval, dst = AvARRAY(ary) + offset;
|
|
newlen; newlen--) {
|
|
*dst = NEWSV(46, 0);
|
|
sv_setsv(*dst++, *src++);
|
|
}
|
|
Safefree(tmparyval);
|
|
}
|
|
}
|
|
else { /* no, expanding (or same) */
|
|
if (length) {
|
|
New(452, tmparyval, length, SV*); /* so remember deletion */
|
|
Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
|
|
}
|
|
|
|
if (diff > 0) { /* expanding */
|
|
|
|
/* push up or down? */
|
|
|
|
if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
|
|
if (offset) {
|
|
src = AvARRAY(ary);
|
|
dst = src - diff;
|
|
Move(src, dst, offset, SV*);
|
|
}
|
|
SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
|
|
AvMAX(ary) += diff;
|
|
AvFILLp(ary) += diff;
|
|
}
|
|
else {
|
|
if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
|
|
av_extend(ary, AvFILLp(ary) + diff);
|
|
AvFILLp(ary) += diff;
|
|
|
|
if (after) {
|
|
dst = AvARRAY(ary) + AvFILLp(ary);
|
|
src = dst - diff;
|
|
for (i = after; i; i--) {
|
|
*dst-- = *src--;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
|
|
*dst = NEWSV(46, 0);
|
|
sv_setsv(*dst++, *src++);
|
|
}
|
|
MARK = ORIGMARK + 1;
|
|
if (GIMME == G_ARRAY) { /* copy return vals to stack */
|
|
if (length) {
|
|
Copy(tmparyval, MARK, length, SV*);
|
|
if (AvREAL(ary)) {
|
|
EXTEND_MORTAL(length);
|
|
for (i = length, dst = MARK; i; i--) {
|
|
sv_2mortal(*dst); /* free them eventualy */
|
|
dst++;
|
|
}
|
|
}
|
|
Safefree(tmparyval);
|
|
}
|
|
MARK += length - 1;
|
|
}
|
|
else if (length--) {
|
|
*MARK = tmparyval[length];
|
|
if (AvREAL(ary)) {
|
|
sv_2mortal(*MARK);
|
|
while (length-- > 0)
|
|
SvREFCNT_dec(tmparyval[length]);
|
|
}
|
|
Safefree(tmparyval);
|
|
}
|
|
else
|
|
*MARK = &PL_sv_undef;
|
|
}
|
|
SP = MARK;
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_push)
|
|
{
|
|
djSP; dMARK; dORIGMARK; dTARGET;
|
|
register AV *ary = (AV*)*++MARK;
|
|
register SV *sv = &PL_sv_undef;
|
|
MAGIC *mg;
|
|
|
|
if (mg = SvTIED_mg((SV*)ary, 'P')) {
|
|
*MARK-- = SvTIED_obj((SV*)ary, mg);
|
|
PUSHMARK(MARK);
|
|
PUTBACK;
|
|
ENTER;
|
|
perl_call_method("PUSH",G_SCALAR|G_DISCARD);
|
|
LEAVE;
|
|
SPAGAIN;
|
|
}
|
|
else {
|
|
/* Why no pre-extend of ary here ? */
|
|
for (++MARK; MARK <= SP; MARK++) {
|
|
sv = NEWSV(51, 0);
|
|
if (*MARK)
|
|
sv_setsv(sv, *MARK);
|
|
av_push(ary, sv);
|
|
}
|
|
}
|
|
SP = ORIGMARK;
|
|
PUSHi( AvFILL(ary) + 1 );
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_pop)
|
|
{
|
|
djSP;
|
|
AV *av = (AV*)POPs;
|
|
SV *sv = av_pop(av);
|
|
if (AvREAL(av))
|
|
(void)sv_2mortal(sv);
|
|
PUSHs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_shift)
|
|
{
|
|
djSP;
|
|
AV *av = (AV*)POPs;
|
|
SV *sv = av_shift(av);
|
|
EXTEND(SP, 1);
|
|
if (!sv)
|
|
RETPUSHUNDEF;
|
|
if (AvREAL(av))
|
|
(void)sv_2mortal(sv);
|
|
PUSHs(sv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_unshift)
|
|
{
|
|
djSP; dMARK; dORIGMARK; dTARGET;
|
|
register AV *ary = (AV*)*++MARK;
|
|
register SV *sv;
|
|
register I32 i = 0;
|
|
MAGIC *mg;
|
|
|
|
if (mg = SvTIED_mg((SV*)ary, 'P')) {
|
|
*MARK-- = SvTIED_obj((SV*)ary, mg);
|
|
PUSHMARK(MARK);
|
|
PUTBACK;
|
|
ENTER;
|
|
perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
|
|
LEAVE;
|
|
SPAGAIN;
|
|
}
|
|
else {
|
|
av_unshift(ary, SP - MARK);
|
|
while (MARK < SP) {
|
|
sv = NEWSV(27, 0);
|
|
sv_setsv(sv, *++MARK);
|
|
(void)av_store(ary, i++, sv);
|
|
}
|
|
}
|
|
SP = ORIGMARK;
|
|
PUSHi( AvFILL(ary) + 1 );
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_reverse)
|
|
{
|
|
djSP; dMARK;
|
|
register SV *tmp;
|
|
SV **oldsp = SP;
|
|
|
|
if (GIMME == G_ARRAY) {
|
|
MARK++;
|
|
while (MARK < SP) {
|
|
tmp = *MARK;
|
|
*MARK++ = *SP;
|
|
*SP-- = tmp;
|
|
}
|
|
SP = oldsp;
|
|
}
|
|
else {
|
|
register char *up;
|
|
register char *down;
|
|
register I32 tmp;
|
|
dTARGET;
|
|
STRLEN len;
|
|
|
|
if (SP - MARK > 1)
|
|
do_join(TARG, &PL_sv_no, MARK, SP);
|
|
else
|
|
sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
|
|
up = SvPV_force(TARG, len);
|
|
if (len > 1) {
|
|
down = SvPVX(TARG) + len - 1;
|
|
while (down > up) {
|
|
tmp = *up;
|
|
*up++ = *down;
|
|
*down-- = tmp;
|
|
}
|
|
(void)SvPOK_only(TARG);
|
|
}
|
|
SP = MARK + 1;
|
|
SETTARG;
|
|
}
|
|
RETURN;
|
|
}
|
|
|
|
STATIC SV *
|
|
mul128(SV *sv, U8 m)
|
|
{
|
|
STRLEN len;
|
|
char *s = SvPV(sv, len);
|
|
char *t;
|
|
U32 i = 0;
|
|
|
|
if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
|
|
SV *tmpNew = newSVpv("0000000000", 10);
|
|
|
|
sv_catsv(tmpNew, sv);
|
|
SvREFCNT_dec(sv); /* free old sv */
|
|
sv = tmpNew;
|
|
s = SvPV(sv, len);
|
|
}
|
|
t = s + len - 1;
|
|
while (!*t) /* trailing '\0'? */
|
|
t--;
|
|
while (t > s) {
|
|
i = ((*t - '0') << 7) + m;
|
|
*(t--) = '0' + (i % 10);
|
|
m = i / 10;
|
|
}
|
|
return (sv);
|
|
}
|
|
|
|
/* Explosives and implosives. */
|
|
|
|
static const char uuemap[] =
|
|
"`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
|
|
#ifndef PERL_OBJECT
|
|
static char uudmap[256]; /* Initialised on first use */
|
|
#endif
|
|
#if 'I' == 73 && 'J' == 74
|
|
/* On an ASCII/ISO kind of system */
|
|
#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
|
|
#else
|
|
/*
|
|
Some other sort of character set - use memchr() so we don't match
|
|
the null byte.
|
|
*/
|
|
#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
|
|
#endif
|
|
|
|
PP(pp_unpack)
|
|
{
|
|
djSP;
|
|
dPOPPOPssrl;
|
|
SV **oldsp = SP;
|
|
I32 gimme = GIMME_V;
|
|
SV *sv;
|
|
STRLEN llen;
|
|
STRLEN rlen;
|
|
register char *pat = SvPV(left, llen);
|
|
register char *s = SvPV(right, rlen);
|
|
char *strend = s + rlen;
|
|
char *strbeg = s;
|
|
register char *patend = pat + llen;
|
|
I32 datumtype;
|
|
register I32 len;
|
|
register I32 bits;
|
|
|
|
/* These must not be in registers: */
|
|
I16 ashort;
|
|
int aint;
|
|
I32 along;
|
|
#ifdef HAS_QUAD
|
|
Quad_t aquad;
|
|
#endif
|
|
U16 aushort;
|
|
unsigned int auint;
|
|
U32 aulong;
|
|
#ifdef HAS_QUAD
|
|
unsigned Quad_t auquad;
|
|
#endif
|
|
char *aptr;
|
|
float afloat;
|
|
double adouble;
|
|
I32 checksum = 0;
|
|
register U32 culong;
|
|
double cdouble;
|
|
#ifndef PERL_OBJECT
|
|
static char* bitcount = 0;
|
|
#endif
|
|
int commas = 0;
|
|
|
|
if (gimme != G_ARRAY) { /* arrange to do first one only */
|
|
/*SUPPRESS 530*/
|
|
for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
|
|
if (strchr("aAZbBhHP", *patend) || *pat == '%') {
|
|
patend++;
|
|
while (isDIGIT(*patend) || *patend == '*')
|
|
patend++;
|
|
}
|
|
else
|
|
patend++;
|
|
}
|
|
while (pat < patend) {
|
|
reparse:
|
|
datumtype = *pat++ & 0xFF;
|
|
if (isSPACE(datumtype))
|
|
continue;
|
|
if (pat >= patend)
|
|
len = 1;
|
|
else if (*pat == '*') {
|
|
len = strend - strbeg; /* long enough */
|
|
pat++;
|
|
}
|
|
else if (isDIGIT(*pat)) {
|
|
len = *pat++ - '0';
|
|
while (isDIGIT(*pat))
|
|
len = (len * 10) + (*pat++ - '0');
|
|
}
|
|
else
|
|
len = (datumtype != '@');
|
|
switch(datumtype) {
|
|
default:
|
|
croak("Invalid type in unpack: '%c'", (int)datumtype);
|
|
case ',': /* grandfather in commas but with a warning */
|
|
if (commas++ == 0 && PL_dowarn)
|
|
warn("Invalid type in unpack: '%c'", (int)datumtype);
|
|
break;
|
|
case '%':
|
|
if (len == 1 && pat[-1] != '1')
|
|
len = 16;
|
|
checksum = len;
|
|
culong = 0;
|
|
cdouble = 0;
|
|
if (pat < patend)
|
|
goto reparse;
|
|
break;
|
|
case '@':
|
|
if (len > strend - strbeg)
|
|
DIE("@ outside of string");
|
|
s = strbeg + len;
|
|
break;
|
|
case 'X':
|
|
if (len > s - strbeg)
|
|
DIE("X outside of string");
|
|
s -= len;
|
|
break;
|
|
case 'x':
|
|
if (len > strend - s)
|
|
DIE("x outside of string");
|
|
s += len;
|
|
break;
|
|
case 'A':
|
|
case 'Z':
|
|
case 'a':
|
|
if (len > strend - s)
|
|
len = strend - s;
|
|
if (checksum)
|
|
goto uchar_checksum;
|
|
sv = NEWSV(35, len);
|
|
sv_setpvn(sv, s, len);
|
|
s += len;
|
|
if (datumtype == 'A' || datumtype == 'Z') {
|
|
aptr = s; /* borrow register */
|
|
if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
|
|
s = SvPVX(sv);
|
|
while (*s)
|
|
s++;
|
|
}
|
|
else { /* 'A' strips both nulls and spaces */
|
|
s = SvPVX(sv) + len - 1;
|
|
while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
|
|
s--;
|
|
*++s = '\0';
|
|
}
|
|
SvCUR_set(sv, s - SvPVX(sv));
|
|
s = aptr; /* unborrow register */
|
|
}
|
|
XPUSHs(sv_2mortal(sv));
|
|
break;
|
|
case 'B':
|
|
case 'b':
|
|
if (pat[-1] == '*' || len > (strend - s) * 8)
|
|
len = (strend - s) * 8;
|
|
if (checksum) {
|
|
if (!bitcount) {
|
|
Newz(601, bitcount, 256, char);
|
|
for (bits = 1; bits < 256; bits++) {
|
|
if (bits & 1) bitcount[bits]++;
|
|
if (bits & 2) bitcount[bits]++;
|
|
if (bits & 4) bitcount[bits]++;
|
|
if (bits & 8) bitcount[bits]++;
|
|
if (bits & 16) bitcount[bits]++;
|
|
if (bits & 32) bitcount[bits]++;
|
|
if (bits & 64) bitcount[bits]++;
|
|
if (bits & 128) bitcount[bits]++;
|
|
}
|
|
}
|
|
while (len >= 8) {
|
|
culong += bitcount[*(unsigned char*)s++];
|
|
len -= 8;
|
|
}
|
|
if (len) {
|
|
bits = *s;
|
|
if (datumtype == 'b') {
|
|
while (len-- > 0) {
|
|
if (bits & 1) culong++;
|
|
bits >>= 1;
|
|
}
|
|
}
|
|
else {
|
|
while (len-- > 0) {
|
|
if (bits & 128) culong++;
|
|
bits <<= 1;
|
|
}
|
|
}
|
|
}
|
|
break;
|
|
}
|
|
sv = NEWSV(35, len + 1);
|
|
SvCUR_set(sv, len);
|
|
SvPOK_on(sv);
|
|
aptr = pat; /* borrow register */
|
|
pat = SvPVX(sv);
|
|
if (datumtype == 'b') {
|
|
aint = len;
|
|
for (len = 0; len < aint; len++) {
|
|
if (len & 7) /*SUPPRESS 595*/
|
|
bits >>= 1;
|
|
else
|
|
bits = *s++;
|
|
*pat++ = '0' + (bits & 1);
|
|
}
|
|
}
|
|
else {
|
|
aint = len;
|
|
for (len = 0; len < aint; len++) {
|
|
if (len & 7)
|
|
bits <<= 1;
|
|
else
|
|
bits = *s++;
|
|
*pat++ = '0' + ((bits & 128) != 0);
|
|
}
|
|
}
|
|
*pat = '\0';
|
|
pat = aptr; /* unborrow register */
|
|
XPUSHs(sv_2mortal(sv));
|
|
break;
|
|
case 'H':
|
|
case 'h':
|
|
if (pat[-1] == '*' || len > (strend - s) * 2)
|
|
len = (strend - s) * 2;
|
|
sv = NEWSV(35, len + 1);
|
|
SvCUR_set(sv, len);
|
|
SvPOK_on(sv);
|
|
aptr = pat; /* borrow register */
|
|
pat = SvPVX(sv);
|
|
if (datumtype == 'h') {
|
|
aint = len;
|
|
for (len = 0; len < aint; len++) {
|
|
if (len & 1)
|
|
bits >>= 4;
|
|
else
|
|
bits = *s++;
|
|
*pat++ = PL_hexdigit[bits & 15];
|
|
}
|
|
}
|
|
else {
|
|
aint = len;
|
|
for (len = 0; len < aint; len++) {
|
|
if (len & 1)
|
|
bits <<= 4;
|
|
else
|
|
bits = *s++;
|
|
*pat++ = PL_hexdigit[(bits >> 4) & 15];
|
|
}
|
|
}
|
|
*pat = '\0';
|
|
pat = aptr; /* unborrow register */
|
|
XPUSHs(sv_2mortal(sv));
|
|
break;
|
|
case 'c':
|
|
if (len > strend - s)
|
|
len = strend - s;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
aint = *s++;
|
|
if (aint >= 128) /* fake up signed chars */
|
|
aint -= 256;
|
|
culong += aint;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
aint = *s++;
|
|
if (aint >= 128) /* fake up signed chars */
|
|
aint -= 256;
|
|
sv = NEWSV(36, 0);
|
|
sv_setiv(sv, (IV)aint);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'C':
|
|
if (len > strend - s)
|
|
len = strend - s;
|
|
if (checksum) {
|
|
uchar_checksum:
|
|
while (len-- > 0) {
|
|
auint = *s++ & 255;
|
|
culong += auint;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
auint = *s++ & 255;
|
|
sv = NEWSV(37, 0);
|
|
sv_setiv(sv, (IV)auint);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 's':
|
|
along = (strend - s) / SIZE16;
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
COPY16(s, &ashort);
|
|
#if SHORTSIZE > SIZE16
|
|
if (ashort > 32767)
|
|
ashort -= 65536;
|
|
#endif
|
|
s += SIZE16;
|
|
culong += ashort;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
COPY16(s, &ashort);
|
|
#if SHORTSIZE > SIZE16
|
|
if (ashort > 32767)
|
|
ashort -= 65536;
|
|
#endif
|
|
s += SIZE16;
|
|
sv = NEWSV(38, 0);
|
|
sv_setiv(sv, (IV)ashort);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'v':
|
|
case 'n':
|
|
case 'S':
|
|
along = (strend - s) / SIZE16;
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
COPY16(s, &aushort);
|
|
s += SIZE16;
|
|
#ifdef HAS_NTOHS
|
|
if (datumtype == 'n')
|
|
aushort = PerlSock_ntohs(aushort);
|
|
#endif
|
|
#ifdef HAS_VTOHS
|
|
if (datumtype == 'v')
|
|
aushort = vtohs(aushort);
|
|
#endif
|
|
culong += aushort;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
COPY16(s, &aushort);
|
|
s += SIZE16;
|
|
sv = NEWSV(39, 0);
|
|
#ifdef HAS_NTOHS
|
|
if (datumtype == 'n')
|
|
aushort = PerlSock_ntohs(aushort);
|
|
#endif
|
|
#ifdef HAS_VTOHS
|
|
if (datumtype == 'v')
|
|
aushort = vtohs(aushort);
|
|
#endif
|
|
sv_setiv(sv, (IV)aushort);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'i':
|
|
along = (strend - s) / sizeof(int);
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
Copy(s, &aint, 1, int);
|
|
s += sizeof(int);
|
|
if (checksum > 32)
|
|
cdouble += (double)aint;
|
|
else
|
|
culong += aint;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
Copy(s, &aint, 1, int);
|
|
s += sizeof(int);
|
|
sv = NEWSV(40, 0);
|
|
#ifdef __osf__
|
|
/* Without the dummy below unpack("i", pack("i",-1))
|
|
* return 0xFFffFFff instead of -1 for Digital Unix V4.0
|
|
* cc with optimization turned on */
|
|
(aint) ?
|
|
sv_setiv(sv, (IV)aint) :
|
|
#endif
|
|
sv_setiv(sv, (IV)aint);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'I':
|
|
along = (strend - s) / sizeof(unsigned int);
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
Copy(s, &auint, 1, unsigned int);
|
|
s += sizeof(unsigned int);
|
|
if (checksum > 32)
|
|
cdouble += (double)auint;
|
|
else
|
|
culong += auint;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
Copy(s, &auint, 1, unsigned int);
|
|
s += sizeof(unsigned int);
|
|
sv = NEWSV(41, 0);
|
|
#ifdef __osf__
|
|
/* Without the dummy below unpack("I", pack("I",0xFFFFFFFF))
|
|
* returns 1.84467440737096e+19 instead of 0xFFFFFFFF for
|
|
* DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (aka V4.0D)
|
|
* with optimization turned on.
|
|
* (DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (aka V4.0B)
|
|
* does not have this problem even with -O4)
|
|
*/
|
|
(auint) ?
|
|
sv_setuv(sv, (UV)auint) :
|
|
#endif
|
|
sv_setuv(sv, (UV)auint);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'l':
|
|
along = (strend - s) / SIZE32;
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
COPY32(s, &along);
|
|
#if LONGSIZE > SIZE32
|
|
if (along > 2147483647)
|
|
along -= 4294967296;
|
|
#endif
|
|
s += SIZE32;
|
|
if (checksum > 32)
|
|
cdouble += (double)along;
|
|
else
|
|
culong += along;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
COPY32(s, &along);
|
|
#if LONGSIZE > SIZE32
|
|
if (along > 2147483647)
|
|
along -= 4294967296;
|
|
#endif
|
|
s += SIZE32;
|
|
sv = NEWSV(42, 0);
|
|
sv_setiv(sv, (IV)along);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'V':
|
|
case 'N':
|
|
case 'L':
|
|
along = (strend - s) / SIZE32;
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
COPY32(s, &aulong);
|
|
s += SIZE32;
|
|
#ifdef HAS_NTOHL
|
|
if (datumtype == 'N')
|
|
aulong = PerlSock_ntohl(aulong);
|
|
#endif
|
|
#ifdef HAS_VTOHL
|
|
if (datumtype == 'V')
|
|
aulong = vtohl(aulong);
|
|
#endif
|
|
if (checksum > 32)
|
|
cdouble += (double)aulong;
|
|
else
|
|
culong += aulong;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
COPY32(s, &aulong);
|
|
s += SIZE32;
|
|
#ifdef HAS_NTOHL
|
|
if (datumtype == 'N')
|
|
aulong = PerlSock_ntohl(aulong);
|
|
#endif
|
|
#ifdef HAS_VTOHL
|
|
if (datumtype == 'V')
|
|
aulong = vtohl(aulong);
|
|
#endif
|
|
sv = NEWSV(43, 0);
|
|
sv_setuv(sv, (UV)aulong);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'p':
|
|
along = (strend - s) / sizeof(char*);
|
|
if (len > along)
|
|
len = along;
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
if (sizeof(char*) > strend - s)
|
|
break;
|
|
else {
|
|
Copy(s, &aptr, 1, char*);
|
|
s += sizeof(char*);
|
|
}
|
|
sv = NEWSV(44, 0);
|
|
if (aptr)
|
|
sv_setpv(sv, aptr);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
break;
|
|
case 'w':
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
{
|
|
UV auv = 0;
|
|
U32 bytes = 0;
|
|
|
|
while ((len > 0) && (s < strend)) {
|
|
auv = (auv << 7) | (*s & 0x7f);
|
|
if (!(*s++ & 0x80)) {
|
|
bytes = 0;
|
|
sv = NEWSV(40, 0);
|
|
sv_setuv(sv, auv);
|
|
PUSHs(sv_2mortal(sv));
|
|
len--;
|
|
auv = 0;
|
|
}
|
|
else if (++bytes >= sizeof(UV)) { /* promote to string */
|
|
char *t;
|
|
STRLEN n_a;
|
|
|
|
sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
|
|
while (s < strend) {
|
|
sv = mul128(sv, *s & 0x7f);
|
|
if (!(*s++ & 0x80)) {
|
|
bytes = 0;
|
|
break;
|
|
}
|
|
}
|
|
t = SvPV(sv, n_a);
|
|
while (*t == '0')
|
|
t++;
|
|
sv_chop(sv, t);
|
|
PUSHs(sv_2mortal(sv));
|
|
len--;
|
|
auv = 0;
|
|
}
|
|
}
|
|
if ((s >= strend) && bytes)
|
|
croak("Unterminated compressed integer");
|
|
}
|
|
break;
|
|
case 'P':
|
|
EXTEND(SP, 1);
|
|
if (sizeof(char*) > strend - s)
|
|
break;
|
|
else {
|
|
Copy(s, &aptr, 1, char*);
|
|
s += sizeof(char*);
|
|
}
|
|
sv = NEWSV(44, 0);
|
|
if (aptr)
|
|
sv_setpvn(sv, aptr, len);
|
|
PUSHs(sv_2mortal(sv));
|
|
break;
|
|
#ifdef HAS_QUAD
|
|
case 'q':
|
|
along = (strend - s) / sizeof(Quad_t);
|
|
if (len > along)
|
|
len = along;
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
if (s + sizeof(Quad_t) > strend)
|
|
aquad = 0;
|
|
else {
|
|
Copy(s, &aquad, 1, Quad_t);
|
|
s += sizeof(Quad_t);
|
|
}
|
|
sv = NEWSV(42, 0);
|
|
if (aquad >= IV_MIN && aquad <= IV_MAX)
|
|
sv_setiv(sv, (IV)aquad);
|
|
else
|
|
sv_setnv(sv, (double)aquad);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
break;
|
|
case 'Q':
|
|
along = (strend - s) / sizeof(Quad_t);
|
|
if (len > along)
|
|
len = along;
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
if (s + sizeof(unsigned Quad_t) > strend)
|
|
auquad = 0;
|
|
else {
|
|
Copy(s, &auquad, 1, unsigned Quad_t);
|
|
s += sizeof(unsigned Quad_t);
|
|
}
|
|
sv = NEWSV(43, 0);
|
|
if (auquad <= UV_MAX)
|
|
sv_setuv(sv, (UV)auquad);
|
|
else
|
|
sv_setnv(sv, (double)auquad);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
break;
|
|
#endif
|
|
/* float and double added gnb@melba.bby.oz.au 22/11/89 */
|
|
case 'f':
|
|
case 'F':
|
|
along = (strend - s) / sizeof(float);
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
Copy(s, &afloat, 1, float);
|
|
s += sizeof(float);
|
|
cdouble += afloat;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
Copy(s, &afloat, 1, float);
|
|
s += sizeof(float);
|
|
sv = NEWSV(47, 0);
|
|
sv_setnv(sv, (double)afloat);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'd':
|
|
case 'D':
|
|
along = (strend - s) / sizeof(double);
|
|
if (len > along)
|
|
len = along;
|
|
if (checksum) {
|
|
while (len-- > 0) {
|
|
Copy(s, &adouble, 1, double);
|
|
s += sizeof(double);
|
|
cdouble += adouble;
|
|
}
|
|
}
|
|
else {
|
|
EXTEND(SP, len);
|
|
EXTEND_MORTAL(len);
|
|
while (len-- > 0) {
|
|
Copy(s, &adouble, 1, double);
|
|
s += sizeof(double);
|
|
sv = NEWSV(48, 0);
|
|
sv_setnv(sv, (double)adouble);
|
|
PUSHs(sv_2mortal(sv));
|
|
}
|
|
}
|
|
break;
|
|
case 'u':
|
|
/* MKS:
|
|
* Initialise the decode mapping. By using a table driven
|
|
* algorithm, the code will be character-set independent
|
|
* (and just as fast as doing character arithmetic)
|
|
*/
|
|
if (uudmap['M'] == 0) {
|
|
int i;
|
|
|
|
for (i = 0; i < sizeof(uuemap); i += 1)
|
|
uudmap[uuemap[i]] = i;
|
|
/*
|
|
* Because ' ' and '`' map to the same value,
|
|
* we need to decode them both the same.
|
|
*/
|
|
uudmap[' '] = 0;
|
|
}
|
|
|
|
along = (strend - s) * 3 / 4;
|
|
sv = NEWSV(42, along);
|
|
if (along)
|
|
SvPOK_on(sv);
|
|
while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
|
|
I32 a, b, c, d;
|
|
char hunk[4];
|
|
|
|
hunk[3] = '\0';
|
|
len = uudmap[*s++] & 077;
|
|
while (len > 0) {
|
|
if (s < strend && ISUUCHAR(*s))
|
|
a = uudmap[*s++] & 077;
|
|
else
|
|
a = 0;
|
|
if (s < strend && ISUUCHAR(*s))
|
|
b = uudmap[*s++] & 077;
|
|
else
|
|
b = 0;
|
|
if (s < strend && ISUUCHAR(*s))
|
|
c = uudmap[*s++] & 077;
|
|
else
|
|
c = 0;
|
|
if (s < strend && ISUUCHAR(*s))
|
|
d = uudmap[*s++] & 077;
|
|
else
|
|
d = 0;
|
|
hunk[0] = (a << 2) | (b >> 4);
|
|
hunk[1] = (b << 4) | (c >> 2);
|
|
hunk[2] = (c << 6) | d;
|
|
sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
|
|
len -= 3;
|
|
}
|
|
if (*s == '\n')
|
|
s++;
|
|
else if (s[1] == '\n') /* possible checksum byte */
|
|
s += 2;
|
|
}
|
|
XPUSHs(sv_2mortal(sv));
|
|
break;
|
|
}
|
|
if (checksum) {
|
|
sv = NEWSV(42, 0);
|
|
if (strchr("fFdD", datumtype) ||
|
|
(checksum > 32 && strchr("iIlLN", datumtype)) ) {
|
|
double trouble;
|
|
|
|
adouble = 1.0;
|
|
while (checksum >= 16) {
|
|
checksum -= 16;
|
|
adouble *= 65536.0;
|
|
}
|
|
while (checksum >= 4) {
|
|
checksum -= 4;
|
|
adouble *= 16.0;
|
|
}
|
|
while (checksum--)
|
|
adouble *= 2.0;
|
|
along = (1 << checksum) - 1;
|
|
while (cdouble < 0.0)
|
|
cdouble += adouble;
|
|
cdouble = modf(cdouble / adouble, &trouble) * adouble;
|
|
sv_setnv(sv, cdouble);
|
|
}
|
|
else {
|
|
if (checksum < 32) {
|
|
aulong = (1 << checksum) - 1;
|
|
culong &= aulong;
|
|
}
|
|
sv_setuv(sv, (UV)culong);
|
|
}
|
|
XPUSHs(sv_2mortal(sv));
|
|
checksum = 0;
|
|
}
|
|
}
|
|
if (SP == oldsp && gimme == G_SCALAR)
|
|
PUSHs(&PL_sv_undef);
|
|
RETURN;
|
|
}
|
|
|
|
STATIC void
|
|
doencodes(register SV *sv, register char *s, register I32 len)
|
|
{
|
|
char hunk[5];
|
|
|
|
*hunk = uuemap[len];
|
|
sv_catpvn(sv, hunk, 1);
|
|
hunk[4] = '\0';
|
|
while (len > 2) {
|
|
hunk[0] = uuemap[(077 & (*s >> 2))];
|
|
hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
|
|
hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
|
|
hunk[3] = uuemap[(077 & (s[2] & 077))];
|
|
sv_catpvn(sv, hunk, 4);
|
|
s += 3;
|
|
len -= 3;
|
|
}
|
|
if (len > 0) {
|
|
char r = (len > 1 ? s[1] : '\0');
|
|
hunk[0] = uuemap[(077 & (*s >> 2))];
|
|
hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
|
|
hunk[2] = uuemap[(077 & ((r << 2) & 074))];
|
|
hunk[3] = uuemap[0];
|
|
sv_catpvn(sv, hunk, 4);
|
|
}
|
|
sv_catpvn(sv, "\n", 1);
|
|
}
|
|
|
|
STATIC SV *
|
|
is_an_int(char *s, STRLEN l)
|
|
{
|
|
STRLEN n_a;
|
|
SV *result = newSVpv("", l);
|
|
char *result_c = SvPV(result, n_a); /* convenience */
|
|
char *out = result_c;
|
|
bool skip = 1;
|
|
bool ignore = 0;
|
|
|
|
while (*s) {
|
|
switch (*s) {
|
|
case ' ':
|
|
break;
|
|
case '+':
|
|
if (!skip) {
|
|
SvREFCNT_dec(result);
|
|
return (NULL);
|
|
}
|
|
break;
|
|
case '0':
|
|
case '1':
|
|
case '2':
|
|
case '3':
|
|
case '4':
|
|
case '5':
|
|
case '6':
|
|
case '7':
|
|
case '8':
|
|
case '9':
|
|
skip = 0;
|
|
if (!ignore) {
|
|
*(out++) = *s;
|
|
}
|
|
break;
|
|
case '.':
|
|
ignore = 1;
|
|
break;
|
|
default:
|
|
SvREFCNT_dec(result);
|
|
return (NULL);
|
|
}
|
|
s++;
|
|
}
|
|
*(out++) = '\0';
|
|
SvCUR_set(result, out - result_c);
|
|
return (result);
|
|
}
|
|
|
|
STATIC int
|
|
div128(SV *pnum, bool *done)
|
|
/* must be '\0' terminated */
|
|
|
|
{
|
|
STRLEN len;
|
|
char *s = SvPV(pnum, len);
|
|
int m = 0;
|
|
int r = 0;
|
|
char *t = s;
|
|
|
|
*done = 1;
|
|
while (*t) {
|
|
int i;
|
|
|
|
i = m * 10 + (*t - '0');
|
|
m = i & 0x7F;
|
|
r = (i >> 7); /* r < 10 */
|
|
if (r) {
|
|
*done = 0;
|
|
}
|
|
*(t++) = '0' + r;
|
|
}
|
|
*(t++) = '\0';
|
|
SvCUR_set(pnum, (STRLEN) (t - s));
|
|
return (m);
|
|
}
|
|
|
|
|
|
PP(pp_pack)
|
|
{
|
|
djSP; dMARK; dORIGMARK; dTARGET;
|
|
register SV *cat = TARG;
|
|
register I32 items;
|
|
STRLEN fromlen;
|
|
register char *pat = SvPVx(*++MARK, fromlen);
|
|
register char *patend = pat + fromlen;
|
|
register I32 len;
|
|
I32 datumtype;
|
|
SV *fromstr;
|
|
/*SUPPRESS 442*/
|
|
static char null10[] = {0,0,0,0,0,0,0,0,0,0};
|
|
static char *space10 = " ";
|
|
|
|
/* These must not be in registers: */
|
|
char achar;
|
|
I16 ashort;
|
|
int aint;
|
|
unsigned int auint;
|
|
I32 along;
|
|
U32 aulong;
|
|
#ifdef HAS_QUAD
|
|
Quad_t aquad;
|
|
unsigned Quad_t auquad;
|
|
#endif
|
|
char *aptr;
|
|
float afloat;
|
|
double adouble;
|
|
int commas = 0;
|
|
|
|
items = SP - MARK;
|
|
MARK++;
|
|
sv_setpvn(cat, "", 0);
|
|
while (pat < patend) {
|
|
#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
|
|
datumtype = *pat++ & 0xFF;
|
|
if (isSPACE(datumtype))
|
|
continue;
|
|
if (*pat == '*') {
|
|
len = strchr("@Xxu", datumtype) ? 0 : items;
|
|
pat++;
|
|
}
|
|
else if (isDIGIT(*pat)) {
|
|
len = *pat++ - '0';
|
|
while (isDIGIT(*pat))
|
|
len = (len * 10) + (*pat++ - '0');
|
|
}
|
|
else
|
|
len = 1;
|
|
switch(datumtype) {
|
|
default:
|
|
croak("Invalid type in pack: '%c'", (int)datumtype);
|
|
case ',': /* grandfather in commas but with a warning */
|
|
if (commas++ == 0 && PL_dowarn)
|
|
warn("Invalid type in pack: '%c'", (int)datumtype);
|
|
break;
|
|
case '%':
|
|
DIE("%% may only be used in unpack");
|
|
case '@':
|
|
len -= SvCUR(cat);
|
|
if (len > 0)
|
|
goto grow;
|
|
len = -len;
|
|
if (len > 0)
|
|
goto shrink;
|
|
break;
|
|
case 'X':
|
|
shrink:
|
|
if (SvCUR(cat) < len)
|
|
DIE("X outside of string");
|
|
SvCUR(cat) -= len;
|
|
*SvEND(cat) = '\0';
|
|
break;
|
|
case 'x':
|
|
grow:
|
|
while (len >= 10) {
|
|
sv_catpvn(cat, null10, 10);
|
|
len -= 10;
|
|
}
|
|
sv_catpvn(cat, null10, len);
|
|
break;
|
|
case 'A':
|
|
case 'Z':
|
|
case 'a':
|
|
fromstr = NEXTFROM;
|
|
aptr = SvPV(fromstr, fromlen);
|
|
if (pat[-1] == '*')
|
|
len = fromlen;
|
|
if (fromlen > len)
|
|
sv_catpvn(cat, aptr, len);
|
|
else {
|
|
sv_catpvn(cat, aptr, fromlen);
|
|
len -= fromlen;
|
|
if (datumtype == 'A') {
|
|
while (len >= 10) {
|
|
sv_catpvn(cat, space10, 10);
|
|
len -= 10;
|
|
}
|
|
sv_catpvn(cat, space10, len);
|
|
}
|
|
else {
|
|
while (len >= 10) {
|
|
sv_catpvn(cat, null10, 10);
|
|
len -= 10;
|
|
}
|
|
sv_catpvn(cat, null10, len);
|
|
}
|
|
}
|
|
break;
|
|
case 'B':
|
|
case 'b':
|
|
{
|
|
char *savepat = pat;
|
|
I32 saveitems;
|
|
|
|
fromstr = NEXTFROM;
|
|
saveitems = items;
|
|
aptr = SvPV(fromstr, fromlen);
|
|
if (pat[-1] == '*')
|
|
len = fromlen;
|
|
pat = aptr;
|
|
aint = SvCUR(cat);
|
|
SvCUR(cat) += (len+7)/8;
|
|
SvGROW(cat, SvCUR(cat) + 1);
|
|
aptr = SvPVX(cat) + aint;
|
|
if (len > fromlen)
|
|
len = fromlen;
|
|
aint = len;
|
|
items = 0;
|
|
if (datumtype == 'B') {
|
|
for (len = 0; len++ < aint;) {
|
|
items |= *pat++ & 1;
|
|
if (len & 7)
|
|
items <<= 1;
|
|
else {
|
|
*aptr++ = items & 0xff;
|
|
items = 0;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
for (len = 0; len++ < aint;) {
|
|
if (*pat++ & 1)
|
|
items |= 128;
|
|
if (len & 7)
|
|
items >>= 1;
|
|
else {
|
|
*aptr++ = items & 0xff;
|
|
items = 0;
|
|
}
|
|
}
|
|
}
|
|
if (aint & 7) {
|
|
if (datumtype == 'B')
|
|
items <<= 7 - (aint & 7);
|
|
else
|
|
items >>= 7 - (aint & 7);
|
|
*aptr++ = items & 0xff;
|
|
}
|
|
pat = SvPVX(cat) + SvCUR(cat);
|
|
while (aptr <= pat)
|
|
*aptr++ = '\0';
|
|
|
|
pat = savepat;
|
|
items = saveitems;
|
|
}
|
|
break;
|
|
case 'H':
|
|
case 'h':
|
|
{
|
|
char *savepat = pat;
|
|
I32 saveitems;
|
|
|
|
fromstr = NEXTFROM;
|
|
saveitems = items;
|
|
aptr = SvPV(fromstr, fromlen);
|
|
if (pat[-1] == '*')
|
|
len = fromlen;
|
|
pat = aptr;
|
|
aint = SvCUR(cat);
|
|
SvCUR(cat) += (len+1)/2;
|
|
SvGROW(cat, SvCUR(cat) + 1);
|
|
aptr = SvPVX(cat) + aint;
|
|
if (len > fromlen)
|
|
len = fromlen;
|
|
aint = len;
|
|
items = 0;
|
|
if (datumtype == 'H') {
|
|
for (len = 0; len++ < aint;) {
|
|
if (isALPHA(*pat))
|
|
items |= ((*pat++ & 15) + 9) & 15;
|
|
else
|
|
items |= *pat++ & 15;
|
|
if (len & 1)
|
|
items <<= 4;
|
|
else {
|
|
*aptr++ = items & 0xff;
|
|
items = 0;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
for (len = 0; len++ < aint;) {
|
|
if (isALPHA(*pat))
|
|
items |= (((*pat++ & 15) + 9) & 15) << 4;
|
|
else
|
|
items |= (*pat++ & 15) << 4;
|
|
if (len & 1)
|
|
items >>= 4;
|
|
else {
|
|
*aptr++ = items & 0xff;
|
|
items = 0;
|
|
}
|
|
}
|
|
}
|
|
if (aint & 1)
|
|
*aptr++ = items & 0xff;
|
|
pat = SvPVX(cat) + SvCUR(cat);
|
|
while (aptr <= pat)
|
|
*aptr++ = '\0';
|
|
|
|
pat = savepat;
|
|
items = saveitems;
|
|
}
|
|
break;
|
|
case 'C':
|
|
case 'c':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
aint = SvIV(fromstr);
|
|
achar = aint;
|
|
sv_catpvn(cat, &achar, sizeof(char));
|
|
}
|
|
break;
|
|
/* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
|
|
case 'f':
|
|
case 'F':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
afloat = (float)SvNV(fromstr);
|
|
sv_catpvn(cat, (char *)&afloat, sizeof (float));
|
|
}
|
|
break;
|
|
case 'd':
|
|
case 'D':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
adouble = (double)SvNV(fromstr);
|
|
sv_catpvn(cat, (char *)&adouble, sizeof (double));
|
|
}
|
|
break;
|
|
case 'n':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
ashort = (I16)SvIV(fromstr);
|
|
#ifdef HAS_HTONS
|
|
ashort = PerlSock_htons(ashort);
|
|
#endif
|
|
CAT16(cat, &ashort);
|
|
}
|
|
break;
|
|
case 'v':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
ashort = (I16)SvIV(fromstr);
|
|
#ifdef HAS_HTOVS
|
|
ashort = htovs(ashort);
|
|
#endif
|
|
CAT16(cat, &ashort);
|
|
}
|
|
break;
|
|
case 'S':
|
|
case 's':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
ashort = (I16)SvIV(fromstr);
|
|
CAT16(cat, &ashort);
|
|
}
|
|
break;
|
|
case 'I':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
auint = SvUV(fromstr);
|
|
sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
|
|
}
|
|
break;
|
|
case 'w':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
adouble = floor(SvNV(fromstr));
|
|
|
|
if (adouble < 0)
|
|
croak("Cannot compress negative numbers");
|
|
|
|
if (
|
|
#ifdef BW_BITS
|
|
adouble <= BW_MASK
|
|
#else
|
|
#ifdef CXUX_BROKEN_CONSTANT_CONVERT
|
|
adouble <= UV_MAX_cxux
|
|
#else
|
|
adouble <= UV_MAX
|
|
#endif
|
|
#endif
|
|
)
|
|
{
|
|
char buf[1 + sizeof(UV)];
|
|
char *in = buf + sizeof(buf);
|
|
UV auv = U_V(adouble);;
|
|
|
|
do {
|
|
*--in = (auv & 0x7f) | 0x80;
|
|
auv >>= 7;
|
|
} while (auv);
|
|
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
|
|
sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
|
|
}
|
|
else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
|
|
char *from, *result, *in;
|
|
SV *norm;
|
|
STRLEN len;
|
|
bool done;
|
|
|
|
/* Copy string and check for compliance */
|
|
from = SvPV(fromstr, len);
|
|
if ((norm = is_an_int(from, len)) == NULL)
|
|
croak("can compress only unsigned integer");
|
|
|
|
New('w', result, len, char);
|
|
in = result + len;
|
|
done = FALSE;
|
|
while (!done)
|
|
*--in = div128(norm, &done) | 0x80;
|
|
result[len - 1] &= 0x7F; /* clear continue bit */
|
|
sv_catpvn(cat, in, (result + len) - in);
|
|
Safefree(result);
|
|
SvREFCNT_dec(norm); /* free norm */
|
|
}
|
|
else if (SvNOKp(fromstr)) {
|
|
char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
|
|
char *in = buf + sizeof(buf);
|
|
|
|
do {
|
|
double next = floor(adouble / 128);
|
|
*--in = (unsigned char)(adouble - (next * 128)) | 0x80;
|
|
if (--in < buf) /* this cannot happen ;-) */
|
|
croak ("Cannot compress integer");
|
|
adouble = next;
|
|
} while (adouble > 0);
|
|
buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
|
|
sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
|
|
}
|
|
else
|
|
croak("Cannot compress non integer");
|
|
}
|
|
break;
|
|
case 'i':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
aint = SvIV(fromstr);
|
|
sv_catpvn(cat, (char*)&aint, sizeof(int));
|
|
}
|
|
break;
|
|
case 'N':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
aulong = SvUV(fromstr);
|
|
#ifdef HAS_HTONL
|
|
aulong = PerlSock_htonl(aulong);
|
|
#endif
|
|
CAT32(cat, &aulong);
|
|
}
|
|
break;
|
|
case 'V':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
aulong = SvUV(fromstr);
|
|
#ifdef HAS_HTOVL
|
|
aulong = htovl(aulong);
|
|
#endif
|
|
CAT32(cat, &aulong);
|
|
}
|
|
break;
|
|
case 'L':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
aulong = SvUV(fromstr);
|
|
CAT32(cat, &aulong);
|
|
}
|
|
break;
|
|
case 'l':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
along = SvIV(fromstr);
|
|
CAT32(cat, &along);
|
|
}
|
|
break;
|
|
#ifdef HAS_QUAD
|
|
case 'Q':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
auquad = (unsigned Quad_t)SvIV(fromstr);
|
|
sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
|
|
}
|
|
break;
|
|
case 'q':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
aquad = (Quad_t)SvIV(fromstr);
|
|
sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
|
|
}
|
|
break;
|
|
#endif /* HAS_QUAD */
|
|
case 'P':
|
|
len = 1; /* assume SV is correct length */
|
|
/* FALL THROUGH */
|
|
case 'p':
|
|
while (len-- > 0) {
|
|
fromstr = NEXTFROM;
|
|
if (fromstr == &PL_sv_undef)
|
|
aptr = NULL;
|
|
else {
|
|
STRLEN n_a;
|
|
/* XXX better yet, could spirit away the string to
|
|
* a safe spot and hang on to it until the result
|
|
* of pack() (and all copies of the result) are
|
|
* gone.
|
|
*/
|
|
if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
|
|
warn("Attempt to pack pointer to temporary value");
|
|
if (SvPOK(fromstr) || SvNIOK(fromstr))
|
|
aptr = SvPV(fromstr,n_a);
|
|
else
|
|
aptr = SvPV_force(fromstr,n_a);
|
|
}
|
|
sv_catpvn(cat, (char*)&aptr, sizeof(char*));
|
|
}
|
|
break;
|
|
case 'u':
|
|
fromstr = NEXTFROM;
|
|
aptr = SvPV(fromstr, fromlen);
|
|
SvGROW(cat, fromlen * 4 / 3);
|
|
if (len <= 1)
|
|
len = 45;
|
|
else
|
|
len = len / 3 * 3;
|
|
while (fromlen > 0) {
|
|
I32 todo;
|
|
|
|
if (fromlen > len)
|
|
todo = len;
|
|
else
|
|
todo = fromlen;
|
|
doencodes(cat, aptr, todo);
|
|
fromlen -= todo;
|
|
aptr += todo;
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
SvSETMAGIC(cat);
|
|
SP = ORIGMARK;
|
|
PUSHs(cat);
|
|
RETURN;
|
|
}
|
|
#undef NEXTFROM
|
|
|
|
|
|
PP(pp_split)
|
|
{
|
|
djSP; dTARG;
|
|
AV *ary;
|
|
register I32 limit = POPi; /* note, negative is forever */
|
|
SV *sv = POPs;
|
|
STRLEN len;
|
|
register char *s = SvPV(sv, len);
|
|
char *strend = s + len;
|
|
register PMOP *pm;
|
|
register REGEXP *rx;
|
|
register SV *dstr;
|
|
register char *m;
|
|
I32 iters = 0;
|
|
I32 maxiters = (strend - s) + 10;
|
|
I32 i;
|
|
char *orig;
|
|
I32 origlimit = limit;
|
|
I32 realarray = 0;
|
|
I32 base;
|
|
AV *oldstack = PL_curstack;
|
|
I32 gimme = GIMME_V;
|
|
I32 oldsave = PL_savestack_ix;
|
|
I32 make_mortal = 1;
|
|
MAGIC *mg = (MAGIC *) NULL;
|
|
|
|
#ifdef DEBUGGING
|
|
Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
|
|
#else
|
|
pm = (PMOP*)POPs;
|
|
#endif
|
|
if (!pm || !s)
|
|
DIE("panic: do_split");
|
|
rx = pm->op_pmregexp;
|
|
|
|
TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
|
|
(pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
|
|
|
|
if (pm->op_pmreplroot)
|
|
ary = GvAVn((GV*)pm->op_pmreplroot);
|
|
else if (gimme != G_ARRAY)
|
|
#ifdef USE_THREADS
|
|
ary = (AV*)PL_curpad[0];
|
|
#else
|
|
ary = GvAVn(PL_defgv);
|
|
#endif /* USE_THREADS */
|
|
else
|
|
ary = Nullav;
|
|
if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
|
|
realarray = 1;
|
|
PUTBACK;
|
|
av_extend(ary,0);
|
|
av_clear(ary);
|
|
SPAGAIN;
|
|
if (mg = SvTIED_mg((SV*)ary, 'P')) {
|
|
PUSHMARK(SP);
|
|
XPUSHs(SvTIED_obj((SV*)ary, mg));
|
|
}
|
|
else {
|
|
if (!AvREAL(ary)) {
|
|
AvREAL_on(ary);
|
|
for (i = AvFILLp(ary); i >= 0; i--)
|
|
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
|
|
}
|
|
/* temporarily switch stacks */
|
|
SWITCHSTACK(PL_curstack, ary);
|
|
make_mortal = 0;
|
|
}
|
|
}
|
|
base = SP - PL_stack_base;
|
|
orig = s;
|
|
if (pm->op_pmflags & PMf_SKIPWHITE) {
|
|
if (pm->op_pmflags & PMf_LOCALE) {
|
|
while (isSPACE_LC(*s))
|
|
s++;
|
|
}
|
|
else {
|
|
while (isSPACE(*s))
|
|
s++;
|
|
}
|
|
}
|
|
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
|
|
SAVEINT(PL_multiline);
|
|
PL_multiline = pm->op_pmflags & PMf_MULTILINE;
|
|
}
|
|
|
|
if (!limit)
|
|
limit = maxiters + 2;
|
|
if (pm->op_pmflags & PMf_WHITE) {
|
|
while (--limit) {
|
|
m = s;
|
|
while (m < strend &&
|
|
!((pm->op_pmflags & PMf_LOCALE)
|
|
? isSPACE_LC(*m) : isSPACE(*m)))
|
|
++m;
|
|
if (m >= strend)
|
|
break;
|
|
|
|
dstr = NEWSV(30, m-s);
|
|
sv_setpvn(dstr, s, m-s);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
|
|
s = m + 1;
|
|
while (s < strend &&
|
|
((pm->op_pmflags & PMf_LOCALE)
|
|
? isSPACE_LC(*s) : isSPACE(*s)))
|
|
++s;
|
|
}
|
|
}
|
|
else if (strEQ("^", rx->precomp)) {
|
|
while (--limit) {
|
|
/*SUPPRESS 530*/
|
|
for (m = s; m < strend && *m != '\n'; m++) ;
|
|
m++;
|
|
if (m >= strend)
|
|
break;
|
|
dstr = NEWSV(30, m-s);
|
|
sv_setpvn(dstr, s, m-s);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
s = m;
|
|
}
|
|
}
|
|
else if (rx->check_substr && !rx->nparens
|
|
&& (rx->reganch & ROPT_CHECK_ALL)
|
|
&& !(rx->reganch & ROPT_ANCH)) {
|
|
i = SvCUR(rx->check_substr);
|
|
if (i == 1 && !SvTAIL(rx->check_substr)) {
|
|
i = *SvPVX(rx->check_substr);
|
|
while (--limit) {
|
|
/*SUPPRESS 530*/
|
|
for (m = s; m < strend && *m != i; m++) ;
|
|
if (m >= strend)
|
|
break;
|
|
dstr = NEWSV(30, m-s);
|
|
sv_setpvn(dstr, s, m-s);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
s = m + 1;
|
|
}
|
|
}
|
|
else {
|
|
#ifndef lint
|
|
while (s < strend && --limit &&
|
|
(m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
|
|
rx->check_substr, 0)) )
|
|
#endif
|
|
{
|
|
dstr = NEWSV(31, m-s);
|
|
sv_setpvn(dstr, s, m-s);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
s = m + i;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
maxiters += (strend - s) * rx->nparens;
|
|
while (s < strend && --limit &&
|
|
CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
|
|
{
|
|
TAINT_IF(RX_MATCH_TAINTED(rx));
|
|
if (rx->subbase
|
|
&& rx->subbase != orig) {
|
|
m = s;
|
|
s = orig;
|
|
orig = rx->subbase;
|
|
s = orig + (m - s);
|
|
strend = s + (strend - m);
|
|
}
|
|
m = rx->startp[0];
|
|
dstr = NEWSV(32, m-s);
|
|
sv_setpvn(dstr, s, m-s);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
if (rx->nparens) {
|
|
for (i = 1; i <= rx->nparens; i++) {
|
|
s = rx->startp[i];
|
|
m = rx->endp[i];
|
|
if (m && s) {
|
|
dstr = NEWSV(33, m-s);
|
|
sv_setpvn(dstr, s, m-s);
|
|
}
|
|
else
|
|
dstr = NEWSV(33, 0);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
}
|
|
}
|
|
s = rx->endp[0];
|
|
}
|
|
}
|
|
|
|
LEAVE_SCOPE(oldsave);
|
|
iters = (SP - PL_stack_base) - base;
|
|
if (iters > maxiters)
|
|
DIE("Split loop");
|
|
|
|
/* keep field after final delim? */
|
|
if (s < strend || (iters && origlimit)) {
|
|
dstr = NEWSV(34, strend-s);
|
|
sv_setpvn(dstr, s, strend-s);
|
|
if (make_mortal)
|
|
sv_2mortal(dstr);
|
|
XPUSHs(dstr);
|
|
iters++;
|
|
}
|
|
else if (!origlimit) {
|
|
while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
|
|
iters--, SP--;
|
|
}
|
|
|
|
if (realarray) {
|
|
if (!mg) {
|
|
SWITCHSTACK(ary, oldstack);
|
|
if (SvSMAGICAL(ary)) {
|
|
PUTBACK;
|
|
mg_set((SV*)ary);
|
|
SPAGAIN;
|
|
}
|
|
if (gimme == G_ARRAY) {
|
|
EXTEND(SP, iters);
|
|
Copy(AvARRAY(ary), SP + 1, iters, SV*);
|
|
SP += iters;
|
|
RETURN;
|
|
}
|
|
}
|
|
else {
|
|
PUTBACK;
|
|
ENTER;
|
|
perl_call_method("PUSH",G_SCALAR|G_DISCARD);
|
|
LEAVE;
|
|
SPAGAIN;
|
|
if (gimme == G_ARRAY) {
|
|
/* EXTEND should not be needed - we just popped them */
|
|
EXTEND(SP, iters);
|
|
for (i=0; i < iters; i++) {
|
|
SV **svp = av_fetch(ary, i, FALSE);
|
|
PUSHs((svp) ? *svp : &PL_sv_undef);
|
|
}
|
|
RETURN;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
if (gimme == G_ARRAY)
|
|
RETURN;
|
|
}
|
|
if (iters || !pm->op_pmreplroot) {
|
|
GETTARGET;
|
|
PUSHi(iters);
|
|
RETURN;
|
|
}
|
|
RETPUSHUNDEF;
|
|
}
|
|
|
|
#ifdef USE_THREADS
|
|
void
|
|
unlock_condpair(void *svv)
|
|
{
|
|
dTHR;
|
|
MAGIC *mg = mg_find((SV*)svv, 'm');
|
|
|
|
if (!mg)
|
|
croak("panic: unlock_condpair unlocking non-mutex");
|
|
MUTEX_LOCK(MgMUTEXP(mg));
|
|
if (MgOWNER(mg) != thr)
|
|
croak("panic: unlock_condpair unlocking mutex that we don't own");
|
|
MgOWNER(mg) = 0;
|
|
COND_SIGNAL(MgOWNERCONDP(mg));
|
|
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
|
|
(unsigned long)thr, (unsigned long)svv);)
|
|
MUTEX_UNLOCK(MgMUTEXP(mg));
|
|
}
|
|
#endif /* USE_THREADS */
|
|
|
|
PP(pp_lock)
|
|
{
|
|
djSP;
|
|
dTOPss;
|
|
SV *retsv = sv;
|
|
#ifdef USE_THREADS
|
|
MAGIC *mg;
|
|
|
|
if (SvROK(sv))
|
|
sv = SvRV(sv);
|
|
|
|
mg = condpair_magic(sv);
|
|
MUTEX_LOCK(MgMUTEXP(mg));
|
|
if (MgOWNER(mg) == thr)
|
|
MUTEX_UNLOCK(MgMUTEXP(mg));
|
|
else {
|
|
while (MgOWNER(mg))
|
|
COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
|
|
MgOWNER(mg) = thr;
|
|
DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
|
|
(unsigned long)thr, (unsigned long)sv);)
|
|
MUTEX_UNLOCK(MgMUTEXP(mg));
|
|
save_destructor(unlock_condpair, sv);
|
|
}
|
|
#endif /* USE_THREADS */
|
|
if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
|
|
|| SvTYPE(retsv) == SVt_PVCV) {
|
|
retsv = refto(retsv);
|
|
}
|
|
SETs(retsv);
|
|
RETURN;
|
|
}
|
|
|
|
PP(pp_threadsv)
|
|
{
|
|
djSP;
|
|
#ifdef USE_THREADS
|
|
EXTEND(SP, 1);
|
|
if (PL_op->op_private & OPpLVAL_INTRO)
|
|
PUSHs(*save_threadsv(PL_op->op_targ));
|
|
else
|
|
PUSHs(THREADSV(PL_op->op_targ));
|
|
RETURN;
|
|
#else
|
|
DIE("tried to access per-thread data in non-threaded perl");
|
|
#endif /* USE_THREADS */
|
|
}
|