# Copyright (C) 2011 Moritz Orbach <gnu@apfelboymchen.net>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# birth: 2011-12-05 12:02:10.000000000 +0100
package ConfigFile;
use strict;
use warnings;

#
# BUGS
# - no possibility to make sections unique.
#

##### interface #####

sub get($$)
{
	my $self    = shift;
	my $section = shift;
	my $name    = shift;

	$name = lc($name);

	#print "get: $section\->$name = " . $self->{cfg}->{$section}->{$name} . "\n"; # debug
	return $self->{cfg}->{$section}->{$name};
}

sub get_sections()
{
	my $self = shift;

	my @sections;
	my $sections = $self->{cfg};

	foreach (keys %$sections) {
		push(@sections, $_);
	}

	return @sections;
}

# to generate a config file base on the template in $template_ref
sub cfg_from_template(\%)
{
	my $self = shift;
	my $template_ref = shift;

	my $linelength = 67;

	$self->_validate_template($template_ref)
		or die("$0: programming error: template invalid\n");

	my $result;

	$result .= ("# ******************** AUTO-GENERATED CONFIGURATION FILE *********************\n");
	$result .=  $self->_commentify("The values within the sections are perl compatible regular expressions specifying what's valid at that point. You have to replace them with actual values.\n", $linelength);
	$result .= ("# ******************** AUTO-GENERATED CONFIGURATION FILE *********************\n\n");
	foreach my $section (keys %$template_ref) {
		my $required = $template_ref->{$section}->{required};

		$result .=  $self->_commentify($template_ref->{$section}->{description}, $linelength) . "\n";
		$result .=  "# This templates applies to every section matching " . $template_ref->{$section}->{matches} . "\n";
		$result .= sprintf("# A section matching this template is %s.\n", $required ? "required" : "not required");
		$result .=  "[" . $section . "]\n";

		my $options = $template_ref->{$section}->{options};
		foreach my $option (keys %$options) {
			$result .= sprintf("\n%s (%s)\n",
				$self->_commentify($options->{$option}->{description}, $linelength),
				$options->{$option}->{required} == 1 ? "required" : "optional"
			);
			$result .= sprintf("%s = %s\n", $option, $options->{$option}->{validation});
		}

		$result .= "\n";
	}
	$result .= "# vim:ft=dosini\n";
}

#
###### implementation #####
#

# poor man's fold, almost good. It breaks a single line $line to a 
# multiple-line comment, breaking after the word that reaches $column
sub _commentify()
{
  my $self   = shift;
  my $text   = shift;
  my $column = shift;

  my $result;

  $_ = $text;
  while (s/^(.{$column}.*?)\s//) {
    #print "$_\n";
    $result .= "# $1\n" ;
    #print "$result\n";
  }
  $result .= "# $_";

  return $result;
}

# debug-helper
sub _print_hash(\%)
{
	my $self = shift;
	my $hash = shift;

	print "- hash -\n";
	if (!defined $hash) {
		print("undefined!\n");
	}
	foreach (keys %$hash) {
		print("$_\t: " . $hash->{$_} . "\n");
	}
	print("\n");
}

sub _set_option($$$)
{
	my $self    = shift;
	my $section = shift;
	my $name    = shift;
	my $value   = shift;

	$name = lc($name);

	$self->{cfg}->{$section}->{$name} = $value;
	#print "set: $section\->$name    \t= " . $self->{cfg}->{$section}->{$name} . "\n"; # debug
}

sub _find_key_nocase(\%$)
{
	my $self = shift;
	my $hash = shift;
	my $find = shift;

	foreach (keys %$hash) {
		return $_ if (/$find/i);
	}
}

sub _error($$$)
{
	my $self    = shift;
	my $section = shift;
	my $name    = shift;
	my $info    = shift;


	my $key;
	if (!defined $name) {
		$key = "section_$section";
	} else {
		$key = "section_$section name_$name";
	}

	warn($self->{cfgfile} . ":" . $self->{linenumbers}->{$key} . ": " . $info . "\n");
}

# validates $template_ref against $template_schema
# returns number of errors
sub _schema_validate(\%$)
{
	my $self            = shift;
	my $info            = shift;
	my $template_ref    = shift;
	my $template_schema = shift;

	my $errors = 0;
	foreach (keys %$template_schema) {
		#print "\n$_: >$template_ref->{$_}< vs. >$template_schema->{$_}< ?\n"; # debug
		if (!defined $template_ref->{$_} || ($template_ref->{$_} !~ /$template_schema->{$_}/)) {
			warn("$0: programming error in config-template: $info: \"$_\" missing or invalid\n");
			$errors++;
		}
	}

	return $errors;
}

# sets default values in $sections_ref from $template_ref
# XXX share with _check_required_options?
sub _merge_defaults(\%\%)
{
	my $self         = shift;
	my $template_ref = shift;
	my $sections_ref = shift;

	# for every section defined
	foreach my $section (keys %$sections_ref) {

		my $section_ref = $sections_ref->{$section};

		# look for defaults matching template
		my $t_section = $self->_get_section_template($template_ref, $section);
		my $t_options_ref = $template_ref->{$t_section}->{options};
		foreach my $t_option (keys %$t_options_ref) {
			$t_option = lc($t_option);
			# no default given
			next if (!defined $t_options_ref->{$t_option}->{default});
			# don't overwrite
			next if (defined $section_ref->{$t_option});
			$section_ref->{$t_option} = $t_options_ref->{$t_option}->{default};
		}

	}
}


# returns true if all required options defined in $template_ref are set in 
# $sections_ref
# XXX share with _merge_defaults?
sub _check_required_options(\%\%)
{
	my $self         = shift;
	my $template_ref = shift;
	my $sections_ref = shift;

	my $errors = 0;
	foreach my $section (keys %$sections_ref) {
		my $t_section = $self->_get_section_template($template_ref, $section);
		if (!defined $t_section) {
			die("$0: programming error: template must be valid before _check_required_options can be used\n");
		}

		my $options_template_ref = $template_ref->{$t_section}->{options};
		foreach my $t_option (keys %$options_template_ref) {
			#print "$t_option in $section?\n"; # debug
			if ($options_template_ref->{$t_option}->{required}) {
				if (!defined $sections_ref->{$section}->{lc($t_option)}) {
					$errors++;
					$self->_error($section, undef, "required option missing in section $section: $t_option");
				}
			}
		}
	}
	return $errors == 0;
}


# returns true if all required options defined in $template_ref are set in 
# $options_ref
sub _check_required_sections(\%\%)
{
	my $self         = shift;
	my $template_ref = shift;
	my $options_ref  = shift;

	my $errors = 0;
	foreach my $section (keys %$template_ref) {
		if (!$template_ref->{$section}->{required}) {
			next;
		}

		my $section_ok = 0;
		foreach my $s (keys %$options_ref) {
			my $matchstring = $template_ref->{$section}->{matches};
			#print "|$s| vs |$matchstring|\n"; # debug
			if ($s =~ /$matchstring/i) {
				$section_ok = 1;
				last;
			}
		}
		if (!$section_ok) {
			warn("required section missing: $section\n");
			$errors++;
		}
	}

	return $errors == 0;
}

# searches a matching section template for $name in $template_ref
# returns the section name if found, undef otherwise
sub _get_section_template(\%$)
{

	my $self         = shift;
	my $template_ref = shift;
	my $name         = shift;

	foreach my $section (keys %$template_ref) {
		#print $template_ref->{$section}->{matches} . "\n";
		my $matchstring = $template_ref->{$section}->{matches};
		if (!defined $matchstring) {
			# programming error
			return undef;
		}
		if ($name =~ /$matchstring/i) {
			return lc($section);
		}
	}
	return undef;
}

# validates options in $options_ref against $template_ref
sub _validate_options(\%\%)
{
	my $self         = shift;
	my $template_ref = shift;
	my $options_ref  = shift;

	my $errors = 0;
	foreach my $name (keys %$options_ref) {
		my $value = $options_ref->{$name};

		# both programmer and user should be able to use their own case for the 
		# names
		my $t_name = $self->_find_key_nocase($template_ref, $name);
		my $matchstring = $template_ref->{$t_name}->{validation};

		#print "|$value|\tvs. |$matchstring|\n"; # debug
		if ($value !~ /$matchstring/) {
			$self->_error($self->{currentoption}, $name, "invalid value for $name in section \"$self->{currentoption}\": \"$value\" does not match \"$matchstring\"");
			$errors++;
		}
	}
	return $errors == 0;
}

# checks that all values in $options_ref are valid according to $template_ref
# template must be valid before calling this!
sub _validate_all_values(\%\%)
{
	my $self = shift;
	my $template_ref = shift;
	my $options_ref  = shift;

	my $errors = 0;
	foreach my $section (keys %$options_ref) {
		#print "[$section]\n"; # debug
		$self->{currentoption} = $section;
		my $t_section = $self->_get_section_template($template_ref, $section);
		if (!defined $t_section) {
			die("$0: programming error: template must be valid before _validate_all_values can be used\n");
		}
		$self->_validate_options($template_ref->{$t_section}->{options}, $options_ref->{$section})
			or $errors++;
	}

	return $errors == 0;
}

# returns true if a template section for every section in $config can be found 
# in $template_ref
sub _validate_sections($$)
{
	my $self          = shift;
	my $template_ref  = shift;
	my $config        = shift;

	my $ok = 1;
	foreach my $s (keys %$config) {
		if (!$self->_get_section_template($template_ref, $s)) {
			$ok = 0;
			$self->_error($s, undef, "invalid section name: $s");
		}
	}
	return $ok;
}

# reads the config and checks syntax
# Reading the config file first has the disadvantage that it's no longer 
# possible to print the line number on errors easily. But the validation can be 
# done cleaner.
sub _load_file($)
{
	my $self    = shift;
	my $cfgfile = shift;

	my $userconfig_ref = { };

	my $line = 0;
	if (!open(OPT, $cfgfile)) {
		print STDERR "could not open \"$cfgfile\"\n";
		return undef;
	}

	my $f_section = undef; # current section in file
	my $t_section = undef; # corresponding section name in template
	my $errors    = 0;

	while (<OPT>) {
		$line++;

		chomp;
		s/^\s+//;  # leading spaces
		s/#.+$//;  # comments
		s/\s+$//;  # trailing spaces
		if (/^\s+$/ or /^$/) {
			# comment / empty line
			next;
		}

		if (/^\[(.*)\]$/) {
			$f_section = $1;
			#print "[$f_section]\n"; # debug
			# new sections
			$userconfig_ref->{$f_section} =  {};
			$self->{linenumbers}->{"section_" . $f_section} = $line;
			next;
		}

		#
		# options
		#
		if (!defined $f_section) {
			warn("$cfgfile:$line: line not within any section\n");
			$errors++;
			next;
		}

		my ($name, $value) = /^(.*?)\s*=\s*(.*)$/;
		$name = lc($name);
		#print "userconfig_ref->$f_section->$name    \t= \"$value\"\n"; # debug
		$userconfig_ref->{$f_section}->{$name} = $value;
		$self->{linenumbers}->{"section_$f_section name_$name"} = $line;

	}
	close OPT;

	return $userconfig_ref if $errors == 0;
}

# checks if all required options were given in $template_ref
# the "schema" lives here.
sub _validate_template(\%$)
{
	my $self         = shift;
	my $template_ref = shift;

	my $errors = 0;
	for my $section (keys %$template_ref) {
		# check caller's section definitions
		$errors += $self->_schema_validate(
			$section,
			$template_ref->{$section},
			{
				required    => '^(1|0)$',
				matches     => '.',
				description => '.',
				options     => '^HASH\('
			}
		);

		my $options_ref = $template_ref->{$section}->{options};
		foreach my $option (keys %$options_ref) {
			# check caller's option definitions
			$errors += $self->_schema_validate(
				"$section\->options\->$option",
				$options_ref->{$option},
				{
					required    => '^(1|0)$',
					validation  => '.',
					description => '.'
				}
			);

			if (defined $options_ref->{$option}->{default}
				&& defined $options_ref->{$option}->{required} == 1
				&& $options_ref->{$option}->{required} == 1) {
				warn("$0: programming error in config template: $section\->options\->$option: required and default together makes no sense\n");
			}
		}
	}

	return $errors == 0;
}

#
## constructor
#

sub new
{
	# template: the configuration definition given by the caller
	# schema  : the template of the template
	my $class        = shift;
	my $cfgfile      = shift;
	my $template_ref = shift;

	my $self = {
		cfg         => { },  	# where the configuration eventually will be saved
		
		# to be able to give information in error messages.
		# This solution isn't great. But I don't want to scatter the checks
		linenumbers   => { },  	
		currentoption => { },  	
		cfgfile       => $cfgfile
	};
	bless($self, $class);

	#
	# verify caller
	#
	#
	if (!defined $cfgfile) {
		warn("no cfgfile given\n");
		return undef;
	}
	if (!defined $template_ref) {
		die("$0: programming error: no config defined\n");
	}

	if (!$self->_validate_template($template_ref)) {
		exit(1);
	}

	#
	# verify user
	#
	my $file_ref = $self->_load_file($cfgfile)
		or return undef;

	$self->_validate_sections($template_ref, $file_ref)
		or return undef;

	# every section can be found in the template from here on

	$self->_check_required_sections($template_ref, $file_ref)
		or return undef;

	$self->_check_required_options($template_ref, $file_ref)
		or return undef;

	$self->_validate_all_values($template_ref, $file_ref)
		or return undef;

	$self->_merge_defaults($template_ref, $file_ref);

	# all good! copy it over!
	foreach my $fsectionname (keys %$file_ref) {
		my $fsection = $file_ref->{$fsectionname};
		foreach my $name (keys %$fsection) {
			$self->_set_option($fsectionname, $name, $fsection->{$name});
		}
	}
	delete $self->{linenumbers};
	delete $self->{currentoption};
	delete $self->{cfgfile};

	return $self;
}

1;
__END__

=head1 NAME

ConfigFile - Loading INI-style configuration files

=head1 SYNOPSIS

 ConfigFile->cfg_from_template(\%CFG_TEMPLATE);
 my $CFG = ConfigFile->new("$cfgfile", \%CFG_TEMPLATE) or die("Error in $cfgfile\n");
 my @sections = $CFG->get_sections();
 my $options = $CFG->get($section, "option");

=head1 DESCRIPTION

ConfigFile loads an INI-style configuration. The file is validated according to 
the template provided by the caller, and default values are set. An initial 
configuration -- including descriptions and valid values for options -- can be 
generated based on the template.

=head2 Template syntax

The template is a hash of hashes, where each hash represents a section.

=head3 Section definitions

Each section must have the following keys

=over

=item required

defines if it is an error if this section is missing

=item matches

a regular expression that defines which section in the config file will match 
this definition

=item description

a description of this section that is printed by cfg_from_template()

=item options

a hash describing the options in this section

=back

=head3 Options definitions

Each key in the options-hash defines the name of an option in the configuration 
file. The value for each option is another hash, with the following required 
keys

=over

=item required

defines if it is an error if this option is missing

=item matches

a regular expression that defines valid assignments for this option

=item description

a description of this option that is printed by cfg_from_template()

=back

A default value for the option can be set with the C<default> key.

=head2 Methods

=over

=item cfg_from_template

 cfg_from_template(\%CFG_TEMPLATE);

Validates the template and returns an annotated configuration stub that can be 
used as an initial configuration file.

=item new

 new("$cfgfile", \%CFG_TEMPLATE);

Constructor. If the Template is invalid the object will die(). If the 
configuration file is invalid the object will return undef.

=item get_sections

 get_sections();

Returns an array of all sections found in the config file.

=item get

 get($section, $option);

Gets value of C<$option> from C<$section>. No further checks are done. If the 
section and/or the option does not exist, this method returns C<undef>.

=back

=head1 EXAMPLE

 #!/usr/bin/perl
 use strict;
 use warnings;
 
 use ConfigFile;
 
 #
 # DEFINITION OF CONFIG OPTIONS 
 #
 
 my %CFG_TEMPLATE = (
 	# global options used by all sections
 	global => {
 		required    => 1,
 		matches     => '^global$',
 		description => 'options used by all sections',
 
 		options => {
 			connect_string => {
 				required    => 1,
 				validation  => ".",
 				description => "How to connect to the database"
 			}
 		}
 	},
 
 	# sections that import files
 	import => {
 		required => 0,
 		matches  => '^import ',
 		description => 'sections used to import files',
 
 		options => {
 			ftpserver => {
 				required    => 1,
  				validation  => "^.+:.+@.+",
 				description => "Where to get the files. Include user and password browser-style."
 			},
 			remotepath => {
 				required    => 1,
 				validation  => ".+",
 				description => "Directory on the remote server"
 			},
 			dstpath => {
 				required    => 1,
 				validation  => ".+",
 				description => "Where to save the files"
 			},
 			specials => {
 				required    => 0,
 				validation  => ".+",
 				default     => "importdefault",
 				description => "What special functions should be called for this directory. May the forces of evil become confused on the way to your house. There are three possibilities: Pioneer's solar panel has turned away from the sun",
 			}
 		}
 	},
 
 	# sections that export files
 	export => {
 		required => 0,
 		matches  => '^export ',
 		description => 'sections used to export files',
 
 		options => {
 			dstpath => {
 				required    => 1,
 				validation  => ".",
 				description => "Where to save the generated files"
 			},
 			specials => {
 				required    => 0,
 				validation  => ".",
 				default     => "somedefaultvalue",
 				description => "What special functions should be called for this directory"
 			},
 		}
 	}
 );


 ###
 
 #
 # initializing
 #
 
 print "---------- cfg_from_template() ----------\n";
 print ConfigFile->cfg_from_template(\%CFG_TEMPLATE);
 print "\n";
 
 my $CFG = ConfigFile->new("configfiledemo.cfg", \%CFG_TEMPLATE);
 
 print "------- using ConfigFile --------\n";
 if (!defined $CFG) {
     die("Error reading config file. Exiting.\n");
 }                                                                                                                                            
 
 my @sections = $CFG->get_sections();
 foreach (@sections) {
 	print "got section: $_\n";
 }
 print "\n";
 
 print $CFG->get("export bla",  "dstpath") . "\n";
 print $CFG->get("import blub", "ftpserver") . "\n";
 print $CFG->get("global",      "connect_string") . "\n";

=head1 BUGS

=over

=item *

This module was an experiment. Config::Grammar already exists, and seems to 
have some additional features (e.g. sub-sections).

=item *

No possibility to make sections unique, except by regular expressions.

=back

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2011 Moritz Orbach <gnu@apfelboymchen.net>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.