summaryrefslogtreecommitdiffstats
path: root/abs/core/tweaker/bin/tweaker.pl
diff options
context:
space:
mode:
Diffstat (limited to 'abs/core/tweaker/bin/tweaker.pl')
-rwxr-xr-xabs/core/tweaker/bin/tweaker.pl333
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;
generated by cgit v0.12 at 2024-05-02 17:26:17 (GMT)