1 |
#============================================================= -*-perl-*- |
2 |
# |
3 |
# BackupPC::Attrib package |
4 |
# |
5 |
# DESCRIPTION |
6 |
# |
7 |
# This library defines a BackupPC::Attrib class for maintaining |
8 |
# file attribute data. One object instance stores attributes for |
9 |
# all the files in a single directory. |
10 |
# |
11 |
# AUTHOR |
12 |
# Craig Barratt <cbarratt@users.sourceforge.net> |
13 |
# |
14 |
# COPYRIGHT |
15 |
# Copyright (C) 2001-2003 Craig Barratt |
16 |
# |
17 |
# This program is free software; you can redistribute it and/or modify |
18 |
# it under the terms of the GNU General Public License as published by |
19 |
# the Free Software Foundation; either version 2 of the License, or |
20 |
# (at your option) any later version. |
21 |
# |
22 |
# This program is distributed in the hope that it will be useful, |
23 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
24 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
25 |
# GNU General Public License for more details. |
26 |
# |
27 |
# You should have received a copy of the GNU General Public License |
28 |
# along with this program; if not, write to the Free Software |
29 |
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
30 |
# |
31 |
#======================================================================== |
32 |
# |
33 |
# Version 2.1.0, released 20 Jun 2004. |
34 |
# |
35 |
# See http://backuppc.sourceforge.net. |
36 |
# |
37 |
#======================================================================== |
38 |
|
39 |
package BackupPC::Attrib; |
40 |
|
41 |
use strict; |
42 |
|
43 |
use Carp; |
44 |
use File::Path; |
45 |
use BackupPC::FileZIO; |
46 |
require Exporter; |
47 |
|
48 |
use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS ); |
49 |
|
50 |
# |
51 |
# These must match the file types used by tar |
52 |
# |
53 |
use constant BPC_FTYPE_FILE => 0; |
54 |
use constant BPC_FTYPE_HARDLINK => 1; |
55 |
use constant BPC_FTYPE_SYMLINK => 2; |
56 |
use constant BPC_FTYPE_CHARDEV => 3; |
57 |
use constant BPC_FTYPE_BLOCKDEV => 4; |
58 |
use constant BPC_FTYPE_DIR => 5; |
59 |
use constant BPC_FTYPE_FIFO => 6; |
60 |
use constant BPC_FTYPE_SOCKET => 8; |
61 |
use constant BPC_FTYPE_UNKNOWN => 9; |
62 |
use constant BPC_FTYPE_DELETED => 10; |
63 |
|
64 |
my @FILE_TYPES = qw( |
65 |
BPC_FTYPE_FILE |
66 |
BPC_FTYPE_HARDLINK |
67 |
BPC_FTYPE_SYMLINK |
68 |
BPC_FTYPE_CHARDEV |
69 |
BPC_FTYPE_BLOCKDEV |
70 |
BPC_FTYPE_DIR |
71 |
BPC_FTYPE_FIFO |
72 |
BPC_FTYPE_SOCKET |
73 |
BPC_FTYPE_UNKNOWN |
74 |
BPC_FTYPE_DELETED |
75 |
); |
76 |
|
77 |
# |
78 |
# The indexes in this list must match the numbers above |
79 |
# |
80 |
my @FileType2Text = ( |
81 |
"file", |
82 |
"hardlink", |
83 |
"symlink", |
84 |
"chardev", |
85 |
"blockdev", |
86 |
"dir", |
87 |
"fifo", |
88 |
"?", |
89 |
"socket", |
90 |
"?", |
91 |
"deleted", |
92 |
); |
93 |
|
94 |
# |
95 |
# Type of attribute file. This is saved as a magic number at the |
96 |
# start of the file. Later there might be other types. |
97 |
# |
98 |
use constant BPC_ATTRIB_TYPE_UNIX => 0x17555555; |
99 |
|
100 |
my @ATTRIB_TYPES = qw( |
101 |
BPC_ATTRIB_TYPE_UNIX |
102 |
); |
103 |
|
104 |
@ISA = qw(Exporter); |
105 |
|
106 |
@EXPORT = qw( ); |
107 |
|
108 |
@EXPORT_OK = ( |
109 |
@FILE_TYPES, |
110 |
@ATTRIB_TYPES, |
111 |
); |
112 |
|
113 |
%EXPORT_TAGS = ( |
114 |
'all' => [ @EXPORT_OK ], |
115 |
); |
116 |
|
117 |
# |
118 |
# These fields are packed using the "w" pack format (variable length |
119 |
# base 128). We use two values to store up to 64 bit size: sizeDiv4GB |
120 |
# is size / 4GB and sizeMod4GB is size % 4GB (although perl can |
121 |
# only represent around 2^52, the size of an IEEE double mantissa). |
122 |
# |
123 |
my @FldsUnixW = qw(type mode uid gid sizeDiv4GB sizeMod4GB); |
124 |
|
125 |
# |
126 |
# These fields are packed using the "N" pack format (32 bit integer) |
127 |
# |
128 |
my @FldsUnixN = qw(mtime); |
129 |
|
130 |
sub new |
131 |
{ |
132 |
my($class, $options) = @_; |
133 |
|
134 |
my $self = bless { |
135 |
type => BPC_ATTRIB_TYPE_UNIX, |
136 |
%$options, |
137 |
files => { }, |
138 |
}, $class; |
139 |
return $self; |
140 |
} |
141 |
|
142 |
sub set |
143 |
{ |
144 |
my($a, $fileName, $attrib) = @_; |
145 |
|
146 |
if ( !defined($attrib) ) { |
147 |
delete($a->{files}{$fileName}); |
148 |
} else { |
149 |
$a->{files}{$fileName} = $attrib; |
150 |
} |
151 |
} |
152 |
|
153 |
sub get |
154 |
{ |
155 |
my($a, $fileName) = @_; |
156 |
return $a->{files}{$fileName} if ( defined($fileName) ); |
157 |
return $a->{files}; |
158 |
} |
159 |
|
160 |
sub fileType2Text |
161 |
{ |
162 |
my($a, $type) = @_; |
163 |
return "?" if ( $type < 0 || $type >= @FileType2Text ); |
164 |
return $FileType2Text[$type]; |
165 |
} |
166 |
|
167 |
sub fileCount |
168 |
{ |
169 |
my($a) = @_; |
170 |
|
171 |
return scalar(keys(%{$a->{files}})); |
172 |
} |
173 |
|
174 |
sub delete |
175 |
{ |
176 |
my($a, $fileName) = @_; |
177 |
if ( defined($fileName) ) { |
178 |
delete($a->{files}{$fileName}); |
179 |
} else { |
180 |
$a->{files} = { }; |
181 |
} |
182 |
} |
183 |
|
184 |
# |
185 |
# Given the directory, return the full path of the attribute file. |
186 |
# |
187 |
sub fileName |
188 |
{ |
189 |
my($a, $dir, $file) = @_; |
190 |
|
191 |
$file = "attrib" if ( !defined($file) ); |
192 |
return "$dir/$file"; |
193 |
} |
194 |
|
195 |
sub read |
196 |
{ |
197 |
my($a, $dir, $file) = @_; |
198 |
my($data); |
199 |
|
200 |
$file = $a->fileName($dir, $file); |
201 |
my $fd = BackupPC::FileZIO->open($file, 0, $a->{compress}); |
202 |
if ( !$fd ) { |
203 |
$a->{_errStr} = "Can't open $file"; |
204 |
return; |
205 |
} |
206 |
$fd->read(\$data, 65536); |
207 |
if ( length($data) < 4 ) { |
208 |
$a->{_errStr} = "Can't read magic number from $file"; |
209 |
$fd->close; |
210 |
return; |
211 |
} |
212 |
(my $magic, $data) = unpack("N a*", $data); |
213 |
if ( $magic != $a->{type} ) { |
214 |
$a->{_errStr} = sprintf("Wrong magic number in $file" |
215 |
. " (got 0x%x, expected 0x%x)", |
216 |
$magic, $a->{type}); |
217 |
$fd->close; |
218 |
return; |
219 |
} |
220 |
while ( length($data) ) { |
221 |
my $newData; |
222 |
if ( length($data) < 4 ) { |
223 |
$fd->read(\$newData, 65536); |
224 |
$data .= $newData; |
225 |
if ( length($data) < 4 ) { |
226 |
$a->{_errStr} = "Can't read file length from $file"; |
227 |
$fd->close; |
228 |
return; |
229 |
} |
230 |
} |
231 |
(my $len, $data) = unpack("w a*", $data); |
232 |
if ( length($data) < $len ) { |
233 |
$fd->read(\$newData, $len + 65536); |
234 |
$data .= $newData; |
235 |
if ( length($data) < $len ) { |
236 |
$a->{_errStr} = "Can't read file name (length $len)" |
237 |
. " from $file"; |
238 |
$fd->close; |
239 |
return; |
240 |
} |
241 |
} |
242 |
(my $fileName, $data) = unpack("a$len a*", $data); |
243 |
my $nFldsW = @FldsUnixW; |
244 |
my $nFldsN = @FldsUnixN; |
245 |
if ( length($data) < 5 * $nFldsW + 4 * $nFldsN ) { |
246 |
$fd->read(\$newData, 65536); |
247 |
$data .= $newData; |
248 |
} |
249 |
( |
250 |
@{$a->{files}{$fileName}}{@FldsUnixW}, |
251 |
@{$a->{files}{$fileName}}{@FldsUnixN}, |
252 |
$data |
253 |
) = unpack("w$nFldsW N$nFldsN a*", $data); |
254 |
if ( $a->{files}{$fileName}{$FldsUnixN[-1]} eq "" ) { |
255 |
$a->{_errStr} = "Can't read attributes for $fileName" |
256 |
. " from $file"; |
257 |
$fd->close; |
258 |
return; |
259 |
} |
260 |
# |
261 |
# Convert the two 32 bit size values into a single size |
262 |
# |
263 |
$a->{files}{$fileName}{size} = $a->{files}{$fileName}{sizeMod4GB} |
264 |
+ $a->{files}{$fileName}{sizeDiv4GB} * 4096 * 1024 * 1024; |
265 |
} |
266 |
$fd->close; |
267 |
$a->{_errStr} = ""; |
268 |
return 1; |
269 |
} |
270 |
|
271 |
sub writeData |
272 |
{ |
273 |
my($a) = @_; |
274 |
my($data); |
275 |
|
276 |
$data = pack("N", BPC_ATTRIB_TYPE_UNIX); |
277 |
foreach my $file ( sort(keys(%{$a->{files}})) ) { |
278 |
my $nFldsW = @FldsUnixW; |
279 |
my $nFldsN = @FldsUnixN; |
280 |
# |
281 |
# Convert the size into two 32 bit size values. |
282 |
# |
283 |
$a->{files}{$file}{sizeMod4GB} |
284 |
= $a->{files}{$file}{size} % (4096 * 1024 * 1024); |
285 |
$a->{files}{$file}{sizeDiv4GB} |
286 |
= int($a->{files}{$file}{size} / (4096 * 1024 * 1024)); |
287 |
$data .= pack("w a* w$nFldsW N$nFldsN", length($file), $file, |
288 |
@{$a->{files}{$file}}{@FldsUnixW}, |
289 |
@{$a->{files}{$file}}{@FldsUnixN}, |
290 |
); |
291 |
} |
292 |
return $data; |
293 |
} |
294 |
|
295 |
sub write |
296 |
{ |
297 |
my($a, $dir, $file) = @_; |
298 |
my($data) = $a->writeData; |
299 |
|
300 |
$file = $a->fileName($dir, $file); |
301 |
mkpath($dir, 0, 0777) if ( !-d $dir ); |
302 |
my $fd = BackupPC::FileZIO->open($file, 1, $a->{compress}); |
303 |
if ( !$fd ) { |
304 |
$a->{_errStr} = "Can't open/write to $file"; |
305 |
return; |
306 |
} |
307 |
if ( $fd->write(\$data) != length($data) ) { |
308 |
$a->{_errStr} = "Can't write to $file"; |
309 |
$fd->close; |
310 |
return; |
311 |
} |
312 |
$fd->close; |
313 |
$a->{_errStr} = ""; |
314 |
return 1; |
315 |
} |
316 |
|
317 |
sub merge |
318 |
{ |
319 |
my($a1, $a2) = @_; |
320 |
|
321 |
foreach my $f ( keys(%{$a2->{files}}) ) { |
322 |
next if ( defined($a1->{files}{$f}) ); |
323 |
$a1->{files}{$f} = $a2->{files}{$f}; |
324 |
} |
325 |
} |
326 |
|
327 |
sub errStr |
328 |
{ |
329 |
my($a) = @_; |
330 |
|
331 |
return $a->{_errStr}; |
332 |
} |
333 |
|
334 |
1; |