diff options
Diffstat (limited to 'abs/core-testing/tweaker/lib')
| -rw-r--r-- | abs/core-testing/tweaker/lib/Tweaker/Definitions.pm | 66 | ||||
| -rw-r--r-- | abs/core-testing/tweaker/lib/Tweaker/Script.pm | 353 |
2 files changed, 419 insertions, 0 deletions
diff --git a/abs/core-testing/tweaker/lib/Tweaker/Definitions.pm b/abs/core-testing/tweaker/lib/Tweaker/Definitions.pm new file mode 100644 index 0000000..cbadf29 --- /dev/null +++ b/abs/core-testing/tweaker/lib/Tweaker/Definitions.pm @@ -0,0 +1,66 @@ +# Copyright 2007 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::Definitions; +use List::Member; +use Log::Log4perl qw(:easy); + +# To install the above modules: +# -- +# sudo cpan install List::Member + +# Recommendation Levels +my $bottom = -200; # a reserved value, under which no recommendationlevel can go +my $not_available = -100; +my $unsupported = -99; +my $inadvisable = -50; +my $optional = 0; +my $recommended = 100; + +# Interactivity Levels +my $guided = "guided"; +my $minimal = "minimal"; + +# Special variables +my $null = "null"; # reserved as the script name for special Tweaks that define Tweaker behavior + +my %global_variable_hash = ( + "bottom" => $bottom, + "not available" => $not_available, + "unsupported" => $unsupported, + "inadvisable" => $inadvisable, + "optional" => $optional, + "recommended" => $recommended, + "guided" => $guided, + "minimal" => $minimal, + "null" => $null +); + +sub get_global_variable_value { + my ($variable) = @_; + + my @known_variables = keys %global_variable_hash; + if (member($variable, @known_variables) + 1) { + if ($global_variable_hash{$variable}) { + return $global_variable_hash{$variable}; + } + } else { + my $logger = get_logger(); + $logger->error("No Tweaker Definition for variable named $variable"); + return $bottom; + } +} + +1; diff --git a/abs/core-testing/tweaker/lib/Tweaker/Script.pm b/abs/core-testing/tweaker/lib/Tweaker/Script.pm new file mode 100644 index 0000000..ec3a42a --- /dev/null +++ b/abs/core-testing/tweaker/lib/Tweaker/Script.pm @@ -0,0 +1,353 @@ +# 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::Script; + +use strict; +use DBI; +use Switch; +use Tweaker::Definitions; + +# To install the above modules: +# -- +# sudo apt-get install libdbi-perl liblog-log4perl-perl +# sudo cpan install Getopt::Lucid List::Member +# choose the defaults for all options, agree to install all dependencies + +use Getopt::Lucid qw( :all ); +# see http://search.cpan.org/~dagolden/Getopt-Lucid-0.16/lib/Getopt/Lucid.pm 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 List::Member; + +my $dbh; # the database we connect to +my $sth; # +my $TWEAKER_ROOT; +my @known_options; + +# Print advice on usage and invocation. +sub help () { + my $logger = get_logger('tweaker.script'); + $logger->fatal("USAGE:\n$0 [--check Option] [--implement Option] [--poll Option] [--iterations] [--help]"); + $logger->fatal("Valid values for Option are: ", join(" ",@known_options)); + $logger->fatal("Only one of the above parameters may be passed."); + $logger->fatal("The --check and --iterations parameters are not yet supported."); + exit; +} + +sub execute_shell_command { + my($command) = @_; + my $results=""; + my $logger = get_logger('tweaker.script'); + + open(SHELL, "$command 2>&1 |"); + + while(<SHELL>) { + $results=$results."".$_; + } + close(SHELL); + chop($results); + $logger->debug("Command '$command' produced output '$results'"); + return $results; +} + +# Simple way to get the value of an environment variable from the executing shell. +sub get_environment_variable { + my($envvar) = @_; + open(SHELL, "echo $envvar|"); + while(<SHELL>) { + chop; + return $_; + } + close(SHELL); +} + +sub get_mythtv_connection_string { + # we want something like mythconverg:localhost + my $dbname = ""; + my $dbhostname = ""; + open(MYSQLTXT, "< /home/mythtv/.mythtv/mysql.txt"); + while(<MYSQLTXT>) { + if (/DBName=(.*)/) { + $dbname=$1; + } elsif (/DBHostName=(.*)/) { + $dbhostname=$1; + } + } + close(MYSQLTXT); + + return "$dbname:$dbhostname"; +} + +sub get_mythtv_authentication { + # we want something like ['root', ''] + my $dbusername = ""; + my $dbpassword = ""; + + open(MYSQLTXT, "< /home/mythtv/.mythtv/mysql.txt"); + while(<MYSQLTXT>) { + if (/DBUserName=(.*)/) { + $dbusername=$1; + } elsif (/DBPassword=(.*)/) { + $dbpassword=$1; + } + } + close(MYSQLTXT); + + return ($dbusername, $dbpassword); +} + +# Database routines. +sub connect_to_db { + my ($db) = @_; + my $logger = get_logger('tweaker.script'); + my ($dbusername, $dbpassword) = get_mythtv_authentication(); + if (!($dbh = DBI->connect($db, $dbusername, $dbpassword))) { + $logger->error("Couldn't connect to database: ", DBI->errstr); + return -1; + } + return 1; +} + +sub disconnect_from_db { + $dbh->disconnect; +} + +sub do_query { + my ($query) = @_; + my $logger = get_logger('tweaker.script'); + my $rv=""; + + $logger->debug("Processing statement: ", $query); + + if (!($sth = $dbh->prepare($query))) { + $logger->error("Couldn't prepare statement: ", $dbh->errstr); + return -1; + } + $rv = $sth->execute(); # Returns an integer when rows were affected; returns -1 when there's an + # error; returns 0E0 (true) when no error but no rows affected. + + if (!$rv) { + $logger->error("Couldn't execute statement: ", $sth->errstr); + return -1; + } + return $rv; +} + +# Make sure the option passed to this script is handled. +sub validate_option { + my($option) = @_; + + if (!(member($option, @known_options) + 1)) { + my $logger = get_logger('tweaker.script'); + $logger->fatal("Option '$option' is not known to $0."); + $logger->fatal("Valid Options are: ", join(", ",@known_options)); + exit -1; + } + return 1; +} + +# Prints out each option that the script handles, separated by '|'. +# This allows for a minimal .tcf entry. +sub get_options { + print join("|",@known_options),"\n"; +} + +# Prints out the passed Recommendation Level first, followed by any other +# strings, separated by '|'. This allows the author of a Tweaker Script to +# return explanatory information along with a Recommendation Level. +sub recommendation_level { + print join("|",@_),"\n"; +} + +sub process_parameters () { + # Accept these parameters: + # -- + my @parameters = ( + Switch("help")->anycase, + Param("check")->anycase, # Requirement 1.1 + Param("implement")->anycase, # Requirement 1.2 + Param("poll")->anycase, # Requirement 1.3 + Switch("iterations")->anycase, # Requirement 1.4 + Switch("getoptions")->anycase # Requirement 1.5 + ); + my $opt = Getopt::Lucid->getopt( \@parameters ); + + if (!(my $TWEAKER_ROOT = get_environment_variable("\$TWEAKER_ROOT"))) { + Log::Log4perl->easy_init(); + my $logger = get_logger(); + $logger->fatal("ERROR: \$TWEAKER_ROOT environment variable is not set."); + exit -1; + } else { + my $log4perl_conf = "$TWEAKER_ROOT/log4perl.conf"; + Log::Log4perl::init_and_watch($log4perl_conf,10); + my $logger = get_logger('tweaker.script'); + $logger->info("\$TWEAKER_ROOT is '$TWEAKER_ROOT'."); + } + + if ($opt->get_help > 0) { + help; + } + + my $check = $opt->get_check; + my $implement = $opt->get_implement; + my $poll = $opt->get_poll; + my $iterations = $opt->get_iterations; + my $getoptions = $opt->get_getoptions; + + # Requirement 1.6 + if ($check) { + if ($implement || $poll || $iterations || $getoptions) { + help; + } + validate_option($check); # exits with an error if option is invalid + check_option($check); # Requirement 1.1 + } elsif ($implement) { + if ($poll || $iterations || $getoptions) { + help; + } + validate_option($implement); # exits with an error if option is invalid + implement_option($implement); # Requirement 1.2 + } elsif ($poll) { + if ($iterations || $getoptions) { + help; + } + validate_option($poll); # exits with an error if option is invalid + poll_options($poll); # Requirement 1.3 + } elsif ($iterations) { + if ($getoptions) { + help; + } + #count_iterations; # Requirement 1.4 + } elsif ($getoptions) { + get_options; # Requirement 1.5 + } else { + help; + } +} + +sub set_known_options { + my(@options) = @_; + @known_options = @_; +} + +# These entries may or may not already exist. First, try updating them, and if that fails, insert them. +# Pass in array references for setfields and checkfields. Each must +# reference an array of lists, where each list is a key, value pair, e.g. +# [["data", "somedata"], ["name", "skippy"]] +sub change_or_make_entry { + my($table, $setfields, $checkfields) = @_; + my $query_string = "UPDATE $table SET "; + + my $fields=""; + foreach my $sets (@$setfields) { + if ($fields) { + $fields = $fields . ", "; + } + $fields = $fields . "@$sets[0]='@$sets[1]' "; + } + $query_string = $query_string . $fields . "WHERE "; + + my $checkstring=""; + foreach my $checks (@$checkfields) { + if ($checkstring) { + $checkstring = $checkstring . "AND "; + } + $checkstring = $checkstring . "@$checks[0]='@$checks[1]' "; + } + $query_string = $query_string . $checkstring; + + my $rv = do_query($query_string); + if (($rv == 0E0) || ($rv < 1)) { # UPDATE didn't apply; do an insert + my $fields=""; + my $values=""; + foreach my $sets (@$setfields) { + if ($fields) { + $fields = $fields . ", "; + $values = $values . ", "; + } + $fields = $fields . "@$sets[0]"; + $values = $values . "'@$sets[1]'"; + } + foreach my $sets (@$checkfields) { + if ($fields) { + $fields = $fields . ", "; + $values = $values . ", "; + } + $fields = $fields . "@$sets[0]"; + $values = $values . "'@$sets[1]'"; + } + + $query_string = "INSERT INTO $table (". $fields . ") VALUES (" . $values . ")"; + + $rv = do_query($query_string); + } + return $rv; +} + +# We update so many entries in the settings table that a subroutine makes coding and readability easier. +sub change_or_make_setting { + my($value, $data) = @_; + + return(change_or_make_entry("settings", [["data", $data]], [["value", $value]])); +} + +# Benchmark-driven tests for low, medium, or high "performance" often look the same. +# If your test falls into this pattern, you can use this subroutine to simplify your +# Tweaker Script's poll_options subroutine. +# NOTE: This only handles options for low, medium, or high right now. +# NOTE: You don't have to use this! Only use it if your poll_options subroutine +# would look like this anyway. Don't shoehorn it to fit! +sub threshold_test { + my($option, $benchmark_number, $name_of_benchmarked_device, $low_threshold, $medium_threshold, $high_threshold) = @_; + # e.g. ("medium", 512, "video card", 350, 425, 500) + + my $logger = get_logger('tweaker.script'); + $logger->debug("Threshold test for option '$option' ($name_of_benchmarked_device) with benchmark of $benchmark_number, where: low = $low_threshold, medium = $medium_threshold, high = $high_threshold"); + + switch ($option) { + case "low" { + if ($benchmark_number <= $low_threshold) { + recommendation_level("recommended", "Your $name_of_benchmarked_device seems to be unable to handle higher usage than this."); + } elsif ($benchmark_number <= $medium_threshold) { + recommendation_level("optional", "Your $name_of_benchmarked_device seems to be able to handle higher usage than this, but select this option if you want to reduce overall $name_of_benchmarked_device usage."); + } elsif ($benchmark_number >= $high_threshold) { + recommendation_level("optional", "Your $name_of_benchmarked_device seems to be quite capable of this setting, but select this option if you want to reduce overall $name_of_benchmarked_device usage."); + } + } + case "medium" { + if ($benchmark_number <= $low_threshold) { + recommendation_level("inadvisable", "Your $name_of_benchmarked_device seems to be unable to handle this usage level, but you are free to try."); + } elsif ($benchmark_number <= $medium_threshold) { + recommendation_level("recommended", "Your $name_of_benchmarked_device seems to be unable to handle higher usage than this."); + } elsif ($benchmark_number >= $high_threshold) { + recommendation_level("optional", "Your $name_of_benchmarked_device seems to be able to handle higher usage than this, but select this option if you want to reduce overall $name_of_benchmarked_device usage."); + } + } + case "high" { + if ($benchmark_number <= $low_threshold) { + recommendation_level("inadvisable", "Your $name_of_benchmarked_device seems to be unable to handle this usage level, and it is not recommended that you try."); + } elsif ($benchmark_number <= $medium_threshold) { + recommendation_level("inadvisable", "Your $name_of_benchmarked_device seems to be unable to handle this usage level, but you are free to try."); + } elsif ($benchmark_number >= $high_threshold) { + recommendation_level("recommended", "Your $name_of_benchmarked_device seems to be quite capable of this setting."); + } + } + } +} + +1; |