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