enum
'ReadHeaderType'
, [
qw(auto none check)
];
has
header
=> (
is
=>
'ro'
,
lazy
=> 1,
isa
=>
'ReadHeaderType'
,
default
=>
'auto'
);
has
extra_class_params
=> (
is
=>
'ro'
,
isa
=>
'ArrayRef[Str]'
,
default
=>
sub
{ [] }
);
has
pre_header_pattern
=> (
is
=>
'ro'
,
isa
=>
'Maybe[RegexpRef]'
,
default
=>
undef
);
has
_is_pre_header
=> (
is
=>
'ro'
,
isa
=>
'CodeRef'
,
lazy
=> 1,
builder
=>
'_init_is_pre_header'
);
sub
_init_is_pre_header {
my
$self
=
shift
;
if
(
my
$pat
=
$self
->pre_header_pattern) {
sub
{
$_
[0] =~ /
$pat
/ }
}
else
{
$self
->_is_comment
}
}
has
pre_headers
=> (
is
=>
'ro'
,
isa
=>
'ArrayRef[Str]'
,
init_arg
=>
undef
,
default
=>
sub
{ [] }
);
has
_comments
=> (
is
=>
'ro'
,
isa
=>
'ArrayRef[Str]'
,
init_arg
=>
undef
,
writer
=>
'_set_comments'
,
default
=>
sub
{ [] }
);
around
BUILDARGS
=>
sub
{
my
$orig
=
shift
;
my
$class
=
shift
;
my
$arg
=
ref
(
$_
[0]) ?
$_
[0] : {
@_
};
my
%valid_arg
= (
file
=> 1,
handle
=> 1,
header
=> 1,
class
=> 1,
comment
=> 1,
pre_comment
=> 1,
pre_header
=> 1,
header_fix
=> 1,
extra_class_params
=> 1,
pre_header_pattern
=> 1,
comment_pattern
=> 1
);
$arg
->{_valid_arg} = \
%valid_arg
;
$arg
->{_open_mode} =
'<'
;
$class
->
$orig
(
$arg
);
};
sub
_read_no_header {
my
$self
=
shift
;
my
$none
=
$self
->header eq
'none'
;
(
$none
,
$none
);
}
sub
_fill_dyn_fields {
return
;
}
sub
_header {
my
$self
=
shift
;
my
$stream_fields
=
shift
;
my
$class_fields
=
$self
->fields;
return
$#$class_fields
<=
$#$stream_fields
&& all {
uc
(
$stream_fields
->[
$_
] ) eq
uc
(
$class_fields
->[
$_
] ) } 0 ..
$#$class_fields
;
}
sub
BUILD {
my
$self
=
shift
;
my
(
$none
,
$ret
) =
$self
->_read_no_header;
return
if
$ret
;
my
@pre
;
my
$stream_fields
= [];
my
$is_head
=
undef
;
print
"Starting pre-header checks\n"
if
$ENV
{HEADER_PROCESS};
if
(!
$self
->_peek) {
$self
->_fill_dyn_fields(
$none
, 0,
$stream_fields
);
}
else
{
while
(
my
$line
=
$self
->_read) {
my
$is_pre
;
my
$lline
=
$line
->{line};
sub
check1 {
my
(
$self
,
$test
,
$bool
,
$check
,
$line
) =
@_
;
if
(
$self
->
$bool
) {
print
" "
,
uc
(
$test
),(
$self
->
$check
->(
$line
) ?
":YES"
:
":no "
),
"\n"
;
}
else
{
print
" "
,
lc
(
$test
),
"\n"
;
}
}
print
"Checking line: $lline\n"
if
$ENV
{HEADER_PROCESS};
check1(
$self
,
'PH'
,
pre_header
=>
_is_pre_header
=>
$lline
)
if
$ENV
{HEADER_PROCESS};
check1(
$self
,
'PC'
,
pre_comment
=>
_is_comment
=>
$lline
)
if
$ENV
{HEADER_PROCESS};
check1(
$self
,
'CO'
,
comment
=>
_is_comment
=>
$lline
)
if
$ENV
{HEADER_PROCESS};
if
(
$self
->pre_header) {
$is_pre
=
$self
->_is_pre_header->(
$lline
);
$is_pre
||=
$self
->_is_comment->(
$lline
)
if
$self
->pre_comment;
}
else
{
$is_pre
=
$self
->_is_comment->(
$lline
)
if
$self
->comment;
}
if
(
$is_pre
) {
print
" -> pre\n"
if
$ENV
{HEADER_PROCESS};
push
@pre
,
$line
;
next
;
}
$stream_fields
=
$self
->header_fix->(
$line
)->{fields};
$is_head
=
$self
->_header(
$stream_fields
);
print
" -> NOT pre, none: $none, is_head: $is_head, header_proc: "
,
$self
->header,
"\n"
if
$ENV
{HEADER_PROCESS};
$self
->_fill_dyn_fields(
$none
,
$is_head
,
$stream_fields
);
if
(
$none
or !
$is_head
&&
$self
->header eq
'auto'
) {
print
" *** put back\n"
if
$ENV
{HEADER_PROCESS};
$self
->_unread(
@pre
,
$line
);
return
;
}
last
;
}
print
" *** kept\n"
if
$ENV
{HEADER_PROCESS};
my
$die
=
$self
->_num_fields !=
scalar
(
@$stream_fields
);
if
(
$die
|| !
$is_head
) {
my
$error
=
''
;
$error
=
'Headers do not match'
if
!
$is_head
;
$error
.=
' and wrong number of fields'
if
$die
;
$error
=~ s/^ and w/W/;
$self
->_croak(
$error
,
$stream_fields
);
}
push
@{
$self
->pre_headers }, (
map
{
$_
->{line} }
@pre
);
}
}
sub
read_comments {
my
$self
=
shift
;
my
$comments
=
$self
->_comments;
$self
->_set_comments( [] );
return
$comments
;
}
sub
_load_comments {
my
$self
=
shift
;
return
unless
$self
->comment;
my
$comments
=
$self
->_comments;
while
(
my
$line
=
$self
->_read) {
if
(!
$self
->_is_comment->(
$line
->{line} )) {
$self
->_unread(
$line
);
return
;
}
push
@$comments
,
$line
->{line};
}
}
sub
read
{
my
$self
=
shift
;
$self
->_load_comments;
return
unless
my
$values
=
$self
->_read;
my
$line
=
$values
->{line};
$values
=
$values
->{fields};
my
$error
;
my
$obj
;
$error
=
'Wrong number of fields'
if
scalar
(
@$values
) !=
$self
->_num_fields;
unless
(
$error
) {
eval
{
$obj
=
$self
->class->new(
field_values
=>
$values
,
@{
$self
->extra_class_params },
$self
->_read_config
);
};
$error
= $@
if
$@;
}
$self
->_croak(
$error
,
$values
)
if
$error
;
return
$obj
;
}
sub
filter {
my
(
$self
,
$filtersub
) =
@_
;
return
BoutrosLab::TSVStream::IO::Role::Reader::Filter->new(
reader
=>
$self
,
filtersub
=>
$filtersub
);
}
has
reader
=> (
is
=>
'ro'
,
isa
=>
'Object'
,
required
=> 1
);
has
filtersub
=> (
is
=>
'ro'
,
isa
=>
'CodeRef'
,
required
=> 1
);
sub
read
{
my
$self
=
shift
;
while
(
my
$record
=
$self
->reader->
read
) {
return
$record
if
$self
->filtersub->(
$record
);
}
return
;
}
sub
filter {
my
(
$self
,
$filtersub
) =
@_
;
return
BoutrosLab::TSVStream::IO::Role::Reader::Filter->new(
reader
=>
$self
,
filtersub
=>
$filtersub
);
}
1;