File Coverage

blib/lib/File/Versions.pm
Criterion Covered Total %
statement 59 71 83.1
branch 17 30 56.6
condition 5 12 41.6
subroutine 11 12 91.6
pod 2 8 25.0
total 94 133 70.6


line stmt bran cond sub pod time code
1             package File::Versions;
2 1     1   86399 use warnings;
  1         3  
  1         39  
3 1     1   6 use strict;
  1         4  
  1         79  
4             require Exporter;
5             our @ISA = qw(Exporter);
6             our @EXPORT_OK = qw/backup_name make_backup/;
7             our %EXPORT_TAGS = ('all' => \@EXPORT_OK);
8 1     1   6 use Carp;
  1         3  
  1         94  
9 1     1   8 use List::Util qw/max/;
  1         2  
  1         1053  
10              
11             our $VERSION = '0.09';
12              
13             # Get the type of version control. Not exported.
14              
15             sub get_version_control
16             {
17 5     5 0 17 my $vc = $ENV{VERSION_CONTROL};
18 5 50       19 if (! $vc) {
19 0         0 $vc = 'numbered';
20             }
21 5         14 return $vc;
22             }
23              
24             sub get_file_max_version_number
25             {
26 3     3 0 20 my ($file, $options) = @_;
27              
28             # The list of files which look like backups of this file.
29              
30 3         7 my @backup_files;
31              
32             # The version numbers of the files.
33              
34             my @version_numbers;
35              
36             # Get a list of candidate files using "glob".
37              
38 3         209 @backup_files = <$file.~*~>;
39              
40 3         15 for my $backup_file (@backup_files) {
41 1 50       27 if ($backup_file =~ /^$file.~(\d+)~$/) {
42 1         6 my $version_number = $1;
43 1         5 push @version_numbers, $version_number;
44             }
45             }
46 3         6 my $max;
47 3 100       12 if (@version_numbers) {
48 1         8 $max = max @version_numbers;
49             }
50 3         12 return $max;
51             }
52              
53             # Look at the files in the current directory and find the next
54             # possible file. Not exported.
55              
56             sub find_next_numbered
57             {
58 3     3 0 7 my ($file, $options) = @_;
59              
60 3         11 my $max_version_number = get_file_max_version_number ($file, $options);
61 3         17 my $next = 1;
62 3 100       10 if ($max_version_number) {
63 1         3 $next = $max_version_number + 1;
64             }
65 3         12 my $next_file = "$file.~$next~";
66              
67             # Test that this file really does not exist.
68              
69 3 50       52 if (-f $next_file) {
70 0         0 die "There is a bug in this program. A file exists which is not supposed to.";
71             }
72 3         14 return $next_file;
73             }
74              
75             # Find out what to use for the value of the suffix for simple backups.
76              
77             sub simple_backup_suffix
78             {
79 2     2 0 5 my $suffix;
80 2         6 $suffix = $ENV{SIMPLE_BACKUP_SUFFIX};
81 2 50       7 if (! $suffix) {
82 2         4 $suffix = '~';
83             }
84 2         6 return $suffix;
85             }
86              
87             # Make a simple backup of the file, copy it to a file with the same
88             # name plus the extension '~' or the value of SIMPLE_BACKUP_SUFFIX.
89              
90             sub simple_backup
91             {
92 2     2 0 8 my ($file, $options) = @_;
93 2         17 my $suffix = simple_backup_suffix ($options);
94 2         7 my $backup = "$file$suffix";
95 2         7 return $backup;
96             }
97              
98             # Make numbered backups of files that already have them, otherwise
99             # simple backups.
100              
101             sub default_backup
102             {
103 0     0 0 0 my ($file, $options) = @_;
104 0         0 my $backup;
105 0         0 my $max_version_number = get_file_max_version_number ($file, $options);
106 0 0       0 if ($max_version_number) {
107 0         0 $backup = find_next_numbered ($file, $options);
108             }
109             else {
110 0         0 $backup = simple_backup ($file, $options);
111             }
112             }
113              
114              
115             sub backup_name
116             {
117 6     6 1 2292 my ($file, $options) = @_;
118              
119 6         16 my $backup_file;
120              
121 6 100       110 if (! -f $file) {
122 1         4 $backup_file = $file;
123             }
124             else {
125 5         21 my $version_control = get_version_control ($options);
126              
127 5 50 33     44 if (! $version_control ||
      33        
128             $version_control eq 'existing' ||
129             $version_control eq 'nil') {
130 0         0 $backup_file = default_backup
131             }
132 5 100 66     26 if ($version_control eq 'numbered' ||
    50 33        
133             $version_control eq 't') {
134 3         11 $backup_file = find_next_numbered ($file, $options);
135             }
136             elsif ($version_control eq 'simple' ||
137             $version_control eq 'never') {
138 2         8 $backup_file = simple_backup ($file, $options);
139             }
140             else {
141 0         0 croak __PACKAGE__, ": I don't know how to do the type of version control '$version_control' in your environment.\n";
142             }
143             }
144 6         24 return $backup_file;
145             }
146              
147             sub make_backup
148             {
149 3     3 1 1670 my ($file, $options) = @_;
150 3 50       49 if (! -f $file) {
151 0         0 croak "Asked to make a backup of a file '$file' which does not exist";
152             }
153 3         32 my $backup_file = backup_name ($file);
154 3 50       35 if (-f $backup_file) {
155 0 0       0 unlink $backup_file or croak "unlink $backup_file failed: $!";
156             }
157 3 50       106 rename $file, $backup_file or croak "rename $file, $backup_file failed: $!";
158 3         16 return $backup_file;
159             }
160              
161             1;
162