mirror of
https://github.com/percona/percona-toolkit.git
synced 2025-09-11 13:40:07 +00:00
cdec55dc84
In order to be able to count individual users for the usage stats, we need to implement UUID instead of just using MD5(hostname) since most servers are just 'localhost' or 'db1'. Using UUID we would be able to count unique users.
740 lines
24 KiB
Perl
740 lines
24 KiB
Perl
# This program is copyright 2012-2014 Percona Ireland Ltd.
|
|
# Feedback and improvements are welcome.
|
|
#
|
|
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
|
|
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
|
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
|
#
|
|
# 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, version 2; OR the Perl Artistic License. On UNIX and similar
|
|
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
|
|
# licenses.
|
|
#
|
|
# You should have received a copy of the GNU General Public License along with
|
|
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
|
|
# Place, Suite 330, Boston, MA 02111-1307 USA.
|
|
# ###########################################################################
|
|
# VersionCheck package
|
|
# ###########################################################################
|
|
{
|
|
package VersionCheck;
|
|
|
|
# NOTE: VersionCheck 2.2 is not compatible with 2.1.
|
|
# In 2.1, the vc file did not have a special system
|
|
# instance with ID 0, and it used the file's mtime.
|
|
# In 2.2, the system and MySQL instances are all saved
|
|
# in the vc file, and the file's mtime doesn't matter.
|
|
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use English qw(-no_match_vars);
|
|
|
|
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
|
|
|
|
use Data::Dumper;
|
|
local $Data::Dumper::Indent = 1;
|
|
local $Data::Dumper::Sortkeys = 1;
|
|
local $Data::Dumper::Quotekeys = 0;
|
|
|
|
use Digest::MD5 qw(md5_hex);
|
|
use Sys::Hostname qw(hostname);
|
|
use File::Basename qw();
|
|
use File::Spec;
|
|
use FindBin qw();
|
|
|
|
eval {
|
|
require Percona::Toolkit;
|
|
require HTTP::Micro;
|
|
};
|
|
|
|
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
|
|
my @vc_dirs = (
|
|
'/etc/percona',
|
|
'/etc/percona-toolkit',
|
|
'/tmp',
|
|
"$home",
|
|
);
|
|
|
|
# Return the version check file used to keep track of
|
|
# MySQL instance that have been checked and when. Some
|
|
# systems use random tmp dirs; we don't want that else
|
|
# every user will have their own vc file. One vc file
|
|
# per system is the goal, so prefer global sys dirs first.
|
|
{
|
|
my $file = 'percona-version-check';
|
|
|
|
sub version_check_file {
|
|
foreach my $dir ( @vc_dirs ) {
|
|
if ( -d $dir && -w $dir ) {
|
|
PTDEBUG && _d('Version check file', $file, 'in', $dir);
|
|
return $dir . '/' . $file;
|
|
}
|
|
}
|
|
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
|
|
return $file; # in the CWD
|
|
}
|
|
}
|
|
|
|
# Return time limit between checks.
|
|
sub version_check_time_limit {
|
|
return 60 * 60 * 24; # one day
|
|
}
|
|
|
|
# #############################################################################
|
|
# Version check handlers
|
|
# #############################################################################
|
|
|
|
# Do a version check. This is only sub a caller/tool needs to call.
|
|
# Pass in an arrayref of hashrefs for each MySQL instance to check.
|
|
# Each hashref should have a dbh and a dsn.
|
|
#
|
|
# This sub fails silently, so you must use PTDEBUG to diagnose. Use
|
|
# PTDEBUG_VERSION_CHECK=1 and this sub will exit 255 when it's done
|
|
# (helpful in combination with PTDEBUG=1 so you don't get the tool's
|
|
# full debug output).
|
|
#
|
|
# Use PERCONA_VERSION_CHECK_URL to set the version check API url,
|
|
# e.g. https://stage.v.percona.com for testing.
|
|
sub version_check {
|
|
my (%args) = @_;
|
|
|
|
my $instances = $args{instances} || [];
|
|
my $instances_to_check;
|
|
|
|
# This sub should only be called if $o->get('version-check') is true,
|
|
# and it is by default because the option is on by default in PT 2.2.
|
|
# However, we do not want dev and testing to v-c, so even though this
|
|
# sub is called, force should be false because $o->got('version-check')
|
|
# is false, then check for a .bzr or .git dir which indicates dev or testing.
|
|
# ../.bzr is when a tool is ran from /bin/; ../../.bzr is when a tool
|
|
# is ran as a module from /t/<tool>/.
|
|
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
|
|
if ( !$args{force} ) {
|
|
if ( $FindBin::Bin
|
|
&& (-d "$FindBin::Bin/../.bzr" ||
|
|
-d "$FindBin::Bin/../../.bzr" ||
|
|
-d "$FindBin::Bin/../.git" ||
|
|
-d "$FindBin::Bin/../../.git"
|
|
)
|
|
) {
|
|
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
|
|
return;
|
|
}
|
|
}
|
|
|
|
eval {
|
|
# Name and ID the instances. The name is for debugging,
|
|
# and the ID is what the code uses to prevent double-checking.
|
|
foreach my $instance ( @$instances ) {
|
|
my ($name, $id) = get_instance_id($instance);
|
|
$instance->{name} = $name;
|
|
$instance->{id} = $id;
|
|
}
|
|
|
|
# Push a special instance for the system itself.
|
|
push @$instances, { name => 'system', id => 0 };
|
|
|
|
# Get the instances which haven't been checked in the 24 hours.
|
|
$instances_to_check = get_instances_to_check(
|
|
instances => $instances,
|
|
vc_file => $args{vc_file}, # testing
|
|
now => $args{now}, # testing
|
|
);
|
|
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
|
|
return unless @$instances_to_check;
|
|
|
|
# Skip Version Check altogether if SSL not available
|
|
my $protocol = 'https';
|
|
eval { require IO::Socket::SSL; };
|
|
if ( $EVAL_ERROR ) {
|
|
PTDEBUG && _d($EVAL_ERROR);
|
|
PTDEBUG && _d("SSL not available, won't run version_check");
|
|
return;
|
|
}
|
|
PTDEBUG && _d('Using', $protocol);
|
|
|
|
# Get list of programs to check from Percona.
|
|
my $advice = pingback(
|
|
instances => $instances_to_check,
|
|
protocol => $protocol,
|
|
url => $args{url} # testing
|
|
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|
|
|| "$protocol://v.percona.com",
|
|
);
|
|
if ( $advice ) {
|
|
PTDEBUG && _d('Advice:', Dumper($advice));
|
|
if ( scalar @$advice > 1) {
|
|
print "\n# " . scalar @$advice . " software updates are "
|
|
. "available:\n";
|
|
}
|
|
else {
|
|
print "\n# A software update is available:\n";
|
|
}
|
|
print join("\n", map { "# * $_" } @$advice), "\n\n";
|
|
}
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
|
|
}
|
|
|
|
# Always update the vc file, even if the version check fails.
|
|
if ( @$instances_to_check ) {
|
|
eval {
|
|
# Update the check time for things we checked. I.e. if we
|
|
# didn't check it, do _not_ update its time.
|
|
update_check_times(
|
|
instances => $instances_to_check,
|
|
vc_file => $args{vc_file}, # testing
|
|
now => $args{now}, # testing
|
|
);
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
|
|
}
|
|
}
|
|
|
|
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
|
|
warn "Exiting because the PTDEBUG_VERSION_CHECK "
|
|
. "environment variable is defined.\n";
|
|
exit 255;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub get_instances_to_check {
|
|
my (%args) = @_;
|
|
|
|
my $instances = $args{instances};
|
|
my $now = $args{now} || int(time);
|
|
my $vc_file = $args{vc_file} || version_check_file();
|
|
|
|
if ( !-f $vc_file ) {
|
|
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
|
|
'version checking all instances');
|
|
return $instances;
|
|
}
|
|
|
|
# The version check file contains "ID,time" lines for each MySQL instance
|
|
# and a special "0,time" instance for the system. Another tool may have
|
|
# seen fewer or more instances than the current tool, but we'll read them
|
|
# all and check only the instances for the current tool.
|
|
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
|
|
chomp(my $file_contents = do { local $/ = undef; <$fh> });
|
|
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
|
|
close $fh;
|
|
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
|
|
|
|
# Check the instances that have either 1) never been checked
|
|
# (or seen) before, or 2) were checked > check time limit ago.
|
|
my $check_time_limit = version_check_time_limit();
|
|
my @instances_to_check;
|
|
foreach my $instance ( @$instances ) {
|
|
my $last_check_time = $last_check_time_for{ $instance->{id} };
|
|
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
|
|
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
|
|
'hours until next check',
|
|
sprintf '%.2f',
|
|
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
|
|
if ( !defined $last_check_time
|
|
|| ($now - $last_check_time) >= $check_time_limit ) {
|
|
PTDEBUG && _d('Time to check', Dumper($instance));
|
|
push @instances_to_check, $instance;
|
|
}
|
|
}
|
|
|
|
return \@instances_to_check;
|
|
}
|
|
|
|
sub update_check_times {
|
|
my (%args) = @_;
|
|
|
|
my $instances = $args{instances};
|
|
my $now = $args{now} || int(time);
|
|
my $vc_file = $args{vc_file} || version_check_file();
|
|
PTDEBUG && _d('Updating last check time:', $now);
|
|
|
|
# We need to write back all instances to the file. The given
|
|
# instances are the ones updated, so use the current ts (now).
|
|
my %all_instances = map {
|
|
$_->{id} => { name => $_->{name}, ts => $now }
|
|
} @$instances;
|
|
|
|
# If the file exists, read the instances in it, and if they're
|
|
# not one of the updated ones, save them with their original ts.
|
|
if ( -f $vc_file ) {
|
|
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
|
|
my $contents = do { local $/ = undef; <$fh> };
|
|
close $fh;
|
|
|
|
foreach my $line ( split("\n", ($contents || '')) ) {
|
|
my ($id, $ts) = split(',', $line);
|
|
if ( !exists $all_instances{$id} ) {
|
|
$all_instances{$id} = { ts => $ts }; # original ts, not updated
|
|
}
|
|
}
|
|
}
|
|
|
|
# Write back all instances, some with updated ts, others with their
|
|
# original ts.
|
|
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
|
|
foreach my $id ( sort keys %all_instances ) {
|
|
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
|
|
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
|
|
}
|
|
close $fh;
|
|
|
|
return;
|
|
}
|
|
|
|
sub get_instance_id {
|
|
my ($instance) = @_;
|
|
|
|
my $dbh = $instance->{dbh};
|
|
my $dsn = $instance->{dsn};
|
|
|
|
# MySQL 5.1+ has @@hostname and @@port
|
|
# MySQL 5.0 has @@hostname but port only in SHOW VARS
|
|
# MySQL 4.x has nothing, so we use the dsn
|
|
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
|
|
PTDEBUG && _d($sql);
|
|
my ($name) = eval { $dbh->selectrow_array($sql) };
|
|
if ( $EVAL_ERROR ) {
|
|
# MySQL 4.x or 5.0
|
|
PTDEBUG && _d($EVAL_ERROR);
|
|
$sql = q{SELECT @@hostname};
|
|
PTDEBUG && _d($sql);
|
|
($name) = eval { $dbh->selectrow_array($sql) };
|
|
if ( $EVAL_ERROR ) {
|
|
# MySQL 4.x
|
|
PTDEBUG && _d($EVAL_ERROR);
|
|
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
|
|
}
|
|
else {
|
|
# MySQL 5.0
|
|
$sql = q{SHOW VARIABLES LIKE 'port'};
|
|
PTDEBUG && _d($sql);
|
|
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
|
|
PTDEBUG && _d('port:', $port);
|
|
$name .= $port || '';
|
|
}
|
|
}
|
|
my $id = md5_hex($name);
|
|
|
|
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
|
|
|
|
return $name, $id;
|
|
}
|
|
|
|
|
|
# This function has been implemented solely to be able to count individual
|
|
# Toolkit users for statistics. It uses a random UUID, no client info is
|
|
# being gathered nor stored
|
|
sub get_uuid {
|
|
my $uuid_file = '/.percona-toolkit.uuid';
|
|
foreach my $dir (@vc_dirs) {
|
|
my $filename = $dir.$uuid_file;
|
|
my $uuid=_read_uuid($filename);
|
|
return $uuid if $uuid;
|
|
}
|
|
|
|
my $filename = $ENV{"HOME"} . $uuid_file;
|
|
my $uuid = _generate_uuid();
|
|
|
|
open(my $fh, '>', $filename) or die "Could not open file '$filename' $!";
|
|
print $fh $uuid;
|
|
close $fh;
|
|
|
|
return $uuid;
|
|
}
|
|
|
|
sub _generate_uuid {
|
|
return sprintf+($}="%04x")."$}-$}-$}-$}-".$}x3,map rand 65537,0..7;
|
|
}
|
|
|
|
sub _read_uuid {
|
|
my $filename = shift;
|
|
my $fh;
|
|
|
|
eval {
|
|
open($fh, '<:encoding(UTF-8)', $filename);
|
|
};
|
|
return if ($EVAL_ERROR);
|
|
|
|
my $uuid;
|
|
eval { $uuid = <$fh>; };
|
|
return if ($EVAL_ERROR);
|
|
|
|
chomp $uuid;
|
|
return $uuid;
|
|
}
|
|
|
|
# #############################################################################
|
|
# Protocol handlers
|
|
# #############################################################################
|
|
|
|
sub pingback {
|
|
my (%args) = @_;
|
|
my @required_args = qw(url instances);
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg arugment" unless $args{$arg};
|
|
}
|
|
my $url = $args{url};
|
|
my $instances = $args{instances};
|
|
|
|
# Optional args
|
|
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
|
|
|
|
# GET https://upgrade.percona.com, the server will return
|
|
# a plaintext list of items/programs it wants the tool
|
|
# to get, one item per line with the format ITEM;TYPE[;VARS]
|
|
# ITEM is the pretty name of the item/program; TYPE is
|
|
# the type of ITEM that helps the tool determine how to
|
|
# get the item's version; and VARS is optional for certain
|
|
# items/types that need extra hints.
|
|
my $response = $ua->request('GET', $url);
|
|
PTDEBUG && _d('Server response:', Dumper($response));
|
|
die "No response from GET $url"
|
|
if !$response;
|
|
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
|
|
($response->{content} || '')) if $response->{status} != 200;
|
|
die("GET on $url did not return any programs to check")
|
|
if !$response->{content};
|
|
|
|
# Parse the plaintext server response into a hashref keyed on
|
|
# the items like:
|
|
# "MySQL" => {
|
|
# item => "MySQL",
|
|
# type => "mysql_variables",
|
|
# vars => ["version", "version_comment"],
|
|
# }
|
|
my $items = parse_server_response(
|
|
response => $response->{content}
|
|
);
|
|
die "Failed to parse server requested programs: $response->{content}"
|
|
if !scalar keys %$items;
|
|
|
|
# Get the versions for those items in another hashref also keyed on
|
|
# the items like:
|
|
# "MySQL" => "MySQL Community Server 5.1.49-log",
|
|
my $versions = get_versions(
|
|
items => $items,
|
|
instances => $instances,
|
|
);
|
|
die "Failed to get any program versions; should have at least gotten Perl"
|
|
if !scalar keys %$versions;
|
|
|
|
# Join the items and whatever versions are available and re-encode
|
|
# them in same simple plaintext item-per-line protocol, and send
|
|
# it back to Percona.
|
|
my $client_content = encode_client_response(
|
|
items => $items,
|
|
versions => $versions,
|
|
general_id => get_uuid(),
|
|
);
|
|
|
|
my $client_response = {
|
|
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
|
|
content => $client_content,
|
|
};
|
|
PTDEBUG && _d('Client response:', Dumper($client_response));
|
|
|
|
$response = $ua->request('POST', $url, $client_response);
|
|
PTDEBUG && _d('Server suggestions:', Dumper($response));
|
|
die "No response from POST $url $client_response"
|
|
if !$response;
|
|
die "POST $url returned HTTP status $response->{status}; expected 200"
|
|
if $response->{status} != 200;
|
|
|
|
# Response contents is empty if the server doesn't have any suggestions.
|
|
return unless $response->{content};
|
|
|
|
# If the server has suggestions for items, it sends them back in
|
|
# the same format: ITEM:TYPE:SUGGESTION\n. ITEM:TYPE is mostly for
|
|
# debugging; the tool just repports the suggestions.
|
|
$items = parse_server_response(
|
|
response => $response->{content},
|
|
split_vars => 0,
|
|
);
|
|
die "Failed to parse server suggestions: $response->{content}"
|
|
if !scalar keys %$items;
|
|
my @suggestions = map { $_->{vars} }
|
|
sort { $a->{item} cmp $b->{item} }
|
|
values %$items;
|
|
|
|
return \@suggestions;
|
|
}
|
|
|
|
sub encode_client_response {
|
|
my (%args) = @_;
|
|
my @required_args = qw(items versions general_id);
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg arugment" unless $args{$arg};
|
|
}
|
|
my ($items, $versions, $general_id) = @args{@required_args};
|
|
|
|
# There may not be a version for each item. For example, the server
|
|
# may have requested the "MySQL" (version) item, but if the tool
|
|
# didn't connect to MySQL, there won't be a $versions->{MySQL}.
|
|
# That's ok; just use what we've got.
|
|
# NOTE: the sort is only need to make testing deterministic.
|
|
my @lines;
|
|
foreach my $item ( sort keys %$items ) {
|
|
next unless exists $versions->{$item};
|
|
if ( ref($versions->{$item}) eq 'HASH' ) {
|
|
my $mysql_versions = $versions->{$item};
|
|
for my $id ( sort keys %$mysql_versions ) {
|
|
push @lines, join(';', $id, $item, $mysql_versions->{$id});
|
|
}
|
|
}
|
|
else {
|
|
push @lines, join(';', $general_id, $item, $versions->{$item});
|
|
}
|
|
}
|
|
|
|
my $client_response = join("\n", @lines) . "\n";
|
|
return $client_response;
|
|
}
|
|
|
|
sub parse_server_response {
|
|
my (%args) = @_;
|
|
my @required_args = qw(response);
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg arugment" unless $args{$arg};
|
|
}
|
|
my ($response) = @args{@required_args};
|
|
|
|
my %items = map {
|
|
my ($item, $type, $vars) = split(";", $_);
|
|
if ( !defined $args{split_vars} || $args{split_vars} ) {
|
|
$vars = [ split(",", ($vars || '')) ];
|
|
}
|
|
$item => {
|
|
item => $item,
|
|
type => $type,
|
|
vars => $vars,
|
|
};
|
|
} split("\n", $response);
|
|
|
|
PTDEBUG && _d('Items:', Dumper(\%items));
|
|
|
|
return \%items;
|
|
}
|
|
|
|
# Safety check: only these types of items are valid/official.
|
|
my %sub_for_type = (
|
|
os_version => \&get_os_version,
|
|
perl_version => \&get_perl_version,
|
|
perl_module_version => \&get_perl_module_version,
|
|
mysql_variable => \&get_mysql_variable,
|
|
);
|
|
|
|
sub valid_item {
|
|
my ($item) = @_;
|
|
return unless $item;
|
|
if ( !exists $sub_for_type{ $item->{type} } ) {
|
|
PTDEBUG && _d('Invalid type:', $item->{type});
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub get_versions {
|
|
my (%args) = @_;
|
|
my @required_args = qw(items);
|
|
foreach my $arg ( @required_args ) {
|
|
die "I need a $arg arugment" unless $args{$arg};
|
|
}
|
|
my ($items) = @args{@required_args};
|
|
|
|
my %versions;
|
|
foreach my $item ( values %$items ) {
|
|
next unless valid_item($item);
|
|
eval {
|
|
my $version = $sub_for_type{ $item->{type} }->(
|
|
item => $item,
|
|
instances => $args{instances},
|
|
);
|
|
if ( $version ) {
|
|
chomp $version unless ref($version);
|
|
$versions{$item->{item}} = $version;
|
|
}
|
|
};
|
|
if ( $EVAL_ERROR ) {
|
|
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
|
|
}
|
|
}
|
|
|
|
return \%versions;
|
|
}
|
|
|
|
# #############################################################################
|
|
# Version getters
|
|
# #############################################################################
|
|
|
|
sub get_os_version {
|
|
if ( $OSNAME eq 'MSWin32' ) {
|
|
require Win32;
|
|
return Win32::GetOSDisplayName();
|
|
}
|
|
|
|
chomp(my $platform = `uname -s`);
|
|
PTDEBUG && _d('platform:', $platform);
|
|
return $OSNAME unless $platform;
|
|
|
|
chomp(my $lsb_release
|
|
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
|
|
PTDEBUG && _d('lsb_release:', $lsb_release);
|
|
|
|
my $release = "";
|
|
|
|
if ( $platform eq 'Linux' ) {
|
|
if ( -f "/etc/fedora-release" ) {
|
|
$release = `cat /etc/fedora-release`;
|
|
}
|
|
elsif ( -f "/etc/redhat-release" ) {
|
|
$release = `cat /etc/redhat-release`;
|
|
}
|
|
elsif ( -f "/etc/system-release" ) {
|
|
$release = `cat /etc/system-release`;
|
|
}
|
|
elsif ( $lsb_release ) {
|
|
$release = `$lsb_release -ds`;
|
|
}
|
|
elsif ( -f "/etc/lsb-release" ) {
|
|
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
|
|
$release =~ s/^\w+="([^"]+)".+/$1/;
|
|
}
|
|
elsif ( -f "/etc/debian_version" ) {
|
|
chomp(my $rel = `cat /etc/debian_version`);
|
|
$release = "Debian $rel";
|
|
if ( -f "/etc/apt/sources.list" ) {
|
|
chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list | awk -F/ '{print \$1}'| awk 'BEGIN {FS="|"} {print \$1}' | sort | uniq -c | sort -rn | head -n1 | awk '{print \$2}'`);
|
|
$release .= " ($code_name)" if $code_name;
|
|
}
|
|
}
|
|
elsif ( -f "/etc/os-release" ) { # openSUSE
|
|
chomp($release = `grep PRETTY_NAME /etc/os-release`);
|
|
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
|
|
}
|
|
elsif ( `ls /etc/*release 2>/dev/null` ) {
|
|
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
|
|
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
|
|
}
|
|
else {
|
|
$release = `cat /etc/*release | head -n1`;
|
|
}
|
|
}
|
|
}
|
|
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
|
|
my $rel = `uname -r`;
|
|
$release = "$platform $rel";
|
|
}
|
|
elsif ( $platform eq "SunOS" ) {
|
|
my $rel = `head -n1 /etc/release` || `uname -r`;
|
|
$release = "$platform $rel";
|
|
}
|
|
|
|
if ( !$release ) {
|
|
PTDEBUG && _d('Failed to get the release, using platform');
|
|
$release = $platform;
|
|
}
|
|
chomp($release);
|
|
|
|
# For Gentoo, which returns a value in quotes
|
|
$release =~ s/^"|"$//g;
|
|
|
|
PTDEBUG && _d('OS version =', $release);
|
|
return $release;
|
|
}
|
|
|
|
sub get_perl_version {
|
|
my (%args) = @_;
|
|
my $item = $args{item};
|
|
return unless $item;
|
|
|
|
my $version = sprintf '%vd', $PERL_VERSION;
|
|
PTDEBUG && _d('Perl version', $version);
|
|
return $version;
|
|
}
|
|
|
|
sub get_perl_module_version {
|
|
my (%args) = @_;
|
|
my $item = $args{item};
|
|
return unless $item;
|
|
|
|
# If there's a var, then its an explicit Perl variable name to get,
|
|
# else the item name is an implicity Perl module name to which we
|
|
# append ::VERSION to get the module's version.
|
|
my $var = '$' . $item->{item} . '::VERSION';
|
|
my $version = eval "use $item->{item}; $var;";
|
|
PTDEBUG && _d('Perl version for', $var, '=', $version);
|
|
return $version;
|
|
}
|
|
|
|
sub get_mysql_variable {
|
|
return get_from_mysql(
|
|
show => 'VARIABLES',
|
|
@_,
|
|
);
|
|
}
|
|
|
|
sub get_from_mysql {
|
|
my (%args) = @_;
|
|
my $show = $args{show};
|
|
my $item = $args{item};
|
|
my $instances = $args{instances};
|
|
return unless $show && $item;
|
|
|
|
if ( !$instances || !@$instances ) {
|
|
PTDEBUG && _d('Cannot check', $item,
|
|
'because there are no MySQL instances');
|
|
return;
|
|
}
|
|
|
|
# Only allow version variables to be reported
|
|
# So in case of MITM attack, we don't report sensitive data
|
|
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
|
|
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
|
|
}
|
|
|
|
|
|
my @versions;
|
|
my %version_for;
|
|
foreach my $instance ( @$instances ) {
|
|
next unless $instance->{id}; # special system instance has id=0
|
|
my $dbh = $instance->{dbh};
|
|
local $dbh->{FetchHashKeyName} = 'NAME_lc';
|
|
my $sql = qq/SHOW $show/;
|
|
PTDEBUG && _d($sql);
|
|
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
|
|
|
|
my @versions;
|
|
foreach my $var ( @{$item->{vars}} ) {
|
|
$var = lc($var);
|
|
my $version = $rows->{$var}->{value};
|
|
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
|
|
'on', $instance->{name});
|
|
push @versions, $version;
|
|
}
|
|
$version_for{ $instance->{id} } = join(' ', @versions);
|
|
}
|
|
|
|
return \%version_for;
|
|
}
|
|
|
|
sub _d {
|
|
my ($package, undef, $line) = caller 0;
|
|
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
|
|
map { defined $_ ? $_ : 'undef' }
|
|
@_;
|
|
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
|
|
}
|
|
|
|
1;
|
|
}
|
|
# ###########################################################################
|
|
# End VersionCheck package
|
|
# ###########################################################################
|