- various fixes to configure.pl and lib/BackupPC/Lib.pm
[BackupPC.git] / lib / BackupPC / Attrib.pm
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 3.0.0alpha, released 23 Jan 2006.
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;