/[BackupPC]/upstream/2.1.0/lib/BackupPC/Attrib.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /upstream/2.1.0/lib/BackupPC/Attrib.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Wed Jun 22 19:12:04 2005 UTC (16 years, 11 months ago) by dpavlin
File size: 7992 byte(s)
import of version 2.1.0

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;

  ViewVC Help
Powered by ViewVC 1.1.26