path: root/abs/core-testing/tweaker/bin/tweaker.pl

#!/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;