package Xconfig::parse; # $Id: parse.pm 247269 2008-10-01 13:57:30Z pixel $

use diagnostics;
use strict;

use common;


sub read_XF86Config {
    my ($file) = @_;
    my $raw = _rraw_from_file($file);
    _from_rraw(@$raw);
    $raw;
}

sub prepare_write_XF86Config {
    my ($raw) = @_;
    map { _raw_to_string(_before_to_string({ %$_ }, 0)) } @$raw;
}

sub write_XF86Config {
    my ($raw, $file) = @_;
    my @blocks = prepare_write_XF86Config($raw);
    @blocks ? output($file, @blocks) : unlink $file;
}

sub read_XF86Config_from_string {
    my ($s) = @_;
    my $raw = _rraw_from_file('-', [ split "\n", $s ]);
    _from_rraw(@$raw);
    $raw;
}

#-###############################################################################
#- raw reading/saving
#-###############################################################################
sub _rraw_from_file {
    my ($file, $o_lines) = @_;
    my $rraw = [];

    my $lines = $o_lines || [ cat_($file) ];
    my $line;

    my ($comment, $obj, @objs);

    my $attach_comment = sub {
	$obj || @objs or warn "$file:$line: can not attach comment\n";
	if ($comment) {
	    $comment =~ s/\n+$/\n/;
	    ($obj || $objs[0])->{$_[0] . '_comment'} = $comment;
	    $comment = '';
	}
    };

    foreach (@$lines) {
	$line++;
	s/^\s*//; s/\s*$//;

	if (/^$/) {
	    $comment .= "\n" if $comment;
	    next;
	} elsif (@objs ? m/^#\W/ || /^#$/ : /^#/) {
	    s/^#\s+/# /;
	    $comment .= "$_\n";
	    next;
	}

	if (/^Section\s+"(.*)"/i) {
	    die "$file:$line: missing EndSection\n" if @objs;
	    my $e = { name => $1, l => [], kind => 'Section' };
	    push @$rraw, $e;
	    unshift @objs, $e; $obj = '';
	    $attach_comment->('pre');
	} elsif (/^Subsection\s+"(.*)"/i) {
	    die "$file:$line: missing EndSubsection\n" if  @objs && $objs[0]{kind} eq 'Subsection';
	    die "$file:$line: not in Section\n"        if !@objs || $objs[0]{kind} ne 'Section';
	    my $e = { name => $1, l => [], kind => 'Subsection' };
	    push @{$objs[0]{l}}, $e;
	    unshift @objs, $e; $obj = '';
	    $attach_comment->('pre');
	} elsif (/^EndSection/i) {
	    die "$file:$line: not in Section\n"        if !@objs || $objs[0]{kind} ne 'Section';
	    $attach_comment->('post');
	    shift @objs; $obj = '';
	} elsif (/^EndSubsection/i) {
	    die "$file:$line: not in Subsection\n"     if !@objs || $objs[0]{kind} ne 'Subsection';
	    $attach_comment->('post');
	    shift @objs; $obj = '';
	} else {
	    die "$file:$line: not in Section\n" if !@objs;

	    my $commented = s/^#//;

	    my $comment_on_line;
	    s/(\s*#.*)/$comment_on_line = $1; ''/e;

	    if (/^$/) {
		die "$file:$line: weird";
	    }

	    (my $name, my $Option, $_)  = 
 	      /^Option\s*"(.*?)"(.*)/ ? ($1, 1, $2) : /^(\S+)(.*)/ ? ($1, 0, $2) : internal_error($_);
	    my ($val) = /(\S.*)/;

	    my %e = (Option => $Option, commented => $commented, comment_on_line => $comment_on_line, pre_comment => $comment);
	    $comment = '';
	    $obj = { name => $name, val => $val };
	    $e{$_} and $obj->{$_} = $e{$_} foreach keys %e;

	    push @{$objs[0]{l}}, $obj;
	}
    }
    $rraw;
}

sub _simple_val_to_string {
    my ($name, $e) = @_;
    my $key = $e->{Option} ? qq(Option "$name") : $name;
    my $val = defined $e->{val} ? ($e->{Option} && $e->{val} !~ /^"/ ? qq( "$e->{val}") : qq( $e->{val})) : '';
    ($e->{commented} ? '#' : '') . $key . $val;
}

sub _raw_to_string {
    my ($e, $b_want_spacing) = @_;
    my $s = do {
	if ($e->{l}) {
	    my $inside = join('', map_index { _raw_to_string($_, $::i) } @{$e->{l}});
	    $inside .= $e->{post_comment} || '';
	    $inside =~ s/^/    /mg;
	    qq(\n$e->{kind} "$e->{name}"\n) . $inside . "End$e->{kind}";
	} else {
	    _simple_val_to_string($e->{name}, $e);
	}
    };
    ($e->{pre_comment} ? ($b_want_spacing ? "\n" : '') . $e->{pre_comment} : '') . $s . ($e->{comment_on_line} || '') . "\n" . (!$e->{l} && $e->{post_comment} || '');
}

#-###############################################################################
#- refine the data structure for easier use
#-###############################################################################
my %kind_names = (
    Pointer  => [ qw(Protocol Device Emulate3Buttons Emulate3Timeout EmulateWheel EmulateWheelButton) ],
    Mouse    => [ qw(DeviceName Protocol Device AlwaysCore Emulate3Buttons Emulate3Timeout EmulateWheel EmulateWheelButton) ], # Subsection in XInput
    Keyboard => [ qw(Protocol Driver XkbModel XkbLayout XkbVariant XkbDisable) ],
    Monitor  => [ qw(Identifier VendorName ModelName HorizSync VertRefresh PreferredMode) ],
    Device   => [ qw(Identifier VendorName BoardName Chipset Driver VideoRam Screen BusID DPMS power_saver AccelMethod MonitorLayout TwinViewOrientation BIOSHotkeys RenderAccel SWCursor XaaNoOffscreenPixmaps) ],
    Display  => [ qw(Depth Modes Virtual) ], # Subsection in Device
    Screen   => [ qw(Identifier Driver Device Monitor DefaultDepth DefaultColorDepth) ],
    Extensions  => [ qw(Composite) ],
    InputDevice => [ qw(Identifier Driver Protocol Device Type Mode XkbModel XkbLayout XkbVariant XkbDisable Emulate3Buttons Emulate3Timeout EmulateWheel EmulateWheelButton) ],
    WacomCursor => [ qw(Port) ], #-\
    WacomStylus => [ qw(Port) ], #--> Port must be first
    WacomEraser => [ qw(Port) ], #-/
    ServerLayout => [ qw(Identifier) ],
);
my @want_string = qw(Identifier DeviceName VendorName ModelName BoardName Driver Device Chipset Monitor Protocol XkbModel XkbLayout XkbVariant XkbOptions XkbCompat Load Disable ModulePath BusID PreferredMode);

%kind_names = map_each { lc $::a => [ map { lc } @$::b ] } %kind_names;
@want_string = map { lc } @want_string;

sub _from_rraw {
    sub _from_rraw__rec {
	my ($current, $e) = @_;
	if ($e->{l}) {
	    _from_rraw($e);
	    push @{$current->{l}{$e->{name}}}, $e;
	} else {
	    if (member(lc $e->{name}, @want_string) || $e->{Option} && $e->{val}) {
		$e->{val} =~ s/^"(.*)"$/$1/ or warn "$e->{name} $e->{val} has no quote\n";
	    }

	    if (member(lc $e->{name}, @{$kind_names{lc $current->{name}} || []})) {
		if ($current->{l}{$e->{name}} && !$current->{l}{$e->{name}}{commented}) {
		    warn "skipping conflicting line for $e->{name} in $current->{name}\n" if !$e->{commented};
		} else {
		    $current->{l}{$e->{name}} = $e;
		}
	    } else {
		push @{$current->{l}{$e->{name}}}, $e;
	    }
	}
	delete $e->{name};
    }

    foreach my $e (@_) {
	($e->{l}, my $l) = ({}, $e->{l});
	_from_rraw__rec($e, $_) foreach @$l;

	delete $e->{kind};
    }
}

sub _before_to_string {
    my ($e, $depth) = @_;

    if ($e->{l}) {
	$e->{kind} = $depth ? 'Subsection' : 'Section';

	my %rated = map_index { $_ => $::i + 1 } @{$kind_names{lc $e->{name}} || []};
	my @sorted = sort { ($rated{lc $a} || 99) <=> ($rated{lc $b} || 99) } keys %{$e->{l}};
	$e->{l} = [ map {		  
	    my $name = $_;
	    map { 
		_before_to_string({ name => $name, %$_ }, $depth+1);
	    } deref_array($e->{l}{$name});
	} @sorted ];
    } elsif (member(lc $e->{name}, @want_string)) {
	$e->{val} = qq("$e->{val}");
    }
    $e;
}