#!/usr/bin/env perl #-*- Mode: perl; tab-width: 2; indent-tabs-mode: nil; c-basic-offset: 2 -*- # # Common functions for XF86Config file. # # Copyright (C) 2000-2001 Ximian, Inc. # # Authors: Tambet Ingo # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Library General Public License as published # by the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. $SCRIPTSDIR = "@scriptsdir@"; if ($SCRIPTSDIR =~ /^@scriptsdir[@]/) { $SCRIPTSDIR = "."; $DOTIN = ".in"; } require "$SCRIPTSDIR/general.pl$DOTIN"; require "$SCRIPTSDIR/file.pl$DOTIN"; require "$SCRIPTSDIR/xml.pl$DOTIN"; use Text::ParseWords; use File::Copy; use IO::File; use POSIX qw(tmpnam); use strict; my $x_version; # Data type declarations. # Keys that *must* be present: # 'parse', 'xml_parse', 'xml_print', 'update' , 'delete' 'add' my $x_unique_string = { 'parse' => \&x_parse_unique_string, 'xml_parse' => \&x_xml_parse_unique, 'xml_print' => \&x_xml_print_unique, 'update' => \&x_update_unique_string, 'delete' => \&x_del_unique_string, 'add' => \&x_add_unique_string, }; my $x_unique_int = { 'parse' => \&x_parse_unique_int, 'xml_parse' => \&x_xml_parse_unique, 'xml_print' => \&x_xml_print_unique, 'update' => \&x_update_unique_int, 'delete' => \&x_del_unique_int, 'add' => \&x_add_unique_int, }; my $x_list_string = { 'parse' => \&x_parse_list_string, 'xml_parse' => \&x_xml_parse_list, 'xml_print' => \&x_xml_print_list, 'update' => \&x_update_list_string, 'delete' => \&x_del_list_string, 'add' => \&x_add_list_string, }; my $x_list_int = { 'parse' => \&x_parse_list_int, 'xml_parse' => \&x_xml_parse_list, 'xml_print' => \&x_xml_print_list, 'update' => \&x_update_list_int, 'delete' => \&x_del_list_int, 'add' => \&x_add_list_int, }; my $x_serverlayout_screen = { 'parse' => \&x_parse_serverlayout_screen, 'xml_parse' => \&x_xml_parse_serverlayout_screen, 'xml_print' => \&x_xml_print_serverlayout_screen, 'update' => \&x_update_serverlayout_screen, 'delete' => \&x_del_serverlayout_screen, 'add' => \&x_add_serverlayout_screen, }; my $x_modeline = { 'parse' => \&x_parse_modeline, 'xml_parse' => \&x_xml_parse_modeline, 'xml_print' => \&x_xml_print_modeline, 'update' => \&x_update_modeline, 'delete' => \&x_del_modeline, 'add' => \&x_add_modeline, }; my $x_range_hz = { 'parse' => \&x_parse_range_hz, 'xml_parse' => \&x_xml_parse_range_hz, 'xml_print' => \&x_xml_print_range_hz, 'update' => \&x_update_range_hz, 'delete' => \&x_del_range_hz, 'add' => \&x_add_range_hz, }; # XFree86 version 4 sections: # Files # ServerFlags # Module # InputDevice # Device # VideoAdaptor # Monitor # Modes # Screen # ServerLayout # DRI # Vendor my $x4_sections = { Monitor => { KEY => 'Identifier', keywords => { Identifier => $x_unique_string, VendorName => $x_unique_string, ModelName => $x_unique_string, HorizSync => $x_range_hz, VertRefresh => $x_range_hz, ModeLine => $x_modeline, Gamma => $x_list_int, }, options => {}, }, Device => { KEY => 'Identifier', keywords => { Identifier => $x_unique_string, Driver => $x_unique_string, }, options => {}, }, Screen => { KEY => 'Identifier', keywords => { Identifier => $x_unique_string, Device => $x_unique_string, Monitor => $x_unique_string, DefaultDepth => $x_unique_int, }, options => {}, Display => { KEY => 'Depth', keywords => { Depth => $x_unique_int, Modes => $x_list_string, Virtual => $x_list_int, } } }, ServerLayout => { KEY => 'Identifier', keywords => { Identifier => $x_unique_string, Screen => $x_serverlayout_screen, }, options => {}, } }; # XFree86 version 3 sections: # Files # Module # ServerFlags # Keyboard # Pointer # Monitor # Device # Screen # XInput my $x3_sections = { Monitor => { KEY => 'Identifier', keywords => { Identifier => $x_unique_string, VendorName => $x_unique_string, ModelName => $x_unique_string, HorizSync => $x_range_hz, VertRefresh => $x_range_hz, ModeLine => $x_modeline, }, options => {}, }, Device => { KEY => 'Identifier', keywords => { Identifier => $x_unique_string, }, options => {}, }, Screen => { KEY => 'Driver', keywords => { Driver => $x_unique_string, Device => $x_unique_string, Monitor => $x_unique_string, DefaultColorDepth => $x_unique_int, }, options => {}, Display => { KEY => 'Depth', keywords => { Depth => $x_unique_int, Modes => $x_list_string, Virtual => $x_list_int, } } }, }; my @x_colordepths = (8, 15, 16, 24); my $x_probe_file = "probe.xml"; # Standard modelines (VESA plus couple extras) my $standard_modes = q ( # 640x350 @ 85Hz (VESA) hsync: 37.9kHz ModeLine "640x350@85" 31.5 640 672 736 832 350 382 385 445 +hsync -vsync # 640x400 @ 85Hz (VESA) hsync: 37.9kHz ModeLine "640x400@85" 31.5 640 672 736 832 400 401 404 445 -hsync +vsync # 720x400 @ 85Hz (VESA) hsync: 37.9kHz ModeLine "720x400@85" 35.5 720 756 828 936 400 401 404 446 -hsync +vsync # 640x480 @ 60Hz (Industry standard) hsync: 31.5kHz ModeLine "640x480@60" 25.2 640 656 752 800 480 490 492 525 -hsync -vsync # 640x480 @ 72Hz (VESA) hsync: 37.9kHz ModeLine "640x480@72" 31.5 640 664 704 832 480 489 491 520 -hsync -vsync # 640x480 @ 75Hz (VESA) hsync: 37.5kHz ModeLine "640x480@75" 31.5 640 656 720 840 480 481 484 500 -hsync -vsync # 640x480 @ 85Hz (VESA) hsync: 43.3kHz ModeLine "640x480@85" 36.0 640 696 752 832 480 481 484 509 -hsync -vsync # 800x600 @ 56Hz (VESA) hsync: 35.2kHz ModeLine "800x600@56" 36.0 800 824 896 1024 600 601 603 625 +hsync +vsync # 800x600 @ 60Hz (VESA) hsync: 37.9kHz ModeLine "800x600@60" 40.0 800 840 968 1056 600 601 605 628 +hsync +vsync # 800x600 @ 72Hz (VESA) hsync: 48.1kHz ModeLine "800x600@72" 50.0 800 856 976 1040 600 637 643 666 +hsync +vsync # 800x600 @ 75Hz (VESA) hsync: 46.9kHz ModeLine "800x600@75" 49.5 800 816 896 1056 600 601 604 625 +hsync +vsync # 800x600 @ 85Hz (VESA) hsync: 53.7kHz ModeLine "800x600@85" 56.3 800 832 896 1048 600 601 604 631 +hsync +vsync # 1024x768i @ 43Hz (industry standard) hsync: 35.5kHz ModeLine "1024x768@43" 44.9 1024 1032 1208 1264 768 768 776 817 +hsync +vsync Interlace # 1024x768 @ 60Hz (VESA) hsync: 48.4kHz ModeLine "1024x768@60" 65.0 1024 1048 1184 1344 768 771 777 806 -hsync -vsync # 1024x768 @ 70Hz (VESA) hsync: 56.5kHz ModeLine "1024x768@70" 75.0 1024 1048 1184 1328 768 771 777 806 -hsync -vsync # 1024x768 @ 75Hz (VESA) hsync: 60.0kHz ModeLine "1024x768@75" 78.8 1024 1040 1136 1312 768 769 772 800 +hsync +vsync # 1024x768 @ 85Hz (VESA) hsync: 68.7kHz ModeLine "1024x768@85" 94.5 1024 1072 1168 1376 768 769 772 808 +hsync +vsync # 1152x864 @ 75Hz (VESA) hsync: 67.5kHz ModeLine "1152x864@75" 108.0 1152 1216 1344 1600 864 865 868 900 +hsync +vsync # 1280x960 @ 60Hz (VESA) hsync: 60.0kHz ModeLine "1280x960@60" 108.0 1280 1376 1488 1800 960 961 964 1000 +hsync +vsync # 1280x960 @ 85Hz (VESA) hsync: 85.9kHz ModeLine "1280x960@85" 148.5 1280 1344 1504 1728 960 961 964 1011 +hsync +vsync # 1280x1024 @ 60Hz (VESA) hsync: 64.0kHz ModeLine "1280x1024@60" 108.0 1280 1328 1440 1688 1024 1025 1028 1066 +hsync +vsync # 1280x1024 @ 75Hz (VESA) hsync: 80.0kHz ModeLine "1280x1024@75" 135.0 1280 1296 1440 1688 1024 1025 1028 1066 +hsync +vsync # 1280x1024 @ 85Hz (VESA) hsync: 91.1kHz ModeLine "1280x1024@85" 157.5 1280 1344 1504 1728 1024 1025 1028 1072 +hsync +vsync # 1400x1050 @ 60Hz (VESA GFT) hsync: 65.5kHz ModeLine "1400x1050@60" 122.0 1400 1488 1640 1880 1050 1052 1064 1082 +hsync +vsync # 1400x1050 @ 75Hz (VESA GFT) hsync: 82.2kHz ModeLine "1400x1050@75" 155.8 1400 1464 1784 1912 1050 1052 1064 1090 +hsync +vsync # 1600x1200 @ 60Hz (VESA) hsync: 75.0kHz ModeLine "1600x1200@60" 162.0 1600 1664 1856 2160 1200 1201 1204 1250 +hsync +vsync # 1600x1200 @ 65Hz (VESA) hsync: 81.3kHz ModeLine "1600x1200@65" 175.5 1600 1664 1856 2160 1200 1201 1204 1250 +hsync +vsync # 1600x1200 @ 70Hz (VESA) hsync: 87.5kHz ModeLine "1600x1200@70" 189.0 1600 1664 1856 2160 1200 1201 1204 1250 +hsync +vsync # 1600x1200 @ 75Hz (VESA) hsync: 93.8kHz ModeLine "1600x1200@75" 202.5 1600 1664 1856 2160 1200 1201 1204 1250 +hsync +vsync # 1600x1200 @ 85Hz (VESA) hsync: 106.3kHz ModeLine "1600x1200@85" 229.5 1600 1664 1856 2160 1200 1201 1204 1250 +hsync +vsync # 1792x1344 @ 60Hz (VESA) hsync: 83.6kHz ModeLine "1792x1344@60" 204.8 1792 1920 2120 2448 1344 1345 1348 1394 -hsync +vsync # 1792x1344 @ 75Hz (VESA) hsync: 106.3kHz ModeLine "1792x1344@75" 261.0 1792 1888 2104 2456 1344 1345 1348 1417 -hsync +vsync # 1856x1392 @ 60Hz (VESA) hsync: 86.3kHz ModeLine "1856x1392@60" 218.3 1856 1952 2176 2528 1392 1393 1396 1439 -hsync +vsync # 1856x1392 @ 75Hz (VESA) hsync: 112.5kHz ModeLine "1856x1392@75" 288.0 1856 1984 2208 2560 1392 1393 1396 1500 -hsync +vsync # 1920x1440 @ 60Hz (VESA) hsync: 90.0kHz ModeLine "1920x1440@60" 234.0 1920 2048 2256 2600 1440 1441 1444 1500 -hsync +vsync # 1920x1440 @ 75Hz (VESA) hsync: 112.5kHz ModeLine "1920x1440@75" 297.0 1920 2064 2288 2640 1440 1441 1444 1500 -hsync +vsync ); BEGIN { &gst_report_table ({ 'x_version' => ['info', _('Detected X version [%s].')], 'x_parse' => ['info', _('Configuration file [%s] successfully parsed.')], 'x_parse_error' => ['error', _('Error parsing keyword [%s].')], 'x_probe_needed' => ['info', _('Going to probe your X server, hold on.')], 'x_probe_error' => ['error', _('Error occured on X server probe on colordepth [%s].')], 'x_general_warn' => ['warn', _('Internal error: [%s].')], } ); } sub x_version { return $x_version if $x_version; # Cache my ($command, $number, $driver); my @paths = qw (/etc/X11/X /usr/X11R6/bin/XFree86 /usr/X11R6/bin/X); foreach my $tmp (@paths) { if (-x $tmp) { $command = $tmp; last; } } unless ($command) { # TODO: add report; &gst_debug_print_line ("Couldn't find X binary."); return; } open (FD, "$command -version 2>&1 |"); while () { if (/^XFree86 Version (\d+)\.(\d+)\.(\d+)/) { $number = $1 . $2 . $3; } elsif ($number > 0 && $number < 400 && /^[ \t]*(\w+): (accelerated)?[ ]*server/) { $driver = $1; $driver = 'Accel' if $2; last; } } close (FD); &gst_report ('x_version', $number); $x_version->{'command'} = $command; $x_version->{'sections'} = ($number >= 400) ? $x4_sections : $x3_sections; $x_version->{'number'} = $number; $x_version->{'driver'} = $driver if $driver; return $x_version; } # Difference from gst_item_is_in_list is that XF86Config keywords are # case-insensitive and "_" characters are ignored. # Returns found value from list or 0. sub x_keyword_in_list { my $keyword = shift @_; $keyword =~ s/\_//g; # We don't care about underscores (_) foreach my $item (@_) { my $pattern = $item; $pattern =~ s/(\W)/\\$1/g; return $item if ($keyword =~ /^$pattern$/i); } return; } sub x_option_in_list { my $keyword = shift @_; $keyword =~ s/\"//g; # We don't care about quotes (") $keyword =~ s/^No//i; # and it could start with optional "No" foreach my $item (@_) { my $pattern = $item; $pattern =~ s/(\W)/\\$1/g; return 1 if ($keyword =~ /^$pattern$/i); } return; } # parse_option # Parses "Option" line form XF86Config. # Arguments: # $line - ref to array containing the actual line split by \s. # Returns hash with one key (Option) containing hash with option # name as key and option value as val. sub parse_option_old { my $line = shift; my ($name, $value); my ($val, $bool); shift @$line; # Remove "Option" $name = shift @$line; $value = shift @$line; $name =~ s/\"//g; $value =~ s/\"//g; if ($value =~ /^(1|on|true|yes)$/i) { $val = 1; $bool = 1; } elsif ($value =~ /^(0|off|false|no)$/i) { $val = 0; $bool = 1; } else { $val = $value; } if ($bool) { $val = !$val if ($name =~ s/^No//i); $val = 'true' if $val; $val = 'false' if not $val; } bless [ $name, $val ], "GstXOption"; } # ------------------------------------------------------ # Data type functions # ------------------------------------------------------ # Unique string data type. sub x_parse_unique_string { my $config = shift; my $buf = shift; my $kw = shift; # Format example: 'Identifier "name"' my $val = &x_get_token ($buf); goto ERROR unless defined ($val); goto ERROR unless $val =~ /^\".*\"$/; $val =~ s/\"//g; &gst_debug_print_line ("x_parse_unique_string: warning: '$kw' is unique but" . "already has value '$config->{$kw}'.") if exists ($config->{$kw}); $config->{$kw} = $val; return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_unique_string: error parsing $kw"); } sub x_xml_parse_unique { my $hash = shift; my $kw = shift; $hash->{$kw} = &gst_xml_get_text (shift @_); } sub x_xml_print_unique { my ($key, $val) = @_; &gst_xml_print_pcdata ($key, $val); } sub x_update_unique_string { my ($buf, $ptr, $old_val, $new_val) = @_; my $token = &x_update_get_token ($buf, $ptr); return if ($old_val eq $new_val); $old_val = "\"" . $old_val . "\"" if $old_val; $new_val = "\"" . $new_val . "\"" if $new_val; &x_update_token ($buf, $ptr, $old_val, $new_val); } sub x_del_unique_string { my ($buf, $ptr, $kw, $old_val) = @_; &x_update_token ($buf, $ptr, $kw); &x_update_unique_string ($buf, $ptr, $old_val); } sub x_add_unique_string { my ($buf, $ptr, $kw, $new_val) = @_; $new_val = "" unless defined ($new_val); &x_update_add_token ($buf, $ptr, $kw) if $kw; $new_val = "\"" . $new_val . "\""; &x_update_add_token ($buf, $ptr, $new_val, 1); } # Unique int data type. sub x_parse_unique_int { my $config = shift; my $buf = shift; my $kw = shift; # Format example: 'Depth depth' my $val = &x_get_token ($buf); goto ERROR unless defined ($val); goto ERROR unless $val =~ /^[0-9]+$/; &gst_debug_print_line ("x_parse_unique_string: warning: '$kw' is unique but" . "already has value '$config->{$kw}'.") if exists ($config->{$kw}); $config->{$kw} = $val; return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_unique_int: error parsing $kw"); } sub x_update_unique_int { my ($buf, $ptr, $old_val, $new_val) = @_; my $token = &x_update_get_token ($buf, $ptr); if ($old_val != $new_val) { &x_update_token ($buf, $ptr, $old_val, $new_val); } } sub x_del_unique_int { my ($buf, $ptr, $kw, $old_val) = @_; &x_update_token ($buf, $ptr, $kw); &x_update_unique_int ($buf, $ptr, $old_val); } sub x_add_unique_int { my ($buf, $ptr, $kw, $new_val) = @_; &x_update_add_token ($buf, $ptr, $kw) if $kw; &x_update_add_token ($buf, $ptr, $new_val, 1); } # String list data type. sub x_parse_list_string { my $config = shift; my $buf = shift; my $kw = shift; # Format example: 'Modes "mode-name" ...' my @list; while (my $token = &x_peek_token ($buf)) { if ($token =~ /^\".*\"$/) { $token = &x_get_token ($buf); goto ERROR unless defined ($token); $token =~ s/\"//g; push @list, $token; } else { last; } } goto ERROR if (scalar @list < 1); foreach (@list) { push @{$config->{$kw}}, $_; } return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_list_string: error parsing $kw"); } sub x_xml_parse_list { my $hash = shift; my $kw = shift; my $values = shift; my $i = 1; while (defined (my $tmp = &gst_xml_get_attribute ($values, 'arg' . $i))) { push @{$hash->{$kw}}, $tmp; $i++; } } sub x_xml_print_list { my $key = shift; my $array = shift; my $str = $key; my $i = 1; foreach (@$array) { $str .= ' arg' . $i . "=\"$_\""; $i++; } &gst_xml_print_line ("<$str/>"); } sub x_update_list_string { my ($buf, $ptr, $old_val, $new_val) = @_; while (@$old_val) { &x_update_unique_string ($buf, $ptr, $$old_val[0], $$new_val[0]); shift @$old_val; shift @$new_val; } while (@$new_val) { $$new_val[0] = "\"" . $$new_val[0] . "\""; &x_update_add_token ($buf, $ptr, $$new_val[0], 1); shift @$new_val; } } sub x_del_list_string { my ($buf, $ptr, $kw, $old_val) = @_; &x_update_token ($buf, $ptr, $kw); if ($old_val) { while (@$old_val) { &x_update_unique_string ($buf, $ptr, $old_val); shift @$old_val; } } } sub x_add_list_string { my ($buf, $ptr, $kw, $new_val) = @_; &x_update_add_token ($buf, $ptr, $kw); &x_update_list_string ($buf, $ptr, [], $new_val); } # Int list data type. sub x_parse_list_int { my $config = shift; my $buf = shift; my $kw = shift; # Format example: 'Virtual xdim ydim' my @list; while (my $token = &x_peek_token ($buf)) { if ($token =~ /^[0-9\.]+$/) { $token = &x_get_token ($buf); goto ERROR unless defined ($token); push @list, $token; } else { last; } } goto ERROR if (scalar @list < 1); foreach (@list) { push @{$config->{$kw}}, $_; } return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_list_int: error parsing $kw"); } sub x_update_list_int { my ($buf, $ptr, $old_val, $new_val) = @_; if ($old_val) { while (@$old_val) { &x_update_unique_int ($buf, $ptr, $$old_val[0], $$new_val[0]); shift @$old_val; shift @$new_val; } } while (@$new_val) { &x_update_add_token ($buf, $ptr, $$new_val[0], 1); shift @$new_val; } } sub x_del_list_int { my ($buf, $ptr, $kw, $old_val) = @_; &x_update_token ($buf, $ptr, $kw); if ($old_val) { while (@$old_val) { &x_update_unique_int ($buf, $ptr, shift @$old_val); } } } sub x_add_list_int { my ($buf, $ptr, $kw, $new_val) = @_; &x_update_add_token ($buf, $ptr, $kw); # push @$new_val, "\n"; &x_update_list_int ($buf, $ptr, undef, $new_val); } # Screen keyword from ServerLayout Section. sub x_parse_serverlayout_screen { my $config = shift; my $buf = shift; my $kw = shift; my ($hash, $token, $tmp); # Format example: 'Screen screen-num "screen-id" position-information' my $screens = 0; $screens = scalar (keys %{$config->{'Screen'}}) if exists $config->{'Screen'}; # Screen number $token = &x_peek_token ($buf); goto ERROR unless defined ($token); if ($token =~ /^\d+$/) { $hash->{'num'} = &x_get_token ($buf); } else { $hash->{'num'} = $screens; } # Screen id $token = &x_peek_token ($buf); goto ERROR unless defined ($token); $hash->{'id'} = &x_get_token ($buf) if ($token =~ /^\".+\"$/); $hash->{'id'} =~ s/\"//g; # Position my $pos = {}; my @known_pos_xy = qw (Absolute Relative); my @known_pos_id = qw (RightOf LeftOf Above Below); $token = &x_peek_token ($buf); goto ERROR unless defined ($token); if ($tmp = &x_keyword_in_list ($token, @known_pos_xy)) { &x_get_token ($buf); $pos->{'name'} = $tmp; foreach my $i (1, 2) { $token = &x_peek_token ($buf); goto ERROR unless (defined ($token) || $token =~ /^\d+$/); $pos->{"val$i"} = &x_get_token ($buf); } $hash->{'pos'} = $pos; } elsif ($tmp = &x_keyword_in_list ($token, @known_pos_id)) { &x_get_token ($buf); $pos->{'name'} = $tmp; $token = &x_peek_token ($buf); goto ERROR unless (defined ($token) || $token =~ /^\".+\"$/); $pos->{'val1'} = &x_get_token ($buf); $pos->{'val1'} =~ s/\"//g; $hash->{'pos'} = $pos; } elsif ($token =~ /^\d+$/) { $pos->{'name'} = 'Absolute'; foreach my $i (1, 2) { $token = &x_peek_token ($buf); goto ERROR unless (defined ($token) || $token =~ /^\d+$/); $pos->{"val$i"} = &x_get_token ($buf); } $hash->{'pos'} = $pos; } $config->{'Screen'}->{$hash->{'num'}} = { 'Identifier' => $hash->{'id'} }; return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_serverlayout_screen: error parsing $kw"); } sub x_xml_parse_serverlayout_screen { my $hash = shift; my $kw = shift; my $tag = shift; $hash->{$kw} = {} unless exists $hash->{$kw}; my $number = &gst_xml_get_attribute ($tag, "number"); my $screen = { 'Identifier' => &gst_xml_get_attribute ($tag, "name") }; $hash->{$kw}->{$number} = $screen; } sub x_xml_print_serverlayout_screen { my ($key, $val) = @_; foreach my $screen (keys %$val) { my $name = $val->{$screen}->{'Identifier'}; &gst_xml_print_line ("<$key number=\"$screen\" name=\"$name\"/>"); } } sub x_update_serverlayout_screen { my ($buf, $ptr, $old_val, $new_val) = @_; # Just get enough tokens from con file. # FIXME: Make it actually WORK. # Screen number my $token = &x_update_get_token ($buf, $ptr); unless ($token =~ /^\d+$/) { &x_update_unget_token ($buf, $ptr); } # Screen id $token = &x_update_get_token ($buf, $ptr); # Position my @known_pos_xy = qw (Absolute Relative); my @known_pos_id = qw (RightOf LeftOf Above Below); my $tmp; $token = &x_update_get_token ($buf, $ptr); if ($tmp = &x_keyword_in_list ($token, @known_pos_xy)) { $token = &x_update_get_token ($buf, $ptr); $token = &x_update_get_token ($buf, $ptr); } elsif ($tmp = &x_keyword_in_list ($token, @known_pos_id)) { $token = &x_update_get_token ($buf, $ptr); } elsif ($token =~ /^\d+$/) { $token = &x_update_get_token ($buf, $ptr); } else { $token = &x_update_unget_token ($buf, $ptr); } } sub x_del_serverlayout_screen { my ($buf, $ptr, $kw, $old_val) = @_; #FIXME: Doesn't do anything. # &x_update_token ($buf, $ptr, $kw); &x_update_serverlayout_screen ($buf, $ptr, $old_val); } sub x_add_serverlayout_screen { my ($buf, $ptr, $kw, $new_val) = @_; &x_update_add_token ($buf, $ptr, $kw); &x_update_add_token ($buf, $ptr, 0, 1); &x_add_unique_string ($buf, $ptr, undef, $new_val); &x_update_add_token ($buf, $ptr, 0, 1); &x_update_add_token ($buf, $ptr, 0, 1); } # ModeLines. sub x_parse_modeline { my $config = shift; my $buf = shift; my $kw = shift; my @keys = qw (dotclock hdisp hsyncstart hsyncend htotal vdisp vsyncstart vsyncend vtotal); my @flags = qw (Interlace DoubleScan +HSync -HSync +VSync -VSync Composite +CSync -CSync); my $modeline = {}; my $token = &x_get_token ($buf); goto ERROR unless defined ($token); $token =~ s/\"//g; $modeline->{'name'} = $token; foreach my $tmp (@keys) { my $token = &x_get_token ($buf); goto ERROR unless defined ($token); goto ERROR unless $token =~ /^[\d\.]+$/; #digit or '.' $modeline->{$tmp} = $token; } # Get flags while (my $token = &x_peek_token ($buf)) { if (my $tmp = &x_keyword_in_list ($token, @flags)) { &x_get_token ($buf); push @{$modeline->{'flags'}}, $tmp; } else { last; } } push @{$config->{$kw}}, $modeline; return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_modeline: error parsing $kw"); } sub x_xml_parse_modeline { my $hash = shift; my $kw = shift; my $list = shift; shift @$list; while (@$list) { my $mode = {}; shift @$list; my $modeline = shift @$list; shift @$modeline; while (@$modeline) { my $field = shift @$modeline; if ($field ne 'flag') { $mode->{$field} = &gst_xml_get_text (shift @$modeline); } else { push @{$mode->{$field}}, &gst_xml_get_text (shift @$modeline); } } push @{$hash->{$kw}}, $mode; } } sub x_xml_print_modeline { my ($key, $list) = @_; &gst_xml_container_enter ("ModeLine"); foreach (@$list) { my $modeline = $_; &gst_xml_container_enter ("Mode"); foreach my $field (keys %$modeline) { my $type = ref ($modeline->{$field}); if (!$type) { &gst_xml_print_pcdata ($field, $modeline->{$field}); } elsif ($type eq 'ARRAY') { foreach my $flag (@{$modeline->{$field}}) { &gst_xml_print_pcdata ('flag', $flag); } } else { my $msg = "unknown data type $type"; &gst_report ('x_general_warn', $msg); &gst_debug_print_line ("x_xml_print_modeline: $msg"); } } &gst_xml_container_leave (); } &gst_xml_container_leave (); } sub x_update_modeline { my ($buf, $ptr, $old_val, $new_val) = @_; my $token = &x_update_get_token ($buf, $ptr); } sub x_del_modeline { } sub x_add_modeline { my ($buf, $ptr, $kw, $new_val) = @_; my @keys = qw (dotclock hdisp hsyncstart hsyncend htotal vdisp vsyncstart vsyncend vtotal); foreach my $modeline (@$new_val) { &x_update_add_token ($buf, $ptr, $kw); &x_add_unique_string ($buf, $ptr, undef, $modeline->{'name'}); foreach my $key (@keys) { &x_update_add_token ($buf, $ptr, $modeline->{$key}, 1); } foreach my $key (@{$modeline->{'flags'}}) { &x_update_add_token ($buf, $ptr, $key, 1); } &x_update_add_token ($buf, $ptr, "\n"); } } # Hertz range datatype sub x_parse_range_hz { my $config = shift; my $buf = shift; my $kw = shift; my @list; while (defined (my $token = &x_peek_token ($buf))) { my ($min, $max); for ($token) { /^([\d.]+)\-([\d\.]+)$/ and do { $min = $1; $max = $2; &x_get_token ($buf); last; }; /^[\d\.]+$/ and do { $min = &x_get_token ($buf); $token = &x_peek_token ($buf); if ($token eq '-') { &x_get_token ($buf); $max = &x_get_token ($buf); } else { $max = $min; } last; }; # Default last; } if ($min && $max) { push @list, [ $min, $max ]; } else { last; } } goto ERROR if (scalar @list < 1); foreach (@list) { push @{$config->{$kw}}, $_; } return; ERROR: &gst_report ('x_parse_error', $kw); &gst_debug_print_line ("x_parse_range_hz: error parsing $kw"); } sub x_xml_parse_range_hz { my $hash, shift; my $kw = shift; push @{$hash->{$kw}}, &gst_xml_get_text (shift @_); } sub x_xml_print_range_hz { my $key = shift; my $array = shift; foreach my $tmp (@$array) { my $val = $$tmp[0]; $val .= '-' . $$tmp[1] if $$tmp[0] != $$tmp[1]; &gst_xml_print_pcdata ($key, $val); } } sub x_update_range_hz { # TODO: my ($buf, $ptr, $old_val, $new_val) = @_; } sub x_del_range_hz { # TODO: my ($buf, $ptr, $kw, $old_val) = @_; } sub x_add_range_hz { my ($buf, $ptr, $kw, $new_val) = @_; foreach my $tmp (@$new_val) { my $val = $$tmp[0]; $val .= '-' . $$tmp[1] if $$tmp[0] != $$tmp[1]; &x_update_add_token ($buf, $ptr, $kw); &x_update_add_token ($buf, $ptr, $val, 1); } } # ------------------------------------------------------- # Parser # ------------------------------------------------------- sub x_get_token { my $buf = shift; my $dest_buf = shift; my $token; while (@$buf) { my $line = $$buf[0]; if (&gst_ignore_line ($line)) { push @$dest_buf, $line if defined ($dest_buf); shift @$buf; next; } $line =~ s/^(\s+)//; push @$dest_buf, $1 if defined ($1); my @list = "ewords ('[ \t]+', 1, $line); $token = $list[0]; chomp $token; my $pattern = $token; $pattern =~ s/(\W)/\\$1/g; $$buf[0] =~ s/$pattern//; last; } return $token; } sub x_peek_token { my $buf = shift; my $token; foreach (@$buf) { my $line = $_; if (&gst_ignore_line ($line)) { next; } $line =~ s/^\s+//; my @list = "ewords ('[ \t]+', 1, $line); $token = $list[0]; chomp $token; last; } return $token; } sub x_parse_section_start { my $buf = shift; my $sections = shift; my $new_buf = shift; my $token = &x_get_token ($buf, $new_buf); $token =~ s/\"//g; return &x_keyword_in_list ($token, keys %$sections); } sub x_parse { my $fname = shift; my ($tmp); $x_version = &x_version () unless $x_version; my $buf = &gst_file_buffer_load ($fname); return unless $buf; # Init section stack my $section_ptr; my @section_stack = (); $section_ptr = $x_version->{'sections'}; unshift @section_stack, $section_ptr; # Init config stack my $config = {}; my $config_ptr = $config; my @config_stack = (); unshift @config_stack, $config_ptr; while (defined (my $token = &x_get_token ($buf))) { for ($token) { /^(Sub)?Section/i and do { if ($tmp = &x_parse_section_start ($buf, $section_ptr)) { $section_ptr = $section_ptr->{$tmp}; unshift @section_stack, $section_ptr; push @{$config_ptr->{$tmp}}, {}; $config_ptr = $config_ptr->{$tmp}[$#{$config_ptr->{$tmp}}]; unshift @config_stack, $config_ptr; } last; }; /^(End(Sub)?Section)/i and do { if (scalar @section_stack > 1) { shift @section_stack; $section_ptr = $section_stack[0]; shift @config_stack; $config_ptr = $config_stack[0]; } last; }; (scalar @section_stack <= 1) and do { # Inside unknown section last; }; ($tmp = &x_keyword_in_list ($token, keys %{$section_ptr->{'keywords'}})) and do { my $func = $section_ptr->{'keywords'}{$tmp}{'parse'}; &$func ($config_ptr, $buf, $tmp); last; }; # Default 1; } } &gst_report ('x_parse', $fname); return $config; } # ------------------------------------------------ # XML Printing. # ------------------------------------------------ sub x_xml_print_section { my $hash = shift; my $section = shift; my $section_list = shift; my $section_ptr = shift; my ($key); return if (!&x_keyword_in_list ($section, @$section_list)); $section_ptr = $x4_sections unless $section_ptr; # Always print using X4_sections. return unless (exists ($section_ptr->{$section})); &gst_xml_container_enter ("$section"); $section_ptr = $section_ptr->{$section}; foreach $key (keys %$hash) { if (exists $section_ptr->{'keywords'}{$key}) { my $func = $section_ptr->{'keywords'}{$key}{'xml_print'}; &$func ($key, $hash->{$key}); } elsif (exists $section_ptr->{$key}) { foreach my $tmp (@{$hash->{$key}}) { &x_xml_print_section ($tmp, $key, $section_list, $section_ptr); } } else { my $msg = "unknown keyword $key in section $section"; &gst_report ('x_general_warn', $msg); &gst_debug_print_line ("x_xml_print_section: $msg"); } } &gst_xml_container_leave (); } # -------------------------------------------------------------------- # XML parser # -------------------------------------------------------------------- # Internal sub x_xml_parse_section { my ($config, $tree, $section_desc, $section_name) = @_; my ($keywords) = $section_desc->{'keywords'}; my ($options) = $section_desc->{'options'}; my $hash = {}; shift @$tree; while (@$tree) { my $func; if (exists $keywords->{$$tree[0]}) { $func = $keywords->{$$tree[0]}{'xml_parse'}; if ($func eq "") { # TODO: # print STDERR "$tree->[0]\n"; 1; } else { &$func ($hash, $$tree[0], $$tree[1]); } } elsif (exists $options->{$$tree[0]}) { # TODO: implement 'Option' xml parser. # $func = $options->{$$tree[0]}[1]; 1; } elsif (exists $section_desc->{$$tree[0]}) { &x_xml_parse_section ($hash, $$tree[1], $section_desc->{$$tree[0]}, $$tree[0]); } shift @$tree; shift @$tree; } unshift @{$config->{$section_name}}, $hash; } sub x_xml_parse { my $tree = shift; my $sections = $x4_sections; # XML uses always X4 format. shift @$tree; # Skip attributes. my $config = {}; while (@$tree) { my ($section); if ($section = &x_keyword_in_list ($$tree[0], keys %$sections)) { &x_xml_parse_section ($config, $$tree[1], $sections->{$section}, $section); } else { my $msg = "received unknown xml tag $$tree[0]"; &gst_report ('xml_unexp_tag', $$tree[0]); &gst_debug_print_line ("x_xml_parse: $msg"); } shift @$tree; shift @$tree; } return $config; } # ---------------------------------------------- # Update # ---------------------------------------------- sub x_update_get_token { my $buf = shift; my $ptr = shift; for ($ptr->{'line'}; $ptr->{'line'} < @$buf; $ptr->{'line'}++, $ptr->{'col'} = 0) { my $line = substr ($$buf[$ptr->{'line'}], $ptr->{'col'}); next if &gst_ignore_line ($line); $line =~ s/^(\s+)//; $ptr->{'col'} += length ($1) if defined ($1); my @list = "ewords ('[ \t]+', 1, $line); my $token = $list[0]; $ptr->{'col'} += length ($token); $ptr->{'col'} -= chomp $token; return $token; } return; } sub x_update_unget_token { my $buf = shift; my $ptr = shift; my $line = substr ($$buf[$ptr->{'line'}], 0, $ptr->{'col'}); my @list = "ewords ('[ \t]+', 1, $line); my $token = $list[$#list]; if (scalar @list == 2 && length ($list[0]) == 0 || scalar @list <= 1) { --$ptr->{'line'}; $ptr->{'col'} = length $$buf[$ptr->{'line'}]; } else { $ptr->{'col'} -= length ($token); } } sub x_update_token { my $buf = shift; my $ptr = shift; my $old_val = shift; my $new_val = shift; my $pattern = $old_val; $pattern =~ s/(\W)/\\$1/g; substr ($$buf[$ptr->{'line'}], 0, $ptr->{'col'}) =~ s/$pattern$/$new_val/; if ($$buf[$ptr->{'line'}] =~ /^\s*$/) { $$buf[$ptr->{'line'}] = ''; $ptr->{'col'} = 0; } else { my $diff = length ($old_val) - length ($new_val); $ptr->{'col'} -= $diff; } } sub x_update_add_token { my $buf = shift; my $ptr = shift; my $val = shift; my $same_line = shift; # my $new_val = $same_line ? " " : "\n"; my $new_val = $same_line ? ' ' : ''; $new_val .= $val; my $head = substr ($$buf[$ptr->{'line'}], 0, $ptr->{'col'}); my $tail = substr ($$buf[$ptr->{'line'}], $ptr->{'col'}); $$buf[$ptr->{'line'}] = $head . $new_val . $tail; $ptr->{'col'} += length ($new_val); } sub x_update_skip_section { my ($buf, $ptr) = @_; my $depth = 1; while (defined (my $token = &x_update_get_token ($buf, $ptr))) { if ($token =~ /End(Sub)?Section/i) { $depth--; last if $depth == 0; } $depth++ if $token =~ /(Sub)?Section/i; } } sub x_update_del_section { my ($buf, $ptr) = @_; my $first = $ptr->{'line'}; &x_update_skip_section ($buf, $ptr); my $last = $ptr->{'line'}; for ($first .. $last) { $$buf[$_] = ''; } } sub x_update_add_section { my ($buf, $ptr, $section, $section_name, $section_list, $sub_section) = @_; my $section_str = $sub_section ? "Subsection" : "Section"; &x_update_add_token ($buf, $ptr, "\n$section_str \"$section_name\"\n"); foreach my $key (keys %$section) { if (exists ($section_list->{$section_name}{'keywords'}{$key})) { my $func = $section_list->{$section_name}{'keywords'}{$key}{'add'}; if ($func) { &$func ($buf, $ptr, $key, $section->{$key}); &x_update_add_token ($buf, $ptr, "\n"); } } elsif (exists ($section_list->{$section_name}{$key})) { foreach my $tmp (@{$section->{$key}}) { &x_update_add_section ($buf, $ptr, $tmp, $key, $section_list->{$section_name}, 1) if $tmp; } } else { my $msg = "unknown keyword $key in section $section"; &gst_report ('x_general_warn', $msg); &gst_debug_print_line ("x_update_add_section: $msg"); } } &x_update_add_token ($buf, $ptr, "End$section_str\n"); } sub x_update_section { my $buf = shift; my $ptr = shift; my $config = shift; my $xml_config = shift; my $section_list = shift; my $new_section; # Read section name my $section_name = &x_update_get_token ($buf, $ptr); $section_name =~ s/\"//g; $section_name = &x_keyword_in_list ($section_name, keys %$section_list); unless ($section_name) { &x_update_skip_section ($buf, $ptr); return; } $section_list = $section_list->{$section_name}; my $section = shift @{$config->{$section_name}}; my $ident_str = $section_list->{KEY}; # Find section from xml config for (my $i = 0; $i <= scalar @{$xml_config->{$section_name}}; $i++) { next unless exists $xml_config->{$section_name}[$i]; if ($xml_config->{$section_name}[$i]->{$ident_str} eq $section->{$ident_str}) { $new_section = $xml_config->{$section_name}[$i]; delete $xml_config->{$section_name}[$i]; last; } } unless ($new_section) { &x_update_del_section ($buf, $ptr); return; } while (defined (my $token = &x_update_get_token ($buf, $ptr))) { if ($token =~ /End(Sub)?Section/i) { last; } if (my $kw = &x_keyword_in_list ($token, keys %{$section_list->{'keywords'}})) { if (exists $new_section->{$kw}) { my $func = $section_list->{'keywords'}{$kw}{'update'}; &$func ($buf, $ptr, $section->{$kw}, $new_section->{$kw}) if $func; delete $new_section->{$kw}; } else { my $func = $section_list->{'keywords'}{$kw}{'delete'}; &$func ($buf, $ptr, $kw, $section->{$kw}) if $func; } next; } if ($token =~ /(Sub)?Section/i) { &x_update_section ($buf, $ptr, $section, $new_section, $section_list); next; } } # Add new values my $first_time = 1; foreach my $kw (keys %$new_section) { &x_update_unget_token ($buf, $ptr) if $first_time; if (exists $section_list->{'keywords'}{$kw}) { my $func = $section_list->{'keywords'}{$kw}{'add'}; &$func ($buf, $ptr, $kw, $new_section->{$kw}); &x_update_add_token ($buf, $ptr, "\n"); } elsif (exists $section_list->{$kw}) { foreach my $tmp (@{$new_section->{$kw}}) { &x_update_add_section ($buf, $ptr, $tmp, $kw, $section_list, 1) if $tmp; } } else { my $msg = "unknown keyword $kw in section $section_name"; &gst_report ('x_general_warn', $msg); &gst_debug_print_line ("x_update_section: $msg"); } undef $first_time if $first_time; } &x_update_get_token ($buf, $ptr) unless $first_time; # Remove empty old data structs if (scalar @{$xml_config->{$section_name}} < 1) { delete $xml_config->{$section_name}; } } sub x_config_set { my $fname = shift; my $config = shift; my $xml_config = shift; return unless $fname; return unless $config; return unless $xml_config; my $section_list = $x_version->{'sections'}; my $buf = &gst_file_buffer_load ($fname); return unless $buf; my $ptr = {}; while (defined (my $token = &x_update_get_token ($buf, $ptr))) { for ($token) { /^(Sub)?Section/i and do { &x_update_section ($buf, $ptr, $config, $xml_config, $section_list) }; # Default: } } # Add new sections foreach my $key (keys %$xml_config) { if (exists ($section_list->{$key})) { foreach my $tmp (@{$xml_config->{$key}}) { &x_update_add_section ($buf, $ptr, $tmp, $key, $section_list) if $tmp; } } } &gst_file_buffer_save ($buf, $fname); } # ------------------------------------------------------ # Compat layer # ------------------------------------------------------ # internal. sub x_get_active_screen { my $config = shift; return unless $config; # Make sure there is at least one screen unless (exists ($config->{'Screen'}) || scalar @{$config->{'Screen'}} > 0) { # TODO: No 'Screen's found. give error or add one. return; } # First try to get it from ServerLayout. if (exists ($config->{'ServerLayout'}) && scalar @{$config->{'ServerLayout'}} > 0) { my $active_screen = $config->{'ServerLayout'}[0]{'Screen'}; $active_screen = $active_screen->{0}->{'Identifier'}; foreach my $screen (@{$config->{'Screen'}}) { if ($screen->{'Identifier'} eq $active_screen) { return $screen; } } # TODO: give error that Screen found at ServerLayout doesn;t exist. } # Get active Screen: my $section = $config->{'Screen'}; if ($x_version->{'number'} < 400) { foreach my $screen (@$section) { # Find screen with right 'Identifier'. return $screen if ($screen->{'Identifier'} =~ /$x_version->{'driver'}/i); } } else { return $$section[0]; } # Didn't find screen. # TODO: give error or add a screen return; } # ServerLayout is optional, compose one if none present sub x_check_get_serverlayout { my $config = shift; return unless $config; # No need to 'fix' anything. return if ($config->{'ServerLayout'}); my $section = "ServerLayout"; my $hash = {}; # Add 'Identifier' $hash->{'Identifier'} = 'Gst Configured'; # Add 'Screen' my $ref = &x_get_active_screen ($config, $x_version); if ($ref) { $hash->{'Screen'} = { 0 => { 'Identifier' => $ref->{'Identifier'} } }; } push @{$config->{$section}}, $hash; } # X3 doesn't have ServerLayout keyword sub x_check_set_serverlayout { my $config = shift; return unless $config; if ($x_version->{'number'} < 400) { delete $config->{'GstXServerLayout'} if (exists ($config->{'GstXServerLayout'})); } } # internal. X verisions earlier than 4.0 didn't have 'Identifier' in 'Screen' section but # 'Driver' was used as one. sub x3_fix_screen { my $config = shift; my $get = shift; return unless $config; unless (exists ($config->{'Screen'})) { # TODO: No 'Screen's found. give error or add one. return; } my $section = $config->{'Screen'}; foreach my $screen (@$section) { if ($get) { # Driver -> Identifier $screen->{'Identifier'} = $screen->{'Driver'}; delete $screen->{'Driver'}; } else { # Identifier -> Driver $screen->{'Driver'} = $screen->{'Identifier'}; delete $screen->{'Identifier'}; } # Color depth if ($get) { # GET if (exists $screen->{'DefaultColorDepth'}) { # DefaultColorDepth -> DefaultDepth $screen->{'DefaultDepth'} = $screen->{'DefaultColorDepth'}; delete $screen->{'DefaultColorDepth'}; } else { # Add default depth $screen->{'DefaultDepth'} = 8; } } else { # SET # DefaultDepth -> DefaultColorDepth $screen->{'DefaultColorDepth'} = $screen->{'DefaultDepth'}; delete $screen->{'DefaultDepth'}; } } } # Internal. sub x_get_active_serverlayout { my $config = shift; return unless $config; if (! $config->{'ServerLayout'} || scalar @{$config->{'ServerLayout'}} < 1) { return; } # Active == first my $active = $config->{'ServerLayout'}[0]; unless ($active->{'Identifier'} || $active->{'Screen'}) { &gst_debug_print_line ("x_get_active_serverlayout: Incomplete active layout."); return; } return $active; } # Internal sub x_get_active_display { my $config = shift; return unless $config; my $screen = &x_get_active_screen ($config); return unless $screen; if (scalar @{$screen->{'Display'}} < 1) { &gst_debug_print_line ("x_get_active_display: No 'Display' subsections found."); return; } foreach my $disp (@{$screen->{'Display'}}) { return $disp if $screen->{'DefaultDepth'} == $disp->{'Depth'}; } &gst_debug_print_line ("x_get_active_display: No 'Display' subsection found."); return; } # Internal sub x_check_display { my $config = shift; return unless $config; my $display = &x_get_active_display ($config); return unless $display; my $modes = $display->{'Modes'}; if (scalar @$modes < 1) { &gst_debug_print_line ("x_check_display: No 'Modes' found."); return; } my ($maxx, $maxy) = (0, 0); foreach my $mode (@$modes) { my ($x, $y) = ($1, $2) if $mode =~ /^(\d+)x(\d+)$/i; $maxx = $x if $x > $maxx; $maxy = $y if $y > $maxy; } my $active_mode = $$modes[0]; my ($x, $y) = ($1, $2) if $active_mode =~ /^(\d+)x(\d+)$/i; if ($x < $maxx || $y < $maxy) { $display->{'Virtual'} = [ $x, $y ]; } else { delete $display->{'Virtual'}; } } sub x_config_fix { my $config = shift; my $get = shift; return unless $config; $x_version = &x_version () unless $x_version; if ($x_version->{'number'} < 400) { &x3_fix_screen ($config, $get); } if ($get) { &x_check_get_serverlayout ($config); } else { &x_check_set_serverlayout ($config); } &x_check_display ($config); } # ----------------------------------------------------------- # Probe functions # ----------------------------------------------------------- # Internal sub x_probe_get_modelines { my $config = shift; my $std_modelines = {}; return unless $config; my @buf = split ('\n', $standard_modes); while (defined (my $token = &x_get_token (\@buf))) { &x_parse_modeline ($std_modelines, \@buf, $token); } return $std_modelines; } # Internal sub x_probe_get_monitor { my $config = shift; my $screen = shift; my $monitor; return unless $config; return unless $screen; my $active_monitor = $screen->{'Monitor'}; foreach $monitor (@{$config->{'Monitor'}}) { if ($monitor->{'Identifier'} eq $active_monitor) { return $monitor; } } return; } # Internal sub x_probe_add_monitor { my $config = shift; my $monitor = shift; my $modes = shift; return unless $config; return unless $monitor; my $new; $new->{'Identifier'} = 'GstTestMonitor'; $new->{'HorizSync'} = $monitor->{'HorizSync'}; $new->{'VertRefresh'} = $monitor->{'VertRefresh'}; $new->{'ModeLine'} = (); $new->{'ModeLine'} = $modes->{'ModeLine'}; push @{$config->{'Monitor'}}, $new; return $new; } # Internal sub x_probe_add_screen { my $config = shift; my $screen = shift; my $monitor = shift; return unless $config; return unless $screen; return unless $monitor; my $new; $new->{'Identifier'} = 'GstTestScreen'; $new->{'Device'} = $screen->{'Device'}; $new->{'Monitor'} = 'GstTestMonitor'; foreach my $depth (@x_colordepths) { my $display; $display->{'Depth'} = $depth; foreach my $mode (@{$monitor->{'ModeLine'}}) { push @{$display->{'Modes'}}, $mode->{'name'}; } push @{$new->{'Display'}}, $display; } push @{$config->{'Screen'}}, $new; } # Internal sub x_probe_save { my $orig_file = shift; my $config = shift; return unless $orig_file; return unless $config; my $cfg_fname; do { $cfg_fname = tmpnam () } until my $fh = IO::File->new ($cfg_fname, O_RDWR|O_CREAT|O_EXCL); copy ($orig_file, $cfg_fname); my $orig_cfg = &x_parse ($cfg_fname); &x_config_set ($cfg_fname, $orig_cfg, $config); return $cfg_fname; } # Internal sub x_probe_scan { my $cfg_file = shift; my $depth = shift; my $depth_cmd = ($x_version->{'number'} >= 400) ? "-depth " : "-bpp "; $depth_cmd .= $depth; my $command = $x_version->{'command'}; &gst_debug_print_line ("$command :9 -xf86config $cfg_file -probeonly $depth_cmd -screen GstTestScreen 2>&1 |"); open (FD, "$command :9 -xf86config $cfg_file -probeonly $depth_cmd -screen GstTestScreen 2>&1 |"); if (FD) { my @content = (); close (FD); my @list = grep (/^\(\*\*\) \w+\(0\): Mode \"/, @content); return \@list if scalar @list; } return; } # Internal sub x_probe_collect { my $data = shift; my $modes = shift; my $depth = shift; if (scalar @$data) { my $mode; my $list = []; foreach $mode (@{$modes->{'ModeLine'}}) { foreach (@$data) { my $modename = $1 if /\"(.+)\"/; if ($modename eq $mode->{'name'}) { push @$list, $mode; last; } } } return $list; } &gst_report ('x_probe_error', $depth); &gst_debug_print_line ("x_probe_collect: error reading XFree's output at depth $depth."); return; } # Internal sub x_probe_run { my $cfg_file = shift; my $modes = shift; return unless $cfg_file; my $hash; foreach my $depth (@x_colordepths) { my $proc = &gst_process_fork (\&x_probe_scan, $cfg_file, $depth); &gst_process_list_check_ready (15, $proc); my $list = &gst_process_result_collect ($proc, \&x_probe_collect, $modes, $depth); if ($list && scalar @$list) { $hash->{$depth} = $list; } else { last; } } unless ($hash) { &gst_report ('x_probe_error', "Error running XFree server"); return; } return $hash; } # Internal sub x_probe_print_xml { my $list = shift; return unless $list; &gst_xml_print_begin (); &gst_xml_print_vspace (); foreach my $depth (keys %$list) { &gst_xml_print_line (""); &gst_xml_enter (); &x_xml_print_modeline (0, $list->{$depth}); &gst_xml_leave (); &gst_xml_print_line (q()); } &gst_xml_print_end (); } # Internal sub x_probe_store { my $config = shift; my $list = shift; return unless $config; # TODO: Write monitor and card information also. my $file = &gst_file_get_data_path () . "/" . $main::tool->{'name'} . "/" . $x_probe_file; my $fh = &gst_file_open_write_from_names ($file); if ($fh) { local *STDOUT = $fh; &x_probe_print_xml ($list); close ($fh); } } # Internal sub x_probe_load { my $config = shift; return unless $config; # TODO: Check if monitor || card is changed my $file = &gst_file_get_data_path () . "/" . $main::tool->{'name'} . "/" . $x_probe_file; my $fh = &gst_file_open_read_from_names ($file); if ($fh) { my @content = <$fh>; close ($fh); return @content if (scalar @content > 0); } return; } sub x_probe { my $orig_file = shift; my $config = shift; my $direct = shift; return unless $orig_file; return unless $config; unless ($direct) { my @content = &x_probe_load ($config); &gst_report ('x_probe_needed') unless @content; &gst_report_end (); print @content; return; } my $modes = &x_probe_get_modelines ($config); my $screen = &x_get_active_screen ($config); my $monitor = &x_probe_get_monitor ($config, $screen); $monitor = &x_probe_add_monitor ($config, $monitor, $modes); &x_probe_add_screen ($config, $screen, $monitor); my $cfg_file = &x_probe_save ($orig_file, $config); my $list = &x_probe_run ($cfg_file, $modes); unlink ($cfg_file); if ($list) { &x_probe_store ($config, $list); &gst_report_end (); &x_probe_print_xml ($list); return; } &gst_report_end (); } 1;