#define FCALL *f
+#ifdef __Lynx__
+/* Missing proto on LynxOS */
+ char *gconvert(double, int, int, char *);
+#endif
+
#ifdef PERL_UTF8_CACHE_ASSERT
/* The cache element 0 is the Unicode offset;
* the cache element 1 is the byte offset of the element 0;
SV* sva = (SV*)ptr;
register SV* sv;
register SV* svend;
- Zero(ptr, size, char);
/* The first SV in an arena isn't an SV. */
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
sv = sva + 1;
while (sv < svend) {
SvANY(sv) = (void *)(SV*)(sv + 1);
+ SvREFCNT(sv) = 0;
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
p = "???";
else if (!HvNAME(hv))
p = "__ANON__";
- else
+ else
p = HvNAME(hv);
if (strNE(p, "main")) {
sv_catpv(name,p);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
*SvPVX(name) = '$';
- Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", aindex);
+ Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
}
else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
sv_insert(name, 0, 0, "within ", 7);
gv = cGVOPx_gv(o);
if (match && GvSV(gv) != uninit_sv)
break;
- return S_varname(aTHX_ gv, "$", 0,
+ return S_varname(aTHX_ gv, "$", 0,
Nullsv, 0, FUV_SUBSCRIPT_NONE);
}
/* other possibilities not handled are:
goto do_op2;
+ case OP_RV2SV:
case OP_CUSTOM:
case OP_ENTERSUB:
match = 1; /* XS or custom code could trigger random warnings */
Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
}
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= mt;
+
switch (mt) {
case SVt_NULL:
Perl_croak(aTHX_ "Can't upgrade to undef");
IoPAGE_LEN(sv) = 60;
break;
}
- SvFLAGS(sv) &= ~SVTYPEMASK;
- SvFLAGS(sv) |= mt;
return TRUE;
}
/*
=for apidoc sv_utf8_upgrade
-Convert the PV of an SV to its UTF-8-encoded form.
+Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
=for apidoc sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF-8-encoded form.
+Converts the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
U8 *s, *t, *e;
int hibit = 0;
- if (!sv)
+ if (sv == &PL_sv_undef)
return 0;
-
if (!SvPOK(sv)) {
STRLEN len = 0;
- (void) sv_2pv_flags(sv,&len, flags);
- if (!SvPOK(sv))
- return len;
+ if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
+ (void) sv_2pv_flags(sv,&len, flags);
+ if (SvUTF8(sv))
+ return len;
+ } else {
+ (void) SvPV_force(sv,len);
+ }
}
- if (SvUTF8(sv))
+ if (SvUTF8(sv)) {
return SvCUR(sv);
+ }
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
/*
=for apidoc sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
-This may not be possible if the PV contains non-byte encoding characters;
-if this is the case, either returns false or, if C<fail_ok> is not
+Attempts to convert the PV of an SV from characters to bytes.
+If the PV contains a character beyond byte, this conversion will fail;
+in this case, either returns false or, if C<fail_ok> is not
true, croaks.
This is not as a general purpose Unicode to byte encoding interface:
bool
Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
{
- if (SvPOK(sv) && SvUTF8(sv)) {
+ if (SvPOKp(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
U8 *s;
STRLEN len;
/*
=for apidoc sv_utf8_encode
-Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
-flag so that it looks like octets again. Used as a building block
-for encode_utf8 in Encode.xs
+Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
+flag off so that it looks like octets again.
=cut
*/
/*
=for apidoc sv_utf8_decode
-Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
-turn off SvUTF8 if needed so that we see characters. Used as a building block
-for decode_utf8 in Encode.xs
+If the PV of the SV is an octet sequence in UTF-8
+and contains a multiple-byte character, the C<SvUTF8> flag is turned on
+so that it looks like a character. If the PV contains only single-byte
+characters, the C<SvUTF8> flag stays being off.
+Scans PV for validity and returns false if the PV is invalid UTF-8.
=cut
*/
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
- if (SvPOK(sv)) {
+ if (SvPOKp(sv)) {
U8 *c;
U8 *e;
dtype = SvTYPE(dstr);
SvAMAGIC_off(dstr);
- if ( SvVOK(dstr) )
+ if ( SvVOK(dstr) )
{
/* need to nuke the magic */
mg_free(dstr);
SvIVX(dstr) = SvIVX(sstr);
}
if (SvVOK(sstr)) {
- MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
+ MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
sv_magic(dstr, NULL, PERL_MAGIC_vstring,
smg->mg_ptr, smg->mg_len);
SvRMAGICAL_on(dstr);
- }
+ }
}
else if (sflags & SVp_IOK) {
if (sflags & SVf_IOK)
=for apidoc sv_setpvn
Copies a string into an SV. The C<len> parameter indicates the number of
-bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
+bytes to be copied. If the C<ptr> argument is NULL the SV will become
+undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
=cut
*/
if (len) { /* this SV was SvIsCOW_normal(sv) */
/* we need to find the SV pointing to us. */
SV *current = SV_COW_NEXT_SV(after);
-
+
if (current == sv) {
/* The SV we point to points back to us (there were only two of us
in the loop.)
/* Same SvOOK_on but SvOOK_on does a SvIOK_off
and we do that anyway inside the SvNIOK_off
*/
- SvFLAGS(sv) |= SVf_OOK;
+ SvFLAGS(sv) |= SVf_OOK;
}
SvNIOK_off(sv);
SvLEN(sv) -= delta;
PUSHs(tmpref);
PUTBACK;
call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
-
-
+
+
POPSTACK;
SPAGAIN;
LEAVE;
* The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
* mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
* (Note that the mg_len is not the length of the mg_ptr field.)
- *
+ *
*/
STRLEN
STATIC bool
S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
{
- bool found = FALSE;
+ bool found = FALSE;
if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
if (!*mgp)
*cachep = (STRLEN *) (*mgp)->mg_ptr;
ASSERT_UTF8_CACHE(*cachep);
if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
- found = TRUE;
+ found = TRUE;
else { /* We will skip to the right spot. */
STRLEN forw = 0;
STRLEN backw = 0;
(*cachep)[2] = 0;
(*cachep)[3] = 0;
}
-
+
found = TRUE;
}
}
return found;
}
-
+
/*
=for apidoc sv_pos_u2b
s += UTF8SKIP(s);
if (s >= send)
s = send;
- if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
- cache[2] += *offsetp;
+ utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
}
*lenp = s - start;
}
/* We already know part of the way. */
len = cache[0];
s += cache[1];
- /* Let the below loop do the rest. */
+ /* Let the below loop do the rest. */
}
else { /* cache[1] > *offsetp */
/* We already know all of the way, now we may
if (!(forw < 2 * backw)) {
U8 *p = s + cache[1];
STRLEN ubackw = 0;
-
+
cache[1] -= backw;
while (backw--) {
cache[0] -= ubackw;
*offsetp = cache[0];
+
+ /* Drop the stale "length" cache */
+ cache[2] = 0;
+ cache[3] = 0;
+
return;
}
}
cache[0] = len;
cache[1] = *offsetp;
+ /* Drop the stale "length" cache */
+ cache[2] = 0;
+ cache[3] = 0;
}
*offsetp = len;
pv1 = SvPV(svrecode, cur1);
}
/* Now both are in UTF-8. */
- if (cur1 != cur2)
+ if (cur1 != cur2) {
+ SvREFCNT_dec(svrecode);
return FALSE;
+ }
}
else {
bool is_utf8 = TRUE;
}
if (is_utf8) {
/* Downgrade not possible - cannot be eq */
+ assert (tpv == 0);
return FALSE;
}
}
rslen = 1;
}
else if (RsSNARF(PL_rs)) {
- /* If it is a regular disk file use size from stat() as estimate
- of amount we are going to read - may result in malloc-ing
- more memory than we realy need if layers bellow reduce
+ /* If it is a regular disk file use size from stat() as estimate
+ of amount we are going to read - may result in malloc-ing
+ more memory than we realy need if layers bellow reduce
size we read (e.g. CRLF or a gzip layer)
*/
Stat_t st;
cnt = PerlIO_get_cnt(fp); /* get count into register */
/* make sure we have the room */
- if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
/* Not room for all of it
- if we are looking for a separator and room for some
+ if we are looking for a separator and room for some
*/
if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
- /* just process what we have room for */
+ /* just process what we have room for */
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
Marks an existing SV as mortal. The SV will be destroyed "soon", either
by an explicit call to FREETMPS, or by an implicit call at places such as
-statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
+statement boundaries. SvTEMP() is turned on which means that the SV's
+string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
+and C<sv_mortalcopy>.
=cut
*/
Creates a new SV and copies a string into it. The reference count for the
SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
string. You are responsible for ensuring that the source string is at least
-C<len> bytes long.
+C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
=cut
*/
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will have a reference count
+C<Nullch> to avoid the blessing. The new SV will have a reference count
of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
}
if (!asterisk)
- if( *q == '0' )
+ if( *q == '0' )
fill = *q++;
EXPECT_NUMBER(q, width);
}
/* Use memchr() instead of strchr(), as eptr is not guaranteed */
/* to point to a null-terminated string. */
- if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
- (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
+ if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
+ (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
Perl_warner(aTHX_ packWARN(WARN_PRINTF),
"Newline in left-justified string for %sprintf",
(PL_op->op_type == OP_PRTF) ? "" : "s");
return tbl;
}
+#if (PTRSIZE == 8)
+# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
+#else
+# define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
+#endif
+
/* map an existing pointer using a table */
void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
{
PTR_TBL_ENT_t *tblent;
- UV hash = PTR2UV(sv);
+ UV hash = PTR_TABLE_HASH(sv);
assert(tbl);
tblent = tbl->tbl_ary[hash & tbl->tbl_max];
for (; tblent; tblent = tblent->next) {
/* XXX this may be pessimal on platforms where pointers aren't good
* hash values e.g. if they grow faster in the most significant
* bits */
- UV hash = PTR2UV(oldv);
- bool i = 1;
+ UV hash = PTR_TABLE_HASH(oldv);
+ bool empty = 1;
assert(tbl);
otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
- for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
+ for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
if (tblent->oldval == oldv) {
tblent->newval = newv;
return;
tblent->next = *otblent;
*otblent = tblent;
tbl->tbl_items++;
- if (i && tbl->tbl_items > tbl->tbl_max)
+ if (!empty && tbl->tbl_items > tbl->tbl_max)
ptr_table_split(tbl);
}
continue;
curentp = ary + oldsize;
for (entp = ary, ent = *ary; ent; ent = *entp) {
- if ((newsize & PTR2UV(ent->oldval)) != i) {
+ if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
*entp = ent->next;
ent->next = *curentp;
*curentp = ent;
IoPAGE(dstr) = IoPAGE(sstr);
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
- if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
+ if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
/* I have no idea why fake dirp (rsfps)
should be treaded differently but otherwise
we end up with leaks -- sky*/
perl_clone takes these flags as parameters:
-CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
-without it we only clone the data and zero the stacks,
-with it we copy the stacks and the new perl interpreter is
-ready to run at the exact same point as the previous one.
-The pseudo-fork code uses COPY_STACKS while the
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
threads->new doesn't.
CLONEf_KEEP_PTR_TABLE
-perl_clone keeps a ptr_table with the pointer of the old
-variable as a key and the new variable as a value,
-this allows it to check if something has been cloned and not
-clone it again but rather just use the value and increase the
-refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
-the ptr_table using the function
-C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
-reason to keep it around is if you want to dup some of your own
-variable who are outside the graph perl scans, example of this
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
code is in threads.xs create
CLONEf_CLONE_HOST
-This is a win32 thing, it is ignored on unix, it tells perls
-win32host code (which is c++) to clone itself, this is needed on
-win32 if you want to run two threads at the same time,
-if you just want to do some stuff in a separate perl interpreter
-and then throw it away and return to the original one,
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
you don't need to do anything.
=cut
EXTEND(SP, 3);
XPUSHs(encoding);
XPUSHs(sv);
-/*
+/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
- for Encode::XS, while UTf-8 decode (currently) assumes a true value means
+ for Encode::XS, while UTf-8 decode (currently) assumes a true value means
remove converted chars from source.
Both will default the value - let them.
-
+
XPUSHs(&PL_sv_yes);
*/
PUTBACK;
https://perl5.git.perl.org / perl5.git / blobdiff