lib/BackupPC/Attrib.pm

#============================================================= -*-perl-*-
#
# BackupPC::Attrib package
#
# DESCRIPTION
#
#   This library defines a BackupPC::Attrib class for maintaining
#   file attribute data.  One object instance stores attributes for
#   all the files in a single directory.
#
# AUTHOR
#   Craig Barratt  <cbarratt@users.sourceforge.net>
#
# COPYRIGHT
#   Copyright (C) 2001-2003  Craig Barratt
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#========================================================================
#
# Version 2.1.0, released 20 Jun 2004.
#
# See http://backuppc.sourceforge.net.
#
#========================================================================

package BackupPC::Attrib;

use strict;

use Carp;
use File::Path;
use BackupPC::FileZIO;
require Exporter;

use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );

#
# These must match the file types used by tar
#
use constant BPC_FTYPE_FILE     => 0;
use constant BPC_FTYPE_HARDLINK => 1;
use constant BPC_FTYPE_SYMLINK  => 2;
use constant BPC_FTYPE_CHARDEV  => 3;
use constant BPC_FTYPE_BLOCKDEV => 4;
use constant BPC_FTYPE_DIR      => 5;
use constant BPC_FTYPE_FIFO     => 6;
use constant BPC_FTYPE_SOCKET   => 8;
use constant BPC_FTYPE_UNKNOWN  => 9;
use constant BPC_FTYPE_DELETED  => 10;

my @FILE_TYPES = qw(
                  BPC_FTYPE_FILE
                  BPC_FTYPE_HARDLINK
                  BPC_FTYPE_SYMLINK
                  BPC_FTYPE_CHARDEV
                  BPC_FTYPE_BLOCKDEV
                  BPC_FTYPE_DIR
                  BPC_FTYPE_FIFO
                  BPC_FTYPE_SOCKET
                  BPC_FTYPE_UNKNOWN
                  BPC_FTYPE_DELETED
             );

#
# The indexes in this list must match the numbers above
#
my @FileType2Text = (
    "file",
    "hardlink",
    "symlink",
    "chardev",
    "blockdev",
    "dir",
    "fifo",
    "?",
    "socket",
    "?",
    "deleted",
);

#
# Type of attribute file.  This is saved as a magic number at the
# start of the file.  Later there might be other types.
#
use constant BPC_ATTRIB_TYPE_UNIX => 0x17555555;

my @ATTRIB_TYPES = qw(
                  BPC_ATTRIB_TYPE_UNIX
             );

@ISA = qw(Exporter);

@EXPORT    = qw( );

@EXPORT_OK = (
                  @FILE_TYPES,
                  @ATTRIB_TYPES,
             );

%EXPORT_TAGS = (
    'all'    => [ @EXPORT_OK ],
);

#
# These fields are packed using the "w" pack format (variable length
# base 128). We use two values to store up to 64 bit size: sizeDiv4GB
# is size / 4GB and sizeMod4GB is size % 4GB (although perl can
# only represent around 2^52, the size of an IEEE double mantissa).
#
my @FldsUnixW = qw(type mode uid gid sizeDiv4GB sizeMod4GB);

#
# These fields are packed using the "N" pack format (32 bit integer)
#
my @FldsUnixN = qw(mtime);

sub new
{
    my($class, $options) = @_;

    my $self = bless {
        type  => BPC_ATTRIB_TYPE_UNIX,
        %$options,
        files => { },
    }, $class;
    return $self;
}

sub set
{
    my($a, $fileName, $attrib) = @_;

    if ( !defined($attrib) ) {
        delete($a->{files}{$fileName});
    } else {
        $a->{files}{$fileName} = $attrib;
    }
}

sub get
{
    my($a, $fileName) = @_;
    return $a->{files}{$fileName} if ( defined($fileName) );
    return $a->{files};
}

sub fileType2Text
{
    my($a, $type) = @_;
    return "?" if ( $type < 0 || $type >= @FileType2Text );
    return $FileType2Text[$type];
}

sub fileCount
{
    my($a) = @_;

    return scalar(keys(%{$a->{files}}));
}

sub delete
{
    my($a, $fileName) = @_;
    if ( defined($fileName) ) {
        delete($a->{files}{$fileName});
    } else {
        $a->{files} = { };
    }
}

#
# Given the directory, return the full path of the attribute file.
#
sub fileName
{
    my($a, $dir, $file) = @_;

    $file = "attrib" if ( !defined($file) );
    return "$dir/$file";
}

sub read
{
    my($a, $dir, $file) = @_;
    my($data);

    $file = $a->fileName($dir, $file);
    my $fd = BackupPC::FileZIO->open($file, 0, $a->{compress});
    if ( !$fd ) {
        $a->{_errStr} = "Can't open $file";
        return;
    }
    $fd->read(\$data, 65536);
    if ( length($data) < 4 ) {
        $a->{_errStr} = "Can't read magic number from $file";
        $fd->close;
        return;
    }
    (my $magic, $data) = unpack("N a*", $data);
    if ( $magic != $a->{type} ) {
        $a->{_errStr} = sprintf("Wrong magic number in $file"
                               . " (got 0x%x, expected 0x%x)",
                                   $magic, $a->{type});
        $fd->close;
        return;
    }
    while ( length($data) ) {
        my $newData;
        if ( length($data) < 4 ) {
            $fd->read(\$newData, 65536);
            $data .= $newData;
            if ( length($data) < 4 ) {
                $a->{_errStr} = "Can't read file length from $file";
                $fd->close;
                return;
            }
        }
        (my $len, $data) = unpack("w a*", $data);
        if ( length($data) < $len ) {
            $fd->read(\$newData, $len + 65536);
            $data .= $newData;
            if ( length($data) < $len ) {
                $a->{_errStr} = "Can't read file name (length $len)"
                           . " from $file";
                $fd->close;
                return;
            }
        }
        (my $fileName, $data) = unpack("a$len a*", $data);
        my $nFldsW = @FldsUnixW;
        my $nFldsN = @FldsUnixN;
        if ( length($data) < 5 * $nFldsW + 4 * $nFldsN ) {
            $fd->read(\$newData, 65536);
            $data .= $newData;
        }
        (
            @{$a->{files}{$fileName}}{@FldsUnixW},
            @{$a->{files}{$fileName}}{@FldsUnixN},
            $data
        ) = unpack("w$nFldsW N$nFldsN a*", $data);
        if ( $a->{files}{$fileName}{$FldsUnixN[-1]} eq "" ) {
            $a->{_errStr} = "Can't read attributes for $fileName"
                          . " from $file";
            $fd->close;
            return;
        }
        #
        # Convert the two 32 bit size values into a single size
        #
        $a->{files}{$fileName}{size} = $a->{files}{$fileName}{sizeMod4GB}
                    + $a->{files}{$fileName}{sizeDiv4GB} * 4096 * 1024 * 1024;
    }
    $fd->close;
    $a->{_errStr} = "";
    return 1;
}

sub writeData
{
    my($a) = @_;
    my($data);

    $data = pack("N", BPC_ATTRIB_TYPE_UNIX);
    foreach my $file ( sort(keys(%{$a->{files}})) ) {
        my $nFldsW = @FldsUnixW;
        my $nFldsN = @FldsUnixN;
        #
        # Convert the size into two 32 bit size values.
        #
        $a->{files}{$file}{sizeMod4GB}
                    = $a->{files}{$file}{size} % (4096 * 1024 * 1024);
        $a->{files}{$file}{sizeDiv4GB}
                    = int($a->{files}{$file}{size} / (4096 * 1024 * 1024));
        $data .= pack("w a* w$nFldsW N$nFldsN", length($file), $file,
                               @{$a->{files}{$file}}{@FldsUnixW},
                               @{$a->{files}{$file}}{@FldsUnixN},
                    );
    }
    return $data;
}

sub write
{
    my($a, $dir, $file) = @_;
    my($data) = $a->writeData;

    $file = $a->fileName($dir, $file);
    mkpath($dir, 0, 0777) if ( !-d $dir );
    my $fd = BackupPC::FileZIO->open($file, 1, $a->{compress});
    if ( !$fd ) {
        $a->{_errStr} = "Can't open/write to $file";
        return;
    }
    if ( $fd->write(\$data) != length($data) ) {
        $a->{_errStr} = "Can't write to $file";
        $fd->close;
        return;
    }
    $fd->close;
    $a->{_errStr} = "";
    return 1;
}

sub merge
{
    my($a1, $a2) = @_;

    foreach my $f ( keys(%{$a2->{files}}) ) {
        next if ( defined($a1->{files}{$f}) );
        $a1->{files}{$f} = $a2->{files}{$f};
    }
}

sub errStr
{
    my($a) = @_;

    return $a->{_errStr};
}

1;
1	dpavlin	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;