lib/Machines.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: Machines.pm,v $
   4
   5 Abstraction of machines.
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@ClearSCM.com>
  14
  15 =item Revision
  16
  17 $Revision: 1.4 $
  18
  19 =item Created
  20
  21 Tue Jan  8 17:24:16 MST 2008
  22
  23 =item Modified
  24
  25 $Date: 2011/11/16 19:46:13 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 This module handles the details of providing information about
  32 machines while obscuring the mechanism for storing such information.
  33
  34  my $machines = Machines->new;
  35
  36  foreach ($machine->all) {
  37    my %machine = %{$_};
  38    display "Machine: $machine{name}";
  39    disp.ay "Owner: $machine{owner}"
  40  } # if
  41
  42 =head1 DESCRIPTION
  43
  44 This module provides information about machines
  45
  46 =head1 ROUTINES
  47
  48 The following routines are exported:
  49
  50 =cut
  51
  52 package Machines;
  53
  54 use strict;
  55 use warnings;
  56
  57 use Carp;
  58 use DBI;
  59 use FindBin;
  60
  61 use DateUtils;
  62 use Display;
  63 use GetConfig;
  64
  65 our %MACHINESOPTS = GetConfig ("$FindBin::Bin/../etc/machines.conf");
  66
  67 my $defaultFilesystemThreshold = 90;
  68 my $defaultFilesystemHist      = '6 months';
  69 my $defaultLoadavgHist         = '6 months';
  70
  71 # Internal methods
  72 sub _dberror ($$) {
  73   my ($self, $msg, $statement) = @_;
  74
  75   my $dberr    = $self->{db}->err;
  76   my $dberrmsg = $self->{db}->errstr;
  77
  78   $dberr    ||= 0;
  79   $dberrmsg ||= 'Success';
  80
  81   my $message = '';
  82
  83   if ($dberr) {
  84     my $function = (caller (1)) [3];
  85
  86     $message = "$function: $msg\nError #$dberr: $dberrmsg\n"
  87              . "SQL Statement: $statement";
  88   } # if
  89
  90   return $dberr, $message;
  91 } # _dberror
  92
  93 sub _formatValues (@) {
  94   my ($self, @values) = @_;
  95
  96   my @returnValues;
  97
  98   # Quote data values
  99   push @returnValues, $_ eq '' ? 'null' : $self->{db}->quote ($_)
 100     foreach (@values);
 101
 102   return @returnValues;
 103 } # _formatValues
 104
 105 sub _formatNameValues (%) {
 106   my ($self, %rec) = @_;
 107
 108   my @nameValueStrs;
 109
 110   push @nameValueStrs, "$_=" . $self->{db}->quote ($rec{$_})
 111     foreach (keys %rec);
 112
 113   return @nameValueStrs;
 114 } # _formatNameValues
 115
 116 sub _error () {\r
 117   my ($self) = @_;
 118
 119   if ($self->{msg}) {
 120     if ($self->{errno}) {
 121       carp $self->{msg};
 122     } else {
 123       cluck $self->{msg};
 124     } # if
 125   } # if\r
 126 } # _error
 127
 128 sub _addRecord ($%) {
 129   my ($self, $table, %rec) = @_;
 130
 131   my $statement  = "insert into $table (";
 132      $statement .= join ',', keys %rec;
 133      $statement .= ') values (';
 134      $statement .= join ',', $self->_formatValues (values %rec);
 135      $statement .= ')';
 136
 137   my ($err, $msg);
 138
 139   $self->{db}->do ($statement);
 140
 141   return $self->_dberror ("Unable to add record to $table", $statement);
 142 } # _addRecord
 143
 144 sub _checkRequiredFields ($$) {
 145   my ($fields, $rec) = @_;
 146
 147   foreach my $fieldname (@$fields) {
 148     my $found = 0;
 149
 150     foreach (keys %$rec) {
 151       if ($fieldname eq $_) {
 152          $found = 1;
 153          last;
 154       } # if
 155     } # foreach
 156
 157     return "$fieldname is required"
 158       unless $found;
 159   } # foreach
 160
 161   return;
 162 } # _checkRequiredFields
 163
 164 sub _connect (;$) {
 165   my ($self, $dbserver) = @_;
 166
 167   $dbserver ||= $MACHINESOPTS{MACHINES_SERVER};
 168
 169   my $dbname   = 'machines';
 170   my $dbdriver = 'mysql';
 171
 172   $self->{db} = DBI->connect (
 173     "DBI:$dbdriver:$dbname:$dbserver",
 174     $MACHINESOPTS{MACHINES_USERNAME},
 175     $MACHINESOPTS{MACHINES_PASSWORD},
 176     {PrintError => 0},
 177   ) or croak (
 178     "Couldn't connect to $dbname database "
 179   . "as $MACHINESOPTS{MACHINESADM_USERNAME}\@$MACHINESOPTS{MACHINESADM_SERVER}"
 180   );
 181
 182   $self->{dbserver} = $dbserver;
 183
 184   return;
 185 } # _connect
 186
 187 sub _getRecords ($$) {
 188   my ($self, $table, $condition) = @_;
 189
 190   my ($err, $msg);
 191
 192   my $statement = "select * from $table where $condition";
 193
 194   my $sth = $self->{db}->prepare ($statement);
 195
 196   unless ($sth) {
 197     ($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
 198
 199     croak $msg;
 200   } # if
 201
 202   my $attempts    = 0;
 203   my $maxAttempts = 3;
 204   my $sleepTime   = 30;
 205   my $status;
 206
 207   # We've been having the server going away. Supposedly it should reconnect so
 208   # here we simply retry up to $maxAttempts times to re-execute the statement.
 209   # (Are there other places where we need to do this?)
 210   $err = 2006;
 211
 212   while ($err == 2006 and $attempts++ < $maxAttempts) {
 213     $status = $sth->execute;
 214
 215     if ($status) {
 216       $err = 0;
 217       last;
 218     } else {
 219       ($err, $msg) = $self->_dberror ('Unable to execute statement',
 220                                       $statement);
 221     } # if
 222
 223     last if $err == 0;
 224
 225     croak $msg unless $err == 2006;
 226
 227     my $timestamp = YMDHMS;
 228
 229     $self->Error ("$timestamp: Unable to talk to DB server.\n\n$msg\n\n"
 230                 . "Will try again in $sleepTime seconds", -1);
 231
 232     # Try to reconnect
 233     $self->_connect ($self->{dbserver});
 234
 235     sleep $sleepTime;
 236   } # while
 237
 238   $self->Error ("After $maxAttempts attempts I could not connect to the database", $err)
 239     if ($err == 2006 and $attempts > $maxAttempts);
 240
 241   my @records;
 242
 243   while (my $row = $sth->fetchrow_hashref) {
 244     push @records, $row;
 245   } # while
 246
 247   return @records;
 248 } # _getRecord
 249
 250
 251 sub new {
 252   my ($class, %parms) = @_;
 253
 254 =pod
 255
 256 =head2 new ($server)
 257
 258 Construct a new Machines object.
 259
 260 =cut
 261
 262   # Merge %parms with %MACHINEOPTS
 263   foreach (keys %parms) {
 264     $MACHINESOPTS{$_} = $parms{$_};
 265   } # foreach;
 266
 267   my $self = bless {}, $class;
 268
 269   $self->_connect ();
 270
 271   return $self;
 272 } # new
 273
 274 sub add (%) {
 275   my ($self, %system) = @_;
 276
 277   my @requiredFields = qw(
 278     name
 279     admin
 280     type
 281   );
 282
 283   my $result = _checkRequiredFields \@requiredFields, \%system;
 284
 285   return -1, "add: $result" if $result;
 286
 287   $system{loadavgHist} ||= $defaultLoadavgHist;
 288
 289   return $self->_addRecord ('system', %system);
 290 } # add
 291
 292 sub delete ($) {
 293   my ($self, $name) = @_;
 294
 295   return $self->_deleteRecord ('system', "name='$name'");
 296 } # delete
 297
 298 sub update ($%) {
 299   my ($self, $name, %update) = @_;
 300
 301   return $self->_updateRecord ('system', "name='$name'", %update);
 302 } # update
 303
 304 sub get ($) {
 305   my ($self, $system) = @_;
 306
 307   return unless $system;
 308
 309   my @records = $self->_getRecords (
 310     'system',
 311     "name='$system' or alias like '%$system%'"
 312   );
 313
 314   if ($records[0]) {
 315     return %{$records[0]};
 316   } else {
 317         return;
 318   } # if
 319 } # get
 320
 321 sub find (;$) {
 322   my ($self, $condition) = @_;
 323
 324   return $self->_getRecords ('system', $condition);
 325 } # find
 326
 327 1;
 328
 329 =pod
 330
 331 =head1 CONFIGURATION AND ENVIRONMENT
 332
 333 MACHINES: If set then points to a flat file containing machine
 334 names. Note this is providied as a way to quickly use an alternate
 335 "machine database". As such only minimal information is support.
 336
 337 =head1 DEPENDENCIES
 338
 339  Display
 340  Rexec
 341
 342 =head1 INCOMPATABILITIES
 343
 344 None yet...
 345
 346 =head1 BUGS AND LIMITATIONS
 347
 348 There are no known bugs in this module.
 349
 350 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
 351
 352 =head1 LICENSE AND COPYRIGHT
 353
 354 This Perl Module is freely available; you can redistribute it and/or
 355 modify it under the terms of the GNU General Public License as
 356 published by the Free Software Foundation; either version 2 of the
 357 License, or (at your option) any later version.
 358
 359 This Perl Module is distributed in the hope that it will be useful,
 360 but WITHOUT ANY WARRANTY; without even the implied warranty of
 361 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 362 General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
 363 details.
 364
 365 You should have received a copy of the GNU General Public License
 366 along with this Perl Module; if not, write to the Free Software Foundation,
 367 Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 368 reserved.
 369
 370 =cut