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