package ALPM::Conf;
use warnings;
use strict;

BEGIN {
	require IO::Handle;
	require Carp;
	require ALPM;
}

## Private functions.

# These options are implemented in pacman, not libalpm, and are ignored.
my @NULL_OPTS = qw{HoldPkg SyncFirst CleanMethod XferCommand
	TotalDownload VerbosePkgLists};

sub _null
{
	1;
}

my $COMMENT_MATCH = qr/ \A \s* [#] /xms;
my $SECTION_MATCH = qr/ \A \s* \[ ([^\]]+) \] \s* \z /xms;
my $FIELD_MATCH = qr/ \A \s* ([^=\s]+) (?: \s* = \s* ([^\n]*))? /xms;
sub _mkparser
{
	my($path, $hooks) = @_;
	sub {
		local $_ = shift;
		s/^\s+//; s/\s+$//; # trim whitespace
		return unless(length);

		# Call the appropriate hook for each type of token...
		if(/$COMMENT_MATCH/){
			;
		}elsif(/$SECTION_MATCH/){
			$hooks->{'section'}->($1);
		}elsif(/$FIELD_MATCH/){
			my($name, $val) = ($1, $2);
			if(length $val){
				my $apply = $hooks->{'field'}{$name};
				$apply->($val) if($apply);
			}
		}else{
			die "Invalid line in config file, not a comment, section, or field\n";
		}
	};
}

sub _parse
{
	my($path, $hooks) = @_;

	my $parser = _mkparser($path, $hooks);
	my $line;
	open my $if, '<', $path or die "open $path: $!\n";
	eval {
		while(<$if>){
			chomp;
			$line = $_;
			$parser->($_);
		}
	};
	my $err = $@;
	close $if;
	if($err){
		# Print the offending file and line number along with any errors...
		# (This is why we use dies with newlines, for cascading error msgs)
		my $lineno = $if->input_line_number();
		die "$@$path:$lineno $line\n"
	}
	return;
}

## Public methods.

sub new
{
	my($class, $path) = @_;
	bless { 'path' => $path }, $class;
}

sub custom_fields
{
	my($self, %cfields) = @_;
	if(grep { ref $_ ne 'CODE' } values %cfields){
		Carp::croak('Hash argument must have coderefs as values' )
	}
	$self->{'cfields'} = \%cfields;
	return;
}

sub _mlisthooks
{
	my($dbsref, $sectref) = @_;

	# Setup hooks for 'Include'ed file parsers...
	return {
		'section' => sub {
			my $file = shift;
			die q{Section declaration is not allowed in Include-ed file\n($file)\n};
	  	},
		'field' => {
			'Server' => sub { _addmirror($dbsref, shift, $$sectref) }
		},
	 };
}

my %CFGOPTS = (
	'RootDir' => 'root',
	'DBPath' => 'dbpath',
	'CacheDir' => 'cachedirs',
	'GPGDir' => 'gpgdir',
	'LogFile' => 'logfile',
	'UseSyslog' => 'usesyslog',
	'UseDelta' => 'usedelta',
	'CheckSpace' => 'checkspace',
	'IgnorePkg' => 'ignorepkgs',
	'IgnoreGroup' => 'ignoregrps',
	'NoUpgrade' => 'noupgrades',
	'NoExtract' => 'noextracts',
	'NoPassiveFtp' => 'nopassiveftp',
	'Architecture' => 'arch',
);

sub _confhooks
{
	my($optsref, $sectref) = @_;
	my %hooks;
	while(my($fld, $opt) = each %CFGOPTS){
		$hooks{$fld} = sub { 
			my $val = shift;
			die qq{$fld can only be set in the [options] section\n}
				unless($$sectref eq 'options');
			$optsref->{$opt} = $val;
		};
	 }
	return %hooks;
}

sub _nullhooks
{
	map { ($_ => \&_null) } @_
}

sub _getdb
{
	my($dbs, $name) = @_;

	# The order databases are added must be preserved as must the order of URLs.
	for my $db (@$dbs){
		return $db if($db->{'name'} eq $name);
	}
	my $new = { 'name' => $name };
	push @$dbs, $new;
	return $new;
}

sub _setsiglvl
{
	my($dbs, $sect, $siglvl) = @_;
	my $db = _getdb($dbs, $sect);
	$db->{'siglvl'} = $siglvl;
	return;
}

sub _parse_siglvl
{
	my($str) = @_;
	my $siglvl;

	my $opt;
	for(split /\s+/, $str){
		my @types = qw/pkg db/;

		if(s/^Package//){
			@types = qw/pkg/;
		}elsif(s/^Database//){
			@types = qw/db/;
		}

		if(/^Never$/){
			$opt->{$_} = 'never' for(@types);
		}elsif(/^Optional$/){
			$opt->{$_} = 'optional' for(@types);
		}elsif(/^Required$/){
			$opt->{$_} = 'required' for(@types);
		}elsif(/^TrustedOnly$/){
			;
		}elsif(/^TrustAll$/){
			for my $t (@types){
				$opt->{$t} = 'optional' unless(defined $opt->{$t});
				$opt->{$t} .= ' trustall';
			}
		}else{
			die "Unknown SigLevel option: $_\n";
		}
	}

	# Check for a blank SigLevel
	unless(defined $opt){
		die "SigLevel was empty\n";
	}
	return $opt;
}

my $ARCH;
sub _addmirror
{
	my($dbs, $url, $sect) = @_;
	die "Section has not previously been declared, cannot set URL\n" unless($sect);

	# Expand $arch like pacman would do.
	$url =~ s{\$arch(/|\$)}{$ARCH}g;
	my $db = _getdb($dbs, $sect);
	push @{$db->{'mirrors'}}, $url;
	return;
}


sub _setopt
{
	my($alpm, $opt, $valstr) = @_;
	no strict 'refs';
	my $meth = *{"ALPM::set_$opt"}{'CODE'};
	die "The ALPM::set_$opt method is missing" unless($meth);

	my @val = ($opt =~ /s$/ ? map { split } $valstr : $valstr);
	return $meth->($alpm, @val);
}


sub _applyopts
{
	my($opts, $dbs) = @_;
	my ($root, $dbpath) = delete @{$opts}{'root', 'dbpath'};

	unless($root){
		$root = '/';
		unless($dbpath){
			$dbpath = "$root/var/lib/pacman";
			$dbpath =~ tr{/}{/}s;
		}
	}

	my $alpm = ALPM->new($root, $dbpath);
	while(my ($opt, $val) = each %$opts){
		# SetOption type in typemap croaks on error for us
		_setopt($alpm, $opt, $val);
	}

	my $sigs = grep { /signatures/ } $alpm->caps;
	for my $db (@$dbs){
		my $name = $db->{'name'};
		my $mirs = $db->{'mirrors'};
		next unless(@$mirs);
		my $siglvl = $db->{'siglvl'};
		if(!$sigs){
			# Do not pass a siglvl if signatures are not supported or this
			# will cause an ALPM error!
			undef $siglvl;
		}

		my $db = $alpm->register($name, $siglvl || 'default');
		if(!$db){
			die "Failed to register $name database: " . $alpm->strerror;
		}
		for my $url (@$mirs){
			$db->add_server($url);
		}
	}
	return $alpm;
}

sub parse
{
	my($self) = @_;

	chomp ($ARCH = `uname -m`); # used by _addmirror

	my (%opts, @dbs, $currsect, $defsiglvl);
	my %fldhooks = (
		_confhooks(\%opts, \$currsect),
		_nullhooks(@NULL_OPTS),
		'Server'  => sub { _addmirror(\@dbs, shift, $currsect) },
		'Include' => sub {
			die "Cannot have an Include directive in the [options] section\n"
				if($currsect eq 'options');

			# An include directive spawns its own little parser...
			_parse(shift, _mlisthooks(\@dbs, \$currsect));
		},
		'SigLevel' => sub {
			if($currsect eq 'options'){
				$defsiglvl = _parse_siglvl(shift);
			}else{
				_setsiglvl(\@dbs, $currsect, _parse_siglvl(shift));
			}
		},
		($self->{'cfields'} ? %{$self->{'cfields'}} : ()),
	);

	my %hooks = (
		'field' => \%fldhooks,
		'section' => sub { $currsect = shift; }
	);

	_parse($self->{'path'}, \%hooks);
	return _applyopts(\%opts, \@dbs);
}

## Import magic used for quick scripting.
# e.g: perl -MALPM::Conf=/etc/pacman.conf -le 'print $alpm->root'

sub import
{
	my($pkg, $path) = @_;
	my($dest) = caller;
	return unless($path);

	my $conf = $pkg->new($path);
	my $alpm = $conf->parse;
	no strict 'refs';
	*{"${dest}::alpm"} = \$alpm;
	return;
}

1;