lib/Config/Model/Backend/Xorg/Read.pm

#
# This file is part of Config-Model-Xorg
#
# This software is Copyright (c) 2011 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::Xorg::Read ;
{
  $Config::Model::Backend::Xorg::Read::VERSION = '1.106';
}

use Any::Moose 'Role';

use Carp ;
use IO::File ;
use Log::Log4perl;
use Data::Dumper ;

my $logger = Log::Log4perl::get_logger('Backend::Xorg::Read');

# return a data structure in the form :
#   hash_ref->array_ref->hash_ref->array_ref
#
# { section_name => [ 
#                     # section_a
#                     { element_name => [ [ value_a ] , [ va, lue, _b ] },
#                     ...
#                     # section_b 
#                     ...
#                   ],
# },
# ...
sub parse_raw_xorg {
    my $xorg_lines = shift ;

    my %data ;

    while (@$xorg_lines) {
	my $line_data = shift @$xorg_lines ;
	my ($line_nb,$line) = @$line_data ;
	my ($raw_key,$value) = split /\s+/,$line,2;
	my $key = lc($raw_key) ;
	if ($key eq 'section') {
	    # Section names are insensitive to '_' and ' '
	    $value =~ s/["_ ]+//g;
	    push @{$data{lc($value)}}, 
	      [ $line_nb, parse_raw_section($xorg_lines) ] ;
	}
    }

    return \%data ;
}

sub parse_raw_section {
    my $xorg_lines = shift ;

    my %data ;
    $logger->debug( "parse_raw_section: called on xorg file $xorg_lines->[0][0]");

    while (@$xorg_lines) {
	my $line_data = shift @$xorg_lines ;
	my ($line_nb,$line) = @$line_data ;
	my ($raw_key,$value) = split /\s+/,$line,2;

	my $key = lc($raw_key) ; # keys are case insensitive
	$key =~ s/_+//g;  # keys are insensitive to '_'

	if ($key =~ /end(sub)?section/) {
	    return \%data ;
	}
	elsif ($key eq 'subsection') {
	    $value =~ s/["_ ]//g;
	    my $store = lc($value) ; # subsection name is case insensitive
	    $logger->debug("parse_raw_section: SubSection $value $line_nb");
	    push @{$data{$store}}, [ $line_nb, parse_raw_section($xorg_lines) ];
	}
	else {
	    my @store = ( $line_nb ) ;
	    while (length($value)) {
		if ($value =~ /^"([^"]+)"/) {
		    push @store,$1 ;
		    $value =~ s/^"[^"]+"\s*//g;
		}
		elsif ($value =~ /^([^"\s]+)/) {
		    push @store,$1 ;
		    $value =~ s/^([^"\s]+)\s*//g;
		}
		else {
		    die "parse_raw_section: unexpected value $value";
		}

	    }
	    push @{$data{$key}}, \@store ;
	}
    }
}

# Need to update functions beloow
sub parse_all {
    my $xorg_conf = shift;
    my $root = shift ;
    $logger->debug("parse_all: called on ".join(' ', keys %$xorg_conf));

    # parse section data according to model elements order
    foreach my $section_name ($root->get_element_name) {
	my $lc_section_name = lc($section_name) ;

	my $section_data_ref = delete $xorg_conf->{$lc_section_name} ;
	next unless defined $section_data_ref ;

	foreach	my $section_data (@$section_data_ref) {
	    $logger->debug( "parse_all: section '$section_name'");
	    parse_section($section_data,$root->fetch_element($section_name)) ;
	}
    }

    if (keys %$xorg_conf) {
	die "can't handle section ", join(' ',keys %$xorg_conf),
	  ": Error in input file or Xorg model is incomplete";
    }
}

sub parse_option {
    my ($obj, $trash, $line, @args) = @_ ;
    my $opt = shift @args;
    $logger->debug( "parse_option: called on option $opt $line");

    if ($obj->config_class_name eq 'Xorg::ServerFlags') {
	$logger->debug( "parse_option: obj ",$obj->name, " ($line) load option '$opt' ");
	my $opt_obj = $obj->fetch_element($opt) ;
	$opt_obj->store ( @args  ? $args[0] : 1 ) ;
    }
    elsif ($opt =~ /Core(Keyboard|Pointer)/ ) {
	my $id = $obj -> index_value ;
	$logger->debug( "parse_option: ($line) Load top level $opt to '$id'");
	$obj->load( qq(! $opt="$id") ) ;
    }
    elsif (    $obj->config_class_name eq 'Xorg::InputDevice' 
	   and $opt eq 'AutoRepeat') {
	$logger->debug( "parse_option: obj ",$obj->name, " ($line) load option '$opt' with '",
			join('+',@args),"' ");
	my @v = split / /,$args[0] ;
	my $load = sprintf ( "Option AutoRepeat delay=%s rate=%s", @v);
	$logger->debug( "parse_option: ",$obj->name," load '$load'");
	$obj->load($load) ;
    }
    elsif (     $obj->config_class_name eq 'Xorg::InputDevice'
	    and $opt eq 'XkbOptions' ) {
	$logger->debug( "parse_option: obj ",$obj->name, " ($line) load option '$opt' with '",
			join('+',@args),"' ");
	my @v = split /:/,$args[0] ;
	my $load = sprintf ( "Option XkbOptions %s=%s", @v);
	$logger->debug( "parse_option: ",$obj->name," load '$load'");
	$obj->load($load) ;
    }
    else {
	# dont' work for ServerFlags
	my $opt_p_obj = $obj->fetch_element("Option") ;
	my $opt_obj;
	if ($opt_p_obj->has_element($opt)) {
	    $logger->debug( "parse_option: obj ",$obj->name, " ($line) load option '$opt' ");
	    $opt_obj= $opt_p_obj->fetch_element($opt) ;
	    $opt_obj->store ( @args  ? $args[0] : 1 ) if defined $opt_obj ;
	}
	elsif ($opt_p_obj->instance->get_value_check('fetch_or_store')) {
	    Config::Model::Exception::UnknownElement
		-> throw(
			 object   => $opt_p_obj,
			 where    => $opt_p_obj->location ,
			 element  => $opt,
			);
	}
	else {
	    $logger->warn( "parse_option: obj ",$obj->name, " ($line) option '$opt' is unknown");
	}
    }
}

my %mode_flags = (
	     '+hsync' => "HSyncPolarity=positive",
	     '-hsync' => "HSyncPolarity=negative",
	     '+vsync' => "VSyncPolarity=positive",
	     '-vsync' => "VSyncPolarity=negative",
	     '+csync' => "CSyncPolarity=positive",
	     '-csync' => "CSyncPolarity=negative",
	    );

sub parse_mode_line {
    my ($obj, $trash, $line, $mode, @m) = @_ ;

    # force @v content to be numerical instead of strings
    my @v = map { 0 + $_ } splice @m,0,9 ;

    my $load = "Mode:$mode DotClock=$v[0] ";
    $load .= "HTimings disp=$v[1] syncstart=$v[2] syncend=$v[3] total=$v[4] - ";
    $load .= "VTimings disp=$v[5] syncstart=$v[6] syncend=$v[7] total=$v[8] - ";

    $load .= "Flags " . join (' ', map {$mode_flags{lc($_)} || "$_=1" } @m ) . ' - ' 
      if @m ;

    $logger->debug( "parse_mode_line: ($line) load '$load'");
    $obj->load($load) ;
}

sub parse_modes_list {
    my ($obj, $trash, $line_nb, @modes) = @_ ;

    my $load = "Modes=".join(',',@modes);
    $logger->debug( "parse_modes_list: ($line_nb))load '$load'");
    $obj->load($load) ;
}

# called while parsing ServerLayout or Device
# key is always 'Screen'
sub parse_layout_screen {
    my ($obj, $key, $line, $value, @args) = @_ ;

    my $load;

    if ($obj->config_class_name eq 'Xorg::Device') {
	$load = "Screen=$value";
    }
    else {
	my ($num, $screen_id);
	if ($value =~ /^(\d+)$/) {
	    $num = $value ;
	    $screen_id = shift @args ;
	} 
	else {
	    $num = 0;
	    $screen_id = $value ;
	}

	$load = "Screen:$num screen_id=\"$screen_id\" ";

	$logger->debug( "parse_layout_screen: screen load '$load'");

	if (@args) {
	    # there's a position information
	    my ($relative_spec, $pos );

	    if ( $args[0] =~ /^\d+$/ ) {
		$pos = 'Absolute' ;
		$relative_spec = sprintf("x=%s y=%s",@args) ;
	    }
	    elsif ($args[0] eq 'Absolute') {
		$pos = shift @args ;
		$relative_spec = sprintf("x=%s y=%s",@args) ;
	    }
	    elsif ($args[0] eq 'Relative') {
		$pos = shift @args ;
		$relative_spec = sprintf("screen_id=\"%s\" x=%s y=%s",@args) ;
	    }
	    else {
		$pos = shift @args;
		$relative_spec = sprintf("screen_id=\"%s\"",@args) ;
	    }
	    $load .= "position relative_screen_location=$pos $relative_spec ";
	}
	$logger->debug( "parse_layout_screen: Screen ($line) load '$load' ");
    }

    $logger->debug( "parse_layout_screen:", $obj->config_class_name," load '$load'");
    $obj->load($load) ;
}

# called when parsing section ServerLayout
sub parse_input_device {
    my ($obj, $trash, $line ,$id, @opt) = @_ ;

    $logger->debug( "$trash id:'$id' option '".join("' '",@opt)."'");

    my $dev = $obj->fetch_element('InputDevice') -> fetch_with_id($id) ;

    foreach my $opt (@opt) {
	if ($opt eq 'SendCoreEvents') {
	    $dev->fetch_element($opt)->store(1) ;
	}
	elsif ($opt =~ /Core(Keyboard|Pointer)/) {
	    $logger->debug( "parse_input_device: Load '! $opt=\"$id\"'");
	    $obj->load("! $opt=\"$id\"") ;
	}
	else {
	    die "parse_input_device ($line): Unexpected ServerLayout->InputDevice ",
	      "option: $opt. Error in input file or Xorg model is incomplete";
	}
    }
}

sub parse_display_size {
    my ($obj, $tag_name, $line ,$w, $h) = @_ ;
    $logger->debug( "$tag_name width:'$w' height:$h");
    my $load = "DisplaySize width=$w height=$h";
    $logger->debug( $obj->config_class_name," load '$load'");
    $obj->load($load) ;
}

sub parse_view_port {
    my ($obj, $tag_name, $line ,$x0, $y0) = @_ ;
    $logger->debug( "$tag_name x0:'$x0' y0:$y0");
    my $load = "ViewPort x0=$x0 y0=$y0";
    $logger->debug( $obj->config_class_name," load '$load'");
    $obj->load($load) ;
}

sub parse_virtual {
    my ($obj, $tag_name, $line ,$xdim, $ydim) = @_ ;
    $logger->debug( "$tag_name xdim:'$xdim' ydim:$ydim");
    my $load = "Virtual xdim=$xdim ydim=$ydim";
    $logger->debug( $obj->config_class_name," load '$load'");
    $obj->load($load) ;
}

sub parse_gamma {
    my ($obj, $tag_name, $line ,@g) = @_ ;
    $logger->debug( "$tag_name @g");
    my $global = @g == 1 ? 1 : 0 ;
    my $load = "Gamma use_global_gamma=$global ";
    $load .= $global ? "gamma=$g[0]" 
                     : sprintf("red_gamma=%s green_gamma=%s blue_gamma=%s",@g) ;
    $logger->debug( $obj->config_class_name," load '$load'");
    $obj->load($load) ;
}

my %parse_line 
  = (
     'fontpath' => sub { $_[0]->fetch_element($_[1])->push($_[3]) ;} ,
     'load'     => sub { $_[0]->fetch_element($_[3])->store(1)    ;} ,
     'modeline' => \&parse_mode_line,
     'option'   => \&parse_option ,
     'modes'    => \&parse_modes_list,
     'screen'   => \&parse_layout_screen,
     'inputdevice' => \&parse_input_device,
     'displaysize' => \&parse_display_size ,
     'viewport' => \&parse_view_port ,
     'virtual'  => \&parse_virtual ,
     'gamma'    => \&parse_gamma ,
    ) ;

sub parse_section {
    my $section_line_data = shift ; # [ line_nb, hash ref ]
    my $obj = shift ;

    my ($sect_line_nb, $section_data) = @$section_line_data ;

    # section like InputDevice have an identifier which must be extracted first
    my $obj_type = $obj->get_type ;
    my $has_id = $obj_type =~ /list|hash/ ? 1 : 0 ;
    my $tmp_obj = $obj ;

    $logger->debug( "parse_section ($sect_line_nb) called on ",
		    $obj->name," (has_id: $has_id)");

    # first get the identifier and create the object. 
    if ($has_id) {
	my $id_rr =  delete $section_data->{identifier}
	          || delete $section_data->{depth} ;
	if (not defined $id_rr) {
	    $logger->debug( "parse_section can't find identifier for ",$obj->name );
	    return ;
	}

	my ($line,$id) = @{$id_rr->[0]}  ;
	$logger->debug( "parse_section $line: found id '$id' for '",
			$obj->name,"'");
	$tmp_obj = $obj->fetch_with_id($id) ;
    }

    # parse special cases and section data according to model elements order
    # special case: modeline must be parsed first
    foreach my $elt_name ('modeline',$tmp_obj->get_element_name) {
	my $lc_name = lc($elt_name) ;
	my $a2_r = delete $section_data->{$lc_name}; # array of array ref ;

	next unless defined $a2_r ;

	$logger->debug( "parse_section: parse section data key '$lc_name'");

	foreach my $arg (@$a2_r) {
	    if (defined $parse_line{$lc_name}) {
		$parse_line{$lc_name} -> ($tmp_obj, $elt_name, @$arg) ;
	    }
	    elsif (ref $arg->[1] eq 'HASH') {
		# we have a subsection
		$logger->debug( $tmp_obj->name, " subsection $elt_name ");
		parse_section($arg,$tmp_obj->fetch_element($elt_name)) ;
	    }
	    else {
		my $line = shift @$arg ;
		my $val = "@$arg" ; 
		$logger->debug( $tmp_obj->name, 
				" ($line) store $elt_name = '$val'");
		$tmp_obj->fetch_element($elt_name)->store($val);
	    }
	}
    }

    if ( %$section_data ) {
	foreach my $lc_name (keys %$section_data) {
	    if (defined $parse_line{$lc_name}) {
		my $a2_r = delete $section_data->{$lc_name};
		foreach my $arg (@$a2_r) {
		    $parse_line{$lc_name} -> ($tmp_obj, $lc_name, @$arg) ;
		}
	    }
	    else {
		$logger->warn( "parse_section: unexpected '$lc_name' "
			       ."element for ", $tmp_obj->name) ;
		die ;
	    }
	}
    }
}

1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)