summaryrefslogtreecommitdiffstats
path: root/abs/core-testing/tweaker/bin/tweaker.pl
diff options
context:
space:
mode:
Diffstat (limited to 'abs/core-testing/tweaker/bin/tweaker.pl')
-rwxr-xr-xabs/core-testing/tweaker/bin/tweaker.pl333
1 files changed, 0 insertions, 333 deletions
diff --git a/abs/core-testing/tweaker/bin/tweaker.pl b/abs/core-testing/tweaker/bin/tweaker.pl
deleted file mode 100755
index 28519df..0000000
--- a/abs/core-testing/tweaker/bin/tweaker.pl
+++ /dev/null
@@ -1,333 +0,0 @@
-#!/usr/bin/perl -w
-
-# Copyright 2007, 2008 Robert ("Bob") Igo of StormLogic, LLC and mythic.tv.
-#
-# This program is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 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 General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-package Tweaker;
-
-use strict;
-use Getopt::Lucid qw( :all );
-# see http://search.cpan.org/~dagolden/Getopt-Lucid-0.16/lib/Getopt/Lucid.pm for usage details
-use XML::Twig;
-# see http://xmltwig.com for usage details
-use Log::Log4perl qw(get_logger);
-
-# see http://search.cpan.org/~mschilli/Log-Log4perl-1.14/lib/Log/Log4perl.pm for usage details
-# http://www.perl.com/pub/a/2002/09/11/log4perl.html is highly recommended as well
-
-use Tweaker::Script;
-use Tweaker::Definitions;
-
-# To install the above modules:
-# --
-# sudo cpan install Getopt::Lucid XML::Twig Log::Log4perl List::Member
-# choose the defaults for all options, agree to install all dependencies
-# Copy TweakerDefinitions.pm to /etc/perl
-
-use vars qw($debug);
-use vars qw($interactivity);
-use vars qw($logfile);
-use vars qw($twig);
-
-my $bottom = Tweaker::Definitions::get_global_variable_value("bottom");
-my $optional = Tweaker::Definitions::get_global_variable_value("optional");
-my $minimal = Tweaker::Definitions::get_global_variable_value("minimal");
-my $null = Tweaker::Definitions::get_global_variable_value("null");
-
-# As each tweak tag is processed, this subroutine is called. Here we will
-# see if any previous tweak tag had the same name attribute. If so, we will
-# replace the previous tweak tag with this new tweak tag's contents.
-sub uniquify_tweaks {
- my ($twig, $this_tweak) = @_;
- my $tweak_name = $this_tweak->att('name');
- my $previous_tweak = $this_tweak->prev_sibling( qq{tweak[\@name="$tweak_name"]});
- my $logger = get_logger('tweaker');
-
- # If the tweak's name is found elsewhere, replace the first
- # instance with the latest one, then delete the latest one.
- if ($previous_tweak) {
- my $log_entry;
- # Requirement 6.3.1
- $log_entry = sprintf("\tReplacing\n\t\t%s\n\twith\n\t\t%s\n", $previous_tweak->sprint, $this_tweak->sprint);
- $logger->info($log_entry);
- $this_tweak->cut;
- $this_tweak->replace($previous_tweak);
- }
-}
-
-$twig = XML::Twig->new(load_DTD => 1,
- expand_external_ents => 1,
- twig_handlers => { 'tweak' => \&uniquify_tweaks }
- );
-
-# Requirement 4.2
-# Print advice on usage and invocation.
-sub help () {
- my $logger = get_logger('tweaker');
- $logger->fatal("USAGE:\n$0 --tcf file1.tcf [--tcf file2.tcf ...] [--help]");
- exit;
-}
-
-sub print_tcf {
- my(@tweaks) = @_;
- my $logger = get_logger('tweaker');
-
- $logger->debug('<?xml version="1.0"?>'); # print the XML declaration
- $logger->debug('<!DOCTYPE stats SYSTEM "tcf.dtd">');
- $logger->debug('<tcf>'); # then the root element start tag
-
- foreach my $tweak (@tweaks) { # the list of tweaks
- $logger->debug($tweak->sprint); # print the xml content of the element
- }
-
- $logger->debug("</tcf>\n"); # close the document
-}
-
-# For each tweak, invoke the option that was selected.
-# Requirement 9.1.5
-# Requirement 13
-sub invoke_selected_options {
- my @tweaks= $twig->root->children; # get the tweak list
- my $logger = get_logger('tweaker');
- my $has_selected_option;
- my $recommendationlevel = $bottom;
-
- foreach my $tweak (@tweaks) { # the list of tweaks
- if ($tweak->att('name')) {
- $has_selected_option=0;
- $logger->debug("TWEAK ", $tweak->att('name'));
- my @options = $tweak->descendants('option');
- foreach my $option (@options) {
- if ($option->first_child('selected')) {
- $has_selected_option++;
- $recommendationlevel = $option->first_child('selected')->text;
- $logger->info("\t", $tweak->att('name'), " : ", $option->att('name'), " is selected (recommendationlevel is ", $recommendationlevel, ")");
- # If the selected option is merely $optional, and we are in $minimal interactivity mode, we
- # really don't know if this option is useful for the user. Just skip it.
- if (($recommendationlevel == $optional) && ($interactivity eq $minimal)) { # UI Requirement 9.1.4
- $logger->debug("\tSKIPPING");
- next;
- } elsif (($tweak->first_child('script')->text) &&
- ($tweak->first_child('script')->text) ne $null) {
- $logger->debug("\tRUNNING");
- my $command = sprintf("%s --implement %s", $tweak->first_child('script')->text, $option->att('name'));
- $logger->info("\t\tRunning '$command' to run a tweak.");
-
- open(COMMAND, "$command|");
- while(<COMMAND>) { # should only be one line of results
- if ($_) {
- $logger->debug("script returned text: ", $_);
- } else {
- $logger->debug("no return value from script");
- }
- }
- close(COMMAND);
- } else {
- $logger->debug("\tNO SCRIPT TO RUN");
- }
- }
- }
- if ($has_selected_option == 0) {
- $logger->debug("\tNO OPTION SELECTED");
- }
- }
- }
-}
-
-
-# Parses an XML file in TCF format, loading its information into memory.
-# Rely on the DTD to mandate required tags.
-sub parse_tcf {
- my $this_tcf = shift(@_);
- my $logger = get_logger('tweaker');
-
- $logger->info("Parsing $this_tcf...");
- $twig->safe_parsefile($this_tcf) || $logger->fatal("Bad TCF $this_tcf: $@");
- if ($@) {
- return 0;
- }
- # ??? For Requirement 5.1, we need to catch parse errors here
- # $twig now has the parsed $this_tcf
- $logger->info("DONE parsing $this_tcf");
-
- my $root= $twig->root; # get the root of the twig (tcf)
- my @tweaks= $root->children; # get the tweak list
-
- print_tcf(@tweaks) if $debug;
-
- return 1; # successfully parsed $this_tcf
-}
-
-sub parse_core_tcf {
- my ($core_tcf_pathname) = @_;
- my $logger = get_logger('tweaker');
-
- $logger->debug("core TCF pathname: $core_tcf_pathname");
-
- # Requirement 5.1
- if (!(parse_tcf($core_tcf_pathname))) {
- # Part of Requirement 6.4.1
- $logger->fatal("$0 requires at least one valid .tcf file.");
- $logger->fatal("$core_tcf_pathname, or a .tcf that it includes, did not parse.");
- exit;
- }
- # $twig->root->print;
-}
-
-sub process_parameters () {
- # Accept these parameters:
- # --
- my @parameters = (
- Switch("help")->anycase, # Requirement 4.2
- Switch("debug")->anycase,
- # part of Requirement 8
- Param("interactivity")->default($minimal), # side-effect of UI Requirement 9 for v0.7
- );
-
- my $opt = Getopt::Lucid->getopt( \@parameters );
- my $help = $opt->get_help;
- $debug = $opt->get_debug;
- $interactivity = $opt->get_interactivity;
-
- if ($interactivity ne $minimal) { # side-effect of UI Requirement 9 for v0.7
- my $logger = get_logger('tweaker');
- $logger->warn("This version of Tweaker ignores requests for $interactivity interactivity and defaults to $minimal.");
- $interactivity = $minimal;
- }
-
- if ( $help > 0 ) {
- help;
- }
-}
-
-# Requirement 6.6: Tweaker shall determine Recommendation Levels and default Options
-# Requirements 6.6.1 and 6.6.2
-sub post_process_tweaks {
- my $logger = get_logger('tweaker');
-
- # Requirement 6.6.1
-
- my $root= $twig->root; # get the root of the twig (tcf)
- my @tweaks= $root->children; # get the tweak list
-
- foreach my $tweak (@tweaks) {
- $logger->debug("#######");
- my @options = $tweak->descendants('option');
-
- my $name_of_most_recommended_option="";
- my $most_recommended_option;
- my $highest_recommendationlevel=$bottom;
-
- foreach my $option (@options) {
- $logger->debug("===== OPTION");
- $logger->debug($option->sprint);
-
- my $recommendationlevel = $option->first_child('recommendationlevel');
- if ($recommendationlevel) {
- # Requirement 6.6.1.1
- $logger->debug("\t+++");
- $logger->debug("\tUsing predefined recommendation level:", $recommendationlevel->text);
- } else {
- # Requirement 6.6.1.4
- my $result="optional";
- my $explanation="";
-
- if (($tweak->first_child('script')->text) &&
- ($tweak->first_child('script')->text) ne $null) {
- # Requirement 6.6.1.2
- $logger->debug("\t---");
- $logger->debug("\tThis has no defined recommendation level.");
-
- # Get the name of the script for this tweak and invoke it with the name of the option.
- my $command = sprintf("%s --poll %s", $tweak->first_child('script')->text, $option->att('name'));
- $logger->debug("\t\tRunning '$command' to see what it should be.");
- # Create a recommendationlevel element and populate it with the script's return value.
-
- open(COMMAND, "$command|");
- while(<COMMAND>) { # should only be one line of results
- $logger->debug("Got this: ", $_);
- if ($_) {
- chop;
- my @text = split(/\|/);
- $result = $text[0];
- if ($text[1]) {
- $explanation = $text[1];
- }
- }
- }
- close(COMMAND);
- }
- # Requirement 6.6.1.3
- $option->set_field ( 'recommendationlevel', $result );
- if ($explanation) {
- $option->set_field ( 'explanation', $explanation );
- }
- #$logger->debug("*** Paste results: ", $option->sprint);
- }
- # Requirement 6.6.2 : Auto-select the Option with the highest non-negative Recommendation Level.
- # Requirement 6.6.2.1 : If there is a tie, Tweaker shall auto-select the first Option with the highest Recommendation Level.
- $recommendationlevel = $option->first_child('recommendationlevel');
- if ($recommendationlevel) {
- if ($name_of_most_recommended_option) {
- $logger->debug("comparing ", $name_of_most_recommended_option, "'s recommendationlevel ($highest_recommendationlevel) to ", $recommendationlevel->text, " (",Tweaker::Definitions::get_global_variable_value($recommendationlevel->text),")");
- } else {
- $logger->debug("considering recommendationlevel ", $recommendationlevel->text, " (",Tweaker::Definitions::get_global_variable_value($recommendationlevel->text),")");
- }
- if (($highest_recommendationlevel < Tweaker::Definitions::get_global_variable_value($recommendationlevel->text))
- && (Tweaker::Definitions::get_global_variable_value($recommendationlevel->text) >= 0)) {
- $highest_recommendationlevel = Tweaker::Definitions::get_global_variable_value($recommendationlevel->text);
- $name_of_most_recommended_option = $option->att('name');
- $most_recommended_option = $option;
- $logger->debug("now recommending: ", $name_of_most_recommended_option, " at level ", $highest_recommendationlevel);
- }
- } else {
- $logger->error("No recommendationlevel defined for ", $option->att('name'));
- }
- # Select the best option, based on recommendation level
- }
- if ($most_recommended_option) {
- $logger->debug("(1) BEST OPTION: ", $most_recommended_option->sprint);
- $most_recommended_option->set_field ( 'selected', $highest_recommendationlevel );
- }
- }
-}
-
-sub main () {
- my $tweaker_root;
-
- if (!($tweaker_root = Tweaker::Script::get_environment_variable("\$TWEAKER_ROOT"))) {
- Log::Log4perl->easy_init();
- my $logger = get_logger();
- $logger->fatal("\$TWEAKER_ROOT not defined. Exiting.");
- exit -1;
- }
- my $core_tcf_path = "$tweaker_root/tcf";
- my $core_tcf = "tweaker-core.tcf";
- my $core_tcf_pathname = "$core_tcf_path/$core_tcf";
- my $log4perl_conf = "$tweaker_root/log4perl.conf";
-
- Log::Log4perl::init_and_watch($log4perl_conf,10);
-
- process_parameters;
- parse_core_tcf($core_tcf_pathname);
- post_process_tweaks;
- # ??? need to add Requirement 11 here
- invoke_selected_options;
-}
-
-main;
-
-#my @tweaks= $twig->root->children; # get the tweak list
-#print_tcf(@tweaks) if $debug;
generated by cgit v0.12 at 2024-05-04 02:43:56 (GMT)