File Coverage

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

Criterion	Covered	Total	%
statement	193	203	95.0
branch	60	72	83.3
condition	8	9	88.8
subroutine	18	18	100.0
pod	0	13	0.0
total	279	315	88.5

#
# This file is part of Config-Model-Xorg
#
# This software is Copyright (c) 2007-2016 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.113';
use Mouse::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 = qq!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;