/dirvish_1_3_ds/dirvish-locate.pl

#!/usr/bin/perl
# dirvish-locate
# 1.3.X series
# Copyright 2005 by the dirvish project
# http://www.dirvish.org
#
# Last Revision   : $Rev: 650 $
# Revision date   : $Date: 2009-02-04 16:09:41 +0100 (Mi, 04 Feb 2009) $
# Last Changed by : $Author: tex $
# Stored as       : $HeadURL: https://secure.id-schulz.info/svn/tex/priv/dirvish_1_3_1/dirvish-locate.pl $
#
#########################################################################
#                                                         				#
#	Licensed under the Open Software License version 2.0				#
#                                                         				#
#	This program is free software; you can redistribute it				#
#	and/or modify it under the terms of the Open Software				#
#	License, version 2.0 by Lauwrence E. Rosen.							#
#                                                         				#
#	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 Open Software License for details.				#
#                                                         				#
#########################################################################
#
#----------------------------------------------------------------------------
# Revision information
#----------------------------------------------------------------------------
my %CodeID = (
    Rev    => '$Rev: 650 $'     ,
    Date   => '$Date: 2009-02-04 16:09:41 +0100 (Mi, 04 Feb 2009) $'    ,
    Author => '$Author: tex $'  ,
    URL    => '$HeadURL: https://secure.id-schulz.info/svn/tex/priv/dirvish_1_3_1/dirvish-locate.pl $' ,
);

$VERSION =   $CodeID{URL};
$VERSION =~  s#^.*dirvish_##;  # strip off the front
$VERSION =~  s#\/.*##;         # strip off the rear after the last /
$VERSION =~  s#[_-]#.#g;       # _ or - to "."

#----------------------------------------------------------------------------
# Modules and includes
#----------------------------------------------------------------------------
use strict;
use warnings;

use Time::ParseDate;
use POSIX qw(strftime);
use Getopt::Long;
use Dirvish;

#----------------------------------------------------------------------------
# SIG Handler
#----------------------------------------------------------------------------
$SIG{TERM} = \&sigterm; # handles "kill <PID>"
$SIG{INT} = \&sigterm; # handles Ctrl+C or "kill -2 <PID>"

#----------------------------------------------------------------------------
# Initialisation
#----------------------------------------------------------------------------
my $KILLCOUNT = 1000;
my $MAXCOUNT = 100;

my $Options = reset_options( \&usage, @ARGV);	# initialize the %$Options hash
load_master_config('f', $Options);				# load master config into $Options

GetOptions($Options, qw(
    version
    help|?
    )) or &usage();

my $Vault = shift;
my $Branch = undef;
$Vault =~ /:/ and ($Vault, $Branch) = split(/:/, $Vault);
my $Pattern = shift;

$Vault && length($Pattern) or &usage();
# prepend dot if asterisk or question mark is
# the first character. Make rsync-like patterns like *.xml work
$Pattern = ".".$Pattern if($Pattern =~ m/^(\*|\?)/);

my $fullpattern = $Pattern;
my $partpattern = undef;
$fullpattern =~ /\$$/ or $fullpattern .= '[^/]*$';
($partpattern = $fullpattern) =~ s/^\^//;

my $bank = undef;
for $b (@{$$Options{bank}})
{
    -d "$b/$Vault" and $bank = $b;
}
$bank or seppuku 220, "No such vault: $Vault";

opendir VAULT, "$bank/$Vault" or seppuku 221, "cannot open vault: $Vault";
my @invault = readdir(VAULT);
closedir VAULT;

my @images = ();
for my $image (@invault)
{
    $image eq 'dirvish' and next;
    my $imdir = "$bank/$Vault/$image";
    -f "$imdir/summary" or next;
    (-l $imdir && $imdir =~ /current/) and next; # skip current-symlink
    my $conf = loadconfig('R', "$imdir/summary", $Options) or next;
    $$conf{Status} eq 'success' || $$conf{Status} =~ /^warn/
        or next;
    $$conf{'Backup-complete'} or next;
    $Branch && $$conf{branch} ne $Branch and next;
	
    unshift @images, {
        imdir   => $imdir,
        image   => $$conf{Image},
        branch  => $$conf{branch},
        created => $$conf{'Backup-complete'},
    }
}

my $imagecount = 0;
my $pathcount = 0;
my $path = undef;
my %match = ();
for my $image (sort(imsort_locate @images))
{
    my $imdir = $$image{imdir};

    my $index = undef;
    -f "$imdir/index.bz2" and $index = "bzip2 -d -c $imdir/index.bz2|";
    -f "$imdir/index.gz" and $index = "gzip -d -c $imdir/index|";
    -f "$imdir/index" and $index = "<$imdir/index";
    $index or next;

    ++$imagecount;

	# can't use three-fold open here, see above
    open(INDEX, $index) or next;
    while (<INDEX>)
    {
        chomp;

        m($partpattern) or next;
		# this parse operation is too slow.  It might be faster as a
		# split with trimmed leading whitespace and remerged modtime
        my $f = { image => $image };
        (
             $$f{inode},
            $$f{blocks},
            $$f{perms},
            $$f{links},
            $$f{owner},
            $$f{group},
            $$f{bytes},
            $$f{mtime},
            $path
        ) = m<^
            \s*(\S+)        # inode
            \s+(\S+)        # block count
            \s+(\S+)        # perms
            \s+(\S+)        # link count
            \s+(\S+)        # owner
            \s+(\S+)        # group
            \s+(\S+)        # byte count
            \s+(\S+\s+\S+\s+\S+)    # date
            \s+(\S.*)        # path
        $>x;
        $$f{perms} =~ /^[dl]/ and next;
        $path =~ m($fullpattern) or next;

        exists($match{$path}) or ++$pathcount;
        push @{$match{$path}}, $f;
    }
    if ($pathcount >= $KILLCOUNT)
    {
        print "dirvish-locate: too many paths match pattern, interrupting search\n";
        last;
    }
}

printf "%d matches in %d images\n", $pathcount, $imagecount;

$pathcount >= $MAXCOUNT
    and printf "Pattern '%s' too vague, listing paths only.\n", $Pattern;

my $last = undef;
my $linesize = 0;
for my $path (sort(keys(%match)))
{
    $last = undef;
    print $path;

    if ($pathcount >= $MAXCOUNT)
    {
        print "\n";
               next;
    }

    for my $hit (@{$match{$path}})
    {
        my $inode = $$hit{inode};
        my $mtime = $$hit{mtime};
        my $image = $$hit{image}{image};
        if (defined($last) && $inode ne $last)
        {
            $linesize = 5 + length($mtime) + length($image);
            printf "\n    %s %s", $mtime, $image;
        } else {
            $linesize += length($image) + 2;
            if ($linesize > 78)
            {
                $linesize = 5 + length($mtime) + length($image);
                print "\n",
                    " " x (5 + length($mtime)),
                    $image;
            } else {
                printf ", %s", $$hit{image}{image};
            }
        }
        $last = $inode;
    }
    print "\n\n";
}

exit 0;
#----------------------------------------------------------------------------
# Subs
#----------------------------------------------------------------------------
# Sort images
sub imsort_locate {
	## WARNING:  don't mess with the sort order, it is needed so that if
	## WARNING:  all images are expired the newest will be retained.
	$$a{branch} cmp $$b{branch}
	  || $$a{created} cmp $$b{created};
}
sub usage
{
    my $message = shift(@_);

    length($message) and print STDERR $message, "\n\n";

    print STDERR <<EOUSAGE;
USAGE
	dirvish-locate vault[:branch] pattern
	
	Pattern can be any PCRE.
	
EOUSAGE
	exit 255;
}
# Handle SIGTERM (SIG-15)
sub sigterm
{
	print STDERR "Received SIGTERM. Aborting running backup ...";
	# kill childs - kill(TERM, -$$):
	use POSIX;
	my $cnt = kill(SIGTERM, -$$);
	no POSIX;
	print STDERR "Signaled $cnt processes in current processgroup";
	# quit
	exit;
}
#----------------------------------------------------------------------------
# EOF
#----------------------------------------------------------------------------