#!/usr/bin/perl
########################################################
#
# This script is intended to provide a means for
# detecting changes made to files, via a regular
# comparison of MD5 hashes and others properties
# to an established "database".
# In this respect, it is designed as a portable clone
# of tripwire or aide softwares.
#
# This script requires perl ,and some others perl modules
# which come in standard installation
#
###############################################################################
#    Copyright (C) 2002-2004 by Eric Gerbier
#    Bug reports to: gerbier@users.sourceforge.net
#    $Id: afick.pl 1269 2009-01-16 12:53:29Z gerbier $
#
#    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.
#
###############################################################################
# I use special naming for references :
# $r_name : for a ref to scalar
# $rh_name : for a ref to hashes
# $ra_name : for a ref to array
# global variables begin with an uppercase
###############################################################################
#                         perl modules and libraries
###############################################################################

use strict;
use warnings;

#use diagnostics;
use English '-no_match_vars';

#use Data::Dumper;	for debugging

use Pod::Usage;
use Digest::MD5;    # for md5 checksum

# !! can also use Digest::SHA1 if exists: see below

use Fcntl qw( :flock :DEFAULT );    # to get F_* and O_* LOCK_* constants

use FileHandle;                     # for database open mode
use Getopt::Long;                   # arg analysis
use Cwd 'abs_path';                 # convert to absolute path

use File::Glob ':glob';             # for jokers
use File::Basename;                 # for delete

# !!! Win32::FileSecurity is used too (on windows)

# afick library
my $dirname = dirname($PROGRAM_NAME);
require $dirname . '/afick-common.pl';

###############################################################################
# constants
###############################################################################
## no critic (ProhibitConstantPragma,ProhibitEmptyQuotes,ProhibitNoisyQuotes)
use constant LF    => "\n";
use constant EMPTY => '';
use constant SLASH => '/';

use constant Progres => 'progress';

# database extension for default SDBM database type (see get_database_ext)
my $Database_ext;

my $Database_idx;    # database index
use constant Control_ext => '.ctr';    # database control file

{

	# index hash for internal info
	my %Id = (
		'md5'      => 0,
		'checksum' => 0,
		'device'   => 1,
		'inode'    => 2,
		'filemode' => 3,
		'links'    => 4,
		'uid'      => 5,
		'acl'      => 6,    # acl data are same than gid
		'gid'      => 6,
		'filesize' => 7,
		'blocs'    => 8,
		'atime'    => 9,
		'mtime'    => 10,
		'ctime'    => 11,
		'sha1'     => 12,
		'unused1'  => 13,
	);

	sub get_id($) {
		my $key = shift @_;

		if ( defined $key ) {
			return $Id{$key};
		}
		else {
			return \%Id;
		}
	}
}
{

	# array of field names for report
	my @Field = (
		'md5       ',    # 0
		'device    ',    # 1
		'inode     ',    # 2
		'filemode ',     # 3
		'links     ',    # 4
		'uid       ',    # 5
		'gid/acl   ',    # 6
		'filesize  ',    # 7
		'blocs     ',    # 8
		'atime     ',    # 9
		'mtime     ',    # 10
		'ctime     ',    # 11
		'sha1      ',    # 12
	);

	sub get_field($) {
		my $idx = shift @_;

		if ( defined $idx ) {
			return $Field[$idx];
		}
		else {
			return \@Field;
		}
	}
}

# database internal separator
# for join
use constant Sep => '|';

# for split
my $Sepmeta = quotemeta Sep;

# for windows acl
my $Sepacl = ',';

#use constant Sepacl => ',';

# comment non-changes lines
use constant Comment => '#';

# masq to force strict file permissions (rw by owner)
use constant Strict_perm => oct 600;

###############################################################################
#                     global variables
###############################################################################
# almost all begin with a first upper-case character

my $Version = '2.13-1';

# for afick-common
## no critic (ProhibitPackageVars)
use vars qw($Verbose);

# temporary, values can be shared to be used by read_configuration (afick.pl)
use vars qw($debug_def $warn_dead_symlinks_def  $report_full_newdel_def
  $warn_missing_file_def  $running_files_def $timing_def $follow_symlinks_def
  $allow_overload_def $ignore_case_def $max_checksum_size_def
  $exclude_prefix_def $exclude_suffix_def $exclude_re_def $only_suffix_def
  $archive_def $history_def $verbose_def $report_url_def $report_syslog_def
);
## use critic

# database type
# why this one ? : because it was the only one common to all my operating systems
# XP (activeperl), redhat, debian, mandrake
my $Dbm;

my %Finded   = ();    # list of scanned files
my %Hashfile = ();    # hash-table tied to database
my %Newfiles = ();    # list of new files
my %Dangling = ();    # dangling links
my %Toscan   = ();    # list of files to scan
my %Onlydir  = ();    # only this and content, without sub-dir
my %Onlythis = ();    # only this inode
my %Oldval   = ();    # store old values
my %Newval   = ();    # store new changes values
my %Control  = ();    # list of auto-control files (can not be excluded)

my %Macros     = ();  # hash-table of macros
my %Aliases    = ();  # hash-table of alias
my %Rules      = ();  # hash-table of rules
my %Directives = ();  # hash-table of directives

my $Nbmod  = 0;       # number of modifications
my $Update = 0;       # distinguish update (1) and compare mode (0)
my $File   = 0;       # distinguish file mode (1) from update/compare (0)
my $Real_time;        # real-time mode

# directives status
# not initialized to be able to detect negative command lines
my (
	$Warn_dead_symlinks,    # warn about dead symlink ?
	$Report_full_newdel,    # report new and del directories contents ?
	$Warn_missing_file
	,            # report about files in configuration file, but not installed ?
	$Report_url, # output device
	$Report_syslog,        # report to syslog or not
	$Progress,             # show progress (for use with tk interface)
	$Timing,               # show cpu statistics ?
	$Running,              # show changed files during scan ?
	$Ignore_case,          # ignore case ?
	$History,              # path to history file
	$Archive,              # path to archive directory
	$Follow_symlinks,      # do checksum on link or on name
	$Allow_overload,       # allow rules overload
	                       #$Output_format,        # not used yet
	$Debug_level,          # debuging level from 0 (none) to 4 (full)
	$Database,             # database name
	$Max_checksum_size,    # max file size for a complete checksum
	$Sufx,                 # list of suffix to exclude
	$Prefx,                # list of prefix to exclude
	$Exclude_re,           # list of regular expression to exclude
	$OnlySufx,             # list of suffix to only search for
);

# patterns for exclude
my $SufxPat     = EMPTY;
my $PrefxPat    = EMPTY;
my $ExRePat     = EMPTY;
my $OnlySufxPat = EMPTY;

# file descriptor to archive directory
my $Archive_df;

# alias table
# contains pre-defined values
my %Alias = get_default_alias();

my $Acl_exist;    # flag on Win32 perl module
my @Date;         # date of begin
my $Date;         # same in strftime format

# counters for excluded files/dir
my $Nb_exclude_sufx  = 0;
my $Nb_exclude_prefx = 0;
my $Nb_exclude_re    = 0;
my $Nb_degraded      = 0;

###############################################################################
#                    default parameter config
###############################################################################
sub get_report_url() {
	return $Report_url || $report_url_def;
}
#######################################################
sub get_debug_level() {
	return $Debug_level || $debug_def;
}
#######################################################
sub get_exclude_sufx() {
	return $Sufx || $exclude_suffix_def;
}
#######################################################
sub get_exclude_prefx() {
	return $Prefx || $exclude_prefix_def;
}
###############################################################################
sub get_exclude_re() {
	return $Exclude_re || $exclude_re_def;
}
#######################################################
sub get_only_sufx() {
	return $OnlySufx || $only_suffix_def;
}
###############################################################################
#                     subroutines
###############################################################################
# a general low-level methode to access database data
sub get_data($$) {

	my $name  = shift @_;    # file name
	my $field = shift @_;    # field name

	if ( !get_id($field) ) {
		warning("(get_data) bad index $field");
		return;
	}

	my $hash = $Hashfile{$name} || $Newval{$name} || EMPTY;
	my @tab = split_record($hash);
	return $tab[ get_id($field) ];
}
###############################################################################
# convert a tab into hash
# to be used by filter in print_dbm to access info
sub tab2hash($) {

	my $name = shift @_;    # file name

	my $info = $Hashfile{$name} || $Newval{$name} || EMPTY;
	my @tab = split_record($info);
	my %hash;
	foreach my $key ( keys %{ get_id(undef) } ) {
		$hash{$key} = $tab[ get_id($key) ];
	}

	# add other infos
	$hash{'name'}     = $name;
	$hash{'filetype'} = file_type($name);

	return \%hash;
}
#######################################################
# get checksum from database
sub get_md5 ($) {
	my $name = shift @_;    # file name

	return get_data( $name, 'md5' );
}
#######################################################
# get file mode from database
sub get_filemode ($) {
	my $name = shift @_;    # file name

	return get_data( $name, 'filemode' );
}
#######################################################
# get file size from database
sub get_filesize ($) {
	my $name = shift @_;    # file name

	return get_data( $name, 'filesize' );
}
#######################################################
# get inode date from database
sub get_ctime ($) {
	my $name = shift @_;    # file name

	return get_data( $name, 'ctime' ) || 0;
}
#######################################################
# get inode date from database
sub get_mtime ($) {
	my $name = shift @_;    # file name

	return get_data( $name, 'mtime' ) || 0;
}
#######################################################
# low-level sub to check a file type with macros from Fcntl
sub is_type($$) {
	my $p    = shift @_;
	my $flag = shift @_;
	return ( ( $p & $flag ) == $flag );
}
#######################################################
# get file_type from database
sub file_type ($) {
	my $name = shift @_;    # file name

	# $Hashfile for changed file
	# Newval in compare mode for new files
	my $hash;
	if ( exists $Hashfile{$name} ) {
		$hash = $Hashfile{$name};
	}
	elsif ( exists $Newval{$name} ) {
		$hash = $Newval{$name};
	}
	else {
		warning("(file_type) problem on $name");
		return 'unknown_type';
	}

	my @tab = split_record($hash);
	my $perm = $tab[ get_id('filemode') ] || 0;

	my $type;

	# order of test is important for the first test !
	## no critic (ProhibitCascadingIfElse)
	if ( S_ISSOCK($perm) ) {
		$type = 'socket';
	}
	elsif ( S_ISLNK($perm) ) {
		$type = 'symbolic_link';
	}
	elsif ( S_ISREG($perm) ) {
		$type = 'file';
	}
	elsif ( S_ISBLK($perm) ) {
		$type = 'block_device';
	}
	elsif ( S_ISDIR($perm) ) {
		$type = 'directory';
	}
	elsif ( S_ISCHR($perm) ) {
		$type = 'character_device';
	}
	elsif ( S_ISFIFO($perm) ) {
		$type = 'fifo';
	}
	else {
		$type = 'unknown_type';
	}
	## use critic
	return $type;
}
#######################################################
# low-level sub to send "normal" messages
sub report($;$$) {
	my $text            = shift @_;
	my $syslog_priority = shift @_ || 'notice';
	my $url             = shift @_ || get_report_url();

	#add line feed
	$text .= LF;

	# 1 output
	## no critic (TestingAndDebugging);
	# because get_report_url does not return a file handler
	no strict 'refs';
	print {$url} $text if ( $url ne 'null' );
	## use critic

	if ( !is_progress($text) ) {

		# 2 archive
		print {$Archive_df} $text if ($Archive_df);

		# syslog
		my_syslog( $syslog_priority, $text );
	}
	return;
}
#######################################################
# high-level sub for summary messages
sub report_summary($$) {
	my $type     = shift @_;    # new, change, deleted, dangling ...
	my $filename = shift @_;    # file name

	my $filetype = file_type($filename);

	report("$type $filetype : $filename");
	return;
}
#######################################################
# high-level sub for detailed messages
sub report_detailed($$;$) {
	my $field = shift @_;       # field name
	my $val1  = shift @_;       # old value
	my $val2  = shift @_;       # new value (optionnal)

	my $txt = "\t$field\t\t : $val1";
	$txt .= "\t$val2" if ( defined $val2 );

	report($txt);
	return;
}
#######################################################
sub crlf() {
	report(LF);
	return;
}
#######################################################
# print a commented line
sub info($) {
	report( Comment . " @_" );
	return;
}
#######################################################
# for progress purpose
sub progress($) {
	if ($Progress) {
		report( Progres . " @_" );
	}
	return;
}
#######################################################
# is this line a progress line
sub is_progress($) {
	my $text = shift @_;
	return ( index( $text, Progres ) == 0 );
}
#######################################################
# for debug purpose
sub debug($;$) {
	my $txt = shift @_;
	my $level = shift @_ || 3;

	report("DEBUG$level: $txt")
	  if ( ($Verbose) or ( $level <= get_debug_level() ) );
	return;
}
#######################################################
# to get full info from caller line
sub get_caller(;$) {
	my $level = shift @_ || 1;
	my (
		$package, $filename, $line, undef, undef,
		undef,    undef,     undef, undef, undef
	) = caller $level++;
	my (
		undef, undef, undef, $subroutine, undef,
		undef, undef, undef, undef,       undef
	) = caller $level;
	$subroutine = $subroutine || 'main';
	return "${subroutine}($filename $line)";
}

#######################################################
# to be used to track subroutine use
# use debug level 4
sub debug_begin(;$) {
	my $text = shift @_ || EMPTY;
	debug( 'begin ' . get_caller() . " $text", 4 );
	return;
}
#######################################################
# to be used to track subroutine use
# use debug level 4
sub debug_end(;$) {
	my $text = shift @_ || EMPTY;
	debug( 'end ' . get_caller() . " $text", 4 );
	return;
}
#######################################################
sub warning($) {
	my $text = shift @_;

	report( "WARNING: $text", 'warning', 'STDERR' );
	return;
}

#######################################################
# to allow clean exit
## no critic (RequireFinalReturn);
sub my_die($) {
	my $text = shift @_;

	my $msg = "ABORT: $text" . LF;
	if ($Archive_df) {
		print {$Archive_df} $msg;
		close_archive();
	}

	## no critic (RequireCarping)
	die $msg;
}
## use critic

#######################################################
# to write on history file
sub history($) {
	my $txt = shift @_;
	chomp $txt;

	if ($History) {

		# add a summary on history file
		my $fh_hist;
		if ( open $fh_hist, '>>', $History ) {
			print {$fh_hist} "$Date  $txt" . LF;
			close $fh_hist
			  or
			  warning("(history) can not close $History history file : $ERRNO");
		}
		else {
			warning(
				"(history) can not write to $History history file : $ERRNO");
		}
	}
	return;
}
#######################################################
# lock a file
# exit if a file is already locked (do not wait)
# the goal is to avoid any access during a database write (init or update)
#
# database type (SDBM, GDBM) do not offer a common generic way to lock
# and using a classic flock on the database is not compatible with GDBM
# (which need a specific code, see DF_File doc)
# so the last way is to use a temporary file : .lock

{

	# to store lock name
	my $stored_lock_name = EMPTY;

	sub set_lock_name($) {
		$stored_lock_name = shift @_;
		debug( "(set_lock_name) lock_name=$stored_lock_name", 1 );
		return;
	}

#######################################################
	sub get_lock_name() {
		return $stored_lock_name;
	}

	my $fh_lock;

#######################################################
	sub my_lock($$) {
		my $name      = shift @_;    # base name to lock
		my $lock_type = shift @_;    # should be LOCK_EX or LOCK_SH

		my $lock_ext = '.lock';

		my $lock_name = $name . $lock_ext;
		set_lock_name($lock_name);

		# create a dummy empty file
		## no critic (RequireBriefOpen)
		if ( !open $fh_lock, '>', $lock_name ) {
			my_die("(my_lock) can not open $name : $ERRNO");
		}

		# not blocking lock
		if ( !flock $fh_lock, $lock_type | LOCK_NB ) {
			my_die("already locked file $name : $ERRNO");
		}

		# set as an exception to avoid warnings
		$Toscan{ to_abspath($lock_name) } = 0;
		return;
	}
#######################################################
	# unlock file
	sub my_unlock() {

		my $lock_name = get_lock_name();
		if ( -f $lock_name ) {

			# unlock
			flock $fh_lock, LOCK_UN;
			close $fh_lock
			  or warning("can not close lock file $lock_name : $ERRNO");

			# remove temporary file
			unlink $lock_name;
			debug( "(my_unlock) lock_name=$lock_name", 1 );
		}
		return;
	}
#######################################################
	sub my_islock() {

		my $lock_name = get_lock_name();
		return ( -f $lock_name );
	}
}
#######################################################
## no critic (RequireFinalReturn);
sub signal_handler {

	# 1st argument is signal name
	my ($sig) = @_;

	# first close database "clean"
	# todo : get database name and test if it is open
	close_database() if ( my_islock() );

	# then exit with a warning
	my_die("Caught a SIG$sig--shutting down");
}
## use critic

#######################################################
# print run conditions
sub print_env ($$) {
	my $action     = shift @_;
	my $configfile = shift @_;

	info("Afick ($Version) $action at $Date with options ($configfile):");

	# only show set directives
	foreach my $elem ( get_list_dir(0) ) {
		info($elem);
	}
	return;
}
#######################################################
# print last run date and version
sub print_last($$) {
	my $run_date    = shift @_;
	my $old_version = shift @_;

	if ( defined $run_date ) {
		info(   'last run on '
			  . $run_date
			  . ' with afick version '
			  . $old_version );
	}
	return;
}
#######################################################
# transform in octal for human
sub print_oct($) {
	my $number = shift @_;

	return sprintf '%lo', $number;
}

#######################################################
# test_double
# to detect bad configuration
sub test_double($) {
	my $elem = shift @_;

	return exists $Toscan{$elem};
}

#######################################################
# test is database library is available
sub test_dbm_available($) {
	my $dbm = shift @_;

	## no critic (StringyEval);
	return eval "require $dbm";
}
#######################################################
# the goal is to find the best available database
# code inspired by AnyDBM_File
## no critic (RequireFinalReturn);
sub get_best_dbm() {

	# this list is sorted from best choice to the worse
	# rem NDBM and ODBM can not be used because they
	# do not implement exist method
	my @list_dbm = qw(GDBM_File SDBM_File DB_File );

	#my @list_dbm = qw(SDBM_File );
	foreach my $mod (@list_dbm) {
		if ( test_dbm_available($mod) ) {
			debug( "(get_best_dbm) the best dbm found is $mod", 2 );
			import $mod;
			return $mod;
		}
	}
	my_die('(get_best_dbm) No DBM package was successfully found or installed');
}
## use critic
#######################################################
# test for a database type
sub test_dbm($) {
	my $dbm = shift @_;

	# 1) is dbm available
	if ( test_dbm_available($dbm) ) {

		# ok : available
		import $dbm;
	}
	else {
		my_die("(test_dbm) database $dbm is not available");
	}

	# 2) is there a better dbm available ?
	my $best_dbm = get_best_dbm();
	if ( $best_dbm ne $dbm ) {
		warning("(test_dbm) a better dbm is available : $best_dbm");
	}
	return;
}
#######################################################
# we need to have the full database name for checksum
{
	my %h_database_ext = (
		GDBM_File => EMPTY,
		SDBM_File => '.pag',
		DB_File   => EMPTY,
	);
	my %h_database_idx = (
		GDBM_File => EMPTY,
		SDBM_File => '.dir',
		DB_File   => EMPTY,
	);

	sub get_database_ext($) {
		my $dbm = shift @_;
		return exists( $h_database_ext{$dbm} ) ? $h_database_ext{$dbm} : EMPTY;
	}

	sub get_database_idx($) {
		my $dbm = shift @_;
		return exists( $h_database_idx{$dbm} ) ? $h_database_idx{$dbm} : EMPTY;
	}
}
#######################################################
# exclude code
# I do not like code duplication (prefix, suffix, regular)
# but I search performance (/o flag on test)
# so there is (bad) ways :
# - a low-level test_exclude sub with common code (see below
#--------------------------------------------------
# sub test_exclude($$$$) {
# 	my $fic        = shift @_;    # file name
# 	my $pattern    = shift @_;    # regular expression
# 	my $r_compteur = shift @_;    # counter for stats
# 	my $text       = shift @_;    # text for debug
#
# 	if ( ($pattern) and ( $fic =~ m/$pattern/ ) ) {
# 		debug( "find excluded $text ($1) in $fic", 2 );
# 		$$r_compteur++;
# 		return 1;
# 	}
# 	else {
# 		return 0;
# 	}
# }
# #######################################################
# # used to exclude suffixes
# sub test_exclude_suffix($) {
# 	my $fic = shift @_;
#
# 	return test_exclude( $fic, $SufxPat, \$Nb_exclude_sufx, 'suffixe' );
# }
# #######################################################
# # used to exclude prefixes
# sub test_exclude_prefix($) {
# 	my $fic = shift @_;
#
# 	return test_exclude( $fic, $PrefxPat, \$Nb_exclude_prefx, 'prefix' );
# }
# #######################################################
# sub test_exclude_re($) {
# 	my $fic = shift @_;
#
# 	return test_exclude( $fic, $ExRePat, \$Nb_exclude_re, 'regular' );
# }
#--------------------------------------------------
# which is nice to see, but slow (impossible to use /o flag :(
# - and to have only one test with all pattern (join all excludes)
# , but file arg is not the same (full path or not), because of prefix/regular
# - 3 subs with a lot of common code :(, but quick
# note : 'advanced perl programming' book gives a tips with code eval
# but it is here impossible to use
#--------------------------------------------------
#######################################################
sub test_only_suffix($) {
	my $fic = shift @_;

	if ( -d $fic ) {

		# we have to recurse on directories
		return 1;
	}
	elsif ( $fic =~ m/$OnlySufxPat/o ) {
		debug( "find only suffix ($1) in $fic", 2 );
		return 1;
	}
	else {
		return 0;
	}
}
#######################################################
# used to exclude suffixes
sub test_exclude_suffix($) {
	my $fic = shift @_;

	if ( ($SufxPat) and ( $fic =~ m/$SufxPat/o ) ) {
		debug( "find excluded suffix ($1) in $fic", 2 );
		$Nb_exclude_sufx++;
		return 1;
	}
	else {
		return 0;
	}
}
#######################################################
# used to exclude prefixes
sub test_exclude_prefix($) {
	my $fic = shift @_;

	if ( ($PrefxPat) and ( $fic =~ m/$PrefxPat/o ) ) {
		debug( "find excluded prefix ($1) in $fic", 2 );
		$Nb_exclude_prefx++;
		return 1;
	}
	else {
		return 0;
	}
}
#######################################################
# used to exclude regex
sub test_exclude_re($) {
	my $fic = shift @_;

	if ( ($ExRePat) and ( $fic =~ m/$ExRePat/o ) ) {
		debug( "find excluded regular ($1) in $fic", 2 );
		$Nb_exclude_re++;
		return 1;
	}
	else {
		return 0;
	}
}
#######################################################
sub is_root($) {
	my $name = shift @_;
	if ( is_microsoft() ) {
		return ( $name =~ m/^[a-zA-Z]:\/$/ );
	}
	else {
		return ( $name eq SLASH );
	}
}
#######################################################
# expand_line
# expand config line : treat jokers, and split into <file attribute flagdir>
sub trait_line ($$$) {
	my $name        = shift @_;
	my $attribute   = shift @_;
	my $ignore_case = shift @_;

	# if ignore_case change all names
	$name = lc $name if ($ignore_case);

	# for compatibility with old syntax
	$attribute = 'all' if ( !$attribute );

	# debug("$name -> $attribute", 1);

	my @tab;
	my $flagdir;    # true if is a directory

	# expand jokers if exists
	if ( $name =~ m/[\*\?]/ ) {
		@tab = glob $name;
		debug( "(trait_line) expand $name in @tab", 2 );
		if ($ignore_case) {
			foreach (@tab) {
				$_ = lc;
			}
		}
	}

	# test for root
	elsif ( is_root($name) ) {
		$flagdir = 1;
		push @tab, $name;
	}
	elsif ( $name =~ m{/$} ) {

		# remove trailing /
		$name =~ s{/$}{};
		$flagdir = 1;
		push @tab, $name;
	}
	else {
		$flagdir = 0;
		push @tab, $name;
	}
	push @tab, $attribute, $flagdir;
	return @tab;
}
#######################################################
# get_names
# used by auto_control to know which program names to control
sub get_names($) {
	my $ignore_case = shift @_;

	# get path from caller
	my $path = dirname($PROGRAM_NAME);

	#my ( $name, $path, undef ) = fileparse($0);

	# add all afick's files
	my $search = abs_path($path) . '/afick*';    # convert in absolute path

	# do not know why, but the glob sub produce a core dump
	# on my linux box (perl-5.8.1-0.RC4.3.3.92mdk)
	# but not the bsd_glob !
	my @list = bsd_glob($search);

	# apply case
	if ($ignore_case) {
		foreach my $elem (@list) {
			$elem = lc $elem;
		}
	}

	debug( "(get_names) list = @list", 3 );

	return @list;
}
#######################################################
# check if config line directive is overloaded by command line option
sub check_overload($$$$$) {
	my $key     = shift @_;    # directive name
	my $val     = shift @_;    # associated value in config file
	my $line    = shift @_;    # config file line string
	my $line_id = shift @_;    # config line number
	my $rh_call = shift @_;    # ref to hash to know if first call

	debug( "(check_overload) $key", 3 );

	my %h_overload = (
		database           => \$Database,
		verbose            => \$Verbose,
		warn_dead_symlinks => \$Warn_dead_symlinks,
		report_full_newdel => \$Report_full_newdel,
		warn_missing_file  => \$Warn_missing_file,
		follow_symlinks    => \$Follow_symlinks,
		allow_overload     => \$Allow_overload,
		report_url         => \$Report_url,
		report_syslog      => \$Report_syslog,
		exclude_suffix     => \$Sufx,
		exclude_prefix     => \$Prefx,
		exclude_re         => \$Exclude_re,
		only_suffix        => \$OnlySufx,
		timing             => \$Timing,
		ignore_case        => \$Ignore_case,
		history            => \$History,
		running_files      => \$Running,
		archive            => \$Archive,
		debug              => \$Debug_level,
		max_checksum_size  => \$Max_checksum_size,
	);

	return unless ( exists $h_overload{$key} );
	my $option = ${ $h_overload{$key} };

	if ( $key =~ m/^exclude/ ) {

		# this directives allow multi-line !!
		debug( '(check_overload) exclude call ' . $rh_call->{$key}, 2 );

		#first call :
		if ( ( $rh_call->{$key} ) and ( defined $option ) ) {
			debug(
"(check_overload) ignore $line (line $line_id) : overload by command line option ($option)",
				2
			);
		}
		else {

			# add new lines
			debug( "(check_overload) add new $key : $val", 2 );
			${ $h_overload{$key} } .= " $val";

			# set to false for next lines
			$rh_call->{$key} = 0;
		}
	}
	else {
		if ( !defined $option ) {
			debug( "(check_overload) found directive $key : $val", 2 );
			${ $h_overload{$key} } = $val;
		}
		else {
			debug(
"(check_overload) ignore $line (line $line_id) : overload by command line option ($option)",
				2
			);
		}
	}

	# special case
	open_syslog() if ( $key eq 'report_syslog' );

	return;
}
#######################################################
# uses by read_configuration
sub config_warning($$$$) {
	my $state   = shift @_;
	my $line    = shift @_;
	my $line_id = shift @_;
	my $text    = shift @_;

	chomp $text;
	warning("$state config file $line (line $line_id), $text");
	return;
}
#######################################################
## no critic (ProhibitManyArgs)
sub addrule($$$$$$) {
	my $elem          = shift @_;    # file name
	my $masqb         = shift @_;    # masq from config file (brut)
	my $masq          = shift @_;    # decoded masq
	my $rliste_toscan = shift @_;
	my $noforce       = shift @_;
	my $force_control = shift @_;    # if true, can not be excluded

	$Rules{$elem}  = $masqb;
	$Toscan{$elem} = $masq;
	push @{$rliste_toscan}, $elem unless ($noforce);
	debug( "(addrule) $elem $masqb $masq $force_control", 3 );

	if ($force_control) {
		$Control{$elem} = 1;
	}
	return;
}
## use critic
#######################################################
# set a default value for parameters
sub set_default($$) {
	my $rvar     = shift @_;
	my $defvalue = shift @_;

	${$rvar} = $defvalue if ( !defined ${$rvar} );
	return;
}
#######################################################
sub make_regex($$$) {
	my $config       = shift @_;
	my $prefix_regex = shift @_;
	my $suffix_regex = shift @_;

	## no critic (ProhibitEmptyQuotes)
	my @tab = split ' ', $config;
	if (@tab) {
		return $prefix_regex . join( Sep, map { "$_" } @tab ) . $suffix_regex;
	}
	else {
		return EMPTY;
	}
}

#######################################################
# read_configuration :
# read the config file to build a list of directory to scan
sub read_configuration($$$$) {
	my $configfile = shift @_;    # config file name
	my $rh_alias   = shift @_;
	my $r_nb_pbs   = shift @_;    # ref to number of problems
	my $clean      = shift @_;    # boolean to

	debug( "(read_configuration) $configfile", 3 );

	# some hash to detect multiple lines
	my %h_m_macro;
	my %h_m_directive;
	my %h_m_alias;

	#my %h_m_rule;

	# this list may seems to be a duplicate for Toscan
	# but is necessary to keep the config file order
	my @liste_toscan;

	debug( '-------- begin of config file -------------', 1 );

	my @config;
	read_config( $configfile, \@config ) or my_die( get_error() );

	my $line_id = 0;
	foreach my $line (@config) {
		$line_id++;

		# clean line and skip comments
		chomp $line;
		remove_trailing_spaces( \$line );
		next unless length $line;    # skip blank lines
		next if ( $line =~ m/^#/ );  # skip comments

		# replace \ by / (for windows), but just on files (selection lines)
		# because exclude_re can use \x patterns
		my $linebis = reg_name($line);

		#debug( "config line = $line", 1);

		my @ret;
		## no critic (ProhibitCascadingIfElse)
		if ( @ret = is_macro($line) ) {

			debug( "detect macro line $line", 3 );

			# macros lines
			###################
			my $key = shift @ret;
			my $val = shift @ret;

			if (   ( !defined check_macro( $key, $val, 0 ) )
				or ( check_duplicate( $key, \%h_m_macro ) ) )
			{
				if ($clean) {

					config_warning( 'fix', $line, $line_id,
						"macro $key : " . get_error() );
					$line = '# ' . $line;
				}
				else {
					config_warning( 'skip', $line, $line_id,
						"macro $key : " . get_error() );
				}
				${$r_nb_pbs}++;
				next;
			}
			debug( "found macro $key : $val", 2 );

			# add to Macro for print_config
			$Macros{$key} = $val;
		}
		elsif ( @ret = is_directive($line) ) {
			debug( "detect directive line $line", 3 );

			# a configuration line
			######################
			my $key = shift @ret;
			my $val = shift @ret;
			remove_trailing_spaces( \$val );

			my $ret2 = check_directive( $key, $val, 0 );
			if (   ( !defined $ret2 )
				or ( check_duplicate( $key, \%h_m_directive ) ) )
			{
				if ($clean) {

					config_warning( 'fix', $line, $line_id,
						"directive $key : " . get_error() );
					$line = '# ' . $line;
				}
				else {
					config_warning( 'skip', $line, $line_id,
						"directive $key : " . get_error() );
				}
				${$r_nb_pbs}++;
				next;
			}
			check_overload( $key, $ret2, $line, $line_id, \%h_m_directive );
		}
		elsif ( @ret = is_alias($line) ) {
			debug( "detect alias line $line", 3 );

			# is an alias definition
			########################
			my $key = shift @ret;
			my $val = shift @ret;
			remove_all_spaces( \$val );

			my $decoded = check_alias( $val, $rh_alias, 0 );
			if (   ( !defined $decoded )
				or ( check_duplicate( $key, \%h_m_alias ) ) )
			{
				if ($clean) {

					config_warning( 'fix', $line, $line_id,
						"alias $key : " . get_error() );
					$line = '# ' . $line;
				}
				else {
					config_warning( 'skip', $line, $line_id,
						"alias $key : " . get_error() );
				}
				${$r_nb_pbs}++;
				next;
			}

			$rh_alias->{$key} = $decoded;

			# for print_config
			$Aliases{$key} = $val;

			debug( "alias $key -> $decoded", 2 );
		}
		elsif ( @ret = is_negsel($linebis) ) {
			debug( "detect negative rule line $line", 3 );

			# begin with ! : it is an exception
			###################################

			my @tab = trait_line( shift @ret, shift @ret, $Ignore_case );
			my $flagdir = pop @tab;    # and ignore
			my $masq    = pop @tab;    # and ignore
			foreach my $elem (@tab) {
				if ( test_double($elem) ) {
					if ($Allow_overload) {
						debug(
"overload rule for $elem with $line (line $line_id)",
							2
						);
					}
					else {
						config_warning( 'skip', $line, $line_id,
							"exception $elem already seen in config file" );
						${$r_nb_pbs}++;
					}
				}
				elsif ( is_anyfile($elem) ) {
					debug( "exception : \"$elem\"", 2 );
					$Toscan{$elem} = 0;
				}
				else {

					# problem : file does not exist
					if ($clean) {
						config_warning( 'fix', $line, $line_id, get_error() );
						$line = '# ' . $line;
					}
					elsif ($Warn_missing_file) {
						config_warning( 'skip', $line, $line_id, get_error() );
					}
					else {
						debug(
"skipped config file $line (line $line_id) : $elem does not exists",
							3
						);
					}
					${$r_nb_pbs}++;
				}
			}
		}
		elsif ( @ret = is_equalsel($linebis) ) {
			debug( "detect equal rule line $line", 3 );

			# begin with a = : a directory to scan without recurse
			######################################################

			my @tab = trait_line( shift @ret, shift @ret, $Ignore_case );
			my $flagdir = pop @tab;
			my $masqb = pop @tab;    # brut alias line

			my $masq = check_alias( $masqb, $rh_alias, 0 );
			if ( !defined $masq ) {
				if ($clean) {

					config_warning( 'fix equal', $line, $line_id, get_error() );
					$line = '# ' . $line;
				}
				else {
					config_warning( 'skip equal', $line, $line_id,
						get_error() );
				}
				${$r_nb_pbs}++;
				next;
			}

			foreach my $elem (@tab) {
				if ( test_double($elem) ) {
					if ($Allow_overload) {
						debug(
"overload rule for $elem with $line (line $line_id)",
							2
						);
					}
					else {
						config_warning( 'skip', $line, $line_id,
							"directory $elem already seen in config file" );
						${$r_nb_pbs}++;
					}
				}
				elsif ( is_directory($elem) ) {

					addrule( $elem, $masqb, $masq, \@liste_toscan, $File, 0 );
					if ($flagdir) {
						$Onlydir{$elem} = 1;
						debug( "toscan without sub-dir : $elem masq $masq", 2 );
					}
					else {
						$Onlythis{$elem} = 1;
						debug( "toscan only this inode : $elem masq $masq", 2 );
					}
				}
				else {

					# problem : not a directory
					if ($clean) {
						config_warning( 'fix', $line, $line_id, get_error() );
						$line = '# ' . $line;
					}
					elsif ($Warn_missing_file) {
						config_warning( 'skip', $line, $line_id, get_error() );
					}
					else {
						debug(
"skipped config file $line (line $line_id) : $elem does not exists",
							3
						);
					}
					${$r_nb_pbs}++;
				}
			}    # foreach my $elem
		}
		elsif ( @ret = is_sel($linebis) ) {
			debug( "detect rule line $line", 3 );

			# directory or file to scan
			###########################
			my @tab = trait_line( shift @ret, shift @ret, $Ignore_case );
			my $flagdir = pop @tab;    # to be ignored
			my $masqb   = pop @tab;    # brut alias line

			my $masq = check_alias( $masqb, $rh_alias, 0 );
			if ( !defined $masq ) {
				if ($clean) {

					config_warning( 'fix', $line, $line_id, get_error() );
					$line = '# ' . $line;
				}
				else {
					config_warning( 'skip', $line, $line_id, get_error() );
				}
				${$r_nb_pbs}++;
				next;
			}
			else {
				debug( "good mask $masq", 3 );
			}

			foreach my $elem (@tab) {
				if ( test_double($elem) ) {
					if ($Allow_overload) {
						debug(
"overload rule for $elem with $line (line $line_id)",
							2
						);
					}
					else {
						config_warning( 'skip', $line, $line_id,
							"file $elem already seen in config file" );
						${$r_nb_pbs}++;
					}
				}
				elsif ( is_anyfile($elem) ) {

					addrule( $elem, $masqb, $masq, \@liste_toscan, $File, 0 );
				}
				else {
					if ($clean) {
						config_warning( 'fix', $line, $line_id, get_error() );
						$line = '# ' . $line;
					}
					elsif ($Warn_missing_file) {
						config_warning( 'skip', $line, $line_id, get_error() );
					}
					else {
						debug(
"skipped config file $line (line $line_id) : $elem does not exists",
							3
						);
					}
					${$r_nb_pbs}++;
				}
			}    # foreach my $elem
		}
		else {
			config_warning( 'skip', $line, $line_id, 'unknown line type' );
		}
		## use critic
	}    # foreach my $line

	# clean config file
	if ( ($clean) and ( ${$r_nb_pbs} ) ) {

		# rewrite cleaned config file
		write_config( $configfile, \@config );
	}

	# test if something to do
	if ( !scalar keys %Toscan ) {
		warning('nothing to scan');
	}

	# set default values if not founds
	set_default( \$Allow_overload, $allow_overload_def );
	set_default( \$Archive,        $archive_def );

	set_default( \$Dbm,                EMPTY );
	set_default( \$Follow_symlinks,    $follow_symlinks_def );
	set_default( \$History,            $history_def );
	set_default( \$Max_checksum_size,  $max_checksum_size_def );
	set_default( \$Ignore_case,        $ignore_case_def );
	set_default( \$Report_full_newdel, $report_full_newdel_def );
	set_default( \$Running,            $running_files_def );
	set_default( \$Timing,             $timing_def );
	set_default( \$Verbose,            $verbose_def );
	set_default( \$Warn_dead_symlinks, $warn_dead_symlinks_def );
	set_default( \$Warn_missing_file,  $warn_missing_file_def );
	set_default( \$Report_syslog,      $report_syslog_def );

	#$Output_format      = 'txt' if ( !defined $Output_format );
	#$Debug_level        = 0 if ( !defined $Debug_level );

	if ($OnlySufx) {
		$OnlySufxPat = make_regex( $OnlySufx, '\.(', ')$' );
		debug( "OnlySufx=$OnlySufx SufxPat=$OnlySufxPat", 2 );
	}

	# compute patterns for exclude
	if ($Sufx) {

		#my @tab = split / /, $Sufx;
		#$SufxPat = '\.(' . join( '|', map { "$_" } @tab ) . ')$' if (@tab);
		$SufxPat = make_regex( $Sufx, '\.(', ')$' );
		debug( "Sufx=$Sufx SufxPat=$SufxPat", 2 );
	}
	if ($Prefx) {

		#my @tab = split / /, $Prefx;
		#$PrefxPat = '^(' . join( '|', map { "$_" } @tab ) . ')' if (@tab);
		$PrefxPat = make_regex( $Prefx, '^(', ')' );
		debug( "Prefx=$Prefx PrefxPat=$PrefxPat", 2 );
	}
	if ($Exclude_re) {

		#my @tab = split / /, $Exclude_re;
		#$ExRePat = '(' . join( '|', map { "$_" } @tab ) . ')' if (@tab);
		$ExRePat = make_regex( $Exclude_re, '(', ')' );
		debug( "Exclude_re=$Exclude_re ExRePat=$ExRePat", 2 );
	}

	# add some files for internal check : programs, the config file
	# it will be check after each database open (calc_control sub)
	# control permissions and changes (md5)
	my $check = 'P';
	my $masq  = $rh_alias->{$check};

	# afick's programs
	my @list = get_names($Ignore_case);
	foreach my $elem (@list) {
		addrule( $elem, $check, $masq, \@liste_toscan, 0, 1 );

		debug( "add program file $elem $masq", 3 );
	}

	# afick's configuration file
	$configfile = lc $configfile if ($Ignore_case);
	addrule( $configfile, $check, $masq, \@liste_toscan, 0, 1 );

	# database : only check permissions
	# see add_database_control sub

	# exclude lock file is done in my_lock sub

	if ( ( !is_microsoft() ) and ($Ignore_case) ) {
		warning('ignore_case is dangerous');
		${$r_nb_pbs}++;
	}

	debug( "-------- end of config file : $$r_nb_pbs problems -------------",
		1 );

	return @liste_toscan;
}
#######################################################
sub add_database_control($$) {
	my $rh_alias        = shift @_;
	my $ra_liste_toscan = shift @_;

	# database : only check permissions
	my $check = 'u+g+p+n';
	my $masq = check_alias( $check, $rh_alias, 0 );

	# bugfix : the bsd_glob is not a valid choice
	# because on init, no database exists, so
	# the first update, or any compare action will show new files !
	# @list  = bsd_glob( $Database . '*' );
	# so we have a list, but we cannot add control file (does not exists)

	my @list = ( $Database . $Database_ext, $Database . Control_ext );

	# the index exist not for all backends
	push @list, $Database . $Database_idx if ($Database_idx);

	foreach my $elem (@list) {
		my $abs_elem = to_abspath($elem);
		$abs_elem = lc $abs_elem if ($Ignore_case);
		addrule( $abs_elem, $check, $masq, $ra_liste_toscan, 0, 1 );
		debug( "add database file $abs_elem $masq", 3 );
	}
	return;
}
#######################################################
# acl
#######################################################
# transform a window's acl in binary form from hashtable
# to clear one for display
sub split_acl($) {
	my $acl = shift @_;

	my @tab_acl = split /$Sepacl/, $acl;
	my @text;
	foreach my $acl_item (@tab_acl) {
		my ( $sid, $mask ) = split /=/, $acl_item;
		next if ( !defined $mask );
		my @rights;
		Win32::FileSecurity::EnumerateRights( $mask, \@rights );
		push @text, "$sid=" . join $Sepacl, @rights;
	}
	return @text;
}
#######################################################
# get windows acl for a given file
sub winacl($) {
	my $filename = shift @_;

	my $acl = 0;
	my %perm;
	if ($Acl_exist) {
		my @acl;

		# catch the error to avoid stop the program
		eval { Win32::FileSecurity::Get( $filename, \%perm ) };
		if ($EVAL_ERROR) {
			debug(
				"(winacl) can not get windows acl for $filename : $EVAL_ERROR",
				3
			);
		}
		else {
			while ( my ( $name, $mask ) = each %perm ) {
				$name =~ s/ /_/g;
				push @acl, "$name=$mask";
			}
			$acl = join $Sepacl, @acl;

			if ( $Dbm eq 'SDBM_File' ) {

	   # caution : acl may be big, too big for sdbm database :
	   # There are a number of limits on the size of the data that you can store
	   # in the SDBM file. The most important is that the length of a key, plus
	   # the length of its associated value, may not exceed 1008 bytes.
				my $len = length $acl;
				warning("(winacl) acl is too long : $len") if ( $len > 500 );
			}
		}
	}
	return $acl;
}
#######################################################
# transform a windows acl from array (split_acl)
# to a hash, to allow a good compare
sub hash_acl(@) {
	my @tab = @_;
	my %acl;

	foreach my $elem (@tab) {
		my ( $sid, $acl ) = split /=/, $elem;
		$acl{$sid} = $acl;
	}
	return %acl;
}
#######################################################
# compare 2 acl : show new, deleted, changed
sub compare_acl($$) {
	my $acl1 = shift @_;    # old value from database
	my $acl2 = shift @_;    # new value from database

	my %acl1 = hash_acl( split_acl($acl1) );
	my %acl2 = hash_acl( split_acl($acl2) );

	foreach my $key ( keys %acl1 ) {
		if ( exists $acl2{$key} ) {
			if ( $acl1{$key} ne $acl2{$key} ) {

				# changed acl
				report_detailed( "change acl $key", $acl1{$key}, $acl2{$key} );
			}
			delete $acl2{$key};
		}
		else {

			# deleted acl
			report_detailed( "deleted acl $key", $acl1{$key} );
		}
	}

	# we deleted all common keys on acl2
	# so we just have new acl now
	foreach my $key ( keys %acl2 ) {

		# new acl
		report_detailed( "new acl $key", $acl2{$key} );
	}
	return;
}
#######################################################
#
#######################################################
# display
# convert a field from database in a human way
sub display($$) {
	my $elem = shift @_;    # field id
	my $info = shift @_;    # array from database

	## no critic (ProhibitCascadingIfElse)
	if ( $elem == get_id('device') ) {

		# device is in hexa, ex 309 == major 3, minor 9 == /dev/hda9
		return sprintf '%lx', $info->[$elem];
	}
	elsif ( $elem == get_id('filemode') ) {

		# perm is in octal
		return print_oct( $info->[$elem] );
	}
	elsif ( ( $elem == get_id('acl') ) and ($Acl_exist) ) {

		# uid on windows are acl
		## no critic (ProhibitNoisyQuotes)
		return join ';', split_acl( $info->[$elem] );
	}
	elsif (( $elem == get_id('atime') )
		or ( $elem == get_id('mtime') )
		or ( $elem == get_id('ctime') ) )
	{

		# dates
		if ( $info->[$elem] ) {
			return localtime $info->[$elem];
		}
		else {
			return 0;
		}
	}
	else {
		return $info->[$elem];
	}
	## use critic
}

#######################################################
# unpack database storage flat format
sub split_record($) {
	my $line = shift @_;    # value from database

	return split /$Sepmeta/, $line;
}
#######################################################
# display_all
# convert in a human way all the record
sub display_all($) {
	my $line = shift @_;    # value from database

	my @fileinfo = split_record($line);

	my $output;

	my $max = scalar @fileinfo;
	foreach my $i ( 0 .. ( $max - 1 ) ) {

		$output .= display( $i, \@fileinfo ) . Sep;
	}
	return $output;
}
#######################################################
# checksum read the file, so a classic open will change access time (atime)
# with O_NOATIME : it is not changed
# but this option is not portable : it seems to exist only on recent linux box
# (not on redhat 7.3/perl 5.6), ok on debian sarge, mandriva 2005/2006/2007)
# so we have to check it
{
	my $sysopen_flag;

	sub get_sysopen_flag() {
		if ( !defined $sysopen_flag ) {

			#eval  { Fcntl->import( qw( O_NOATIME) ); };
			eval {
				import Fcntl qw( O_NOATIME);
				$sysopen_flag = O_RDONLY | Fcntl::O_NOATIME();
			};
			if ($EVAL_ERROR) {
				$sysopen_flag = O_RDONLY;
				debug( 'can not import noatime', 2 );
			}
			else {
				debug( 'import noatime', 2 );
			}
		}
		return $sysopen_flag;
	}
}
#######################################################
# low-level checksum sub
sub base_checksum($$$$) {
	my $ctx  = shift @_;    # checksum object
	my $name = shift @_;    # file name
	my $degraded =
	  shift @_;    # flag of degraded mode :0 for all file else max file size
	my $is_link = shift @_;    # flag for symbolik links

	if ( $is_link and not $Follow_symlinks ) {

		# for symbolic links, check the change in pointed name
		# not in pointed file content
		my $link = readlink $name;
		$ctx->add($link);
		my $sum = $ctx->b64digest;
		debug( "(base_checksum) checksum follow_symlink from $name to link",
			2 );
		return $sum;
	}

	#elsif ( open( my $fh_file, '<', $name ) ) {
	elsif ( sysopen my $fh_file, $name, get_sysopen_flag() ) {
		binmode $fh_file;
		my $buf_size = 65_536;    # buffer size
		if ($degraded) {

			debug(
"(base_checksum) degraded checksum on $name : $degraded > $Max_checksum_size",
				2
			);
			$Nb_degraded++;

			# we just want to have checksum on first Max_checksum_size bytes
			my $buf;              # buffer
			my $lu;               # effective read count
			my $reste = $Max_checksum_size;    # size to read
			while ( $reste > $buf_size ) {
				$lu = read $fh_file, $buf, $buf_size;
				$ctx->add($buf);
				$reste -= $lu;
				last if ($lu);
			}
			$lu = read $fh_file, $buf, $reste;
			$ctx->add($buf);
			$reste -= $lu;

			# check : $reste = 0
			warning(
"(base_checksum) pb checksum on file $name size $degraded buf_size $buf_size limit $Max_checksum_size"
			) if ( $reste != 0 );
		}
		else {

			# checksum on all file
			#$ctx->addfile($fh_file);
			# because I was reported some strange probleme on windows
			# I got and rewrite addfile method to suppress Carp::croak call
			my $n;
			my $buf = EMPTY;
			while ( $n = read $fh_file, $buf, $buf_size ) {
				$ctx->add($buf);
			}
			if ( !defined $n ) {
				warning(
					"(base_checksum) can not read $name for checksum: $ERRNO");
			}
		}
		close $fh_file or warning("can not close $name : $ERRNO");
		my $sum = $ctx->b64digest;
		return $sum;
	}
	else {
		if ( is_microsoft() ) {

			# because it is very common on windows to not allow to administator
			# with some acl
			debug( "(base_checksum) can not open $name for checksum: $ERRNO",
				1 );
		}
		else {

			# on unix, it show a big problem
			warning("(base_checksum) can not open $name for checksum: $ERRNO");
		}
		return 0;
	}
}
#######################################################
# md5sum :
# build a MD5 checksum on the given file
sub md5sum($$$) {
	my $name     = shift @_;    # file name
	my $degraded = shift @_;
	my $is_link  = shift @_;

	# !!! the Digest module is not in standard
	# so we can not write Digest->new("MD5");
	my $ctx = Digest::MD5->new();

	return base_checksum( $ctx, $name, $degraded, $is_link );
}
#######################################################
# sha1sum :
# build a sha1 checksum on the given file
sub sha1sum($$$) {
	my $name     = shift @_;    # file name
	my $degraded = shift @_;
	my $is_link  = shift @_;

	# !!! the Digest module is not in standard
	# so we can not write Digest->new("SHA1");
	my $ctx = Digest::SHA1->new();
	return base_checksum( $ctx, $name, $degraded, $is_link );
}
#######################################################
# file_info :
# build a complete info on the given file
sub file_info($$) {
	my $name = shift @_;
	my $masq = shift @_;

	my @fileinfo = lstat $name;
	if ( !@fileinfo ) {
		warning("(fileinfo) can not get lstat on $name");

		# we must return an entry ...
		# so we fill it with null values
		@fileinfo = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );
	}

	# for afick-tk progress text
	progress("$name");
	debug( $name . Sep, 3 );

	my $is_link = S_ISLNK( $fileinfo[2] );
	my $fsize   = $fileinfo[7];

	my $md5_sum  = 0;
	my $sha1_sum = 0;
	if ( -f $name ) {

		if ($fsize) {

			# just compute checksum on not empty files

			# test on file size to reduce cpu cost
			# if degraded mode, pass file size
			my $degraded =
			  ( ($Max_checksum_size) and ( $fsize > $Max_checksum_size ) )
			  ? $fsize
			  : 0;

			if ( $masq =~ m/1/ ) {
				$sha1_sum = sha1sum( $name, $degraded, $is_link );
			}
			if ( $masq =~ m/5/ ) {
				$md5_sum = md5sum( $name, $degraded, $is_link );
			}
		}
		else {

			# empty file : skip it
		}
	}

	# Each file gets a pipe-delimited entry, with format as follows:
	#
	# field 0 = md5 checksum hash
	# field 1 = device number of filesystem
	# field 2 = inode number
	# field 3 = file mode (type/permissions)
	# field 4 = number of hard links to file
	# field 5 = uid of the file
	# field 6 = gid of the file
	# field 7 = total size of file, in bytes
	# field 8 = actual number of blocks allocated
	# field 9 = last access time in seconds since the epoch
	# field 10 = last modify time (since epoch)
	# field 11 = inode change time
	# field 12 = sha1 checksum hash
	#
	# See the perl "stat" command or man stat() for more information.

	# default value is 0
	my (
		$device, $inode, $mode,  $link,  $uid, $gid,
		$size,   $bloc,  $atime, $mtime, $ctime
	) = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );

	$device = $fileinfo[0] if ( $masq =~ m/d/ );
	$inode  = $fileinfo[1] if ( $masq =~ m/i/ );

	# file mode are different on unix and windows
	# user/group/other and acl
	# but we use mode to get file type, so keep this field as it
	$mode = $fileinfo[2] if ( $masq =~ m/p/ );
	$link = $fileinfo[3] if ( $masq =~ m/n/ );
	$uid  = $fileinfo[4] if ( $masq =~ m/u/ );

	#$gid   = $fileinfo[5]  if ( $masq =~ m/g/ );
	if ( $masq =~ m/g/ ) {
		if ( is_microsoft() ) {

			# gid is unused on windows
			# it is replaced by the acess control list
			$gid = winacl($name);
		}
		else {

			# unix
			$gid = $fileinfo[5];
		}
	}

	$size  = $fileinfo[7]  if ( $masq =~ m/s/ );
	$atime = $fileinfo[8]  if ( $masq =~ m/a/ );
	$mtime = $fileinfo[9]  if ( $masq =~ m/m/ );
	$ctime = $fileinfo[10] if ( $masq =~ m/c/ );
	$bloc  = $fileinfo[12] if ( $masq =~ m/b/ );

	# we use a flat format here because the database force us to store only this
	# see also split_record sub to unpack the data
	my $entry = join Sep,
	  $md5_sum, $device, $inode, $mode,  $link,  $uid,      $gid,
	  $size,    $bloc,   $atime, $mtime, $ctime, $sha1_sum, 0;

	debug( display_all($entry), 3 );

	# !! seems to be a problem with -M/-C on dangling links
	if ( $Running and ( !$is_link ) ) {
		my $cur_time = time;
		if ( $masq =~ m/m/ ) {
			if ( $mtime < $BASETIME ) {

				# ok
			}
			elsif ( $mtime > $cur_time ) {
				warning("(file_info) $name modified in the future");
			}
			else {
				warning(
					"(file_info) $name as been modified during the afick scan");
			}
		}
		if ( $masq =~ m/c/ ) {
			if ( $ctime < $BASETIME ) {

				# ok
			}
			elsif ( $ctime > $cur_time ) {
				warning("(file_info) inode of $name in the future");
			}
			else {
				warning(
"(file_info) inode of $name as been modified during the afick scan"
				);
			}
		}
	}
	return $entry;
}
#######################################################
# compare_entry :
# compare 2 file infos and print the difference
sub compare_entry($$$) {
	my $name   = shift @_;    # file name
	my $entry1 = shift @_;    # old value
	my $entry2 = shift @_;    # new value

	my @fileinfo1 = split_record($entry1);
	my @fileinfo2 = split_record($entry2);

	my $max1 = scalar @fileinfo1;
	my $max2 = scalar @fileinfo2;

	if ( $max1 != $max2 ) {
		warning("pb compare_entry $name max1=$max1 max2=$max2");
	}
	foreach my $i ( 0 .. ( $max1 - 1 ) ) {

		if ( !defined $fileinfo1[$i] ) {
			warning( "pb compare_entry $name on old $i : " . get_field($i) );
			return;
		}
		if ( !defined $fileinfo2[$i] ) {
			warning( "pb compare_entry $name on new $i :" . get_field($i) );
			return;
		}

		if ( $fileinfo1[$i] ne $fileinfo2[$i] ) {

			# !!!! for windows acl, it is long and difficult to read
			# so a special report is necessary
			if ( ( $i == get_id('acl') ) and $Acl_exist ) {
				compare_acl( $fileinfo1[$i], $fileinfo2[$i] );
			}
			else {

				# general case
				report_detailed(
					get_field($i),
					display( $i, \@fileinfo1 ),
					display( $i, \@fileinfo2 )
				);
			}
		}    # if fileinfo ne
	}    # for
	return;
}

#######################################################
# is_exception :
# return true if the file name belong exception list
sub is_exception($) {
	my $elem = shift @_;
	my $ret = ( ( exists $Toscan{$elem} ) and ( $Toscan{$elem} eq '0' ) );

	#debug ("test exception on \"$elem\" : $ret (" . $Toscan{$elem} . ")" , 3);
	return $ret;
}
#######################################################
# parcours :
# the general sub to scan a directory (recursive)
# explore a directory or a file to populate an array
sub parcours($$$$) {
	my $rep     = shift @_;    # file or directory to scan
	my $traite  = shift @_;    # sub to call
	my $masq    = shift @_;    # herited masq
	my $newflag = shift @_;    # herited new flag

	debug( "(parcours) $rep masq = $masq", 3 );

	my @liste;

	my $rep_key;
	if ($Ignore_case) {
		$rep_key = lc $rep;
	}
	else {
		$rep_key = $rep;
	}

	# first build a list of file
	if ( -d $rep ) {
		return if ( $rep =~ /\/\.\.?$/ );    # skip . and ..

		if ( exists $Toscan{$rep_key} ) {
			$masq = $Toscan{$rep_key};

			debug( "(parcours) change masq to $masq for $rep", 2 );
		}
		$traite->( $rep, $masq, $newflag );

		# equal : do not scan into the directory
		return if ( exists $Onlythis{$rep_key} );

		if ( !-l $rep ) {

			my $fh_dir;
			if ( !opendir $fh_dir, $rep ) {
				warning("(parcours) can not open directory $rep : $ERRNO");
				return;
			}
			my $elem;
			while ( defined( $elem = readdir $fh_dir ) ) {
				next if $elem =~ /^\.\.?$/;

				# equal : do not scan sub-dir
				next
				  if (  ( exists $Onlydir{$rep_key} )
					and ( -d $rep . SLASH . $elem ) );

				push @liste, $elem;
			}
			closedir $fh_dir
			  or warning("can not close directory $rep : $ERRNO");
		}
		else {

			# on ne suit pas les liens sur les repertoires
			debug( "(parcours) $rep skipped (link on directory)", 2 );
		}
	}
	else {

		# ordinary files (for exemples afick.pl afick.conf ...)
		my ( $fic, $dir, undef ) = fileparse($rep);
		$dir =~ s/\/$//;

		# just put in @list the file name without path
		push @liste, $fic;

		# we had to build the parent directory
		$rep = $dir;
	}

	parcours2( $rep, $traite, $masq, $Newfiles{$rep}, \@liste );
	return;
}
#######################################################
# treat an array of file (or directory)
# search exceptions
# call file info on remaining files
# recursive call on directories
sub parcours2($$$$$) {
	my $rep     = shift @_;    # file or directory to scan
	my $traite  = shift @_;    # sub to call
	my $masq    = shift @_;    # herited masq
	my $newflag = shift @_;    # herited new flag
	my $liste   = shift @_;

	foreach my $file ( @{$liste} ) {

		# build full path
		my $fic;
		if ( is_root($rep) ) {

			#special case : / to avoid //
			$fic = $rep . $file;
		}
		else {
			$fic = $rep . SLASH . $file;
		}

		# build case/nocase name
		my $fic_key;
		if ($Ignore_case) {
			$fic_key = lc $fic;
		}
		else {
			$fic_key = $fic;
		}

		# a security to force auto-control
		if ( !exists $Control{$fic_key} ) {

			if ($OnlySufxPat) {
				next if ( is_exception($fic_key) );
				next unless ( test_only_suffix($fic_key) );
			}
			else {
				next if ( is_exception($fic_key) );
				next if ( test_exclude_prefix($file) );
				next if ( test_exclude_re($fic_key) );
				next if ( test_exclude_suffix($fic_key) );

			}
		}
		else {
			debug( "(parcours2) forced scan for $fic_key", 2 );
		}

		my $lmasq = $masq;

		# surcharge
		if ( exists $Toscan{$fic_key} ) {
			$lmasq = $Toscan{$fic_key};

			debug( "(parcours2) change masq to $lmasq for $fic", 2 );
		}
		elsif ( !$lmasq ) {

			# heritage, set to all by default (ex : -l action)
			$lmasq = $Alias{'all'};
			debug( '(parcours2) lmasq set to all', 2 );
		}

		debug( "(parcours2) $fic ($rep) lmasq=$lmasq", 2 );

		if ( -d $fic ) {
			parcours( $fic, $traite, $lmasq, $newflag );
		}    # end directory
		elsif ( -l $fic ) {
			my $whatlink = readlink $fic;
			my $abs_whatlink;

			# is the link an absolute path ?
			if ( $whatlink !~ m/^\// ) {

				# absolute path for check
				$abs_whatlink = $rep . SLASH . $whatlink;
				debug(
"(parcours2) abs_whatlink for $fic : $abs_whatlink ($whatlink)",
					2
				);
			}
			else {
				$abs_whatlink = $whatlink;
			}
			if ( !-e $abs_whatlink ) {

				# real path for display
				$Dangling{$fic} = $whatlink;
			}
			$traite->( $fic, $lmasq, $Newfiles{$rep} );
		}    # end link
		else {
			$traite->( $fic, $lmasq, $Newfiles{$rep} );
		}    # end normal file
	}    # foreach
	return;
}
#######################################################
# wanted_create
# process a file in create mode
sub wanted_create($$) {
	my $name = shift @_;
	my $masq = shift @_;

	$Finded{$name} = 1;

	my $entry = file_info( $name, $masq );

	$Hashfile{$name} = $entry;
	return;
}
#######################################################
# end_report
# to be called at end of scan to display informations on database
# and write control file
sub end_report($$) {
	my $database = shift @_;
	my $flag     = shift @_;

	# Generate a MD5 for the dbm file.
	my $sum = md5sum( $database . $Database_ext, 0, 0 );

	info( Comment x 65 );
	info("MD5 hash of $database => $sum");
	write_control( $sum, $database ) if ($flag);
	return;
}
#######################################################
# create (base liste)
# create a new database (empty the existing one if exists)
sub create($$$) {
	my $database   = shift @_;
	my $configfile = shift @_;
	my $listerep   = shift @_;

	# todo : call  open_database ...

	# get best dbm
	$Dbm          = get_best_dbm();
	$Database_ext = get_database_ext($Dbm);
	$Database_idx = get_database_idx($Dbm);

	my $database_fullname = $database . $Database_ext;

	if ( -f $database_fullname ) {
		warning(
'(create) init on an already existing database : changes will be lost'
		);
	}

	# create control file
	my $control_file = $database . Control_ext;
	touch($control_file);
	chmod Strict_perm, $control_file;

	# lock then open database to solve problems with GDBM
	my_lock( $database_fullname, LOCK_EX );

	## no critic (ProhibitTies,ProhibitParensWithBuiltins)
	tie( %Hashfile, $Dbm, $database, O_RDWR | O_CREAT, Strict_perm )
	  or my_die("(create) : can not open $Dbm $database : $ERRNO");

	# add database controls
	add_database_control( \%Alias, $listerep );

	# delete all previous keys
	%Hashfile = ();

	print_env( 'init', $configfile );
	debug( '(create) begin', 1 );

	foreach my $elem ( @{$listerep} ) {

		# to skip already scanned files
		next if ( exists $Finded{$elem} );

		parcours( $elem, \&wanted_create, EMPTY, undef );
	}
	my $nbscan = scalar keys %Finded;
	print_dangling(1);
	close_database();

	crlf();
	info("Hash database created successfully. $nbscan files entered.");
	history("init : $nbscan files entered");

	end_report( $database, 1 );
	return;
}
#######################################################
# normalize info : the goal is to skip leading 0
sub norm_info($) {
	my $info = shift @_;

	$info =~ s/$Sepmeta//go;
	$info =~ s/0+$//;
	return $info;
}
#######################################################
sub is_changed($$) {
	my $old = shift @_;
	my $new = shift @_;

	my $o = norm_info($old);
	my $n = norm_info($new);
	debug( "o=$o n=$n", 2 );

	return ( norm_info($old) ne norm_info($new) );
}
#######################################################
# wanted_update
# process a file in update mode
sub wanted_update($$$) {
	my $name    = shift @_;
	my $masq    = shift @_;
	my $newflag = shift @_;

	$Finded{$name} = 1;

	my $entry = file_info( $name, $masq );

	if ( exists $Hashfile{$name} ) {

		# test for changes
		my $old_entry = $Hashfile{$name};

		if ( is_changed( $old_entry, $entry ) ) {

			# keep values to compare
			$Oldval{$name} = $old_entry;
			$Newval{$name} = $entry;
			$Nbmod++;

			# for file : print result immediatly
			if ($File) {
				report_summary( 'changed', $name );
				compare_entry( $name, $old_entry, $entry );
			}

			# update database
			$Hashfile{$name} = $entry if ($Update);
		}
		elsif ( $old_entry ne $entry ) {

			# dummy change
			# update database
			$Hashfile{$name} = $entry if ($Update);
		}
		else {

			# no change
		}
	}
	else {

		# new entry
		if ( defined $newflag ) {
			$Newfiles{$name} = $newflag + 1;
		}
		else {
			$Newfiles{$name} = 1;
		}

		$Newval{$name} = $entry;

		# for file : print result immediatly
		if ($File) {
			report_summary( 'new', $name );

			#compare_entry( $name, $old_entry, $entry );
		}

		$Hashfile{$name} = $entry if ($Update);
	}
	return;
}    # end of wanted
#######################################################
sub open_database($$$$) {
	my $database   = shift @_;
	my $configfile = shift @_;
	my $action     = shift @_;
	my $r_hashfile = shift @_;

	# open control file and check security
	my ( $old_version, $run_date ) = read_control($database);

	# test database perm and restrict if necessary
	# Database_ext is set in read_control
	my $database_fullname = $database . $Database_ext;
	my $mode              = ( stat $database_fullname )[2];
	if ( $mode != Strict_perm ) {
		chmod Strict_perm, $database_fullname;
		chmod Strict_perm, $database . $Database_idx
		  if ( -e $database . $Database_idx );
		my $mode_human = print_oct($mode);
		my $new_mode   = print_oct(Strict_perm);
		debug(
"(open_database) restrict permission on $database from $mode_human to $new_mode",
			1
		);
	}

	## no critic (ProhibitTies)
	# open database in adequate mode
	if ($Update) {
		my_lock( $database_fullname, LOCK_EX );
		## no critic (ProhibitParensWithBuiltins)
		tie( %{$r_hashfile}, $Dbm, $database, O_RDWR, Strict_perm )
		  or my_die("(update) : can not open $Dbm $database : $ERRNO");
		$action = 'update' if ( !$action );
	}
	else {

		# if we work on read-only media, can not lock a file
		#my_lock( $database_fullname, LOCK_SH );
		## no critic (ProhibitParensWithBuiltins)
		tie( %{$r_hashfile}, $Dbm, $database, O_RDONLY, Strict_perm )
		  or my_die("can not open $Dbm $database : $ERRNO");
		$action = 'compare' if ( !$action );
	}

	# check if afick was changed
	calc_control($configfile);

	# display informations
	print_env( $action, $configfile );
	debug( "begin $action", 1 );
	print_last( $run_date, $old_version );

	# todo : to avoid global Hashfile :
	return $action;
}
#######################################################
sub close_database() {

	# todo : to avoid global %Hashfile
	# get it as arg
	untie %Hashfile;
	my_unlock();
	return;
}
#######################################################
sub statistics($$$) {
	my $action   = shift @_;
	my $nbnew    = shift @_;
	my $nbdelete = shift @_;

	my $nbscan   = scalar keys %Finded;
	my $dangling = scalar keys %Dangling;
	my $nbchange = $nbnew + $nbdelete + $Nbmod;

	my $text =
"$nbscan files scanned, $nbchange changed (new : $nbnew; delete : $nbdelete; changed : $Nbmod; dangling : $dangling; exclude_suffix : $Nb_exclude_sufx; exclude_prefix : $Nb_exclude_prefx; exclude_re : $Nb_exclude_re; degraded : $Nb_degraded)";
	if ($Update) {
		info("Hash database updated successfully : $text");
	}
	else {
		info("Hash database : $text");
	}
	history("$action : $text");

	# status
	## no critic (ProhibitParensWithBuiltins)
	return oct(
		join( EMPTY,
			'0b', map { $_ ? 1 : 0; } ( $nbnew, $nbdelete, $Nbmod, $dangling ) )
	);
}
#######################################################
# update :
# compare or update a database with the system
sub update($$$) {
	my $database   = shift @_;
	my $configfile = shift @_;
	my $listerep   = shift @_;

	#first check if database exists
	my $control_file = $database . Control_ext;
	if ( -s $control_file ) {
		debug( "(update) $database $configfile", 3 );
	}
	else {

		# no control file
		# switch to init, to allow cron job to start
		# (allow to suppress init from install)
		warning('(update) no database found : change action to init');
		create( $database, $configfile, $listerep );
		return 0;
	}

	my $action = open_database( $database, $configfile, undef, \%Hashfile );

	# add database controls
	add_database_control( \%Alias, $listerep );

	# for afick-tk progress bar
	# guess the number of file does not change too much
	my $total = scalar keys %Hashfile;
	progress("total $total");

	# scan file list
	foreach my $elem ( @{$listerep} ) {

		# skip already scanned
		next if ( exists $Finded{$elem} );

		parcours( $elem, \&wanted_update, EMPTY, undef );
	}

	debug( '(update) begin analysis', 1 );

	# analysis
	my $nbchange = $Nbmod;
	my $nbdelete = 0;
	my $nbnew    = 0;
	if ( !$File ) {

		# look for new files
		$nbnew = print_new(0);
		$nbchange += $nbnew;

		# look for deleted files
		$nbdelete = print_delete(0);
		$nbchange += $nbdelete;

		print_changed(0);
		print_dangling(0);
	}

	crlf();
	info('detailed changes') if ($nbchange);
	if ( !$File ) {
		print_new(1);
		print_delete(1);
		print_changed(1);
		print_dangling(1);
	}

	close_database();

	crlf();

	my $ret = statistics( $action, $nbnew, $nbdelete );

	end_report( $database, $Update );

	# return a status
	return $ret;
}    # end update

#######################################################
# we need a way to communicate with afick daemon
# signal do not work well with gamin
# so we will use a named pipe
my $rt_fifo = '/tmp/afick';

sub signal_handler_real {

	# 1st argument is signal name
	my ($sig) = @_;

	info("(signal_handler_real) : Caught a SIG$sig");

	if ( ( $sig eq 'INT' ) or ( $sig eq 'QUIT' ) or ( $sig eq 'TERM' ) ) {

		# stop real_time
		$Real_time = 0;
	}

	# to force enter the loop
	touch($rt_fifo);

	return;
}
#######################################################
# syslog
#######################################################
sub open_syslog() {

	if ($Report_syslog) {
		eval { require Sys::Syslog };
		if ($EVAL_ERROR) {

			# can not use syslog
			# so reset url
			$Report_syslog = $report_syslog_def;
			warning(
"can not use syslog : perl module Sys::Syslog not found : $EVAL_ERROR"
			);

		}
		else {

			# ok : open syslog
			import Sys::Syslog;
			openlog( 'afick', 'ndelay', 'user' );
		}
	}
	return;
}
#######################################################
sub close_syslog() {
	closelog() if ($Report_syslog);
	return;
}
#######################################################
sub my_syslog($$) {
	my $priority = shift @_;
	my $text     = shift @_;

	return unless $Report_syslog;

	#return if ( is_progress($text) );

	# replace tab by space
	$text =~ s/\t/        /g;

	syslog( $priority, $text );
	return;
}
#######################################################
#
#######################################################
# a beta code for a "real-time" (daemon) use
## no critic (ProhibitExcessComplexity)
sub real_time($$$) {
	my $database   = shift @_;
	my $configfile = shift @_;
	my $listerep   = shift @_;

	eval { require Sys::Gamin };
	if ($EVAL_ERROR) {
		my_die(
"can not run in real-time mode : perl module Sys::Gamin not found : $EVAL_ERROR"
		);
	}

	debug( "(real_time) $database $configfile", 3 );

	# report immediatly
	$File = 1;

	# update database
	$Update = 1;

	# do not test for running !
	$Running = 0;
	my $action = open_database( $database, $configfile, 'daemon', \%Hashfile );

	my $nbdelete = 0;
	my $nbnew    = 0;

	# configure gamin from afick config file
	my $fm = new Sys::Gamin;
	foreach my $fic ( keys %Toscan ) {
		$fm->monitor($fic) if ( $Toscan{$fic} );
	}

	# special monitoring to get have immediate signal treatment
	if ( !-p $rt_fifo ) {
		unlink $rt_fifo if -e $rt_fifo;
		system 'mkfifo', $rt_fifo;
	}
	my $fh_fifo;
	## no critic (RequireBriefOpen)
	if ( !open $fh_fifo, '<', $rt_fifo ) {
		warning("can not read $rt_fifo : $ERRNO\n");
	}
	info("fifo is $rt_fifo");
	$fm->monitor($rt_fifo);

	# use signals to control loop
	$SIG{'INT'}  = \&signal_handler_real;
	$SIG{'QUIT'} = \&signal_handler_real;
	$SIG{'TERM'} = \&signal_handler_real;

	# no buffering
	$OUTPUT_AUTOFLUSH = 1;

	# start monitoring
  EVENT: while (1) {
		do {
			last unless $Real_time;

			# event
			my $ev = $fm->next_event;

			my $type     = $ev->type;
			my $monitor  = $fm->which($ev);
			my $filename = $ev->filename;

			debug("(real_time) event $type on $monitor : $filename");
			$filename = $monitor . SLASH . $filename if ( -d $monitor );

			# commands from named pipe
			if ( $filename eq $rt_fifo ) {
				while ( my $cmd = <$fh_fifo> ) {
					chomp $cmd;
					info("fifo command : $cmd\n");
					## no critic (ProhibitCascadingIfElse)
					if ( $cmd eq 'quit' ) {
						last EVENT;
					}
					elsif ( $cmd eq 'stat' ) {
						statistics( $action, $nbnew, $nbdelete );
					}
					elsif ( $cmd =~ m/watch (.*)\s(.*)/ ) {

						# add a file
						my $fic  = $1;
						my $rule = $2;
						if ( -e $fic ) {

							# todo : we have to check rule syntaxe
							$Toscan{$fic} = $rule;
							$fm->monitor($fic);
						}
						else {
							warning("can not monitor $fic : do not exists");
						}
					}
					elsif ( $cmd =~ m/unwatch (.*)/ ) {

						# remove a file
						my $fic = $1;
						if ( $Toscan{$fic} ) {
							$fm->cancel($fic);
							$Toscan{$fic} = 0;
						}
						else {
							warning("can not stop monitoring $fic");
						}
					}
					elsif ( $cmd eq 'monitored' ) {

						# print list of all monitored
						my @list = $fm->monitored();
						foreach my $elem (@list) {
							info("monitored : $elem");
						}
					}
					else {
						warning("(real_time) unknown command $cmd");
					}
					## use critic
				}
				next;
			}

			if ( ( $type eq 'create' ) or ( $type eq 'change' ) ) {
				$nbnew++ if ( $type eq 'create' );
				my $masq = rech_parent( $filename, \%Toscan );
				if ($masq) {

					# set scan options
					$Toscan{$filename} = $masq unless exists $Toscan{$filename};
					debug( "scan option for file $filename : $masq", 2 );
					wanted_update( $filename, $masq, undef );

					#parcours( $filename, \&wanted_update, EMPTY, undef );
				}
				else {
					warning(
						"(real_time) can not scan $filename : no rules found");
				}

			}
			elsif ( $type eq 'delete' ) {
				report_summary( 'deleted', $filename );
				$nbdelete++;

				# update database
				delete $Hashfile{$filename};
			}
			elsif (
				   ( $type eq 'start_exec' )
				or ( $type eq 'stop_exec' )
				or ( $type eq 'ack' )
				or    # do not know what is mean
				( $type    eq 'exist' )
				or ( $type eq 'end_exist' )
				or ( $type eq 'move' )
			  )       # never seen
			{
				debug("skip $type $filename");
			}
			else {
				debug("skip unknown $type $filename");
			}

		} while $fm->pending;
	}
	close_database();
	close $fh_fifo or warning("can not close fifo : $ERRNO");

	statistics( $action, $nbnew, $nbdelete );
	end_report( $database, $Update );
	return 0;
}
#######################################################
# print_dangling
# print all danglink symbolic links
sub print_dangling($) {
	my $detailed = shift @_;

	debug( "(print_dangling) begin detailed=$detailed", 1 );
	if ($Warn_dead_symlinks) {

		# warnings
		foreach my $key ( keys %Dangling ) {
			report_summary( 'Dangling', $key );
			report_detailed( 'linked_to', $Dangling{$key} ) if ($detailed);
		}
	}
	else {

		# just info
		foreach my $key ( keys %Dangling ) {
			info("Dangling file : $key");
		}
	}
	debug( '(print_dangling) end', 1 );
	return;
}

#######################################################
# a sub to return files which match the given filter
# to be used by print_dbm
sub filterdb($) {
	my $filter = shift @_;

	my @result;
	my $rhash;

	#my $key;

	# for filter, use the perl cookbook, tips 1.18
	# function alias to access data
	my @list = keys %{ get_id(undef) };
	push @list, 'name';        # add name
	push @list, 'filetype';    # add name

	# avoid warning on second call for redefine functions
	## no critic (TestingAndDebugging);
	no warnings 'redefine';

	foreach my $id (@list) {
		no strict 'refs';
		## no critic (ProhibitDoubleSigils)
		*$id = sub () { $rhash->{$id} };
	}
	## use critic

	my $code = 'sub my_filter { ' . $filter . '}';
	## no critic (StringyEval);
	## no critic (ProhibitMismatchedOperators,ProhibitUnlessBlocks)
	unless ( eval $code . 1 ) {
		warning("(filterdb) error in filter $filter : $EVAL_ERROR");
	}
	foreach my $key ( sort keys %Hashfile ) {
		$rhash = tab2hash($key);
		if ( my_filter() ) {
			push @result, $key;
		}
	}
	return @result;
}
#######################################################
# print_dbm
# print the database content
sub print_dbm($$;$) {
	my $database   = shift @_;
	my $configfile = shift @_;
	my $filter     = shift @_;

	open_database( $database, $configfile, 'print', \%Hashfile );

	# display print format
	info( 'format : filetype name' . Sep . join Sep, @{ get_field(undef) } );

	if ($filter) {

		my @res = filterdb($filter);
		my $nb  = 0;
		foreach my $key (@res) {
			report( file_type($key) . " $key" 
				  . Sep
				  . display_all( $Hashfile{$key} ) );
			$nb++;
		}
		info( 'number of file : ' . $nb . " for filter '$filter'" );
	}
	else {

		# ??? change to have same format as other ?
		foreach my $key ( sort keys %Hashfile ) {
			report( file_type($key) . " $key" 
				  . Sep
				  . display_all( $Hashfile{$key} ) );
		}
		info( 'number of file : ' . scalar keys %Hashfile );
	}
	close_database();
	return;
}
#######################################################
# print a summary or detailed info on changes
sub print_changed($) {
	my $detailed = shift @_;
	foreach my $key ( sort keys %Oldval ) {
		report_summary( 'changed', $key );
		compare_entry( $key, $Oldval{$key}, $Newval{$key} ) if ($detailed);
	}
	return;
}
#######################################################
# get a forced ctime to display inode date for new files
sub ctimef($) {
	my $key = shift @_;
	my $ctime = get_ctime($key) || ( stat $key )[10] || 0;
	return localtime $ctime;
}
#######################################################
# we display as detailed info the inode last change date
sub print_new($) {
	my $detailed = shift @_;

	# look for new files
	my $nb    = 0;
	my $nbnew = 0;
	foreach my $key ( sort keys %Newfiles ) {

		# report only if asked all ($Report_full_newdel) or first level
		if ($Report_full_newdel) {
			report_summary( 'new', $key );
			report_detailed( 'inode_date', ctimef($key) ) if ($detailed);
		}
		elsif ( $Newfiles{$key} == 1 ) {
			if ($nb) {
				report_detailed( 'number of new files', $nb );
			}
			report_summary( 'new', $key );
			report_detailed( 'inode_date', ctimef($key) ) if ($detailed);
			$nb = 0;
		}
		else {
			$nb++;
		}

		$nbnew++;
	}
	if ($nb) {
		report_detailed( 'number of new files', $nb );
	}
	return $nbnew;
}
#######################################################
# get parent mtime
sub parent_date($) {
	my $parent = shift @_;
	my $mtime = get_mtime($parent) || ( stat $parent )[9] || 0;
	return localtime $mtime;
}
#######################################################
# we display as info the date change of parent directory
sub print_delete($) {
	my $detailed = shift @_;

	my %deleted;
	my $nb       = 0;
	my $nbdelete = 0;
	foreach my $key ( sort keys %Hashfile ) {
		if ( !exists $Finded{$key} ) {

			# get directory for a file or parent directory for a directory
			my $path = dirname($key);

			if ($Report_full_newdel) {
				report_summary( 'deleted', $key );
				report_detailed( 'parent_date', parent_date($path) )
				  if ($detailed);
				$nb = 0;
			}
			else {

				#print "--- deleted $key $path";
				if ( exists $deleted{$path} ) {
					$deleted{$key} = $deleted{$path} + 1;
					$nb++;
				}
				else {
					$deleted{$key} = 1;
					if ($nb) {
						report_detailed( 'number of deleted files', $nb );
					}
					$nb = 0;
					report_summary( 'deleted', $key );
					report_detailed( 'parent_date', parent_date($path) )
					  if ($detailed);
				}
			}
			delete $Hashfile{$key} if ( $detailed and $Update );
			$nbdelete++;
		}
	}
	if ($nb) {
		report_detailed( 'number of deleted files', $nb );
	}
	return $nbdelete;
}
#######################################################
sub display_rule($$;$$) {
	my $elem    = shift @_;
	my $r_alias = shift @_;             # reverse alias
	my $prefix  = shift @_ || EMPTY;    # prefix (optionnal)
	my $suffix  = shift @_ || EMPTY;

	# resolved alias in base attributes
	debug( "(display_rule) intern $elem $Toscan{$elem}", 3 );

	## no critic (ProhibitParensWithBuiltins,ProhibitNoisyQuotes)
	my $v = join( '+', map { $r_alias->{$_} } split( //, $Toscan{$elem} ) );
	debug( "# resolved ${prefix}${elem}${suffix} $v", 2 );
	debug( "${prefix}${elem}${suffix} $Rules{$elem}", 1 );
	return;
}
#######################################################
# a low-level sub, used by get_list_dir
sub set_list_dir($$$$) {
	my $rlist_dir = shift @_;
	my $all       = shift @_;
	my $dir_name  = shift @_;
	my $dir_value = shift @_;

	if ( $all or $dir_value ) {
		## no critic (ProhibitNoisyQuotes)
		push @{$rlist_dir}, $dir_name . ':=' . $dir_value;
	}
	return;
}
#######################################################
# return an array of directives in "config" format
# used by print_env, print_config ...
sub get_list_dir($) {
	my $all =
	  shift @_;   # if true print all directives, else print only set directives

	my @list_dir;

	set_list_dir( \@list_dir, $all, 'database',           $Database );
	set_list_dir( \@list_dir, $all, 'history',            $History );
	set_list_dir( \@list_dir, $all, 'archive',            $Archive );
	set_list_dir( \@list_dir, $all, 'report_url',         get_report_url() );
	set_list_dir( \@list_dir, $all, 'report_syslog',      $Report_syslog );
	set_list_dir( \@list_dir, $all, 'verbose',            $Verbose );
	set_list_dir( \@list_dir, $all, 'debug',              get_debug_level() );
	set_list_dir( \@list_dir, $all, 'warn_dead_symlinks', $Warn_dead_symlinks );
	set_list_dir( \@list_dir, $all, 'follow_symlinks',    $Follow_symlinks );
	set_list_dir( \@list_dir, $all, 'allow_overload',     $Allow_overload );
	set_list_dir( \@list_dir, $all, 'report_full_newdel', $Report_full_newdel );
	set_list_dir( \@list_dir, $all, 'warn_missing_file',  $Warn_missing_file );
	set_list_dir( \@list_dir, $all, 'running_files',      $Running );
	set_list_dir( \@list_dir, $all, 'timing',             $Timing );
	set_list_dir( \@list_dir, $all, 'ignore_case',        $Ignore_case );
	set_list_dir( \@list_dir, $all, 'exclude_suffix',     get_exclude_sufx() );
	set_list_dir( \@list_dir, $all, 'exclude_prefix',     get_exclude_prefx() );
	set_list_dir( \@list_dir, $all, 'exclude_re',         get_exclude_re() );
	set_list_dir( \@list_dir, $all, 'only_suffix',        get_only_sufx() );
	set_list_dir( \@list_dir, $all, 'max_checksum_size',  $Max_checksum_size );
	set_list_dir( \@list_dir, $all, 'dbm',                $Dbm );

	#set_list_dir(\@list_dir, $all,  'output_format', $Output_format );
	return @list_dir;
}
#######################################################
# print internal flag state
sub print_config($$$$) {
	my $flag_directive = shift @_;
	my $flag_macro     = shift @_;
	my $flag_alias     = shift @_;
	my $flag_rule      = shift @_;

	# nothing to do if debug is not set
	return if ( get_debug_level() == 0 );

	if ($flag_directive) {

		# directives
		foreach my $elem ( get_list_dir(1) ) {
			debug( $elem, 1 );
		}
	}

	if ($flag_macro) {

		# macros
		foreach my $m ( keys %Macros ) {
			debug( "\@\@define $m $Macros{$m}", 1 );
		}
	}

	if ($flag_alias) {

		# alias
		while ( my ( $a, $v ) = each %Aliases ) {
			debug( "$a=$v", 1 ) if ( $a ne $v );
		}
	}

	if ($flag_rule) {

		# and now : the list of files to scan
		my %r_alias = reverse %Alias;

		## no critic(ProhibitNoisyQuotes)
		foreach my $elem ( keys %Toscan ) {
			if ( !$Toscan{$elem} ) {

				# negative option
				debug( "! $elem", 1 );
			}
			elsif ( exists $Onlythis{$elem} ) {
				display_rule( $elem, \%r_alias, '=' );
			}
			elsif ( exists $Onlydir{$elem} ) {
				display_rule( $elem, \%r_alias, '=', SLASH );
			}
			else {

				# normal
				display_rule( $elem, \%r_alias );
			}
		}
	}
	return;
}

#######################################################
#  print program version
sub version($) {
	my $version = shift @_;
	print "afick : another file integrity checker\nversion $version\n";
	return;
}
#######################################################
# convert an array to a hash
sub conv2hash($$) {
	my $ra_tab    = shift @_;
	my $separator = shift @_;

	my %h;
	foreach my $line ( @{$ra_tab} ) {
		if ( $line =~ m/(.*)$separator(.*)/ ) {
			my $key = $1;
			my $val = $2;
			$h{$key} = $val;
		}
	}
	return %h;
}
#######################################################
# a tool to compare 2 arrays
# the best way is to convert to hash, then compare keys
sub diff_tab($$) {

	my $r_tab1 = shift @_;
	my $r_tab2 = shift @_;

	# suppress debug lines and commented lines
	my @tab1 = grep !/^debug/, grep !/^#/, @{$r_tab1};
	my @tab2 = grep !/^debug/, grep !/^#/, @{$r_tab2};

	# convert in hash
	## no critic (ProhibitNoisyQuotes)
	my %t1 = conv2hash( \@tab1, ':=' );
	my %t2 = conv2hash( \@tab2, ':=' );
	## use critic

	my $nb_errors = 0;

	# cf perl cookbook 4.8
	foreach my $key ( keys %t1 ) {
		if ( exists $t2{$key} ) {

			# same key : check val
			if ( $t1{$key} ne $t2{$key} ) {
				warning(
					"(control) directives $key change : $t1{$key} -> $t2{$key}"
				);
				$nb_errors++;
			}
		}
		else {

			# old key was suppressed
			warning(
				"(control) directives $key (" . $t1{$key} . ') was removed' );
			$nb_errors++;
		}
	}
	foreach my $key ( keys %t2 ) {
		if ( !exists $t1{$key} ) {

			# find a new key
			warning(
				"(control) directives $key (" . $t2{$key} . ') was added' );
			$nb_errors++;
		}
	}

	return !$nb_errors;
}
#######################################################
# read database previous checksum and compare with new one
sub read_control($) {
	my $database     = shift @_;
	my $control_file = $database . Control_ext;

	my ( $oldchecksum, $old_version, $run_date );
	my @old_dir;
	my $fh_control;
	## no critic (RequireBriefOpen)
	if ( open $fh_control, '<', $control_file ) {

		my $line1 = <$fh_control>;
		if ( $line1 =~ m/#format=/ ) {

			# new format
			@old_dir = <$fh_control>;
			chomp @old_dir;

			foreach my $elem (@old_dir) {
				## no critic (ProhibitCascadingIfElse)
				if ( $elem =~ m/#checksum=(.*)/ ) {
					$oldchecksum = $1;
				}
				elsif ( $elem =~ m/#version=(.*)/ ) {
					$old_version = $1;
				}
				elsif ( $elem =~ m/#date=(.*)/ ) {
					$run_date = $1;
				}
				elsif ( $elem =~ m/#database_type=(.*)/ ) {
					$Dbm = $1;
				}
			}
		}
		else {

			# old format
			$oldchecksum = $line1;
			chomp $oldchecksum;
			$old_version = <$fh_control>;
			chomp $old_version if ( defined $old_version );
			$run_date = <$fh_control>;
			chomp $run_date if ( defined $run_date );
			$Dbm = 'SDBM_File';
		}
		close $fh_control
		  or warning(
			"(control) can not close control file $control_file : $ERRNO");

		$Database_ext = get_database_ext($Dbm);
		$Database_idx = get_database_idx($Dbm);

		# check if database exists
		my $fulldatabase = $database . $Database_ext;
		if ( !-f $fulldatabase ) {
			my_die("can not find database : $fulldatabase");
		}

		# database checksum control
		my $newchecksum = md5sum( $fulldatabase, 0, 0 );
		warning(
			"(control) internal change in afick database $database (see below)"
		) if ( $oldchecksum ne $newchecksum );

		# directives control
		my @new_dir = get_list_dir(1);
		chomp @new_dir;
		diff_tab( \@old_dir, \@new_dir ) if (@old_dir);

		# database type controls
		test_dbm($Dbm);

		# date control
		# warning if last run is too late
		# compute difference between @Date and $run_date
	}
	else {
		warning("(control) can not read control file $control_file : $ERRNO");
	}
	return ( $old_version, $run_date );
}
#######################################################
# write database checksum for next run
sub write_control ($$) {
	my $checksum = shift @_;    # the string to write
	my $database = shift @_;

	my $control_file = $database . Control_ext;

	# to avoid Tainted warnings
	#$control_file = $1 if ( $control_file =~ m/(.+)/ );

	my $fh_control;
	if ( open $fh_control, '>', $control_file ) {

		#old format
		#print $fh_control "$checksum". LF;               # database checksum
		#print $fh_control "$Version" .LF;                # afick version
		#print $fh_control strftime( $Datefmt, @Date ) . LF;    # date of run

		# new format
		print {$fh_control} '#format=2' . LF;
		print {$fh_control} "#checksum=$checksum" . LF;    # database checksum
		print {$fh_control} "#version=$Version" . LF;      # afick version
		print {$fh_control} "#date=$Date" . LF;            # date of run
		print {$fh_control} "#database_type=$Dbm" . LF;    # database type
		                                                   # directives
		foreach my $elem ( get_list_dir(1) ) {
			print {$fh_control} $elem . LF;
		}

		close $fh_control
		  or warning(
"(write_control) can not close in control file $control_file : $ERRNO"
		  );

		# restrict permissions
		chmod Strict_perm, $control_file;
	}
	else {
		warning(
"(write_control) can not write in control file $control_file : $ERRNO"
		);
	}
	return;
}
#######################################################
# compare old and entry for afick main components
sub control($$) {
	my $name = shift @_;    # file name to control
	my $type = shift @_;    # type of file

	# get old entry
	my $old_entry = $Hashfile{$name};
	if ( !defined $old_entry ) {

		# first run
		warning("(control) detect a new afick $type : $name");
	}
	else {

		# compute the new entry
		my $new_entry = file_info( $name, $Toscan{$name} );

		if ( $old_entry ne $new_entry ) {
			warning(
				"(control) afick internal change : $type $name (see below)");
			debug( "(control) old_entry=$old_entry new_entry=$new_entry", 3 );
		}
	}
	return;
}
#######################################################
# check if afick change since last run
sub calc_control($) {
	my $configfile = shift @_;

	# programs
	my @list = get_names($Ignore_case);
	foreach my $elem (@list) {
		control( $elem, 'program' );    # afick.pl, afick-tk.pl, ...
	}

	# config file
	if ($Ignore_case) {
		$configfile = lc $configfile;
	}
	control( $configfile, 'config' );    # config file

	return;
}
#############################################################
sub open_archive() {
	debug( '(open_archive)', 3 );
	if ($Archive) {

		if ( !-d $Archive ) {
			warning(
				"(open_archive) archive directory $Archive does not exists");
		}
		else {

			# open archive file
			my $archive_file = $Archive . '/afick.' . reports_date(@Date);

			## no critic (RequireBriefOpen)
			# $Archive . '/afick.' . strftime( '%Y%m%d%H%M%S', @Date );
			if ( !open $Archive_df, '>', $archive_file ) {
				warning(
"(open_archive) can not open archive file $archive_file : $ERRNO"
				);
			}
			else {
				debug( "(open_archive) file $archive_file", 1 );
			}
		}
	}
	return;
}
#######################################################
sub close_archive() {
	if ($Archive_df) {
		close $Archive_df or warning("can not close archive : $ERRNO");
	}
	return;
}
#######################################################
# generic display sub to be called by stat_secu
sub display_group($@) {
	my $text  = shift @_;
	my @group = @_;

	info( "$text : " . scalar @group );
	foreach my $key (@group) {
		my @tab = split_record( $Hashfile{$key} );
		report( file_type($key) . " $key" 
			  . Sep
			  . display( get_id('filemode'), \@tab )
			  . LF );
	}

	return;
}
#######################################################
# display info on specific files from database
sub stat_secu($$) {
	my $database   = shift @_;
	my $configfile = shift @_;

	open_database( $database, $configfile, 'stat', \%Hashfile );

	my @suid;
	my @sgid;
	my @gwrite;
	my $gwriteflag = oct 20;
	my @world;
	my $worldflag = oct 2;
	my @uid_orphan;
	my @gid_orphan;

	# get uid and gid
	#################

	my %Uid;

	while ( my ( $name, undef, $uid ) = getpwent ) {
		$Uid{$uid} = $name;
	}

	my %Gid;
	while ( my ( $name, undef, $gid ) = getgrent ) {
		$Gid{$gid} = $name;
	}

	# analyse datas
	################
	# use of filterdb is much longer
	# and I have problems with test of symbolic links
	#@world = filterdb( '(filemode & 02) and  ! (filemode & S_IFLNK) ');
	#@gwrite = filterdb( '(filemode & 020) and  ! (filemode & S_IFLNK)');
	#@suid   = filterdb( 'filemode & S_ISUID ');
	#@sgid   = filterdb( 'filemode & S_ISGID ');

	# so just a classic loop
	foreach my $key ( sort keys %Hashfile ) {
		my $fmode = get_filemode($key);
		next if ( S_ISLNK($fmode) );
		if ( $fmode & $worldflag ) {
			push @world, $key;
		}
		if ( $fmode & $gwriteflag ) {
			push @gwrite, $key;
		}
		if ( is_type( $fmode, S_ISUID() ) ) {
			push @suid, $key;
		}
		if ( is_type( $fmode, S_ISGID() ) ) {
			push @sgid, $key;
		}
		if ( !exists $Uid{ get_data( $key, 'uid' ) } ) {
			push @uid_orphan, $key;
		}
		if ( !exists $Gid{ get_data( $key, 'gid' ) } ) {
			push @gid_orphan, $key;
		}
	}

	# display
	display_group( 'suid files',            @suid );
	display_group( 'sgid files',            @sgid );
	display_group( 'group writables files', @gwrite );
	display_group( 'world writables files', @world );
	display_group( 'orphan uid',            @uid_orphan );
	display_group( 'orphan gid',            @gid_orphan );

	close_database();
	return;
}
#######################################################
sub stat_size($$) {
	my $database   = shift @_;
	my $configfile = shift @_;

	open_database( $database, $configfile, 'stat', \%Hashfile );

	my %size;

	# analyse datas
	foreach my $key ( sort keys %Hashfile ) {
		my $fmode = get_filemode($key);
		next if ( S_ISLNK($fmode) );
		my $size = get_filesize($key);
		my $l = $size ? length $size : 0;
		if ( exists $size{$l} ) {
			$size{$l}++;
		}
		else {
			$size{$l} = 1;
		}
	}

	# results
	info('size interval : number of files');
	foreach my $elem ( sort { $a <=> $b } keys %size ) {

		#info("size 10**$elem : $size{$elem}");
		if ( $elem == 0 ) {
			info("0 :  $size{$elem}");
		}
		else {
			info(
				sprintf '%d-%d : %d',
				10**( $elem - 1 ),
				10**($elem) - 1,
				$size{$elem}
			);
		}
	}

	close_database();
	return;
}
#######################################################
sub stat_ext($$) {
	my $database   = shift @_;
	my $configfile = shift @_;

	open_database( $database, $configfile, 'stat', \%Hashfile );

	# analyse datas
	my %ext;
	foreach my $key ( sort keys %Hashfile ) {

		# search for suffix
		if ( $key =~ m/\.(\w+)$/ ) {
			my $suffix = $1;
			if ( exists $ext{$suffix} ) {
				$ext{$suffix}++;
			}
			else {
				$ext{$suffix} = 1;
			}
		}
	}

	# results
	foreach my $key ( sort { $ext{$a} <=> $ext{$b} } keys %ext ) {
		info("$key : $ext{$key} ");
	}

	close_database();
	return;
}
#############################################################
#                          main
#############################################################
# for file type macros : the POSIX module contains all standard defines macros
# others (links, sockets) may be loaded from Fcntl (tag :mode), cf man perlfunc
# but are not all defined on windows for example

my $default_config_file = get_default_config();
if ( is_microsoft() ) {

	# for acl list
	eval { require Win32::FileSecurity };
	if ($EVAL_ERROR) {
		warning("perl module Win32::FileSecurity not found : $EVAL_ERROR");

		# will work but without acl
		$Acl_exist = 0;
	}
	else {
		$Acl_exist = 1;
	}

	require POSIX;
	import POSIX ':sys_stat_h';    # to get S_ constants

	# define some macros not in POSIX module,
	# set, but not defined in Fcntl module
	# but needed : used in the code
	*S_ISSOCK = sub { return 0 };
	*S_ISLNK  = sub { return 0 };
}
else {

	# unix/linux

	# get socket and link macros
	require Fcntl;
	import Fcntl ':mode';    # for file type macros
}

# buffer
$OUTPUT_AUTOFLUSH = 1;

# var for get options
my $opt_clean_config;
my $opt_check_config;
my $opt_check_update;
my $opt_compare;
my $opt_configfile;          # config file name
my $opt_help;
my $opt_man;
my $opt_init;
my $opt_list;
my $opt_print;
my $opt_print_all_config;
my $opt_print_directive;
my $opt_print_macro;
my $opt_print_alias;
my $opt_print_rule;
my $opt_search;
my $opt_stat_secu;
my $opt_stat_size;
my $opt_stat_ext;
my $opt_version;

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

		# directives
		'allow_overload|o!'     => \$Allow_overload,
		'archive|A=s'           => \$Archive,
		'database|D=s'          => \$Database,
		'debug|d=i'             => \$Debug_level,
		'only_suffix=s'         => \$OnlySufx,
		'exclude_suffix|x=s'    => \$Sufx,
		'exclude_prefix|X=s'    => \$Prefx,
		'exclude_re|R=s'        => \$Exclude_re,
		'follow_symlinks|Y!'    => \$Follow_symlinks,
		'full_newdel|f!'        => \$Report_full_newdel,
		'history|y=s'           => \$History,
		'ignore_case|a!'        => \$Ignore_case,
		'max_checksum_size|S=i' => \$Max_checksum_size,
		'missing_files|m!'      => \$Warn_missing_file,
		'report_url=s'          => \$Report_url,
		'report_syslog!'        => \$Report_syslog,

		#'dbm|b=s'               => \$Dbm,
		#'output_format|o=s'  => \$Output_format,
		'running_files|r!' => \$Running,
		'dead_symlinks|s!' => \$Warn_dead_symlinks,
		'timing|t!'        => \$Timing,
		'verbose|v!'       => \$Verbose,

		# config
		'config_file|c=s' => \$opt_configfile,
		'progress|P'      => \$Progress,

		#'real_time'          => \$Real_time,

		# actions
		'check_config|C'  => \$opt_check_config,
		'check_update|U!' => \$opt_check_update,
		'clean_config|G'  => \$opt_clean_config,
		'help|?'          => \$opt_help,
		'man'             => \$opt_man,
		'init|i'          => \$opt_init,
		'compare|k'       => \$opt_compare,
		'list|l=s'        => \$opt_list,
		'search=s'        => \$opt_search,
		'print|p'         => \$opt_print,
		'print_config'    => \$opt_print_all_config,
		'print_directive' => \$opt_print_directive,
		'print_macro'     => \$opt_print_macro,
		'print_alias'     => \$opt_print_alias,
		'print_rule'      => \$opt_print_rule,
		'version|V'       => \$opt_version,
		'update|u'        => \$Update,

		# plugins
		'stat_ext'  => \$opt_stat_ext,
		'stat_secu' => \$opt_stat_secu,
		'stat_size' => \$opt_stat_size,
	)
  )
{
	pod2usage(2);
}

## no critic (ProhibitCascadingIfElse)
if ($opt_help) {

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

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

	# -U : check if new version
	check_update( 'afick', $Version );
	exit;
}

if ($opt_configfile) {

	# convert in absolute path

	$opt_configfile = to_abspath($opt_configfile);
	debug( "config file : $opt_configfile", 2 );
}
elsif ( -e $default_config_file ) {
	$opt_configfile = $default_config_file;
}
else {

	pod2usage(
"missing opt_configfile name (-c flag) and default config file $default_config_file"
	);
}

# parse config file
my $nb_pbs = 0;

# need to be set before read_configuration because change listerep
$File = 1 if ($opt_list);

# list of files from config file
my @listerep =
  read_configuration( $opt_configfile, \%Alias, \$nb_pbs, $opt_clean_config );

# todo : convert global variables for directives into hash table
# ex :
$Directives{'timing'} = $Timing;

if ( ($opt_check_config) or ($opt_clean_config) ) {
	if ($nb_pbs) {
		warning("find $nb_pbs errors in config file $opt_configfile");
	}
	else {
		info("config file $opt_configfile ok");
	}
	exit $nb_pbs;
}

# change priority
# test for NICE macro
if ( ( not is_microsoft() ) and ( exists $Macros{NICE} ) ) {
	setpriority 0, 0, $Macros{NICE};
	debug( "change priority to $Macros{NICE}", 2 );
}

if ($opt_print_all_config) {
	$opt_print_directive = 1;
	$opt_print_macro     = 1;
	$opt_print_alias     = 1;
	$opt_print_rule      = 1;
}

if (   $opt_print_directive
	or $opt_print_macro
	or $opt_print_alias
	or $opt_print_rule )
{

	# force print and exit
	$Debug_level = 1;
	print_config(
		$opt_print_directive, $opt_print_macro,
		$opt_print_alias,     $opt_print_rule
	);
	exit;
}
else {

	# print in debug mode
	print_config( 1, 1, 1, 1 );
}

# the scan will be dated with date of program begin
my $date_ref = $BASETIME;
@Date = localtime $date_ref;
$Date = history_date(@Date);

# no we should have a database name
if ( !$Database ) {

	#usage($Version);
	pod2usage(
"missing database name in options (-D) and in config file $opt_configfile"
	);
}

# signal trapping
$SIG{'INT'}  = \&signal_handler;
$SIG{'QUIT'} = \&signal_handler;
$SIG{'TERM'} = \&signal_handler;
$SIG{'HUP'}  = 'IGNORE';

my $return_value = 0;

# actions
## no critic (ProhibitCascadingIfElse)
if ($opt_list) {

	# -l : list
	#$File         = 1;
	## no critic (ProhibitEmptyQuotes)
	foreach my $elem ( split ' ', $opt_list ) {
		my $ret = rech_parent( $elem, \%Toscan );
		if ($ret) {

			# add to the list
			push @listerep, $elem;

			# set scan options
			$Toscan{$elem} = $ret unless exists $Toscan{$elem};
			debug( "scan option for file $elem : $ret", 2 );
		}
		else {
			warning("can not scan $elem : no rules found");
		}
	}
	$return_value = update( $Database, $opt_configfile, \@listerep );
}
elsif ($opt_print) {

	# -p : print
	print_dbm( $Database, $opt_configfile );
}
elsif ($opt_search) {

	# -p : print
	print_dbm( $Database, $opt_configfile, $opt_search );
}
elsif ($opt_init) {

	# -i : init
	open_archive();
	create( $Database, $opt_configfile, \@listerep );
}
elsif ($Real_time) {
	open_archive();
	$return_value = real_time( $Database, $opt_configfile, \@listerep );
}
elsif ($Update) {

	# -u : update
	open_archive();
	$return_value = update( $Database, $opt_configfile, \@listerep );
}
elsif ($opt_compare) {

	# -k : check
	open_archive();
	$return_value = update( $Database, $opt_configfile, \@listerep );
}

elsif ($opt_stat_ext) {
	stat_ext( $Database, $opt_configfile );
}
elsif ($opt_stat_secu) {
	stat_secu( $Database, $opt_configfile );
}
elsif ($opt_stat_size) {
	stat_size( $Database, $opt_configfile );
}
else {

	# problem : print doc
	pod2usage('no action to do (-i, -u, -k, -l, -p)');
}
## use critic

# timing info
if ($Timing) {
	my ( $user, $system, $cuser, $csystem ) = times;
	info( "user time : $user; system time : $system; real time : "
		  . ( time - $BASETIME ) );
}

close_archive();
close_syslog();

exit $return_value;
## no critic (UnreachableCode);

__END__

=head1 NAME

afick - Another File Integrity Checker

=head1 DESCRIPTION

The goal of this program is to monitor what change on your host : new/deleted/modified files.
So it can be used as an intrusion detection system ( by integrity checking ).
It is designed to be a portable clone of aide (Advanced Intrusion Detection Environment), or Tripwire software.

You should launch it regularly (by cron for example) and after any software change.

This is a command-line program, you can use C<afick-tk.pl> if you
prefer a graphical interface.

=head1 SYNOPSIS

afick [L<action|actions>] [L<options|options>]

afick use posix syntax, which allow many possibilities : 

=over 4

=item *
long (--) options

=item *
short (-) options

=item *
negative (--no) options

=back

Mandatory action (one and only one must be used) : 

 -i|--init                    initialize the hash.dbm database
 -C|--check_config	      only check config file and exit
 -G|--clean_config            check and clean configuration, then exit
 -U|--check_update            check if a software update is available
 -k|--compare                 compare the hash.dbm database
 -l|--list fic1 .. fic2       check the files given in arg 
 -u|--update                  compare and update the hash.dbm database
 -p|--print                   print content of database
 --search filter              print content of database, filtered (see man of html doc for exemples)
 --print_config               display all internals variables after arguments and config file parsing.
 			      it is the same as the 4 followings options, concatenated
 				(for debugging purposes)
 --print_directive	      display directives (after config file and command line parsing)
 --print_macro		      display macros (after config file parsing)
 --print_alias	              display aliases (after config file parsing)
 --print_rule		      display rules (after config file parsing)
 --stat_ext		      display list of file extension, sorted by number (usefull for windows)
 --stat_secu		      display from databases some dangerous files (suid, sgid, group writable, world writable )
 --stat_size		      display from databases statistics on file size

Other options

 -a|--ignore_case             helpful on Windows platforms, dangerous on Unix ones
 				reverse : --noignore_case
 -c|--config_file file        name of config file to use
 -D| --database file          force the database name    
 -d|--debug level	      set a level of debugging messages, from 0 (none) to 4 (full)
 -f|--full_newdel             report full information for new or deleted directories
			       reverse : --nofull_newdel 
 -m|--missing_files           warn about files declared in config files 
                               which do not exists, 
			       reverse : --nomissing_files
 -o|--allow_overload          allow rule overload : the last rule wins
                               reverse: --noallow_overload
 -r|--running_files           warn about "running" files : modified since program begin
                               reverse: --norunning_files
 -s|--dead_symlinks           warn about dead symlinks 
                               reverse: --nodead_symlinks
 -Y|--follow_symlinks         checksum on links target file (yes) or checksum on target name (no)
                               reverse: --nofollow_symlinks
 -S|--max_checksum_size	size  maximum cheksum size (bytes) : for bigger file, just compute checksum on begin of file
 				0 means no limit
 -t|--timing		      Print timing statistics
				reverse : --notiming
 -v|--verbose                 toggle verbose mode (identical to full debug);
 			       reverse : --noverbose
 -P|--progress		      display the name of scanned files, to be used only by afick-tk
 -h|--help                    show this help page
 --man			      full help
 -V|--version                 show afick version
 -x|--exclude_suffix "ext1 ext2"        list of file/dir suffixes to ignore
 -X|--exclude_prefix "pre1 pre2"        list of files/dir prefixes to ignore
 -R|--exclude_re "patern1 patern2"      list of files/dir patterns (regular expressions) to ignore
 --only_suffix "ext1 ext2"              list of suffix to scan (just this ones)
 -y|--history file	      history file of all runs with summary
 -A|--archive directory	      directory where archive files are stored
 --report_url output	      where to send afick report.default is stdout
 --report_syslog 	      send afick report to sylog. reverser : --noreport_syslog

=head1 REQUIRED ARGUMENTS

=head1 ACTIONS

You have to use one this mandatory action :

=over 4

=item B<--init|-i>

initiate the database.

=item B<--check_config|-C>

only check config file syntax and exit with the number of errors

=item B<--check_update|-U>

check if a new software version is available on web server

=item B<--clean_config|-G>

check config file syntax, clean (comments) bad line, and exit with the number of errors

=item B<--compare|-k>

compare the file system with the database.

=item B<--list|-l "file1 file2 ... filen">

compare the specified files with the database.

=item B<--print|-p>

print the content of the database.

=item B<--search your_filter>

print the content of the database, filtered by your_filter filter.

filters are to be written with column keywords and perl operators, and should be quoted

keywords are :  filetype, name, md5, sha1, checksum, device, inode, filemode, links, uid, acl, gid, filesize, blocs, atime, mtime, ctime

for examples :

"filetype =~ m/symbolic/"  : filter on file type

"filesize E<lt>  5000000" : filter on file size

"filemode & 04000" : extract suid files

"(filesize E<gt>  5000) and (name =~ m/urpmi/)" : you can combine filters

=item B<--print_config>

display all internals variables after command line and config file parsing (for debugging purposes).
It is the same as the 4 following options : --print_directive --print_macro --print_alias --print_rule

=item B<--print_directive>

display directives (after config file and command line parsing)

=item B<--print_macro>

display macros (after config file parsing)

=item B<--print_alias>

display aliases (after config file parsing)

=item B<--print_rule>

display rules (after config file parsing)

=item B<--update|-u>

compare and update the database.

=item B<--stat_ext>

display list of file extension, sorted by number (usefull for windows)

=item B<--stat_secu>

display from databases some dangerous files (suid, sgid, group writable, world writable )

=item B<--stat_size>

display from databases statistics on file size

can help to configure the max_checksum_size option

=back

=head1 OPTIONS

You can use any number of the following options :

=over 4

=item B<--archive|-A directory>

write reports to "directory".

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

read the configuration in config file named "configfile".

=item B<--database|-D name>

name of database to use.

=item B<--debug|-d level>

set a level of debugging messages, from 0 (none) to 4 (full)

=item B<--full_newdel|-f,(--nofull_newdel)>

(do not) report full information on new and deleted directories.

=item B<--help|-h>

Output summary help information and exit.

=item B<--man>

Output full help information and exit.

=item B<--history|-y historyfile>

write session status to history file

=item B<--ignore_case|-a>

ignore case for file names. Can be helpful on Windows operating systems, but is dangerous on Unix ones.

=item B<--max_checksum_size|-S size>

fix a maximum size (bytes) for checksum. on bigger files, compute checksum only on first 'size' bytes.
( 0 means no limit)

=item B<--missing_files|-m,(--nomissing_files)>

(do not) warn about files declared in config files which does not exists.

=item B<--dead_symlinks|-s,(--nodead_symlinks)>

(do not) warn about dead symlinks.

=item B<--follow_symlinks,(--nofollow_symlinks)>

if set, do checksum on target file, else do checksum on target file name.

=item B<--allow_overload,(--noallow_overload)>

if set, allow rule overload (the last rule wins), else put a warning and keep the first rule.

=item B<--progress|-P>

display the name of scanned files, to be used only by afick-tk

=item B<--running_files|-r,(--norunning_files)>

(do not) warn about "running" files : modified since program begin.

=item B<--timing|-t,(--notiming)>

(do not) Print timing statistics.

=item B<--version|-V>

Output version information and exit.

=item B<--verbose|-v,(--noverbose)>

(not in) verbose mode (obsolete).

=item B<--only_suffix|-x "ext1 ext2 ... extn">

list of suffix to scan (just this ones)

=item B<--exclude_suffix|-x "ext1 ext2 ... extn">

list of suffixes (files/directories ending in .ext1 or .ext2 ...) to ignore

=item B<--exclude_prefix|-X "pre1 pre2 ... pren">

list of prefix (files/directories beginning with pre1 or pre2 ...) to ignore

=item B<--exclude_re|-R "pre1 pre2 ... pren">

list of patterns (regular expressions) to ignore files or directories

=item B<--report_url output>

output can stdout, stderr or null (which mean no output)

=item B<--report_syslog (--noreport_syslog)>

send (or not) afick's report to syslog. the priority is 'notice' for info messages,
'warning' for warning messages. The facility is 'user'

=back

=head1 FILES

if no config file on command line, afick try to open F</etc/afick.conf> (Unix) or F<windows.conf> (Windows) as
default config

for config file syntax see afick.conf(5)

afick uses a "control file" too. It has the name of the database, with
'.ctr' suffix.

=head1 DATABASE

until release 2.9, the database backend was SDBM, because
it was the only one available on every operating system.

Coming with 2.10 release, afick can use other database backend : the 'best'
available one will be detected on init.
There is no way to migrate an existing SDBM base to a new format. The only way 
is to re-run afick in init mode (caution : changes since last update will be "lost")

=head1 USAGE

To use this program, you must

first adjust the config file to your needs :
see afick.conf(5) for the syntax)

then initiate the database with :
C<afick -c afick.conf --init>

then you can compare with
C<afick -c afick.conf -k>

or compare and update with
C<afick -c afick.conf --update>


=head1 ENVIRONMENT

The default config file can be set with AFICK_CONFIG environment variable.

=head1 RETURN VALUES

An exit status of 0 means no differences were found, and no dangling links 
(if the warn_dead_symlinks option is set) , non-zero means
some differences were found or some dangling links. 
The non-zero value is a bitmap representing the type of difference found:

=over 4

=item Bit 0 ( value : 1)

Dangling

=item Bit 1 (value : 2)

Changed

=item Bit 2 (value : 4)

Deleted

=item Bit 3 (value : 8)

New

=back

=head1 SECURITY

For a better security, afick not only check the rules from configuration file,
but try to check it-self : perl scripts, configuration file, database, and warn
if something change.

=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 configuration file
<a href="afick-tk.1.html">afick-tk(1)</a> for graphical interface
<a href="afickonfig.1.html">afickonfig(1)</a> for a tool to change afick's configuration file
<a href="afick_archive.1.html">afick_archive(1)</a> for a tool to manage archive's reports

=for man
\fIafick.conf\fR\|(5) for configuration file
.PP
\fIafick\-tk\fR\|(1) for graphical interface
.PP
\fIafickonfig\fR\|(1) for a tool to change afick's configuration file
.PP
\fIafick_archive\fR\|(1) for a tool to manage archive's reports

=head1 DIAGNOSTICS

=head1 EXIT STATUS

=head1 CONFIGURATION

=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
