our
$VERSION
=
"0.82"
;
my
%_CMD_LOC_FOR
= ();
sub
new {
my
$self
=
shift
;
my
$class
=
ref
$self
||
$self
;
return
bless
{},
$class
;
}
sub
add_pattern {
my
(
$self
,
$pattern
,
$callback
) =
@_
;
confess(
"Pattern is mandatory\n"
)
unless
$pattern
;
confess(
"Code reference is expected\n"
)
unless
ref
(
$callback
) eq
'CODE'
;
my
$pattern_map
=
$self
->_search_pattern();
if
(!
$pattern_map
) {
$pattern_map
= {};
$self
->_search_pattern(
$pattern_map
);
}
$pattern_map
->{
$pattern
} = [
$callback
];
}
sub
search {
my
(
$self
,
$base_dir
,
$do_extract
) =
@_
;
my
$dirs_ref
= [
$base_dir
];
$self
->_walk_tree(
$dirs_ref
,
sub
{
my
(
$file
) =
@_
;
my
$ctx
=
''
;
$self
->_match(
$do_extract
,
$base_dir
,
$ctx
,
$file
);
if
(
$self
->_is_archive_file(
$file
)) {
my
$ctx
=
$file
.
'__'
;
$ctx
=
$self
->_strip_dir(
$base_dir
,
$ctx
);
$self
->_search_in_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
);
}
});
$self
->_callback();
}
sub
reset_matches {
my
(
$self
) =
@_
;
my
$patterns
=
$self
->_search_pattern();
foreach
my
$pat
(
keys
(
%$patterns
)) {
undef
(
$patterns
->{
$pat
}[1]);
}
}
sub
working_dir {
my
(
$self
,
$value
) =
@_
;
if
(
defined
$value
) {
my
$oldval
=
$self
->{working_dir};
$self
->{working_dir} =
$value
;
return
$oldval
;
}
return
$self
->{working_dir};
}
sub
show_extracting_output {
my
(
$self
,
$value
) =
@_
;
if
(
defined
$value
) {
my
$oldval
=
$self
->{show_extracting_output};
$self
->{show_extracting_output} =
$value
;
return
$oldval
;
}
return
$self
->{show_extracting_output};
}
sub
_extract_matched {
my
(
$self
,
$base_dir
,
$ctx
,
$file
,
$do_extract
) =
@_
;
my
$dest
;
my
$work_dir
=
$self
->working_dir();
if
(
$ctx
ne
''
) {
my
$parent
= catfile(
$base_dir
,
substr
(
$ctx
, 0, -2));
my
$extract_dir
= catdir(
$work_dir
,
$ctx
);
if
(
$do_extract
) {
my
$ret
=
$self
->_extract_archive_file(
$parent
,
$file
,
$extract_dir
);
if
(!
$ret
) {
carp(
"$file can not be extracted from $parent, ignored\n"
);
return
undef
;
}
}
$dest
= catfile(
$extract_dir
,
$file
);
}
else
{
my
$local_path
=
$self
->_strip_dir(
$base_dir
,
$file
);
$dest
= catfile(
$work_dir
,
$local_path
);
if
(
$do_extract
) {
my
$dir2
= catdir(
$work_dir
,
$self
->_dir_name(
$local_path
));
mkpath(
$dir2
)
unless
-d
$dir2
;
my
$ret
= copy(
$file
,
$dest
);
if
(!
$ret
) {
carp(
"Can't copy file $file to $dest due to: $!\n"
);
return
undef
;
}
}
}
return
$dest
;
}
sub
_match {
my
(
$self
,
$do_extract
,
$base_dir
,
$ctx
,
$file
) =
@_
;
my
$matches
= 0;
my
$part
=
$self
->_strip_dir(catdir(
$base_dir
,
$ctx
),
$file
);
my
$patterns
=
$self
->_search_pattern();
foreach
my
$pat
(
keys
(
%$patterns
)) {
if
(
$part
=~ /
$pat
/) {
$matches
++;
my
$dest
=
$self
->_extract_matched(
$base_dir
,
$ctx
,
$file
,
$do_extract
);
next
unless
$dest
;
my
$pat_ref
=
$patterns
->{
$pat
};
if
(!
defined
(
$pat_ref
->[1])) {
$pat_ref
->[1] = [
$dest
];
}
else
{
push
@{
$pat_ref
->[1]},
$dest
;
}
}
}
return
$matches
;
}
sub
_callback {
my
(
$self
) =
@_
;
my
$patterns
=
$self
->_search_pattern();
foreach
my
$pat
(
keys
(
%$patterns
)) {
my
$pat_ref
=
$patterns
->{
$pat
};
if
(
ref
(
$pat_ref
->[0]) eq
'CODE'
&&
defined
(
$pat_ref
->[1])) {
$pat_ref
->[0]->(
$pat
,
$pat_ref
->[1]);
}
}
$self
->_cleanup();
}
sub
_walk_tree {
my
(
$self
,
$dirs_ref
,
$file_handler
) =
@_
;
my
@dirs
= ();
foreach
my
$dir
(
@$dirs_ref
) {
if
(-d
$dir
) {
my
$ret
=
opendir
(DIR,
$dir
);
if
(!
$ret
) {
carp(
"Can't read directory due to: $!\n"
);
next
;
}
while
(
my
$entry
=
readdir
(DIR)) {
next
if
$entry
eq
'.'
||
$entry
eq
'..'
;
my
$full_path
= catfile(
$dir
,
$entry
);
if
(-f
$full_path
) {
$file_handler
->(
$full_path
);
}
elsif
(-d
$full_path
) {
push
@dirs
,
$full_path
;
}
}
closedir
(DIR);
}
}
if
(
@dirs
) {
$self
->_walk_tree(\
@dirs
,
$file_handler
);
}
}
sub
_search_in_archive {
my
(
$self
,
$do_extract
,
$base_dir
,
$ctx
,
$file
) =
@_
;
if
(
$file
=~ /\.zip$/) {
if
(
$self
->_is_cmd_avail(
'7za'
)) {
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
'7za l'
,
'(-+)\s+(-+)\s+(-+)\s+(-+)\s+(-+)'
,
'---+'
,
''
,
sub
{
my
(
$entry
,
undef
,
undef
,
undef
,
undef
,
$file_pos
) =
@_
;
my
(
undef
,
undef
,
$a
,
undef
) =
split
(
' '
,
$entry
, 4);
return
undef
if
$a
=~ /^D/;
if
(
$file_pos
&&
$file_pos
<
length
(
$entry
)) {
my
$f
=
substr
(
$entry
,
$file_pos
);
return
$f
;
}
return
undef
;
}
);
}
else
{
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
"unzip -l"
,
"--------"
,
"--------"
,
''
,
sub
{
my
(
$entry
) =
@_
;
my
(
undef
,
undef
,
undef
,
$f
) =
split
(
' '
,
$entry
, 4);
return
$f
;
}
);
}
}
elsif
(
$file
=~ /\.7z$/) {
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
'7za l'
,
'(-+)\s+(-+)\s+(-+)\s+(-+)\s+(-+)'
,
'---+'
,
''
,
sub
{
my
(
$entry
,
undef
,
undef
,
undef
,
undef
,
$file_pos_7z
) =
@_
;
my
(
undef
,
undef
,
$a
,
undef
) =
split
(
' '
,
$entry
, 4);
return
undef
if
$a
=~ /^D/;
if
(
$file_pos_7z
&&
$file_pos_7z
<
length
(
$entry
)) {
my
$f
=
substr
(
$entry
,
$file_pos_7z
);
return
$f
;
}
return
undef
;
}
);
}
elsif
(
$file
=~ /\.rar$/) {
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
"unrar vb"
,
''
,
''
,
''
,
sub
{
my
(
$entry
) =
@_
;
return
$entry
;
}
);
}
elsif
(
$file
=~ /\.tgz$|\.tar\.gz$|\.tar\.Z$/) {
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
"tar -tzf"
,
''
,
''
,
'\/$'
,
sub
{
my
(
$entry
) =
@_
;
return
$entry
;
}
);
}
elsif
(
$file
=~ /\.bz2$/) {
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
"tar -tjf"
,
''
,
''
,
'\/$'
,
sub
{
my
(
$entry
) =
@_
;
return
$entry
;
}
);
}
elsif
(
$file
=~ /\.tar$/) {
$self
->_peek_archive(
$do_extract
,
$base_dir
,
$ctx
,
$file
,
"tar -tf"
,
''
,
''
,
'\/$'
,
sub
{
my
(
$entry
) =
@_
;
return
$entry
;
}
);
}
else
{
carp(
"Archive file $file is not supported\n"
);
}
}
sub
_peek_archive {
my
(
$self
,
$do_extract
,
$base_dir
,
$ctx
,
$file
,
$list_cmd
,
$begin_pat
,
$end_pat
,
$ignore_pat
,
$sub
) =
@_
;
my
(
$ar_cmd
) =
split
(/\s+/,
$list_cmd
);
if
(!
$self
->_is_cmd_avail(
$ar_cmd
)) {
carp(
"$ar_cmd not in PATH, archive $file ignored\n"
);
return
;
}
my
$tmpdir
=
$self
->working_dir();
my
$lst_file
=
$self
->_get_list_file();
my
$cmd
=
join
(
" "
,
$list_cmd
,
$self
->_escape(
$file
));
my
$cmd_shell
=
"$cmd > $lst_file 2>&1"
;
my
$ret
=
system
(
$cmd_shell
);
if
(
$ret
!= 0) {
carp(
"Can't run $cmd due to: $!\n"
);
return
;
}
$ret
=
open
(
my
$fh
,
"<$lst_file"
);
if
(!
$ret
) {
carp(
"Can't open file $lst_file due to: $!\n"
);
return
;
}
my
@col_indexes
;
my
$file_list_begin
= 0;
while
(<
$fh
>) {
chomp
;
my
$line
=
$_
;
if
(
$begin_pat
) {
if
(!
$file_list_begin
) {
my
@captures
=
$line
=~ /
$begin_pat
/g;
if
(
@captures
) {
my
$pos
= 0;
$file_list_begin
= 1;
foreach
my
$cap
(
@captures
) {
push
@col_indexes
,
index
(
$line
,
$cap
,
$pos
);
$pos
+=
length
(
$cap
);
}
}
next
;
}
}
if
(
$ignore_pat
) {
next
if
/
$ignore_pat
/;
}
if
(
$end_pat
) {
last
if
/
$end_pat
/;
}
my
$f
=
$sub
->(
$line
,
@col_indexes
);
next
unless
$f
;
$self
->_match(
$do_extract
,
$base_dir
,
$ctx
,
$f
);
if
(
$self
->_is_archive_file(
$f
)) {
my
$extract_dir
= catdir(
$tmpdir
,
$ctx
);
my
$ret
=
$self
->_extract_archive_file(
$file
,
$f
,
$extract_dir
);
if
(
$ret
) {
my
$new_ctx
= catfile(
$ctx
,
$f
.
'__'
);
$self
->_search_in_archive(
$do_extract
,
$tmpdir
,
$new_ctx
,
catfile(
$extract_dir
,
$f
)
);
}
else
{
carp(
"$f can not be extracted from $file, ignored\n"
);
}
}
}
close
(
$fh
);
}
sub
_extract_archive_file {
my
(
$self
,
$parent
,
$file
,
$extract_dir
) =
@_
;
mkpath(
$extract_dir
)
unless
-d
$extract_dir
;
my
$cmd
=
""
;
if
(
$parent
=~ /\.zip$/) {
if
(
$self
->_is_cmd_avail(
'7za'
)) {
$cmd
=
$self
->_build_cmd(
'7za x -y -pxxx'
,
$extract_dir
,
$parent
,
$file
);
}
else
{
$cmd
=
$self
->_build_cmd(
'unzip -P xxx -o'
,
$extract_dir
,
$parent
,
$file
);
}
}
elsif
(
$parent
=~ /\.zip$|\.7z$/) {
$cmd
=
$self
->_build_cmd(
'7za x -y -pxxx'
,
$extract_dir
,
$parent
,
$file
);
}
elsif
(
$parent
=~ /\.rar$/) {
$cmd
=
$self
->_build_cmd(
'unrar x -o+'
,
$extract_dir
,
$parent
,
$file
);
}
elsif
(
$parent
=~ /\.tgz$|\.tar\.gz$|\.tar\.Z$/) {
$cmd
=
$self
->_build_cmd(
'tar -xzof'
,
$extract_dir
,
$parent
,
$file
);
}
elsif
(
$parent
=~ /\.bz2$/) {
$cmd
=
$self
->_build_cmd(
'tar -xjof'
,
$extract_dir
,
$parent
,
$file
);
}
elsif
(
$parent
=~ /\.tar$/) {
$cmd
=
$self
->_build_cmd(
'tar -xof'
,
$extract_dir
,
$parent
,
$file
);
}
my
$cmd_shell
=
sprintf
(
"%s 2>%s 1>&2"
,
$cmd
, devnull());
$cmd_shell
=
"$cmd 1>&2"
if
$self
->show_extracting_output();
my
$ret
=
system
(
$cmd_shell
);
return
$ret
== 0;
}
sub
_build_cmd {
my
(
$self
,
$extract_cmd
,
$dir
,
$parent
,
$file
) =
@_
;
my
$chdir_cmd
=
q[cd]
;
if
($^O eq
'MSWin32'
) {
$chdir_cmd
=
q[cd /d]
;
}
return
sprintf
(
"%s %s && %s %s %s"
,
$chdir_cmd
,
$self
->_escape(
$dir
),
$extract_cmd
,
$self
->_escape(
$parent
),
$self
->_escape(
$file
)
);
}
sub
_is_cmd_avail {
my
(
$self
,
$cmd
) =
@_
;
if
(!
exists
$_CMD_LOC_FOR
{
$cmd
}) {
my
@path
= path();
foreach
my
$p
(
@path
) {
my
$fp
= catfile(
$p
,
$cmd
);
if
(-f
$fp
) {
$_CMD_LOC_FOR
{
$cmd
} =
$fp
;
return
1;
}
else
{
if
($^O eq
'MSWin32'
) {
my
$fp_win
=
$fp
.
".exe"
;
if
(-f
$fp_win
) {
$_CMD_LOC_FOR
{
$cmd
} =
$fp_win
;
return
1;
}
$fp_win
=
$fp
.
".bat"
;
if
(-f
$fp_win
) {
$_CMD_LOC_FOR
{
$cmd
} =
$fp_win
;
return
1;
}
}
}
}
$_CMD_LOC_FOR
{
$cmd
} =
""
;
}
return
$_CMD_LOC_FOR
{
$cmd
} ? 1 : 0;
}
sub
_strip_dir {
my
(
$self
,
$base_dir
,
$path
) =
@_
;
my
$dir1
=
$base_dir
;
my
$path1
=
$path
;
my
$path_sep
=
'/'
;
$path_sep
=
'\\'
if
$^O eq
'MSWin32'
;
$dir1
.=
$path_sep
unless
substr
(
$dir1
, -1, 1) eq
$path_sep
;
if
(
index
(
$path1
,
$dir1
) == 0) {
$path1
=
substr
(
$path1
,
length
(
$dir1
));
}
return
$path1
;
}
sub
_escape {
my
(
$self
,
$str
) =
@_
;
my
$ret
=
$str
;
if
($^O ne
'MSWin32'
) {
$ret
=~ s/([ ;<>\\\*\|`&\$!
}
else
{
$ret
=
qq["$ret"]
if
$ret
=~ /[ &
}
return
$ret
;
}
sub
_is_archive_file {
my
(
$self
,
$file
) =
@_
;
return
$file
=~ /\.(zip|7z|rar|tgz|bz2|tar|tar\.gz|tar\.Z)$/
}
sub
_property {
my
(
$self
,
$attr
,
$value
) =
@_
;
if
(
defined
$value
) {
my
$oldval
=
$self
->{
$attr
};
$self
->{
$attr
} =
$value
;
$self
->{_properties_with_value} = {}
if
(!
exists
$self
->{_properties_with_value});
$self
->{_properties_with_value}{
$attr
} = 1;
return
$oldval
;
}
return
$self
->{
$attr
};
}
sub
_remove_property ($$) {
my
(
$self
,
$attr
) =
@_
;
$self
->{
$attr
} =
undef
;
}
sub
_search_pattern {
my
(
$self
,
$value
) =
@_
;
if
(
defined
$value
) {
my
$oldval
=
$self
->{search_pattern};
$self
->{search_pattern} =
$value
;
return
$oldval
;
}
return
$self
->{search_pattern};
}
sub
_dir_name {
my
(
$self
,
$path
) =
@_
;
my
$path_sep
=
'/'
;
$path_sep
=
'\\'
if
$^O eq
'MSWin32'
;
my
$idx
=
rindex
(
$path
,
$path_sep
);
if
(
$idx
> 0) {
return
substr
(
$path
, 0,
$idx
);
}
else
{
return
''
;
}
}
sub
_get_list_file {
my
(
$self
) =
@_
;
my
(
undef
,
$lst
) = tempfile();
my
$files
=
$self
->_property(
'archive_lst_files'
);
if
(!
defined
(
$files
)) {
$files
= [];
$self
->_property(
'archive_lst_files'
,
$files
);
}
push
@$files
,
$lst
;
return
$lst
;
}
sub
_cleanup {
my
(
$self
) =
@_
;
my
$files
=
$self
->_property(
'archive_lst_files'
);
foreach
my
$f
(
@$files
) {
unlink
(
$f
);
}
}
1;