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


line stmt bran cond sub pod time code
1             #
2             # This file is part of Config-Model-Xorg
3             #
4             # This software is Copyright (c) 2007-2018 by Dominique Dumont.
5             #
6             # This is free software, licensed under:
7             #
8             # The GNU Lesser General Public License, Version 2.1, February 1999
9             #
10              
11             package Config::Model::Backend::Xorg::Write ;
12             $Config::Model::Backend::Xorg::Write::VERSION = '1.114';
13 1     1   658 use Mouse::Role ;
  1         3  
  1         8  
14              
15 1     1   433 use Carp ;
  1         2  
  1         57  
16 1     1   6 use IO::File ;
  1         14  
  1         176  
17 1     1   8 use Config::Model::ObjTreeScanner ;
  1         2  
  1         47  
18 1     1   8 use Log::Log4perl ;
  1         2  
  1         8  
19 1     1   61 use File::Path ;
  1         2  
  1         1208  
20              
21             my $logger = Log::Log4perl::get_logger('Backend::Xorg::Write');
22              
23             sub wr_std_leaf {
24 272     272 0 718 my ($scanner, $data_r, $node,$element_name,$index, $leaf_object,$v) = @_ ;
25 272 100       1833 push @$data_r , qq(\t$element_name\t"$v") if defined $v;
26             } ;
27              
28             sub wr_module {
29 65     65 0 160 my ($scanner, $data_r , $node,$element_name,$index, $leaf_object,$v) = @_ ;
30 65 100       412 push @$data_r, qq(\tLoad "$element_name") if $v ;
31             } ;
32              
33             sub wr_std_options {
34 571     571 0 1373 my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
35 571         1435 my $b_in = $leaf_object->upstream_default ;
36 571 100 66     3171 if ( defined $v && ( (not defined $b_in)
      66        
37             || (defined $b_in && $v && $v ne $b_in) )
38             ) {
39 73         180 my $str = qq(\tOption\t"$element_name");
40 73 50 33     376 $str .= qq(\t"$v") if defined $v && $v ;
41 73         465 push @$data_r, $str ;
42             }
43             } ;
44              
45             sub wr_kbd_model_options {
46 100     100 0 256 my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
47 100 100 66     635 if ( defined $v && $v ) {
48 1         12 push @$data_r, qq(\tOption\t"XkbOptions"\t"$element_name:$v");
49             }
50             } ;
51              
52             sub push_value {
53 275     275 0 673 my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
54 275 100       1770 push @$data_r, $v if defined $v;
55             } ;
56              
57              
58             sub push_flag_value {
59 150     150 0 359 my ($scanner, $data_r ,$node,$element_name,$index, $leaf_object,$v) = @_ ;
60 150 100 100     499 if (defined $v && $element_name =~ s/Polarity// ) {
61 4 100       17 $v = ($v eq 'positive' ? '+' : '-' ) . $element_name ;
62 4         27 push @$data_r, $v ;
63             }
64             else {
65 146 100 66     926 push @$data_r, $element_name if defined $v && $v ;
66             }
67             } ;
68              
69             my %dispatch_leaf
70             = (
71             'Xorg' => 1,
72             'Xorg::Module' => \&wr_module,
73             'Xorg::Files' => \&wr_std_leaf ,
74             'Xorg::InputDevice' => \&wr_std_leaf ,
75             'Xorg::InputDevice::MouseOpt' => \&wr_std_options ,
76             'Xorg::InputDevice::KeyboardOpt' => \&wr_std_options ,
77             'Xorg::Device' => \&wr_std_leaf ,
78             'Xorg::Device::Ati' => \&wr_std_options ,
79             'Xorg::Device::Radeon' => \&wr_std_options ,
80             'Xorg::Device::Nvidia' => \&wr_std_options ,
81             'Xorg::Device::Fglrx' => \&wr_std_options ,
82             'Xorg::Device::Vesa' => \&wr_std_options ,
83             'Xorg::Extensions' => \&wr_std_options ,
84             'Xorg::Extensions::Option' => \&wr_std_options ,
85             'Xorg::Monitor' => \&wr_std_leaf ,
86             'Xorg::Monitor::Option' => \&wr_std_options ,
87             'Xorg::Monitor::Mode' => \&push_value ,
88             'Xorg::Monitor::Mode::Timing' => \&push_value ,
89             'Xorg::Monitor::Mode::Flags' => \&push_flag_value ,
90             'Xorg::Screen' => \&wr_std_leaf ,
91             'Xorg::Screen::Option' => \&wr_std_options ,
92             'Xorg::Screen::Display' => \&wr_std_leaf ,
93             'Xorg::ServerLayout' => \&wr_std_leaf ,
94             'Xorg::ServerFlags' => \&wr_std_options ,
95             'Xorg::DRI' => \&wr_std_leaf
96             ) ;
97              
98             my %dispatch_leaf_re
99             = (
100             'Xorg::InputDevice::KeyboardOptModel::.*' => \&wr_kbd_model_options ,
101             ) ;
102              
103             sub wr_leaf {
104 1448     1448 0 177928 my ($scanner, $data_r, $node,$element_name,$index, $leaf_object) = @_ ;
105 1448         4193 my $v = $leaf_object->fetch ;
106 1448         528249 my $class_name = $node ->config_class_name() ;
107 1448         3201 my $cb = $dispatch_leaf{$class_name} ;
108              
109 1448 100       3613 if (not defined $cb) {
110 100         274 foreach my $k (keys %dispatch_leaf_re) {
111 100 50       628 next unless $class_name =~ /$k/ ;
112 100         196 $cb = $dispatch_leaf_re{$k};
113             #warn "using regexp dispath $k for $class_name\n";
114 100         158 last;
115             }
116             }
117              
118 1448 100 66     6040 if (defined $cb && ref $cb) {
    50          
119 1433         3610 $cb->(@_ ,$v ) ;
120             }
121             elsif (not defined $cb) {
122             # can't fallback to wr_std_leaf as some elements from model
123             # are not meant to be written back in xorg.conf
124 0         0 warn "wr_leaf: no call-back defined for ",$node ->config_class_name() ;
125             }
126             }
127              
128             sub wr_section {
129 73     73 0 184 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
130             #print "wr_section called on ",$node->name," $element_name,$key\n";
131              
132 73         127 my @section_lines ;
133 73 100       282 push @section_lines, qq(\tIdentifier\t"$key") if defined $key ;
134              
135 73 100       264 if ($element_name eq 'InputDevice') {
136             map {
137 21         52 my $core_v = $node->grab_value("! $_") ;
  42         186  
138 42 100 100     123546 push @section_lines, qq(\tOption\t"$_")
139             if (defined $core_v and $key eq $core_v) ;
140             } qw/CoreKeyboard CorePointer/ ;
141             }
142              
143 73         336 $scanner->scan_node(\@section_lines,$next_node) ;
144              
145 73 100       4440 if (@section_lines) {
146 62         808 push @$data_r, qq(Section "$element_name"), @section_lines,
147             "EndSection" , '' ;
148             }
149             }
150              
151             sub wr_mode_line {
152 25     25 0 61 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
153              
154 25         46 my @mode_values ;
155 25         94 $scanner->scan_node(\@mode_values,$next_node) ;
156 25         185 my @numbers = splice (@mode_values, 0, 9) ;
157              
158 25   100     104 my $flags = join(' ',@mode_values) || '' ;
159 25         677 push @$data_r,
160             sprintf(
161             qq(\tModeLine %-20s %8.3f %4u %4u %4u %4u %4u %4u %4u %4u %s),
162             qq("$key"), @numbers, $flags);
163             } ;
164              
165             sub wr_sub_section {
166 15     15 0 65 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
167             {
168 1     1   8 no warnings "uninitialized" ;
  1         3  
  1         1090  
  15         35  
169 15         55 $logger->debug( "wr_sub_section called on ",$node->name," $element_name,$key");
170             }
171              
172 15         427 push @$data_r, qq(\tSubSection "$element_name") ,
173             qq(\t\tDepth\t$key) ;
174              
175 15         101 $scanner->scan_node($data_r,$next_node) ;
176 15         311 push @$data_r, "\tEndSubSection" , '' ;
177             } ;
178              
179             sub wr_serverlayout_screen {
180 6     6 0 21 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
181 6         22 my $id = $next_node->fetch_element_value('screen_id') ;
182 6         18617 my $rel_loc = $next_node->grab_value("position relative_screen_location") ;
183              
184 6         5686 my $str = qq(\tScreen $key "$id") ;
185              
186 6 100       30 if (defined $rel_loc) {
187 4         20 $str .= qq( $rel_loc ) ;
188 4         17 my $pos_obj = $next_node->fetch_element('position') ;
189 4 100       237 if ($pos_obj-> is_element_available('screen_id')) {
190 1         105 $str .= '"'. $pos_obj->fetch_element_value("screen_id").'" ' ;
191             }
192 4 100       3388 if ($pos_obj-> is_element_available('x')) {
193             map {
194 3         307 $str .= $pos_obj->fetch_element_value($_).' ' ;
  6         1246  
195             } qw/x y/ ;
196             }
197              
198             }
199 6         1321 push @$data_r, $str ;
200             }
201              
202             sub wr_serverlayout_inputdevice {
203 12     12 0 32 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
204              
205 12         45 my $str = qq(\tInputDevice "$key") ;
206 12         46 my $sce = $next_node->fetch_element_value("SendCoreEvents");
207 12 50 33     5161 if (defined $sce && $sce) {
208 0         0 $str .= ' "SendCoreEvents" ' ;
209             }
210 12         90 push @$data_r, $str ;
211             }
212              
213             sub wr_monitor_display_size {
214 8     8 0 31 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
215              
216 8         26 my $w = $next_node->fetch_element_value("width") ;
217 8         3078 my $h = $next_node->fetch_element_value("height") ;
218              
219 8 100 66     3134 push @$data_r, "\tDisplaySize\t$w $h" if defined $w && defined $h;
220             }
221              
222             sub wr_monitor_gamma {
223 8     8 0 35 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
224              
225 8 100       26 if ($next_node->fetch_element_value("use_global_gamma")) {
226 7         2719 my $g = $next_node->fetch_element_value("gamma") ;
227 7 100       2747 push @$data_r, "\tGamma\t$g" if defined $g ;
228             }
229             else {
230 1         425 my @v = map { $next_node->fetch_element_value($_."_gamma") }
  3         801  
231             qw/red green blue/ ;
232 1         462 push @$data_r, "\tGamma\t@v" ;
233             }
234              
235             }
236              
237             sub wr_screen_display_virtual {
238 15     15 0 61 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
239              
240 15         84 my $x = $next_node->fetch_element_value("xdim") ;
241 15         5980 my $y = $next_node->fetch_element_value("ydim") ;
242              
243 15 100 66     5885 push @$data_r, "\t\tVirtual\t$x $y" if defined $x && defined $y;
244             }
245              
246             sub wr_screen_display_viewport {
247 15     15 0 55 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
248              
249 15         43 my $x = $next_node->fetch_element_value("x0") ;
250 15         5914 my $y = $next_node->fetch_element_value("y0") ;
251              
252 15 100 66     5849 push @$data_r, "\t\tViewPort\t$x $y" if defined $x && defined $y;
253             }
254              
255             sub wr_device_kbd_autorepeat {
256 10     10 0 32 my ($scanner, $data_r, $node,$element_name,$key,$next_node) = @_;
257              
258 10         40 my $d = $next_node->fetch_element_value("delay") ;
259 10         3911 my $r = $next_node->fetch_element_value("rate") ;
260              
261 10 100 66     3889 push @$data_r, qq(\tOption\t"AutoRepeat" "$d $r")
262             if defined $d && defined $r;
263             }
264              
265             my %dispatch_node
266             = (
267             'Xorg' => 1 ,
268             'Xorg::Extensions' => \&wr_section,
269             'Xorg::Files' => \&wr_section,
270             'Xorg::Module' => \&wr_section,
271             'Xorg::InputDevice' => \&wr_section,
272             'Xorg::InputDevice::KeyboardOpt::AutoRepeat' => \&wr_device_kbd_autorepeat,
273             'Xorg::Device' => \&wr_section,
274             'Xorg::DRI' => \&wr_section,
275             'Xorg::Monitor' => \&wr_section,
276             'Xorg::Monitor::Mode' => \&wr_mode_line ,
277             'Xorg::Monitor::DisplaySize' => \&wr_monitor_display_size ,
278             'Xorg::Monitor::Gamma' => \&wr_monitor_gamma ,
279             'Xorg::Screen' => \&wr_section,
280             'Xorg::Screen::Display' => \&wr_sub_section,
281             "Xorg::Screen::Display::Virtual" => \&wr_screen_display_virtual,
282             "Xorg::Screen::Display::ViewPort" => \&wr_screen_display_viewport,
283             'Xorg::ServerLayout' => \&wr_section,
284             'Xorg::ServerFlags' => \&wr_section,
285             'Xorg::ServerLayout::Screen' => \&wr_serverlayout_screen,
286             'Xorg::ServerLayout::InputDevice' => \&wr_serverlayout_inputdevice,
287             ) ;
288              
289             sub wr_node {
290 320     320 0 50319 my ($scanner, $data_r, $node,$element_name,$key, $next_node) = @_;
291 320         1313 my $dispatcher_data = $next_node->config_class_name ;
292 320         1298 my $cb = $dispatch_node{$dispatcher_data} ;
293 320 100 66     1431 if (defined $cb && ref $cb) { $cb->(@_) ; }
  187 50 33     545  
294             elsif (defined $cb && $cb) {
295 0         0 $scanner->scan_node($data_r,$next_node) ;
296             }
297             else {
298 1     1   10 no warnings "uninitialized" ;
  1         2  
  1         500  
299 133         728 $logger->debug( "wr_node called on $dispatcher_data $element_name,$key");
300 133         1921 $scanner->scan_node($data_r,$next_node) ;
301             }
302             } ;
303              
304             sub wr_mode_list {
305 0     0 0 0 my ($scanner, $data_ref,$node,$element_name,@indexes) = @_ ;
306 0         0 my @list = $node->fetch_element($element_name)->fetch_all_values ;
307 0 0       0 push @$data_ref, qq(\t\tModes\t").join('" "',@list).'"' if @list;
308             }
309              
310             my %dispatch_list = ( 'Xorg::Screen::Display' => \&wr_mode_list );
311              
312             sub wr_list {
313 0     0 0 0 my ($scanner, $data_ref,$node,$element_name,@indexes) = @_ ;
314 0         0 my $dispatcher_data = $node->config_class_name ;
315 0         0 my $cb = $dispatch_list{$dispatcher_data} ;
316 0 0       0 if (defined $cb ) { $cb->(@_) ; }
  0         0  
317             else {
318             # resume exploration
319 0         0 map {$scanner->scan_list($data_ref,$node,$element_name,$_)} @indexes ;
  0         0  
320             }
321             }
322              
323             sub wr_check_list {
324 15     15 0 1292 my ($scanner, $data_ref,$node,$element_name,@indexes) = @_ ;
325             #warn "wr_check_list called on node ".$node->name." element $element_name\n";
326 15         49 my @list = $node->fetch_element($element_name)->get_checked_list ;
327 15 100       514801 push @$data_ref, qq(\t\t$element_name\t").join('" "',@list).'"' if @list;
328             }
329              
330             sub write_all {
331 5     5 0 20 my $root = shift ;
332              
333 5         31 $logger->debug( "write_all called");
334              
335 5         91 my @result = ("# Xorg.conf written by Xorg Config::Model",
336             "# do not edit", '' ) ;
337              
338 5         65 my $scan = Config::Model::ObjTreeScanner-> new
339             (
340             leaf_cb => \&wr_leaf ,
341             node_element_cb => \&wr_node ,
342             check_list_element_cb => \&wr_check_list ,
343             fallback => 'all',
344             ) ;
345              
346 5         1151 $scan->scan_node (\@result, $root) ;
347              
348 5         167 return \@result ;
349             # foreach my $sect_obj (@_) {
350             # my $section_name = $sect_obj->element_name ;
351             # $$ref .= qq(Section "$section_name"\n) ;
352             # $scan->scan_node($sect_obj) ;
353             # $$ref .= "EndSection\n\n" ;
354             # }
355              
356             }
357              
358             1;
359             __END__