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-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 3.0.0alpha, released 23 Jan 2006.
  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;