511 lines
13 KiB
Perl
511 lines
13 KiB
Perl
|
#----------------------------------------------------------------------
|
||
|
|
# Copyright 2015 Ian Wells
|
||
|
|
# This program is free software; you can redistribute it and/or
|
||
|
|
# modify it under the same terms as Perl itself.
|
||
|
|
#----------------------------------------------------------------------
|
||
|
|
|
||
|
|
package esmith::BlockDevices;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use warnings;
|
||
|
|
use English '-no_match_vars';
|
||
|
|
use Carp;
|
||
|
|
use File::Path qw(make_path remove_tree);
|
||
|
|
use POSIX qw(:sys_wait_h strftime);
|
||
|
|
use Locale::gettext;
|
||
|
|
use File::stat;
|
||
|
|
use v5.10.1;
|
||
|
|
use Taint::Util;
|
||
|
|
use Readonly;
|
||
|
|
use File::Find;
|
||
|
|
|
||
|
|
use vars qw($VERSION @ISA @EXPORT_OK);
|
||
|
|
|
||
|
|
@ISA = qw(Exporter);
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
esmith::BlockDevices - Module to handle block devices
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
use esmith::BlockDevices;
|
||
|
|
my $devices = BlockDevices->new ();
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
This module provides an abstracted interface to the
|
||
|
|
block devices used for backup/restore
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
my $EMPTY = q{};
|
||
|
|
|
||
|
|
sub new
|
||
|
|
{
|
||
|
|
my $class = shift;
|
||
|
|
my $self = {
|
||
|
|
_blox => lsblk(),
|
||
|
|
mount => findValidFS(),
|
||
|
|
_fstype => $EMPTY,
|
||
|
|
allowmount => $EMPTY,
|
||
|
|
@_,
|
||
|
|
};
|
||
|
|
bless $self, $class;
|
||
|
|
return $self;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub lsblk
|
||
|
|
{
|
||
|
|
#ToDo add some comments
|
||
|
|
my %blox; # a hash to hold the device information
|
||
|
|
|
||
|
|
my $short = qx(/bin/lsblk -sdn -o KNAME);
|
||
|
|
my @long = qx(/bin/lsblk -P -b -o KNAME,MAJ:MIN,RM,RO,TYPE,MOUNTPOINT,FSTYPE,LABEL,UUID,MODEL,SIZE,STATE,MODE,OWNER,GROUP);
|
||
|
|
# Not all of this information may be needed currently, but it does not affect the processing time
|
||
|
|
untaint ($short);
|
||
|
|
untaint (@long);
|
||
|
|
|
||
|
|
my $devicemodel= $EMPTY;
|
||
|
|
|
||
|
|
for (@long)
|
||
|
|
{
|
||
|
|
my @line = split /\"\s/s;
|
||
|
|
my $name;
|
||
|
|
if ($line[0] =~ /KNAME=\"(.*)/s)
|
||
|
|
{
|
||
|
|
$name = $1;
|
||
|
|
}
|
||
|
|
else {carp 'Could not match KNAME'; last;} # should never occur.
|
||
|
|
|
||
|
|
$blox{$name}{tip} = ($short =~ m/^$name$/sm) ? 1 : 0;
|
||
|
|
|
||
|
|
for (@line)
|
||
|
|
{
|
||
|
|
my ($key,$value) = split /=/s;
|
||
|
|
$value =~ s/\"//sg;
|
||
|
|
$blox{$name}{$key} = trim($value);
|
||
|
|
}
|
||
|
|
if ($blox{$name}{TYPE} =~ /rom|disk/s)
|
||
|
|
{
|
||
|
|
$devicemodel = $blox{$name}{MODEL};
|
||
|
|
}
|
||
|
|
else
|
||
|
|
{
|
||
|
|
$blox{$name}{MODEL} = trim($devicemodel);
|
||
|
|
}
|
||
|
|
$blox{$name}{SIZEH} = scaleIt($blox{$name}{SIZE});
|
||
|
|
}
|
||
|
|
return \%blox;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub findValidFS
|
||
|
|
{
|
||
|
|
# Find all filesystem types that are supported
|
||
|
|
my %fs; # a hash to hold the supported filesystem type information
|
||
|
|
|
||
|
|
my @cmd = `cat /proc/filesystems`;
|
||
|
|
foreach (@cmd)
|
||
|
|
{
|
||
|
|
if (/.*\t(.*?)$/s){$fs {$1}=$1;}
|
||
|
|
}
|
||
|
|
@cmd = `ls -1 /lib/modules/\$(uname -r)/kernel/fs/*/*ko.*`;
|
||
|
|
foreach (@cmd)
|
||
|
|
{
|
||
|
|
if (/.*\/(.*?)\.ko/s){$fs {$1}=$1;}
|
||
|
|
}
|
||
|
|
|
||
|
|
# If ext4 driver is present, add ext2 and ext3
|
||
|
|
if(exists($fs{ext4}))
|
||
|
|
{
|
||
|
|
$fs{'ext2'}='ext2';
|
||
|
|
$fs{'ext3'}='ext3';
|
||
|
|
}
|
||
|
|
return \%fs;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub scanBlocks
|
||
|
|
{
|
||
|
|
# Scan all the block devices
|
||
|
|
# This takes some seconds on systems with many filesystems
|
||
|
|
my ($self) = @_;
|
||
|
|
$self->{_blox} = lsblk;
|
||
|
|
$self->{_fstype} = findValidFS;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub list
|
||
|
|
{
|
||
|
|
my ($self) = @_;
|
||
|
|
my @dirs=();
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
|
||
|
|
foreach my $drive (keys %{$hashref})
|
||
|
|
{
|
||
|
|
push @dirs, $drive;
|
||
|
|
}
|
||
|
|
|
||
|
|
return @dirs;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub checkBackupDriveSize
|
||
|
|
{
|
||
|
|
my ($self,$drive, $size) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
my $sz = $EMPTY;
|
||
|
|
my $mntdir = $self->{mount};
|
||
|
|
Readonly my $VFAT_LIMIT => 2147483648;
|
||
|
|
Readonly my $KBYTE => 1024;
|
||
|
|
|
||
|
|
# size > drive size
|
||
|
|
if ($size > $hashref->{$drive}{SIZE})
|
||
|
|
{
|
||
|
|
return 1; # filesystem too small
|
||
|
|
}
|
||
|
|
|
||
|
|
# FAT32 drive and size > 2G
|
||
|
|
if (($size > $VFAT_LIMIT) && ($hashref->{$drive}{FSTYPE} eq 'vfat'))
|
||
|
|
{
|
||
|
|
return 2; # filesystem vfat limit
|
||
|
|
}
|
||
|
|
|
||
|
|
#ToDo add a check here to see if mounting is allowed by db value
|
||
|
|
|
||
|
|
# check mount and find actual size
|
||
|
|
if ($self->mountable ($drive)) # Only check filesystems that appear mountable
|
||
|
|
{
|
||
|
|
$self->mount ($drive);
|
||
|
|
my $filesize = -s "$mntdir/smeserver.tgz";
|
||
|
|
|
||
|
|
# Check free disk space
|
||
|
|
my $df = qx(/usr/bin/df -P \"$mntdir\");
|
||
|
|
if ($df =~ /(\S+)\s+(\S+)\s+(\S+)\s+(\d*%)/s)
|
||
|
|
{
|
||
|
|
my $dsize = ($3 * $KBYTE) + ($filesize //= 0);
|
||
|
|
if ($size > $dsize) # not enough space
|
||
|
|
{
|
||
|
|
$sz = 3; # filesystem has too little free space
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else # fail (never seen in testing)
|
||
|
|
{
|
||
|
|
$sz = 4; # Failed to get disk size
|
||
|
|
}
|
||
|
|
$self->unmount;
|
||
|
|
}
|
||
|
|
return $sz;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Check each block device
|
||
|
|
# Return two arrays, valid drives, invalid drives
|
||
|
|
sub checkBackupDrives
|
||
|
|
{
|
||
|
|
my ($self,$bsize) = @_;
|
||
|
|
my @valid = ();
|
||
|
|
my @invalid = ();
|
||
|
|
$self->scanBlocks; # scan all block devices
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
my $allowmount = $self->{'allowmount'}; # Are mounted drives allowed in $checks.
|
||
|
|
my $checks = 'UU RO FS'; # These checks are always valid
|
||
|
|
$checks .= ' MO' if ($allowmount eq 'enabled');
|
||
|
|
$checks .= ' SZ' if ($bsize); # Only run the size check when a valid size is given
|
||
|
|
|
||
|
|
foreach my $drive (keys %{$hashref})
|
||
|
|
{
|
||
|
|
$hashref->{$drive}{REASON} = $EMPTY; # Reason for a filesystem being (in)valid
|
||
|
|
next unless $hashref->{$drive}{tip}; #Ignore drives that have child filesystems
|
||
|
|
|
||
|
|
# drives mounted on /, /boot, or [SWAP] are never valid for backups
|
||
|
|
next if ($hashref->{$drive}{MOUNTPOINT} =~ /^\/boot$|^\[SWAP\]$|^\/$/s );
|
||
|
|
|
||
|
|
# validate each filesystem against the checks
|
||
|
|
foreach my $check (split / /s, $checks)
|
||
|
|
{
|
||
|
|
for ($check)
|
||
|
|
{
|
||
|
|
if (/^UU/si) # No UUID
|
||
|
|
{
|
||
|
|
$hashref->{$drive}{REASON} .='UU ' unless $self->uuid ($drive); last;
|
||
|
|
}
|
||
|
|
if (/^RO/si) # Read Only
|
||
|
|
{
|
||
|
|
$hashref->{$drive}{REASON} .='RO ' if $self->readonly ($drive); last;
|
||
|
|
}
|
||
|
|
if (/^FS/si) # Invalid filesystem
|
||
|
|
{
|
||
|
|
$hashref->{$drive}{REASON} .='FS ' unless $self->validFS ($drive); last;
|
||
|
|
}
|
||
|
|
if (/^MO/si) # Mounted
|
||
|
|
{
|
||
|
|
$hashref->{$drive}{REASON} .='MO ' if $self->mountpoint ($drive); last;
|
||
|
|
}
|
||
|
|
if (/^SZ/si) # filesystem size, this includes mounting to check free space
|
||
|
|
{
|
||
|
|
$hashref->{$drive}{REASON} .='SZ ' if $self->checkBackupDriveSize ($drive, $bsize);
|
||
|
|
#ToDo the return value contains the reason why there is insufficient space, but this is not used yet.
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
{ carp "not supported yet in checkBackupDrives: $check"; } # Should never be seen
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ($hashref->{$drive}{REASON})
|
||
|
|
{
|
||
|
|
push @invalid, $drive;
|
||
|
|
}
|
||
|
|
else
|
||
|
|
{
|
||
|
|
push @valid, $drive;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return (\@valid, \@invalid);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub findBackup
|
||
|
|
{
|
||
|
|
my ($self, $kname, $foundref, $maxDepth, $count) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
my $mountpoint = $self->{'mount'};
|
||
|
|
my $file = 'smeserver.tgz';
|
||
|
|
|
||
|
|
$self->mount ($kname);
|
||
|
|
sleep 1;
|
||
|
|
|
||
|
|
# start with the absolute path
|
||
|
|
my $findRoot = Cwd::realpath($mountpoint);
|
||
|
|
|
||
|
|
# determine the depth of our beginning directory
|
||
|
|
my $begDepth = 1 + grep { length } File::Spec->splitdir($findRoot);
|
||
|
|
|
||
|
|
find (
|
||
|
|
{
|
||
|
|
preprocess => sub
|
||
|
|
{ @_ if (scalar File::Spec->splitdir($File::Find::dir) - $begDepth) <= $maxDepth },
|
||
|
|
wanted => sub
|
||
|
|
{
|
||
|
|
if (($_ =~ m/^$file/s) && ($File::Find::name =~ qr|^([-+@\w\s./:\\]+)$| )) # if matching the backup name
|
||
|
|
{
|
||
|
|
$$count++;
|
||
|
|
my $sb = stat $1;
|
||
|
|
${$foundref}{$$count}{count}=$$count;
|
||
|
|
${$foundref}{$$count}{device}=$kname;
|
||
|
|
${$foundref}{$$count}{path} = $1;
|
||
|
|
${$foundref}{$$count}{path} =~ s/$mountpoint//; #strip off the mountpoint
|
||
|
|
${$foundref}{$$count}{path} =~ s/$file//; #strip off the filename
|
||
|
|
${$foundref}{$$count}{size}=$sb->size; # size in bytes
|
||
|
|
${$foundref}{$$count}{sizeH}=scaleIt($sb->size); # human readable size
|
||
|
|
${$foundref}{$$count}{time}=strftime '%d %b %g %H:%M', localtime $sb->mtime;
|
||
|
|
}
|
||
|
|
},
|
||
|
|
untaint => 1,
|
||
|
|
untaint_pattern => qr|^([-+@\w\s./:\\]+)$|,
|
||
|
|
untaint_skip =>1,
|
||
|
|
},
|
||
|
|
$findRoot
|
||
|
|
);
|
||
|
|
|
||
|
|
$self->unmount;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub desc # brief description of a filesystem
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
|
||
|
|
my $model = $hashref->{$kname}{MODEL};
|
||
|
|
my $label = $hashref->{$kname}{LABEL} || gettext('no label');
|
||
|
|
my $size = $hashref->{$kname}{SIZEH};
|
||
|
|
|
||
|
|
return "$label $model $size";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Given the KNAME check if the filesystem.could be mountable
|
||
|
|
# Check that there are no children, i.e. a tip
|
||
|
|
# Check that it has a UUID, Filesystem,
|
||
|
|
sub mountable
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{tip} && $hashref->{$kname}{UUID} && _isFS ($hashref->{$kname}{FSTYPE})) ? 1 : $EMPTY;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Given the KNAME check if the filesystem.is read-only
|
||
|
|
# returns 1 for Read-Only and $EMPTY for R-W
|
||
|
|
sub readonly
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{RO}) ? 1 : $EMPTY;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub mountpoint
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{MOUNTPOINT});
|
||
|
|
}
|
||
|
|
|
||
|
|
sub uuid
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{UUID});
|
||
|
|
}
|
||
|
|
|
||
|
|
sub model
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{MODEL});
|
||
|
|
}
|
||
|
|
|
||
|
|
# Given the KNAME return the label
|
||
|
|
# returns 'no label' if none found
|
||
|
|
sub label
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{LABEL}) || gettext('no label');
|
||
|
|
}
|
||
|
|
|
||
|
|
sub size
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{SIZE});
|
||
|
|
}
|
||
|
|
|
||
|
|
# Given a filesystem.(eg sr0) check if it's filesystem type is allowed
|
||
|
|
sub validFS
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
my $fsref = $self->{_fstype};
|
||
|
|
return ($fsref->{$hashref->{$kname}{FSTYPE}}) || $EMPTY;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Given a filesystem.type (eg vfat) check if it is allowed
|
||
|
|
sub _isFS
|
||
|
|
{
|
||
|
|
my ($filesystem) = @_;
|
||
|
|
return $EMPTY unless $filesystem;
|
||
|
|
|
||
|
|
my $fsref = findValidFS;
|
||
|
|
return ($fsref->{$filesystem}) || $EMPTY;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Return the reason string which indicates why a drive is (in)valid
|
||
|
|
sub reason
|
||
|
|
{
|
||
|
|
my ($self,$kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
return ($hashref->{$kname}{REASON});
|
||
|
|
}
|
||
|
|
|
||
|
|
# Given the KNAME mount the filesystem, example
|
||
|
|
# system ('/bin/mount', '-t', 'vfat', '-U', '9891-4C8A', '/tmp/mnt');
|
||
|
|
sub mount
|
||
|
|
{
|
||
|
|
my ($self, $kname) = @_;
|
||
|
|
my $hashref = $self->{_blox};
|
||
|
|
|
||
|
|
$self->createMountpoint;
|
||
|
|
|
||
|
|
system ('/bin/mount', '-t', $hashref->{$kname}{FSTYPE}, '-U', $hashref->{$kname}{UUID}, $self->{mount}) == 0
|
||
|
|
or croak (gettext('Failed to mount')." $self->{mount},$hashref->{$kname}{FSTYPE},$hashref->{$kname}{UUID}: $?");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Unmount the block device
|
||
|
|
sub unmount
|
||
|
|
{
|
||
|
|
my $self = shift;
|
||
|
|
system('/bin/umount', $self->{mount}) == 0
|
||
|
|
or croak (gettext('Failed to unmount')." $self->{mount}: $?");
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Create the mountpoint directory
|
||
|
|
# Error if already mounted
|
||
|
|
sub createMountpoint
|
||
|
|
{
|
||
|
|
my $self = shift;
|
||
|
|
my $mount = $self->{mount};
|
||
|
|
|
||
|
|
# Check if the mountpoint is in use
|
||
|
|
if (!checkMount ($mount))
|
||
|
|
{
|
||
|
|
# Try to unmount, will die if fails
|
||
|
|
$self->unmount;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($mount && ! -d $mount)
|
||
|
|
{
|
||
|
|
eval {make_path($mount)};
|
||
|
|
croak (gettext('Error while creating')." $mount $EVAL_ERROR".gettext('Maybe insufficient permissions.')) if $EVAL_ERROR;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub destroy
|
||
|
|
{
|
||
|
|
# cleanup, unmount and remove mountpoint
|
||
|
|
|
||
|
|
my $self = shift;
|
||
|
|
my $mount = $self->{mount};
|
||
|
|
|
||
|
|
|
||
|
|
# Check if the mountpoint is in use
|
||
|
|
if (!checkMount ($mount))
|
||
|
|
{
|
||
|
|
$self->unmount;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($mount && -d $mount)
|
||
|
|
{
|
||
|
|
eval {remove_tree($mount)};
|
||
|
|
croak (gettext('Error while deleting')." $mount $EVAL_ERROR") if $EVAL_ERROR;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
### The following subroutines are not specific to block devices
|
||
|
|
sub scaleIt {
|
||
|
|
Readonly my $KBYTE => 1024;
|
||
|
|
my( $size, $n ) =( shift, 0 );
|
||
|
|
++$n and $size /= $KBYTE until $size < $KBYTE;
|
||
|
|
if ($size >= 1000){++$n ; $size /= $KBYTE;}
|
||
|
|
return sprintf "%.3g %s",
|
||
|
|
$size, ( qw[ bytes KB MB GB TB] )[ $n ];
|
||
|
|
}
|
||
|
|
|
||
|
|
sub checkMount
|
||
|
|
{
|
||
|
|
# check if $mountdir is mounted
|
||
|
|
my $mountdir = shift;
|
||
|
|
$|=1; # Auto-flush
|
||
|
|
|
||
|
|
# copy STDOUT to another filehandle
|
||
|
|
open (my $STDOLD, '>&', STDOUT);
|
||
|
|
|
||
|
|
open(STDOUT, ">/dev/null");
|
||
|
|
if ( open(MOUNTDIR, "|-", "/bin/findmnt", $mountdir)){;}
|
||
|
|
|
||
|
|
# restore STDOUT
|
||
|
|
open (STDOUT, '>&', $STDOLD);
|
||
|
|
|
||
|
|
return (!close(MOUNTDIR));
|
||
|
|
}
|
||
|
|
|
||
|
|
# remove leading and trailing spaces from a string
|
||
|
|
# this should be moved to a util library.
|
||
|
|
sub trim
|
||
|
|
{
|
||
|
|
my ($string) = @_;
|
||
|
|
$string =~ s/^\s+|\s+$//g;
|
||
|
|
return $string;
|
||
|
|
}
|
||
|
|
1;
|