finish rename to BackupPC::Search
[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-2009  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.2.0, released 31 Jul 2010.
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 use Encode qw/from_to/;
47 require Exporter;
48
49 use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
50
51 #
52 # These must match the file types used by tar
53 #
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;
64
65 my @FILE_TYPES = qw(
66                   BPC_FTYPE_FILE
67                   BPC_FTYPE_HARDLINK
68                   BPC_FTYPE_SYMLINK
69                   BPC_FTYPE_CHARDEV
70                   BPC_FTYPE_BLOCKDEV
71                   BPC_FTYPE_DIR
72                   BPC_FTYPE_FIFO
73                   BPC_FTYPE_SOCKET
74                   BPC_FTYPE_UNKNOWN
75                   BPC_FTYPE_DELETED
76              );
77
78 #
79 # The indexes in this list must match the numbers above
80 #
81 my @FileType2Text = (
82     "file",
83     "hardlink",
84     "symlink",
85     "chardev",
86     "blockdev",
87     "dir",
88     "fifo",
89     "?",
90     "socket",
91     "?",
92     "deleted",
93 );
94
95 #
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.
98 #
99 use constant BPC_ATTRIB_TYPE_UNIX => 0x17555555;
100
101 my @ATTRIB_TYPES = qw(
102                   BPC_ATTRIB_TYPE_UNIX
103              );
104
105 @ISA = qw(Exporter);
106
107 @EXPORT    = qw( );
108
109 @EXPORT_OK = (
110                   @FILE_TYPES,
111                   @ATTRIB_TYPES,
112              );
113
114 %EXPORT_TAGS = (
115     'all'    => [ @EXPORT_OK ],
116 );
117
118 #
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).
123 #
124 my @FldsUnixW = qw(type mode uid gid sizeDiv4GB sizeMod4GB);
125
126 #
127 # These fields are packed using the "N" pack format (32 bit integer)
128 #
129 my @FldsUnixN = qw(mtime);
130
131 sub new
132 {
133     my($class, $options) = @_;
134
135     my $self = bless {
136         type  => BPC_ATTRIB_TYPE_UNIX,
137         %$options,
138         files => { },
139     }, $class;
140     return $self;
141 }
142
143 sub set
144 {
145     my($a, $fileName, $attrib) = @_;
146
147     if ( !defined($attrib) ) {
148         delete($a->{files}{$fileName});
149     } else {
150         $a->{files}{$fileName} = $attrib;
151     }
152 }
153
154 sub get
155 {
156     my($a, $fileName) = @_;
157     return $a->{files}{$fileName} if ( defined($fileName) );
158     return $a->{files};
159 }
160
161 sub fileType2Text
162 {
163     my($a, $type) = @_;
164     return "?" if ( $type < 0 || $type >= @FileType2Text );
165     return $FileType2Text[$type];
166 }
167
168 sub fileCount
169 {
170     my($a) = @_;
171
172     return scalar(keys(%{$a->{files}}));
173 }
174
175 sub delete
176 {
177     my($a, $fileName) = @_;
178     if ( defined($fileName) ) {
179         delete($a->{files}{$fileName});
180     } else {
181         $a->{files} = { };
182     }
183 }
184
185 #
186 # Given the directory, return the full path of the attribute file.
187 #
188 sub fileName
189 {
190     my($a, $dir, $file) = @_;
191
192     $file = "attrib" if ( !defined($file) );
193     return "$dir/$file";
194 }
195
196 sub read
197 {
198     my($a, $dir, $file) = @_;
199     my($data);
200
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});
205     if ( !$fd ) {
206         $a->{_errStr} = "Can't open $file";
207         return;
208     }
209     $fd->read(\$data, 65536);
210     if ( length($data) < 4 ) {
211         $a->{_errStr} = "Can't read magic number from $file";
212         $fd->close;
213         return;
214     }
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});
220         $fd->close;
221         return;
222     }
223     while ( length($data) ) {
224         my $newData;
225         if ( length($data) < 4 ) {
226             $fd->read(\$newData, 65536);
227             $data .= $newData;
228             if ( length($data) < 4 ) {
229                 $a->{_errStr} = "Can't read file length from $file";
230                 $fd->close;
231                 return;
232             }
233         }
234         (my $len, $data) = unpack("w a*", $data);
235         if ( length($data) < $len ) {
236             $fd->read(\$newData, $len + 65536);
237             $data .= $newData;
238             if ( length($data) < $len ) {
239                 $a->{_errStr} = "Can't read file name (length $len)"
240                            . " from $file";
241                 $fd->close;
242                 return;
243             }
244         }
245         (my $fileName, $data) = unpack("a$len a*", $data);
246
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);
253             $data .= $newData;
254         }
255         eval {
256            (
257                @{$a->{files}{$fileName}}{@FldsUnixW},
258                @{$a->{files}{$fileName}}{@FldsUnixN},
259                $data
260             ) = unpack("w$nFldsW N$nFldsN a*", $data);
261         };
262         if ( $@ ) {
263             $a->{_errStr} = "unpack: Can't read attributes for $fileName from $file ($@)";
264             $fd->close;
265             return;
266         }
267         if ( $a->{files}{$fileName}{$FldsUnixN[-1]} eq "" ) {
268             $a->{_errStr} = "Can't read attributes for $fileName"
269                           . " from $file";
270             $fd->close;
271             return;
272         }
273         #
274         # Convert the two 32 bit size values into a single size
275         #
276         $a->{files}{$fileName}{size} = $a->{files}{$fileName}{sizeMod4GB}
277                     + $a->{files}{$fileName}{sizeDiv4GB} * 4096 * 1024 * 1024;
278     }
279     $fd->close;
280     $a->{_errStr} = "";
281     return 1;
282 }
283
284 sub writeData
285 {
286     my($a) = @_;
287     my($data);
288
289     $data = pack("N", BPC_ATTRIB_TYPE_UNIX);
290     foreach my $file ( sort(keys(%{$a->{files}})) ) {
291         my $nFldsW = @FldsUnixW;
292         my $nFldsN = @FldsUnixN;
293         #
294         # Convert the size into two 32 bit size values.
295         #
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},
303                     );
304     }
305     return $data;
306 }
307
308 sub write
309 {
310     my($a, $dir, $file) = @_;
311     my($data) = $a->writeData;
312
313     $file = $a->fileName($dir, $file);
314     if ( !-d $dir ) {
315         eval { mkpath($dir, 0, 0777) };
316         if ( $@ ) {
317             $a->{_errStr} = "Can't create directory $dir";
318             return;
319         }
320     }
321     my $fd = BackupPC::FileZIO->open($file, 1, $a->{compress});
322     if ( !$fd ) {
323         $a->{_errStr} = "Can't open/write to $file";
324         return;
325     }
326     if ( $fd->write(\$data) != length($data) ) {
327         $a->{_errStr} = "Can't write to $file";
328         $fd->close;
329         return;
330     }
331     $fd->close;
332     $a->{_errStr} = "";
333     return 1;
334 }
335
336 sub merge
337 {
338     my($a1, $a2) = @_;
339
340     foreach my $f ( keys(%{$a2->{files}}) ) {
341         next if ( defined($a1->{files}{$f}) );
342         $a1->{files}{$f} = $a2->{files}{$f};
343     }
344 }
345
346 sub errStr
347 {
348     my($a) = @_;
349
350     return $a->{_errStr};
351 }
352
353 1;