Algorithm-AM
view release on metacpan or search on metacpan
you changed the files and the date of any change; and
b) cause the whole of any work that you distribute or publish, that
in whole or in part contains the Program or any part thereof, either
with or without modifications, to be licensed at no charge to all
third parties under the terms of this General Public License (except
that you may choose to grant warranty protection to some or all
third parties, at your option).
c) If the modified program normally reads commands interactively when
run, you must cause it, when started running for such interactive use
in the simplest and most usual way, to print or display an
announcement including an appropriate copyright notice and a notice
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
d) You may charge a fee for the physical act of transferring a
copy, and you may at your option offer warranty protection in
exchange for a fee.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to humanity, the best way to achieve this is to make it
free software which everyone can redistribute and change under these
terms.
To do so, attach the following notices to the program. It is safest to
attach them to the start of each source file to most effectively convey
the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the program's name and a brief idea of what it does.>
Copyright (C) 19yy <name of author>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) 19xx name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the
appropriate parts of the General Public License. Of course, the
commands you use may be called something other than `show w' and `show
c'; they could even be mouse-clicks or menu items--whatever suits your
lib/Algorithm/AM.pm view on Meta::CPAN
exclude_nulls => $self->exclude_nulls,
count_method => $self->linear ? 'linear' : 'squared',
training_set => $training_set,
test_item => $test_item,
test_in_train => $test_in_training,
);
$log->debug(${$result->config_info})
if($log->is_debug);
$result->start_time([ (localtime)[0..2] ]);
$self->_fillandcount(
$lattice_sizes, $self->linear ? 1 : 0);
$result->end_time([ (localtime)[0..2] ]);
unless ($self->{pointers}->{'grand_total'}) {
#TODO: is this tested yet?
if($log->is_warn){
$log->warn('No training items considered. ' .
'No prediction possible.');
}
lib/Algorithm/AM/Batch.pm view on Meta::CPAN
=head2 C<begin_test_hook>
$batch->begin_repeat_hook(sub {
my ($batch, $test_item) = @_;
$batch->probability(.5);
print $test_item->comment . "\n";
});
This hook is called by L</classify_all> before any iterations of
classification start for each test item. It is provided with the Batch
object instance and the test item.
=head2 C<begin_repeat_hook>
$batch->begin_repeat_hook(sub {
my ($batch, $test_item, $iteration) = @_;
$batch->probability(.5);
print $test_item->comment . "\n";
print "I'm on iteration $iteration\n";
});
lib/Algorithm/AM/DataSet.pm view on Meta::CPAN
}
# initialize internal state
sub _init {
my ($self) = @_;
# contains all of the items in the dataset
$self->{items} = [];
# map unique class labels to unique integers;
# these are the indices of the class labels in class_list below;
# the indices must start at 1 for AM to work, as 0 is reserved
# for heterogeneity.
$self->{class_num_index} = {};
# contains the list of class strings in an order that matches
# the indices in class_num_index
$self->{class_list} = [];
# the total number of different classes contained in the data set
$self->{num_classes} = 0;
return;
}
lib/Algorithm/AM/Result.pm view on Meta::CPAN
## %context_to_class
## %context_size
use Class::Tiny qw(
exclude_nulls
given_excluded
cardinality
test_in_train
test_item
count_method
start_time
end_time
training_set
scores
high_score
total_points
winners
is_tie
result
lib/Algorithm/AM/Result.pm view on Meta::CPAN
score.
=head2 C<is_tie>
Returns true if more than one class was assigned the high score.
=head2 C<total_points>
The sum total number of points assigned as a score to any contexts.
=head2 C<start_time>
Returns the start time of the classification.
=head2 C<end_time>
Returns the end time of the classification.
=head1 AUTHOR
Theron Stanford <shixilun@yahoo.com>, Nathan Glenn <garfieldnate@gmail.com>
=head1 COPYRIGHT AND LICENSE
lib/Algorithm/AM/algorithm.pod view on Meta::CPAN
=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>.
The supracontextual lattice starts out with every element being the
empty set. The AM algorithm adds I<subcontexts> to them one at a
time.
=head2 Subcontexts
Subcontexts are also sets, and they are also labeled with an integer
in the range 0 to S<2^I<n> - 1>. The elements of the subcontexts are
data items.
=over 4
bad_type_pv|5.016000||Viu
BADVERSION|5.011004||Viu
BASEOP|5.003007||Viu
BhkDISABLE|5.013003||xV
BhkENABLE|5.013003||xV
BhkENTRY|5.013003||xVi
BhkENTRY_set|5.013003||xV
BHKf_bhk_eval|5.013006||Viu
BHKf_bhk_post_end|5.013006||Viu
BHKf_bhk_pre_end|5.013006||Viu
BHKf_bhk_start|5.013006||Viu
BhkFLAGS|5.013003||xVi
BIN|5.003007|5.003007|Vn
bind|5.005000||Viu
bind_match|5.003007||Viu
BIN_EXP|5.004000|5.004000|Vn
Bit|5.006000||Viu
BIT_BUCKET|5.003007||Viu
BIT_DIGITS|5.004000||Viu
BITMAP_BYTE|5.009005||Viu
BITMAP_TEST|5.009005||Viu
blk_oldpm|5.003007||Viu
blk_oldsaveix|5.023008||Viu
blk_oldscopesp|5.003007||Viu
blk_oldsp|5.003007||Viu
blk_old_tmpsfloor|5.023008||Viu
blk_sub|5.003007||Viu
blk_u16|5.011000||Viu
block_end|5.004000|5.004000|
block_gimme|5.004000|5.004000|u
blockhook_register|5.013003|5.013003|x
block_start|5.004000|5.004000|
BmFLAGS|5.009005||Viu
BmPREVIOUS|5.003007||Viu
BmRARE|5.003007||Viu
BmUSEFUL|5.003007||Viu
BOL|5.003007||Viu
BOM_UTF8|5.025005|5.003007|p
BOM_UTF8_FIRST_BYTE|5.019004||Viu
BOM_UTF8_TAIL|5.019004||Viu
bool|5.003007||Viu
boolSV|5.004000|5.003007|p
closedir|5.005000||Viu
closest_cop|5.007002||Viu
CLUMP_2IV|5.006000||Viu
CLUMP_2UV|5.006000||Viu
CLUMP|5.006000||Viu
cMETHOPx|5.021005||Viu
cMETHOPx_meth|5.021005||Viu
cMETHOPx_rclass|5.021007||Viu
cmpchain_extend|5.031010||Viu
cmpchain_finish|5.031010||Viu
cmpchain_start|5.031010||Viu
cmp_desc|5.031010||Viu
cmp_locale_desc|5.031010||Viu
cntrl_to_mnemonic|5.021004||cVniu
CODESET|5.027010||Viu
COMBINING_DOT_ABOVE_UTF8|5.029008||Viu
COMBINING_GRAVE_ACCENT_UTF8|5.017004||Viu
COMMIT|5.009005||Viu
COMMIT_next|5.009005||Viu
COMMIT_next_fail|5.009005||Viu
compile_wildcard|5.031009||Viu
DEBUG_R_TEST|5.007001||Viu
DEBUG_r_TEST|5.007001||Viu
DEBUG_s|5.003007||Viu
DEBUG_S|5.017002||Viu
DEBUG_SBOX32_HASH|5.027001||Viu
DEBUG_SCOPE|5.008001||Viu
DEBUG_s_FLAG|5.007001||Viu
DEBUG_S_FLAG|5.017002||Viu
DEBUG_STACK_r|5.009005||Viu
DEBUG_STADTX_HASH|5.027001||Viu
debug_start_match|5.009004||Viu
DEBUG_STATE_r|5.009004||Viu
DEBUG_s_TEST|5.007001||Viu
DEBUG_S_TEST|5.017002||Viu
DEBUG_t|5.003007||Viu
DEBUG_T|5.007001||Viu
DEBUG_TEST_r|5.021005||Viu
DEBUG_T_FLAG|5.007001||Viu
DEBUG_t_FLAG|5.007001||Viu
DEBUG_TOP_FLAG|5.007001||Viu
DEBUG_TRIE_COMPILE_MORE_r|5.009002||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
is_THREE_CHAR_FOLD_latin1_safe|5.031007||Viu
is_THREE_CHAR_FOLD_utf8_safe|5.031007||Viu
IS_TRIE_AC|5.009005||Viu
_is_uni_FOO|5.017008||cVu
_is_uni_perl_idcont|5.017008||cVu
_is_uni_perl_idstart|5.017007||cVu
isUPPER|5.003007|5.003007|p
isUPPER_A|5.013006|5.003007|p
isUPPER_L1|5.013006|5.003007|p
isUPPER_LC|5.004000|5.004000|
isUPPER_LC_utf8|5.006000||Viu
isUPPER_LC_utf8_safe|5.025009|5.006000|p
isUPPER_LC_uvchr|5.007001|5.007001|
isUPPER_uni|5.006000||Viu
isUPPER_utf8|5.031005|5.031005|
isUPPER_utf8_safe|5.025009|5.006000|p
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
_is_utf8_perl_idcont|5.031006||cVu
_is_utf8_perl_idstart|5.031006||cVu
isUTF8_POSSIBLY_PROBLEMATIC|5.023003||Viu
is_utf8_string|5.006001|5.006001|n
is_utf8_string_flags|5.025006|5.025006|n
is_utf8_string_loc|5.008001|5.008001|n
is_utf8_string_loc_flags|5.025006|5.025006|n
is_utf8_string_loclen|5.009003|5.009003|n
is_utf8_string_loclen_flags|5.025006|5.025006|n
is_utf8_valid_partial_char|5.025005|5.025005|n
is_utf8_valid_partial_char_flags|5.025005|5.025005|n
is_VERTWS_cp_high|5.017006||Viu
LEX_EVALBYTES|5.015005||Viu
lex_grow_linestr|5.011002|5.011002|x
LEX_IGNORE_UTF8_HINTS|5.015005||Viu
LEX_KEEP_PREVIOUS|5.011002|5.011002|
lex_next_chunk|5.011002|5.011002|x
LEX_NOTPARSING|5.004004||Viu
lex_peek_unichar|5.011002|5.011002|x
lex_read_space|5.011002|5.011002|x
lex_read_to|5.011002|5.011002|x
lex_read_unichar|5.011002|5.011002|x
lex_start|5.009005|5.009005|x
LEX_START_COPIED|5.015005||Viu
LEX_START_FLAGS|5.015005||Viu
LEX_START_SAME_FILTER|5.014000||Viu
lex_stuff_pv|5.013006|5.013006|x
lex_stuff_pvn|5.011002|5.011002|x
lex_stuff_pvs|5.013005|5.013005|x
lex_stuff_sv|5.011002|5.011002|x
LEX_STUFF_UTF8|5.011002|5.011002|
lex_unstuff|5.011002|5.011002|x
LF_NATIVE|5.019004||Viu
pad_add_name_sv|5.015001|5.015001|
padadd_NO_DUP_CHECK|5.011002||Viu
padadd_OUR|5.011002||Viu
padadd_STALEOK|5.017003||Viu
padadd_STATE|5.011002||Viu
pad_add_weakref|5.021007||Viu
pad_alloc|5.003007|5.003007|x
pad_alloc_name|5.015001||Vi
PadARRAY|5.017004|5.017004|x
PAD_BASE_SV|5.008001||Vi
pad_block_start|5.008001||Vi
pad_check_dup|5.008001||Vi
PAD_CLONE_VARS|5.008001||Vi
PAD_COMPNAME|5.017004||Viu
PAD_COMPNAME_FLAGS|5.008001||Vi
PAD_COMPNAME_FLAGS_isOUR|5.009004||Viu
PAD_COMPNAME_GEN|5.008001||Vi
PAD_COMPNAME_GEN_set|5.009003||Vi
PAD_COMPNAME_OURSTASH|5.008001||Vi
PAD_COMPNAME_PV|5.008001||Vi
PAD_COMPNAME_SV|5.009005||Viu
Perl_pp_i_predec|5.006000||Viu
Perl_pp_i_preinc|5.006000||Viu
Perl_pp_keys|5.013009||Viu
Perl_pp_kill|5.013009||Viu
Perl_pp_lcfirst|5.013009||Viu
Perl_pp_lineseq|5.013009||Viu
Perl_pp_listen|5.013009||Viu
Perl_pp_localtime|5.013009||Viu
Perl_pp_log|5.013009||Viu
Perl_pp_lstat|5.013009||Viu
Perl_pp_mapstart|5.013009||Viu
Perl_pp_msgctl|5.013009||Viu
Perl_pp_msgget|5.013009||Viu
Perl_pp_msgrcv|5.013009||Viu
Perl_pp_msgsnd|5.013009||Viu
Perl_pp_nbit_xor|5.021009||Viu
Perl_pp_orassign|5.013009||Viu
Perl_pp_padany|5.013009||Viu
Perl_pp_pop|5.013009||Viu
Perl_pp_read|5.013009||Viu
Perl_pp_recv|5.013009||Viu
PL_encoding|5.007003||Viu
PL_endav|5.005000||Viu
PL_Env|5.006000||Viu
PL_envgv|5.005000||Viu
PL_errgv|5.004005|5.003007|p
PL_error_count||5.003007|ponu
PL_errors|5.006000||Viu
PL_e_script|5.005000||Viu
PL_eval_root|5.005000||Viu
PL_evalseq|5.005000||Viu
PL_eval_start|5.005000||Viu
PL_exit_flags|5.006000|5.006000|
PL_exitlist|5.005000||Viu
PL_exitlistlen|5.005000||Viu
PL_expect||5.003007|ponu
PL_fdpid|5.005000||Viu
PL_filemode|5.005000||Viu
PL_firstgv|5.005000||Viu
PL_forkprocess|5.005000||Viu
PL_formtarget|5.005000||Viu
PL_GCB_invlist|5.021009||Viu
PL_lex_stuff||5.003007|ponu
PL_linestr||5.003007|ponu
PL_LIO|5.006000||Viu
PL_locale_utf8ness|5.027009||Viu
PL_localizing|5.005000||Viu
PL_localpatches|5.005000||Viu
PL_lockhook|5.007003||Viu
PL_main_cv|5.005000||Viu
PL_main_root|5.005000||Viu
PL_mainstack|5.005000||Viu
PL_main_start|5.005000||Viu
PL_markstack|5.005000||Viu
PL_markstack_max|5.005000||Viu
PL_markstack_ptr|5.005000||Viu
PL_max_intro_pending|5.005000||Viu
PL_maxo|5.005000||Viu
PL_maxsysfd|5.005000||Viu
PL_mbrlen_ps|5.031009||Viu
PL_mbrtowc_ps|5.031009||Viu
PL_Mem|5.006000||Viu
PL_memory_debug_header|5.009004||Viu
PL_RANDOM_STATE_TYPE|5.019004||Viu
PL_reentrant_buffer|5.007002||Viu
PL_reentrant_retint|5.008001||Viu
PL_reg_curpm|5.006000||Viu
PL_regex_pad|5.007002||Viu
PL_regex_padav|5.007002||Viu
PL_registered_mros|5.010001||Viu
PL_regmatch_slab|5.009004||Viu
PL_regmatch_state|5.009004||Viu
PL_replgv|5.005000||Viu
PL_restartjmpenv|5.013001||Viu
PL_restartop|5.005000||Viu
PL_rpeepp|5.013005|5.013005|
PL_rs|5.005000||Vi
PL_rsfp||5.003007|ponu
PL_rsfp_filters||5.003007|ponu
PL_runops|5.006000|5.006000|
PL_savebegin|5.007003||Viu
PL_savestack|5.005000||Viu
PL_savestack_ix|5.005000||Viu
PL_savestack_max|5.005000||Viu
PL_sawampersand|5.005000||Viu
PL_signals|5.008001|5.003007|poVnu
PL_sig_pending|5.007001||Viu
PL_Sock|5.006000||Viu
PL_sortcop|5.005000||Viu
PL_sortstash|5.005000||Viu
PL_splitstr|5.005000||Viu
PL_srand_called|5.006000||Viu
PL_stack_base|5.005000|5.003007|poVnu
PL_stack_max|5.005000||Viu
PL_stack_sp|5.005000|5.003007|poVnu
PL_start_env|5.005000||Viu
PL_stashcache|5.008001||Viu
PL_stashpad|5.017001||Viu
PL_stashpadix|5.017001||Viu
PL_stashpadmax|5.017001||Viu
PL_statcache|5.005000|5.003007|poVnu
PL_statgv|5.005000||Viu
PL_statname|5.005000||Viu
PL_statusvalue|5.005000||Viu
PL_statusvalue_posix|5.009003||Viu
PL_statusvalue_vms|5.005000||Viu
PL_unitcheckav_save|5.009005||Viu
PL_unlockhook|5.007003||Viu
PL_unsafe|5.005000||Viu
PL_UpperLatin1|5.019005||Viu
PLUS|5.003007||Viu
PL_utf8cache|5.009004||Viu
PL_utf8_charname_begin|5.017006||Viu
PL_utf8_charname_continue|5.017006||Viu
PL_utf8_foldclosures|5.013007||Viu
PL_utf8_idcont|5.008000||Viu
PL_utf8_idstart|5.008000||Viu
PL_utf8locale|5.008001||Viu
PL_utf8_mark|5.006000||Viu
PL_utf8_perl_idcont|5.017008||Viu
PL_utf8_perl_idstart|5.015004||Viu
PL_utf8_tofold|5.007003||Viu
PL_utf8_tolower|5.006000||Viu
PL_utf8_tosimplefold|5.027011||Viu
PL_utf8_totitle|5.006000||Viu
PL_utf8_toupper|5.006000||Viu
PL_utf8_xidcont|5.013010||Viu
PL_utf8_xidstart|5.013010||Viu
PL_vtbl_arylen|5.015000||Viu
PL_vtbl_arylen_p|5.015000||Viu
PL_vtbl_backref|5.015000||Viu
PL_vtbl_bm|5.015000||Viu
PL_vtbl_checkcall|5.017000||Viu
PL_vtbl_collxfrm|5.015000||Viu
PL_vtbl_dbline|5.015000||Viu
PL_vtbl_debugvar|5.021005||Viu
PL_vtbl_defelem|5.015000||Viu
PL_vtbl_env|5.015000||Viu
regtail|5.005000||Viu
regtail_study|5.009004||Viu
reg_temp_copy|5.009005||cViu
REG_TOP_LEVEL_BRANCHES_SEEN|5.019009||Viu
regtry|5.005000||Viu
REG_UNBOUNDED_QUANTIFIER_SEEN|5.019009||Viu
REG_UNFOLDED_MULTI_SEEN|5.019009||Viu
REG_VERBARG_SEEN|5.019009||Viu
REG_ZERO_LEN_SEEN|5.019009||Viu
re_indentf|5.023009||vViu
re_intuit_start|5.006000||cVu
re_intuit_string|5.006000||cVu
rename|5.005000||Viu
Renew|5.003007|5.003007|
Renewc|5.003007|5.003007|
RENUM|5.005000||Viu
re_op_compile|5.017001||Viu
repeatcpy|5.003007|5.003007|nu
REPLACEMENT_CHARACTER_UTF8|5.025005|5.003007|p
report_evil_fh|5.006001||Viu
report_redefined_cv|5.015006||Viu
STADTX_K2_U64|5.027001||Viu
STADTX_K3_U32|5.027001||Viu
STADTX_K3_U64|5.027001||Viu
STADTX_K4_U32|5.027001||Viu
STADTX_K5_U32|5.027001||Viu
STADTX_SCRAMBLE64|5.027001||Viu
STADTX_STATIC_INLINE|5.027001||Viu
STANDARD_C|5.003007||Viu
STAR|5.003007||Viu
START_EXTERN_C|5.005000|5.003007|pV
start_glob|||xi
START_MY_CXT|5.010000|5.010000|p
STARTPERL|5.003007|5.003007|Vn
start_subparse|5.004000|5.003007|pu
StashHANDLER|5.007001||Viu
Stat|5.003007||Viu
stat|5.005000||Viu
STATIC|5.005000||Viu
STATIC_ASSERT_1|5.021007||Viu
STATIC_ASSERT_2|5.021007||Viu
STATIC_ASSERT_DECL|5.027001||Viu
STATIC_ASSERT_STMT|5.021007||Viu
Stat_t|5.004005||Viu
STATUS_ALL_FAILURE|5.004000||Viu
strtoull|5.006000||Viu
str_to_version|5.006000||cVu
StructCopy|5.003007|5.003007|V
STRUCT_OFFSET|5.004000||Viu
STRUCT_SV|5.007001||Viu
STR_WITH_LEN|5.009003|5.003007|pV
study_chunk|5.005000||Viu
sub_crush_depth|5.004000||Viu
sublex_done|5.005000||Viu
sublex_push|5.005000||Viu
sublex_start|5.005000||Viu
SUBST_TAINT_BOOLRET|5.013010||Viu
SUBST_TAINT_PAT|5.013010||Viu
SUBST_TAINT_REPL|5.013010||Viu
SUBST_TAINT_RETAINT|5.013010||Viu
SUBST_TAINT_STR|5.013010||Viu
SUBVERSION|5.003007||Viu
SUCCEED|5.003007||Viu
SUSPEND|5.005000||Viu
sv_2bool|5.013006||cV
sv_2bool_flags|5.013006||cV
}
else {
$function->[1] .= $_;
}
}
$function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
# Set $replace to the number given for lines that look like
# / * Replace: \d+ * /
# Thus setting it to 1 starts a region where replacements are automatically
# done, and setting it to 0 ends that region.
$replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
# Add bar => foo to %replace for lines like '#define foo bar in a region
# where $replace is non-zero
$replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
# Add bar => foo to %replace for lines like '#define foo bar / * Replace * /
$replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
#else
/* ensure that PL_parser != NULL and cannot be dereferenced */
# define PL_parser ((void *) 1)
#endif
#if (PERL_BCDVERSION <= 0x5003022)
# undef start_subparse
# if (PERL_BCDVERSION < 0x5003022)
#ifndef start_subparse
# define start_subparse(a, b) Perl_start_subparse()
#endif
# else
#ifndef start_subparse
# define start_subparse(a, b) Perl_start_subparse(b)
#endif
# endif
#if (PERL_BCDVERSION < 0x5003007)
foo
#endif
#endif
/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005)
/* And before that, we need to make sure this gets compiled for the functions
* that rely on it */
#define NEED_newCONSTSUB
#if defined(NEED_newCONSTSUB)
static CV * DPPP_(my_newCONSTSUB)(HV * stash, const char * name, SV * sv);
static
#else
HV *old_curstash = PL_curstash;
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = D_PPP_PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
cv = newSUB(
start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
PL_curcop->cop_line = oldline;
* isLOWER_LC_utf8_safe, isPRINT_LC_utf8_safe, isPSXSPC_LC_utf8_safe,
* isPUNCT_LC_utf8_safe, isSPACE_LC_utf8_safe, isUPPER_LC_utf8_safe,
* isWORDCHAR_LC_utf8_safe, isWORDCHAR_LC_utf8_safe, isXDIGIT_LC_utf8_safe,
* isALPHANUMERIC_uvchr, isALPHA_uvchr, isASCII_uvchr, isBLANK_uvchr,
* isCNTRL_uvchr, isDIGIT_uvchr, isGRAPH_uvchr, isIDCONT_uvchr,
* isIDFIRST_uvchr, isLOWER_uvchr, isPRINT_uvchr, isPSXSPC_uvchr,
* isPUNCT_uvchr, isSPACE_uvchr, isUPPER_uvchr, isWORDCHAR_uvchr,
* isWORDCHAR_uvchr, isXDIGIT_uvchr
*
* The UTF-8 handling is buggy in early Perls, and this can give inaccurate
* results for code points above 0xFF, until the implementation started
* settling down in 5.12 and 5.14 */
#endif
#define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \
" \\x%02x (too short; %d bytes available, need" \
" %d)\n"
/* Perls starting here had a new API which handled multi-character results */
#if (PERL_BCDVERSION >= 0x5007003)
#ifndef toLOWER_uvchr
# define toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l))
#endif
#ifndef toUPPER_uvchr
# define toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l))
#endif
#ifndef toTITLE_uvchr
#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
void
DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...)
{
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#ifdef PERL_IMPLICIT_CONTEXT
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext)
#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
void
DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */
#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
void
DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...)
{
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#ifdef PERL_IMPLICIT_CONTEXT
#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext)
#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
void
DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */
#if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
#define Perl_warner DPPP_(my_warner)
void
DPPP_(my_warner)(U32 err, const char *pat, ...)
{
va_list args;
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
}
# define warner Perl_warner
# define Perl_warner_nocontext Perl_warner
# endif
#endif
va_list args;
if ( ! ckWARN((err ) & 0xFF)
&& ! ckWARN((err >> 8) & 0xFF)
&& ! ckWARN((err >> 16) & 0xFF)
&& ! ckWARN((err >> 24) & 0xFF))
{
return;
}
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
}
# define ck_warner Perl_ck_warner
# endif
#endif
#if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner_d)
# if defined(NEED_ck_warner_d)
va_list args;
if ( ! ckWARN_d((err ) & 0xFF)
&& ! ckWARN_d((err >> 8) & 0xFF)
&& ! ckWARN_d((err >> 16) & 0xFF)
&& ! ckWARN_d((err >> 24) & 0xFF))
{
return;
}
va_start(args, pat);
vwarner(err, pat, &args);
va_end(args);
}
# define ck_warner_d Perl_ck_warner_d
# endif
#endif
#define mess_nocontext DPPP_(my_mess_nocontext)
#define Perl_mess_nocontext DPPP_(my_mess_nocontext)
SV*
DPPP_(my_mess_nocontext)(const char* pat, ...)
{
dTHX;
SV *sv;
va_list args;
va_start(args, pat);
sv = vmess(pat, &args);
va_end(args);
return sv;
}
#endif
#endif
#ifndef mess
#if defined(NEED_mess)
static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
#if defined(NEED_mess) || defined(NEED_mess_GLOBAL)
#define Perl_mess DPPP_(my_mess)
SV*
DPPP_(my_mess)(pTHX_ const char* pat, ...)
{
SV *sv;
va_list args;
va_start(args, pat);
sv = vmess(pat, &args);
va_end(args);
return sv;
}
#ifdef mess_nocontext
#define mess mess_nocontext
#else
#define mess Perl_mess_nocontext
#endif
#endif
PUTBACK;
D_PPP_CROAK_IF_ERROR(croak_on_error);
return sv;
}
#endif
#endif
#if ! defined(vload_module) && defined(start_subparse)
#if defined(NEED_vload_module)
static void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
static
#else
extern void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
#endif
#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL)
#ifdef vload_module
while (sv) {
imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
sv = va_arg(*args, SV*);
}
}
{
const line_t ocopline = PL_copline;
COP * const ocurcop = PL_curcop;
const int oexpect = PL_expect;
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
#if (PERL_BCDVERSION > 0x5003000)
veop,
#endif
modname, imop);
PL_expect = oexpect;
PL_copline = ocopline;
PL_curcop = ocurcop;
}
}
# undef load_module
#endif
#define load_module DPPP_(my_load_module)
#define Perl_load_module DPPP_(my_load_module)
void
DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...)
{
va_list args;
va_start(args, ver);
vload_module(flags, name, ver, &args);
va_end(args);
}
#endif
#endif
#ifndef newRV_inc
# define newRV_inc(sv) newRV(sv) /* Replace */
#endif
# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
#endif
#endif /* USE_ITHREADS */
#if (PERL_BCDVERSION >= 0x5006000)
#ifndef caller_cx
# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
static I32
DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
{
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT * const cx = &cxstk[i];
switch (CxTYPE(cx)) {
default:
continue;
case CXt_EVAL:
case CXt_SUB:
case CXt_FORMAT:
return i;
}
}
#endif
/*
* The grok_* routines have been modified to use warn() instead of
* Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
* which is why the stack variable has been renamed to 'xdigit'.
*/
#ifndef grok_bin
#if defined(NEED_grok_bin)
static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
static
#else
extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
#endif
#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
#ifdef grok_bin
# undef grok_bin
#endif
#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
#define Perl_grok_bin DPPP_(my_grok_bin)
UV
DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_2 = UV_MAX / 2;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading b or 0b.
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Binary number > 0b11111111111111111111111111111111 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_hex
#if defined(NEED_grok_hex)
static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
static
#else
extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
#endif
#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
#ifdef grok_hex
# undef grok_hex
#endif
#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
#define Perl_grok_hex DPPP_(my_grok_hex)
UV
DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_16 = UV_MAX / 16;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
const char *xdigit;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Hexadecimal number > 0xffffffff non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_oct
#if defined(NEED_grok_oct)
static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
static
#else
extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
#endif
#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
#ifdef grok_oct
# undef grok_oct
#endif
#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
#define Perl_grok_oct DPPP_(my_grok_oct)
UV
DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Octal number > 037777777777 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#define my_snprintf DPPP_(my_my_snprintf)
#define Perl_my_snprintf DPPP_(my_my_snprintf)
int
DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
{
dTHX;
int retval;
va_list ap;
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
#else
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
if (retval < 0 || (len > 0 && (Size_t)retval >= len))
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
/* Warning: my_sprintf
It's safer to use my_snprintf instead
*/
/* Replace my_sprintf with my_snprintf */
int
DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
{
va_list args;
va_start(args, pat);
vsprintf(buffer, pat, args);
va_end(args);
return strlen(buffer);
}
#endif
#endif
#ifdef NO_XSLOCKS
# ifdef dJMPENV
*retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
*retlen = D_PPP_MIN(*retlen, curlen);
}
return UNICODE_REPLACEMENT;
}
else {
/* We use the error message in use from 5.8-5.26 */
Perl_warner(aTHX_ packWARN(WARN_UTF8),
"Malformed UTF-8 character (overflow at 0x%" UVxf
", byte 0x%02x, after start byte 0x%02x)",
ret, *cur_s, *s);
if (retlen) {
*retlen = (STRLEN) -1;
}
return 0;
}
}
/* Here, did not overflow, but if it failed for some other reason, and
* warnings are off, to emulate the behavior of the real utf8_to_uvchr(),
return ret;
}
# endif
#endif
#if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
#undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses
to read past a NUL, making it much less likely to read
off the end of the buffer. A NUL indicates the start
of the next character anyway. If the input isn't
NUL-terminated, the function remains unsafe, as it
always has been. */
#ifndef utf8_to_uvchr
# define utf8_to_uvchr(s, lp) \
((*(s) == '\0') \
? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \
: utf8_to_uvchr_buf(s, (s) + UTF8_CHK_SKIP(s), (lp)))
#endif
if (escaped != NULL)
*escaped= pv - str;
return SvPVX(dsv);
}
#endif
#endif
#ifndef pv_pretty
#if defined(NEED_pv_pretty)
static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
static
#else
extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
#endif
#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL)
#ifdef pv_pretty
# undef pv_pretty
#endif
#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g)
#define Perl_pv_pretty DPPP_(my_pv_pretty)
char *
DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count,
const STRLEN max, char const * const start_color, char const * const end_color,
const U32 flags)
{
const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
STRLEN escaped;
if (!(flags & PERL_PV_PRETTY_NOCLEAR))
sv_setpvs(dsv, "");
if (dq == '"')
sv_catpvs(dsv, "\"");
else if (flags & PERL_PV_PRETTY_LTGT)
sv_catpvs(dsv, "<");
if (start_color != NULL)
sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
if (end_color != NULL)
sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
if (dq == '"')
sv_catpvs(dsv, "\"");
else if (flags & PERL_PV_PRETTY_LTGT)
sv_catpvs(dsv, ">");
( run in 1.593 second using v1.01-cache-2.11-cpan-d6f9594c0a5 )