File Coverage

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

Criterion	Covered	Total	%
statement	134	147	91.1
branch	55	64	85.9
condition	31	47	65.9
subroutine	28	30	93.3
pod	0	22	0.0
total	248	310	80.0

#
# 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::Write ;
$Config::Model::Backend::Xorg::Write::VERSION = '1.113';
use Mouse::Role ;

use Carp ;
use IO::File ;
use Config::Model::ObjTreeScanner ;
use Log::Log4perl ;
use File::Path ;

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

sub wr_std_leaf {
    my ($scanner, $data_r, $node,$element_name,$index, $leaf_object,$v) = @_ ;
    push @$data_r , qq(\t$element_name\t"$v") if defined $v;
} ;

sub wr_module {
    my ($scanner, $data_r , $node,$element_name,$index, $leaf_object,$v) = @_ ;
    push @$data_r, qq(\tLoad "$element_name") if $v ;
} ;

sub wr_std_options {
    my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
    my $b_in = $leaf_object->upstream_default ;
    if ( defined $v && (   (not defined $b_in)
			|| (defined $b_in && $v && $v ne $b_in) )
       ) {
	my $str =  qq(\tOption\t"$element_name");
	$str .= qq(\t"$v") if defined $v && $v ;
	push @$data_r, $str ;
    }
} ;

sub wr_kbd_model_options {
    my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
    if ( defined $v && $v ) {
	push @$data_r, qq(\tOption\t"XkbOptions"\t"$element_name:$v");
    }
} ;

sub push_value {
    my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
    push @$data_r, $v if defined $v;
} ;


sub push_flag_value {
    my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
    if (defined $v && $element_name =~ s/Polarity// ) {
	$v = ($v eq 'positive' ? '+' : '-' ) . $element_name ;
	push @$data_r, $v ;
    }
    else {
	push @$data_r, $element_name if defined $v && $v ;
    }
} ;

my %dispatch_leaf
  = (
     'Xorg' => 1,
     'Xorg::Module' => \&wr_module,
     'Xorg::Files'  => \&wr_std_leaf ,
     'Xorg::InputDevice' => \&wr_std_leaf ,
     'Xorg::InputDevice::MouseOpt' => \&wr_std_options ,
     'Xorg::InputDevice::KeyboardOpt' => \&wr_std_options ,
     'Xorg::Device' => \&wr_std_leaf ,
     'Xorg::Device::Ati' => \&wr_std_options ,
     'Xorg::Device::Radeon' => \&wr_std_options ,
     'Xorg::Device::Nvidia' => \&wr_std_options ,
     'Xorg::Device::Fglrx' => \&wr_std_options ,
     'Xorg::Device::Vesa' => \&wr_std_options ,
     'Xorg::Extensions' => \&wr_std_options ,
     'Xorg::Extensions::Option' => \&wr_std_options ,
     'Xorg::Monitor' => \&wr_std_leaf ,
     'Xorg::Monitor::Option' => \&wr_std_options ,
     'Xorg::Monitor::Mode' => \&push_value ,
     'Xorg::Monitor::Mode::Timing' => \&push_value ,
     'Xorg::Monitor::Mode::Flags' => \&push_flag_value ,
     'Xorg::Screen' => \&wr_std_leaf ,
     'Xorg::Screen::Option' => \&wr_std_options ,
     'Xorg::Screen::Display' => \&wr_std_leaf ,
     'Xorg::ServerLayout' => \&wr_std_leaf ,
     'Xorg::ServerFlags' => \&wr_std_options ,
     'Xorg::DRI' => \&wr_std_leaf
    ) ;

my %dispatch_leaf_re
 = (
    'Xorg::InputDevice::KeyboardOptModel::.*' => \&wr_kbd_model_options ,
   ) ;

sub wr_leaf {
    my ($scanner, $data_r, $node,$element_name,$index, $leaf_object) = @_ ;
    my $v = $leaf_object->fetch ;
    my $class_name = $node ->config_class_name() ;
    my $cb = $dispatch_leaf{$class_name} ;

    if (not defined $cb) {
	foreach my $k (keys %dispatch_leaf_re) {
	    next unless $class_name =~ /$k/ ;
	    $cb = $dispatch_leaf_re{$k};
	    #warn "using regexp dispath $k for $class_name\n";
	    last;
	}
    }

    if (defined $cb && ref $cb) {
	$cb->(@_ ,$v ) ;
    }
    elsif (not defined $cb) {
	# can't fallback to wr_std_leaf as some elements from model
	# are not meant to be written back in xorg.conf
	warn "wr_leaf: no call-back defined for ",$node ->config_class_name() ;
    }
}

sub wr_section {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
    #print "wr_section called on ",$node->name," $element_name,$key\n";

    my @section_lines ;
    push @section_lines, qq(\tIdentifier\t"$key") if defined $key ;

    if ($element_name eq 'InputDevice') {
	map {
	    my $core_v = $node->grab_value("! $_") ;
	    push @section_lines, qq(\tOption\t"$_")
	      if (defined $core_v and $key eq $core_v) ;
	} qw/CoreKeyboard CorePointer/ ;
    }

    $scanner->scan_node(\@section_lines,$next_node) ;

    if (@section_lines) {
	push @$data_r, qq(Section "$element_name"), @section_lines,
	  "EndSection" , '' ;
    }
}

sub wr_mode_line {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    my @mode_values ;
    $scanner->scan_node(\@mode_values,$next_node) ;
    my @numbers = splice (@mode_values, 0, 9) ;

    my $flags = join(' ',@mode_values) || '' ;
    push @$data_r,
      sprintf(
	      qq(\tModeLine %-20s %8.3f %4u %4u %4u %4u %4u %4u %4u %4u %s),
	      qq("$key"), @numbers, $flags);
} ;

sub wr_sub_section {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
    {
	no warnings "uninitialized" ;
	$logger->debug( "wr_sub_section called on ",$node->name," $element_name,$key");
    }

    push @$data_r, qq(\tSubSection "$element_name") ,
                   qq(\t\tDepth\t$key) ;

    $scanner->scan_node($data_r,$next_node) ;
    push @$data_r, "\tEndSubSection" , '' ;
} ;

sub wr_serverlayout_screen {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
    my $id = $next_node->fetch_element_value('screen_id') ;
    my $rel_loc = $next_node->grab_value("position relative_screen_location") ;

    my $str = qq(\tScreen $key "$id") ;

    if (defined $rel_loc) {
	$str .= qq( $rel_loc ) ;
	my $pos_obj = $next_node->fetch_element('position') ;
	if ($pos_obj-> is_element_available('screen_id')) {
	    $str .= '"'. $pos_obj->fetch_element_value("screen_id").'" ' ;
	}
	if ($pos_obj-> is_element_available('x')) {
	    map {
		$str .= $pos_obj->fetch_element_value($_).' ' ;
		} qw/x y/ ;
	}

    }
    push @$data_r, $str ;
}

sub wr_serverlayout_inputdevice {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    my $str = qq(\tInputDevice "$key") ;
    my $sce = $next_node->fetch_element_value("SendCoreEvents");
    if (defined $sce && $sce) {
	$str .= ' "SendCoreEvents" ' ;
    }
    push @$data_r, $str ;
}

sub wr_monitor_display_size {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    my $w = $next_node->fetch_element_value("width") ;
    my $h = $next_node->fetch_element_value("height") ;

    push @$data_r, "\tDisplaySize\t$w $h" if defined $w && defined $h;
}

sub wr_monitor_gamma {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    if ($next_node->fetch_element_value("use_global_gamma")) {
	my $g = $next_node->fetch_element_value("gamma") ;
	push @$data_r, "\tGamma\t$g" if defined $g ;
    }
    else {
	my @v = map { $next_node->fetch_element_value($_."_gamma") }
	  qw/red green blue/ ;
	push @$data_r, "\tGamma\t@v" ;
    }

}

sub wr_screen_display_virtual {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    my $x = $next_node->fetch_element_value("xdim") ;
    my $y = $next_node->fetch_element_value("ydim") ;

    push @$data_r, "\t\tVirtual\t$x $y" if defined $x && defined $y;
}

sub wr_screen_display_viewport {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    my $x = $next_node->fetch_element_value("x0") ;
    my $y = $next_node->fetch_element_value("y0") ;

    push @$data_r, "\t\tViewPort\t$x $y" if defined $x && defined $y;
}

sub wr_device_kbd_autorepeat {
    my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;

    my $d = $next_node->fetch_element_value("delay") ;
    my $r = $next_node->fetch_element_value("rate") ;

    push @$data_r, qq(\tOption\t"AutoRepeat" "$d $r")
      if defined $d && defined $r;
}

my %dispatch_node
  = (
     'Xorg' => 1 ,
     'Xorg::Extensions' => \&wr_section,
     'Xorg::Files' => \&wr_section,
     'Xorg::Module' => \&wr_section,
     'Xorg::InputDevice' => \&wr_section,
     'Xorg::InputDevice::KeyboardOpt::AutoRepeat' => \&wr_device_kbd_autorepeat,
     'Xorg::Device' => \&wr_section,
     'Xorg::DRI' => \&wr_section,
     'Xorg::Monitor' => \&wr_section,
     'Xorg::Monitor::Mode' => \&wr_mode_line ,
     'Xorg::Monitor::DisplaySize' => \&wr_monitor_display_size ,
     'Xorg::Monitor::Gamma' => \&wr_monitor_gamma ,
     'Xorg::Screen' => \&wr_section,
     'Xorg::Screen::Display' => \&wr_sub_section,
     "Xorg::Screen::Display::Virtual" => \&wr_screen_display_virtual,
     "Xorg::Screen::Display::ViewPort" => \&wr_screen_display_viewport,
     'Xorg::ServerLayout' => \&wr_section,
     'Xorg::ServerFlags' => \&wr_section,
     'Xorg::ServerLayout::Screen' => \&wr_serverlayout_screen,
     'Xorg::ServerLayout::InputDevice' => \&wr_serverlayout_inputdevice,
    ) ;

sub wr_node {
    my ($scanner, $data_r, $node,$element_name,$key, $next_node) = @_;
    my $dispatcher_data = $next_node->config_class_name ;
    my $cb = $dispatch_node{$dispatcher_data} ;
    if (defined $cb && ref $cb) { $cb->(@_) ; }
    elsif (defined $cb && $cb) {
	$scanner->scan_node($data_r,$next_node) ;
    }
    else {
	no warnings "uninitialized" ;
	$logger->debug( "wr_node called on $dispatcher_data $element_name,$key");
	$scanner->scan_node($data_r,$next_node) ;
    }
} ;

sub wr_mode_list {
    my ($scanner, $data_ref,$node,$element_name,@indexes) = @_ ;
    my @list = $node->fetch_element($element_name)->fetch_all_values ;
    push @$data_ref, qq(\t\tModes\t").join('" "',@list).'"' if @list;
}

my %dispatch_list = ( 'Xorg::Screen::Display' => \&wr_mode_list );

sub wr_list {
    my ($scanner, $data_ref,$node,$element_name,@indexes) = @_ ;
    my $dispatcher_data = $node->config_class_name ;
    my $cb = $dispatch_list{$dispatcher_data} ;
    if (defined $cb ) { $cb->(@_) ; }
    else {
	# resume exploration
	map {$scanner->scan_list($data_ref,$node,$element_name,$_)} @indexes ;
    }
}

sub wr_check_list {
    my ($scanner, $data_ref,$node,$element_name,@indexes) = @_ ;
    #warn "wr_check_list called on node ".$node->name." element $element_name\n";
    my @list = $node->fetch_element($element_name)->get_checked_list ;
    push @$data_ref, qq(\t\t$element_name\t").join('" "',@list).'"' if @list;
}

sub write_all {
    my $root = shift ;

    $logger->debug( "write_all called");

    my @result = ("# Xorg.conf written by Xorg Config::Model",
		  "# do not edit", '' ) ;

    my $scan = Config::Model::ObjTreeScanner-> new
      (
       leaf_cb => \&wr_leaf ,
       node_element_cb => \&wr_node ,
       check_list_element_cb => \&wr_check_list ,
       fallback => 'all',
      ) ;

    $scan->scan_node (\@result, $root) ;

    return \@result ;
#     foreach my $sect_obj (@_) {
# 	my $section_name = $sect_obj->element_name ;
# 	$$ref .= qq(Section "$section_name"\n) ;
# 	$scan->scan_node($sect_obj) ;
# 	$$ref .= "EndSection\n\n" ;
#     }

}

1;
__END__