File Coverage

blib/lib/Filename/Archive.pm
Criterion Covered Total %
statement 31 32 96.8
branch 8 10 80.0
condition 1 2 50.0
subroutine 4 4 100.0
pod 1 1 100.0
total 45 49 91.8


line stmt bran cond sub pod time code
1             package Filename::Archive;
2              
3             our $DATE = '2015-09-03'; # DATE
4             our $VERSION = '0.02'; # VERSION
5              
6 1     1   582 use 5.010001;
  1         2  
7 1     1   4 use strict;
  1         2  
  1         19  
8 1     1   5 use warnings;
  1         2  
  1         458  
9              
10             require Exporter;
11             our @ISA = qw(Exporter);
12             our @EXPORT_OK = qw(check_archive_filename);
13             #list_archive_suffixes
14              
15             # XXX multi-part archive?
16              
17             our %SUFFIXES = (
18             '.zip' => {name=>'Zip'},
19             '.rar' => {name=>'RAR'},
20             '.tar' => {name=>'tar'},
21             # XXX 7zip
22             # XXX older/less popular: ARJ, lha, zoo
23             # XXX windows: cab
24             # XXX zip-based archives: war, etc
25             # XXX tar-based archives: linux packages
26             );
27              
28             our %ARCHIVES = (
29             Zip => {
30             # all programs mentioned here must accept filename(s) as arguments.
31             # preferably CLI. XXX specify capabilities (password-protection, unix
32             # permission, etc). XXX specify how to create (with password, etc). XXX
33             # specify how to extract.
34             archiver_programs => [
35             {name => 'zip', opts => ''},
36             ],
37             extractor_programs => [
38             {name => 'zip', opts => ''},
39             {name => 'unzip', opts => ''},
40             ],
41             },
42             RAR => {
43             },
44             tar => {
45             },
46             );
47              
48             our %SPEC;
49              
50             $SPEC{check_archive_filename} = {
51             v => 1.1,
52             summary => 'Check whether filename indicates being an archive file',
53             description => <<'_',
54              
55              
56             _
57             args => {
58             filename => {
59             schema => 'str*',
60             req => 1,
61             pos => 0,
62             },
63             # XXX recurse?
64             ci => {
65             summary => 'Whether to match case-insensitively',
66             schema => 'bool',
67             default => 1,
68             },
69             },
70             result_naked => 1,
71             result => {
72             schema => ['any*', of=>['bool*', 'hash*']],
73             description => <<'_',
74              
75             Return false if no archive suffixes detected. Otherwise return a hash of
76             information, which contains these keys: `archive_name`, `archive_suffix`,
77             `compressor_info`.
78              
79             _
80             },
81             };
82             sub check_archive_filename {
83 4     4 1 13443 require Filename::Compressed;
84              
85 4         658 my %args = @_;
86              
87 4         16 my $filename = $args{filename};
88 4   50     33 my $ci = $args{ci} // 1;
89              
90 4         9 my @compressor_info;
91 4         9 while (1) {
92 7         33 my $res = Filename::Compressed::check_compressed_filename(
93             filename => $filename, ci => $ci);
94 7 100       303 if ($res) {
95 3         11 push @compressor_info, $res;
96 3         8 $filename = $res->{uncompressed_filename};
97 3         7 next;
98             } else {
99 4         12 last;
100             }
101             }
102              
103 4 50       25 $filename =~ /(\.\w+)\z/ or return 0;
104 4         52 my $suffix = $1;
105              
106 4         10 my $spec;
107 4 50       10 if ($ci) {
108 4         9 my $suffix_lc = lc($suffix);
109 4         16 for (keys %SUFFIXES) {
110 9 100       35 if (lc($_) eq $suffix_lc) {
111 3         9 $spec = $SUFFIXES{$_};
112 3         9 last;
113             }
114             }
115             } else {
116 0         0 $spec = $SUFFIXES{$suffix};
117             }
118 4 100       21 return 0 unless $spec;
119              
120             return {
121             archive_name => $spec->{name},
122 3         71 archive_suffix => $suffix,
123             (compressor_info => \@compressor_info) x !!@compressor_info,
124             };
125             }
126              
127             1;
128             # ABSTRACT: Check whether filename indicates being an archive file
129              
130             __END__