File Coverage

blib/lib/Filename/Backup.pm
Criterion Covered Total %
statement 25 25 100.0
branch 7 8 87.5
condition 2 2 100.0
subroutine 4 4 100.0
pod 1 1 100.0
total 39 40 97.5


line stmt bran cond sub pod time code
1             package Filename::Backup;
2              
3             our $DATE = '2015-01-04'; # DATE
4             our $VERSION = '0.01'; # VERSION
5              
6 1     1   733 use 5.010001;
  1         4  
  1         50  
7 1     1   6 use strict;
  1         1  
  1         38  
8 1     1   6 use warnings;
  1         2  
  1         461  
9              
10             require Exporter;
11             our @ISA = qw(Exporter);
12             our @EXPORT_OK = qw(check_backup_filename);
13              
14             our %SPEC;
15              
16             our %SUFFIXES = (
17             '~' => 1,
18             '.bak' => 1,
19             '.old' => 1,
20             # XXX % (from /etc/mime.types)
21             # XXX sik? (from /etc/mime.types)
22             );
23              
24             $SPEC{check_backup_filename} = {
25             v => 1.1,
26             summary => 'Check whether filename indicates being a backup file',
27             description => <<'_',
28              
29              
30             _
31             args => {
32             filename => {
33             schema => 'str*',
34             req => 1,
35             pos => 0,
36             },
37             # XXX recurse?
38             ci => {
39             summary => 'Whether to match case-insensitively',
40             schema => 'bool',
41             default => 1,
42             },
43             },
44             result_naked => 1,
45             result => {
46             schema => ['any*', of=>['bool*', 'hash*']],
47             description => <<'_',
48              
49             Return false if not detected as backup name. Otherwise return a hash, which may
50             contain these keys: `original_filename`. In the future there will be extra
51             information returned, e.g. editor name (if filename indicates backup from
52             certain backup program), date (if filename contains date information), and so
53             on.
54              
55             _
56             },
57             };
58             sub check_backup_filename {
59 6     6 1 24 my %args = @_;
60              
61 6         7 my $filename = $args{filename};
62              
63 6 50       46 $filename =~ /(~|\.\w+)\z/ or return 0;
64 6   100     20 my $ci = $args{ci} // 1;
65              
66 6         12 my $suffix = $1;
67              
68 6         6 my $spec;
69 6 100       11 if ($ci) {
70 5         6 my $suffix_lc = lc($suffix);
71 5         14 for (keys %SUFFIXES) {
72 10 100       20 if (lc($_) eq $suffix_lc) {
73 4         6 $spec = $SUFFIXES{$_};
74 4         6 last;
75             }
76             }
77             } else {
78 1         3 $spec = $SUFFIXES{$suffix};
79             }
80 6 100       22 return 0 unless $spec;
81              
82 4         53 (my $orig_filename = $filename) =~ s/\Q$suffix\E\z//;
83              
84             return {
85 4         22 original_filename => $orig_filename,
86             };
87             }
88              
89             1;
90             # ABSTRACT: Check whether filename indicates being a backup file
91              
92             __END__