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-2017  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.3.2, released 25 Jan 2017.
34#
35# See http://backuppc.sourceforge.net.
36#
37#========================================================================
38
39package BackupPC::Attrib;
40
41use strict;
42
43use Carp;
44use File::Path;
45use BackupPC::FileZIO;
46use Encode qw/from_to/;
47require Exporter;
48
49use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
50
51#
52# These must match the file types used by tar
53#
54use constant BPC_FTYPE_FILE     => 0;
55use constant BPC_FTYPE_HARDLINK => 1;
56use constant BPC_FTYPE_SYMLINK  => 2;
57use constant BPC_FTYPE_CHARDEV  => 3;
58use constant BPC_FTYPE_BLOCKDEV => 4;
59use constant BPC_FTYPE_DIR      => 5;
60use constant BPC_FTYPE_FIFO     => 6;
61use constant BPC_FTYPE_SOCKET   => 8;
62use constant BPC_FTYPE_UNKNOWN  => 9;
63use constant BPC_FTYPE_DELETED  => 10;
64
65my @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#
81my @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#
99use constant BPC_ATTRIB_TYPE_UNIX => 0x17555555;
100
101my @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#
124my @FldsUnixW = qw(type mode uid gid sizeDiv4GB sizeMod4GB);
125
126#
127# These fields are packed using the "N" pack format (32 bit integer)
128#
129my @FldsUnixN = qw(mtime);
130
131sub 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
143sub 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
154sub get
155{
156    my($a, $fileName) = @_;
157    return $a->{files}{$fileName} if ( defined($fileName) );
158    return $a->{files};
159}
160
161sub fileType2Text
162{
163    my($a, $type) = @_;
164    return "?" if ( $type < 0 || $type >= @FileType2Text );
165    return $FileType2Text[$type];
166}
167
168sub fileCount
169{
170    my($a) = @_;
171
172    return scalar(keys(%{$a->{files}}));
173}
174
175sub 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#
188sub fileName
189{
190    my($a, $dir, $file) = @_;
191
192    $file = "attrib" if ( !defined($file) );
193    return "$dir/$file";
194}
195
196sub 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
284sub 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        eval {
301            $data .= pack("w a* w$nFldsW N$nFldsN", length($file), $file,
302                                   @{$a->{files}{$file}}{@FldsUnixW},
303                                   @{$a->{files}{$file}}{@FldsUnixN},
304                        );
305        };
306        if ( $@ ) {
307            $a->{_errStr} = "Can't pack attr for $file: " . Dumper($a->{files}{$file});
308        }
309    }
310    return $data;
311}
312
313sub write
314{
315    my($a, $dir, $file) = @_;
316    my($data) = $a->writeData;
317
318    $file = $a->fileName($dir, $file);
319    if ( !-d $dir ) {
320        eval { mkpath($dir, 0, 0777) };
321        if ( $@ ) {
322            $a->{_errStr} = "Can't create directory $dir";
323            return;
324        }
325    }
326    my $fd = BackupPC::FileZIO->open($file, 1, $a->{compress});
327    if ( !$fd ) {
328	$a->{_errStr} = "Can't open/write to $file";
329	return;
330    }
331    if ( $fd->write(\$data) != length($data) ) {
332	$a->{_errStr} = "Can't write to $file";
333	$fd->close;
334	return;
335    }
336    $fd->close;
337    $a->{_errStr} = "";
338    return 1;
339}
340
341sub merge
342{
343    my($a1, $a2) = @_;
344
345    foreach my $f ( keys(%{$a2->{files}}) ) {
346	next if ( defined($a1->{files}{$f}) );
347	$a1->{files}{$f} = $a2->{files}{$f};
348    }
349}
350
351sub errStr
352{
353    my($a) = @_;
354
355    return $a->{_errStr};
356}
357
3581;
359