Sphinx::Config - Sphinx search engine configuration file read/modify/write

    use Sphinx::Config;

    my $c = Sphinx::Config->new();
    $c->parse($filename);
    $path = $c->get('index', 'test1', 'path');
    $c->set('index', 'test1', 'path', $path);
    $c->save($filename);
    ...

    $c = Sphinx::Config->new;

    $c->preserve_inheritance(0);
    $c->preserve_inheritance(1);
    $pi = $c->preserve_inheritance(1);

    $c->parse($filename)

    $c->parse_string( $string );

    $config = $c->config;

    $value = $c->get($type, $name, $varname)
    $value = $c->get($type, $name)

    $c->set($type, $name, $varname, $value)
    $c->set($type, $name, \%values)
    $c->set($type, $name, undef(), $base_name)
    $c->set($type, $name, \%values, $base_name)

    $c->set('source', , $name, \%values);

    $c->set('indexer', undef, 'listen', $port);
    $c->set('search', undef, \%values );

    $c->set('source', 'src1', undef(), 'base2');

    $c->set('source', 'src1', \%values, 'base_source');

    $c->set('source', 'src1', 'sql_query_pre', undef());
    $c->set('source', 'src1', 'sql_query_pre');

    $c->save
    $c->save($filename, $comment)

    $s = $c->as_string
    $s = $c->as_string($comment)

    $s = $c->as_string_new
    $s = $c->as_string_new($comment)

    perldoc Sphinx::Config

package Sphinx::Config;

use warnings;
use strict;
use Carp qw/croak/;
use Storable qw/dclone/;
use List::MoreUtils qw/firstidx/;

our $VERSION = '0.09';

sub new {
    my $class = shift;

    bless { _bestow => 1 }, ref($class) || $class;
}

sub preserve_inheritance {
    my $self = shift;
    $self->{_bestow} = shift if @_;

    return $self->{_bestow};
}

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

    die "Sphinx::Config: $filename does not exist" unless -f $filename;

    my $fh;
    open($fh, "<$filename") or die "Sphinx::Config: cannot open $filename: $!";
    $self->{_file} = [ <$fh> ];
    close( $fh );
    $self->{_filename} = $filename;
    $self->_parse_file;
    return;
}

sub parse_string {
    my( $self, $string ) = @_;
    # split string on newlines, keeping the newlines in-place
    $self->{_file} = [ split /^/m, $string ];
    delete $self->{_filename};
    # _filename is used by _parse_file in its error messages
    local $self->{_filename} = "STRING";
    $self->_parse_file;
    return;
}

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

    my $state = 'outer';
    my $seq = "section";
    my $max = @{ $self->{_file} };
    my $current;
    my @config;

    foreach( my $line = 0; $line < $max ; $line++ ) {
        my $first = $line;
        my $input = $self->{_file}[ $line ];
	chomp $input;
	# discard comments
	$input =~ s/\s*\#.*//o;
        # merge continued lines
        while ($input =~ s!\\\s*$!!s and $line < $max ) {
            $line++;
            my $new = $self->{_file}[ $line ];
            chomp( $new );
            # We are folding all space up.  XXX- How does Sphinx handle this?
            if( $input =~ / $/ ) {
                $new =~ s/^\s+//;
            } else {
                $new =~ s/^\s+/ /;
	}
            $input .= $new;
    	}
        # handling this virtual line
	while ($input) {
	    if ($state eq 'outer') {
		# split into tokens, fully consuming input line
		my @tokens = split(/\s+/, $input);
		$input = "";
                while( @tokens ) {
                    my $tok = shift @tokens;
                    next unless length $tok;
		    if ($seq eq "section") {
			if ($tok =~ m/^(?:source|index)$/o) {
                            $current = { _type => $tok, _lines => [ $first ] };
			    push(@config, $current);
			    $seq = "name";
			}
			elsif ($tok =~ m/^(?:indexer|searchd|search)$/o) {
                            $current = { _type => $tok, _lines => [ $first ] };
			    push(@config, $current);
			    $seq = "openblock";
			}
			else {
                            die "Sphinx::Config: $self->{_filename}:$first: Expected section type, got '$tok'";
			}
		    }
		    elsif ($seq eq "name") {
			$current->{_name} = $tok;
			$seq = "openorinherit";
		    }
		    elsif ($seq eq "openorinherit") {
			if ($tok eq ':') {
			    $seq = "inherit";
			}
			else {
			    unshift(@tokens, $tok);
			    $seq = "openblock";
			}
		    }
		    elsif ($seq eq "inherit") {
                        die "Sphinx::Config:: $self->{_filename}:$line: a section may not inherit from itself"
                            if $tok eq $current->{_name};
                        unless( $self->_setup_inherit( $current, $tok, \@config ) ) {
                            die "Sphinx::Config: $self->{_filename}:$first: Base section '$tok' does not exist";
                        } 
			$seq = "openblock";
		    }
		    elsif ($seq eq "openblock") {
                        die "Sphinx::Config: $self->{_filename}:$first: expected '{'" unless $tok eq "{";
			$seq = "section";
			$state = "inner";
			# return any leftovers
			$input = join(" ", @tokens);
		    }
		}
	    }
	    elsif ($state eq "inner") {
                my $pos = [ $first, $line ];
		if ($input =~ s/^\s*\}//o) {
		    $state = "outer";
                    $current->{_lines}[1] = $line;
		    $current = undef;
		}
		elsif ($input =~ s/^\s*([\w]+)\s*=\s*(.*)\s*$//o) {
		    my $k = $1;
		    my $v = $2;
		    if (exists($current->{_data}->{$k}) && ! $current->{_inherited}->{$k}) {
			if (ref($current->{_data}->{$k}) eq 'ARRAY') {
			    # append to existing array
			    push(@{$current->{_data}->{$k}}, $v);
			}
			else {
			    # promote to array
			    $current->{_data}->{$k} = [ $current->{_data}->{$k}, $v ];
			}
                        push(@{$current->{_pos}->{$k}}, $pos);
		    }
		    else {
			# first or simple value
			$current->{_data}->{$k} = $v;
                        $current->{_pos}->{$k} = [$pos];
			$current->{_inherited}->{$k} = 0;
		    }
		}
		elsif ($input =~ s/^\s+$//o) {
		    # carry on
		}
		else {
                    die "Sphinx::Config: $self->{_filename}:$line: expected name=value pair or end of section, got '$input'";
		}
	    }
	}	
    }

    $self->{_config} = \@config;
    my %keys;
    for (@config) {
	$keys{$_->{_type} . ($_->{_name}?(' ' . $_->{_name}):'')} = $_;
    }

    $self->{_keys} = \%keys;
    return;
}


# Find a section.  
# Either in $config (at parse-time) or in {_keys}
sub _find_section
{
    my( $self, $type, $name, $config ) = @_;
    if( $config ) {
        my $c;
        for (my $i = 0; $i <= $#$config; $i++) {
            $c = $config->[$i];
            next unless $c->{_name};    # ignore searchd, indexer sections
            if( $c->{_name} eq $name && $c->{_type} eq $type ) {
                return $c;
            }
        }
    }
    else {
        my $key = $type;
        $key .= " $name" if $name;
        return $self->{_keys}{$key};
    }
}

# setup (or change) the inheritance of a section
# returns true on success
# returns undef if it can't find the base section
sub _setup_inherit
{
    my( $self, $current, $base_name, $config ) = @_;

    my $base = $self->_find_section( $current->{_type}, $base_name, $config );
    
    return unless defined $base && $base != $current;

    my $out = $current->{_data} ||= {};

    if( $current->{_inherit} ) {
        # Delete all inherited variables
        my $I = $current->{_inherited};
        while( my( $f, $v ) = each %$I ) {
            next unless $v;
            delete $out->{$f};
        }
        $current->{_inherited} = {};
    }

    $current->{_inherit} = $base_name;
    # XXX - check that {_children} doesn't already have {_name}
    push(@{$base->{_children} ||= []}, $current->{_name});

    # copy new values over
    my $in = dclone($base->{_data} || {});
    while( my( $f, $v ) = each %$in ) {
        next if exists $out->{$f};
        $out->{$f} = $v;
        $current->{_inherited}{ $f } = 1;
    }
    return 1;
}

sub config {
    return shift->{_config};
}

sub get {
    my ($self, $type, $name, $var) = @_;

    my $key = $type;
    $key .= ' ' . $name if $name;

    my $current = $self->{_keys}->{$key};
    return undef unless $current;
    if ($var) {
	if ($var =~ m/^_/) {
	    return $current->{$var};
	}
	else {
	    return $current->{_data}->{$var};
	}
    }
    
    return $current->{_data};
}

sub set {
    my ($self, $type, $name, $var, $value) = @_;

    my $key = $type;
    $key .= ' ' . $name if $name;

    if (! $self->{_keys}->{$key}) {
        # append to configuration
	my $current = { _type => $type, _new => 1 };
	$current->{_name} = $name if $name;
	push(@{$self->{_config}}, $current);
	$self->{_keys}->{$key} = $current;
        # new lines will be created by as_string()
        # set inheritance at the same time
    }

    if( not defined $var and $value ) {
        # change inheritance
        unless( $self->_change_inherit( $key, $value ) ) {
            croak "Sphinx::Config: Unable to find $name $value for inheritance";
        }
    }
    elsif (! ref($var)) {
	if (! defined($var)) {
            # delete section
	    if (my $entry = delete $self->{_keys}->{$key}) {
		my $i = firstidx { $_ == $entry } @{$self->{_config}};
                if( $i >= 0 ) {
                    # delete config
                    splice(@{$self->{_config}}, $i, 1);
                    # delete from file
                    $self->_clear_lines( $entry->{_lines} );
                }
	    }
	}
	elsif ($var =~ m/^_/) {
            # This seems to be mainly useful for unit tests
	    if (defined $value) {
		$self->{_keys}->{$key}->{$var} = $value;
	    }
	    else {
		delete $self->{_keys}->{$key}->{$var};
	    }
            # _keys belong to us : no inheritance, not written to config file
	}
	else {
            $self->_set( $type, $name, $var, $value );
	}
    }
    elsif (ref($var) eq "HASH") {
        $self->_redefine( $type, $name, $var );
        if( $value ) {
            # Change inheritance
            unless( $self->_change_inherit( $key, $value ) ) {
                croak "Sphinx::Config: Unable to find $type $value for inheritance";
            }
        }
    }
    else {
        croak "Must provide variable name or hash, not " . ref($var);
    }

    return $self->{_keys}->{$key}->{_data};
}

# Set or remove a variable.  Deals with inheritance
sub _set
{
    my( $self, $type, $name, $var, $value ) = @_;

    my $key = $type;
    $key .= " $name" if $name;

	    if (defined $value) {
		$self->{_keys}->{$key}->{_data}->{$var} = $value;
        $self->_set_var_lines( $key, $var, $value );
	    }
	    else {
		delete $self->{_keys}->{$key}->{_data}->{$var};
        $self->_clear_var_lines( $key, $var );
	    }
    if( $self->{_keys}{$key}{_inherit} ) {
	    $self->{_keys}->{$key}->{_inherited}->{$var} = 0;
    }

	    for my $child (@{$self->{_keys}->{$key}->{_children} || []}) {
        my $ckey = join ' ', $type, $child;
        my $c = $self->{_keys}->{$ckey} or next;
		if ($self->{_bestow}) {
		    if ($c->{_inherited}->{$var}) {
			if (defined $value) {
			    $c->{_data}->{$var} = $value;
			}
			else {
			    delete $c->{_data}->{$var};
			}
		    }
		}
		else {
		    $c->{_inherited}->{$var} = 0;
            $self->_set_var_lines( $ckey, $var, $c->{_data}{$var} );
		}
	    }
}

# Completely redefine a section
sub _redefine {
    my( $self, $type, $name, $var ) = @_;
    
    my $key = $type;
    $key .= " $name" if $name;
    my $section = $self->{_keys}{$key};

    $var = dclone $var;
    # Get a list of variables that currently exist
    my @have = keys %{ $section->{_data} };
    my %had;
    @had{ @have } = (1) x @have;
    # Set new values
    foreach my $sk ( keys %$var ) {
        $self->_set( $type, $name, $sk, $var->{$sk} );
        delete $had{ $sk };
    }
    # Delete any remaining non-inherited values
    foreach my $sk ( keys %had ) {
        next if $section->{_inherited}{$sk};
        $self->_set( $type, $name, $sk );
    }
}


# Clear all lines between $pos->[0] and $pos->[1], inclusive
sub _clear_lines {
    my( $self, $pos ) = @_;
    for( my $line= $pos->[0]; $line <= $pos->[1]; $line++ ) {
        $self->{_file}[$line] = undef;
	}
}

# Clear all lines associated with a variable
sub _clear_var_lines {
    my( $self, $key, $var ) = @_;
    foreach my $pos ( @{ $self->{_keys}{$key}{_pos}{$var} } ) {
        $self->_clear_lines( $pos );
    }
}

# Append a variable to a section
sub _append_var_lines {
    my( $self, $key, $var, $value ) = @_;
    my $section = $self->{_keys}{ $key };

    # find last variable
    my( $last, $last_var, $output );
    foreach my $var ( keys %{ $section->{_pos} } ) {
        foreach my $pos ( @{ $section->{_pos}{$var} } ) {
            if( not $last or $pos->[1] > $last->[1] ) {
                $last_var = $var;
                $last = $pos
		}
		}
	    }
    # adding to an empty section?
    unless( $last ) {
        $last = $section->{_lines};
        $output = $self->_var_as_string( $var, $value );
    }
    else {
        $output = $self->_get_var_lines( $last );
        # change the key
        $output =~ s/$last_var(\s*=)/$var$1/;
        # change the value(s)
        $output = $self->_set_var_value( $output, $var, $value );
	}
    $section->{_append}{$var} = $output;
}

sub _set_var_value {
    my( $self, $output, $var, $value ) = @_;
    unless( ref $value ) {
        $output =~ s/($var\s*=\s*)(.+)$/$1$value\n/s;
    }
    else {
        my $line = $output;
        $output = '';
        foreach my $v ( @$value ) {
            $output .= $self->_set_var_value( $line, $var, $v );
        }
    }
    return $output;
}

# Convert a [min,max] into a string that may be modified
sub _get_var_lines {
    my( $self, $pos ) = @_;
    my @text;
    for( my $line= $pos->[0] ; $line <= $pos->[1] ; $line++ ) {
        push @text, $self->{_file}[$line]||'';
    }
    return join '', @text;
}

# Change the line(s) associated with a variable
sub _set_var_lines {
    my( $self, $key, $var, $value ) = @_;

    my $section = $self->{_keys}{ $key };
    croak "Can't find section $key" unless $section;

    # New variable...
    unless( $section->{_pos}{ $var } ) {
        # ... in a new section: generated by as_string
        return if $section->{_new};
    
        $self->_append_var_lines( $key, $var, $value );
        return;
    }

    # build one line based on the first instance
    my $pos = $section->{_pos}{$var}[0];
    my $input = $self->_get_var_lines( $pos );
    # modify the line
    my $output = $self->_set_var_value( $input, $var, $value );
    # clear every other instance
    $self->_clear_var_lines( $key, $var );
    # set the new line
    $self->{_file}[$pos->[0]] = $output;
    # only one pos, on only one line.  Yes this line could contain \n, but
    # and this will cause problems
    $pos->[1] = $pos->[0];
    $section->{_pos}{$var} = [ $pos ];
    return;
}

# Change the inheritance of a section
sub _set_inherit_lines {
    my( $self, $key, $base_name, $was ) = @_;

    my $section = $self->{_keys}{ $key };
    croak "Can't find section $key" unless $section;
    return 1 if $section->{_new};

    my $file = $self->{_file};
    my $pos  = $section->{_lines};
    my $done;
    for( my $line=$pos->[0]; $line <= $pos->[1]; $line++ ) {
        next unless defined $file->[$line];
        if( $was ) {
            if( ($file->[$line] =~ s/(:\s*)$was/$1$base_name/ or
                      $file->[$line] =~ s/^(\s*)$was(\s*(\{|\Z))/$1$base_name$2/ ) ) {
                return 1;
            }
        }
        elsif( $file->[$line] =~ s/\{/$base_name {/ ) {
            return 1;
        }
    }
    die "Can't find where to put the base name in ", join '', 
                @{ $file }[ $pos->[0] .. $pos->[1] ];
}

sub _change_inherit {
    my( $self, $key, $base_name ) = @_;
    my $section = $self->{_keys}{$key};
    my $was = $section->{_inherit};
    return unless $self->_setup_inherit( $section, $base_name );
    return $self->_set_inherit_lines( $key, $base_name, $was );
}

sub save {
    my ($self, $filename, $comment) = @_;

    if( not $filename and not $self->{_filename} ) {
        croak "Sphinx::Config: Please to specify the file to save to";
    }

    $filename ||= $self->{_filename};

    my $fh;
    open($fh, ">$filename") or croak "Sphinx::Config: Cannot open $filename for writing";
    print $fh $self->as_string($comment);
    close($fh);
}

sub as_string {
    my ($self, $comment) = @_;

    # By using a copy, ->as_string can be called multiple times, even
    # if we append variables to a section.  Otherwise the new variables
    # would be added multiple times
    if (! $self->{_file} || ! @{$self->{_file}}) {
        return $self->as_string_new($comment);
    }
    my $file = [@{ $self->{_file} }];

    # Find new sections and variables
    my @todo;
    foreach my $section ( @{ $self->{_config} } ) {
        unless( $section->{_lines} ) {
            push @todo, $section;
            next;
        }
        if( $section->{_append} ) {
            my $A = { %{ $section->{_append} } };
            my $pos = $section->{_lines};
            LINE:
            for( my $line = $pos->[0] ; $line <= $pos->[1] ; $line++ ) {
                foreach my $var ( keys %$A ) {
                    next unless $file->[$line] =~ /(\s*)#\s*$var/;
                    my $prefix = $1;
                    my $output = delete $A->{$var};
                    $output =~ s/^\s+//;
                    $file->[$line] .= "$prefix$output";
                    next LINE;
                }
            }
            if( %$A ) {
                my $add = join '', values %$A;
                $DB::single = 1;
                $file->[ $pos->[1] ] =~ s/}/$add}/;
            }
        }
    }
    
    # Build a config string
    my $s = $comment ? "$comment\n" : "";
    foreach my $line ( @$file ) {
        next unless defined $line;
        $s .= $line;
    }

    # Append new sections
    for my $c (@todo) {
        $s .= "\n" if $s =~ /}$/;
	$s .= $c->{_type} . ($c->{_name} ? (" " . $c->{_name}) : '');
	my $data = dclone($c->{_data});
	if ($c->{_inherit} && $self->{_bestow}) {
	    $s .= " : " . $c->{_inherit};
	    # my $base = $self->get($c->{_type}, $c->{_inherit});
	}
	my $section = " {\n";
	for my $k (sort keys %$data) {
	    next if $self->{_bestow} && $c->{_inherited}->{$k};
            $section .= $self->_var_as_string( $k, $data->{$k} );
	}
	$s .= $section . "}\n";
    }

    return $s;
}

sub _var_as_string
{
    my( $self, $k, $value ) = @_;
    my $section = '';
    if ( ref($value) eq 'ARRAY' ) {
        for my $v (@$value ) {
            $section .= $self->_var_as_string( $k, $v );
        }
    }
    else {
        $section .= '        ' . $k . ' = ' . $value . "\n";
    }
    return $section;
}

sub as_string_new {
    my ($self, $comment) = @_;

    my $s = $comment ? "$comment\n" : "";
    for my $c (@{$self->{_config}}) {
	$s .= $c->{_type} . ($c->{_name} ? (" " . $c->{_name}) : '');
	my $data = dclone($c->{_data});
	if ($c->{_inherit} && $self->{_bestow}) {
	    $s .= " : " . $c->{_inherit};
	    my $base = $self->get($c->{_type}, $c->{_inherit});
	}
	my $section = " {\n";
	for my $k (sort keys %$data) {
	    next if $self->{_bestow} && $c->{_inherited}->{$k};
	    if (ref($data->{$k}) eq 'ARRAY') {
		for my $v (@{$data->{$k}}) {
		    $section .= '        ' . $k . ' = ' . $v . "\n";
		}
	    }
	    else {
		$section .= '        ' . $k . ' = ' . $data->{$k} . "\n";
	    }
	}
	$s .= $section . "}\n";
    }

    return $s;
}

1; # End of Sphinx::Config