# -*- perl -*-

#
#   Copyright (C) Heinz-Josef Claes (2001-2009)
#                 hjclaes@web.de
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.

#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
#



push @VERSION, '$Id: fileDir.pl 361 2009-07-18 13:37:37Z hjc $ ';

use Fcntl qw(O_RDWR O_CREAT);
use POSIX;

require 'prLog.pl';
require 'forkProc.pl';

use strict;

# checks if a file is a symlink and deletes it if wanted
# return values (if not exiting):
#               0: no symlink
#              -1: found symlink
############################################################
sub checkDelSymLink
{
    my $file = shift;       # name of the file
    my $prLog = shift;
    my $delExit = shift;    # set bits:
                            #  bit 0:  0 = do not delete
                            #          1 = delete synlink
                            #              if not possible, exit
                            #  bit 1:  0 = do not exit (if exists)
                            #          1 = exit

    return 0 unless -l $file;

    if ($delExit & 0x02)
    {
	$prLog->print('-kind' => 'E',
		      '-str' =>
		      ["found symbolic link at <$file>, exiting "],
		      '-exit' => 1);
    }

    if ($delExit & 0x01)
    {
	$prLog->print('-kind' => 'W',
		      '-str' => ["unlinking symbolic link <$file>"]);
	unlink $file or
	    $prLog->print('-kind' => 'E',
			  '-str' => ["cannot unlink <$file>, exiting"],
			  '-exit' => 1);
    }

    return -1;
}


############################################################
sub splitFileDir
{
    my $name = shift;

    return (undef, undef) unless $name;
    return ('.', $name) unless ($name =~/\//);    # nur einfacher Dateiname

    my ($dir, $file) = $name =~ /^(.*)\/(.*)$/s;
    $dir = '/' if ($dir eq '');                   # gilt, falls z.B. /filename
    return ($dir, $file);
}


############################################################
# Parameter kann directory oder Datei sein
%main::absolutePathCache = ();
@main::absolutePathCache = ();
sub absolutePath
{
    my $dir = shift;

    return undef unless $dir;

    # Erst im Hash nachsehen, ob das schon ermittelt wurde
    return $main::absolutePathCache{$dir}
        if exists $main::absolutePathCache{$dir};
    my $dirSave = $dir;

    # Falls Datei selbst ein symlink ist, solange folgen, bis aufgelöst
    my $file = '';


    $dir = $ENV{'PWD'} . "/$dir" unless ($dir =~ /^\//); # relativer Pfad

    if (-e $dir)
    {
	$file = $dir;
	while (-l $file)
	{
	    my $link = readlink($file);

	    if (substr($link, 0, 1) ne "/")
	    {
		$file =~ s/[^\/]+$/$link/;
	    }
	    else
	    {
		$file = $link;
	    }
	}

	($dir, $file) = &splitFileDir($file);
	$file = "/$file";
    }

    my $ret = (-e "$dir$file") ? "$dir$file" : undef;
    $ret =~ s/\/\//\//g;       # // -> /
    $ret =~ s/\/\.\//\//g;     # /./ -> /
    $ret =~ s/\A(.+)\/\Z/$1/;  # remove trailing /
    $ret =~ s/\A\.\///;        # ./xxx -> xxx
    $ret =~ s/\/\.\Z//;        # xxx/. -> xxx

    # eliminate /../
    my (@ret) = split(/\//, $ret);
    if (@ret)
    {
	my (@rev) = reverse(@ret);
	(@ret) = ();
	my ($i, $j);
	for ($i = $j = 0 ; $i < @rev ; $i++, $j++)
	{
	    if ($rev[$i] eq '..')
	    {
		$j++;
	    }
	    else
	    {
		push @ret, $rev[$j] if ($j < @rev);
	    }
	}
	$ret = join('/', reverse @ret);
    }

    if (@main::absolutePathCache > 100)
    {
	my $del = shift @main::absolutePathCache;   # delete oldest
	delete $main::absolutePathCache{$del};
    }
    push @main::absolutePathCache, $ret;
    return $main::absolutePathCache{$dirSave} = $ret;
}


########################################
sub clearAbsolutePathCache
{
    %main::absolutePathCache = ();
    @main::absolutePathCache = ();
}


############################################################
sub relPath
{
                            # calculate relative path from
    my $dir = shift;        # this file or directory
    my $target = shift;     # to this directory or file

    return undef unless $dir or $target;

    $dir = ::absolutePath($dir) if substr($dir, 0, 1) ne '/';
    $target = ::absolutePath($dir) if substr($target, 0, 1) ne '/';

    my (@dir) = split(/\//, $dir);
    my (@target) = split(/\//, $target);
    shift @dir;
    shift @target;

    my $min = (@dir < @target) ? @dir : @target;
    my $i;
    for ($i = 0 ; $i < $min ; $i++)
    {
	last if ($dir[$i] ne $target[$i]);
    }
    my $relPath = '../' x (@dir - $i) . join('/', @target[$i..@target-1]);
    $relPath = '.' unless $relPath;
    return $relPath;
}


############################################################
sub uniqFileName
{
    my $prefix = shift;                 # z.B. '/tmp/test-'

    my $suffix;
    do
    {
	$suffix = sprintf '%08x%08x', rand 0xffffffff, rand 0xffffffff;
    }
    while (-e $prefix . $suffix);

    return $prefix . $suffix;
}


############################################################
# testet, ob subDir ein Unterverzeichnis von dir ist
sub isSubDir
{
    my $dir = shift;
    my $subDir = shift;

    $dir = &::absolutePath($dir);
    $dir .= '/' unless $dir eq '/';
    $subDir = &::absolutePath($subDir);
    $subDir .= '/' unless $subDir eq '/';

    return (index($subDir, $dir) == 0) ? 1 : 0;
}


############################################################
# substract pathLong - pathShort = relPath
sub substractPath
{
    my $pathLong = shift;       # longer path
    my $pathShort = shift;      # shorter path

    $pathLong =~ s/\/+$//;      # remove trailing /
    $pathShort =~ s/\/+$//;     # remove trailing /
    $pathLong =~ s/\/\//\//g;   # // -> /
    $pathShort =~ s/\/\//\//g;  # // -> /

    my $relPath;
    if ($pathShort eq '/')
    {
	$relPath = substr($pathLong, 1);
    }
    else
    {
	$relPath = substr($pathLong, length($pathShort) + 1);
    }
    return $relPath;
}

############################################################
# makes the directories to a file
sub makeFilePath
{
    my $path = shift;
    my $prLog = shift;

    $path =~ m#\A(.*)/.*\Z#s;
    &makeDirPath($1, $prLog);
}


############################################################
# like `mkdir -p`, all permissions set to 0700
sub makeDirPath
{
    my $path = shift;
    my $prLog = shift;

    my @p;
    return if -e $path;

    my ($p1, $p2) = $path =~ m#\A(.*)/(.*)\Z#s;

    &makeDirPath($p1, $prLog);

    unless (mkdir $path, 0700)
    {
	return if -e $path;
	$prLog->print('-kind' => 'E',
		      '-str' => ["cannot create directory <$path>"]);
    }
    return;
}


############################################################
# liest Typ der File Systeme und liefert sortiert nach Länge,
# die längsten zuerst, Liefert Zeiger auf Liste von Hashes
sub getFileSystemInfosSorted
{
    my $prLog = shift;
    my $tmpdir = shift;

    my $fs = forkProc->new('-exec' => 'mount',
			   '-outRandom' => "$tmpdir/mount-",
			   '-prLog' => $prLog);
    $fs->wait();
    my $out = $fs->getSTDERR();
    $prLog->print('-kind' => 'E',
		  '-str' => ['STDERR of command mount (exit status ' .
			     $fs->get('-what' => 'status') . "):",
			     @$out, 'exiting'],
		  '-exit' => 1)
	if (@$out > 0);
    $out = $fs->getSTDOUT();
    my ($o, @fstypes);
    foreach $o (@$out)
    {
	my ($origin, $dir, $type, $flags) = $o =~
	    /^(.*) on (.*) type (\w+) \((.*)\)/;
#	print "<$origin> <$dir> <$type> <$flags>\n";
	push @fstypes, {'origin' => $origin,
			'dir' => $dir,
			'type' => $type,
			'flags' => $flags};
    }

    @fstypes = sort { length($b->{'dir'}) <=> length($a->{'dir'}) } @fstypes;

    return \@fstypes;
}


############################################################
sub checkLockFile
{
    my ($lockFile, $prLog) = @_;

    local *FILE;
    if (-f $lockFile)
    {
	open(FILE, "< $lockFile") or
	    $prLog->print('-kind' => 'E',
			  '-str' => ["cannot read lock file <$lockFile>"],
			  '-exit' => 1);
	my $pid = <FILE>;
	chop $pid;
	close(FILE);
	$prLog->print('-kind' => 'E',
		      '-str' => ["strange format in lock file <$lockFile>, " .
				 "line is <$pid>"],
		      '-exit' => 1)
	    unless ($pid =~ /\A\d+\Z/o);
	if (kill(0, $pid) == 1)   # alte Instanz läuft noch
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["cannot start, old instance with pid " .
				     "<$pid> is allready running"],
			  '-exit' => 1);
	}
	else
	{
	    $prLog->print('-kind' => 'I',
			  '-str' => ["removing old lock file of process <$pid>"]
			  );
	}
    }

    $prLog->print('-kind' => 'I',
		  '-str' => ["creating lock file <$lockFile>"]);

    &::checkDelSymLink($lockFile, $prLog, 0x01);
    open(FILE, "> $lockFile") or
	$prLog->print('-kind' => 'E',
		      '-str' => ["cannot create lock file <$lockFile>"],
		      '-exit' => 1);
    print FILE "$$\n";
    close(FILE);
}


############################################################
sub calcMD5
{
    my $filename = shift;
    my $prLog = shift;

    local *FROM;
    unless (sysopen(FROM, $filename, O_RDONLY))
    {
	return undef;
    }
    my $md5 = Digest::MD5->new();
    my $buffer;
    while (sysread(FROM, $buffer, 1024*1024))
    {
	$md5->add($buffer);
    }
    close(FROM);
    return $md5->hexdigest();
}


############################################################
# Objekt kann zum (wiederholten) Abfragen von Informationen
# über eine Datei verwendet werden.
# Liefert: alles von stat, md5sum
############################################################
package singleFileInfo;

##################################################
sub new
{
    my ($class) = shift;
    my ($self) = {};

    my (%params) = ('-filename'      => undef,
		    '-prLog'         => undef
		    );

    &::checkObjectParams(\%params, \@_, 'singleFileInfo::new',
			 ['-filename', '-prLog']);
    &::setParamsDirect($self, \%params);

    my (@statStruct) = (stat($params{'-filename'}));
    $self->{'stat'} = \@statStruct;

    bless $self, $class;
}

##################################################
sub getFilename
{
    my $self = shift;

    return $self->{'filename'};
}

##################################################
sub getInfo
{
    my $self = shift;

    my (%params) = ('-kind'    => undef
		    );

    &::checkObjectParams(\%params, \@_, 'singleFileInfo::getInfo',
			 ['-kind']);
    my $kind = $params{'-kind'};
    my $prLog = $self->{'prLog'};

    if ($kind eq 'md5')
    {
	if (defined $self->{'md5'})
	{
	    return $self->{'md5'};
	}

	my $f = forkProc->new('-exec' => 'md5sum',
			      '-stdout' => "/tmp/out.$$",
			      '-stderr' => "/tmp/err.$$",
			      '-param' => [$self->{'filename'}],
			      '-prLog' => $prLog);
	$f->wait();
	my $x = $f->getSTDERR();
	if (@$x > 0)
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["md5sum " . $self->{'filename'} .
				     " generated the following error " .
				     "message, exiting:", @$x],
			  '-exit' => 1);
	}
	$x = $f->getSTDOUT();
	if (@$x != 1)
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["md5sum " . $self->{'filename'} .
				     " generated incorrect output " .
				     "exiting:", @$x],
			  '-exit' => 1);
	}

	# Filtern der md5 Summe
	my ($md5) = $$x[0] =~ /^(\w+)/;

	$self->{'md5'} = $md5;
	return $md5;
    }

    my (%kind) = ('inode' => 1,   # index ist von stat
		  'mode' => 2,
		  'nlink' => 3,
		  'uid' => 4,
		  'gid' => 5,
		  'size' => 7,
		  'atime' => 8,
		  'mtime' => 9,
		  'ctime' => 10);
    return undef unless (defined $kind{$kind});
    return $self->{'stat'}[$kind{$kind}];
}



############################################################
# Liefert directories, files und symbolic links
package recursiveReadDir;

########################################
sub new
{
    my $class = shift;
    my $self = {};

    my (%params) = ('-dirs'                => [],# zu durchsuchende dirs
		    '-exceptDirs'          => [],# zu überspringende dirs
		    '-includeDirs'         => [],# except all but these dirs
		                               # if empty, ignore this option
		    '-followLinks'         => 0, # nicht folgen, wenn 1, dann
		                                 # in erster Ebene folgen, mehr
		                                 # geht bisher nicht
		    '-prLog'               => undef,
		    '-prLogError'          => 'E',
		    '-prLogWarn'           => 'W',
		    '-exitIfError'         => 1, # Errorcode bei Fehler
		    '-verbose'             => undef,
		    '-ignoreReadError'     => 'no', # no, yes, onlyPrintMessage
		    '-printDepth'          => 'no',
		    '-printDepthPrlogKind' => 'I'
		    );

    &::checkObjectParams(\%params, \@_, 'recursiveReadDir::new',
			 ['-dirs', '-prLog']);
    &::setParamsDirect($self, \%params);

    @{$self->{'files'}} = ();   # in 'dirs' und 'files' werden die
                                # files bzw. dirs abgelegt, die noch
                                # auszuliefern bzw. zu durchsuchen sind
    @{$self->{'types'}} = ();   # Typ der Datei: 'f', 'd' oder 'l'
                                # nach Optionen von test -f, etc.

    my $e;
    my %except;
    foreach $e (@{$params{'-exceptDirs'}})
    {
	$e = &::absolutePath($e);
	$except{$e} = 1;
    }
    $self->{'except'} = \%except;

    my %include;
    foreach $e (@{$params{'-includeDirs'}})
    {
	$e = &::absolutePath($e);
	$include{$e} = 1;
    }
    $self->{'include'} = \%include;

    my @depths;
    for ($e = 0 ; $e < @{$self->{'dirs'}} ; $e++)
    {
	push @depths, 0;    # Initalwert, wichtig falls 'followLinks' > 0
    }
    $self->{'depths'} = \@depths;
    $self->{'printedDepth'} = -1;

    bless $self, $class;
}


########################################
sub next
{
    my $self = shift;

    my $dirs = $self->{'dirs'};

    while (@{$self->{'files'}} == 0 and @$dirs > 0)
    {
	$self->readDir();
    }

    if (@{$self->{'files'}} > 0)
    {
        my $f = shift @{$self->{'files'}};
	my $t = shift @{$self->{'types'}};
#print "--> $t $f\n";
	return ($f, $t);
    }

    return ();
}


########################################
sub readDir
{
    my $self = shift;

    my $prLog = $self->{'prLog'};
    my $prLogErr = $self->{'prLogError'};
    my $prLogWarn = $self->{'prLogWarn'};
    my $exit = $self->{'exitIfError'};

    my $dirs = $self->{'dirs'};
    my $dir = shift @$dirs;
    my $depths = $self->{'depths'};
    my $depth = shift @$depths;
    my $files = $self->{'files'};
    my $types = $self->{'types'};
    my $except = $self->{'except'};
    my $include = $self->{'include'};
    my $includeDirs = $self->{'includeDirs'};
    my $ignoreReadError = $self->{'ignoreReadError'};


    if ($self->{'printDepth'} eq 'yes' and defined $depth
	and $self->{'printedDepth'} != $depth)
    {
	$self->{'printedDepth'} = $depth;
	$prLog->print('-kind' => $self->{'printDepthPrlogKind'},
		      '-str' => ["reading directories at depth $depth"]);
    }

    return unless $dir;
    if (@$includeDirs)
    {
	my $ignore = 1;

	if (exists $$include{$dir})        # if directly
	{                                  # an included dir
	    $ignore = 0;
	}
	else
	{
	    my $i;
	    foreach $i (@$includeDirs)
	    {
		$i = &::absolutePath($i);
		if (&::isSubDir($dir, $i))   # on the way to includeDir
		{
		    # get all and only includeDirs to which I'm on the way
		    my (%yetGot) = ();       # avoid duplicates
		    my $id;
		    foreach $id (@$includeDirs)
		    {
			my $id = &::absolutePath($id);
			next
			    unless &::isSubDir($dir, $id);

			my $next = &::substractPath($id, $dir);
			($next) = split(/\/+/, $next);
			if ($dir eq '/')
			{
			    $next = "/$next";
			}
			else
			{
			    $next = $dir . '/' . $next;
			}
			next if exists $yetGot{$next};

			$yetGot{$next} = $next;
			push @$files, $next;
			push @$types, 'd';
			push @$dirs, $next;
			push @$depths, ($depth + 1);
		    }
		    last;
		}
		elsif (&::isSubDir($i, $dir))   # inside includDir
		{
		    $ignore = 0;
		    last;
		}
	    }
	}

	return if $ignore;
    }

    local *DIR;
    unless (opendir(DIR, $dir))
    {
	if ($ignoreReadError eq 'no')
	{
	    $prLog->print('-kind' => $prLogErr,
			  '-str' =>
			  ["cannot opendir <$dir>, exiting",
			   "check your source and clean your backup!"],
			  '-exit' => $exit);
	}
	elsif ($ignoreReadError eq 'onlyPrintMessage')
	{
	    $prLog->print('-kind' => $prLogErr,
			  '-str' => ["cannot opendir <$dir>"]);
	    return;
	}
	else
	{
	    return;
	}
    }

    my $entry;
    my @notPlainFiles;
    while ($entry = readdir DIR)
    {
	next if ($entry eq '.' or $entry eq '..');
	$entry = $dir . '/' . $entry;
	if (-l $entry)
	{
	    if ($self->{'followLinks'} > $depth and
               -d "$entry/.")
	    {
		if (exists $$except{&::absolutePath($entry)})
		{
		    $prLog->print('-kind' => 'I',
				  '-str' => ["ignoring directory <$entry>"])
			if $self->{'verbose'};
		    push @$files, $entry;
		    push @$types, 'd';
		    next;
		}
		push @$files, $entry;
		push @$types, 'd';
		push @$dirs, $entry;
		push @$depths, ($depth + 1);
	    }
	    else
	    {
		push @$files, $entry;
		push @$types, 'l';
	    }
	    next;
	}
	unless (-r $entry)
	{
	    $prLog->print('-kind' => $prLogWarn,
			  '-str' => ["no permissions to read <$entry>"]);
	    next;
	}
	if (-d $entry)       # Dieses Directory muß beim Kopieren
	{                      # z.B. muß angelegt werden!
	    push @$files, $entry;
	    push @$types, 'd';
	    next if exists $$except{&::absolutePath($entry)};
	    push @$dirs, $entry;
	    push @$depths, ($depth + 1);
	    next;
	}
	if (-f $entry)
	{
	    push @$files, $entry;
	    push @$types, 'f';
	    next;
	}
	if (-p $entry)      # named pipe
	{
	    push @$files, $entry;
	    push @$types, 'p';
	    next;
	}
	if (-S $entry)      # socket
	{
	    push @$files, $entry;
	    push @$types, 'S';
	    next;
	}
	if (-b $entry)      # block special file
	{
	    push @$files, $entry;
	    push @$types, 'b';
	    next;
	}
	if (-c $entry)      # character special file
	{
	    push @$files, $entry;
	    push @$types, 'c';
	    next;
	}
	$prLog->print('-kind' => $prLogWarn,
		      '-str' => ["unsupported file type for <$entry>"]);
    }

    closedir DIR;
}


############################################################
# Löscht directories, liefert Anzahl Dateien und Größe zurück
package recursiveDelDir;


########################################
sub new
{
    my $class = shift;
    my $self = {};

    my (%params) = ('-dir'   => undef,     # einzelne Datei ist auch möglich
		    '-prLog' => undef);

    &::checkObjectParams(\%params, \@_, 'recursiveDelDir::new',
			 ['-dir', '-prLog']);
    $self->{'prLog'} = $params{'-prLog'};

    $self->{'dirs'} = 0;         # hier wurde ein Directory gelöscht
    $self->{'files'} = 0;        # hier wurde eine Datei gelöscht
    $self->{'bytes'} = 0;        # hier wurde eine Datei gelöscht,
                                 # Datei hatte entsprechend bytes
    $self->{'links'} = 0;        # hier wurde nur ein Link weggenommen
    $self->{'stayBytes'} = 0;    # hier wurde nur ein Link weggenommen
                                 # Anzahl Bytes bleiben bestehen
    my $dir = $params{'-dir'};

    my $ret = bless $self, $class;
    if (-d $dir and not -l $dir)  # ist ein Directory
    {
	$self->_oneDir($dir);
    }
    else
    {
	$self->_delFile($dir, $self->{'prLog'});
    }

    return $ret;
}


########################################
sub getStatistics
{
    my $self = shift;

    return ($self->{'dirs'},
	    $self->{'files'},
	    $self->{'bytes'},
	    $self->{'links'},
	    $self->{'stayBytes'});
}


########################################
sub _oneDir
{
    my $self = shift;

    my ($aktDir) = shift;

    my $prLog = $self->{'prLog'};

    unless (-w $aktDir)
    {
	if (chmod(0700, $aktDir) != 1)
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["no permissions to delete <$aktDir"]);
	    return;
	}
    }

    local *DIR;
    unless (opendir(DIR, $aktDir))
    {
	$prLog->print('-kind' => 'E',
		      '-str' => ["cannot opendir <$aktDir>"]);
	return;
    }
    my ($e, @dirs);
    while ($e = readdir DIR)
    {
	next if ($e eq '.' or $e eq '..');
	$e = "$aktDir/$e";
	push @dirs, $self->_delFile($e, $prLog);
    }
    closedir(DIR) or
	$prLog->print('-kind' => 'E',
		      '-str' => ["cannot closedir <$aktDir>"]);;

    foreach $e (@dirs)
    {
	$self->_oneDir($e);
    }

    unless (rmdir $aktDir)
    {
	$prLog->print('-kind' => 'E',
		      '-str' => ["cannot delete directory <$aktDir>"]);
    }
    else
    {
	++$self->{'dirs'};
    }
}


########################################
sub _delFile
{
    my $self = shift;

    my $e = shift;              # zu löschende Datei
    my $prLog = shift;

    if (-l $e)
    {
	my ($nlink, $size) = (lstat($e))[3,7];
	unless (unlink $e)
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["cannot delete symlink <$e>"]);
	    next;
	}
	if ($nlink == 1)
	{
	    $self->{'bytes'} += $size;
	    ++$self->{'files'};
	}
	else
	{
	    $self->{'stayBytes'} += $size;
	    ++$self->{'links'};
	}
    }
    elsif (-d $e)
    {
	return ($e);
    }
    else
    {
	my ($nlink, $size) = (stat($e))[3,7];
	unless (unlink $e)
	{
	    $prLog->print('-kind' => 'E',
			  '-str' => ["cannot delete <$e>"]);
	    next;
	}
	if ($nlink == 1)
	{
	    $self->{'bytes'} += $size;
	    ++$self->{'files'};
	}
	else
	{
	    $self->{'stayBytes'} += $size;
	    ++$self->{'links'};
	}
    }

    return ();
}


1