move some files around
This commit is contained in:
181
scripts/Modules/Mars.pm
Normal file
181
scripts/Modules/Mars.pm
Normal file
@ -0,0 +1,181 @@
|
||||
package Mars;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use DBI;
|
||||
use Net::OpenSSH;
|
||||
|
||||
use feature 'say';
|
||||
|
||||
my $local_root = '/home/christoph/Notes/TU/MastersThesis/FailNix';
|
||||
|
||||
my $_remote = undef;
|
||||
my $remote_host = 'mars'; # smchurla@mars.cs.tu-dortmund.de
|
||||
|
||||
# The mars db is bound to local port 3306 over SSH.
|
||||
# - This requires using the configured 'mars'
|
||||
# remote_host instead of smchurla@mars
|
||||
# or setting up another tunnel here
|
||||
my $_db = undef;
|
||||
my $db_host = "127.0.0.1";
|
||||
my $db_port = "3306";
|
||||
my $db_user = "smchurla";
|
||||
my $_db_password = undef;
|
||||
|
||||
sub ssh_connect {
|
||||
if ( !defined $_remote ) {
|
||||
|
||||
# Initialize SSH connection
|
||||
# - This connection also sets up the database tunnel
|
||||
$_remote = Net::OpenSSH->new(
|
||||
$remote_host,
|
||||
timeout => 30,
|
||||
master_opts => [
|
||||
-o => 'BatchMode=yes',
|
||||
-o => 'StrictHostKeyChecking=accept-new',
|
||||
-o => 'ServerAliveInterval=60',
|
||||
],
|
||||
);
|
||||
$_remote->error and die 'SSH connection failed: ' . $_remote->error;
|
||||
say 'Connected to mars.cs.tu-dortmund.de';
|
||||
}
|
||||
|
||||
return $_remote;
|
||||
}
|
||||
|
||||
sub ssh_system {
|
||||
my (@cmd) = @_;
|
||||
|
||||
my $ssh = ssh_connect();
|
||||
|
||||
$ssh->system(@cmd);
|
||||
$ssh->error and die "Remote command failed (@cmd): " . $ssh->error;
|
||||
}
|
||||
|
||||
sub ssh_capture {
|
||||
my (@cmd) = @_;
|
||||
|
||||
my $ssh = ssh_connect();
|
||||
|
||||
my $out = $ssh->capture(@cmd);
|
||||
$ssh->error and die "Remote command failed (@cmd): " . $ssh->error;
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub upload_dir {
|
||||
my ( $source_dir, $target_dir ) = @_;
|
||||
|
||||
my $ssh = ssh_connect();
|
||||
|
||||
say " - Uploading $source_dir to $target_dir...";
|
||||
$ssh->scp_put(
|
||||
{
|
||||
recursive => 1,
|
||||
copy_attrs => 1
|
||||
},
|
||||
$source_dir,
|
||||
$target_dir,
|
||||
) or die "Failed to upload $source_dir: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub download_dir {
|
||||
my ( $source_dir, $target_dir ) = @_;
|
||||
|
||||
my $ssh = ssh_connect();
|
||||
|
||||
say " - Downloading $source_dir to $target_dir...";
|
||||
$ssh->scp_get(
|
||||
{
|
||||
recursive => 1,
|
||||
copy_attrs => 1
|
||||
},
|
||||
$source_dir,
|
||||
$target_dir,
|
||||
) or die "Failed to download $source_dir: " . $ssh->error;
|
||||
}
|
||||
|
||||
sub find_remote_subdirs {
|
||||
my ($dir) = @_;
|
||||
|
||||
my $out = ssh_capture(
|
||||
'find', $dir, '-mindepth', '1',
|
||||
'-maxdepth', '1', '-type', 'd',
|
||||
'-printf', '%f' . "\n",
|
||||
);
|
||||
|
||||
my @subdirs = sort grep { length } split /\n/, $out;
|
||||
|
||||
return @subdirs;
|
||||
}
|
||||
|
||||
sub read_db_password_file {
|
||||
if ( !defined $_db_password ) {
|
||||
open( my $fhandle, '<', "$local_root/mars-db.conf" )
|
||||
or die "Failed to read mars-db.conf: $!";
|
||||
chomp( $_db_password = <$fhandle> );
|
||||
close($fhandle);
|
||||
}
|
||||
|
||||
return $_db_password;
|
||||
}
|
||||
|
||||
sub db_connect {
|
||||
|
||||
# Opens tunnel for db_port
|
||||
my $ssh = ssh_connect();
|
||||
|
||||
if ( !defined $_db ) {
|
||||
$_db = DBI->connect( "DBI:MariaDB:host=$db_host;port=$db_port",
|
||||
$db_user, read_db_password_file() )
|
||||
or die 'Failed to connect to database: ' . $DBI::errstr;
|
||||
say 'Connected to database';
|
||||
}
|
||||
|
||||
return $_db;
|
||||
}
|
||||
|
||||
sub db_disconnect {
|
||||
if ( defined $_db ) {
|
||||
$_db->disconnect or warn $_db->errstr;
|
||||
}
|
||||
}
|
||||
|
||||
sub db_prefix {
|
||||
return $db_user;
|
||||
}
|
||||
|
||||
sub db_list {
|
||||
my $db = db_connect();
|
||||
|
||||
my @db_names =
|
||||
sort
|
||||
map { s/DBI:MariaDB://r }
|
||||
grep { !/information_schema|smchurla_ll/ } $db->data_sources();
|
||||
|
||||
return @db_names;
|
||||
}
|
||||
|
||||
sub db_do {
|
||||
my (@cmd) = @_;
|
||||
|
||||
my $db = db_connect();
|
||||
|
||||
$db->do(@cmd) or die "Database command failed (@cmd): " . $db->errstr;
|
||||
}
|
||||
|
||||
sub db_create {
|
||||
my ($db_name) = @_;
|
||||
say " - Creating database $db_name...";
|
||||
db_do("create database `$db_name`");
|
||||
}
|
||||
|
||||
sub db_drop {
|
||||
my ($db_name) = @_;
|
||||
say " - Dropping database $db_name...";
|
||||
db_do("drop database `$db_name`");
|
||||
}
|
||||
|
||||
1;
|
||||
110
scripts/Modules/TUI.pm
Normal file
110
scripts/Modules/TUI.pm
Normal file
@ -0,0 +1,110 @@
|
||||
package TUI;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use Curses::UI;
|
||||
|
||||
# Singleton
|
||||
my $_cui;
|
||||
|
||||
sub init_cui {
|
||||
if ( !defined $_cui ) {
|
||||
$_cui = new Curses::UI(
|
||||
-color_support => 1,
|
||||
-mouse_support => 1,
|
||||
|
||||
# -clear_on_exit => 1,
|
||||
);
|
||||
}
|
||||
|
||||
return $_cui;
|
||||
}
|
||||
|
||||
sub select_from_list {
|
||||
my ( $title, $multiselect, @items ) = @_;
|
||||
die "No items to choose from" unless @items;
|
||||
|
||||
my @values = $multiselect ? ( '__ALL__', @items ) : @items;
|
||||
my %labels =
|
||||
$multiselect
|
||||
? ( '__ALL__' => '[ALL]', map { $_ => $_ } @items, )
|
||||
: map { $_ => $_ } @items;
|
||||
|
||||
my @selection;
|
||||
my @selection_order; # multiselect only: items in toggle order
|
||||
|
||||
my $cui = init_cui();
|
||||
my $win = $cui->add( 'root', 'Window', );
|
||||
|
||||
my $listbox;
|
||||
$listbox = $win->add(
|
||||
'item_list',
|
||||
'Listbox',
|
||||
-title => $title,
|
||||
-border => 1,
|
||||
-values => \@values,
|
||||
-labels => \%labels,
|
||||
-multi => $multiselect == 1,
|
||||
-radio => $multiselect == 0,
|
||||
-padbottom => 1,
|
||||
-onchange => sub {
|
||||
return unless $multiselect;
|
||||
my %now = map { $_ => 1 } $listbox->get();
|
||||
|
||||
# Append newly selected items in toggle order
|
||||
for my $item (@items) {
|
||||
if ( $now{$item} && !grep { $_ eq $item } @selection_order ) {
|
||||
push @selection_order, $item;
|
||||
}
|
||||
}
|
||||
|
||||
# Drop deselected items
|
||||
@selection_order = grep { $now{$_} } @selection_order;
|
||||
},
|
||||
);
|
||||
|
||||
$win->add(
|
||||
'info', 'Label',
|
||||
-y => -1,
|
||||
-text => "Space/Enter = toggle, C = confirm, Q = quit",
|
||||
);
|
||||
|
||||
$listbox->clear_binding('loose-focus');
|
||||
|
||||
$listbox->set_binding(
|
||||
sub {
|
||||
my @picked = $listbox->get();
|
||||
if ( $multiselect && grep { $_ eq '__ALL__' } @picked ) {
|
||||
@selection = @items;
|
||||
}
|
||||
elsif ($multiselect) {
|
||||
@selection = @selection_order;
|
||||
}
|
||||
else {
|
||||
@selection = @picked;
|
||||
}
|
||||
$cui->mainloopExit();
|
||||
},
|
||||
'c',
|
||||
);
|
||||
|
||||
$listbox->set_binding(
|
||||
sub {
|
||||
@selection = ();
|
||||
$cui->mainloopExit();
|
||||
},
|
||||
'q',
|
||||
);
|
||||
|
||||
$listbox->focus();
|
||||
$cui->mainloop();
|
||||
|
||||
$cui->leave_curses();
|
||||
$cui->delete('root');
|
||||
|
||||
return @selection;
|
||||
}
|
||||
|
||||
1;
|
||||
292
scripts/Modules/Util.pm
Normal file
292
scripts/Modules/Util.pm
Normal file
@ -0,0 +1,292 @@
|
||||
package Util;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use diagnostics;
|
||||
|
||||
use DateTime;
|
||||
|
||||
use feature 'say';
|
||||
|
||||
my $local_root = '/home/christoph/Notes/TU/MastersThesis/FailNix';
|
||||
my $local_archive_dir = "$local_root/injections";
|
||||
|
||||
my $ntfy_url = 'https://ntfy.vps.chriphost.de';
|
||||
my $ntfy_token = 'tk_rx8fd6hojuz4ekcb72j7juugkbmga'; # May be public
|
||||
my $ntfy_topic = 'fail-alerts';
|
||||
|
||||
sub notify {
|
||||
my ($msg) = @_;
|
||||
|
||||
system( 'curl', '-H', "Authorization: Bearer $ntfy_token",
|
||||
'-d', $msg, "$ntfy_url/$ntfy_topic" );
|
||||
|
||||
sleep(1);
|
||||
}
|
||||
|
||||
sub notify_file {
|
||||
my ($file) = @_;
|
||||
|
||||
system(
|
||||
'curl', '-H', "Authorization: Bearer $ntfy_token",
|
||||
'-T', $file, '-H', "Filename: $file",
|
||||
"$ntfy_url/$ntfy_topic"
|
||||
);
|
||||
|
||||
sleep(1);
|
||||
}
|
||||
|
||||
sub shell_quote {
|
||||
my ($string) = @_;
|
||||
$string =~ s/'/'"'"'/g;
|
||||
return "'$string'";
|
||||
}
|
||||
|
||||
sub date_now {
|
||||
my $dt = DateTime->now( time_zone => 'local' );
|
||||
my $date = $dt->iso8601;
|
||||
|
||||
return $date;
|
||||
}
|
||||
|
||||
sub run {
|
||||
my @cmd = @_;
|
||||
say "Running: @cmd";
|
||||
system(@cmd) == 0
|
||||
or die "Command failed (exit " . ( $? >> 8 ) . "): @cmd\n";
|
||||
}
|
||||
|
||||
sub read_file {
|
||||
my ($file) = @_;
|
||||
open( my $readhandle, '<', $file ) or die "failed to open $file: $!";
|
||||
local $/;
|
||||
my $content = <$readhandle> // die "failed to read $file: $!";
|
||||
close($readhandle) or die "failed to close $file: $!";
|
||||
return $content;
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my ( $file, $content ) = @_;
|
||||
open( my $writehandle, '>', $file ) or die "failed to open $file: $!";
|
||||
print $writehandle $content or die "failed to write $file: $!";
|
||||
close($writehandle) or die "failed to close $file: $!";
|
||||
}
|
||||
|
||||
sub rewrite_file {
|
||||
my ( $file, $matches, $replacement ) = @_;
|
||||
|
||||
open( my $readhandle, '<', $file ) or die "failed to open $file: $!";
|
||||
my @lines;
|
||||
my $found = 0;
|
||||
while ( my $line = <$readhandle> ) {
|
||||
if ( index( $line, $matches ) != -1 ) {
|
||||
$line = $replacement;
|
||||
$found = 1;
|
||||
}
|
||||
push @lines, $line;
|
||||
}
|
||||
close($readhandle) or die "failed to close $file: $!";
|
||||
|
||||
die "no line containing $matches found in $file" unless $found;
|
||||
|
||||
open( my $writehandle, '>', $file ) or die "failed to open $file: $!";
|
||||
print $writehandle @lines or die "failed to write $file: $!";
|
||||
close($writehandle) or die "failed to close $file: $!";
|
||||
|
||||
say "Updated $file with $replacement";
|
||||
}
|
||||
|
||||
sub cpu_count {
|
||||
open( my $handle, '/proc/cpuinfo' ) or die "Can't open cpuinfo: $!\n";
|
||||
my $count = scalar( map /^processor/, <$handle> );
|
||||
close $handle;
|
||||
|
||||
return $count;
|
||||
}
|
||||
|
||||
sub find_files {
|
||||
my ($dir) = @_;
|
||||
|
||||
opendir( my $dhandle, $dir ) or die "opendir($dir): $!";
|
||||
my @files = sort grep { -f "$dir/$_" } readdir($dhandle);
|
||||
closedir($dhandle);
|
||||
|
||||
return @files;
|
||||
}
|
||||
|
||||
sub find_subdirs {
|
||||
my ($dir) = @_;
|
||||
|
||||
opendir( my $dhandle, $dir ) or die "opendir($dir): $!";
|
||||
my @subdirs =
|
||||
sort grep { $_ ne '.' && $_ ne '..' && -d "$dir/$_" } readdir($dhandle);
|
||||
closedir($dhandle);
|
||||
|
||||
return @subdirs;
|
||||
}
|
||||
|
||||
sub execute_query {
|
||||
my ( $experiment, $queryname, $db_conf, $builds_dir, $do_notify_file ) = @_;
|
||||
|
||||
my $module = "Queries::$queryname";
|
||||
my $file = "$module.pm";
|
||||
$file =~ s/::/\//g;
|
||||
|
||||
require $file;
|
||||
|
||||
my $query = $module->can('query') or die "$module can't query()";
|
||||
my $args = $module->can('args') or die "$module can't args()";
|
||||
my $filename = $module->can('filename') or die "$module can't filanem()";
|
||||
my $postprocess = $module->can('postprocess')
|
||||
or die "$module can't postprocess()";
|
||||
|
||||
my $querystring = $query->($experiment);
|
||||
my $argsstring = $args->();
|
||||
my $filenamestring = $filename->();
|
||||
|
||||
# TODO: Pass the values instead of rewriting db.conf.
|
||||
# Can also use DBI's database handle directly.
|
||||
my $result =
|
||||
qx{mariadb --defaults-file=$db_conf $argsstring -e "$querystring"};
|
||||
die "Query failed: $?" if $? != 0;
|
||||
|
||||
$postprocess->($result);
|
||||
|
||||
system( 'mkdir', '-p', "$builds_dir/$experiment" );
|
||||
open( my $results_handle, '>', "$builds_dir/$experiment/$filenamestring" )
|
||||
or die "failed to open file: $!";
|
||||
print $results_handle $result;
|
||||
close($results_handle) or die "failed to close file: $!";
|
||||
|
||||
if ( defined $do_notify_file and $do_notify_file == 1 ) {
|
||||
notify_file("$builds_dir/$experiment/$filenamestring");
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub format_number_sep {
|
||||
my ($number) = @_;
|
||||
1 while $number =~ s/^(-?\d+)(\d{3})/$1.$2/;
|
||||
return $number;
|
||||
}
|
||||
|
||||
sub elf_read_sections {
|
||||
my ($elffile) = @_;
|
||||
|
||||
my $readelf_out = qx{readelf -S $elffile};
|
||||
my @lines = split "\n", $readelf_out;
|
||||
|
||||
my @sections;
|
||||
foreach my $line (@lines) {
|
||||
|
||||
# [ 1] .text PROGBITS 00100000 001000 0000f0 00 AX 0 0 4
|
||||
next
|
||||
unless $line =~
|
||||
/^\s*\[\s*\d+\]\s+(\..+?)\s+([A-Z]+)\s+([0-9a-f]+)\s+([0-9a-f]+)\s+([0-9a-f]+)\s+.*$/;
|
||||
|
||||
push @sections, {
|
||||
name => $1,
|
||||
type => $2,
|
||||
address => $3, # Memory location
|
||||
offset => $4, # File location
|
||||
size => $5,
|
||||
};
|
||||
}
|
||||
|
||||
return @sections;
|
||||
}
|
||||
|
||||
sub get_section_name {
|
||||
my ( $address, @sections ) = @_;
|
||||
|
||||
my $name;
|
||||
my $last_address = 0;
|
||||
foreach my $section (@sections) {
|
||||
my $cur_address = hex( $section->{address} );
|
||||
if ( hex($address) >= $cur_address && $cur_address > $last_address ) {
|
||||
$name = $section->{name};
|
||||
$last_address = $cur_address;
|
||||
}
|
||||
}
|
||||
|
||||
return $name;
|
||||
}
|
||||
|
||||
sub read_experiment_info {
|
||||
my ($exp) = @_;
|
||||
|
||||
return unless ( -f "$local_archive_dir/$exp/0.info" );
|
||||
|
||||
open( my $fhandle, '<', "$local_archive_dir/$exp/0.info" )
|
||||
or die "Failed to open 0.info: $!";
|
||||
my $info = <$fhandle>;
|
||||
chomp $info if defined $info;
|
||||
close($fhandle);
|
||||
|
||||
return defined $info ? $info : "";
|
||||
}
|
||||
|
||||
sub read_marker_info {
|
||||
my ( $experiment, $benchmark, $address ) = @_;
|
||||
|
||||
return ""
|
||||
unless (
|
||||
-f "$local_archive_dir/$experiment/markers/$benchmark-$address.info" );
|
||||
|
||||
open( my $fhandle, '<',
|
||||
"$local_archive_dir/$experiment/markers/$benchmark-$address.info" )
|
||||
or die "Failed to open $benchmark-$address.info: $!";
|
||||
local $/;
|
||||
my $info = <$fhandle>;
|
||||
chomp $info;
|
||||
close($fhandle);
|
||||
|
||||
return $info;
|
||||
}
|
||||
|
||||
sub overwrite_marker_info {
|
||||
my ( $experiment, $benchmark, $address, $info ) = @_;
|
||||
|
||||
system( 'mkdir', '-p', "$local_archive_dir/$experiment/markers" );
|
||||
|
||||
open( my $fhandle, '>',
|
||||
"$local_archive_dir/$experiment/markers/$benchmark-$address.info" )
|
||||
or die "Failed to open $benchmark-$address.info: $!";
|
||||
print $fhandle $info;
|
||||
close($fhandle);
|
||||
}
|
||||
|
||||
sub delete_marker_info {
|
||||
my ( $experiment, $benchmark, $address ) = @_;
|
||||
|
||||
system( 'rm',
|
||||
"$local_archive_dir/$experiment/markers/$benchmark-$address.info" );
|
||||
}
|
||||
|
||||
sub select_experiment {
|
||||
my ($multi) = @_;
|
||||
|
||||
my @experiments = find_subdirs($local_archive_dir);
|
||||
|
||||
my @exp_with_notes;
|
||||
foreach my $exp (@experiments) {
|
||||
my $info = read_experiment_info($exp);
|
||||
|
||||
push @exp_with_notes,
|
||||
( defined $info && length($info) > 0 )
|
||||
? sprintf( "%-50s (%s)", $exp, $info )
|
||||
: $exp;
|
||||
}
|
||||
|
||||
my @selected_experiments =
|
||||
TUI::select_from_list( "Select Experiment", $multi, @exp_with_notes );
|
||||
die "No experiment selected" unless @selected_experiments;
|
||||
|
||||
@selected_experiments =
|
||||
map { s/(.*?)\s+\(.+\)$/$1/r } @selected_experiments;
|
||||
|
||||
return $multi == 1 ? @selected_experiments : $selected_experiments[0];
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user