diff options
Diffstat (limited to 'abs/core/tweaker/bin/tweaker.pl')
-rwxr-xr-x | abs/core/tweaker/bin/tweaker.pl | 333 |
1 files changed, 333 insertions, 0 deletions
diff --git a/abs/core/tweaker/bin/tweaker.pl b/abs/core/tweaker/bin/tweaker.pl new file mode 100755 index 0000000..28519df --- /dev/null +++ b/abs/core/tweaker/bin/tweaker.pl @@ -0,0 +1,333 @@ +#!/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; |