has
header_check_sub
=> (
is
=>
'rw'
,
isa
=>
'CodeRef'
,
writer
=>
'set_header_check_sub'
,
reader
=>
'get_header_check_sub'
,
default
=>
sub
{
return
sub
{
return
1 }; });
has
stanza_check_sub
=> (
is
=>
'rw'
,
isa
=>
'CodeRef'
,
writer
=>
'set_stanza_check_sub'
,
reader
=>
'get_stanza_check_sub'
,
default
=>
sub
{
return
sub
{
return
1 }; });
has
tag_check_sub
=> (
is
=>
'rw'
,
isa
=>
'CodeRef'
,
writer
=>
'set_tag_check_sub'
,
reader
=>
'get_tag_check_sub'
,
default
=>
sub
{
return
sub
{
return
1 }; });
my
$body_subs
= {
"id"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{stanzaclass} eq
'term'
) {
${
$args
->{node}} = ${
$args
->{graph}}->add_term(
$args
->{value});
}
elsif
(
$args
->{stanzaclass} eq
'typedef'
) {
${
$args
->{node}} = ${
$args
->{graph}}->add_relation(
$args
->{value});
}
elsif
(
$args
->{stanzaclass} eq
'instance'
) {
${
$args
->{node}} = ${
$args
->{graph}}->instance_noderef(
$args
->{value});
${
$args
->{graph}}->add_instance(${
$args
->{node}});
}
elsif
(
$args
->{stanzaclass} eq
'annotation'
) {
}
else
{
warn
"Unknown stanza class "
.
$args
->{stanzaclass};
}
if
(!${
$args
->{node}}) {
die
"cannot parse: $_"
;
}
${
$args
->{node}}->namespace(
$self
->default_namespace)
if
(!${
$args
->{node}}->namespace &&
$self
->default_namespace);
},
"name"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->label(
$args
->{value});
},
"namespace"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->namespace(
$args
->{value});
},
"alt_id"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->add_alt_ids(
$args
->{value});
},
"def"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$vals
= [];
_parse_vals(
$args
->{value},
$vals
);
$args
->{node}->definition(
$vals
->[0]);
if
(
$vals
->[1] && @{
$vals
->[1]}) {
$args
->{node}->definition_xrefs( [
map
{
$_
= new GOBO::Node({
id
=>
$_
}) } @{
$vals
->[1]} ]);
}
},
"is_obsolete"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{value} eq
'true'
)
{
$args
->{node}->obsolete(1);
}
},
"property_value"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$vals
= [];
_parse_vals(
$args
->{value},
$vals
);
$args
->{node}->add_property_value(
$vals
->[0],
$vals
->[1]);
},
"comment"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->comment(
$args
->{value});
},
"subset"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$ss
=
$args
->{graph}->subset_noderef(
$args
->{value});
$args
->{node}->add_subsets(
$ss
);
if
(
$self
->liberal_mode && !
$args
->{graph}->subset_index->{
$ss
->id})
{
print
STDERR
$args
->{value} .
" was not in the subset index. Crap!\n"
;
$args
->{graph}->subset_index->{
$args
->{value}} =
$ss
;
}
},
"consider"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->add_considers(
$args
->{value});
},
"replaced_by"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->add_replaced_bys(
$args
->{value});
},
"created_by"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->created_by(
$args
->{value});
},
"creation_date"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->creation_date(
$args
->{value});
},
"synonym"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$vals
= [];
_parse_vals(
$args
->{value},
$vals
);
my
$syn
= new GOBO::Synonym(
label
=>
shift
@$vals
);
$args
->{node}->add_synonym(
$syn
);
my
$xrefs
=
pop
@$vals
;
if
(
@$vals
) {
$syn
->scope(
shift
@$vals
);
}
else
{
warn
"no scope specified: $_"
;
}
if
(
$vals
->[0] && !
ref
(
$vals
->[0])) {
$syn
->type(
shift
@$vals
);
}
$syn
->xrefs(
$xrefs
);
},
"xref"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->add_xrefs(
$args
->{value});
},
"is_a"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{value} =~ /^(\S+)(.*)/) {
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef($1);
}
else
{
$tn
=
$args
->{graph}->term_noderef($1);
}
my
$s
= new GOBO::LinkStatement(
node
=>
$args
->{node},
relation
=>
'is_a'
,
target
=>
$tn
);
$self
->add_metadata(
$s
,$2);
$args
->{graph}->add_link(
$s
);
if
(
$args
->{stanzaclass} eq
'typedef'
) {
$args
->{node}->add_subrelation_of(
$tn
);
}
}
},
"relationship"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{value} =~ /(\S+)\s+(\S+)(.*)/) {
my
$rn
=
$args
->{graph}->relation_noderef($1);
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef($2);
}
else
{
$tn
=
$args
->{graph}->term_noderef($2);
}
my
$s
= new GOBO::LinkStatement(
node
=>
$args
->{node},
relation
=>
$rn
,
target
=>
$tn
);
$self
->add_metadata(
$s
,$3);
$args
->{graph}->add_link(
$s
);
}
},
"complement_of"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef(
$args
->{value});
}
else
{
$tn
=
$args
->{graph}->term_noderef(
$args
->{value});
}
$args
->{node}->complement_of(
$tn
);
},
"disjoint_from"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef(
$args
->{value});
}
else
{
$tn
=
$args
->{graph}->term_noderef(
$args
->{value});
}
$args
->{node}->add_disjoint_from(
$tn
);
},
"domain"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
=
$args
->{graph}->term_noderef(
$args
->{value});
$args
->{node}->domain(
$tn
);
},
"range"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
=
$args
->{graph}->term_noderef(
$args
->{value});
$args
->{node}->range(
$tn
);
},
"disjoint_over"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
=
$args
->{graph}->relation_noderef(
$args
->{value});
$args
->{node}->add_disjoint_over(
$tn
);
},
"inverse_of"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
=
$args
->{graph}->relation_noderef(
$args
->{value});
$args
->{node}->add_inverse_of(
$tn
);
},
"inverse_of_on_instance_level"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
=
$args
->{graph}->relation_noderef(
$args
->{value});
$args
->{node}->add_inverse_of_on_instance_level(
$tn
);
},
"instance_of"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{value} =~ /^(\S+)/)
{
my
$tn
=
$args
->{graph}->term_noderef($1);
$args
->{node}->add_type(
$tn
);
}
},
"equivalent_to"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef(
$args
->{value});
}
else
{
$tn
=
$args
->{graph}->term_noderef(
$args
->{value});
}
$args
->{node}->add_equivalent_to(
$tn
);
},
"intersection_of"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{value} =~ /^(\S+)\s+(\S+)/) {
my
$rn
=
$args
->{graph}->relation_noderef($1);
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef($2);
}
else
{
$tn
=
$args
->{graph}->term_noderef($2);
}
my
$s
= new GOBO::LinkStatement(
node
=>
$args
->{node},
relation
=>
$rn
,
target
=>
$tn
,
is_intersection
=>1);
$args
->{graph}->add_link(
$s
);
}
elsif
(
$args
->{value} =~ /^(\S+)/) {
my
$tn
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$tn
=
$args
->{graph}->relation_noderef($1);
}
else
{
$tn
=
$args
->{graph}->term_noderef($1);
}
my
$s
= new GOBO::LinkStatement(
node
=>
$args
->{node},
relation
=>
'is_a'
,
target
=>
$tn
,
is_intersection
=>1);
$args
->{graph}->add_link(
$s
);
}
else
{
$self
->throw(
"badly formatted intersection: $_"
);
}
},
"union_of"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$u
;
if
(
$args
->{stanzaclass} eq
'typedef'
)
{
$u
=
$args
->{graph}->relation_noderef(
$args
->{value});
}
else
{
$u
=
$args
->{graph}->term_noderef(
$args
->{value});
}
my
$ud
=
$args
->{node}->union_definition;
if
(!
$ud
) {
$ud
= new GOBO::ClassExpression::Union;
$args
->{node}->union_definition(
$ud
);
}
$ud
->add_argument(
$u
);
},
"transitive_over"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$rn
=
$args
->{graph}->relation_noderef(
$args
->{value});
$args
->{node}->transitive_over(
$rn
);
},
"holds_over_chain"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
@rels
=
map
{
$args
->{graph}->relation_noderef(
$_
) }
split
(
' '
,
$args
->{value});
$args
->{node}->add_holds_over_chain(\
@rels
);
},
"equivalent_to_chain"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
@rels
=
map
{
$args
->{graph}->relation_noderef(
$_
) }
split
(
' '
,
$args
->{value});
$args
->{node}->add_equivalent_to_chain(\
@rels
);
},
"is_"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$att
=
$args
->{tag};
if
(
$args
->{value} eq
'true'
)
{
$args
->{node}->
$att
( 1 );
}
},
"subject"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->node(
$args
->{graph}->noderef(
$args
->{value}));
},
"relation"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->relation(
$args
->{graph}->relation_noderef(
$args
->{value}));
},
"object"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->target(
$args
->{graph}->noderef(
$args
->{value}));
},
"description"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->description(
$args
->{value});
},
"source"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->provenance(
$args
->{graph}->noderef(
$args
->{value}));
},
"assigned_by"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{node}->source(
$args
->{graph}->noderef(
$args
->{value}));
},
"formula"
=>
sub
{
my
(
$self
,
$args
) =
@_
;
my
$vals
= [];
_parse_vals(
$args
->{value},
$vals
);
my
$f
= new GOBO::Formula(
text
=>
$vals
->[0],
language
=>
$vals
->[1]);
$f
->associated_with(
$args
->{node});
$args
->{graph}->add_formula(
$f
);
},
};
my
$header_subs
= {
'subsetdef'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
if
(
$args
->{value} =~ /^(\S+)\s+\"(.*)\"/)
{
my
(
$id
,
$label
) = ($1,$2);
my
$ss
= new GOBO::Subset(
id
=>
$id
,
label
=>
$label
);
$args
->{graph}->subset_index->{
$id
} =
$ss
;
}
else
{
warn
"Uh-oh... subset value "
.
$args
->{value};
}
},
'date'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{graph}->date(
$args
->{value});
},
'remark'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{graph}->comment(
$args
->{value});
},
'data-version'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{graph}->version(
$args
->{value});
},
'default'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$args
->{graph}->set_property_value(
$args
->{tag},
$args
->{value});
},
'default-namespace'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$self
->default_namespace(
$args
->{value});
},
'format-version'
=>
sub
{
my
(
$self
,
$args
) =
@_
;
$self
->format_version(
$args
->{value});
},
};
override
'parse_header'
=>
sub
{
my
$self
=
shift
;
my
$g
=
$self
->graph;
my
$header_check
=
$self
->get_header_check_sub;
$/ =
"\n"
;
while
(
$_
=
$self
->next_line) {
next
unless
/\S/;
if
(/^\[/) {
$self
->unshift_line(
$_
);
last
;
}
if
(/^(\S+):\s*(.*?)$/) {
next
unless
&$header_check
($1);
if
(
$header_subs
->{$1})
{
$header_subs
->{$1}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
});
}
else
{
$header_subs
->{
default
}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
});
}
}
}
$self
->parsed_header(1);
return
;
};
sub
parse_header_from_array {
my
$self
=
shift
;
my
$args
=
shift
;
my
$g
=
$args
->{graph} || new GOBO::Graph;
my
$header_check
=
$self
->get_header_check_sub;
foreach
(@{
$args
->{array}})
{
next
unless
/\S/;
if
(/^\[/) {
last
;
}
if
(/^(\S+):\s*(.*?)$/) {
next
unless
&$header_check
($1);
if
(
$header_subs
->{$1})
{
$header_subs
->{$1}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
});
}
else
{
$header_subs
->{
default
}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
});
}
}
}
return
$g
;
}
override
'parse_body'
=>
sub
{
my
$self
=
shift
;
my
$stanza_check
=
$self
->get_stanza_check_sub;
my
$tag_check
=
$self
->get_tag_check_sub;
if
(
$self
->has_body_parser_options &&
$self
->body_parser_options->{ignore_all})
{
return
;
}
my
$stanzaclass
;
my
$n
;
my
@anns
= ();
my
$g
=
$self
->graph;
while
(
$_
=
$self
->next_line) {
next
unless
/\S/;
if
(/^\[(\S+)\]/) {
undef
$n
;
$stanzaclass
=
lc
($1);
next
unless
&$stanza_check
(
$stanzaclass
);
if
(
$stanzaclass
eq
'annotation'
) {
$n
= new GOBO::Annotation;
push
(
@anns
,
$n
);
}
next
;
}
if
(/^id:\s*(.*)\s*$/) {
$body_subs
->{id}->(
$self
, {
value
=> $1,
graph
=> \
$g
,
node
=> \
$n
,
stanzaclass
=>
$stanzaclass
});
next
;
}
if
(/^(.*?):\s*/) {
next
unless
&$tag_check
(
$stanzaclass
, $1 );
}
s/\!.*//;
s/\s+$//;
if
(/^(.*?):\s*(.*)$/) {
if
(
$body_subs
->{$1}) {
$body_subs
->{$1}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
,
node
=>
$n
,
stanzaclass
=>
$stanzaclass
});
next
;
}
elsif
(/^is_(\w+):\s*(\w+)/) {
$body_subs
->{
'is_'
}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
,
node
=>
$n
} );
next
;
}
}
warn
"ignored: $_"
;
}
if
(
@anns
) {
$g
->add_annotations(\
@anns
);
}
return
;
};
sub
parse_body_from_array {
my
$self
=
shift
;
my
$args
=
shift
;
my
$g
=
$args
->{graph} || new GOBO::Graph;
confess( (
caller
(0))[3] .
": missing required arguments"
)
unless
defined
$g
&&
$args
->{array} && @{
$args
->{array}};
my
$stanza_check
=
$self
->get_stanza_check_sub;
my
$tag_check
=
$self
->get_tag_check_sub;
if
(
$self
->has_body_parser_options &&
$self
->body_parser_options->{ignore_all})
{
return
;
}
my
$stanzaclass
;
my
$n
;
my
@anns
= ();
foreach
(@{
$args
->{array}})
{
next
unless
/\S/;
if
(/^\[(\S+)\]/) {
undef
$n
;
$stanzaclass
=
lc
($1);
next
unless
&$stanza_check
(
$stanzaclass
);
if
(
$stanzaclass
eq
'annotation'
) {
$n
= new GOBO::Annotation;
push
(
@anns
,
$n
);
}
next
;
}
if
(/^id:\s*(.*)\s*$/) {
$body_subs
->{id}->(
$self
, {
value
=> $1,
graph
=> \
$g
,
node
=> \
$n
,
stanzaclass
=>
$stanzaclass
});
next
;
}
if
(/^(.*?):\s*/) {
next
unless
&$tag_check
(
$stanzaclass
, $1 );
}
s/\!.*//;
s/\s+$//;
if
(/^(.*?):\s*(.*)$/) {
if
(
$body_subs
->{$1}) {
$body_subs
->{$1}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
,
node
=>
$n
,
stanzaclass
=>
$stanzaclass
});
next
;
}
elsif
(/^is_(\w+):\s*(\w+)/) {
$body_subs
->{
'is_'
}->(
$self
, {
tag
=> $1,
value
=> $2,
graph
=>
$g
,
node
=>
$n
} );
next
;
}
}
warn
"ignored: $_"
;
}
if
(
@anns
) {
$g
->add_annotations(\
@anns
);
}
return
$g
;
}
sub
_parse_vals {
GOBO::Parsers::OBOParser::_parse_vals(
@_
);
}
override
'check_options'
=>
sub
{
my
$self
=
shift
;
my
$options
=
$self
->options;
if
(
$options
&&
values
%$options
)
{
$self
->clear_header_parser_options;
$self
->clear_body_parser_options;
if
(
$options
->{header} &&
keys
%{
$options
->{header}})
{
if
(
$options
->{header}{ignore} &&
$options
->{header}{parse_only})
{
warn
"Warning: both ignore and parse_only specified in header parsing options; using setting in parse_only"
;
}
if
(
$options
->{header}{parse_only})
{
if
(
ref
$options
->{header}{parse_only} &&
ref
$options
->{header}{parse_only} eq
'ARRAY'
)
{
$self
->set_header_parser_options({
parse_only
=>
$options
->{header}{parse_only} });
my
$arr
=
$options
->{header}{parse_only};
$self
->set_header_check_sub(
sub
{
my
$t
=
shift
;
return
1
if
grep
{
$t
eq
$_
}
@$arr
;
return
undef
;
} );
}
else
{
warn
"wrong header options format"
;
}
}
elsif
(
$options
->{header}{ignore})
{
if
(!
ref
$options
->{header}{ignore} &&
$options
->{header}{ignore} eq
'*'
)
{
$self
->set_header_parser_options({
ignore_all
=> 1 });
$self
->set_header_check_sub(
sub
{
return
undef
; } );
}
elsif
(
ref
$options
->{header}{ignore} &&
ref
$options
->{header}{ignore} eq
'ARRAY'
)
{
$self
->set_header_parser_options({
ignore
=>
$options
->{header}{ignore} });
my
$arr
=
$self
->header_parser_options->{ignore};
$self
->set_header_check_sub(
sub
{
my
$t
=
shift
;
return
1
unless
grep
{
$t
eq
$_
}
@$arr
;
return
undef
;
} );
}
else
{
warn
"wrong header options format"
;
}
}
}
if
(
$options
->{body} &&
keys
%{
$options
->{body}})
{
my
$b_hash
;
if
(
$options
->{body}{ignore} &&
$options
->{body}{parse_only})
{
warn
"Warning: both ignore and parse_only specified in body parsing options; using setting in parse_only"
;
}
if
(
$options
->{body}{parse_only})
{
if
(
ref
$options
->{body}{parse_only} &&
ref
$options
->{body}{parse_only} eq
'HASH'
)
{
foreach
my
$s_type
(
keys
%{
$options
->{body}{parse_only}})
{
if
(!
ref
$options
->{body}{parse_only}{
$s_type
} &&
$options
->{body}{parse_only}{
$s_type
} eq
'*'
)
{
$b_hash
->{
$s_type
} = [
'*'
];
}
elsif
(
ref
$options
->{body}{parse_only}{
$s_type
} &&
ref
$options
->{body}{parse_only}{
$s_type
} eq
'ARRAY'
)
{
$b_hash
->{
$s_type
} =
$options
->{body}{parse_only}{
$s_type
};
}
}
if
(
$b_hash
)
{
$self
->set_body_parser_options({
parse_only
=>
$b_hash
});
$self
->set_stanza_check_sub(
sub
{
my
$s
=
shift
;
return
1
if
$b_hash
->{
$s
};
$self
->next_stanza([
keys
%$b_hash
]);
return
undef
;
} );
$self
->set_tag_check_sub(
sub
{
my
(
$s
,
$t
) =
@_
;
if
(
$b_hash
->{
$s
})
{
if
(
$b_hash
->{
$s
}[0] eq
'*'
||
grep
{
$t
eq
$_
} @{
$b_hash
->{
$s
}} )
{
return
1;
}
return
undef
;
}
warn
"Incorrect stanza type!\n"
;
$self
->next_stanza([
keys
%$b_hash
]);
return
undef
;
} );
}
}
else
{
warn
"wrong body options format"
;
}
}
elsif
(
$options
->{body}{ignore})
{
if
(
ref
$options
->{body}{ignore} &&
ref
$options
->{body}{ignore} eq
'HASH'
)
{
foreach
my
$s_type
(
keys
%{
$options
->{body}{ignore}})
{
if
(!
ref
$options
->{body}{ignore}{
$s_type
} &&
$options
->{body}{ignore}{
$s_type
} eq
'*'
)
{
$b_hash
->{
$s_type
} = [
'*'
];
}
elsif
(
ref
$options
->{body}{ignore}{
$s_type
} &&
ref
$options
->{body}{ignore}{
$s_type
} eq
'ARRAY'
)
{
$b_hash
->{
$s_type
} =
$options
->{body}{ignore}{
$s_type
};
}
}
if
(
$b_hash
)
{
$self
->set_body_parser_options({
ignore
=>
$b_hash
});
my
@ignore_all
=
grep
{
$b_hash
->{
$_
}[0] eq
'*'
}
keys
%$b_hash
;
if
(
@ignore_all
)
{
$self
->set_stanza_check_sub(
sub
{
my
$s
=
shift
;
if
(
grep
{
$s
eq
$_
}
@ignore_all
)
{
$self
->next_stanza(\
@ignore_all
,
'ignore'
);
return
undef
;
}
return
1;
} );
}
$self
->set_tag_check_sub(
sub
{
my
(
$s
,
$t
) =
@_
;
return
1
if
!
$b_hash
->{
$s
};
return
undef
if
(
$b_hash
->{
$s
}[0] eq
'*'
||
grep
{ /^
$t
$/i } @{
$b_hash
->{
$s
}} );
return
1;
} );
}
}
elsif
(!
ref
$options
->{body}{ignore} &&
$options
->{body}{ignore} eq
'*'
)
{
$self
->set_body_parser_options({
ignore_all
=> 1 });
}
else
{
warn
"wrong body options format"
;
}
}
}
}
$self
->checked_options(1);
};
after
'reset_parser'
=>
sub
{
my
$self
=
shift
;
$self
->set_header_check_sub(
sub
{
return
1 } );
$self
->set_stanza_check_sub(
sub
{
return
1 } );
$self
->set_tag_check_sub(
sub
{
return
1 } );
};
sub
get_header_check_sub {
my
$self
=
shift
;
$self
->check_options
if
!
$self
->checked_options;
return
$self
->header_check_sub;
}
sub
get_stanza_check_sub {
my
$self
=
shift
;
$self
->check_options
if
!
$self
->checked_options;
return
$self
->stanza_check_sub;
}
sub
get_tag_check_sub {
my
$self
=
shift
;
$self
->check_options
if
!
$self
->checked_options;
return
$self
->tag_check_sub;
}
1;