path: root/abs/core-testing/tweaker/lib/Tweaker/Script.pm

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