#!/usr/bin/perl -w 
###############################################################################
#   afick_common.pl
#      it's a part of the afick project
#
#    Copyright (C) 2002-2004 by Eric Gerbier
#    Bug reports to: gerbier@users.sourceforge.net
#    $Id: afick-common.pl 1227 2009-01-08 09:18:48Z 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.
#
###############################################################################
# common sub and var for afick's tool
###############################################################################
# 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

use strict;
use warnings;

use English qw(-no_match_vars);
use POSIX qw(strftime);

###############################################################################
# constants
my $EMPTY = q{};
my $SPACE = q{ };
my $SLASH = q{/};

###############################################################################
# default values for configuration directives

# temporary, values can be shared to be used by read_configuration (afick.pl)
## no critic (ProhibitPackageVars)
use vars qw( $Verbose );

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

$debug_def              = 0;
$verbose_def            = 0;
$warn_dead_symlinks_def = 0;
$report_full_newdel_def = 0;
$warn_missing_file_def  = 0;
$running_files_def      = 0;
$timing_def             = 0;
$follow_symlinks_def    = 0;
$allow_overload_def     = 1;
$ignore_case_def        = 0;
$max_checksum_size_def  = 0;
$exclude_prefix_def     = $EMPTY;
$exclude_suffix_def     = $EMPTY;
$exclude_re_def         = $EMPTY;
$only_suffix_def        = $EMPTY;
$archive_def            = $EMPTY;
$history_def            = $EMPTY;
$report_url_def         = 'STDOUT';
$report_syslog_def      = 0;

###############################################################################
{

	# alias table
	# contains pre-defined values
	my %alias = (

		# unitary values
		a => 'a',    # atime
		b => 'b',    # blocks
		c => 'c',    # ctime
		d => 'd',    # device
		g => 'g',    # gid
		i => 'i',    # inode
		m => 'm',    # mtime

		#	h    => '5',              # md5 hash by default (compatibility)
		md5  => '5',    # md5 hash
		sha1 => '1',    # sha1
		n    => 'n',    # number of links
		p    => 'p',    # permissions
		u    => 'u',    # uid
		s    => 's',    # size

		# real aliases (combined values)
		all => 'pdinugsbmc5',    # all except a
		R   => 'pdinugsmc5',     # aide compatibility
		L   => 'pdinug',         # aide compatibility
		P   => 'ugpsn5',
		E   => $SPACE,           # aide compatibility
	);

	sub get_default_alias() {
		return %alias;
	}

}

###############################################################################
{

	# debug max level
	my $max_debug = 4;

	sub max_debug() { return $max_debug; }
}
###############################################################################
{

# a block to store error messages
# to be used like errno
# if a subroutine return undef, it set a message error to be retrieved by get_error
# (a call to get_error reset error message)

	# a "private" var (in a block)
	my $empty = q{};
	my $error = $empty;

	sub set_error($) {
		$error = shift @_;
		return;
	}

	sub get_error() {
		my $msg = $error;

		# reset error
		$error = $empty;
		return $msg;
	}
}
###############################################################################
sub is_linux() {
	return ( $OSNAME =~ m/linux/i );
}
###############################################################################
sub is_microsoft() {
	return ( $OSNAME =~ m/^MSWin/i );
}
#######################################################
# return a file name with full path (not relative)
sub to_abspath($) {
	my $elem = shift @_;

	# a test to avoid loosing time
	if ( $elem !~ m/^\// ) {
		my ( $name, $path, undef ) = fileparse($elem);
		return abs_path($path) . $SLASH . $name;
	}
	else {
		return $elem;
	}
}
###############################################################################
# return default config file according operating system
# environment variable
sub get_default_config() {
	my $default_config_file;

	if ( exists $ENV{AFICK_CONFIG} ) {
		$default_config_file = $ENV{AFICK_CONFIG};
	}
	elsif ( is_linux() ) {
		$default_config_file = '/etc/afick.conf';
	}
	elsif ( is_microsoft() ) {
		$default_config_file = 'windows.conf';
	}
	else {
		$default_config_file = 'afick.conf';
	}

	return ( -r $default_config_file ) ? $default_config_file : $EMPTY;
}
#######################################################
# default subroutines : for program which does not
# provide their own version
#######################################################
sub info_def($) {
	my $msg = shift @_;
	print "# $msg\n";
	return;
}
if ( !defined &main::info ) {
	*info = \&info_def;
}
#######################################################
# debug(message, level)
# we use here a global variable (BAD) : Verbose
# to be set in main program by the line
# use vars qw( $Verbose);
sub debug_def($;$) {
	my $msg = shift @_;
	my $level = shift @_ || $EMPTY;

	## no critic (ProhibitPackageVars)
	print "DEBUG$level: $msg\n" if ($main::Verbose);
	## use critic
	return;
}
if ( !defined &main::debug ) {
	*debug = \&debug_def;
}
#######################################################
sub warning_def($) {
	my $msg = shift @_;
	warn "WARNING: $msg\n";
	return;
}
if ( !defined &main::warning ) {
	*warning = \&warning_def;
}
#######################################################
# remove_trailing blanks
# syntaxe : remove_trailing_spaces(\$var)
sub remove_trailing_spaces ($) {
	my $r_val = shift @_;    # ref to var to clean

	${$r_val} =~ s/^\s+//;
	${$r_val} =~ s/\s+$//;

	return ${$r_val};
}
#######################################################
# remove all spaces in a string
# syntaxe : remove_all_spaces(\$var)
sub remove_all_spaces ($) {
	my $r_val = shift @_;

	${$r_val} =~ s/\s+//g;

	return ${$r_val};
}
###############################################################################
# read config file and have some cleaning
sub read_config($$) {
	my $configfile = shift @_;    # config file name
	my $ra_config  = shift @_;    # array to store config lines

	if ( !$configfile ) {
		set_error('(read_config) no config file');
		return;
	}
	elsif ( open my $fh_config, '<', $configfile ) {
		while ( my $ligne = <$fh_config> ) {

			# normalize config line
			chomp $ligne;
			remove_trailing_spaces( \$ligne );
			push @{$ra_config}, $ligne;
		}
		close $fh_config
		  or set_error("(read_config) can not close $configfile : $ERRNO");
		return 1;
	}
	else {
		set_error("(read_config) can not open $configfile : $ERRNO");
		return;
	}
}
###############################################################################
# write to a config file
sub write_config($$) {
	my $configfile = shift @_;    # config file name
	my $ra_config  = shift @_;    # array containing config lines

	if ( open my $fh_config, '>', $configfile ) {
		foreach my $ligne ( @{$ra_config} ) {
			print {$fh_config} $ligne . "\n";
		}
		close $fh_config or set_error("can not close $configfile : $ERRNO");
		return 1;
	}
	else {
		set_error("can not write to $configfile : $ERRNO");
		return;
	}
}
###############################################################################
# patterns for following config line tests

## no critic (RequireInterpolationOfMetachars)
my $macro_pattern = '^\@\@define\s+(\w+)\s*(.*)';    # @@define name val
## use critic
my $alias_pattern     = '^(\w+)\s*=\s*(.*)';         # name = val
my $directive_pattern = '^(\w+)\s*:=\s*(.*)';        # name := val

my $negsel_pattern   = '^!\s*(.*)';                  # ! ligne
my $equalsel_pattern = '^=\s*(.*)';                  # = ligne
my $anysel_pattern   = '^[=!]?\s*(.*)';              # [!/=] ligne
my $file_pattern1    = '^"(.+)"\s*(.*)';             # "name with blanks" val
my $file_pattern2    = '^(\S+)\s*(.*)';              # name val

###############################################################################
# all test pattern return :
# an empty array is not match
# an array of 2 values if match
###############################################################################
# low-level sub, to be called by is_macro, is_alias ...
sub test_pattern ($$) {
	my $ligne   = shift @_;                          # string to be tested
	my $pattern = shift @_;                          # motif pattern

	if ( $ligne =~ m/$pattern/ ) {

		#print "found $1 : $2\n";
		return ( $1, $2 );
	}
	else {
		return ();
	}
}
###############################################################################
sub is_macro($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_macro ";

	return test_pattern( $ligne, $macro_pattern );
}
###############################################################################
sub is_alias($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_alias ";
	return test_pattern( $ligne, $alias_pattern );
}
###############################################################################
sub is_directive($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_directive ";
	return test_pattern( $ligne, $directive_pattern );
}
###############################################################################
sub is_file($) {
	my $ligne = shift @_;    # string to be tested

	if ( $ligne =~ m/$file_pattern1/o ) {

		#print "file pattern1 $1 : $2\n";
		return ( $1, $2 );
	}
	elsif ( $ligne =~ m/$file_pattern2/o ) {

		#print "file pattern2 $1 : $2\n";
		return ( $1, $2 );
	}
	else {
		return ();
	}
}
###############################################################################
sub is_negsel($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_negsel ";
	my @ret = test_pattern( $ligne, $negsel_pattern );
	if (@ret) {
		return is_file( shift @ret );
	}
	else {
		return ();
	}
}
###############################################################################
sub is_equalsel($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_equalsel ";
	my @ret = test_pattern( $ligne, $equalsel_pattern );
	if (@ret) {
		return is_file( shift @ret );
	}
	else {
		return ();
	}
}
###############################################################################
sub is_sel($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_sel ";
	return is_file($ligne);
}
###############################################################################
sub is_anysel($) {
	my $ligne = shift @_;    # string to be tested

	#print "is_anysel ";
	my @ret = test_pattern( $ligne, $anysel_pattern );
	if (@ret) {
		return is_file( shift @ret );
	}
	else {
		return ();
	}
}
###############################################################################
# decode binaries values
# return 1/0 if good, else undef
sub is_binary($) {
	my $val = shift @_;

	## no critic (ProhibitFixedStringMatches)
	if ( !defined $val ) {
		set_error('not defined : not a binary value');
		return;
	}
	elsif ( $val =~ m/^(yes|true|on|1)$/ ) {
		return 1;
	}
	elsif ( $val =~ m/^(no|false|off|0)$/ ) {
		return 0;
	}
	else {
		set_error("$val is not a binary value");
		return;
	}
	## use critic
}
###############################################################################
# check if a number (integer, without sign)
sub is_number($) {
	my $val = shift @_;

	if ( $val =~ m/^\d+$/ ) {
		return $val;
	}
	else {
		set_error("$val is not a number");
		return;
	}
}
###############################################################################
# check if it looks like a email adress
sub is_mail_adress($) {
	my $val = shift @_;

	# a mail adress should contain the "at" character
	if ( $val =~ m/\@/ ) {
		return $val;
	}
	else {
		set_error("$val do not seems to be a mail adress");
		return;
	}
}
###############################################################################
# check if a number is in [min , max ] interval
sub is_borned_number($$$) {
	my $val = shift @_;
	my $min = shift @_;
	my $max = shift @_;

	if ( !defined is_number($val) ) {
		return;
	}
	elsif ( ( $val >= $min ) and ( $val <= $max ) ) {
		return $val;
	}
	else {
		set_error("$val do not seems to be a good value [$min - $max]");
		return;
	}
}
###############################################################################
# check if it looks like a nice value (man nice on unix)
# we just allow positives value (lower priority)
sub is_nicevalue($) {
	my $val = shift @_;

	return is_borned_number( $val, 0, 19 );
}
###############################################################################
sub is_hostname($) {
	my $val = shift @_;

	if ( $val =~ m/^[\w\.]+$/ ) {
		return $val;
	}
	else {
		set_error("$val is not a hostname");
		return;
	}
}
###############################################################################
# check a macro syntaxe
sub check_macro($$$) {
	my $key         = shift @_;
	my $val         = shift @_;
	my $allow_undef = shift @_;

	# the hash contains all available macro key
	# and point to syntaxe checking sub
	my %macro = (
		LINES    => \&is_number,
		MAILTO   => \&is_mail_adress,
		MAILHOST => \&is_hostname,
		REPORT   => \&is_binary,
		VERBOSE  => \&is_binary,
		NICE     => \&is_nicevalue,
		BATCH    => \&is_binary,
		MOUNT    => \&is_directory,
	);

	if ( exists $macro{$key} ) {
		if ( ( !defined $val ) or ( $val eq $EMPTY ) ) {

			# special case for afickonfig to delete values
			if ($allow_undef) {
				return 1;
			}
			else {
				set_error('missing macro value');
				return;
			}
		}
		else {
			return &{ $macro{$key} }($val);
		}
	}
	else {
		set_error("$key is not a valid macro keyword");
		return;
	}
}
###############################################################################
# check if a file exists
sub is_plainfile($) {
	my $val = shift @_;

	if ( -f $val ) {
		return $val;
	}
	else {
		set_error("$val plain file does not exists");
		return;
	}
}
###############################################################################
# check if a file exists
# and try to create it if not
sub check_plainfile($) {
	my $val = shift @_;

	if ( is_plainfile($val) ) {
		return $val;
	}
	elsif ( open my $fh_file, '>', $val ) {

		# create file
		close $fh_file or set_error("can not close $val : $ERRNO");
		return;
	}
	else {
		set_error("can not create file $val : $ERRNO");
		return;
	}
}
###############################################################################
# check if a directory exists
sub is_directory($) {
	my $val = shift @_;

	if ( -d $val ) {
		return $val;
	}
	else {
		set_error("$val directory does not exists");
		return;
	}
}
###############################################################################
# check if a directory exists
# and try to create it if not
sub check_directory($) {
	my $val = shift @_;

	if ( is_directory($val) ) {
		return $val;
	}
	elsif ( mkdir $val, oct 700 ) {

		# create directory
		return $val;
	}
	else {
		set_error("can not create directory $val : $ERRNO");
		return;
	}
}
###############################################################################
sub is_anyfile($) {
	my $val = shift @_;

	if ( ( -e $val ) or ( -l $val ) ) {
		return $val;
	}
	else {
		set_error("$val file does not exists");
		return;
	}
}
###############################################################################
# never return false (undef) : to be used if no checking available
sub is_bidon($) {
	my $val = shift @_;
	return $val;
}
###############################################################################
# check if it is debug level
sub is_debug_level($) {
	my $val = shift @_;

	return is_borned_number( $val, 0, max_debug() );
}
###############################################################################
# check if a valid url
sub is_url($) {
	my $val = shift @_;

	## no critic (ProhibitFixedStringMatches)
	if ( $val =~ m/^(stdout|stderr|null)$/ ) {
		return $val;
	}
	else {
		set_error("$val is not a valid url");
		return;
	}
	## use critic
}
###############################################################################
# check if a valid file name (?)
sub is_name($) {
	my $val = shift @_;

	if ( $val =~ m/^\w+$/ ) {
		return $val;
	}
	else {
		set_error("$val is not a valid name");
		return;
	}
}
###############################################################################
# not yet used
sub is_format($) {
	my $val = shift @_;

	my %format = (
		'txt'  => 1,
		'html' => 2,
		'xml'  => 3,
	);

	if ( exists $format{$val} ) {
		return $val;
	}
	else {
		set_error("$val is not a valid format");
		return;
	}
}
###############################################################################
sub check_directive($$$) {
	my $key         = shift @_;
	my $val         = shift @_;
	my $allow_undef = shift @_;

	my %directive = (
		ignore_case        => \&is_binary,
		report_full_newdel => \&is_binary,
		running_files      => \&is_binary,
		timing             => \&is_binary,
		verbose            => \&is_binary,
		warn_dead_symlinks => \&is_binary,
		warn_missing_file  => \&is_binary,
		follow_symlinks    => \&is_binary,
		allow_overload     => \&is_binary,

		max_checksum_size => \&is_number,

		archive => \&check_directory,
		history => \&check_plainfile,

		debug         => \&is_debug_level,
		report_url    => \&is_url,
		report_syslog => \&is_binary,
		database      => \&is_bidon,

		exclude_suffix => \&is_bidon,
		exclude_prefix => \&is_bidon,
		exclude_re     => \&is_bidon,
		only_suffix    => \&is_bidon,

		#output_format  => \&is_format,
	);

	if ( exists $directive{$key} ) {
		if ( ( !defined $val ) or ( $val eq $EMPTY ) ) {

			# special case for afickonfig to delete values
			if ($allow_undef) {
				return 1;
			}
			else {
				set_error('missing directive value');
				return;
			}
		}
		else {
			return &{ $directive{$key} }($val);
		}
	}
	else {
		set_error("$key is not a directive keyword");
		return;
	}
}
###############################################################################
# test if a valid operator
sub test_op($) {
	my $op = shift @_;

	return ( $op =~ m/^[+-]$/ );
}
##########################################################################
# test if a valid attribute
# return decoded value (alias -> attributes) or undef
sub test_attribute($$$) {
	my $val        = shift @_;
	my $rh_aliases = shift @_;    # ref to resolved aliases
	my $resolv     = shift @_;    # binary : resolv ?

	if ( !$resolv ) {
		return $val;
	}
	else {
		return ( exists( $rh_aliases->{$val} ) ? $rh_aliases->{$val} : undef );
	}
}
##########################################################################
# apply an attribute on chain
sub apply_attribute($$$$) {
	my $begin     = shift @_;     # begin of resolved chain
	my $op        = shift @_;     # operator
	my $attribute = shift @_;     # attribute to add/subtract
	my $resolv    = shift @_;     # binary : resolv ?

	if ( !$resolv ) {
		return "$begin$op$attribute";
	}

	if ( $op eq q{+} ) {

		# test duplicate
		if ( $begin =~ m/$attribute/ ) {
			set_error("find duplicate $attribute ($begin)");
			return;
		}
		else {

			# ok
			$begin .= "$attribute";
		}
	}
	else {

		# negative operator
		if ( $begin =~ s/$attribute// ) {

			# ok
		}
		else {
			set_error("can not remove $attribute from $begin");
			return;
		}
	}
	return $begin;
}
##########################################################################
{

	# private value used as a cache, to avoid too many calls
	my $sha1_exist;

	sub is_sha1() {
		if ( !defined $sha1_exist ) {
			eval { require Digest::SHA1 };
			if ($EVAL_ERROR) {
				$sha1_exist = 0;
			}
			else {
				$sha1_exist = 1;
			}
		}
		else {

			# already in cache : nothing to do
		}
		return $sha1_exist;
	}
}
##########################################################################
# check alias syntaxe
# can resolv in base attribute if resolv is 1
# else just check operator syntaxe
# the problem is with afickonfig : when checking arg, we do not know all
# alias defined in config file
#
# warning : this version stop at first error
#   and do not try to skip bad elements
sub check_alias($$$) {
	my $var         = shift @_;    # string containing the alias to be resolved
	my $rh_aliases  = shift @_;    # ref to hash containing aliases
	my $allow_undef = shift @_;

	if ( ( !defined $var ) or ( $var eq $EMPTY ) ) {
		if ($allow_undef) {
			return 1;
		}
		else {
			set_error('missing alias value');
			return;
		}
	}

	# resolv is set from alias hash
	my $resolv = defined $rh_aliases;    # a binary value

	remove_all_spaces( \$var );

	my @tab = split /\b/, $var;

	# first attribute
	my $first = shift @tab;

	# test resolution
	my $real = test_attribute( $first, $rh_aliases, $resolv );
	if ( !defined $real ) {
		set_error("$first is not a valid attribute");
		return;
	}

	while ( my $op = shift @tab ) {

		if ( test_op($op) ) {
			my $next = shift @tab;
			if ( !defined $next ) {
				set_error('missing last attribute');
				return;
			}
			my $next2 = test_attribute( $next, $rh_aliases, $resolv );
			if ( defined $next2 ) {
				$real = apply_attribute( $real, $op, $next2, $resolv );
				return if ( !defined $real );
			}
			else {
				set_error("$next is not a valid attribute");
				return;
			}
		}
		else {
			set_error("$op should be the operator + or -");
			return;
		}
	}

	# test for checksum :
	# sha1 is not allways available
	if ( $real =~ m/1/ ) {
		if ( is_sha1() ) {

			# ok : keep it
		}
		elsif ( $real =~ m/5/ ) {

			# sha1 not available, remove it
			$real =~ s/1//;
			warning("sha1 checksum not available on $real : removed");
		}
		else {

			# sha1 not available, replaced by md5
			$real =~ s/1/5/;
			warning("sha1 checksum not available on $real : replaced by md5");
		}
	}

	debug("(check_alias) $var -> $real");
	return $real;
}
##########################################################################
# check duplicate for alias, macros
sub check_duplicate($$) {
	my $key     = shift @_;
	my $rh_find = shift @_;

	debug("(check_duplicate) $key");

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

		# allow multi_lines
		# rh_find is to true on first call
		# and then set to false in overload sub
		$rh_find->{$key} = 1 unless exists $rh_find->{$key};
		return 0;
	}
	elsif ( exists $rh_find->{$key} ) {
		set_error('find duplicate key');
		return 1;
	}
	else {
		$rh_find->{$key}++;
		return 0;
	}
}
##########################################################################
sub set_h_default($$$) {
	my $key          = shift @_;
	my $rh_directive = shift @_;
	my $value        = shift @_;

	$rh_directive->{$key} = $value if ( !exists $rh_directive->{$key} );
	return;
}
##########################################################################
sub config_default($) {
	my $rh_directive = shift @_;

	# set defaults values if not found in file
	set_h_default( 'archive', $rh_directive, $archive_def );
	set_h_default( 'history', $rh_directive, $history_def );
	set_h_default( 'debug',   $rh_directive, $debug_def );
	set_h_default( 'verbose', $rh_directive, $verbose_def );
	set_h_default( 'warn_dead_symlinks', $rh_directive,
		$warn_dead_symlinks_def );
	set_h_default( 'report_full_newdel', $rh_directive,
		$report_full_newdel_def );
	set_h_default( 'warn_missing_file', $rh_directive, $warn_missing_file_def );
	set_h_default( 'running_files',     $rh_directive, $running_files_def );
	set_h_default( 'timing',            $rh_directive, $timing_def );
	set_h_default( 'follow_symlinks',   $rh_directive, $follow_symlinks_def );
	set_h_default( 'allow_overload',    $rh_directive, $allow_overload_def );
	set_h_default( 'ignore_case',       $rh_directive, $ignore_case_def );
	set_h_default( 'max_checksum_size', $rh_directive, $max_checksum_size_def );
	set_h_default( 'exclude_prefix',    $rh_directive, $exclude_prefix_def );
	set_h_default( 'exclude_suffix',    $rh_directive, $exclude_suffix_def );
	set_h_default( 'exclude_re',        $rh_directive, $exclude_re_def );
	set_h_default( 'only_suffix',       $rh_directive, $only_suffix_def );
	set_h_default( 'report_syslog',     $rh_directive, $report_syslog_def );

	return;
}
##########################################################################
# a clone from read_configuration (afick.pl)
# but using parameter instead global var
# todo : to be recoded
# this sub does not treat glob characters !
# (do not call treat_line ...)
## no critic (ProhibitManyArgs,ProhibitExcessComplexity)
sub get_configuration($$$$$$) {
	my $configfile   = shift @_;
	my $rh_macro     = shift @_;
	my $rh_alias     = shift @_;
	my $rh_directive = shift @_;
	my $rh_rule      = shift @_;
	my $rh_onlydir   = shift @_;

	my @config;
	if ( !read_config( $configfile, \@config ) ) {

		# warn or warning ?
		warning( get_error() );
		return 0;
	}

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

	#my %h_m_rule;

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

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

		# replace \ by / (for windows)
		$line = reg_name($line);

		# remove trailing slash
		$line =~ s{/$}{};

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

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

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

			if (   ( !defined check_macro( $key, $val, 0 ) )
				or ( check_duplicate( $key, \%h_m_macro ) ) )
			{
				$nb_pbs++;
				next;
			}
			debug( "(get_config) found macro $key : $val", 2 );

			# add to Macro for print_config
			$rh_macro->{$key} = $val;
		}
		elsif ( @ret = is_directive($line) ) {

			# 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 ) ) )
			{
				$nb_pbs++;
				next;
			}
			if ( $key =~ m/^exclude/ ) {
				$rh_directive->{$key} .= $val;
			}
			else {
				$rh_directive->{$key} = $val;
			}
			debug( "(get_config) found directive $key : $val", 2 );
		}
		elsif ( @ret = is_alias($line) ) {

			# 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 ) ) )
			{
				$nb_pbs++;
				next;
			}

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

			debug( "(get_config) alias $key -> $decoded", 2 );
		}
		elsif ( @ret = is_negsel($line) ) {

			my $key = shift @ret;
			$rh_directive->{$key} = 0;

			debug( "(get_config) negsel $key", 2 );
		}
		elsif ( @ret = is_equalsel($line) ) {
			my $key       = shift @ret;
			my $attribute = shift @ret;

			my $masq = check_alias( $attribute, $rh_alias, 0 );
			if ( !defined $masq ) {
				$nb_pbs++;
				next;
			}

			$rh_rule->{$key}    = $attribute;
			$rh_onlydir->{$key} = 1;

			debug( "(get_config) equalsel $key $masq", 2 );
		}
		elsif ( @ret = is_sel($line) ) {
			my $key       = shift @ret;
			my $attribute = shift @ret;

			my $masq = check_alias( $attribute, $rh_alias, 0 );
			if ( !defined $masq ) {
				$nb_pbs++;
				next;
			}
			$rh_rule->{$key} = $attribute;

			debug( "(get_config) sel $key $masq", 2 );
		}
		else {
			warning(
"(get_config) skipped config file $line (line $line_id) : unknown type"
			);
		}
		## use critic
	}    # foreach my $line

	# set defaults values if not found in file
	config_default($rh_directive);

	# callers do not test code return for now
	return 1;
}
## use critic
##########################################################################
# search for a rule matching $file in $rscan
# return undef if not found, 0 if an exception, else the rule
sub rech_parent($$) {
	my $file  = shift @_;
	my $rscan = shift @_;

	my $found = undef;

	# first search for this file
	if ( exists $rscan->{$file} ) {
		$found = $rscan->{$file};
		if ( $found ne '0' ) {

			# found the name in the list and not an exception
			debug( "(rech_parent) found $file in config file : $found", 2 );
		}
		else {

			# found the file as an exception : the end
			debug( "(rech_parent) $file is an exception", 2 );
		}
	}
	else {

		# then search for directory parent
		my $dirname = dirname($file);

		# infinite loop
		# there is 2 ways to go out
		while (1) {
			if ( exists $rscan->{$dirname} ) {
				$found = $rscan->{$dirname};
				if ( $rscan->{$dirname} ne '0' ) {

					# found a good parent directory
					debug(
"(rech_parent) found $dirname for $file in config file : $found",
						2
					);
					last;
				}
				else {

					# found the directory as an exception : the end
					debug(
"(rech_parent) found $dirname for $file is an exception",
						2
					);
					last;
				}
			}
			else {

				# next parent directory
				my $newdirname = dirname($dirname);
				if ( $newdirname eq $dirname ) {
					debug( "(rech_parent) stop on $dirname", 2 );
					last;
				}
				else {
					debug( "(rech_parent) search $newdirname (from $dirname)",
						3 );
					$dirname = $newdirname;
				}
			}
		}
	}
	return $found;
}
##########################################################################
# check if a new release is available
# return 1 if true
# return 0 if not
# return undef if some error
sub check_update($$) {
	my $cur_product = shift @_;
	my $cur_version = shift @_;

	my $url = 'http://afick.sourceforge.net/version';

	# version 1 : LWP::Simple
	# very easy and simple to code, but can not configure timeout
	#eval {require  LWP::Simple};
	#$content =  LWP::Simple::get($url);

	my $ret;    # return code

	# version 2 : LWP::UserAgent : a little bit more complex
	eval { require LWP::UserAgent };
	if ($EVAL_ERROR) {
		warning('missing library LWP : impossible get last version');
	}
	else {
		my $ua = LWP::UserAgent->new();
		$ua->timeout(5);
		my $response = $ua->get($url);    # HTTP::Response
		if ( $response->is_success ) {

			# get file content
			my $content = $response->content;

			# parse each line to search for product
			my @lines = split /\n/, $content;
			my $version;
			foreach my $line (@lines) {
				my ( $l_prod, $l_version ) = split / /, $line;
				if ( $l_prod eq $cur_product ) {
					$version = $l_version;
					last;
				}
			}
			if ( !defined $version ) {
				warning("can not find version for $cur_product");
			}
			else {

				# can get version file
				# then compare with current version
				# rem : it should be possible to have a real compare
				# if we remove . and - from version (or keep only numerics)
				if ( $version eq $cur_version ) {

					# ok
					info("ok : last version ($version) is installed");
					$ret = 0;
				}
				else {

					# another version is available
					warning(
"another version of $cur_product is available : $version (current is $cur_version)"
					);
					$ret = 1;
				}
			}
		}
		else {

			# can not get url
			warning( 'can not get version from internet site : '
				  . $response->status_line() );

		}
	}
	return $ret;
}
##########################################################################
# date format for reports name
sub reports_date(@) {
	my @date = @_;

	return strftime( '%Y%m%d%H%M%S', @date );
}
##########################################################################
# date format for history, reports ....
sub history_date(@) {
	my @date = @_;

	my $datefmt = '%Y/%m/%d %H:%M:%S';
	return strftime( $datefmt, @date );
}
##########################################################################
# just create an empty file if does not exists
sub touch($) {
	my $name = shift @_;
	if ( !-f $name ) {
		my $fh_touch;
		## no critic (RequireCheckedOpen,RequireCheckedClose,RequireCheckedSyscalls)
		open $fh_touch, '>', $name;
		close $fh_touch;
		## use critic
	}
	return;
}
##########################################################################
#replace \ by / (for windows)
sub reg_name($) {
	my $name = shift @_;

	if ( is_microsoft() ) {
		$name =~ s{\\}{/}g;
		return lc $name;
	}
	else {
		return $name;
	}
}
##########################################################################
1;
