#!/usr/bin/perl
###############################################################################
#    Copyright (C) 2002-2204 by Eric Gerbier
#    Bug reports to: gerbier@users.sourceforge.net
#    $Id: afick_archive.pl,v 1.15 2005/02/01 12:32:21 gerbier Exp $
#
#    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 2 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.
#
###############################################################################
# afick_archive is a tool to manage history file and archive directory
#
###############################################################################

use strict;
use warnings;

use English '-no_match_vars';

# debuggging
#use diagnostics;
use Pod::Usage;

# use Data::Dumper;
#use Carp qw(cluck);	# debugging

use Getopt::Long;    # option analysis

use File::Basename;  # for path
my $dirname = dirname($PROGRAM_NAME);
require $dirname . '/afick-common.pl';

###############################################################################
#                     global variables
###############################################################################

my $Version = '0.3';

## no critic (ProhibitPackageVars)
use vars qw( $Verbose );
## use critic

my $EMPTY = q{};
#############################################################
# just display program version
sub version($) {
	my $version = shift @_;
	print "\n";
	print
"afick_archive : another file integrity checker tool for history/archive\nversion $version\n";
	return;
}
#############################################################
# get date of previous run from report file
# and type of run : init, update, compare
sub get_info($) {
	my $fic = shift @_;

	my $date = $EMPTY;
	my $type;
	my $fh_report;
	if ( open $fh_report, '<', $fic ) {
		while (<$fh_report>) {
			if (m/^# Afick \(\S+\) (\w+) /) {
				$type = $1;
			}
			elsif (m/^# last run on (.*) with/) {
				$date = $1;

				# parse date and transform to such as file name
				$date =~ s/://g;
				$date =~ s/ //g;
				$date =~ s/\///g;
				last;
			}
			else {
				next;
			}
		}
		close $fh_report or warning("can not close report $fic : $ERRNO");
	}
	else {
		warning("can not open report $fic : $ERRNO");
	}

	return ( $type, $date );
}

#############################################################
# transform a date in human format
sub human_date($) {
	my $date       = shift @_;
	my $human_date = $EMPTY;

	# date
	my ( $year, $month, $day );

	# time
	my ( $hour, $min, $sec );
	if ( $date =~ m/^(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ ) {
		$year  = $1;
		$month = $2;
		$day   = $3;
		$hour  = $4;
		$min   = $5;
		$sec   = $6;

		$human_date = "$year/$month/$day $hour:$min:$sec";
	}

	return $human_date;
}
#############################################################
# return the list of reports file in archive directory
# sorted by date
sub get_reports_list($) {
	my $archive_dir = shift @_;

	if ( -d $archive_dir ) {
		my $fh_arc;
		if ( opendir $fh_arc, $archive_dir ) {

			# we read reports files form archive directory
			# and sort the list to have them sort from old to last
			my @reports = sort grep /^afick/, readdir $fh_arc;
			closedir $fh_arc
			  or warning("can not close archive directory $archive_dir: $!");
			return @reports;
		}
		else {
			warning("can not open archive directory $archive_dir: $!");
			exit;
		}
	}
	else {
		warning("$archive_dir is not a directory");
		exit;
	}

	# just for perlcritic
	return;
}
#############################################################
# suppress reports from archive directory
# older than $period
sub clean_archive($$) {
	my $period      = shift @_;
	my $archive_dir = shift @_;

	# convert to seconds
	my %hperiod = (
		'd' => 86_400,       # day
		'w' => 604_800,      # week
		'm' => 2_678_400,    # month
	);

	# test for period validity
	my $delai;
	my $scale = 'd';
	if ( $period =~ m/(\d+)(\w?)/ ) {
		$delai = $1;
		$scale = $2;

		# known scale ?
		if ( !exists $hperiod{$scale} ) {
			warning(
				'bad scale format : should be d (day), w (week), m (month)');
			exit;
		}
	}
	else {
		warning(
'bad period format : should be in the form xP, x is a number, P can be d for days, w for weeks, m for months (ex : 2w ask for 2 weeks'
		);
		exit;
	}

	# convert period in seconds
	my $age = $delai * $hperiod{$scale};

	# get current date
	my $current = time;

	# convert to human date
	# and build date in reports format
	## no critic (ProhibitParensWithBuiltins)
	my $limit = reports_date( localtime( $current - $age ) );
	## use critic

	debug("limit : $limit\n");

	my @reports    = get_reports_list($archive_dir);
	my $nb_deleted = 0;
	foreach my $report (@reports) {
		my $report_date = $report;
		$report_date =~ s/^afick\.//;

		if ( $report_date < $limit ) {

			# so we have to remove file
			my $fic = $archive_dir . '/afick.' . $report_date;

			unlink $fic;
			info("remove old reports $fic");
			$nb_deleted++;
		}
		else {

			# reports are sorted, so all others have a date newer than limit
			last;
		}
	}
	info("$nb_deleted reports removed");
	return;
}
#############################################################
# clean history : remove all entry, which does not have a reports
# in archive directory
sub clean_history($$) {
	my $history     = shift @_;
	my $archive_dir = shift @_;

	if ( !$history ) {
		warning('history directive is not set !');
	}
	elsif ( !-f $history ) {
		warning("history $history is not a file");
	}
	else {

		my $fh_hist;
		if ( !open $fh_hist, '<', $history ) {
			warning("can not open history file $history : $!");
		}
		else {
			my @new_history;    # new history file
			my $changes = 0;
			while ( my $ligne = <$fh_hist> ) {
				chomp $ligne;
				if ( $ligne =~ m/^(\d+)\/(\d+)\/(\d+) (\d+):(\d+):(\d+) / ) {
					my $report =
					  $archive_dir . '/afick.' . $1 . $2 . $3 . $4 . $5 . $6;
					if ( -r $report ) {

						# looks good
						push @new_history, $ligne;
					}
					else {

						# reports does not exists any more
						info("remove history line : $ligne");
						$changes++;
					}
				}
				else {

					# bad format
					warning("bad history line : $ligne");
					$changes++;
				}
			}
			close $fh_hist
			  or warning("can not open history file $history : $!");

			if ($changes) {

				#rewrite new history file if necessary
				my $fh_new_hist;
				if ( open $fh_new_hist, '>', $history ) {
					foreach my $line (@new_history) {
						print {$fh_new_hist} $line . "\n";
					}
					close $fh_new_hist
					  or warning("can not close history $history : $ERRNO");
				}
				else {
					warning("can not rewrite $history : $ERRNO");
				}

				info("$changes lines removed from history");
			}
			else {
				info('no lines removed from history');
			}
		}
	}
	return;
}
#############################################################
sub check_date($$$$$) {
	my $expected_date = shift @_;
	my $report_date   = shift @_;
	my $r_txt         = shift @_;
	my $r_init        = shift @_;
	my $r_first       = shift @_;

	my $etat = 0;

	if ($expected_date) {
		if ( $report_date == $expected_date ) {
			${$r_txt} .= ' ok ';
		}
		elsif ( $report_date > $expected_date ) {
			${$r_txt} .= ' strange report ';
			$etat++;
		}
		else {
			${$r_txt} .= " missing report afick.$expected_date";
			$etat++;
		}
	}
	elsif ( ${$r_first} ) {
		${$r_txt} .= ' ok (last run)';
		${$r_first} = 0;
	}
	elsif ( ${$r_init} ) {
		${$r_txt} .= ' ok? (next run is init)';
		${$r_init} = 0;
	}
	else {

		# last run or init
		${$r_txt} .= ' problem (no chaining run)';
	}

	#print "check_date : $txt\n";
	return $etat;
}
#############################################################
# the idea is to check for "holes" in afick's reports
# each report contains date from previous run so we
# can build a chain, from the last one
sub check($) {
	my $archive_dir = shift @_;    # archive directory

	my $expected_date = $EMPTY;    # expected date of report
	my @reports = reverse get_reports_list($archive_dir);

	my $nb_pb = 0;
	my $first = 1;                 # flag for first report
	my $init  = 0;                 # flag for init
	foreach my $report (@reports) {
		my $etat = 0;

		# get run's date of current report from name
		my $report_date = $report;
		$report_date =~ s/^afick\.//;

		my $txt = human_date($report_date) . ' : ';

		my ( $type, $last_run_date ) = get_info("$archive_dir/$report");
		## no critic (ProhibitCascadingIfElse)
		if ( !defined $type ) {

			# not a regular report
			warning("$report is not a regular report : you may remove it");
			next;
		}
		elsif ( $type eq 'init' ) {

			$etat = check_date( $expected_date, $report_date, \$txt, \$init,
				\$first );
			$txt .= ' (but init may masq some changes)';
			$expected_date = $EMPTY;
			$init          = 1;
		}
		elsif ( $type eq 'compare' ) {

			# compare run do not modify database
			# so does not appear in the chain
			info("$txt ok (compare run)");
			next;
		}
		elsif ( $type eq 'update' ) {

			$etat = check_date( $expected_date, $report_date, \$txt, \$init,
				\$first );

			# get previous run date
			if ($last_run_date) {
				$expected_date = $last_run_date;

				#$txt .= ", preceding run is $expected_date";
			}
			else {
				$txt .= ', no date found';
				$etat++;
			}
		}
		else {
			warning("$report : unknown type of action : $type");
			next;
		}
		## use critic

		if ($etat) {
			warning($txt);
			$nb_pb++;
		}
		else {
			info($txt);
		}

	}    # end foreach
	if ($nb_pb) {
		info("$nb_pb problems detected");
	}
	else {
		info('congratulations : no problems detected');
	}

	return;
}
#############################################################
# search for a regex into reports in archive directory
sub search($$) {
	my $archive_dir = shift @_;
	my $regex       = shift @_;

	my @reports  = get_reports_list($archive_dir);
	my $nb_match = 0;
	my $nb_files = 0;
	foreach my $report (@reports) {
		my $fh_report;
		if ( !open $fh_report, '<', "$archive_dir/$report" ) {
			warning("can not open report file $report : $ERRNO");
		}
		else {
			my $found = 0;
			debug("scan $report");
			while (<$fh_report>) {
				if (m/$regex/) {
					chomp;
					info("$report : $_");
					$nb_match++;
					if ( !$found ) {
						$found = 1;
						$nb_files++;
					}
				}
			}
			close $fh_report
			  or warning("can not close report file $report : $ERRNO");
		}
	}
	if ($nb_match) {
		info("$nb_match lines founds in $nb_files files");
	}
	else {
		info("no line found matching $regex");
	}

	return;
}
#############################################################
#                          main
#############################################################

my $default_config_file = get_default_config();

$OUTPUT_AUTOFLUSH = 1;

# variables for parameter analysis
my $configfile;    # config file name
my $opt_help;
my $opt_man;
my $opt_version;
my $opt_check;
my $opt_clean_history;
my $opt_keep;
my $opt_search;

Getopt::Long::Configure('no_ignore_case');
if (
	!GetOptions(

		# options
		'config_file|c=s' => \$configfile,
		'check|C'         => \$opt_check,
		'clean_history|H' => \$opt_clean_history,
		'keep|k=s'        => \$opt_keep,
		'search|s=s'      => \$opt_search,
		'help|h'          => \$opt_help,
		'man'             => \$opt_man,
		'version|V'       => \$opt_version,
		'verbose|v'       => \$Verbose,
	)
  )
{
	pod2usage('incorrect option');
}

# this options can be treated as soon as possible
if ($opt_help) {

	# -h : help
	pod2usage(1);
}
elsif ($opt_man) {
	pod2usage( -verbose => 2 );
}
elsif ($opt_version) {

	# -V : version
	version($Version);
	exit;
}

# do we have a configuration file ?
if ( !$configfile ) {
	if ( -e $default_config_file ) {
		$configfile = $default_config_file;
	}
	else {

		pod2usage(
"abort : missing configfile name (-c flag) and default config file $default_config_file\n"
		);
	}
}

# get old config from, to be able to check new aliases/rules
my %macros;
my %alias = get_default_alias();
my %directive;
my %rules;
my %onlydir;

get_configuration( $configfile, \%macros, \%alias, \%directive, \%rules,
	\%onlydir );

# get archive directory
my $archive_dir = $directive{archive};
if ( !$archive_dir ) {
	warning('archive directory is not set !');
	exit;
}
my $history = $directive{history};

# treat others options
## no critic (ProhibitCascadingIfElse)
if ($opt_check) {
	check($archive_dir);
}
elsif ($opt_keep) {
	clean_archive( $opt_keep, $archive_dir );
	if ($opt_clean_history) {
		clean_history( $history, $archive_dir );
	}
}
elsif ($opt_clean_history) {
	clean_history( $history, $archive_dir );
}
elsif ($opt_search) {
	search( $archive_dir, $opt_search );
}
else {
	pod2usage(1);
}
## use critic

__END__


=head1 NAME

afick_archive - a tool to manage history file and archive directory

=head1 DESCRIPTION

C<afick_archive> is designed to manage afick's archives reports.
It allow to suppress old reports, check reports consistency, and search 
for informations in reports.

=head1 SYNOPSIS

afick_archive.pl  [L<options|options>]

=head1 REQUIRED ARGUMENTS

one of the 3 actions is mandatory (check, keep, search) (see below)

=head1 OPTIONS

options are used to control afickconfig

=over 4

=item B<--config_file|-c configfile>

read the configuration in config file named "configfile".

=item B<--help|-h>

Output summary help information and exit.

=item B<--man>

Output full help infomation and exit

=item B<--version|-V>

Output version information and exit.

=item B<--verbose|-v>

add debugging messages

=item B<--check|-C>

check consistency in archives : check if a report is missing

=item B<--search|-s regex>

regex is a regular expression to search in all reports, for exemple : "changed file :.*\.pl$"
(search all changed perl files)

=item B<--keep|-k age>

with age in the form xP, x un number, P can be d for days, w for weeks, m for months (ex : 2w ask for 2 weeks)

the software will remove all reports older than the specified period from archive directory.

=item B<--clean_history|-H>

clean history file : remove line matching removed reports

=back

=head1 EXAMPLES

Check archive consistency

C<afick_archive.pl --check>

Remove reports older than 2 months

C<afick_archive.pl --keep 2m>

Search all changed perl files

C<afick_archive.pl --search "changed file :.*\.pl$">

=head1 USAGE

=head1 NOTES

this program only use perl and its standard modules.

=head1 SEE ALSO

=for html
<a href="afick.conf.5.html">afick.conf(5)</a> for the configuration file syntaxe
<a href="afick-tk.1.html">afick-tk(1)</a> for the graphical interface
<a href="afick.1.html">afick(1)</a> for the command-line interface
<a href="afickonfig.1.html">afickonfig(1)</a> for a tool to change afick's configuration file

=for man
\fIafick.conf\fR\|(5) for the configuration file syntaxe
.PP
\fIafick\-tk\fR\|(1) for the graphical interface
.PP
\fIafick\fR\|(1) for the command-line interface
.PP
\fIafickonfig\fR\|(1) for a tool to change afick's configuration file

=head1 DIAGNOSTICS

=head1 EXIT STATUS

=head1 CONFIGURATION

this program uses the afick's configuration file

=head1 DEPENDENCIES

=head1 INCOMPATIBILITIES

=head1 BUGS AND LIMITATIONS

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2002 Eric Gerbier
All rights reserved.

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 2 of the License, or (at your option)
any later version.

=head1 AUTHOR

Eric Gerbier

you can report any bug or suggest to gerbier@users.sourceforge.net
