summaryrefslogtreecommitdiffstats
path: root/perl-install/Xconfig/parse.pm
diff options
context:
space:
mode:
Diffstat (limited to 'perl-install/Xconfig/parse.pm')
-rw-r--r--perl-install/Xconfig/parse.pm192
1 files changed, 192 insertions, 0 deletions
diff --git a/perl-install/Xconfig/parse.pm b/perl-install/Xconfig/parse.pm
new file mode 100644
index 000000000..b61651ceb
--- /dev/null
+++ b/perl-install/Xconfig/parse.pm
@@ -0,0 +1,192 @@
+package Xconfig::parse; # $Id$
+
+use diagnostics;
+use strict;
+
+use MDK::Common;
+
+
+sub read_XF86Config {
+ my ($file) = @_;
+ my $raw_X = raw_from_file($file);
+ from_raw(@$raw_X);
+ $raw_X;
+}
+
+sub write_XF86Config {
+ my ($raw_X, $file) = @_;
+ my @blocks = map { raw_to_string(before_to_string({ %$_ }, 0)) } @$raw_X;
+ @blocks ? output($file, @blocks) : unlink $file;
+}
+
+sub read_XF86Config_from_string {
+ my ($s) = @_;
+ my $raw_X = raw_from_file('-', [ split "\n", $s ]);
+ from_raw(@$raw_X);
+ $raw_X;
+}
+
+#-###############################################################################
+#- raw reading/saving
+#-###############################################################################
+sub raw_from_file { #- internal
+ my ($file, $lines) = @_;
+ my $raw_X = [];
+
+ $lines ||= [ cat_($file) ];
+ my $line;
+ my $weird = sub { warn "$file:$line: strange $_[0]" };
+
+ my ($comment, $obj, @objs);
+
+ my $attach_comment = sub {
+ $obj || @objs or warn "$file:$line: can't 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 (/^#\s+(.*)/) {
+ $comment .= "# $1\n";
+ next;
+ }
+
+ if (/^Section\s+"(.*)"/i) {
+ die "$file:$line: missing EndSection\n" if @objs;
+ my $e = { name => $1, l => [], kind => 'Section' };
+ push @$raw_X, $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');
+ my $e = 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;
+
+ (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;
+ }
+ }
+ $raw_X;
+}
+
+sub raw_to_string {
+ my ($e, $want_spacing) = @_;
+ my $s = do {
+ if ($e->{l}) {
+ my $inside = join('', map_index { raw_to_string($_, $::i) } @{$e->{l}});
+ $inside =~ s/^/ /mg;
+ qq(\n$e->{kind} "$e->{name}"\n) . $inside . "End$e->{kind}";
+ } else {
+ ($e->{commented} ? '#' : '') .
+ ($e->{Option} ? qq(Option "$e->{name}") : $e->{name}) .
+ (defined $e->{val} ? ($e->{Option} && $e->{val} !~ /^"/ ? qq( "$e->{val}") : qq( $e->{val})) : '');
+ }
+ };
+ ($e->{pre_comment} ? ($want_spacing ? "\n" : '') . $e->{pre_comment} : '') . $s . ($e->{comment_on_line} || '') . "\n" . ($e->{post_comment} || '');
+}
+
+#-###############################################################################
+#- refine the data structure for easier use
+#-###############################################################################
+my %kind_names = (
+ Pointer => [ qw(Protocol Device Emulate3Buttons Emulate3Timeout) ],
+ Mouse => [ qw(DeviceName Protocol Device AlwaysCore Emulate3Buttons Emulate3Timeout) ], # Subsection in XInput
+ Keyboard => [ qw(Protocol Driver XkbModel XkbLayout XkbDisable) ],
+ Monitor => [ qw(Identifier VendorName ModelName HorizSync VertRefresh) ],
+ Device => [ qw(Identifier VendorName BoardName Chipset Driver VideoRam Screen BusID) ],
+ Display => [ qw(Depth Modes) ], # Subsection in Device
+ Screen => [ qw(Identifier Driver Device Monitor DefaultColorDepth) ],
+ InputDevice => [ qw(Identifier Driver Protocol Device XkbModel XkbLayout XkbDisable Emulate3Buttons Emulate3Timeout) ],
+ ServerLayout => [ qw(Identifier Screen) ],
+);
+my @want_string = qw(Identifier DeviceName VendorName ModelName BoardName Driver Device Chipset Monitor Protocol XkbModel XkbLayout);
+
+%kind_names = map_each { lc $::a => [ map { lc } @$::b ] } %kind_names;
+@want_string = map { lc } @want_string;
+
+sub from_raw {
+ foreach my $e (@_) {
+ ($e->{l}, my $l) = ({}, $e->{l});
+ from_raw__rec($e, $_) foreach @$l;
+
+ delete $e->{kind};
+ }
+
+ sub from_raw__rec {
+ my ($current, $e) = @_;
+ if ($e->{l}) {
+ from_raw($e);
+ push @{$current->{l}{$e->{name}}}, $e;
+ } else {
+ if (member(lc $e->{name}, @want_string)) {
+ $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};
+ }
+}
+
+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;
+}