Lots of changes:
[BackupPC.git] / bin / BackupPC_tarExtract
1 #!/bin/perl
2 #============================================================= -*-perl-*-
3 #
4 # BackupPC_tarExtract: extract data from a dump
5 #
6 # DESCRIPTION
7 #
8 # AUTHOR
9 #   Craig Barratt  <cbarratt@users.sourceforge.net>
10 #
11 # COPYRIGHT
12 #   Copyright (C) 2001-2003  Craig Barratt
13 #
14 #   This program is free software; you can redistribute it and/or modify
15 #   it under the terms of the GNU General Public License as published by
16 #   the Free Software Foundation; either version 2 of the License, or
17 #   (at your option) any later version.
18 #
19 #   This program is distributed in the hope that it will be useful,
20 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
21 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
22 #   GNU General Public License for more details.
23 #
24 #   You should have received a copy of the GNU General Public License
25 #   along with this program; if not, write to the Free Software
26 #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
27 #
28 #========================================================================
29 #
30 # Version 2.1.0_CVS, released 8 Feb 2004.
31 #
32 # See http://backuppc.sourceforge.net.
33 #
34 #========================================================================
35
36 use strict;
37 no  utf8;
38 use lib "/usr/local/BackupPC/lib";
39 use BackupPC::Lib;
40 use BackupPC::Attrib qw(:all);
41 use BackupPC::FileZIO;
42 use BackupPC::PoolWrite;
43 use File::Path;
44
45 die("BackupPC::Lib->new failed\n") if ( !(my $bpc = BackupPC::Lib->new) );
46 my $TopDir = $bpc->TopDir();
47 my $BinDir = $bpc->BinDir();
48 my %Conf   = $bpc->Conf();
49
50 if ( @ARGV != 3 ) {
51     print("usage: $0 <host> <shareName> <compressLevel>\n");
52     exit(1);
53 }
54 if ( $ARGV[0] !~ /^([\w\.\s-]+)$/ ) {
55     print("$0: bad host name '$ARGV[0]'\n");
56     exit(1);
57 }
58 my $host = $1;
59 if ( $ARGV[1] !~ /^([\w\s\.\/\$-]+)$/ ) {
60     print("$0: bad share name '$ARGV[1]'\n");
61     exit(1);
62 }
63 my $ShareNameUM = $1;
64 my $ShareName = $bpc->fileNameEltMangle($ShareNameUM);
65 if ( $ARGV[2] !~ /^(\d+)$/ ) {
66     print("$0: bad compress level '$ARGV[2]'\n");
67     exit(1);
68 }
69 my $Compress = $1;
70
71 #
72 # This constant and the line of code below that uses it is borrowed
73 # from Archive::Tar.  Thanks to Calle Dybedahl and Stephen Zander.
74 # See www.cpan.org.
75 #
76 # Archive::Tar is Copyright 1997 Calle Dybedahl. All rights reserved.
77 #                 Copyright 1998 Stephen Zander. All rights reserved.
78 #
79 my $tar_unpack_header
80     = 'Z100 A8 A8 A8 A12 A12 A8 A1 Z100 A6 A2 Z32 Z32 A8 A8 A155 x12';
81 my $tar_header_length = 512;
82
83 my $BufSize  = 1048576;     # 1MB or 2^20
84 my $MaxFiles = 20;
85 my $Errors   = 0;
86 my $OutDir   = "$TopDir/pc/$host/new";
87 my %Attrib   = ();
88
89 my $ExistFileCnt      = 0;
90 my $ExistFileSize     = 0;
91 my $ExistFileCompSize = 0;
92 my $TotalFileCnt      = 0;
93 my $TotalFileSize     = 0;
94
95 sub TarRead
96 {
97     my($fh, $totBytes) = @_;
98     my($numBytes, $newBytes, $data);
99
100     $data = "\0" x $totBytes;
101     while ( $numBytes < $totBytes ) {
102         $newBytes = sysread($fh,
103                         substr($data, $numBytes, $totBytes - $numBytes),
104                         $totBytes - $numBytes);
105         if ( $newBytes <= 0 ) {
106             print(STDERR "Unexpected end of tar archive (tot = $totBytes,"
107                    . " num = $numBytes, posn = " . sysseek($fh, 0, 1) . ")\n");
108             $Errors++;
109             return;
110         }
111         $numBytes += $newBytes;
112     }
113     return $data;
114 }
115
116 sub TarReadHeader
117 {
118     my($fh) = @_;
119
120     return $1 if ( TarRead($fh, $tar_header_length) =~ /(.*)/s );
121     return;
122 }
123
124 sub TarFlush
125 {
126     my($fh, $size) = @_;
127
128     if ( $size % $tar_header_length ) {
129         TarRead($fh, $tar_header_length - ($size % $tar_header_length));
130     }
131 }
132
133 sub TarReadFileInfo
134 {
135     my($fh) = @_;
136     my($head, $longName, $longLink);
137     my($name, $mode, $uid, $gid, $size, $mtime, $chksum, $type,
138        $linkname, $magic, $version, $uname, $gname, $devmajor,
139        $devminor, $prefix);
140
141     while ( 1 ) {
142         $head = TarReadHeader($fh);
143         return if ( $head eq "" || $head eq "\0" x $tar_header_length );
144         ($name,         # string
145             $mode,      # octal number
146             $uid,       # octal number
147             $gid,       # octal number
148             $size,      # octal number
149             $mtime,     # octal number
150             $chksum,    # octal number
151             $type,      # character
152             $linkname,  # string
153             $magic,     # string
154             $version,   # two bytes
155             $uname,     # string
156             $gname,     # string
157             $devmajor,  # octal number
158             $devminor,  # octal number
159             $prefix) = unpack($tar_unpack_header, $head);
160
161         $mode     = oct $mode;
162         $uid      = oct $uid;
163         $gid      = oct $gid;
164         if ( ord($size) == 128 ) {
165             #
166             # GNU tar extension: for >=8GB files the size is stored
167             # in big endian binary.
168             #
169             $size = 65536 * 65536 * unpack("N", substr($size, 4, 4))
170                                   + unpack("N", substr($size, 8, 4));
171         } else {
172             #
173             # We used to have a patch here for smbclient 2.2.x.  For file
174             # sizes between 2 and 4GB it sent the wrong size.  But since
175             # samba 3.0.0 has been released we no longer support this
176             # patch since valid files could have sizes that start with
177             # 6 or 7 in octal (eg: 6-8GB files).
178             #
179             # $size =~ s/^6/2/;       # fix bug in smbclient for >=2GB files
180             # $size =~ s/^7/3/;       # fix bug in smbclient for >=2GB files
181             #
182             # To avoid integer overflow in case we are in the 4GB - 8GB
183             # range, we do the conversion in two parts.
184             #
185             if ( $size =~ /([0-9]{9,})/ ) {
186                 my $len = length($1);
187                 $size = oct(substr($1, 0, $len - 8)) * (1 << 24)
188                       + oct(substr($1, $len - 8));
189             } else {
190                 $size = oct($size);
191             }
192         }
193         $mtime    = oct $mtime;
194         $chksum   = oct $chksum;
195         $devmajor = oct $devmajor;
196         $devminor = oct $devminor;
197         $name     = "$prefix/$name" if $prefix;
198         $prefix   = "";
199         substr ($head, 148, 8) = "        ";
200         if (unpack ("%16C*", $head) != $chksum) {
201            print(STDERR "$name: checksum error at "
202                         . sysseek($fh, 0, 1) , "\n");
203            $Errors++;
204         }
205         if ( $type eq "L" ) {
206             $longName = TarRead($fh, $size) || return;
207             # remove trailing NULL
208             $longName = substr($longName, 0, $size - 1);
209             TarFlush($fh, $size);
210             next;
211         } elsif ( $type eq "K" ) {
212             $longLink = TarRead($fh, $size) || return;
213             # remove trailing NULL
214             $longLink = substr($longLink, 0, $size - 1);
215             TarFlush($fh, $size);
216             next;
217         }
218         $name     = $longName if ( defined($longName) );
219         $linkname = $longLink if ( defined($longLink) );
220         $name     =~ s{^\./+}{};
221         $name     =~ s{/+$}{};
222         $name     =~ s{//+}{/}g;
223         return {
224             name       => $name,
225             mangleName => $bpc->fileNameMangle($name),
226             mode       => $mode,
227             uid        => $uid,
228             gid        => $gid,
229             size       => $size,
230             mtime      => $mtime,
231             type       => $type,
232             linkname   => $linkname,
233             devmajor   => $devmajor,
234             devminor   => $devminor,
235         };
236     }
237 }
238
239 sub TarReadFile
240 {
241     my($fh) = @_;
242     my $f = TarReadFileInfo($fh) || return;
243     my($dir, $file);
244
245     if ( $f->{name} eq "" ) {
246         # top-level dir
247         $dir = "";
248         $file = $ShareNameUM;
249     } else {
250         ($file = $f->{name}) =~ s{.*?([^/]*)$}{$1};         # unmangled file
251         if ( ($dir = $f->{mangleName}) =~ m{(.*)/.*} ) {
252             $dir = "$ShareName/$1";
253         } else {
254             $dir = $ShareName;
255         }
256     }
257     if ( !defined($Attrib{$dir}) ) {
258         foreach my $d ( keys(%Attrib) ) {
259             next if ( $dir =~ m{^\Q$d/} );
260             attributeWrite($d);
261         }
262         $Attrib{$dir} = BackupPC::Attrib->new({ compress => $Compress });
263         if ( -f $Attrib{$dir}->fileName("$OutDir/$dir")
264                     && !$Attrib{$dir}->read("$OutDir/$dir") ) {
265             printf(STDERR "Unable to read attribute file %s\n",
266                                 $Attrib{$dir}->fileName("$OutDir/$dir"));
267             $Errors++;
268         }
269     }
270     if ( $f->{type} == BPC_FTYPE_DIR ) {
271         #
272         # Directory
273         #
274         mkpath("$OutDir/$ShareName/$f->{mangleName}", 0, 0777)
275                             if ( !-d "$OutDir/$ShareName/$f->{mangleName}" );
276     } elsif ( $f->{type} == BPC_FTYPE_FILE ) {
277         #
278         # Regular file
279         #
280         my($nRead);
281         #print("Reading $f->{name}, $f->{size} bytes, type $f->{type}\n");
282         my $poolWrite = BackupPC::PoolWrite->new($bpc,
283                                          "$OutDir/$ShareName/$f->{mangleName}",
284                                          $f->{size}, $Compress);
285         while ( $nRead < $f->{size} ) {
286             my $thisRead = $f->{size} - $nRead < $BufSize
287                                 ? $f->{size} - $nRead : $BufSize;
288             my $data = TarRead($fh, $thisRead);
289             if ( $data eq "" ) {
290                 print(STDERR "Unexpected end of tar archive during read\n");
291                 $Errors++;
292                 return;
293             }
294             $poolWrite->write(\$data);
295             $nRead += $thisRead;
296         }
297         processClose($poolWrite, "$ShareName/$f->{mangleName}", $f->{size});
298         TarFlush($fh, $f->{size});
299     } elsif ( $f->{type} == BPC_FTYPE_HARDLINK ) {
300         #
301         # Hardlink to another file.  GNU tar is clever about files
302         # that are hardlinks to each other.  The first link will be
303         # sent as a regular file.  The additional links will be sent
304         # as this type.  We store the hardlink just like a symlink:
305         # the link name (path of the linked-to file) is stored in
306         # a plain file.
307         #
308         $f->{size} = length($f->{linkname});
309         my $poolWrite = BackupPC::PoolWrite->new($bpc,
310                                          "$OutDir/$ShareName/$f->{mangleName}",
311                                          $f->{size}, $Compress);
312         $poolWrite->write(\$f->{linkname});
313         processClose($poolWrite, "$ShareName/$f->{mangleName}", $f->{size});
314     } elsif ( $f->{type} == BPC_FTYPE_SYMLINK ) {
315         #
316         # Symbolic link: write the value of the link to a plain file,
317         # that we pool as usual (ie: we don't create a symlink).
318         # The attributes remember the original file type.
319         # We also change the size to reflect the size of the link
320         # contents.
321         #
322         $f->{size} = length($f->{linkname});
323         my $poolWrite = BackupPC::PoolWrite->new($bpc,
324                                          "$OutDir/$ShareName/$f->{mangleName}",
325                                          $f->{size}, $Compress);
326         $poolWrite->write(\$f->{linkname});
327         processClose($poolWrite, "$ShareName/$f->{mangleName}", $f->{size});
328     } elsif ( $f->{type} == BPC_FTYPE_CHARDEV
329            || $f->{type} == BPC_FTYPE_BLOCKDEV
330            || $f->{type} == BPC_FTYPE_FIFO ) {
331         #
332         # Special files: for char and block special we write the
333         # major and minor numbers to a plain file, that we pool
334         # as usual.  For a pipe file we create an empty file.
335         # The attributes remember the original file type.
336         #
337         my $data;
338         if ( $f->{type} == BPC_FTYPE_FIFO ) {
339             $data = "";
340         } else {
341             $data = "$f->{devmajor},$f->{devminor}";
342         }
343         my $poolWrite = BackupPC::PoolWrite->new($bpc,
344                                          "$OutDir/$ShareName/$f->{mangleName}",
345                                          length($data), $Compress);
346         $poolWrite->write(\$data);
347         $f->{size} = length($data);
348         processClose($poolWrite, "$ShareName/$f->{mangleName}", length($data));
349     } else {
350         print("Got unknown type $f->{type} for $f->{name}\n");
351         $Errors++;
352     }
353     $Attrib{$dir}->set($file, {
354                             type  => $f->{type},
355                             mode  => $f->{mode},
356                             uid   => $f->{uid},
357                             gid   => $f->{gid},
358                             size  => $f->{size},
359                             mtime => $f->{mtime},
360                        });
361     return 1;
362 }
363
364 sub attributeWrite
365 {
366     my($d) = @_;
367     my($poolWrite);
368
369     return if ( !defined($Attrib{$d}) );
370     if ( $Attrib{$d}->fileCount ) {
371         my $data = $Attrib{$d}->writeData;
372         my $fileName = $Attrib{$d}->fileName("$OutDir/$d");
373         my $poolWrite = BackupPC::PoolWrite->new($bpc, $fileName,
374                                          length($data), $Compress);
375         $poolWrite->write(\$data);
376         processClose($poolWrite, $Attrib{$d}->fileName($d), length($data));
377     }
378     delete($Attrib{$d});
379 }
380
381 sub processClose
382 {
383     my($poolWrite, $fileName, $origSize) = @_;
384     my($exists, $digest, $outSize, $errs) = $poolWrite->close;
385
386     if ( @$errs ) {
387         print(STDERR join("", @$errs));
388         $Errors += @$errs;
389     }
390     $TotalFileCnt++;
391     $TotalFileSize += $origSize;
392     if ( $exists ) {
393         $ExistFileCnt++;
394         $ExistFileSize     += $origSize;
395         $ExistFileCompSize += $outSize;
396     } elsif ( $outSize > 0 ) {
397         print(NEW_FILES "$digest $origSize $fileName\n");
398     }
399 }
400
401 mkpath("$OutDir/$ShareName", 0, 0777);
402 open(NEW_FILES, ">>", "$TopDir/pc/$host/NewFileList")
403                  || die("can't open $TopDir/pc/$host/NewFileList");
404 binmode(NEW_FILES);
405 binmode(STDIN);
406 1 while ( TarReadFile(*STDIN) );
407 1 while ( sysread(STDIN, my $discard, 1024) );
408
409 #
410 # Flush out remaining attributes.
411 #
412 foreach my $d ( keys(%Attrib) ) {
413     attributeWrite($d);
414 }
415 close(NEW_FILES);
416
417 #
418 # Report results to BackupPC_dump
419 #
420 print("Done: $Errors errors, $ExistFileCnt filesExist,"
421     . " $ExistFileSize sizeExist, $ExistFileCompSize sizeExistComp,"
422     . " $TotalFileCnt filesTotal, $TotalFileSize sizeTotal\n");