summaryrefslogtreecommitdiffstats
path: root/abs/core-testing/tweaker/lib/Tweaker/Script.pm
diff options
context:
space:
mode:
Diffstat (limited to 'abs/core-testing/tweaker/lib/Tweaker/Script.pm')
-rw-r--r--abs/core-testing/tweaker/lib/Tweaker/Script.pm353
1 files changed, 0 insertions, 353 deletions
diff --git a/abs/core-testing/tweaker/lib/Tweaker/Script.pm b/abs/core-testing/tweaker/lib/Tweaker/Script.pm
deleted file mode 100644
index 7dd2c8f..0000000
--- a/abs/core-testing/tweaker/lib/Tweaker/Script.pm
+++ /dev/null
@@ -1,353 +0,0 @@
-# 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, "< /usr/share/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, "< /usr/share/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;
generated by cgit v0.12 at 2024-04-26 12:53:24 (GMT)