← Back to branch summary

~percona-core/percona-toolkit/release-2.2.8-v2

« back to all changes in this revision

Viewing changes to lib/VersionCheck.pm

  • Committer: Daniel Nichter
  • Date: 2013-06-19 21:23:55 UTC
  • mfrom: (582.1.5 release-2.2.3)
  • Revision ID: daniel@percona.com-20130619212355-nf6bmx23j3b76afe
Tags: 2.2.3
Merge release-2.2.3.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/VersionCheck.pm
 
1
# This program is copyright 2012-2013 Percona Ireland Ltd.
 
2
# Feedback and improvements are welcome.
 
3
#
 
4
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 
5
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 
6
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
7
#
 
8
# This program is free software; you can redistribute it and/or modify it under
 
9
# the terms of the GNU General Public License as published by the Free Software
 
10
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
 
11
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
 
12
# licenses.
 
13
#
 
14
# You should have received a copy of the GNU General Public License along with
 
15
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
 
16
# Place, Suite 330, Boston, MA  02111-1307  USA.
 
17
# ###########################################################################
 
18
# VersionCheck package
 
19
# ###########################################################################
 
20
{
 
21
package VersionCheck;
 
22
 
 
23
# NOTE: VersionCheck 2.2 is not compatible with 2.1.
 
24
# In 2.1, the vc file did not have a special system
 
25
# instance with ID 0, and it used the file's mtime.
 
26
# In 2.2, the system and MySQL instances are all saved
 
27
# in the vc file, and the file's mtime doesn't matter.
 
28
 
 
29
use strict;
 
30
use warnings FATAL => 'all';
 
31
use English qw(-no_match_vars);
 
32
 
 
33
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
 
34
 
 
35
use Data::Dumper;
 
36
local $Data::Dumper::Indent    = 1;
 
37
local $Data::Dumper::Sortkeys  = 1;
 
38
local $Data::Dumper::Quotekeys = 0;
 
39
 
 
40
use Digest::MD5 qw(md5_hex);
 
41
use Sys::Hostname qw(hostname);
 
42
use File::Basename qw();
 
43
use File::Spec;
 
44
use FindBin qw();
 
45
 
 
46
eval {
 
47
   require Percona::Toolkit;
 
48
   require HTTPMicro;
 
49
};
 
50
 
 
51
# Return the version check file used to keep track of
 
52
# MySQL instance that have been checked and when.  Some
 
53
# systems use random tmp dirs; we don't want that else
 
54
# every user will have their own vc file.  One vc file
 
55
# per system is the goal, so prefer global sys dirs first.
 
56
{
 
57
   my $file    = 'percona-version-check';
 
58
   my $home    = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
 
59
   my @vc_dirs = (
 
60
      '/etc/percona',
 
61
      '/etc/percona-toolkit',
 
62
      '/tmp',
 
63
      "$home",
 
64
   );
 
65
 
 
66
   sub version_check_file {
 
67
      foreach my $dir ( @vc_dirs ) {
 
68
         if ( -d $dir && -w $dir ) {
 
69
            PTDEBUG && _d('Version check file', $file, 'in', $dir);
 
70
            return $dir . '/' . $file;
 
71
         }
 
72
      }
 
73
      PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
 
74
      return $file;  # in the CWD
 
75
   } 
 
76
}
 
77
 
 
78
# Return time limit between checks.
 
79
sub version_check_time_limit {
 
80
   return 60 * 60 * 24;  # one day
 
81
}
 
82
 
 
83
# #############################################################################
 
84
# Version check handlers
 
85
# #############################################################################
 
86
 
 
87
# Do a version check.  This is only sub a caller/tool needs to call.
 
88
# Pass in an arrayref of hashrefs for each MySQL instance to check.
 
89
# Each hashref should have a dbh and a dsn.
 
90
#
 
91
# This sub fails silently, so you must use PTDEBUG to diagnose.  Use
 
92
# PTDEBUG_VERSION_CHECK=1 and this sub will exit 255 when it's done
 
93
# (helpful in combination with PTDEBUG=1 so you don't get the tool's
 
94
# full debug output).
 
95
#
 
96
# Use PERCONA_VERSION_CHECK_URL to set the version check API url,
 
97
# e.g. https://stage.v.percona.com for testing.
 
98
sub version_check {
 
99
   my (%args) = @_;
 
100
 
 
101
   my $instances = $args{instances} || [];
 
102
   my $instances_to_check;
 
103
 
 
104
   # This sub should only be called if $o->get('version-check') is true,
 
105
   # and it is by default because the option is on by default in PT 2.2.
 
106
   # However, we do not want dev and testing to v-c, so even though this
 
107
   # sub is called, force should be false because $o->got('version-check')
 
108
   # is false, then check for a .bzr dir which indicates dev or testing. 
 
109
   # ../.bzr is when a tool is ran from /bin/; ../../.bzr is when a tool
 
110
   # is ran as a module from /t/<tool>/.
 
111
   PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
 
112
   if ( !$args{force} ) {
 
113
      if ( $FindBin::Bin
 
114
           && (-d "$FindBin::Bin/../.bzr" || -d "$FindBin::Bin/../../.bzr") ) {
 
115
         PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
 
116
         return;
 
117
      }
 
118
   }
 
119
 
 
120
   eval {
 
121
      # Name and ID the instances.  The name is for debugging,
 
122
      # and the ID is what the code uses to prevent double-checking.
 
123
      foreach my $instance ( @$instances ) {
 
124
         my ($name, $id) = get_instance_id($instance);
 
125
         $instance->{name} = $name;
 
126
         $instance->{id}   = $id;
 
127
      }
 
128
 
 
129
      # Push a special instance for the system itself.
 
130
      push @$instances, { name => 'system', id => 0 };
 
131
 
 
132
      # Get the instances which haven't been checked in the 24 hours.
 
133
      $instances_to_check = get_instances_to_check(
 
134
         instances => $instances,
 
135
         vc_file   => $args{vc_file},  # testing
 
136
         now       => $args{now},      # testing
 
137
      );
 
138
      PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
 
139
      return unless @$instances_to_check;
 
140
 
 
141
      # Get the list of program to check from Percona.  Try using
 
142
      # https first; fallback to http if that fails (probably because
 
143
      # IO::Socket::SSL isn't installed).
 
144
      my $protocol = 'https';  # optimistic, but...
 
145
      eval { require IO::Socket::SSL; };
 
146
      if ( $EVAL_ERROR ) {
 
147
         PTDEBUG && _d($EVAL_ERROR);
 
148
         $protocol = 'http';
 
149
      }
 
150
      PTDEBUG && _d('Using', $protocol);
 
151
 
 
152
      my $advice = pingback(
 
153
         instances => $instances_to_check,
 
154
         protocol  => $protocol,
 
155
         url       => $args{url}                       # testing
 
156
                   || $ENV{PERCONA_VERSION_CHECK_URL}  # testing
 
157
                   || "$protocol://v.percona.com",
 
158
      );
 
159
      if ( $advice ) {
 
160
         PTDEBUG && _d('Advice:', Dumper($advice));
 
161
         if ( scalar @$advice > 1) {
 
162
            print "\n# " . scalar @$advice . " software updates are "
 
163
               . "available:\n";
 
164
         }
 
165
         else {
 
166
            print "\n# A software update is available:\n";
 
167
         }
 
168
         print join("\n", map { "#   * $_" } @$advice), "\n\n";
 
169
      }
 
170
   };
 
171
   if ( $EVAL_ERROR ) {
 
172
      PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
 
173
   }
 
174
 
 
175
   # Always update the vc file, even if the version check fails.
 
176
   if ( @$instances_to_check ) {
 
177
      eval {
 
178
         # Update the check time for things we checked.  I.e. if we
 
179
         # didn't check it, do _not_ update its time.
 
180
         update_check_times(
 
181
            instances => $instances_to_check,
 
182
            vc_file   => $args{vc_file},  # testing
 
183
            now       => $args{now},      # testing
 
184
         );
 
185
      };
 
186
      if ( $EVAL_ERROR ) {
 
187
         PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
 
188
      }
 
189
   }
 
190
 
 
191
   if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
 
192
      warn "Exiting because the PTDEBUG_VERSION_CHECK "
 
193
         . "environment variable is defined.\n";
 
194
      exit 255;
 
195
   }
 
196
 
 
197
   return;
 
198
}
 
199
 
 
200
sub get_instances_to_check {
 
201
   my (%args) = @_;
 
202
 
 
203
   my $instances = $args{instances};
 
204
   my $now       = $args{now}     || int(time);
 
205
   my $vc_file   = $args{vc_file} || version_check_file();
 
206
 
 
207
   if ( !-f $vc_file ) {
 
208
      PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
 
209
         'version checking all instances');
 
210
      return $instances;
 
211
   }
 
212
 
 
213
   # The version check file contains "ID,time" lines for each MySQL instance
 
214
   # and a special "0,time" instance for the system.  Another tool may have
 
215
   # seen fewer or more instances than the current tool, but we'll read them
 
216
   # all and check only the instances for the current tool.
 
217
   open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
 
218
   chomp(my $file_contents = do { local $/ = undef; <$fh> });
 
219
   PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
 
220
   close $fh;
 
221
   my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
 
222
 
 
223
   # Check the instances that have either 1) never been checked
 
224
   # (or seen) before, or 2) were checked > check time limit ago.
 
225
   my $check_time_limit = version_check_time_limit();
 
226
   my @instances_to_check;
 
227
   foreach my $instance ( @$instances ) {
 
228
      my $last_check_time = $last_check_time_for{ $instance->{id} };
 
229
      PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
 
230
         $last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
 
231
         'hours until next check',
 
232
         sprintf '%.2f',
 
233
            ($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
 
234
      if ( !defined $last_check_time
 
235
           || ($now - $last_check_time) >= $check_time_limit ) {
 
236
         PTDEBUG && _d('Time to check', Dumper($instance));
 
237
         push @instances_to_check, $instance;
 
238
      }
 
239
   }
 
240
 
 
241
   return \@instances_to_check;
 
242
}
 
243
 
 
244
sub update_check_times {
 
245
   my (%args) = @_;
 
246
 
 
247
   my $instances = $args{instances};
 
248
   my $now       = $args{now}     || int(time);
 
249
   my $vc_file   = $args{vc_file} || version_check_file();
 
250
   PTDEBUG && _d('Updating last check time:', $now);
 
251
 
 
252
   # We need to write back all instances to the file.  The given
 
253
   # instances are the ones updated, so use the current ts (now).
 
254
   my %all_instances = map {
 
255
      $_->{id} => { name => $_->{name}, ts => $now }
 
256
   } @$instances;
 
257
 
 
258
   # If the file exists, read the instances in it, and if they're
 
259
   # not one of the updated ones, save them with their original ts.
 
260
   if ( -f $vc_file ) {
 
261
      open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
 
262
      my $contents = do { local $/ = undef; <$fh> };
 
263
      close $fh;
 
264
 
 
265
      foreach my $line ( split("\n", ($contents || '')) ) {
 
266
         my ($id, $ts) = split(',', $line);
 
267
         if ( !exists $all_instances{$id} ) {
 
268
            $all_instances{$id} = { ts => $ts };  # original ts, not updated
 
269
         }
 
270
      }
 
271
   }
 
272
 
 
273
   # Write back all instances, some with updated ts, others with their
 
274
   # original ts.
 
275
   open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
 
276
   foreach my $id ( sort keys %all_instances ) {
 
277
      PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
 
278
      print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
 
279
   }
 
280
   close $fh;
 
281
 
 
282
   return;
 
283
}
 
284
 
 
285
sub get_instance_id {
 
286
   my ($instance) = @_;
 
287
 
 
288
   my $dbh = $instance->{dbh};
 
289
   my $dsn = $instance->{dsn};
 
290
 
 
291
   # MySQL 5.1+ has @@hostname and @@port
 
292
   # MySQL 5.0  has @@hostname but port only in SHOW VARS
 
293
   # MySQL 4.x  has nothing, so we use the dsn
 
294
   my $sql = q{SELECT CONCAT(@@hostname, @@port)};
 
295
   PTDEBUG && _d($sql);
 
296
   my ($name) = eval { $dbh->selectrow_array($sql) };
 
297
   if ( $EVAL_ERROR ) {
 
298
      # MySQL 4.x or 5.0
 
299
      PTDEBUG && _d($EVAL_ERROR);
 
300
      $sql = q{SELECT @@hostname};
 
301
      PTDEBUG && _d($sql);
 
302
      ($name) = eval { $dbh->selectrow_array($sql) };
 
303
      if ( $EVAL_ERROR ) {
 
304
         # MySQL 4.x
 
305
         PTDEBUG && _d($EVAL_ERROR);
 
306
         $name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
 
307
      }
 
308
      else {
 
309
         # MySQL 5.0
 
310
         $sql = q{SHOW VARIABLES LIKE 'port'};
 
311
         PTDEBUG && _d($sql);
 
312
         my (undef, $port) = eval { $dbh->selectrow_array($sql) };
 
313
         PTDEBUG && _d('port:', $port);
 
314
         $name .= $port || '';
 
315
      }
 
316
   }
 
317
   my $id = md5_hex($name);
 
318
 
 
319
   PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
 
320
 
 
321
   return $name, $id;
 
322
}
 
323
 
 
324
# #############################################################################
 
325
# Protocol handlers
 
326
# #############################################################################
 
327
 
 
328
sub pingback {
 
329
   my (%args) = @_;
 
330
   my @required_args = qw(url instances);
 
331
   foreach my $arg ( @required_args ) {
 
332
      die "I need a $arg arugment" unless $args{$arg};
 
333
   }
 
334
   my $url       = $args{url};
 
335
   my $instances = $args{instances};
 
336
 
 
337
   # Optional args
 
338
   my $ua = $args{ua} || HTTPMicro->new( timeout => 3 );
 
339
 
 
340
   # GET https://upgrade.percona.com, the server will return
 
341
   # a plaintext list of items/programs it wants the tool
 
342
   # to get, one item per line with the format ITEM;TYPE[;VARS]
 
343
   # ITEM is the pretty name of the item/program; TYPE is
 
344
   # the type of ITEM that helps the tool determine how to
 
345
   # get the item's version; and VARS is optional for certain
 
346
   # items/types that need extra hints.
 
347
   my $response = $ua->request('GET', $url);
 
348
   PTDEBUG && _d('Server response:', Dumper($response));
 
349
   die "No response from GET $url"
 
350
      if !$response;
 
351
   die("GET on $url returned HTTP status $response->{status}; expected 200\n",
 
352
       ($response->{content} || '')) if $response->{status} != 200;
 
353
   die("GET on $url did not return any programs to check")
 
354
      if !$response->{content};
 
355
 
 
356
   # Parse the plaintext server response into a hashref keyed on
 
357
   # the items like:
 
358
   #    "MySQL" => {
 
359
   #      item => "MySQL",
 
360
   #      type => "mysql_variables",
 
361
   #      vars => ["version", "version_comment"],
 
362
   #    }
 
363
   my $items = parse_server_response(
 
364
      response => $response->{content}
 
365
   );
 
366
   die "Failed to parse server requested programs: $response->{content}"
 
367
      if !scalar keys %$items;
 
368
      
 
369
   # Get the versions for those items in another hashref also keyed on
 
370
   # the items like:
 
371
   #    "MySQL" => "MySQL Community Server 5.1.49-log",
 
372
   my $versions = get_versions(
 
373
      items     => $items,
 
374
      instances => $instances,
 
375
   );
 
376
   die "Failed to get any program versions; should have at least gotten Perl"
 
377
      if !scalar keys %$versions;
 
378
 
 
379
   # Join the items and whatever versions are available and re-encode
 
380
   # them in same simple plaintext item-per-line protocol, and send
 
381
   # it back to Percona.
 
382
   my $client_content = encode_client_response(
 
383
      items      => $items,
 
384
      versions   => $versions,
 
385
      general_id => md5_hex( hostname() ),
 
386
   );
 
387
 
 
388
   my $client_response = {
 
389
      headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
 
390
      content => $client_content,
 
391
   };
 
392
   PTDEBUG && _d('Client response:', Dumper($client_response));
 
393
 
 
394
   $response = $ua->request('POST', $url, $client_response);
 
395
   PTDEBUG && _d('Server suggestions:', Dumper($response));
 
396
   die "No response from POST $url $client_response"
 
397
      if !$response;
 
398
   die "POST $url returned HTTP status $response->{status}; expected 200"
 
399
      if $response->{status} != 200;
 
400
 
 
401
   # Response contents is empty if the server doesn't have any suggestions.
 
402
   return unless $response->{content};
 
403
 
 
404
   # If the server has suggestions for items, it sends them back in
 
405
   # the same format: ITEM:TYPE:SUGGESTION\n.  ITEM:TYPE is mostly for
 
406
   # debugging; the tool just repports the suggestions.
 
407
   $items = parse_server_response(
 
408
      response   => $response->{content},
 
409
      split_vars => 0,
 
410
   );
 
411
   die "Failed to parse server suggestions: $response->{content}"
 
412
      if !scalar keys %$items;
 
413
   my @suggestions = map { $_->{vars} }
 
414
                     sort { $a->{item} cmp $b->{item} }
 
415
                     values %$items;
 
416
 
 
417
   return \@suggestions;
 
418
}
 
419
 
 
420
sub encode_client_response {
 
421
   my (%args) = @_;
 
422
   my @required_args = qw(items versions general_id);
 
423
   foreach my $arg ( @required_args ) {
 
424
      die "I need a $arg arugment" unless $args{$arg};
 
425
   }
 
426
   my ($items, $versions, $general_id) = @args{@required_args};
 
427
 
 
428
   # There may not be a version for each item.  For example, the server
 
429
   # may have requested the "MySQL" (version) item, but if the tool
 
430
   # didn't connect to MySQL, there won't be a $versions->{MySQL}.
 
431
   # That's ok; just use what we've got.
 
432
   # NOTE: the sort is only need to make testing deterministic.
 
433
   my @lines;
 
434
   foreach my $item ( sort keys %$items ) {
 
435
      next unless exists $versions->{$item};
 
436
      if ( ref($versions->{$item}) eq 'HASH' ) {
 
437
         my $mysql_versions = $versions->{$item};
 
438
         for my $id ( sort keys %$mysql_versions ) {
 
439
            push @lines, join(';', $id, $item, $mysql_versions->{$id});
 
440
         }
 
441
      }
 
442
      else {
 
443
         push @lines, join(';', $general_id, $item, $versions->{$item});
 
444
      }
 
445
   }
 
446
 
 
447
   my $client_response = join("\n", @lines) . "\n";
 
448
   return $client_response;
 
449
}
 
450
 
 
451
sub parse_server_response {
 
452
   my (%args) = @_;
 
453
   my @required_args = qw(response);
 
454
   foreach my $arg ( @required_args ) {
 
455
      die "I need a $arg arugment" unless $args{$arg};
 
456
   }
 
457
   my ($response) = @args{@required_args};
 
458
 
 
459
   my %items = map {
 
460
      my ($item, $type, $vars) = split(";", $_);
 
461
      if ( !defined $args{split_vars} || $args{split_vars} ) {
 
462
         $vars = [ split(",", ($vars || '')) ];
 
463
      }
 
464
      $item => {
 
465
         item => $item,
 
466
         type => $type,
 
467
         vars => $vars,
 
468
      };
 
469
   } split("\n", $response);
 
470
 
 
471
   PTDEBUG && _d('Items:', Dumper(\%items));
 
472
 
 
473
   return \%items;
 
474
}
 
475
 
 
476
# Safety check: only these types of items are valid/official.
 
477
my %sub_for_type = (
 
478
   os_version          => \&get_os_version,
 
479
   perl_version        => \&get_perl_version,
 
480
   perl_module_version => \&get_perl_module_version,
 
481
   mysql_variable      => \&get_mysql_variable,
 
482
   bin_version         => \&get_bin_version,
 
483
);
 
484
 
 
485
sub valid_item {
 
486
   my ($item) = @_;
 
487
   return unless $item;
 
488
   if ( !exists $sub_for_type{ $item->{type} } ) {
 
489
      PTDEBUG && _d('Invalid type:', $item->{type});
 
490
      return 0;
 
491
   }
 
492
   return 1;
 
493
}
 
494
 
 
495
sub get_versions {
 
496
   my (%args) = @_;
 
497
   my @required_args = qw(items);
 
498
   foreach my $arg ( @required_args ) {
 
499
      die "I need a $arg arugment" unless $args{$arg};
 
500
   }
 
501
   my ($items) = @args{@required_args};
 
502
 
 
503
   my %versions;
 
504
   foreach my $item ( values %$items ) {
 
505
      next unless valid_item($item);
 
506
      eval {
 
507
         my $version = $sub_for_type{ $item->{type} }->(
 
508
            item      => $item,
 
509
            instances => $args{instances},
 
510
         );
 
511
         if ( $version ) {
 
512
            chomp $version unless ref($version);
 
513
            $versions{$item->{item}} = $version;
 
514
         }
 
515
      };
 
516
      if ( $EVAL_ERROR ) {
 
517
         PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
 
518
      }
 
519
   }
 
520
 
 
521
   return \%versions;
 
522
}
 
523
 
 
524
# #############################################################################
 
525
# Version getters
 
526
# #############################################################################
 
527
 
 
528
sub get_os_version {
 
529
   if ( $OSNAME eq 'MSWin32' ) {
 
530
      require Win32;
 
531
      return Win32::GetOSDisplayName();
 
532
   }
 
533
 
 
534
  chomp(my $platform = `uname -s`);
 
535
  PTDEBUG && _d('platform:', $platform);
 
536
  return $OSNAME unless $platform;
 
537
 
 
538
   chomp(my $lsb_release
 
539
            = `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
 
540
   PTDEBUG && _d('lsb_release:', $lsb_release);
 
541
 
 
542
   my $release = "";
 
543
 
 
544
   if ( $platform eq 'Linux' ) {
 
545
      if ( -f "/etc/fedora-release" ) {
 
546
         $release = `cat /etc/fedora-release`;
 
547
      }
 
548
      elsif ( -f "/etc/redhat-release" ) {
 
549
         $release = `cat /etc/redhat-release`;
 
550
      }
 
551
      elsif ( -f "/etc/system-release" ) {
 
552
         $release = `cat /etc/system-release`;
 
553
      }
 
554
      elsif ( $lsb_release ) {
 
555
         $release = `$lsb_release -ds`;
 
556
      }
 
557
      elsif ( -f "/etc/lsb-release" ) {
 
558
         $release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
 
559
         $release =~ s/^\w+="([^"]+)".+/$1/;
 
560
      }
 
561
      elsif ( -f "/etc/debian_version" ) {
 
562
         chomp(my $rel = `cat /etc/debian_version`);
 
563
         $release = "Debian $rel";
 
564
         if ( -f "/etc/apt/sources.list" ) {
 
565
             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}'`);
 
566
             $release .= " ($code_name)" if $code_name;
 
567
         }
 
568
      }
 
569
      elsif ( -f "/etc/os-release" ) { # openSUSE
 
570
         chomp($release = `grep PRETTY_NAME /etc/os-release`);
 
571
         $release =~ s/^PRETTY_NAME="(.+)"$/$1/;
 
572
      }
 
573
      elsif ( `ls /etc/*release 2>/dev/null` ) {
 
574
         if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
 
575
            $release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
 
576
         }
 
577
         else {
 
578
            $release = `cat /etc/*release | head -n1`;
 
579
         }
 
580
      }
 
581
   }
 
582
   elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
 
583
      my $rel = `uname -r`;
 
584
      $release = "$platform $rel";
 
585
   }
 
586
   elsif ( $platform eq "SunOS" ) {
 
587
      my $rel = `head -n1 /etc/release` || `uname -r`;
 
588
      $release = "$platform $rel";
 
589
   }
 
590
 
 
591
   if ( !$release ) {
 
592
      PTDEBUG && _d('Failed to get the release, using platform');
 
593
      $release = $platform;
 
594
   }
 
595
   chomp($release);
 
596
 
 
597
   # For Gentoo, which returns a value in quotes
 
598
   $release =~ s/^"|"$//g;
 
599
 
 
600
   PTDEBUG && _d('OS version =', $release);
 
601
   return $release;
 
602
}
 
603
 
 
604
sub get_perl_version {
 
605
   my (%args) = @_;
 
606
   my $item = $args{item};
 
607
   return unless $item;
 
608
 
 
609
   my $version = sprintf '%vd', $PERL_VERSION;
 
610
   PTDEBUG && _d('Perl version', $version);
 
611
   return $version;
 
612
}
 
613
 
 
614
sub get_perl_module_version {
 
615
   my (%args) = @_;
 
616
   my $item = $args{item};
 
617
   return unless $item;
 
618
 
 
619
   # If there's a var, then its an explicit Perl variable name to get,
 
620
   # else the item name is an implicity Perl module name to which we
 
621
   # append ::VERSION to get the module's version.
 
622
   my $var     = '$' . $item->{item} . '::VERSION';
 
623
   my $version = eval "use $item->{item}; $var;";
 
624
   PTDEBUG && _d('Perl version for', $var, '=', $version);
 
625
   return $version;
 
626
}
 
627
 
 
628
sub get_mysql_variable {
 
629
   return get_from_mysql(
 
630
      show => 'VARIABLES',
 
631
      @_,
 
632
   );
 
633
}
 
634
 
 
635
sub get_from_mysql {
 
636
   my (%args) = @_;
 
637
   my $show      = $args{show};
 
638
   my $item      = $args{item};
 
639
   my $instances = $args{instances};
 
640
   return unless $show && $item;
 
641
 
 
642
   if ( !$instances || !@$instances ) {
 
643
      PTDEBUG && _d('Cannot check', $item,
 
644
         'because there are no MySQL instances');
 
645
      return;
 
646
   }
 
647
 
 
648
   my @versions;
 
649
   my %version_for;
 
650
   foreach my $instance ( @$instances ) {
 
651
      next unless $instance->{id};  # special system instance has id=0
 
652
      my $dbh = $instance->{dbh};
 
653
      local $dbh->{FetchHashKeyName} = 'NAME_lc';
 
654
      my $sql = qq/SHOW $show/;
 
655
      PTDEBUG && _d($sql);
 
656
      my $rows = $dbh->selectall_hashref($sql, 'variable_name');
 
657
 
 
658
      my @versions;
 
659
      foreach my $var ( @{$item->{vars}} ) {
 
660
         $var = lc($var);
 
661
         my $version = $rows->{$var}->{value};
 
662
         PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
 
663
            'on', $instance->{name});
 
664
         push @versions, $version;
 
665
      }
 
666
      $version_for{ $instance->{id} } = join(' ', @versions);
 
667
   }
 
668
 
 
669
   return \%version_for;
 
670
}
 
671
 
 
672
sub get_bin_version {
 
673
   my (%args) = @_;
 
674
   my $item = $args{item};
 
675
   my $cmd  = $item->{item};
 
676
   return unless $cmd;
 
677
 
 
678
   my $sanitized_command = File::Basename::basename($cmd);
 
679
   PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
 
680
   return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
 
681
 
 
682
   my $output = `$sanitized_command --version 2>&1`;
 
683
   PTDEBUG && _d('output:', $output);
 
684
 
 
685
   my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
 
686
 
 
687
   PTDEBUG && _d('Version for', $sanitized_command, '=', $version);
 
688
   return $version;
 
689
}
 
690
 
 
691
sub _d {
 
692
   my ($package, undef, $line) = caller 0;
 
693
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
 
694
        map { defined $_ ? $_ : 'undef' }
 
695
        @_;
 
696
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
 
697
}
 
698
 
 
699
1;
 
700
}
 
701
# ###########################################################################
 
702
# End VersionCheck package
 
703
# ###########################################################################