Algorithm-AM
view release on metacpan or search on metacpan
const unsigned int ASCII_0 = 0x30;
const unsigned int DIVIDE_SPACE = 10;
const int OUTSPACE_SIZE = 55;
void normalize(pTHX_ SV *s) {
AM_LONG *p = (AM_LONG *)SvPVX(s);
AM_LONG dspace[DIVIDE_SPACE];
AM_LONG qspace[DIVIDE_SPACE];
AM_LONG *dividend, *quotient, *dptr, *qptr;
STRLEN length = SvCUR(s) / sizeof(AM_LONG);
/* length indexes into dspace and qspace */
assert(length <= DIVIDE_SPACE);
/*
* outptr iterates outspace from end to beginning, and an ASCII digit is inserted at each location.
* No need to 0-terminate, since we track the final string length in outlength and pass it to sv_setpvn.
*/
char outspace[OUTSPACE_SIZE];
char *outptr;
outptr = outspace + (OUTSPACE_SIZE - 1);
unsigned int outlength = 0;
/* TODO: is this required to be a certain number of bits? */
long double nn = 0;
/* nn will be assigned to the NV */
for (int j = 8; j; --j) {
/* 2^16 * nn + p[j-1] */
nn = 65536.0 * nn + (double) *(p + j - 1);
}
dividend = &dspace[0];
quotient = &qspace[0];
Copy(p, dividend, length, AM_LONG);
while (1) {
while (length && (*(dividend + length - 1) == 0)) {
--length;
}
if (length == 0) {
sv_setpvn(s, outptr, outlength);
break;
}
dptr = dividend + length - 1;
qptr = quotient + length - 1;
AM_LONG carry = 0;
while (dptr >= dividend) {
unsigned int i;
*dptr += carry << 16;
*qptr = 0;
for (i = 16; i; ) {
--i;
if (tens[i] <= *dptr) {
*dptr -= tens[i];
*qptr += ones[i];
}
}
carry = *dptr;
--dptr;
--qptr;
}
--outptr;
*outptr = (char)(ASCII_0 + *dividend) & 0x00ff;
++outlength;
AM_LONG *temp = dividend;
dividend = quotient;
quotient = temp;
}
SvNVX(s) = nn;
SvNOK_on(s);
}
/* Given 2 lists of training item indices sorted in descending order,
* the first two lists into the third via intersection, the final
* list is checked for heterogeneity and the non-deterministic
* heterogeneous supracontexts are removed.
* The return value is the number of items contained in the resulting
* list.
*/
AM_SHORT intersect_supras_final(
AM_SHORT *intersection_list_top, AM_SHORT *subcontext_list_top,
AM_SHORT *intersect, AM_SHORT *subcontext_class){
AM_SHORT class = 0;
AM_SHORT length = 0;
while (1) {
while (*intersection_list_top > *subcontext_list_top) {
--intersection_list_top;
}
if (*intersection_list_top == 0) {
break;
}
if (*intersection_list_top < *subcontext_list_top) {
AM_SHORT *temp = intersection_list_top;
intersection_list_top = subcontext_list_top;
subcontext_list_top = temp;
continue;
}
*intersect = *intersection_list_top;
++intersect;
++length;
/* is it heterogeneous? */
if (class == 0) {
/* is it not deterministic? */
if (length > 1) {
length = 0;
break;
} else {
class = subcontext_class[*intersection_list_top];
}
} else {
/* Do the classes not match? */
if (class != subcontext_class[*intersection_list_top]) {
length = 0;
break;
}
}
--intersection_list_top;
--subcontext_list_top;
}
return length;
}
/* clear out the supracontexts */
void clear_supras(AM_SUPRA **supra_list, int supras_length)
{
AM_SUPRA *p;
for (int i = 0; i < supras_length; i++)
{
for (iter_supras(p, supra_list[i]))
{
Safefree(p->data);
}
}
}
MODULE = Algorithm::AM PACKAGE = Algorithm::AM
continue;
}
*k = 0;
AM_SUPRA *p3;
for (iter_supras(p3, supra_list[3])) {
/* Find intersection between previous intersection and p3;
* check for disqualified supras this time.
*/
AM_SHORT length = intersect_supras_final(
ilist3top,
sublist_top(p3),
intersectlist,
subcontext_class
);
/* count occurrences */
if (length) {
AM_BIG_INT count = {0, 0, 0, 0, 0, 0, 0, 0};
count[0] = p0->count;
count[0] *= p1->count;
carry(count, 0);
count[0] *= p2->count;
count[1] *= p2->count;
carry(count, 0);
count[0] *= p3->count;
count[1] *= p3->count;
count[2] *= p3->count;
carry(count, 0);
carry(count, 1);
carry(count, 2);
if(!linear_flag){
/* If scoring is pointers (quadratic) instead of linear*/
AM_LONG pointercount = 0;
for (int i = 0; i < length; ++i) {
pointercount += (AM_LONG) SvUV(*hv_fetch(context_size,
(char *) (subcontext + (NUM_LATTICES * intersectlist[i])), 8, 0));
}
if (pointercount & 0xffff0000) {
AM_SHORT pchi = (AM_SHORT) (high_bits(pointercount));
AM_SHORT pclo = (AM_SHORT) (low_bits(pointercount));
AM_LONG hiprod[6];
hiprod[1] = pchi * count[0];
hiprod[2] = pchi * count[1];
hiprod[3] = pchi * count[2];
count[0] *= pointercount;
count[1] *= pointercount;
count[2] *= pointercount;
count[3] *= pointercount;
carry(count, 0);
carry(count, 1);
carry(count, 2);
carry(count, 3);
}
}
for (int i = 0; i < length; ++i) {
SV *final_pointers_sv = *hv_fetch(pointers,
(char *) (subcontext + (NUM_LATTICES * intersectlist[i])), 8, 1);
if (!SvPOK(final_pointers_sv)) {
SvUPGRADE(final_pointers_sv, SVt_PVNV);
SvGROW(final_pointers_sv, 8 * sizeof(AM_LONG) + 1);
Zero(SvPVX(final_pointers_sv), 8, AM_LONG);
SvCUR_set(final_pointers_sv, 8 * sizeof(AM_LONG));
SvPOK_on(final_pointers_sv);
}
AM_LONG *final_pointers = (AM_LONG *) SvPVX(final_pointers_sv);
for (int j = 0; j < 7; ++j) {
*(final_pointers + j) += count[j];
carry_pointer(final_pointers + j);
}
} /* end for (i = 0;... */
} /* end if (length) */
} /* end for (iter_supras(p3... */
} /* end for (iter_supras(p2... */
} /* end for (iter_supras(p1... */
} /* end for (iter_supras(p0... */
clear_supras(supra_list, 4);
/*
* compute analogical set and raw gang effects
*
lib/Algorithm/AM/BigInt.pm view on Meta::CPAN
#pod
#pod =head2 C<bigcmp>
#pod
#pod Compares two big integers, returning 1, 0, or -1 depending on whether
#pod the first argument is greater than, equal to, or less than the second
#pod argument.
#pod
#pod =cut
sub bigcmp {
my($a,$b) = @_;
return (length($a) <=> length($b)) || ($a cmp $b);
}
1;
__END__
=pod
=encoding UTF-8
lib/Algorithm/AM/DataSet/Item.pm view on Meta::CPAN
sub comment {
my ($self) = @_;
if(!defined $self->{comment}){
$self->{comment} = join ',', @{ $self->{features} };
}
return $self->{comment};
}
#pod =head2 C<cardinality>
#pod
#pod Returns the length of the feature vector for this item.
#pod
#pod =cut
sub cardinality {
my ($self) = @_;
return scalar @{$self->features};
}
#pod =head2 C<id>
#pod
#pod Returns a unique string id for this item, for use as a hash key or
lib/Algorithm/AM/DataSet/Item.pm view on Meta::CPAN
indicates that the feature value is null (meaning that it has
no value).
=head2 C<comment>
Returns the comment for this item. By default, the comment is
just a comma-separated list of the feature values.
=head2 C<cardinality>
Returns the length of the feature vector for this item.
=head2 C<id>
Returns a unique string id for this item, for use as a hash key or
similar situations.
=head1 AUTHOR
Theron Stanford <shixilun@yahoo.com>, Nathan Glenn <garfieldnate@gmail.com>
lib/Algorithm/AM/Result.pm view on Meta::CPAN
$current_row++;
$gang_rows[$current_row]++;
my $features = $gang->{features};
# add the gang supracontext, effect and score
push @rows, [
sprintf($percentage_format, 100 * $gang->{effect}),
$gang->{score},
undef,
undef,
# print undefined feature slots as asterisks
map {length($_) ? $_ : '*'} @$features
];
# add each class in the gang, along with the total number
# and effect of the gang items supporting it
for my $class (sort keys %{ $gang->{class} }){
$gang_rows[$current_row]++;
push @rows, [
sprintf($percentage_format,
100 * $gang->{class}->{$class}->{effect}),
$gang->{class}->{$class}->{score},
scalar @{ $gang->{data}->{$class} },
lib/Algorithm/AM/Result.pm view on Meta::CPAN
my $train = $self->training_set;
my $total_points = $self->total_points;
my $raw_gang = $self->{raw_gang};
my @gangs;
foreach my $context (keys %{$raw_gang})
{
my $gang = {};
my @features = $self->_unpack_supracontext($context);
# for now, store gangs by the supracontext printout
my $key = join ' ', map {length($_) ? $_ : '-'} @features;
$gang->{score} = $raw_gang->{$context};
$gang->{effect} = $raw_gang->{$context} / $total_points;
$gang->{features} = \@features;
my $num_class_pointers = $self->{pointers}->{$context};
# if the supracontext is homogenous
if ( my $class_index = $self->{context_to_class}->{$context} ) {
# store a 'homogenous' key that indicates this, besides
# indicating the unanimous class prediction.
my $class = $train->_class_for_index($class_index);
lib/Algorithm/AM/algorithm.pod view on Meta::CPAN
=head1 VERSION
version 3.13
=head1 DESCRIPTION
First, the user must create a set of data items, with their outcomes,
and some test items. All of these items are represented by I<feature
vectors>. These feature vectors are I<not> created by the AM
algorithm; they could be generated by hand or script, it matters not
to AM. All the feature vectors must be of the same length, call it
I<n>.
=head2 The supracontextual lattice
AM requires the construction of a I<supracontextual lattice>. It is
merely a complete distributive lattice of sets called
I<supracontexts>, each one labeled with an integer in the range 0
to S<2^I<n> - 1>. If I<a> and I<b> are labels of two supracontexts,
then I<a> & I<b> = I<b> (that's bitwise AND) iff the supracontext
labeled by I<a> is a superset of the supracontext labeled by I<b>.
lib/Algorithm/AM/lattice.pod view on Meta::CPAN
The elements of the lattice created by AM are sets. The partial order
is defined as follows: I<A> E<lt>= I<B> if I<B> is a subset of I<A>.
If you draw the lattice, the smaller sets are at the top. This
lattice is known as the I<supracontextual lattice>; its elements are
called I<supracontexts>.
=item *
The value of I<n>, and thus the size of the lattice, is determined by
the length of the I<feature vector> of the test item (see F<AM.pod>
for more explanation). There is a set corresponding to each I<n>-bit
positive integer; furthermore, if set I<A> corresponds to integer I<a>
and set I<B> corresponds to integer I<b>, then I<A> is a superset of
(or "below") I<B> if I<a> & I<b> = I<b>.
=item *
Many of the elements of the supracontextual lattice are equal as sets;
i.e., they have precisely the same members. Thus, for those of you
who know a lot of math, it is important not to confuse the
supracontextual lattice with the Boolean algebra generated by the
power set of a set. The supracontextual lattice I<is> a Boolean
algebra of sets; where these sets come from is explained in F<AM.pod>.
To store the supracontextual lattice, it is enough to create an array
C<lattice[]> of length 2^I<n>, where C<lattice[>I<a>C<]> contains a
pointer to a structure containing information about the elements of
the set corresponding to I<a>.
Of course, the size of C<lattice[]> grows exponentially with I<n>; to
overcome that, see the section on L<lattices as products of smaller
lattices|"LATTICES AS PRODUCTS OF SMALLER LATTICES">.
=item *
The supracontextual lattice is built up by adding elements to these
isBLANK_LC|5.006001|5.003007|p
isBLANK_LC_uni|5.006001||Viu
isBLANK_LC_utf8|5.006001||Viu
isBLANK_LC_utf8_safe|5.025009|5.006000|p
isBLANK_LC_uvchr|5.017007|5.017007|
isBLANK_uni|5.006001||Viu
isBLANK_utf8|5.031005|5.031005|
isBLANK_utf8_safe|5.025009|5.006000|p
isBLANK_uvchr|5.023009|5.006000|p
isC9_STRICT_UTF8_CHAR|5.025005|5.025005|n
is_C9_STRICT_UTF8_CHAR_utf8_no_length_checks|5.025005||Viu
is_C9_STRICT_UTF8_CHAR_utf8_no_length_checks_part0|5.025008||Viu
is_C9_STRICT_UTF8_CHAR_utf8_no_length_checks_part1|5.025008||Viu
is_c9strict_utf8_string|5.025006|5.025006|n
is_c9strict_utf8_string_loc|5.025006|5.025006|n
is_c9strict_utf8_string_loclen|5.025006|5.025006|n
isCHARNAME_CONT|5.011005||Viu
isCNTRL|5.006000|5.003007|p
isCNTRL_A|5.013006|5.003007|p
isCNTRL_L1|5.013006|5.003007|p
isCNTRL_LC|5.006000|5.006000|
isCNTRL_LC_utf8|5.006000||Viu
isCNTRL_LC_utf8_safe|5.025009|5.006000|p
isSPACE_LC|5.004000|5.004000|
isSPACE_LC_utf8|5.006000||Viu
isSPACE_LC_utf8_safe|5.025009|5.006000|p
isSPACE_LC_uvchr|5.007001|5.007001|
isSPACE_uni|5.006000||Viu
isSPACE_utf8|5.031005|5.031005|
isSPACE_utf8_safe|5.025009|5.006000|p
isSPACE_uvchr|5.023009|5.006000|p
is_ssc_worth_it|5.021005||Vniu
isSTRICT_UTF8_CHAR|5.025005|5.025005|n
is_STRICT_UTF8_CHAR_utf8_no_length_checks|5.025005||Viu
is_STRICT_UTF8_CHAR_utf8_no_length_checks_part0|5.025005||Viu
is_STRICT_UTF8_CHAR_utf8_no_length_checks_part1|5.025005||Viu
is_STRICT_UTF8_CHAR_utf8_no_length_checks_part2|5.025008||Viu
is_STRICT_UTF8_CHAR_utf8_no_length_checks_part3|5.025008||Viu
is_strict_utf8_string|5.025006|5.025006|n
is_strict_utf8_string_loc|5.025006|5.025006|n
is_strict_utf8_string_loclen|5.025006|5.025006|n
is_STRICT_VERSION|5.011004||Viu
is_SURROGATE_utf8_safe|5.025005||Viu
I_STDARG|5.003007||Viu
I_STDBOOL|5.015003|5.015003|Vn
I_STDINT|5.021004|5.021004|Vn
is_THREE_CHAR_FOLD_HEAD_latin1_safe|5.031007||Viu
is_THREE_CHAR_FOLD_HEAD_utf8_safe|5.031007||Viu
isUPPER_uni|5.006000||Viu
isUPPER_utf8|5.031005|5.031005|
isUPPER_utf8_safe|5.025009|5.006000|p
isUPPER_uvchr|5.023009|5.006000|p
is_utf8_char|5.006000|5.006000|dn
IS_UTF8_CHAR|5.009003||Viu
isUTF8_CHAR|5.021001|5.006001|pn
is_utf8_char_buf|5.015008|5.015008|n
isUTF8_CHAR_flags|5.025005|5.025005|
is_utf8_char_helper|5.031004||cVnu
is_UTF8_CHAR_utf8_no_length_checks|5.021001||Viu
is_utf8_common|5.009003||Viu
is_utf8_cp_above_31_bits|5.025005||Vniu
is_utf8_fixed_width_buf_flags|5.025006|5.025006|n
is_utf8_fixed_width_buf_loc_flags|5.025006|5.025006|n
is_utf8_fixed_width_buf_loclen_flags|5.025006|5.025006|n
_is_utf8_FOO|5.031006||cVu
is_utf8_invariant_string|5.025005|5.011000|pn
is_utf8_invariant_string_loc|5.027001|5.027001|n
is_utf8_non_invariant_string|5.027007||cVni
is_utf8_overlong_given_start_byte_ok|5.025006||Vniu
KEY_int|5.003007||Viu
KEY_ioctl|5.003007||Viu
KEY_isa|5.031007||Viu
KEY_join|5.003007||Viu
KEY_keys|5.003007||Viu
KEY_kill|5.003007||Viu
KEY_last|5.003007||Viu
KEY_lc|5.003007||Viu
KEY_lcfirst|5.003007||Viu
KEY_le|5.003007||Viu
KEY_length|5.003007||Viu
KEY___LINE|5.003007||Viu
KEY_link|5.003007||Viu
KEY_listen|5.003007||Viu
KEY_local|5.003007||Viu
KEY_localtime|5.003007||Viu
KEY_lock|5.005000||Viu
KEY_log|5.003007||Viu
KEY_lstat|5.003007||Viu
KEY_lt|5.003007||Viu
KEY_m|5.003007||Viu
MGf_LOCAL|5.009003||Viu
MGf_MINMATCH|5.003007||Viu
MGf_PERSIST|5.021005||Viu
mg_free|5.003007|5.003007|
mg_freeext|5.027004|5.027004|
mg_free_type|5.013006|5.013006|
MGf_REFCOUNTED|5.003007||Viu
MGf_REQUIRE_GV|5.021004||Viu
MGf_TAINTEDDIR|5.003007||Viu
mg_get|5.003007|5.003007|
mg_length|5.005000|5.005000|d
mg_localize|5.009003||Vi
mg_magical|5.003007|5.003007|n
MgPV|5.003007||Viu
MgPV_const|5.009003||Viu
MgPV_nolen_const|5.009003||Viu
mg_set|5.003007|5.003007|
mg_size|5.005000|5.005000|u
MgTAINTEDDIR|5.003007||Viu
MgTAINTEDDIR_off|5.004000||Viu
MgTAINTEDDIR_on|5.003007||Viu
reg_named_buff_iter|5.009005||cViu
reg_named_buff_nextkey|5.009005||cVu
reg_named_buff_scalar|5.009005||cVu
regnext|5.003007||cVu
reg_node|5.005000||Viu
regnode_guts|5.021005||Viu
REGNODE_MAX|5.009004||Viu
REGNODE_SIMPLE|5.013002||Viu
REGNODE_VARIES|5.013002||Viu
reg_numbered_buff_fetch|5.009005||cViu
reg_numbered_buff_length|5.009005||cViu
reg_numbered_buff_store|5.009005||cViu
regpiece|5.005000||Viu
regpnode|5.031009||Viu
regprop|5.003007||Viu
reg_qr_package|5.009005||cViu
REG_RECURSE_SEEN|5.019009||Viu
regrepeat|5.005000||Viu
REG_RUN_ON_COMMENT_SEEN|5.019009||Viu
reg_scan_name|5.009005||Viu
reg_skipcomment|5.009005||Vniu
UTF8_IS_DOWNGRADEABLE_START|5.007001||Viu
UTF8_IS_INVARIANT|5.007001|5.003007|p
UTF8_IS_NEXT_CHAR_DOWNGRADEABLE|5.017006||Viu
UTF8_IS_NONCHAR|5.023002|5.023002|
UTF8_IS_NONCHAR_GIVEN_THAT_NON_SUPER_AND_GE_PROBLEMATIC|5.013009||Viu
UTF8_IS_REPLACEMENT|5.017000||Viu
UTF8_IS_START|5.007001||Viu
UTF8_IS_START_base|5.031007||Viu
UTF8_IS_SUPER|5.023002|5.023002|
UTF8_IS_SURROGATE|5.023002|5.023002|
utf8_length|5.007001|5.007001|
UTF8_MAXBYTES|5.009002|5.006000|p
UTF8_MAXBYTES_CASE|5.009002|5.003007|p
UTF8_MAX_FOLD_CHAR_EXPAND|5.013009||Viu
UTF8_MAXLEN|5.006000||Viu
utf8_mg_len_cache_update|5.013003||Viu
utf8_mg_pos_cache_update|5.009004||Viu
utf8n_to_uvchr|5.007001|5.007001|n
utf8n_to_uvchr_error|5.025006|5.025006|n
utf8n_to_uvchr_msgs|5.027009|5.027009|n
_utf8n_to_uvchr_msgs_helper|5.029001||cVnu
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort dictionary_order keys %API) {
next if $API{$f}{core_only};
next if $API{$f}{beyond_depr};
next if $API{$f}{inaccessible};
next if $API{$f}{experimental};
next unless $API{$f}{todo};
next if int_parse_version($API{$f}{todo}) <= $int_min_perl;
my $repeat = 40 - length($f);
$repeat = 0 if $repeat < 0;
print "$f ", '.'x $repeat, " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for hints, possible replacement candidates, etc.
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
while (<DATA>) {
if ($hint) {
# Here, we are in the middle of accumulating a hint or warning.
my $end_of_hint = 0;
# A line containing a comment end marker closes the hint. Remove that
# marker for processing below.
if (s/\s*$rcce(.*?)\s*$//) {
die "Nothing can follow the end of comment in '$_'\n" if length $1 > 0;
$end_of_hint = 1;
}
# Set $h to the hash of which type.
my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
# Ignore any leading and trailing white space, and an optional star comment
# continuation marker, then place the meat of the line into $1
m/^\s*(?:\*\s*)?(.*?)\s*$/;
#endif
#ifndef av_count
# define av_count(av) (AvFILL(av)+1)
#endif
#ifndef ERRSV
# define ERRSV get_sv("@",FALSE)
#endif
/* Hint: gv_stashpvn
* This function's backport doesn't support the length parameter, but
* rather ignores it. Portability can only be ensured if the length
* parameter is used for speed reasons, but the length can always be
* correctly computed from the string argument.
*/
#ifndef gv_stashpvn
# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
#endif
/* Replace: 1 */
#ifndef get_cv
# define get_cv perl_get_cv
#endif
Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL)
# define D_PPP_TO_FOLD_CALLEE(s,r,l) \
Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL)
# endif
/* The actual implementation of the backported macros. If too short, croak,
* otherwise call the original that doesn't have an upper limit parameter */
# define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \
(((((e) - (s)) <= 0) \
/* We could just do nothing, but modern perls croak */ \
? (croak("Attempting case change on zero length string"), \
0) /* So looks like it returns something, and will compile */ \
: ((e) - (s)) < UTF8SKIP(s)) \
? (croak(D_PPP_TOO_SHORT_MSG, \
s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \
0) \
: D_PPP_TO_ ## name ## _CALLEE(s,r,l))
#ifndef toUPPER_utf8_safe
# define toUPPER_utf8_safe(s,e,r,l) \
D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l)
#endif
/* Here we have UTF-8 support, but using the original API where the case
* changing functions merely returned the changed code point; hence they
* couldn't handle multi-character results. */
# ifdef uvchr_to_utf8
# define D_PPP_UV_TO_UTF8 uvchr_to_utf8
# else
# define D_PPP_UV_TO_UTF8 uv_to_utf8
# endif
/* Get the utf8 of the case changed value, and store its length; then have
* to re-calculate the changed case value in order to return it */
# define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \
(*(l) = (D_PPP_UV_TO_UTF8(s, \
UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \
UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c))))
#ifndef toLOWER_uvchr
# define toLOWER_uvchr(c, s, l) \
D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l)
#endif
# define toTITLE_uvchr(c, s, l) \
D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l)
#endif
#ifndef toFOLD_uvchr
# define toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l)
#endif
# define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \
(((((e) - (s)) <= 0) \
? (croak("Attempting case change on zero length string"), \
0) /* So looks like it returns something, and will compile */ \
: ((e) - (s)) < UTF8SKIP(s)) \
? (croak(D_PPP_TOO_SHORT_MSG, \
s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \
0) \
/* Get the changed code point and store its UTF-8 */ \
: D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \
/* Then store its length, and re-get code point for return */ \
*(l) = UTF8SKIP(r), to_utf8_ ## name(r))
/* Warning: toUPPER_utf8_safe, toLOWER_utf8_safe, toTITLE_utf8_safe,
* toUPPER_uvchr, toLOWER_uvchr, toTITLE_uvchr
The UTF-8 case changing operations had bugs before around 5.12 or 5.14;
this backport does not correct them.
In perls before 7.3, multi-character case changing is not implemented; this
backport uses the simple case changes available in those perls. */
#ifndef toUPPER_utf8_safe
#ifndef SvSHARED_HASH
# define SvSHARED_HASH(sv) (0 + SvUVX(sv))
#endif
#ifndef HvNAME_get
# define HvNAME_get(hv) HvNAME(hv)
#endif
#ifndef HvNAMELEN_get
# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
#endif
#if (PERL_BCDVERSION >= 0x5009002) && (PERL_BCDVERSION <= 0x5009003) /* 5.9.2 and 5.9.3 ignore the length param */
#undef gv_fetchpvn_flags
#endif
#ifdef GV_NOADD_MASK
# define D_PPP_GV_NOADD_MASK GV_NOADD_MASK
#else
# define D_PPP_GV_NOADD_MASK 0xE0
#endif
#ifndef gv_fetchpvn_flags
# define gv_fetchpvn_flags(name, len, flags, sv_type) gv_fetchpv(SvPVX(sv_2mortal(newSVpvn((name), (len)))), ((flags) & D_PPP_GV_NOADD_MASK) ? FALSE : TRUE, (I32)(sv_type))
#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
#define my_strlcat DPPP_(my_my_strlcat)
#define Perl_my_strlcat DPPP_(my_my_strlcat)
Size_t
DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
{
Size_t used, length, copy;
used = strlen(dst);
length = strlen(src);
if (size > 0 && used < size - 1) {
copy = (length >= size - used) ? size - used - 1 : length;
memcpy(dst + used, src, copy);
dst[used + copy] = '\0';
}
return used + length;
}
#endif
#endif
#if !defined(my_strlcpy)
#if defined(NEED_my_strlcpy)
static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
static
#else
extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
#define my_strlcpy DPPP_(my_my_strlcpy)
#define Perl_my_strlcpy DPPP_(my_my_strlcpy)
Size_t
DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
{
Size_t length, copy;
length = strlen(src);
if (size > 0) {
copy = (length >= size) ? size - 1 : length;
memcpy(dst, src, copy);
dst[copy] = '\0';
}
return length;
}
#endif
#endif
#ifdef SVf_UTF8
#ifndef SvUTF8
# define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8)
#endif
UV
DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
{
UV ret;
STRLEN curlen;
bool overflows = 0;
const U8 *cur_s = s;
const bool do_warnings = ckWARN_d(WARN_UTF8);
# if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC)
STRLEN overflow_length = 0;
# endif
if (send > s) {
curlen = send - s;
}
else {
assert(0); /* Modern perls die under this circumstance */
curlen = 0;
if (! do_warnings) { /* Handle empty here if no warnings needed */
if (retlen) *retlen = 0;
* parameters. Therefore detect it ourselves in releases it was
* problematic in. */
if (curlen > 0 && UNLIKELY(*s >= 0xFE)) {
/* First, on a 32-bit machine the first byte being at least \xFE
* automatically is overflow, as it indicates something requiring more
* than 31 bits */
if (sizeof(ret) < 8) {
overflows = 1;
overflow_length = (*s == 0xFE) ? 7 : 13;
}
else {
const U8 highest[] = /* 2*63-1 */
"\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
const U8 *cur_h = highest;
for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
if (UNLIKELY(*cur_s == *cur_h)) {
continue;
}
* sequence doesn't overflow */
overflows = *cur_s > *cur_h;
break;
}
/* Here, either we set the bool and broke out of the loop, or got
* to the end and all bytes are the same which indicates it doesn't
* overflow. If it did overflow, it would be this number of bytes
* */
overflow_length = 13;
}
}
if (UNLIKELY(overflows)) {
ret = 0;
if (! do_warnings && retlen) {
*retlen = overflow_length;
}
}
else
# endif /* < 5.26 */
/* Here, we are either in a release that properly detects overflow, or
* we have checked for overflow and the next statement is executing as
* part of the above conditional where we know we don't have overflow.
*
ret = D_PPP_utf8_to_uvchr_buf_callee(
(U8 *) /* Early perls: no const */
s, curlen, retlen, UTF8_ALLOW_ANY);
/* Override with the REPLACEMENT character, as that is what the
* modern version of this function returns */
ret = UNICODE_REPLACEMENT;
# if (PERL_BCDVERSION < 0x5016000)
/* Versions earlier than this don't necessarily return the proper
* length. It should not extend past the end of string, nor past
* what the first byte indicates the length is, nor past the
* continuation characters */
if (retlen && (IV) *retlen >= 0) {
unsigned int i = 1;
*retlen = D_PPP_MIN(*retlen, curlen);
*retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
do {
# ifdef UTF8_IS_CONTINUATION
if (! UTF8_IS_CONTINUATION(s[i]))
# else /* Versions without the above don't support EBCDIC anyway */
t/00-report-prereqs.t view on Meta::CPAN
if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) {
push @dep_errors, "$mod is not installed ($req_string)";
}
}
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
else {
splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
}
( run in 0.690 second using v1.01-cache-2.11-cpan-65fba6d93b7 )