1 #============================================================= -*-perl-*-
3 # BackupPC::Attrib package
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.
12 # Craig Barratt <cbarratt@users.sourceforge.net>
15 # Copyright (C) 2001-2009 Craig Barratt
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.
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.
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
31 #========================================================================
33 # Version 3.2.0, released 31 Jul 2010.
35 # See http://backuppc.sourceforge.net.
37 #========================================================================
39 package BackupPC::Attrib;
45 use BackupPC::FileZIO;
46 use Encode qw/from_to/;
49 use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
52 # These must match the file types used by tar
54 use constant BPC_FTYPE_FILE => 0;
55 use constant BPC_FTYPE_HARDLINK => 1;
56 use constant BPC_FTYPE_SYMLINK => 2;
57 use constant BPC_FTYPE_CHARDEV => 3;
58 use constant BPC_FTYPE_BLOCKDEV => 4;
59 use constant BPC_FTYPE_DIR => 5;
60 use constant BPC_FTYPE_FIFO => 6;
61 use constant BPC_FTYPE_SOCKET => 8;
62 use constant BPC_FTYPE_UNKNOWN => 9;
63 use constant BPC_FTYPE_DELETED => 10;
79 # The indexes in this list must match the numbers above
96 # Type of attribute file. This is saved as a magic number at the
97 # start of the file. Later there might be other types.
99 use constant BPC_ATTRIB_TYPE_UNIX => 0x17555555;
101 my @ATTRIB_TYPES = qw(
115 'all' => [ @EXPORT_OK ],
119 # These fields are packed using the "w" pack format (variable length
120 # base 128). We use two values to store up to 64 bit size: sizeDiv4GB
121 # is size / 4GB and sizeMod4GB is size % 4GB (although perl can
122 # only represent around 2^52, the size of an IEEE double mantissa).
124 my @FldsUnixW = qw(type mode uid gid sizeDiv4GB sizeMod4GB);
127 # These fields are packed using the "N" pack format (32 bit integer)
129 my @FldsUnixN = qw(mtime);
133 my($class, $options) = @_;
136 type => BPC_ATTRIB_TYPE_UNIX,
145 my($a, $fileName, $attrib) = @_;
147 if ( !defined($attrib) ) {
148 delete($a->{files}{$fileName});
150 $a->{files}{$fileName} = $attrib;
156 my($a, $fileName) = @_;
157 return $a->{files}{$fileName} if ( defined($fileName) );
164 return "?" if ( $type < 0 || $type >= @FileType2Text );
165 return $FileType2Text[$type];
172 return scalar(keys(%{$a->{files}}));
177 my($a, $fileName) = @_;
178 if ( defined($fileName) ) {
179 delete($a->{files}{$fileName});
186 # Given the directory, return the full path of the attribute file.
190 my($a, $dir, $file) = @_;
192 $file = "attrib" if ( !defined($file) );
198 my($a, $dir, $file) = @_;
201 $file = $a->fileName($dir, $file);
202 from_to($file, "utf8", $a->{charsetLegacy})
203 if ( $a->{charsetLegacy} ne "" );
204 my $fd = BackupPC::FileZIO->open($file, 0, $a->{compress});
206 $a->{_errStr} = "Can't open $file";
209 $fd->read(\$data, 65536);
210 if ( length($data) < 4 ) {
211 $a->{_errStr} = "Can't read magic number from $file";
215 (my $magic, $data) = unpack("N a*", $data);
216 if ( $magic != $a->{type} ) {
217 $a->{_errStr} = sprintf("Wrong magic number in %s"
218 . " (got 0x%x, expected 0x%x)",
219 $file, $magic, $a->{type});
223 while ( length($data) ) {
225 if ( length($data) < 4 ) {
226 $fd->read(\$newData, 65536);
228 if ( length($data) < 4 ) {
229 $a->{_errStr} = "Can't read file length from $file";
234 (my $len, $data) = unpack("w a*", $data);
235 if ( length($data) < $len ) {
236 $fd->read(\$newData, $len + 65536);
238 if ( length($data) < $len ) {
239 $a->{_errStr} = "Can't read file name (length $len)"
245 (my $fileName, $data) = unpack("a$len a*", $data);
247 from_to($fileName, $a->{charsetLegacy}, "utf8")
248 if ( $a->{charsetLegacy} ne "" );
249 my $nFldsW = @FldsUnixW;
250 my $nFldsN = @FldsUnixN;
251 if ( length($data) < 5 * $nFldsW + 4 * $nFldsN ) {
252 $fd->read(\$newData, 65536);
257 @{$a->{files}{$fileName}}{@FldsUnixW},
258 @{$a->{files}{$fileName}}{@FldsUnixN},
260 ) = unpack("w$nFldsW N$nFldsN a*", $data);
263 $a->{_errStr} = "unpack: Can't read attributes for $fileName from $file ($@)";
267 if ( $a->{files}{$fileName}{$FldsUnixN[-1]} eq "" ) {
268 $a->{_errStr} = "Can't read attributes for $fileName"
274 # Convert the two 32 bit size values into a single size
276 $a->{files}{$fileName}{size} = $a->{files}{$fileName}{sizeMod4GB}
277 + $a->{files}{$fileName}{sizeDiv4GB} * 4096 * 1024 * 1024;
289 $data = pack("N", BPC_ATTRIB_TYPE_UNIX);
290 foreach my $file ( sort(keys(%{$a->{files}})) ) {
291 my $nFldsW = @FldsUnixW;
292 my $nFldsN = @FldsUnixN;
294 # Convert the size into two 32 bit size values.
296 $a->{files}{$file}{sizeMod4GB}
297 = $a->{files}{$file}{size} % (4096 * 1024 * 1024);
298 $a->{files}{$file}{sizeDiv4GB}
299 = int($a->{files}{$file}{size} / (4096 * 1024 * 1024));
300 $data .= pack("w a* w$nFldsW N$nFldsN", length($file), $file,
301 @{$a->{files}{$file}}{@FldsUnixW},
302 @{$a->{files}{$file}}{@FldsUnixN},
310 my($a, $dir, $file) = @_;
311 my($data) = $a->writeData;
313 $file = $a->fileName($dir, $file);
315 eval { mkpath($dir, 0, 0777) };
317 $a->{_errStr} = "Can't create directory $dir";
321 my $fd = BackupPC::FileZIO->open($file, 1, $a->{compress});
323 $a->{_errStr} = "Can't open/write to $file";
326 if ( $fd->write(\$data) != length($data) ) {
327 $a->{_errStr} = "Can't write to $file";
340 foreach my $f ( keys(%{$a2->{files}}) ) {
341 next if ( defined($a1->{files}{$f}) );
342 $a1->{files}{$f} = $a2->{files}{$f};
350 return $a->{_errStr};