lib/Xconfig/parse.pm

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 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 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 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;
}
1	package Xconfig::parse; # $Id: parse.pm 247269 2008-10-01 13:57:30Z pixel $
2
3	use diagnostics;
4	use strict;
5
6	use common;
7
8
9	sub read_XF86Config {
10	my ($file) = @_;
11	my $raw = _rraw_from_file($file);
12	_from_rraw(@$raw);
13	$raw;
14	}
15
16	sub prepare_write_XF86Config {
17	my ($raw) = @_;
18	map { _raw_to_string(_before_to_string({ %$_ }, 0)) } @$raw;
19	}
20
21	sub write_XF86Config {
22	my ($raw, $file) = @_;
23	my @blocks = prepare_write_XF86Config($raw);
24	@blocks ? output($file, @blocks) : unlink $file;
25	}
26
27	sub read_XF86Config_from_string {
28	my ($s) = @_;
29	my $raw = _rraw_from_file('-', [ split "\n", $s ]);
30	_from_rraw(@$raw);
31	$raw;
32	}
33
34	#-###############################################################################
35	#- raw reading/saving
36	#-###############################################################################
37	sub _rraw_from_file {
38	my ($file, $o_lines) = @_;
39	my $rraw = [];
40
41	my $lines = $o_lines \|\| [ cat_($file) ];
42	my $line;
43
44	my ($comment, $obj, @objs);
45
46	my $attach_comment = sub {
47	$obj \|\| @objs or warn "$file:$line: can not attach comment\n";
48	if ($comment) {
49	$comment =~ s/\n+$/\n/;
50	($obj \|\| $objs[0])->{$_[0] . '_comment'} = $comment;
51	$comment = '';
52	}
53	};
54
55	foreach (@$lines) {
56	$line++;
57	s/^\s//; s/\s$//;
58
59	if (/^$/) {
60	$comment .= "\n" if $comment;
61	next;
62	} elsif (@objs ? m/^#\W/ \|\| /^#$/ : /^#/) {
63	s/^#\s+/# /;
64	$comment .= "$_\n";
65	next;
66	}
67
68	if (/^Section\s+"(.*)"/i) {
69	die "$file:$line: missing EndSection\n" if @objs;
70	my $e = { name => $1, l => [], kind => 'Section' };
71	push @$rraw, $e;
72	unshift @objs, $e; $obj = '';
73	$attach_comment->('pre');
74	} elsif (/^Subsection\s+"(.*)"/i) {
75	die "$file:$line: missing EndSubsection\n" if @objs && $objs[0]{kind} eq 'Subsection';
76	die "$file:$line: not in Section\n" if !@objs \|\| $objs[0]{kind} ne 'Section';
77	my $e = { name => $1, l => [], kind => 'Subsection' };
78	push @{$objs[0]{l}}, $e;
79	unshift @objs, $e; $obj = '';
80	$attach_comment->('pre');
81	} elsif (/^EndSection/i) {
82	die "$file:$line: not in Section\n" if !@objs \|\| $objs[0]{kind} ne 'Section';
83	$attach_comment->('post');
84	shift @objs; $obj = '';
85	} elsif (/^EndSubsection/i) {
86	die "$file:$line: not in Subsection\n" if !@objs \|\| $objs[0]{kind} ne 'Subsection';
87	$attach_comment->('post');
88	shift @objs; $obj = '';
89	} else {
90	die "$file:$line: not in Section\n" if !@objs;
91
92	my $commented = s/^#//;
93
94	my $comment_on_line;
95	s/(\s#.)/$comment_on_line = $1; ''/e;
96
97	if (/^$/) {
98	die "$file:$line: weird";
99	}
100
101	(my $name, my $Option, $_) =
102	/^Option\s"(.?)"(.)/ ? ($1, 1, $2) : /^(\S+)(.)/ ? ($1, 0, $2) : internal_error($_);
103	my ($val) = /(\S.*)/;
104
105	my %e = (Option => $Option, commented => $commented, comment_on_line => $comment_on_line, pre_comment => $comment);
106	$comment = '';
107	$obj = { name => $name, val => $val };
108	$e{$_} and $obj->{$_} = $e{$_} foreach keys %e;
109
110	push @{$objs[0]{l}}, $obj;
111	}
112	}
113	$rraw;
114	}
115
116	sub _simple_val_to_string {
117	my ($name, $e) = @_;
118	my $key = $e->{Option} ? qq(Option "$name") : $name;
119	my $val = defined $e->{val} ? ($e->{Option} && $e->{val} !~ /^"/ ? qq( "$e->{val}") : qq( $e->{val})) : '';
120	($e->{commented} ? '#' : '') . $key . $val;
121	}
122
123	sub _raw_to_string {
124	my ($e, $b_want_spacing) = @_;
125	my $s = do {
126	if ($e->{l}) {
127	my $inside = join('', map_index { _raw_to_string($_, $::i) } @{$e->{l}});
128	$inside .= $e->{post_comment} \|\| '';
129	$inside =~ s/^/ /mg;
130	qq(\n$e->{kind} "$e->{name}"\n) . $inside . "End$e->{kind}";
131	} else {
132	_simple_val_to_string($e->{name}, $e);
133	}
134	};
135	($e->{pre_comment} ? ($b_want_spacing ? "\n" : '') . $e->{pre_comment} : '') . $s . ($e->{comment_on_line} \|\| '') . "\n" . (!$e->{l} && $e->{post_comment} \|\| '');
136	}
137
138	#-###############################################################################
139	#- refine the data structure for easier use
140	#-###############################################################################
141	my %kind_names = (
142	Pointer => [ qw(Protocol Device Emulate3Buttons Emulate3Timeout EmulateWheel EmulateWheelButton) ],
143	Mouse => [ qw(DeviceName Protocol Device AlwaysCore Emulate3Buttons Emulate3Timeout EmulateWheel EmulateWheelButton) ], # Subsection in XInput
144	Keyboard => [ qw(Protocol Driver XkbModel XkbLayout XkbDisable) ],
145	Monitor => [ qw(Identifier VendorName ModelName HorizSync VertRefresh PreferredMode) ],
146	Device => [ qw(Identifier VendorName BoardName Chipset Driver VideoRam Screen BusID DPMS power_saver AccelMethod MonitorLayout TwinViewOrientation BIOSHotkeys RenderAccel SWCursor XaaNoOffscreenPixmaps) ],
147	Display => [ qw(Depth Modes Virtual) ], # Subsection in Device
148	Screen => [ qw(Identifier Driver Device Monitor DefaultDepth DefaultColorDepth) ],
149	Extensions => [ qw(Composite) ],
150	InputDevice => [ qw(Identifier Driver Protocol Device Type Mode XkbModel XkbLayout XkbDisable Emulate3Buttons Emulate3Timeout EmulateWheel EmulateWheelButton) ],
151	WacomCursor => [ qw(Port) ], #-\
152	WacomStylus => [ qw(Port) ], #--> Port must be first
153	WacomEraser => [ qw(Port) ], #-/
154	ServerLayout => [ qw(Identifier) ],
155	);
156	my @want_string = qw(Identifier DeviceName VendorName ModelName BoardName Driver Device Chipset Monitor Protocol XkbModel XkbLayout XkbOptions XkbCompat Load Disable ModulePath BusID PreferredMode);
157
158	%kind_names = map_each { lc $::a => [ map { lc } @$::b ] } %kind_names;
159	@want_string = map { lc } @want_string;
160
161	sub _from_rraw {
162	sub _from_rraw__rec {
163	my ($current, $e) = @_;
164	if ($e->{l}) {
165	_from_rraw($e);
166	push @{$current->{l}{$e->{name}}}, $e;
167	} else {
168	if (member(lc $e->{name}, @want_string) \|\| $e->{Option} && $e->{val}) {
169	$e->{val} =~ s/^"(.*)"$/$1/ or warn "$e->{name} $e->{val} has no quote\n";
170	}
171
172	if (member(lc $e->{name}, @{$kind_names{lc $current->{name}} \|\| []})) {
173	if ($current->{l}{$e->{name}} && !$current->{l}{$e->{name}}{commented}) {
174	warn "skipping conflicting line for $e->{name} in $current->{name}\n" if !$e->{commented};
175	} else {
176	$current->{l}{$e->{name}} = $e;
177	}
178	} else {
179	push @{$current->{l}{$e->{name}}}, $e;
180	}
181	}
182	delete $e->{name};
183	}
184
185	foreach my $e (@_) {
186	($e->{l}, my $l) = ({}, $e->{l});
187	_from_rraw__rec($e, $_) foreach @$l;
188
189	delete $e->{kind};
190	}
191	}
192
193	sub _before_to_string {
194	my ($e, $depth) = @_;
195
196	if ($e->{l}) {
197	$e->{kind} = $depth ? 'Subsection' : 'Section';
198
199	my %rated = map_index { $_ => $::i + 1 } @{$kind_names{lc $e->{name}} \|\| []};
200	my @sorted = sort { ($rated{lc $a} \|\| 99) <=> ($rated{lc $b} \|\| 99) } keys %{$e->{l}};
201	$e->{l} = [ map {
202	my $name = $_;
203	map {
204	_before_to_string({ name => $name, %$_ }, $depth+1);
205	} deref_array($e->{l}{$name});
206	} @sorted ];
207	} elsif (member(lc $e->{name}, @want_string)) {
208	$e->{val} = qq("$e->{val}");
209	}
210	$e;
211	}