summaryrefslogtreecommitdiff
path: root/x.pl.in
diff options
context:
space:
mode:
Diffstat (limited to 'x.pl.in')
-rw-r--r--x.pl.in2209
1 files changed, 0 insertions, 2209 deletions
diff --git a/x.pl.in b/x.pl.in
deleted file mode 100644
index c5124cc..0000000
--- a/x.pl.in
+++ /dev/null
@@ -1,2209 +0,0 @@
-#!/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 <tambet@ximian.com>
-#
-# 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 (<FD>) {
- 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 = &quotewords ('[ \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 = &quotewords ('[ \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 = &quotewords ('[ \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 = &quotewords ('[ \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 = (<FD>);
- 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 ("<Depth value=\"$depth\">");
- &gst_xml_enter ();
- &x_xml_print_modeline (0, $list->{$depth});
- &gst_xml_leave ();
- &gst_xml_print_line (q(</Depth>));
- }
-
- &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;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-11 22:21:28 +0000