# Create new Clearadm object
my $clearadm = new Clearadm;
-
+
# Add a new system
my %system = (
name => 'jupiter',
type => 'Linux',
description => 'Home server',
);
-
+
my ($err, $msg) = $clearadm->AddSystem (%system);
-
+
# Find systems matching 'jup'
my @systems = $clearadm->FindSystem ('jup');
-
+
# Get a system by name
my %system = $clearadm->GetSystem ('jupiter');
-
+
# Update system
my %update = (
'region' => 'East Coast',
);
my ($err, $msg) = $clearadm->UpdateSystem ('jupiter', %update);
-
+
# Delete system (Warning: will delete all related records regarding this
# system).
my ($err, $msg) = $clearadm->DeleteSystem ('jupiter');
=head1 DESCRIPTION
This package provides and object oriented interface to the Clearadm database.
-Methods are provided to manipulate records by adding, updating and deleting
-them. In general you need to specify a hash which contains keys and values
+Methods are provided to manipulate records by adding, updating and deleting
+them. In general you need to specify a hash which contains keys and values
corresponding to the database field names and values.
=head1 ROUTINES
# Globals
our $VERSION = '$Revision: 1.54 $';
($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
-
-$CLEAROPTS{CLEARADM_USERNAME} = $ENV{CLEARADM_USERNAME}
+
+$CLEAROPTS{CLEARADM_USERNAME} = $ENV{CLEARADM_USERNAME}
? $ENV{CLEARADM_USERNAME}
: $CLEAROPTS{CLEARADM_USERNAME}
? $CLEAROPTS{CLEARADM_USERNAME}
: 'clearwriter';
-$CLEAROPTS{CLEARADM_PASSWORD} = $ENV{CLEARADM_PASSWORD}
+$CLEAROPTS{CLEARADM_PASSWORD} = $ENV{CLEARADM_PASSWORD}
? $ENV{CLEARADM_PASSWORD}
: $CLEAROPTS{CLEARADM_PASSWORD}
? $CLEAROPTS{CLEARADM_PASSWORD}
: 'clearwriter';
-$CLEAROPTS{CLEARADM_SERVER} = $ENV{CLEARADM_SERVER}
- ? $ENV{CLEARADM_SERVER}
+$CLEAROPTS{CLEARADM_SERVER} = $ENV{CLEARADM_SERVER}
+ ? $ENV{CLEARADM_SERVER}
: $CLEAROPTS{CLEARADM_SERVER}
? $CLEAROPTS{CLEARADM_SERVER}
: 'localhost';
my $dberr = $self->{db}->err;
my $dberrmsg = $self->{db}->errstr;
-
+
$dberr ||= 0;
$dberrmsg ||= 'Success';
my $message = '';
-
+
if ($dberr) {
my $function = (caller (1)) [3];
. "SQL Statement: $statement";
} # if
- return $dberr, $message;
+ return $dberr, $message;
} # _dberror
sub _formatValues (@) {
my ($self, @values) = @_;
-
+
my @returnValues;
-
+
# Quote data values
- push @returnValues, $_ eq '' ? 'null' : $self->{db}->quote ($_)
- foreach (@values);
-
+ push @returnValues, $_ eq '' ? 'null' : $self->{db}->quote ($_)
+ for (@values);
+
return @returnValues;
} # _formatValues
sub _formatNameValues (%) {
my ($self, %rec) = @_;
-
+
my @nameValueStrs;
-
+
push @nameValueStrs, "$_=" . $self->{db}->quote ($rec{$_})
- foreach (keys %rec);
-
+ for (keys %rec);
+
return @nameValueStrs;
} # _formatNameValues
sub _addRecord ($%) {
my ($self, $table, %rec) = @_;
-
+
my $statement = "insert into $table (";
$statement .= join ',', keys %rec;
$statement .= ') values (';
$statement .= join ',', $self->_formatValues (values %rec);
$statement .= ')';
-
+
my ($err, $msg);
-
+
$self->{db}->do ($statement);
-
+
return $self->_dberror ("Unable to add record to $table", $statement);
} # _addRecord
sub _deleteRecord ($;$) {
my ($self, $table, $condition) = @_;
-
+
my $count;
-
+
my $statement = "select count(*) from $table ";
$statement .= "where $condition"
if $condition;
-
+
my $sth = $self->{db}->prepare ($statement)
or return $self->_dberror ('Unable to prepare statement', $statement);
-
+
$sth->execute
or return $self->_dberror ('Unable to execute statement', $statement);
-
+
my @row = $sth->fetchrow_array;
-
+
$sth->finish;
-
+
if ($row[0]) {
$count = $row[0];
} else {
$count = 0;
} # if
-
+
return ($count, 'Records deleted')
if $count == 0;
-
+
$statement = "delete from $table ";
$statement .= "where $condition"
if $condition;
-
+
$self->{db}->do ($statement);
-
+
if ($self->{db}->err) {
return $self->_dberror ("Unable to delete record from $table", $statement);
} else {
$statement .= join ',', $self->_formatNameValues (%rec);
$statement .= " where $condition"
if $condition;
-
+
$self->{db}->do ($statement);
-
+
return $self->_dberror ("Unable to update record in $table", $statement);
} # _updateRecord
sub _checkRequiredFields ($$) {
my ($fields, $rec) = @_;
-
- foreach my $fieldname (@$fields) {
+
+ for my $fieldname (@$fields) {
my $found = 0;
-
- foreach (keys %$rec) {
+
+ for (keys %$rec) {
if ($fieldname eq $_) {
$found = 1;
last;
} # if
- } # foreach
-
+ } # for
+
return "$fieldname is required"
unless $found;
- } # foreach
-
+ } # for
+
return;
} # _checkRequiredFields
sub _getRecords ($$) {
my ($self, $table, $condition) = @_;
-
+
my ($err, $msg);
-
+
my $statement = "select * from $table where $condition";
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
my $maxAttempts = 3;
my $sleepTime = 30;
my $status;
-
+
# We've been having the server going away. Supposedly it should reconnect so
- # here we simply retry up to $maxAttempts times to re-execute the statement.
+ # here we simply retry up to $maxAttempts times to re-execute the statement.
# (Are there other places where we need to do this?)
$err = 2006;
-
+
while ($err == 2006 and $attempts++ < $maxAttempts) {
$status = $sth->execute;
-
+
if ($status) {
$err = 0;
last;
($err, $msg) = $self->_dberror ('Unable to execute statement',
$statement);
} # if
-
+
last if $err == 0;
-
+
croak $msg unless $err == 2006;
my $timestamp = YMDHMS;
-
+
$self->Error ("$timestamp: Unable to talk to DB server.\n\n$msg\n\n"
. "Will try again in $sleepTime seconds", -1);
-
+
# Try to reconnect
$self->_connect ($self->{dbserver});
$self->Error ("After $maxAttempts attempts I could not connect to the database", $err)
if ($err == 2006 and $attempts > $maxAttempts);
-
+
my @records;
-
+
while (my $row = $sth->fetchrow_hashref) {
push @records, $row;
} # while
-
+
return @records;
} # _getRecord
sub _aliasSystem ($) {
my ($self, $system) = @_;
-
+
my %system = $self->GetSystem ($system);
-
+
if ($system{name}) {
return $system{name};
} else {
sub _getLastID () {
my ($self) = @_;
-
+
my $statement = 'select last_insert_id()';
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
my ($err, $msg);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
-
+
my $status = $sth->execute;
-
+
unless ($status) {
($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
-
+
croak $msg;
} # if
-
+
my @records;
my @row = $sth->fetchrow_array;
-
+
return $row[0];
} # _getLastID
sub _connect (;$) {
my ($self, $dbserver) = @_;
-
+
$dbserver ||= $CLEAROPTS{CLEARADM_SERVER};
-
+
my $dbname = 'clearadm';
my $dbdriver = 'mysql';
$self->{db} = DBI->connect (
- "DBI:$dbdriver:$dbname:$dbserver",
+ "DBI:$dbdriver:$dbname:$dbserver",
$CLEAROPTS{CLEARADM_USERNAME},
$CLEAROPTS{CLEARADM_PASSWORD},
{PrintError => 0},
) or croak (
- "Couldn't connect to $dbname database "
+ "Couldn't connect to $dbname database "
. "as $CLEAROPTS{CLEARADM_USERNAME}\@$CLEAROPTS{CLEARADM_SERVER}"
);
-
+
$self->{dbserver} = $dbserver;
-
+
return;
} # _connect
sub SetNotify () {
my ($self) = @_;
-
+
$self->{NOTIFY} = $CLEAROPTS{CLEARADM_NOTIFY};
-
+
return;
} # SetNotify
my ($self, $msg, $errno) = @_;
# If $errno is specified we need to stop. However we need to notify somebody
- # that cleartasks is no longer running.
+ # that cleartasks is no longer running.
error $msg;
-
+
if ($errno) {
if ($self->{NOTIFY}) {
mail (
data => "<p>An unexpected, internal error occurred in Clearadm:</p><p>$msg</p>",
mode => 'html',
);
-
+
exit $errno if $errno > 0;
} # if
} # if
-
+
return;
} # Error
sub AddSystem (%) {
my ($self, %system) = @_;
-
+
my @requiredFields = (
'name',
);
my $result = _checkRequiredFields \@requiredFields, \%system;
-
+
return -1, "AddSystem: $result"
if $result;
-
+
$system{loadavgHist} ||= $defaultLoadavgHist;
-
+
return $self->_addRecord ('system', %system);
} # AddSystem
sub DeleteSystem ($) {
my ($self, $name) = @_;
- return $self->_deleteRecord ('system', "name='$name'");
+ return $self->_deleteRecord ('system', "name='$name'");
} # DeleteSystem
sub UpdateSystem ($%) {
sub GetSystem ($) {
my ($self, $system) = @_;
-
+
return
unless $system;
-
+
my @records = $self->_getRecords (
- 'system',
+ 'system',
"name='$system' or alias like '%$system%'"
);
-
+
if ($records[0]) {
return %{$records[0]};
} else {
my ($self, $system) = @_;
$system ||= '';
-
+
my $condition = "name like '%$system%' or alias like '%$system%'";
-
+
return $self->_getRecords ('system', $condition);
} # FindSystem
sub SearchSystem (;$) {\r
my ($self, $condition) = @_;
-
+
$condition = "name like '%'" unless $condition;
-
- return $self->_getRecords ('system', $condition); \r
+
+ return $self->_getRecords ('system', $condition);\r
} # SearchSystem
sub AddPackage (%) {
my ($self, %package) = @_;
-
+
my @requiredFields = (
'system',
'name',
);
my $result = _checkRequiredFields \@requiredFields, \%package;
-
+
return -1, "AddPackage: $result"
if $result;
-
+
return $self->_addRecord ('package', %package);
} # AddPackage
sub DeletePackage ($$) {
my ($self, $system, $name) = @_;
-
+
return $self->_deleteRecord (
- 'package',
+ 'package',
"(system='$system' or alias='$system') and name='$name'");
} # DeletePackage
sub UpdatePackage ($$%) {
my ($self, $system, $name, %update) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return $self->_updateRecord ('package', "system='$system'", %update);
} # UpdatePackage
sub GetPackage($$) {
my ($self, $system, $name) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return
unless $name;
-
+
my @records = $self->_getRecords (
- 'package',
+ 'package',
"system='$system' and name='$name'"
);
-
+
if ($records[0]) {
return %{$records[0]};
} else {
$name ||= '';
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
my $condition = "system='$system' and name like '%$name%'";
-
+
return $self->_getRecords ('package', $condition);
} # FindPackage
sub AddFilesystem (%) {
my ($self, %filesystem) = @_;
-
+
my @requiredFields = (
'system',
'filesystem',
);
my $result = _checkRequiredFields \@requiredFields, \%filesystem;
-
+
return -1, "AddFilesystem: $result"
if $result;
-
+
# Default filesystem threshold
$filesystem{threshold} ||= $defaultFilesystemThreshold;
-
+
return $self->_addRecord ('filesystem', %filesystem);
} # AddFilesystem
sub DeleteFilesystem ($$) {
my ($self, $system, $filesystem) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return $self->_deleteRecord (
- 'filesystem',
+ 'filesystem',
"system='$system' and filesystem='$filesystem'"
);
} # DeleteFilesystem
sub UpdateFilesystem ($$%) {
my ($self, $system, $filesystem, %update) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return $self->_updateRecord (
'filesystem',
"system='$system' and filesystem='$filesystem'",
sub GetFilesystem ($$) {
my ($self, $system, $filesystem) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return
unless $filesystem;
-
+
my @records = $self->_getRecords (
- 'filesystem',
+ 'filesystem',
"system='$system' and filesystem='$filesystem'"
);
-
+
if ($records[0]) {
return %{$records[0]};
} else {
sub FindFilesystem ($;$) {
my ($self, $system, $filesystem) = @_;
-
+
$filesystem ||= '';
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
- my $condition = "system='$system' and filesystem like '%$filesystem%'";
-
+ my $condition = "system='$system' and filesystem like '%$filesystem%'";
+
return $self->_getRecords ('filesystem', $condition);
} # FindFilesystem
sub AddVob (%) {
my ($self, %vob) = @_;
-
+
my @requiredFields = (
'system',
'tag',
);
my $result = _checkRequiredFields \@requiredFields, \%vob;
-
+
return -1, "AddVob: $result"
if $result;
-
+
return $self->_addRecord ('vob', %vob);
} # AddVob
sub DeleteVob ($) {
my ($self, $tag) = @_;
-
+
return $self->_deleteRecord ('vob', "tag='$tag'");
} # DeleteVob
sub GetVob ($) {
my ($self, $tag) = @_;
-
- return
+
+ return
unless $tag;
-
+
my @records = $self->_getRecords ('vob', "tag='$tag'");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
sub FindVob ($) {
my ($self, $tag) = @_;
-
+
return $self->_getRecords ('vob', "tag like '%$tag%'");
} # FindVob
sub AddView (%) {
my ($self, %view) = @_;
-
+
my @requiredFields = (
'system',
'tag',
);
my $result = _checkRequiredFields \@requiredFields, \%view;
-
+
return -1, "AddView: $result"
if $result;
-
+
return $self->_addRecord ('view', %view);
} # AddView
sub DeleteView ($) {
my ($self, $tag) = @_;
-
+
return $self->_deleteRecord ('vob', "tag='$tag'");
} # DeleteView
sub GetView ($) {
my ($self, $tag) = @_;
-
+
return
unless $tag;
-
+
my @records = $self->_getRecords ('view', "tag='$tag'");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
$region ||= '';
$tag ||= '';
$ownerName ||= '';
-
+
my $condition;
-
+
$condition = "system like '%$system%'";
$condition .= ' and ';
$condition = "region like '%$region%'";
$condition .= "tag like '%$tag'";
$condition .= ' and ';
$condition .= "ownerName like '%$ownerName'";
-
+
return $self->_getRecords ('view', $condition);
} # FindView
sub AddFS (%) {
my ($self, %fs) = @_;
-
+
my @requiredFields = (
'system',
'filesystem',
);
my $result = _checkRequiredFields \@requiredFields, \%fs;
-
+
return -1, "AddFS: $result"
if $result;
-
+
# Timestamp record
$fs{timestamp} = Today2SQLDatetime;
-
+
return $self->_addRecord ('fs', %fs);
} # AddFS
sub TrimFS ($$) {
my ($self, $system, $filesystem) = @_;
-
+
my %filesystem = $self->GetFilesystem ($system, $filesystem);
-
+
return
unless %filesystem;
-
+
my %task = $self->GetTask ('scrub');
-
+
$self->Error ("Unable to find scrub task!", 1) unless %task;
-
+
my $days;
my $today = Today2SQLDatetime;
-
+
# TODO: SubtractDays uses just an approximation (i.e. subtracting 30 days when
# in February is not right.
if ($filesystem{filesystemHist} =~ /(\d+) month/i) {
} # if
my $oldage = SubtractDays $today, $days;
-
+
my ($dberr, $dbmsg) = $self->_deleteRecord (
'fs',
"system='$system' and filesystem='$filesystem' and timestamp<='$oldage'"
);
-
+
if ($dbmsg eq 'Records deleted') {
return (0, $dbmsg)
if $dberr == 0;
-
+
my %runlog;
-
+
$runlog{task} = $task{name};
$runlog{started} = $today;
$runlog{status} = 0;
- $runlog{message} =
+ $runlog{message} =
"Scrubbed $dberr fs records for filesystem $system:$filesystem";
-
+
my ($err, $msg) = $self->AddRunlog (%runlog);
-
+
$self->Error ("Unable to add runlog - (Error: $err)\n$msg") if $err;
} # if
-
+
return ($dberr, $dbmsg);
} # TrimFS
sub TrimLoadavg ($) {
my ($self, $system) = @_;
-
+
my %system = $self->GetSystem ($system);
-
+
return
unless %system;
-
+
my %task = $self->GetTask ('loadavg');
-
+
$self->Error ("Unable to find loadavg task!", 1) unless %task;
-
+
my $days;
my $today = Today2SQLDatetime;
} # if
my $oldage = SubtractDays $today, $days;
-
+
my ($dberr, $dbmsg) = $self->_deleteRecord (
'loadavg',
"system='$system' and timestamp<='$oldage'"
);
-
+
if ($dbmsg eq 'Records deleted') {
return (0, $dbmsg)
if $dberr == 0;
-
+
my %runlog;
-
+
$runlog{task} = $task{name};
$runlog{started} = $today;
$runlog{status} = 0;
- $runlog{message} =
+ $runlog{message} =
"Scrubbed $dberr loadavg records for system $system";
my ($err, $msg) = $self->AddRunlog (%runlog);
-
+
$self->Error ("Unable to add runload (Error: $err)\n$msg") if $err;
} # if
sub GetFS ($$;$$$$) {
my ($self, $system, $filesystem, $start, $end, $count, $interval) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return
unless $filesystem;
-
+
$interval ||= 'Minute';
-
+
my $size = $interval =~ /month/i
? 7
: $interval =~ /day/i
: $interval =~ /hour/i
? 13
: 16;
-
+
undef $start if $start and $start =~ /earliest/i;
undef $end if $end and $end =~ /latest/i;
-
+
my $condition = "system='$system' and filesystem='$filesystem'";
$condition .= " and timestamp>='$start'" if $start;
$condition .= " and timestamp<='$end'" if $end;
-
+
$condition .= " group by left(timestamp,$size)";
-
+
if ($count) {
# We can't simply do a "limit 0, $count" as that just gets the front end of
# the records return (i.e. if $count = say 10 and the timestamp range
# $count
my $nbrRecs = $self->Count ('fs', $condition);
my $offset = $nbrRecs - $count;
-
+
# Offsets of < 0 are not allowed.
$offset = 0
if $offset < 0;
$condition .= " limit $offset, $count";
} # if
-
+
my $statement = <<"END";
select
system,
END
my ($err, $msg);
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
-
+
my $status = $sth->execute;
-
+
unless ($status) {
($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
-
+
croak $msg;
} # if
-
+
my @records;
-
+
while (my $row = $sth->fetchrow_hashref) {
push @records, $row;
} # while
-
+
return @records;
} # GetFS
sub GetLatestFS ($$) {
my ($self, $system, $filesystem) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
return
unless $filesystem;
-
+
my @records = $self->_getRecords (
'fs',
"system='$system' and filesystem='$filesystem'"
. " order by timestamp desc limit 0, 1",
);
-
+
if ($records[0]) {
return %{$records[0]};
} else {
sub AddLoadavg () {
my ($self, %loadavg) = @_;
-
+
my @requiredFields = (
'system',
);
my $result = _checkRequiredFields \@requiredFields, \%loadavg;
-
+
return -1, "AddLoadavg: $result"
if $result;
-
+
# Timestamp record
$loadavg{timestamp} = Today2SQLDatetime;
-
+
return $self->_addRecord ('loadavg', %loadavg);
} # AddLoadavg
sub GetLoadavg ($;$$$$) {
my ($self, $system, $start, $end, $count, $interval) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
$interval ||= 'Minute';
-
+
my $size = $interval =~ /month/i
? 7
: $interval =~ /day/i
: $interval =~ /hour/i
? 13
: 16;
-
+
my $condition;
-
+
undef $start if $start and $start =~ /earliest/i;
undef $end if $end and $end =~ /latest/i;
-
+
$condition .= " system='$system'" if $system;
$condition .= " and timestamp>='$start'" if $start;
$condition .= " and timestamp<='$end'" if $end;
-
+
$condition .= " group by left(timestamp,$size)";
if ($count) {
# $count
my $nbrRecs = $self->Count ('loadavg', $condition);
my $offset = $nbrRecs - $count;
-
+
# Offsets of < 0 are not allowed.
$offset = 0
if $offset < 0;
$condition .= " limit $offset, $count";
} # if
-
+
my $statement = <<"END";
select
system,
END
my ($err, $msg);
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
-
+
my $status = $sth->execute;
-
+
unless ($status) {
($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
-
+
croak $msg;
} # if
-
+
my @records;
-
+
while (my $row = $sth->fetchrow_hashref) {
push @records, $row;
} # while
-
+
return @records;
} # GetLoadvg
sub GetLatestLoadavg ($) {
my ($self, $system) = @_;
-
+
$system = $self->_aliasSystem ($system);
-
+
return
unless $system;
-
+
my @records = $self->_getRecords (
'loadavg',
"system='$system'"
. " order by timestamp desc limit 0, 1",
);
-
+
if ($records[0]) {
return %{$records[0]};
} else {
sub AddTask (%) {
my ($self, %task) = @_;
-
+
my @requiredFields = (
'name',
'command'
);
-
+
my $result = _checkRequiredFields \@requiredFields, \%task;
-
+
return -1, "AddTask: $result"
if $result;
-
- return $self->_addRecord ('task', %task);
+
+ return $self->_addRecord ('task', %task);
} # AddTask
sub DeleteTask ($) {
my ($self, $name) = @_;
-
+
return $self->_deleteRecord ('task', "name='$name'");
} # DeleteTask
sub FindTask ($) {
my ($self, $name) = @_;
-
+
$name ||= '';
-
+
my $condition = "name like '%$name%'";
-
+
return $self->_getRecords ('task', $condition);
} # FindTask
sub GetTask ($) {
my ($self, $name) = @_;
-
+
return
unless $name;
-
+
my @records = $self->_getRecords ('task', "name='$name'");
if ($records[0]) {
return %{$records[0]};
} else {
return;
- } # if
+ } # if
} # GetTask
sub UpdateTask ($%) {
my ($self, $name, %update) = @_;
-
+
return $self->_updateRecord ('task', "name='$name'", %update);
} # Update
sub AddSchedule (%) {
my ($self, %schedule) = @_;
-
+
my @requiredFields = (
'task',
);
-
+
my $result = _checkRequiredFields \@requiredFields, \%schedule;
-
+
return -1, "AddSchedule: $result"
if $result;
-
- return $self->_addRecord ('schedule', %schedule);
+
+ return $self->_addRecord ('schedule', %schedule);
} # AddSchedule
sub DeleteSchedule ($) {
my ($self, $name) = @_;
-
+
return $self->_deleteRecord ('schedule', "name='$name'");
} # DeleteSchedule
sub FindSchedule (;$$) {
my ($self, $name, $task) = @_;
-
+
$name ||= '';
$task||= '';
-
+
my $condition = "name like '%$name%'";
$condition .= ' and ';
$condition .= "task like '%$task%'";
- return $self->_getRecords ('schedule', $condition);
+ return $self->_getRecords ('schedule', $condition);
} # FindSchedule
sub GetSchedule ($) {
my ($self, $name) = @_;
-
+
my @records = $self->_getRecords ('schedule', "name='$name'");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
return;
- } # if
+ } # if
} # GetSchedule
sub UpdateSchedule ($%) {
my ($self, $name, %update) = @_;
-
+
return $self->_updateRecord ('schedule', "name='$name'", %update);
} # UpdateSchedule
sub AddRunlog (%) {
my ($self, %runlog) = @_;
-
+
my @requiredFields = (
'task',
);
-
+
my $result = _checkRequiredFields \@requiredFields, \%runlog;
-
+
return -1, "AddRunlog: $result"
if $result;
-
+
$runlog{ended} = Today2SQLDatetime;
-
+
my ($err, $msg) = $self->_addRecord ('runlog', %runlog);
return ($err, $msg, $self->_getLastID);
sub DeleteRunlog ($) {
my ($self, $condition) = @_;
-
+
return $self->_deleteRecord ('runlog', $condition);
} # DeleteRunlog
sub FindRunlog (;$$$$$$) {
my ($self, $task, $system, $status, $id, $start, $page) = @_;
-
+
$task ||= '';
-
+
# If ID is specified then that's all that really matters as it uniquely
# identifies a runlog entry;
my $condition;
-
+
unless ($id) {
$condition = "task like '%$task%'";
-
+
if ($system) {
$condition .= " and system like '%$system%'"
unless $system eq 'All';
} else {
$condition .= ' and system is null';
} # unless
-
+
if (defined $status) {
if ($status =~ /!(-*\d+)/) {
$condition .= " and status<>$1";
$condition .= " and status=$status"
} # if
} # if
-
- $condition .= " order by started desc";
-
+
+ $condition .= " order by started desc";
+
if (defined $start) {
$page ||= 10;
$condition .= " limit $start, $page";
} else {
$condition = "id=$id";
} # unless
-
+
return $self->_getRecords ('runlog', $condition);
} # FindRunlog
sub GetRunlog ($) {
my ($self, $id) = @_;
-
+
return
unless $id;
-
+
my @records = $self->_getRecords ('runlog', "id=$id");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
return;
- } # if
+ } # if
} # GetRunlog
sub UpdateRunlog ($%) {
my ($self, $id, %update) = @_;
-
+
return $self->_updateRecord ('runlog', "id=$id", %update);
} # UpdateRunlog
sub Count ($;$) {
my ($self, $table, $condition) = @_;
-
+
$condition = $condition ? 'where ' . $condition : '';
-
+
my ($err, $msg);
-
+
my $statement = "select count(*) from $table $condition";
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
-
+
my $status = $sth->execute;
-
+
unless ($status) {
($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
-
+
croak $msg;
} # if
-
+
# Hack! Statements such as the following:
#
# select count(*) from fs where system='jupiter' and filesystem='/dev/sdb5'
- # > group by left(timestamp,10);
+ # > group by left(timestamp,10);
# +----------+
# | count(*) |
# +----------+
# | 190 |
# +----------+
# 7 rows in set (0.00 sec)
- #
+ #
# Here we want 7 but what we see in $records[0] is 49. So the hack is that if
# statement contains "group by" then we assume we have the above and return
# scalar @records, otherwise we return $records[0];
# us again.
sub GetWork () {
my ($self) = @_;
-
+
my ($err, $msg);
-
+
my $statement = <<"END";
select
schedule.name as schedulename,
and schedule.active='true'
order by lastrun
END
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
-
+
my $status = $sth->execute;
-
+
unless ($status) {
($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
-
+
croak $msg;
} # if
-
- my $sleep;
+
+ my $sleep;
my @records;
-
+
while (my $row = $sth->fetchrow_hashref) {
if ($$row{system} !~ /localhost/i) {
my %system = $self->GetSystem ($$row{system});
-
+
# Skip inactive systems
next if $system{active} eq 'false';
} # if
-
+
# If started is not defined then this task was never run so run it now.
unless ($$row{lastrun}) {
push @records, $row;
next;
} # unless
-
+
# TODO: Handle frequencies better.
my $seconds;
-
+
if ($$row{frequency} =~ /(\d+) seconds/i) {
$seconds = $1;
} elsif ($$row{frequency} =~ /(\d+) minute/i) {
warning "Don't know how to handle frequencies like $$row{frequency}";
next;
} # if
-
+
my $today = Today2SQLDatetime;
my $lastrun = Add ($$row{lastrun}, (seconds => $seconds));
my $waitTime = DateToEpoch ($lastrun) - DateToEpoch ($today);
-
+
if ($waitTime < 0) {
# We're late - push this onto records and move on
push @records, $row;
} # if
-
+
$sleep ||= $waitTime;
-
+
if ($sleep > $waitTime) {
$sleep = $waitTime;
} # if
} # while
-
+
# Even if there is nothing to do the caller should sleep a bit and come back
# to us. So if it ends up there's nothing past due, and nothing upcoming, then
# sleep for a minute and return here. Somebody may have added a new task next
if (@records == 0 and not $sleep) {
$sleep = 60;
} # if
-
- return ($sleep, @records);
+
+ return ($sleep, @records);
} # GetWork
sub GetUniqueList ($$) {
my ($self, $table, $field) = @_;
-
+
my ($err, $msg);
-
+
my $statement = "select $field from $table group by $field";
-
+
my $sth = $self->{db}->prepare ($statement);
-
+
unless ($sth) {
($err, $msg) = $self->_dberror ('Unable to prepare statement', $statement);
-
+
croak $msg;
} # if
-
+
my $status = $sth->execute;
-
+
unless ($status) {
($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);
-
+
croak $msg;
} # if
my @values;
-
+
while (my @row = $sth->fetchrow_array) {
if ($row[0]) {
push @values, $row[0];
} else {
push @values, '<NULL>';
} # if
- } # foreach
+ } # for
return @values;
} # GetUniqueList
sub AddAlert(%) {
my ($self, %alert) = @_;
-
+
my @requiredFields = (
'name',
'type',
);
-
+
my $result = _checkRequiredFields \@requiredFields, \%alert;
-
+
return -1, "AddAlert: $result"
if $result;
-
- return $self->_addRecord ('alert', %alert);
+
+ return $self->_addRecord ('alert', %alert);
} # AddAlert
sub DeleteAlert ($) {
my ($self, $name) = @_;
-
+
return $self->_deleteRecord ('alert', "name='$name'");
} # DeleteAlert
sub FindAlert (;$) {
my ($self, $alert) = @_;
-
+
$alert ||= '';
-
+
my $condition = "name like '%$alert%'";
-
- return $self->_getRecords ('alert', $condition);
+
+ return $self->_getRecords ('alert', $condition);
} # FindAlert
sub GetAlert ($) {
my ($self, $name) = @_;
-
+
return
unless $name;
-
+
my @records = $self->_getRecords ('alert', "name='$name'");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
return;
- } # if
+ } # if
} # GetAlert
sub SendAlert ($$$$$$$) {
$to,
$runlogID,
) = @_;
-
+
my $footing = '<hr><p style="text-align: center;">';
$footing .= '<font color="#bbbbbb">';
my $year = (localtime)[5] + 1900;
- $footing .= "<a href='$CLEAROPTS{CLEARADM_WEBBASE}'>Clearadm</a><br>";
+ $footing .= "<a href='$CLEAROPTS{CLEARADM_WEBBASE}'>Clearadm</a><br>";
$footing .= "Copyright © $year, ClearSCM, Inc. - All rights reserved";
-
+
my %alert = $self->GetAlert ($alert);
-
+
if ($alert{type} eq 'email') {
my $from = 'Clearadm@' . hostdomain;
-
+
mail (
from => $from,
to => $to,
subject => "Clearadm Alert: $system: $subject",
mode => 'html',
- data => $message,
- footing => $footing,
+ data => $message,
+ footing => $footing,
);
} else {
$self->Error ("Don't know how to send $alert{type} alerts\n"
notification => $notification,
runlog => $runlogID,
timestamp => Today2SQLDatetime,
- message => $subject,
- );
-
+ message => $subject,
+ );
+
return $self->AddAlertlog (%alertlog);
} # SendAlert
sub GetLastAlert ($$) {
my ($self, $notification, $system) = @_;
-
+
my $statement = <<"END";
select
runlog,
timestamp
-from
+from
alertlog
where
notification='$notification'
and system='$system'
order by
timestamp desc
-limit
+limit
0, 1
END
-
+
my $sth = $self->{db}->prepare ($statement)
or return $self->_dberror ('Unable to prepare statement', $statement);
-
+
$sth->execute
or return $self->_dberror ('Unable to execute statement', $statement);
-
+
my $alertlog= $sth->fetchrow_hashref;
-
+
$sth->finish;
-
+
if ($alertlog) {
return %$alertlog;
} else {
sub GetLastTaskFailure ($$) {
my ($self, $task, $system) = @_;
-
+
my $statement = <<"END";
select
id,
ended
-from
+from
runlog
where
- status <> 0
+ status <> 0
and task='$task'
and system='$system'
and alerted='true'
order by
ended desc
-limit
+limit
0, 1
END
-
+
my $sth = $self->{db}->prepare ($statement)
or return $self->_dberror ('Unable to prepare statement', $statement);
-
+
$sth->execute
or return $self->_dberror ('Unable to execute statement', $statement);
-
+
my $runlog= $sth->fetchrow_hashref;
-
+
$sth->finish;
-
+
if ($$runlog{ended}) {
return %$runlog;
} # if
-
+
# If we didn't get any ended in the last call then there's nothing that
# qualified. Still let's return a record (%runlog) that has a valid id so
# that the caller can update that runlog with alerted = 'true'.
status <> 0
and task='$task'
and system='$system'
-order by
+order by
ended desc
limit
0, 1
$sth = $self->{db}->prepare ($statement)
or return $self->_dberror ('Unable to prepare statement', $statement);
-
+
$sth->execute
or return $self->_dberror ('Unable to execute statement', $statement);
-
+
$runlog = $sth->fetchrow_hashref;
-
+
$sth->finish;
-
+
if ($runlog) {
return %$runlog;
} else {
return
} # if
-} # GetLastTaskFailure
+} # GetLastTaskFailure
sub Notify ($$$$$$) {
my (
$runlogID = $self->_getLastID
unless $runlogID;
-
+
my ($err, $msg);
-
+
# Update filesystem, if $filesystem was specified
if ($filesystem) {
($err, $msg) = $self->UpdateFilesystem (
notification => $notification,
),
);
-
+
$self->Error ("Unable to set notification for filesystem $system:$filesystem "
. "(Status: $err)\n$msg", $err) if $err;
} # if
-
+
# Update system
($err, $msg) = $self->UpdateSystem (
$system, (
notification => $notification,
),
);
-
+
my %notification = $self->GetNotification ($notification);
-
+
my %lastnotified = $self->GetLastAlert ($notification, $system);
-
+
if (%lastnotified and $lastnotified{timestamp}) {
my $today = Today2SQLDatetime;
my $lastnotified = $lastnotified{timestamp};
-
+
if ($notification{nomorethan} =~ /hour/i) {
$lastnotified = Add ($lastnotified, (hours => 1));
} elsif ($notification{nomorethan} =~ /day/i) {
} elsif ($notification{nomorethan} =~ /month/i) {
$lastnotified = Add ($lastnotified, (month => 1));
} # if
-
+
# If you want to fake an alert in the debugger just change $diff accordingly
my $diff = Compare ($today, $lastnotified);
-
+
return
if $diff <= 0;
- } # if
+ } # if
my $when = Today2SQLDatetime;
my $nomorethan = lc $notification{nomorethan};
unless ($to) {
if ($system) {
my %system = $self->GetSystem ($system);
-
+
$to = $system{email};
} else {
# If we don't know what system this error occurred on we'll have to notify
$to = $self->{NOTIFY};
} # if
} # unless
-
+
unless ($to) {
Error "To undefined";
} # unless
-
+
$message .= "<p>You will receive this alert no more than $nomorethan.</p>";
-
+
($err, $msg) = $self->SendAlert (
$notification{alert},
$system,
$to,
$runlogID,
);
-
+
$self->Error ("Unable to send alert (Status: $err)\n$msg", $err) if $err;
verbose "Sent alert to $to";
alerted => 'true',
),
);
-
+
$self->Error ("Unable to update runlog (Status: $err)\n$msg", $err) if $err;
- return;
+ return;
} # Notify
sub ClearNotifications ($$;$) {
my ($self, $system, $filesystem) = @_;
-
+
my ($err, $msg);
-
+
if ($filesystem) {
($err, $msg) = $self->UpdateFilesystem (
$system,
$filesystem, (notification => undef),
);
-
+
error "Unable to clear notification for filesystem $system:$filesystem "
. "(Status: $err)\n$msg", $err
if $err;
-
+
# Check to see any of this system's filesystems have notifications. If none
- # then it's save to say we've turned off the last notification for a
+ # then it's save to say we've turned off the last notification for a
# filesystem involved with this system and if $system{notification} was
# 'Filesystem' then we can toggle off the notification on the system too
my $filesystemsAlerted = 0;
-
- foreach ($self->FindFilesystem ($system)) {
- $filesystemsAlerted++
+
+ for ($self->FindFilesystem ($system)) {
+ $filesystemsAlerted++
if $$_{notification};
- } # foreach
-
+ } # for
+
my %system = $self->GetSystem ($system);
-
+
return
unless $system;
-
- if ($system{notification} and
+
+ if ($system{notification} and
$system{notification} eq 'Filesystem' and
$filesystemsAlerted == 0) {
($err, $msg) = $self->UpdateSystem ($system, (notification => undef));
} # if
} else {
($err, $msg) = $self->UpdateSystem ($system, (notification => undef));
-
+
$self->Error ("Unable to clear notification for system $system "
. "(Status: $err)\n$msg", $err) if $err;
} # if
-
+
return;
} # ClearNotifications
# If we've never heard from this system then we will assume that the system
# has not been set up to run clearagent and has never checked in. In any event
- # we cannot say the system died because we've never known it to be alive!
+ # we cannot say the system died because we've never known it to be alive!
return 1
unless $system{lastheardfrom};
-
+
# If a system is not active (may have been temporarily been deactivated) then
# we don't want to turn on the bells and whistles alerting people it's down.
return 1
if $system{active} eq 'false';
-
+
my $today = Today2SQLDatetime;
my $lastheardfrom = $system{lastheardfrom};
-
+
my $tenMinutes = 10 * 60;
-
+
$lastheardfrom = Add ($lastheardfrom, (seconds => $tenMinutes));
if (DateToEpoch ($lastheardfrom) < DateToEpoch ($today)) {
notification => 'Heartbeat'
),
);
-
+
return;
} else {
if ($system{notification}) {
sub UpdateAlert ($%) {
my ($self, $name, %update) = @_;
-
+
return $self->_updateRecord (
'alert',
"name='$name'",
sub AddAlertlog (%) {
my ($self, %alertlog) = @_;
-
+
my @requiredFields = (
'alert',
'notification',
);
-
+
my $result = _checkRequiredFields \@requiredFields, \%alertlog;
-
+
return -1, "AddAlertlog: $result"
if $result;
-
+
# Timestamp record
$alertlog{timestamp} = Today2SQLDatetime;
-
- return $self->_addRecord ('alertlog', %alertlog);
+
+ return $self->_addRecord ('alertlog', %alertlog);
} # AddAlertlog
sub DeleteAlertlog ($) {
my ($self, $condition) = @_;
-
+
return
unless $condition;
-
+
if ($condition =~ /all/i) {
return $self->_deleteRecord ('alertlog');
} else {
sub FindAlertlog (;$$$$$) {
my ($self, $alert, $system, $notification, $start, $page) = @_;
-
+
$alert ||= '';
$system ||= '';
$notification ||= '';
-
+
my $condition = "alert like '%$alert%'";
$condition .= ' and ';
$condition .= "system like '%$system%'";
$condition .= ' and ';
$condition .= "notification like '%$notification%'";
$condition .= " order by timestamp desc";
-
+
if (defined $start) {
$page ||= 10;
$condition .= " limit $start, $page";
sub GetAlertlog ($) {
my ($self, $alert) = @_;
-
+
return
unless $alert;
-
+
my @records = $self->_getRecords ('alertlog', "alert='$alert'");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
return;
- } # if
+ } # if
} # GetAlertlog
sub UpdateAlertlog ($%) {
my ($self, $alert, %update) = @_;
-
+
return $self->_updateRecord (
'alertlog',
"alert='$alert'",
sub AddNotification (%) {
my ($self, %notification) = @_;
-
+
my @requiredFields = (
'name',
'alert',
'cond'
);
-
+
my $result = _checkRequiredFields \@requiredFields, \%notification;
-
+
return -1, "AddNotification: $result"
if $result;
-
- return $self->_addRecord ('notification', %notification);
+
+ return $self->_addRecord ('notification', %notification);
} # AddNotification
sub DeleteNotification ($) {
my ($self, $name) = @_;
-
+
return $self->_deleteRecord ('notification', "name='$name'");
} # DeletePackage
sub FindNotification (;$$) {
my ($self, $name, $cond, $ordering) = @_;
-
+
$name ||= '';
-
+
my $condition = "name like '%$name%'";
$condition .= " and $cond"
if $cond;
-
- return $self->_getRecords ('notification', $condition);
+
+ return $self->_getRecords ('notification', $condition);
} # FindNotification
sub GetNotification ($) {
my ($self, $name) = @_;
-
+
return
unless $name;
-
+
my @records = $self->_getRecords ('notification', "name='$name'");
-
+
if ($records[0]) {
return %{$records[0]};
} else {
return;
- } # if
+ } # if
} # GetNotification
sub UpdateNotification ($%) {
my ($self, $name, %update) = @_;
-
+
return $self->_updateRecord (
'notification',
"name='$name'",
=head2 ClearSCM Perl Modules
-=begin man
+=begin man
DateUtils
Display
use base 'Exporter';
use CGI qw (
- :standard
+ :standard
start_a
end_a
start_div
our $APPNAME= 'Clearadm';
our $VERSION = '$Revision: 1.46 $';
($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
-
+
our @EXPORT = qw (
autoScale
displayError
sub dbug ($) {
my ($msg) = @_;
-
+
display font ({-class => 'error'}, '<br>DEBUG: '). $msg;
-
+
return;
} # dbug
sub displayError ($) {
my ($msg) = @_;
-
+
display font ({-class => 'error'}, 'Error: ') . $msg;
-
+
return
} # displayError;
sub setField ($;$) {
my ($field, $label) = @_;
-
+
$label ||= 'Unknown';
my $undef = font {-class => 'unknown'}, $label;
-
+
return defined $field ? $field : $undef;
} # setField
sub setFields ($%) {
my ($label, %rec) = @_;
-
+
$rec{$_} = setField ($rec{$_}, $label)
foreach keys %rec;
-
+
return %rec;
} # setFields;
sub dumpVars (%) {
my (%vars) = @_;
-
+
foreach (keys %vars) {
dbug "$_: $vars{$_}";
} # foreach
-
+
return;
} # dumpVars
sub graphError ($) {
my ($msg) = @_;
-
+
use GD;
-
+
# Make the image fit the message. It seems that characters are ~ 7px wide.
my $imageLength = length ($msg) * 7;
-
+
my $errorImage = GD::Image->new ($imageLength, 20);
# Allocate some colors
my $white = $errorImage->colorAllocate (255, 255, 255);
my $red = $errorImage->colorAllocate (255, 0, 0);
-
+
# Allow the text to shine through
$errorImage->transparent($white);
$errorImage->interlaced('true');
- # Now put out the message
+ # Now put out the message
$errorImage->string (gdMediumBoldFont, 0, 0, $msg, $red);
# And return it
print "Content-type: image/png\n\n";
print $errorImage->png;
-
+
# Since we've "returned" the error in the form of an image, there's nothing
# left for us to do so we can exit
exit;
sub autoScale ($) {
my ($amount) = @_;
-
+
my $kbyte = 1024;
my $meg = (1024 * $kbyte);
my $gig = (1024 * $meg);
-
+
my $size = $amount > $gig
? sprintf ('%.2f Gig', $amount / $gig)
: $amount > $meg
? sprintf ('%.2f Meg', $amount / $meg)
: sprintf ('%.2f Kbyte', $amount / $kbyte);
-
- return $size;
+
+ return $size;
} # autoScale
sub _makeAlertlogSelection ($$) {
my ($name, $default) = @_;
-
+
$default ||= 'All';
my %values;
$values{All} = 'All';
-
+
$values{$$_{$name}} = $$_{$name}
foreach ($clearadm->FindAlertlog);
class => 'dropdown',
values => [sort keys %values],
default => $default,
- };
-
+ };
+
return $dropdown;
} # _makeAlertlogSelection
sub _makeRunlogSelection ($$) {
my ($name, $default) = @_;
-
+
$default ||= 'All';
my @values = sort $clearadm->GetUniqueList ('runlog', $name);
-
+
unshift @values, 'All';
-
+
my %values;
-
+
foreach (@values) {
unless ($_ eq '') {
$values{$_} = $_;
} else {
$values{NULL} = '<NULL>';
- } #if
+ } #if
} # foreach
-
+
my $dropdown = popup_menu {
name => $name,
class => 'dropdown',
values => \@values,
default => $default,
labels => \%values,
- };
-
+ };
+
return $dropdown;
} # _makeRunlogSelection
sub _makeRunlogSelectionNumeric ($$) {
my ($name, $default) = @_;
-
+
$default ||= 'All';
my @values = sort {$a <=> $b} $clearadm->GetUniqueList ('runlog', $name);
-
+
unshift @values, 'All';
-
+
my $dropdown = popup_menu {
name => $name,
class => 'dropdown',
values => [@values],
default => $default,
- };
-
+ };
+
return $dropdown;
} # _makeRunlogSelection
sub makeAlertDropdown (;$$) {
my ($label, $default) = @_;
-
+
$label ||= '';
my @values;
push @values, $$_{name}
foreach ($clearadm->FindAlert);
-
+
my $dropdown = "$label ";
$dropdown .= popup_menu {
name => 'alert',
class => 'dropdown',
values => [sort @values],
default => $default,
- };
-
+ };
+
return $dropdown;
} # makeAlertDropdown
sub makeMultiplierDropdown (;$$) {
my ($label, $default) = @_;
-
+
$label ||= '';
-
+
my $dropdown = "$label ";
$dropdown .= popup_menu {
name => 'multiplier',
class => 'dropdown',
values => [sort @PREDEFINED_MULTIPLIERS],
default => $default,
- };
+ };
return $dropdown;
} # makeMultiplierDropdown
sub makeNoMoreThanDropdown (;$$) {
my ($label, $default) = @_;
-
+
$label ||= '';
-
+
my $dropdown = "$label ";
$dropdown .= popup_menu {
name => 'nomorethan',
class => 'dropdown',
values => [sort @PREDEFINED_NOTMORETHAN],
default => $default,
- };
+ };
return $dropdown;
} # makeNoMorThanDropdown
-
+
sub makeFilesystemDropdown ($;$$$) {
my ($system, $label, $default, $onchange) = @_;
$label ||= '';
-
+
my %filesystems;
-
+
foreach ($clearadm->FindFilesystem ($system)) {
my %filesystem = %{$_};
-
+
my $value = "$filesystem{filesystem} ($filesystem{mount})";
$filesystems{$filesystem{filesystem}} = $value;
} # foreach
-
+
my $dropdown .= "$label ";
$dropdown .= popup_menu {
name => 'filesystem',
onChange => ($onchange) ? $onchange : '',
default => $default,
};
-
- return span {id => 'filesystems'}, $dropdown;
+
+ return span {id => 'filesystems'}, $dropdown;
} # makeFilesystemDropdown
sub makeIntervalDropdown (;$$$) {
my ($label, $default, $onchange) = @_;
-
+
$label ||= '';
-
+
my @intervals = (
'Minute',
'Hour',
$default = ucfirst lc $default
if $default;
-
+
my $dropdown = "$label ";
$dropdown .= popup_menu {
name => 'scaling',
default => $default,
onchange => $onchange,
};
-
- return span {id => 'scaling'}, $dropdown;
+
+ return span {id => 'scaling'}, $dropdown;
} # makeIntervalDropdown;
sub makeNotificationDropdown (;$$) {
my ($label, $default) = @_;
-
+
$label ||= '';
my @values;
-
- push @values, $$_{name}
+
+ push @values, $$_{name}
foreach ($clearadm->FindNotification);
-
+
my $dropdown = "$label ";
$dropdown .= popup_menu {
name => 'notification',
class => 'dropdown',
values => [sort @values],
default => $default,
- };
-
+ };
+
return $dropdown;
} # makeNotificationDropdown
sub makeRestartableDropdown (;$$) {
my ($label, $default) = @_;
-
+
$label ||= '';
my @values = (
'true',
'false',
);
-
+
my $dropdown = "$label ";
$dropdown .= popup_menu {
name => 'restartable',
class => 'dropdown',
values => [@values],
default => $default,
- };
-
+ };
+
return $dropdown;
} # makeRestartableDropdown
my ($label, $default, $onchange, %systems) = @_;
$label ||= '';
-
+
foreach ($clearadm->FindSystem) {
my %system = %{$_};
-
+
my $value = $system{name};
$value .= $system{alias} ? " ($system{alias})" : '';
$systems{$system{name}} = $value;
} # foreach
-
+
my $systemDropdown .= "$label ";
$systemDropdown .= popup_menu {
name => 'system',
onchange => ($onchange) ? $onchange : '',
default => $default,
};
-
+
return span {id => 'systems'}, $systemDropdown;
} # makeSystemDropdown
sub makeTaskDropdown (;$$) {
my ($label, $default) = @_;
-
+
$label ||= '';
my @values;
push @values, $$_{name}
foreach ($clearadm->FindTask);
-
+
my $taskDropdown = "$label ";
$taskDropdown .= popup_menu {
name => 'task',
class => 'dropdown',
values => [sort @values],
default => $default,
- };
-
+ };
+
return $taskDropdown;
} # makeTaskDropdown
) = @_;
$label ||= '';
-
+
my @times;
-
+
$name ||= lc $label;
-
+
push @times, 'Earliest';
if ($table =~ /loadavg/i) {
} elsif ($table =~ /filesystem/i) {
push @times, $$_{timestamp}
foreach ($clearadm->GetFS ($system, $filesystem, undef, undef, undef, $interval));
- } # if
+ } # if
push @times, 'Latest';
-
+
unless ($default) {
$default = $name eq 'start' ? 'Earliest' : 'Latest';
} # unless
-
+
my $timeDropdown = "$label ";
$timeDropdown .= span {id => $elementID}, popup_menu {
name => $name,
values => [@times],
default => $default,
};
-
- return $timeDropdown;
+
+ return $timeDropdown;
} # makeTimeDropdown
sub heading (;$$) {
} else {
$title = $APPNAME;
} # if
-
+
display header;
display start_html {
-title => $title,
}, $title;
return if $type;
-
+
my $ieTableWrapStart = '<!--[if gt IE 6]><!--></a><!--<![endif]--><!--'
. '[if lt IE 7]><table border="0" cellpadding="0" '
. 'cellspacing="0"><tr><td><![endif]-->';
my $ieTableWrapEnd = '<!--[if lte IE 6]></td></tr></table></a><![endif]-->';
-
+
# Menubar
display div {id=>'mastheadlogo'}, h1 {class => 'title'}, $APPNAME;
display start_div {class => 'menu'};
-
+
# Home
display ul li a {href => '/clearadm'}, 'Home';
-
+
my @allSystems = $clearadm->FindSystem;
-
+
# Systems
display start_ul;
display start_li;
my $sysName = ucfirst $system{name};
$sysName .= " ($system{alias})"
if $system{alias};
-
+
display li a {
href => "systemdetails.cgi?system=$system{name}"
}, ucfirst " $sysName";
display end_li;
display end_li;
display end_ul;
-
+
# Filesystems
display start_ul;
display start_li;
my $sysName = ucfirst $system{name};
$sysName .= " ($system{alias})"
if $system{alias};
-
+
display li a {
href => "filesystems.cgi?system=$system{name}"
}, ucfirst " $sysName";
display $ieTableWrapEnd;
display end_li;
display end_ul;
-
+
# Servers
display start_ul;
display start_li;
display end_ul;
display $ieTableWrapEnd;
display end_li;
-
+
display start_li;
display start_a {href => 'views.cgi'};
display "<span class='drop'><span>View</span>»</span>$ieTableWrapStart";
display $ieTableWrapEnd;
display end_li;
display end_ul;
-
+
# Vobs
display start_ul;
display start_li;
display end_ul;
display $ieTableWrapEnd;
display end_li;
- display end_ul;
-
+ display end_ul;
+
# Views
display start_ul;
display start_li;
display end_ul;
display $ieTableWrapEnd;
display end_li;
- display end_ul;
+ display end_ul;
# Configure
display start_ul;
display end_ul;
display $ieTableWrapEnd;
display end_li;
- display end_ul;
-
+ display end_ul;
+
# Logs
display start_ul;
display start_li;
display end_ul;
display $ieTableWrapEnd;
display end_li;
- display end_ul;
-
+ display end_ul;
+
# Help
display start_ul;
display start_li;
display end_li;
display end_ul;
display end_div;
-
+
display start_div {class => 'page'};
-
+
return;
} # heading
sub displayAlert (;$) {
my ($alert) = @_;
-
+
display start_table {cellspacing => 1};
display start_Tr;
display th {class => 'labelCentered'}, 'Who';
display th {class => 'labelCentered'}, 'Category';
display end_Tr;
-
+
foreach ($clearadm->FindAlert ($alert)) {
my %alert = %{$_};
-
+
$alert{who} = setField $alert{who}, 'System Administrator';
-
+
display start_Tr;
my $areYouSure = "Are you sure you want to delete the $alert{name} alert?";
-
+
my $actions = start_form {
method => 'post',
action => 'processalert.cgi',
alt => 'Delete',
value => 'Delete',
title => 'Cannot delete predefined alert',
- };
+ };
$actions .= input {
name => 'edit',
disabled => 'true',
};
} # if
- display end_form;
+ display end_form;
my $who = $alert{who};
-
+
if ($who =~ /^([a-zA-Z0-9._-]+)@([a-zA-Z0-9.-]+\.[a-zA-Z]{2,4})$/) {
$who = a {href => "mailto:$1\@$2"}, $who;
} # if
display end_Tr;
} # foreach
- display end_table;
-
+ display end_table;
+
display p {class => 'center'}, a {
href => 'processalert.cgi?action=Add',
}, 'New alert ', img {
sub displayAlertlog (%) {
my (%opts) = @_;
-
+
my $optsChanged;
-
+
unless (($opts{oldalert} and $opts{alert} and
$opts{oldalert} eq $opts{alert}) and
($opts{oldsystem} and $opts{system} and
$opts{oldsystem} eq $opts{system}) and
($opts{oldnotification} and $opts{notification} and
$opts{oldnotification} eq $opts{notification})) {
- $optsChanged = 1;
+ $optsChanged = 1;
} # unless
-
+
my $condition;
unless ($opts{id}) {
$opts{start} = 0;
} # if
- my $next = $opts{start} + $opts{page} < $total
+ my $next = $opts{start} + $opts{page} < $total
? $opts{start} + $opts{page}
: $opts{start};
my $prev = $opts{start} - $opts{page} >= 0
$opts .= " of $total";
display start_form {
- method => 'post',
+ method => 'post',
action => 'alertlog.cgi'
};
# Hidden fields to pass along
display input {name => 'prev', type => 'hidden', value => $prev};
display input {name => 'next', type => 'hidden', value => $next};
-
+
display input {
name => 'oldalert',
type => 'hidden',
disabled => 'disabled',
};
} # unless
-
+
$caption .= td {align => 'center'}, $opts;
unless ($opts{id}) {
type => 'button',
value => 'Clear All Events',
onclick => "return AreYouSure('Are you sure you want to delete all alerts?');",
- };
+ };
display end_Tr;
-
+
my $i = $opts{start};
foreach ($clearadm->FindAlertlog (
$opts{page},
)) {
my %alertlog = setFields 'N/A', %{$_};
-
+
display start_Tr;
my %system = $clearadm->GetSystem ($alertlog{system});
-
+
display td {class => 'dataCentered'}, ++$i;
display td {class => 'dataCentered'}, a {
href => "deletealertlog.cgi?alertlogid=$alertlog{id}"
display end_form;
- display end_table;
-
+ display end_table;
+
return;
} # displayAlertlog
my ($systemName) = @_;
display start_table {cellspacing => 1, width => '98%'};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Action';
display th {class => 'labelCentered'}, 'Name';
display th {class => 'labelCentered'}, 'Threshold';
display th {class => 'labelCentered'}, 'Usage';
display end_Tr;
-
+
foreach ($clearadm->FindSystem ($systemName)) {
my %system = %{$_};
-
+
%system = setFields ('N/A', %system);
my $admin = ($system{email} !~ 'N/A')
? a {-href => "mailto:$system{email}"}, $system{admin}
: $system{admin};
-
+
foreach ($clearadm->FindFilesystem ($system{name})) {
my %filesystem = %{$_};
my $used = autoScale $fs{used};
my $free = autoScale $fs{free};
- # TODO: Note that this percentages does not agree with df output. I'm not
+ # TODO: Note that this percentages does not agree with df output. I'm not
# sure why.
- my $usedPct = $fs{size} == 0 ? 0
+ my $usedPct = $fs{size} == 0 ? 0
: sprintf ('%.0f',
(($fs{reserve} + $fs{used}) / $fs{size} * 100));
href => "systemdetails.cgi?system=$system{name}"
}, $system{alias}
: $system{alias};
-
- my $class = $usedPct < $filesystem{threshold}
+
+ my $class = $usedPct < $filesystem{threshold}
? 'data'
: 'dataAlert';
- my $classRight = $usedPct < $filesystem{threshold}
+ my $classRight = $usedPct < $filesystem{threshold}
? 'dataRight'
: 'dataRightAlert';
- my $classCentered = $usedPct < $filesystem{threshold}
+ my $classCentered = $usedPct < $filesystem{threshold}
? 'dataCentered'
: 'dataCenteredAlert';
my $classRightTop = $usedPct < $filesystem{threshold}
? 'dataRightTop'
- : 'dataRightAlertTop';
+ : 'dataRightAlertTop';
display start_Tr;
display start_td {class => 'dataCentered'};
method => 'post',
action => "processfilesystem.cgi",
};
-
+
display input {
type => 'hidden',
name => 'system',
name => 'filesystem',
value => $filesystem{filesystem},
};
-
+
display input {
name => 'delete',
type => 'image',
value => 'Edit',
title => 'Edit',
};
-
+
if ($filesystem{notification}) {
display a {
href => "alertlog.cgi?system=$filesystem{system}"}, img {
src => 'alert.png',
border => 0,
alt => 'Alert!',
- title => 'This filesystem has alerts',
+ title => 'This filesystem has alerts',
};
- } # if
-
+ } # if
+
display end_form;
-
- display end_td;
+
+ display end_td;
display td {class => $class},
a {-href => "systemdetails.cgi?system=$system{name}"}, $system{name};
display td {class => $class}, $alias;
display td {class => $class}, $filesystem{mount};
display td {class => $class}, $filesystem{fstype};
display td {class => $classCentered}, $filesystem{filesystemHist};
- display td {class => $classRightTop}, "$used ($usedPct%)<br>",
+ display td {class => $classRightTop}, "$used ($usedPct%)<br>",
font {class => 'unknown'}, "$fs{timestamp}";
display td {class => $classRightTop}, "$filesystem{threshold}%";
display td {class => $class},
- a {href =>
+ a {href =>
"plot.cgi?type=filesystem&system=$system{name}"
. "&filesystem=$filesystem{filesystem}&scaling=Day&points=7"
}, img {
} # foreach
display end_table;
-
+
return;
} # displayFilesystem
sub displayNotification (;$) {
my ($notification) = @_;
-
+
display start_table {cellspacing => 1};
display start_Tr;
display th {class => 'labelCentered'}, 'Not More Than';
display th {class => 'labelCentered'}, 'Category';
display end_Tr;
-
+
foreach ($clearadm->FindNotification ($notification)) {
my %notification= setFields 'N/A', %{$_};
-
+
display start_Tr;
my $areYouSure = "Are you sure you want to delete the $notification{name} "
. 'notification?';
-
+
my $actions = start_form {
method => 'post',
action => 'processnotification.cgi',
type => 'hidden',
value => $notification{name},
};
-
+
if (InArray $notification{name}, @PREDEFINED_NOTIFICATIONS) {
$actions .= input {
name => 'delete',
alt => 'Delete',
value => 'Delete',
title => 'Cannot delete predefined notification',
- };
+ };
$actions .= input {
name => 'edit',
disabled => 'true',
title => 'Edit',
};
} # if
-
- display end_form;
+
+ display end_form;
display td {class => 'dataCentered'}, $actions;
display td {class => 'data'}, $notification{name};
display td {class => 'data'}, $notification{cond};
display td {class => 'data'}, $notification{nomorethan};
display td {class => 'data'},
- (InArray $notification{name}, @PREDEFINED_NOTIFICATIONS)
+ (InArray $notification{name}, @PREDEFINED_NOTIFICATIONS)
? 'Predefined'
: 'User Defined';
-
+
display end_Tr;
} # foreach
display end_table;
-
+
display p {class => 'center'}, a {
href => 'processnotification.cgi?action=Add',
}, 'New notification', img {
sub displayRunlog (%) {
my (%opts) = @_;
-
+
my $optsChanged;
-
+
unless (($opts{oldtask} and $opts{task} or
$opts{oldtask} eq $opts{task}) and
($opts{oldsystem} and $opts{system} or
$opts{oldnot} eq $opts{not}) and
($opts{oldstatus} and $opts{status} or
$opts{oldstatus} eq $opts{status})) {
- $optsChanged = 1;
+ $optsChanged = 1;
} # unless
-
- my $condition;
+
+ my $condition;
unless ($opts{id}) {
$condition = "task like '%";
$condition .= $opts{task} ? $opts{task} : '';
$condition .= "%'";
-
+
if ($opts{system}) {
if ($opts{system} eq '<NULL>') {
$condition .= ' and system is null';
undef $opts{system}
} elsif ($opts{system} ne 'All') {
- $condition .= " and system like '%$opts{system}%'";;
+ $condition .= " and system like '%$opts{system}%'";;
} # if
} # if
if (defined $opts{status}) {
$condition .= ' and ';
unless ($opts{not}) {
- $condition .= "status=$opts{status}";
+ $condition .= "status=$opts{status}";
} else {
$condition .= "status<>$opts{status}";
} # unless
} # unless
my $total = $clearadm->Count ('runlog', $condition);
-
+
$opts{start} = $opts{'nextArrow.x'} ? $opts{next} : $opts{prev};
$opts{start} ||= 0;
$opts{start} = 0
if $optsChanged;
-
- my $next = $opts{start} + $opts{page} < $total
+
+ my $next = $opts{start} + $opts{page} < $total
? $opts{start} + $opts{page}
: $opts{start};
my $prev = $opts{start} - $opts{page} >= 0
$opts .= " of $total";
display start_form {
- method => 'post',
+ method => 'post',
action => 'runlog.cgi'
};
disabled => 'disabled',
};
} # unless
-
+
$caption .= td {align => 'center'}, $opts;
unless ($opts{id}) {
display th {class => 'labelCentered'}, 'Status';
display th {class => 'labelCentered'}, 'Message';
display end_Tr;
-
+
display start_Tr;
$opts{not} ||= 'false';
display start_form {
- method => 'post',
+ method => 'post',
action => 'runlog.cgi'
};
display td {
type => 'submit',
value => 'Update',
};
-
+
display end_form;
display end_Tr;
my $i = $opts{start};
my $status;
-
+
if (defined $opts{status}) {
if ($opts{status} !~ /all/i) {
$status = $opts{not} ne 'true' ? $opts{status} : "!$opts{status}";
} # if
} # if
-
+
foreach ($clearadm->FindRunlog (
$opts{task},
$opts{system},
$opts{page},
)) {
my %runlog = setFields 'N/A', %{$_};
-
- my $class = $runlog{status} == 0
+
+ my $class = $runlog{status} == 0
? 'data'
: 'dataAlert';
my $classCentered = $runlog{status} == 0
my $classRight = $runlog{status} == 0
? 'dataRight'
: 'dataAlertRight';
-
+
display start_Tr;
display td {class => 'dataCentered'}, ++$i;
display td {class => 'dataCentered'}, $runlog{id};
display td {class => 'dataCentered'}, $runlog{started};
display td {class => 'dataCentered'}, $runlog{ended};
display td {class => $classRight}, $runlog{status};
-
+
my $message = $runlog{message};
$message =~ s/\r\n/<br>/g;
-
+
display td {class => $class, width => '50%'}, $message;
display end_Tr;
} # foreach
display end_table;
-
+
return;
} # displayRunlog
display th {class => 'labelCentered'}, 'Frequency';
display th {class => 'labelCentered'}, 'Category';
display end_Tr;
-
+
foreach ($clearadm->FindSchedule) {
my %schedule = setFields 'N/A', %{$_};
-
+
display start_Tr;
my $areYouSure = "Are you sure you want to delete the $schedule{name} "
. "schedule?";
-
+
my $actions = start_form {
method => 'post',
action => 'processschedule.cgi',
type => 'hidden',
value => $schedule{name},
};
-
+
if (InArray $schedule{name}, @PREDEFINED_SCHEDULES) {
$actions .= input {
name => 'delete',
alt => 'Delete',
value => 'Delete',
title => 'Cannot delete predefined schedule',
- };
+ };
$actions .= input {
name => 'edit',
disabled => 'true',
title => 'Edit',
};
} # if
-
- display end_form;
-
+
+ display end_form;
+
display td {class => 'dataCentered'}, $actions;
display td {class => 'dataCentered'}, checkbox {
disabled => 'disabled',
}, $schedule{notification};
display td {class => 'data'}, $schedule{frequency};
display td {class => 'data'},
- (InArray $schedule{name}, @PREDEFINED_SCHEDULES)
- ? 'Predefined'
- : 'User Defined';
-
+ (InArray $schedule{name}, @PREDEFINED_SCHEDULES)
+ ? 'Predefined'
+ : 'User Defined';
+
display end_Tr;
} # foreach
display end_table;
-
+
display p {class => 'center'}, a {
href => 'processschedule.cgi?action=Add',
}, 'New schedule', img {
sub displaySystem ($) {
my ($systemName) = @_;
-
+
my %system = $clearadm->GetSystem ($systemName);
-
+
unless (%system) {
displayError "Nothing known about system $systemName";
return;
} # unless
-
+
my $lastheardfromClass = 'dataCentered';
my $lastheardfromData = $system{lastheardfrom};
-
+
my %load = $clearadm->GetLatestLoadavg ($systemName);
unless ($clearadm->SystemAlive (%system)) {
my $admin = ($system{email})
? a {-href => "mailto:$system{email}"}, $system{admin}
: $system{admin};
-
+
$system{alias} = setField $system{alias}, 'N/A';
$system{region} = setField $system{region}, 'N/A';
display start_table {cellspacing => 1};
-
+
display start_Tr;
my $areYouSure = 'Are you sure you want to delete this system?\n'
. "Doing so will remove all records related to $system{name}"
. '\nincluding filesystem records and history as well as '
. 'loadavg history.';
-
+
my $actions = start_form {
method => 'post',
action => 'processsystem.cgi',
type => 'hidden',
value => $system{name},
};
-
+
$actions .= input {
name => 'delete',
type => 'image',
$actions .= checkbox {
disabled => 'disabled',
checked => $system{active} eq 'true' ? 1 : 0,
- };
-
+ };
+
if ($system{notification}) {
$actions .= a {
href => "alertlog.cgi?system=$system{name}"}, img {
src => 'alert.png',
border => 0,
alt => 'Alert!',
- title => 'This system has alerts',
+ title => 'This system has alerts',
};
} # if
-
+
display th {class => 'label'}, "$actions Name:";
display end_form;
display td {class => 'dataCentered', colspan => 2}, $system{name};
display th {class => 'label', colspan => 2}, 'Type:';
display td {class => 'dataCentered'}, $system{type};
display end_Tr;
-
+
display start_Tr;
display th {class => 'label'}, 'OS Version:';
- display td {class => 'data', colspan => 10}, $system{os};
+ display td {class => 'data', colspan => 10}, $system{os};
display end_Tr;
-
+
display start_Tr;
display th {class => 'label'}, 'Last Contacted:';
display td {
display td {class => 'dataCentered'}, $system{loadavgHist};
display th {class => 'label'}, 'Load Avg:';
display td {class => 'data'},
- a {href =>
+ a {href =>
"plot.cgi?type=loadavg&system=$system{name}&scaling=Hour&points=24"
}, img {
src => "plotloadavg.cgi?system=$system{name}&tiny=1",
border => 0,
};
-
+
my $description = $system{description};
$description =~ s/\r\n/<br>/g;
-
+
display start_Tr;
display th {class => 'label'}, 'Description:';
- display td {class => 'data', colSpan => 10}, $description;
+ display td {class => 'data', colSpan => 10}, $description;
display end_Tr;
-
+
display end_table;
-
+
display p {class => 'center'}, a {
href => 'processsystem.cgi?action=Add',
}, 'New system', img {
border => 0,
};
- display h1 {class => 'center'},
+ display h1 {class => 'center'},
'Filesystem Details: ' . ucfirst $system{name};
-
+
display start_table {cellspacing => 1};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Action';
display th {class => 'labelCentered'}, 'Filesystem';
display th {class => 'labelCentered'}, 'Threshold';
display th {class => 'labelCentered'}, 'History';
display th {class => 'labelCentered'}, 'Usage';
- display end_Tr;
-
+ display end_Tr;
+
foreach ($clearadm->FindFilesystem ($system{name})) {
my %filesystem = %{$_};
-
+
my %fs = $clearadm->GetLatestFS (
- $filesystem{system},
+ $filesystem{system},
$filesystem{filesystem}
);
-
+
my $size = autoScale $fs{size};
my $used = autoScale $fs{used};
- my $free = autoScale $fs{free};
+ my $free = autoScale $fs{free};
- # TODO: Note that this percentages does not agree with df output. I'm not
+ # TODO: Note that this percentages does not agree with df output. I'm not
# sure why.
- my $usedPct = $fs{size} == 0 ? 0
+ my $usedPct = $fs{size} == 0 ? 0
: sprintf ('%.0f',
(($fs{reserve} + $fs{used}) / $fs{size} * 100));
-
- my $class = $usedPct < $filesystem{threshold}
+
+ my $class = $usedPct < $filesystem{threshold}
? 'data'
: 'dataAlert';
my $classCentered = $class . 'Centered';
my $classRight = $class . 'Right';
-
+
display start_Tr;
display start_td {class => 'data'};
method => 'post',
action => 'processfilesystem.cgi',
};
-
+
display input {
type => 'hidden',
name => 'system',
name => 'filesystem',
value => $filesystem{filesystem},
};
-
+
display input {
name => 'delete',
type => 'image',
value => 'Edit',
title => 'Edit',
};
-
+
if ($filesystem{notification}) {
display a {
href => "alertlog.cgi?system=$filesystem{system}"}, img {
src => 'alert.png',
border => 0,
alt => 'Alert!',
- title => 'This filesystem has alerts',
+ title => 'This filesystem has alerts',
};
- } # if
+ } # if
- display end_form;
+ display end_form;
display td {class => $class}, $filesystem{filesystem};
display td {class => $classCentered}, $filesystem{fstype};
display td {class => $class}, $filesystem{mount};
display td {class => $classRight}, "$usedPct%";
display td {class => $classRight}, "$filesystem{threshold}%";
display td {class => $classCentered}, $filesystem{filesystemHist};
- display td {class => $classCentered},
- a {href =>
+ display td {class => $classCentered},
+ a {href =>
"plot.cgi?type=filesystem&system=$system{name}"
. "&filesystem=$filesystem{filesystem}"
. "&scaling=Day&points=7"
} # foreach
display end_table;
-
+
return;
} # displaySystem
sub displayTask (;$) {
my ($task) = @_;
-
+
display start_table {cellspacing => 1, width => '98%'};
display start_Tr;
display th {class => 'labelCentered'}, 'Restartable';
display th {class => 'labelCentered'}, 'Category';
display end_Tr;
-
+
foreach ($clearadm->FindTask ($task)) {
my %task = %{$_};
-
+
$task{system} = 'All Systems'
unless $task{system};
-
+
display start_Tr;
my $areYouSure = "Are you sure you want to delete the $task{name} task?";
-
+
my $actions = start_form {
method => 'post',
action => 'processtask.cgi',
alt => 'Delete',
value => 'Delete',
title => 'Cannot delete predefined task',
- };
+ };
$actions .= input {
name => 'edit',
disabled => 'true',
};
} # if
- display end_form;
+ display end_form;
display td {class => 'dataCentered'}, $actions;
display td {class => 'data'}, $task{name};
- display td {class => 'data'}, $task{system};
+ display td {class => 'data'}, $task{system};
display td {class => 'data'}, $task{description};
display td {class => 'data'}, $task{command};
display td {class => 'dataCentered'}, $task{restartable};
- display td {class => 'data'},
+ display td {class => 'data'},
(InArray $task{name}, @PREDEFINED_TASKS) ? 'Predefined' : 'User Defined';
display end_Tr;
} # foreach
- display end_table;
-
+ display end_table;
+
display p {class => 'center'}, a {
href => 'processtask.cgi?action=Add',
}, 'New task', img {
src => 'add.png',
border => 0,
};
-
+
return;
} # DisplayAlerts
sub editAlert (;$) {
my ($alert) = @_;
-
+
display start_form (
-method => 'post',
-action => 'processalert.cgi',
if ($alert) {
%alert = $clearadm->GetAlert ($alert);
-
+
return
- unless %alert;
-
+ unless %alert;
+
display input {
name => 'oldname',
type => 'hidden',
} else {
$alert= '';
} # if
-
+
display input {
name => 'action',
type => 'hidden',
value => 'Post',
};
-
+
display start_table {cellspacing => 1};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Name';
display th {class => 'labelCentered'}, 'Type';
display th {class => 'labelCentered'}, 'Who';
display end_Tr;
-
+
display start_Tr;
display td {
class => 'data',
};
display end_Tr;
display end_table;
-
+
display '<center>';
display p submit ({value => $alert ? 'Update' : 'Add'}), reset;
display '</center>';
-
+
display end_form;
-
+
return;
} # editAlert
sub editFilesystem ($$) {
my ($system, $filesystem) = @_;
-
+
display start_form (
-method => 'post',
-action => 'processfilesystem.cgi',
);
display start_table {width => '800px', cellspacing => 1};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Filesystem';
display th {class => 'labelCentered'}, 'Type';
display th {class => 'labelCentered'}, 'Used %';
display th {class => 'labelCentered'}, 'History';
display th {class => 'labelCentered'}, 'Threshold';
- display end_Tr;
-
+ display end_Tr;
+
my %filesystem = $clearadm->GetFilesystem ($system, $filesystem);
my %fs = $clearadm->GetLatestFS ($system, $filesystem);
-
+
display input {
name => 'action',
type => 'hidden',
name => 'system',
type => 'hidden',
value => $filesystem{system},
- };
+ };
display input {
name => 'filesystem',
type => 'hidden',
value => $filesystem{filesystem},
- } ;
-
+ } ;
+
my $size = autoScale $fs{size};
my $used = autoScale $fs{used};
my $free = autoScale $fs{free};
display td {class => 'dataRight'}, $size;
display td {class => 'dataRight'}, $used;
display td {class => 'dataRight'}, $free;
- # TODO: Note that this percentages does not agree with df output. I'm not
+ # TODO: Note that this percentages does not agree with df output. I'm not
# sure why.
display td {class => 'dataCentered'},
sprintf ('%.0f%%', (($fs{reserve} + $fs{used}) / $fs{size} * 100));
-
+
my $historyDropdown = popup_menu {
name => 'filesystemHist',
class => 'dropdown',
],
default => $system ? $filesystem{filesystemHist} : '6 months',
};
-
+
display td {
class => 'dataRight',
- }, $historyDropdown;
-
+ }, $historyDropdown;
+
my $thresholdDropdown = popup_menu {
name => 'threshold',
class => 'dropdown',
values => [1 .. 100],
default => $filesystem{threshold},
- };
+ };
display td {class => 'dataCentered'}, $thresholdDropdown . '%';
display end_Tr;
-
- display end_table;
-
+
+ display end_table;
+
display '<center>';
display p submit ({value => 'Update'}), reset;
display '</center>';
-
+
display end_form;
-
+
return;
} # editFilesytem
sub editNotification (;$) {
my ($notification) = @_;
-
+
display start_form (
-method => 'post',
-action => 'processnotification.cgi',
if ($notification) {
%notification = $clearadm->GetNotification ($notification);
-
+
return
- unless %notification;
-
+ unless %notification;
+
display input {
name => 'oldname',
type => 'hidden',
} else {
$notification = '';
} # if
-
+
display input {
name => 'action',
type => 'hidden',
value => 'Post',
};
-
+
display start_table {cellspacing => 1};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Name';
display th {class => 'labelCentered'}, 'Alert';
display th {class => 'labelCentered'}, 'Condition';
display th {class => 'labelCentered'}, 'Not More Than';
display end_Tr;
-
+
display start_Tr;
display td {
class => 'data',
type => 'text',
value => $notification ? $notification{name} : '',
};
-
+
display td {
class => 'dataCentered',
- }, makeAlertDropdown undef, $notification{alert}
+ }, makeAlertDropdown undef, $notification{alert}
? $notification{alert}
: 'Email admin';
-
+
display td {
class => 'data',
}, input {
display td {
class => 'dataCentered',
}, makeNoMoreThanDropdown undef, $notification{nomorethan};
-
+
display end_Tr;
display end_table;
-
+
display '<center>';
display p submit ({value => $notification ? 'Update' : 'Add'}), reset;
display '</center>';
-
+
display end_form;
-
+
return;
} # editNotification
sub editSchedule (;$) {
my ($schedule) = @_;
-
+
display start_form (
-method => 'post',
-action => 'processschedule.cgi',
if ($schedule) {
%schedule = $clearadm->GetSchedule ($schedule);
-
+
return
- unless %schedule;
-
+ unless %schedule;
+
display input {
name => 'oldname',
type => 'hidden',
} else {
$schedule = '';
} # if
-
+
display input {
name => 'action',
type => 'hidden',
value => 'Post',
};
-
+
display start_table {cellspacing => 1};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Active';
display th {class => 'labelCentered'}, 'Name';
display th {class => 'labelCentered'}, 'Notification';
display th {class => 'labelCentered'}, 'Frequency';
display end_Tr;
-
+
display start_Tr;
display td {
class => 'dataCentered',
};
display td {
class => 'dataCentered',
- }, makeTaskDropdown undef, $schedule{task};
+ }, makeTaskDropdown undef, $schedule{task};
display td {
class => 'dataCentered',
- }, makeNotificationDropdown undef, $schedule{notification};
-
+ }, makeNotificationDropdown undef, $schedule{notification};
+
my $nbr = 5;
my $multiplier = 'minutes';
-
+
if ($schedule{frequency} =~ /(\d+)\s(\S+)/ ) {
$nbr = $1;
$multiplier = $2;
-
+
$multiplier .= 's' if $nbr == 1;
} # if
-
+
display td {
class => 'data',
}, input {
size => 1,
type => 'text',
value => $nbr,
- },
+ },
' ',
makeMultiplierDropdown undef, $multiplier;
-
+
display end_Tr;
display end_table;
-
+
display '<center>';
display p submit ({value => $schedule ? 'Update' : 'Add'}), reset;
display '</center>';
-
+
display end_form;
-
+
return;
} # editSchedule
sub editSystem (;$) {
my ($system) = @_;
-
+
display start_form (
-method => 'post',
-action => 'processsystem.cgi',
);
my %system;
-
+
if ($system) {
%system = $clearadm->GetSystem ($system);
-
+
return
unless %system;
-
+
display input {
name => 'name',
type => 'hidden',
} else {
$system = '';
} # if
-
+
display input {
name => 'action',
type => 'hidden',
value => 'Post',
};
-
+
display start_table {cellspacing => 1};
-
+
display start_Tr;
display th {class => 'label'}, checkbox ({
name => 'active',
checked => $system{active} eq 'false' ? 0 : 1,
label => '',
}) . ' Name: ';
-
+
if ($system) {
display td {class => 'data'}, $system{name};
} else {
type => 'text',
};
} # if
-
+
display th {class => 'label'}, 'Alias:';
display td {
class => 'data',
name => 'port',
size => 4,
type => 'text',
- value => $system
+ value => $system
? $system{port}
: $Clearadm::CLEAROPTS{CLEARADM_PORT},
};
-
+
my $systemTypeDropdown = popup_menu {
name => 'type',
class => 'dropdown',
values => ['Unix', 'Linux', 'Windows'],
default => $system ? $system{type} : 'Linux',
};
-
+
display th {class => 'label'}, 'Type:';
display td {
class => 'dataRight',
}, $systemTypeDropdown;
display end_Tr;
-
+
display start_Tr;
display th {class => 'label'}, 'Admin:';
display td {
name => 'loadavgThreshold',
size => 3,
type => 'text',
- value => $system
+ value => $system
? $system{loadavgThreshold}
: $Clearadm::CLEAROPTS{CLEARADM_LOADAVG_THRESHOLD},
};
-
+
my $historyDropdown = popup_menu {
name => 'loadavgHist',
class => 'dropdown',
],
default => $system ? $system{loadavgHist} : '6 months',
};
-
+
display th {class => 'label'}, 'History:';
display td {
class => 'dataRight',
- }, $historyDropdown;
-
+ }, $historyDropdown;
+
my $description = $system ? $system{description} : '';
$description =~ s/\r\n/<br>/g;
-
+
display start_Tr;
display th {class => 'label'}, 'Description:';
display td {
};
display end_Tr;
display end_table;
-
+
display '<center>';
display p submit ({value => $system ? 'Update' : 'Add'}), reset;
display '</center>';
-
+
display end_form;
-
+
return;
} # editSystem
sub editTask (;$) {
my ($task) = @_;
-
+
display start_form (
-method => 'post',
-action => 'processtask.cgi',
if ($task) {
%task = $clearadm->GetTask ($task);
-
+
return
unless %task;
-
+
display input {
name => 'oldname',
type => 'hidden',
} else {
$task = '';
} # if
-
+
display input {
name => 'action',
type => 'hidden',
value => 'Post',
};
-
+
display start_table {cellspacing => 1};
-
+
display start_Tr;
display th {class => 'labelCentered'}, 'Name';
display th {class => 'labelCentered'}, 'System';
display th {class => 'labelCentered'}, 'Command';
display th {class => 'labelCentered'}, 'Restartable';
display end_Tr;
-
+
display start_Tr;
display td {
class => 'data',
'Localhost' => 'Localhost',
),
);
-
- display td {class => 'data'}, $systemDropdown;
+
+ display td {class => 'data'}, $systemDropdown;
display td {
class => 'data',
type => 'text',
value => $task ? $task{description} : '',
};
-
+
display td {
class => 'data',
}, input {
display td {
class => 'dataCentered',
}, makeRestartableDropdown undef, $task{restartable};
-
+
display end_Tr;
display end_table;
-
+
display '<center>';
display p submit ({value => $task ? 'Update' : 'Add'}), reset;
display '</center>';
-
+
display end_form;
-
+
return;
} # editTask
sub footing () {
my $clearscm = a {-href => 'http://clearscm.com'}, 'ClearSCM, Inc.';
-
+
# Figure out which script by using CLEARADM_BASE.
- my $script = basename (url {-absolute => 1});
+ my $script = basename (url {-absolute => 1});
$script = 'index.cgi'
if $script eq 'clearadm';
my $scriptFullPath = "$Clearadm::CLEAROPTS{CLEARADM_BASE}/$script";
-
- my ($year, $mon, $mday, $hour, $min, $sec) =
+
+ my ($year, $mon, $mday, $hour, $min, $sec) =
ymdhms ((stat ($scriptFullPath))[9]);
my $dateModified = "$mon/$mday/$year @ $hour:$min";
-
+
$script = a {
-href => "http://clearscm.com/php/scm_man.php?file=clearadm/$script"
}, $script;
-
+
display end_div;
-
+
display start_div {-class => 'copyright'};
display "$script: Last modified: $dateModified";
display br "Copyright © $year, $clearscm - All rights reserved";
display end_div;
-
+
print end_html;
-
+
return;
} # footing
-
+
1;
=pod
=head2 ClearSCM Perl Modules
-=begin man
+=begin man
Clearadm
DateUtils
Display
Utils
-
+
=end man
=begin html
Status: <status>
<command output>
-
+
This allows the caller to determine if the command execution was successful as
well as capture the commands output.
$self->_debug ("Status: $status");
} # if
- print $client "$_\n" foreach (@output);
+ print $client "$_\n" for (@output);
print $client "Clearexec Status: $status\n";
$self->_debug ("Looping around for next command");
while () {
$client = $self->{socket}->accept;
-
+
if ($? == -1) {\r
if ($!{EINTR}) {
next;
=head2 ClearSCM Perl Modules
-=begin man
+=begin man
DateUtils
Display
This module implements a User object which returns information about a user.
my $user = new User ('adefaria');
-
+
print "Fullname: $user->{fullname}\n";
print "EMail: $user->{email}\n";
-
+
=head2 DESCRIPTION
-This module instanciates a user object for the given user identifier and
+This module instanciates a user object for the given user identifier and
then collects information about the user such as fullname, email, etc. It does
so by contacting Active Directory in a Windows domain or other directory servers
-depending on the site. As such exactly what data members are available may
+depending on the site. As such exactly what data members are available may
change or be different from site to site.
=cut
our $VERSION = '$Revision: 1.4 $';
($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
-
+
# Override options if in the environment
$CLEAROPTS{CLEARUSER_LDAPHOST} = $ENV{CLEARUSER_LDAPHOST}
if $ENV{CLEARUSER_LDAPHOST};
sub GetOwnerInfo ($) {
my ($userid) = @_;
-
+
my @parts = split /(\/|\\)/, $userid;
if (@parts == 3) {
} # if
my $sso = unix2sso ($userid);
-
+
unless ($ldap) {
$ldap = Net::LDAP->new ($CLEAROPTS{CLEARUSER_LDAPHOST})
or croak 'Unable to create LDAP object';
-
+
$ad = $ldap->bind (
"$CLEAROPTS{CLEARUSER_USERNAME}\@$CLEAROPTS{CLEARUSER_BIND}",
password => $CLEAROPTS{CLEARUSER_PASSWORD});
} # unless
-
+
$ad = $ldap->search (
base => $CLEAROPTS{CLEARUSER_BASEDN},
filter => "(&(objectclass=user)(sAMAccountName=$sso))",
);
-
- $ad->code
+
+ $ad->code
&& croak $ad->error;
-
+
my @entries = $ad->entries;
my %ownerInfo;
-
+
if (@entries == 1) {
for (my $i = 0; $i < $ad->count; $i++) {
my $entry = $ad->entry ($i);
$ownerInfo{$attribute} = $entry->get_value ($attribute)
} # foreach
} # for
-
+
return %ownerInfo;
} else {
return;
- } # if
+ } # if
} # GetOwnerInfo
=pod
croak "Must specify userid to User constructor"
if @_ == 1;
-
+
my %members;
-
+
$members{id} = $userid;
-
+
my %ownerInfo = GetOwnerInfo ($userid);
-
+
$members{$_} = $ownerInfo{$_}
foreach (keys %ownerInfo);
-
+
return bless \%members, $class;
} # new
=head2 ClearSCM Perl Modules
-=begin man
+=begin man
GetConfig
# Column 4 ClearCase Version (if applicable)
# Column 5 Owner (if known)
# Column 6 Usage (if known)
-chargers:Sun:Solaris 5.9:70.1.1:ccadm:ranview1
+chargers:Sun:Solaris 5.9:7.0.1.1:ccadm:ranview1
colts:Sun:Solaris 5.9:7.0.1.0:ccadm:ranview2
cowboys:Sun:Solaris 5.9:7.0.1.0:ccadm:ranvob1/registry server
-niners:Sun:Solaris 5.9:2003.06.10+:ccadm:?
-patriots:Sun:?:Solaris 5.9:7.0.1.0:ccadm:ranvob2
+niners:Sun:Solaris 5.9:2003.06.10+:ccadm:
+patriots:Sun:Solaris 5.9:7.0.1.0:ccadm:ranvob2
rams:Sun:Solaris 5.9:7.0.1.0:ccadm:ranvob3/registry server
-#ranadm1:Sun:Solaris 5.9:?:ccadm:Jumpstart, PowerBroker, NIS, SMTP, DNS, NTP
+#ranadm1:Sun:Solaris 5.9::ccadm:Jumpstart, PowerBroker, NIS, SMTP, DNS, NTP
ranadm2:Sun:Solaris 5.9:2003.06.10+:ccadm:License server, Sys admin, NIS, Home Directory server
-ranbkp2:?:?:?:ccadm:?
+ranbkp2::::ccadm:Backup
ranbuild1:Sun:Solaris 5.8:7.0.1.0:ccadm:builds
ranbuild2:Sun:Solaris 5.9:2003.06.10+:ccadm:builds
ranbuild4:Sun:Solaris 5.9:7.0.1.1:ccadm:builds
-rancpp01:Redhat Linux:2.6.18.53.Eel5xen:?:ccadm:?
-rancpp02:Redhat Linux:2.6.18.53.Eel5xen:?:ccadm:?
-rancpp03:Redhat Linux:2.6.18.53.Eel5xen:?:ccadm:?
-rancpp10:Redhat Linux:2.6.18.53.Eel5xen:?:ccadm:?
-#randbs:Sun:Solaris 5.9:?:ccadm:CQ DB server/Bldforge
+rancpp01:Redhat Linux:2.6.18.53.Eel5xen::ccadm:
+rancpp02:Redhat Linux:2.6.18.53.Eel5xen::ccadm:
+rancpp03:Redhat Linux:2.6.18.53.Eel5xen::ccadm:
+rancpp10:Redhat Linux:2.6.18.53.Eel5xen::ccadm:
+#randbs:Sun:Solaris 5.9::ccadm:CQ DB server/Bldforge
randws094:Sun:Solaris 5.10:7.0.1.1:John Hartin:Old workstation
-randws103:Sun:Solaris 5.9:7.0.1.1:?:?
-randws106:Sun:Solaris 5.9:2003.06.10+:?:?
-randws113:Sun:Solaris 5.9:7.0.1.1:?:?
-randws114:Sun:Solaris 5.9:2003.06.10+:Tony Trujilo:?
+randws103:Sun:Solaris 5.9:7.0.1.1::
+randws106:Sun:Solaris 5.9:2003.06.10+::
+randws113:Sun:Solaris 5.9:7.0.1.1::
+randws114:Sun:Solaris 5.9:2003.06.10+:Tony Trujilo:
randws119:Sun:Solaris 5.9:7.0.1.1:Hy Truong:Workstation
-ranlin03:Redhat Linux:2.4.21-50.Elsmp:?:ccadm:?
-ranray:Sun:Solaris 5.9:2003.06.10+:ccadm:?
+ranlin03:Redhat Linux:2.4.21-50.Elsmp::ccadm:
+ranray:Sun:Solaris 5.9:2003.06.10+:ccadm:
--- /dev/null
+-- -----------------------------------------------------------------------------\r
+--\r
+-- File: $RCSfile: Machines.sql,v $\r
+-- Revision: $Revision: 1.$\r
+-- Description: Create the Machines database\r
+-- Author: Andrew@DeFaria.com\r
+-- Created: Fri, Jul 13, 2018 10:51:18 AM\r
+-- Modified: $Date: $\r
+-- Language: SQL\r
+--\r
+-- Copyright (c) 2010, ClearSCM, Inc., all rights reserved\r
+--\r
+-- -----------------------------------------------------------------------------\r
+-- Warning: The following line will delete the old database!\r
+-- drop database if exists machines;\r
+\r
+-- Create a new database\r
+create database machines;\r
+\r
+-- Now let's focus on this new database\r
+use machines;\r
+\r
+-- system: Define what makes up a system or machine\r
+create table system (\r
+ name varchar (255) not null,\r
+ model tinytext,\r
+ alias varchar (255),\r
+ active enum (\r
+ 'true',\r
+ 'false'\r
+ ) not null default 'true',\r
+ admin tinytext,\r
+ email tinytext,\r
+ os tinytext,\r
+ ccver tinytext,\r
+ type enum (\r
+ 'Linux',\r
+ 'Unix',\r
+ 'Windows',\r
+ 'Mac'\r
+ ) not null,\r
+ lastheardfrom datetime,\r
+ description text,\r
+\r
+ primary key (name)\r
+) engine=innodb; -- system\r
+\r
+-- package: A package is any software package that we wish to keep track of\r
+create table package (\r
+ system varchar (255) not null,\r
+ name varchar (255) not null,\r
+ version tinytext not null,\r
+ vendor tinytext,\r
+ description text,\r
+\r
+ key packageIndex (name),\r
+ key systemIndex (system),\r
+ foreign key systemLink (system) references system (name)\r
+ on delete cascade\r
+ on update cascade,\r
+ primary key (system, name)\r
+) engine=innodb; -- package\r
Provides an interface to the Clearquest database over the network.
-This library implements both the daemon portion of the server and the client
+This library implements both the daemon portion of the server and the client
API.
=head1 DESCRIPTION
A hash is passed into to the execute method, which the client should use to talk
to the server, that describes relatively simple protocol to tell the server what
action to perform. In both the read case and the read/write case a field named
-id should be defined that has a value of "<record>=<id>" (e.g.
+id should be defined that has a value of "<record>=<id>" (e.g.
"defect=BUGDB00034429").
For the read case the rest of the keys are the names of the fields to retrieve
value pairs of fields to set and their values.
Execute returns a status and a hash of name value pairs for the read case and an
-array of lines for any error messages for the read/write case.
+array of lines for any error messages for the read/write case.
=head1 ROUTINES
our $VERSION = '$Revision: 1.2 $';
($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
-
+
# Override options if in the environment
$OPTS{CQD_HOST} = $ENV{CQD_HOST}
if $ENV{CQD_HOST};
my $tag = YMDHMS;
$tag .= ' ';
$tag .= $self->{pid} ? "[$self->{pid}] " : '';
-
+
return "$tag$msg";
} # _tag
-sub _verbose ($) {
+ sub _verbose ($) {
my ($self, $msg) = @_;
verbose $self->_tag ($msg);
-
+
return;
} # _verbose
sub _debug ($) {
my ($self, $msg) = @_;
-
+
debug $self->_tag ($msg);
-
+
return;
} # _debug
sub _log ($) {
my ($self, $msg) = @_;
-
+
display $self->_tag ($msg);
-
+
return;
} # log
while (my $childpid = waitpid (-1, WNOHANG) > 0) {
my $status = $?;
-
+
debug "childpid: $childpid - status: $status";
-
+
if ($childpid != -1) {
local $SIG{CHLD} = \&_funeral;
debug "All children reaped";
} # if
} # while
-
+
return;
} # _funeral
sub _endServer () {
display "CQDService V$VERSION shutdown at " . localtime;
-
+
# Kill process group
kill 'TERM', -$$;
-
+
# Wait for all children to die
while (wait != -1) {
# do nothing
- } # while
-
+ } # while
+
# Now that we are alone, we can simply exit
exit;
} # _endServer
sub _restartServer () {
# Not sure what to do on a restart server
display 'Entered _restartServer';
-
+
return;
} # _restartServer
$host ||= $OPTS{CQD_HOST};
$port ||= $OPTS{CQD_PORT};
-
+
$self->{socket} = IO::Socket::INET->new (
Proto => 'tcp',
PeerAddr => $host,
);
return unless $self->{socket};
-
+
$self->{socket}->autoflush;
$self->{host} = $host;
if ($self->{socket}) {
close $self->{socket};
-
+
undef $self->{socket};
} # if
-
+
return;
} # disconnectFromServer
# Set autoflush for client
$client->autoflush
if $client;
-
+
# Input is simple and consists of the following:
#
# <recordType>=<ID>
#
# Notes: <ID> can be <ID_scope>. Also a += means append this fieldvalue to
# the existing value for the field.
-
+
# First get record line
my $line = <$client>;
-
+
if ($line) {
chomp $line; chop $line if $line =~ /\r$/;
} else {
$self->_verbose ("Host $host went away!");
-
+
close $client;
-
+
return;
} # if
-
+
if ($line =~ /stopserver/i) {
if ($self->{server}) {
$self->_verbose ("$host requested to stop server [$self->{server}]");
-
+
# Send server hangup signal
kill 'HUP', $self->{server};
} else {
$self->_verbose ('Shutting down server');
-
+
print $client "CQDService Status: 0\n";
-
+
exit;
} # if
} # if
my ($record, $id) = split /=/, $line;
-
+
unless ($id) {
$self->_verbose ('Garbled record line - rejected request');
-
+
close $client;
-
+
return;
} # unless
-
+
$self->_verbose ("Client wishes to deal with $id");
-
+
my $scope;
-
+
if ($id =~ /_(\S+)/) {
$scope = $1;
} # if
-
+
$self->_debug ("$host wants $record:$id");
-
+
my ($read, %fields);
-
- # Now read name/value pairs
+
+ # Now read name/value pairs
while () {
# Read command from client
- $line = <$client>;
-
+ $line = <$client>;
+
if ($line) {
chomp $line; chop $line if $line =~ /\r$/;
} else {
$self->_verbose ("Host $host went away!");
-
+
close $client;
-
+
return;
} # if
# Collect name/values. Note if only names are requested then we will instead
# return data.
my ($name, $value) = split /=/, $line;
-
+
if ($value) {
# Transform %0A's back to \n
$value =~ s/\%0A/\n/g;
-
+
$self->_verbose ("Will set $name to $value");
} else {
$read = 1;
$self->_verbose ("Will retrieve $name");
- } # if
-
+ } # if
+
$fields{$name} = $value;
} # while
-
+
# Get record
my $entity;
-
+
$self->_verbose ("Getting $record:$id");
-
+
eval { $entity = $self->{session}->GetEntity ($record, $id) };
-
+
unless ($entity) {
print $client "Unable to GetEntity $record:$id\n";
-
+
close $client;
-
+
return;
} # unless
if ($read) {
print $client "$_@@" . $entity->GetFieldValue ($_)->GetValue . "\n"
- foreach (keys %fields);
+ for (keys %fields);
print $client "CQD Status: 0\n";
-
+
close $client;
-
+
return;
} # if
-
+
# Edit record
$self->_verbose ("Editing $id");
-
+
$entity->EditEntity ('Backend');
-
+
my $status;
-
- foreach my $fieldName (keys %fields) {
+
+ for my $fieldName (keys %fields) {
if ($fieldName =~ /(.+)\*$/) {
my $newValue = delete $fields{$fieldName};
$fieldName = $1;
-
+
$fields{$fieldName} = $entity->GetFieldValue ($fieldName)->GetValue
. $newValue;
} # if
$self->_verbose ("Setting $fieldName to $fields{$fieldName}");
-
+
$status = $entity->SetFieldValue ($fieldName, $fields{$fieldName});
-
+
if ($status ne '') {
$self->_verbose ($status);
-
+
print $client "$status\n";
print $client "CQD Status: 1\n";
-
+
close $client;
-
+
return;
} # if
- } # foreach
-
+ } # for
+
$self->_verbose ("Validating $id");
-
+
$status = $entity->Validate;
-
+
if ($status eq '') {
$self->_verbose ('Committing');
$entity->Commit;
-
+
print $client "Successfully updated $id\n";
print $client "CQD Status: 0\n";
} else {
print $client "$status\n";
print $client "CQD Status: 1\n";
} # if
-
+
close $client;
-
+
$self->_verbose ("Serviced requests from $host");
-
+
return;
} # _serviceClient
sub execute (%) {
my ($self, %request) = @_;
-
+
$self->connectToServer or croak 'Unable to connect to CQD Service';
return (-1, 'Unable to talk to server')
unless $self->{socket};
-
+
my ($status, @output) = (-1, ());
-
+
my $server = $self->{socket};
-
+
my $id = delete $request{id};
-
+
print $server "$id\n";
-
+
my $read;
-
- foreach (keys %request) {
+
+ for (keys %request) {
if ($request{$_}) {
print $server "$_=$request{$_}\n";
} else {
$read = 1;
print $server "$_\n";
} # if
- } # foreach
+ } # for
print $server "end\n";
-
+
my ($response, %output);
-
+
while (defined ($response = <$server>)) {
if ($response =~ /CQD Status: (-*\d+)/) {
$status = $1;
last;
} # if
-
+
if ($read) {
chomp $response; chop $response if $response =~ /\r$/;
-
+
my ($field, $value) = split /\@\@/, $response;
-
+
$output{$field} = $value;
} else {
push @output, $response;
} # if
} # while
-
+
chomp @output unless $read;
-
+
$self->disconnectFromServer;
-
+
if ($status != 0 or $read == 0) {
return ($status, @output);
} else {
} # execute
sub startServer (;$$$$$) {
-
+
require 'Clearquest.pm';
-
+
my ($self, $port, $username, $password, $db, $dbset) = @_;
$port ||= $OPTS{CQD_PORT};
$password ||= $OPTS{CQD_PASSWORD};
$db ||= $OPTS{CQD_DATABASE};
$dbset ||= $OPTS{CQD_DBSET};
-
+
# Create new socket to communicate to clients with
$self->{socket} = IO::Socket::INET->new(
Proto => 'tcp',
# Announce ourselves
$self->_log ("CQD V$VERSION accepting clients at " . localtime);
-
+
# Now wait for an incoming request
LOOP:
my $client;
error "Can't fork: $!"
unless defined ($childpid = fork);
-
+
if ($childpid) {
$self->{pid} = $$;
=head2 ClearSCM Perl Modules
-=begin man
+=begin man
DateUtils
Display
=back
=cut
-
+
our (%RECORDS, %FIELDS);
# FieldTypes ENUM
sub _callREST ($$$;%) {
my ($self, $type, $url, $body, %parms) = @_;
-
+
# Set error and errmsg to no error
$self->error (0);
$self->{errmsg} = '';
-
+
# Upshift the call type as the calls are actually like 'GET' and not 'get'
$type = uc $type;
-
+
# We only support these call types
croak "Unknown call type \"$type\""
unless $type eq 'GET' or
$type eq 'PUT' or
$type eq 'DELETE' or
$type eq 'HEAD';
-
+
# If the caller did not give us authorization then use the login member we
# already have in the object
unless ($parms{Authorization}) {
if ($url =~ /oslc.where/) {
$parms{'OSLC-Core-Version'} = '2.0';
} # if
-
+
# Remove the host portion if any
$url =~ s/^http.*$self->{server}//;
-
+
# Call the REST call (Different calls have different numbers of parameters)
if ($type eq 'GET' or
$type eq 'DELETE' or
} else {
$self->{rest}->$type ($url, $body, \%parms);
} # if
-
+
return $self->error;
} # _callREST
sub _getRecordName ($) {
my ($self, $query) = @_;
-
+
$self->_callREST ('get', $query);
-
+
if ($self->error) {
$self->errmsg ("Unable to get record name for $query");
-
+
return;
} # if
my %record = %{XMLin ($self->{rest}->responseContent)};
-
+
return $record{element}{name};
} # _getRecordName
sub _getAttachmentList ($$) {
my ($self, $result, $fields) = @_;
-
+
croak ((caller(0))[3] . ' is not implemented');
return;
$query .= "rcm.name=$key";
$self->_callREST ('get', $query);
-
+
unless ($self->error) {
my %result = %{XMLin ($self->{rest}->responseContent)};
return $result{entry}{id};
} else {
$self->errmsg ("Record not found (Table: $table, Key: \"$key\")");
-
+
return $self->errmsg;
} # unless
} # _getInternalID
my ($self, $table, $url, @fields) = @_;
$self->{fields} = [$self->_setFields ($table, @fields)];
-
+
$self->_callREST ('get', $url);
-
+
return if $self->error;
# Now parse the results
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
if ($result{entry}{content}{$table}) {
return $self->_parseFields ($table, %{$result{entry}{content}{$table}});
} elsif (ref \%result eq 'HASH') {
# The if test above will create an empty $result{entry}{content}. We need
# to delete that
delete $result{entry};
-
+
return $self->_parseFields ($table, %result);
} else {
return;
my ($self, $table) = @_;
$self->records;
-
+
return $RECORDS{$table};
} # _getRecordID
my ($self, $table, $url, @fields) = @_;
$self->{fields} = [$self->_setFields ($table, @fields)];
-
+
$self->error ($self->_callREST ('get', $url));
-
+
return if $self->error;
-
+
return $self->_parseFields ($table, %{XMLin ($self->{rest}->responseContent)});
} # _getRecordURL
sub _getReferenceList ($$) {
my ($self, $url, $field) = @_;
-
+
$self->error ($self->_callREST ('get', $url));
-
+
return if $self->error;
-
+
my %result = %{XMLin ($self->{rest}->responseContent)};
my @values;
-
+
# Need to find the field array here...
foreach my $key (keys %result) {
if (ref $result{$key} eq 'ARRAY') {
foreach (@{$result{$key}}) {
push @values, $$_{'oslc_cm:label'};
} # foreach
-
+
last;
} elsif (ref $result{$key} eq 'HASH' and $result{$key}{'oslc_cm:label'}) {
push @values, $result{$key}{'oslc_cm:label'};
} # if
} # foreach
-
+
return @values;
} # _getReferenceList
sub _parseCondition ($$) {
my ($self, $table, $condition) = @_;
-
+
# Parse simple conditions only
my ($field, $operator, $value);
return "$field in [$value]"
} # if
} # if
-
+
if ($operator eq '=' and $value =~ /^null$/i) {
return "$field in [\"\"]";
} elsif ($operator eq '!=' and $value =~ /^null$/i) {
return "$field in [*]";
} # if
-
+
# Trim quotes if any:
if ($value =~ /^\s*\'/) {
$value =~ s/^\s*\'//;
$value =~ s/^\s*\"//;
$value =~ s/\"\s*$//;
} # if
-
+
# Trim leading and trailing whitespace
$value =~ s/^\s+//;
$value =~ s/\s+$//;
-
+
# Convert datetimes to Zulu
if ($self->fieldType ($table, $field) == $DATE_TIME and
$value !~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/) {
$value = Clearquest::_UTCTime ($value);
} # if
-
+
return "$field $operator \"$value\"";
} # _parseCondition
my ($self, $table, $condition) = @_;
return 'oslc_cm.query=' unless $condition;
-
+
my $parsedConditional;
-
+
# Special case when the condition is ultra simple
if ($condition !~ /(\w+)\s*(==|=|!=|<>|<|>|<=|>=|in|is\s+null|is\s+not\s+null)\s*(.*)/i) {
return "rcm.name=$condition";
} # if
-
+
# TODO: This section needs improvement to handle more complex conditionals
while () {
if ($condition =~ /(.+?)\s+(and|or)\s+(.+)/i) {
my $leftSide = $self->_parseCondition ($table, $1);
-
+
$parsedConditional .= "$leftSide $2 ";
$condition = $3;
} else {
$parsedConditional .= $self->_parseCondition ($table, $condition);
-
+
last;
} # if
} # while
-
+
# TODO: How would this work if we have a condition like 'f1 = "value" and
# f2 is not null'?
if ($parsedConditional =~ /in \[\*\]/) {
sub _parseFields ($%) {
my ($self, $table, %record) = @_;
-
+
foreach my $field (keys %record) {
if ($field =~ /:/ or
$field eq 'xmlns' or
grep {/^$field$/} @{$self->{fields}} == 0) {
delete $record{$field};
-
+
next;
} # if
-
+
my $fieldType = $self->fieldType ($table, $field);
if (ref $record{$field} eq 'HASH') {
$record{$field} = \@values;
} elsif ($fieldType == $ATTACHMENT_LIST) {
my @attachments = $self->_getAttachmentList ($record{$field}{'oslc_cm:collref'}, $field);
-
+
$record{$field} = \@attachments;
} elsif ($fieldType == $RECORD_TYPE) {
$record{$field} = $record{$field}{'oslc_cm:label'};
$record{$field} = undef;
} # if
} # if
-
+
$record{$field} ||= '' if $self->{emptyStringForUndef};
if ($fieldType == $DATE_TIME) {
$record{$field} = Clearquest::_UTC2Localtime $record{$field};
} # if
} # foreach
-
+
return %record;
} # _parseFields
sub _parseRecordDesc ($) {
my ($self, $table) = @_;
-
+
# Need to get fieldType info
my $recordID = $self->_getRecordID ($table);
-
+
return unless $recordID;
-
+
my $url = "$self->{uri}/record-type/$recordID";
-
+
$self->_callREST ('get', $url);
-
+
return if $self->error;
-
+
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
# Reach in deep for field definitions
my %fields = %{$result{element}{complexType}{choice}{element}};
} else {
$FIELDS{$table}{$_}{FieldType} = $UNKNOWN;
} # if
-
+
if ($fields{$_}{'cq:systemOwned'} and $fields{$_}{'cq:systemOwned'} eq 'true') {
$FIELDS{$table}{$_}{SystemField} = 1;
} else {
$FIELDS{$table}{$_}{SystemField} = 0;
} # if
} # foreach
-
- return;
+
+ return;
} # _parseRecordDesc
sub _isSystemField ($$) {
# Cause %FIELDS to be expanded for $table
$self->_parseRecordDesc ($table);
-
+
unless (@fields) {
foreach ($self->fields ($table)) {
unless ($self->{returnSystemFields}) {
next if $FIELDS{$table}{$_}{SystemField}
} # unless
-
+
push @fields, $_;
} # foreach
} # unless
-
+
push @fields, 'dbid' unless grep { /dbid/ } @fields;
return @fields;
my ($self, $table, $fieldName, $fieldValue) = @_;
return if $self->_isSystemField ($table, $fieldName);
-
+
my $xml .= "<$fieldName>";
-
+
my $fieldType = $self->fieldType ($table, $fieldName);
if ($fieldType == $STRING or
# Fix MULTILINE_STRINGs
if ($fieldType == $MULTILINE_STRING and ref $fieldValue eq 'ARRAY') {
chomp @{$fieldName};
-
+
$fieldValue= join "\n", @$fieldValue;
} # if
-
+
$xml .= escapeHTML $fieldValue;
} elsif ($fieldType == $REFERENCE) {
my $tableReferenced = $self->fieldReference ($table, $fieldName);
-
+
if ($tableReferenced) {
$xml .= $self->_getInternalID ($tableReferenced, $fieldValue);
} else {
$self->error (600);
$self->errmsg ("Could not determine reference for $fieldName");
-
+
return;
} # if
} elsif ($fieldType == $REFERENCE_LIST) {
# We'll allow either an array reference or a single value, which we will
# turn into an array
my @values;
-
+
@values = ref $fieldValue eq 'ARRAY' ? @$fieldValue
: ($fieldValue);
-
+
my $tableReferenced = $self->fieldReference ($table, $fieldName);
-
+
unless ($tableReferenced) {
$self->error (600);
$self->errmsg ("Could not determine reference for $fieldName");
-
+
return;
} # if
-
+
foreach (@values) {
my $internalID = $self->_getInternalID ($tableReferenced, $_);
} else {
$self->error (600);
$self->errmsg ("Could not find a valid/active $tableReferenced with a key of \"$_\"");
-
+
return
} # if
} # foreach
} # if
$xml .= "</$fieldName>\n";
-
+
return $xml;
} # _setFieldValue
sub _startXML ($) {
my ($table) = @_;
-
+
my $xml = << "XML";
<?xml version="1.0" encoding="UTF-8"?>
<$table
xmlns:dc="http://purl.org/dc/terms/"
xmlns:oslc_cm="http://open-services.net/xmlns/cm/1.0/">
XML
-
+
return $xml
} # _startXML
# First process all fields in the @ordering, if specified
$xml .= $self->_setFieldValue ($table, $_, $record{$_}) foreach (@ordering);
-
+
foreach my $field (keys %record) {
next if InArray $field, @ordering;
-
+
$xml .= $self->_setFieldValue ($table, $field, $record{$field});
} # foreach
-
+
$xml .= "</$table>";
-
+
$self->_callREST ('post', $uri, $xml);
# Get the DBID of the newly created record
sub connect (;$$$$) {
my ($self, $username, $password, $database, $dbset) = @_;
-
+
=pod
=head2 connect (;$$$$)
if (ref $username eq 'HASH') {
my %opts = %$username;
-
+
$self->{username} = delete $opts{CQ_USERNAME};
$self->{password} = delete $opts{CQ_PASSWORD};
$self->{database} = delete $opts{CQ_DATABASE};
$self->{database} = $database if $database;
$self->{dbset} = $dbset if $dbset;
} # if
-
+
# Set URI in case anything changed
$self->{uri} = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}";
$self->{loggedin} = 1;
-
+
return 1;
} # connect
sub connected () {
my ($self) = @_;
-
+
=pod
=head2 connected ()
=for html </blockquote>
=cut
-
+
return $self->{loggedin};
} # connected
sub delete ($$) {
my ($self, $table, $key) = @_;
-
+
=pod
=head2 delete ($table, $key)
=cut
my $query = $self->_getInternalID ($table, $key);
-
+
# Need to remove $self->{server} from beginning of $query
$query =~ s/^http.*$self->{server}//;
# global destruction (like when you die or exit), the ordering of destruction
# is unpredictable so we might not succeed.
return unless $self->{rest};
-
+
# Delete session - ignore error as there's really nothing we can do if this
# fails.
$self->_callREST ('delete', '/cqweb/oslc/session/');
-
+
croak "Unable to release REST session in destructor" if $self->error;
-
+
return;
} # DESTROY
=cut
return unless $self->{rest};
-
+
$self->_callREST ('delete', '/cqweb/oslc/session/');
-
+
return $self->error;
} # disconnect
return $self->{errmsg};
} else {
my $response = $self->response;
-
+
if ($response and $response ne '') {
my %xml = %{XMLin ($self->response)};
-
+
if ($xml{Error}{message}) {
$self->{errmsg} = $xml{Error}{message};
} elsif (ref $xml{message} ne 'HASH' and $xml{message}) {
} # if
} # if
} # if
-
+
return $self->{errmsg};
} # errmsg
sub error (;$) {
my ($self, $error) = @_;
-
+
=pod
=head2 error ($error)
=for html </blockquote>
=cut
-
-
+
if (defined $error) {
$self->{responseCode} = $error;
} else {
sub fields ($) {
my ($self, $table) = @_;
-
+
=pod
=head2 fields ($table)
=cut
my $recordID = $self->_getRecordID ($table);
-
+
return unless $recordID;
-
+
my $url = "$self->{uri}/record-type/$recordID";
$self->_callREST ('get', $url);
-
+
return if $self->error;
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
my @fields = keys %{$result{element}{complexType}{choice}{element}};
-
+
return @fields;
} # fields
=for html </blockquote>
=cut
-
+
# If we've already computed the fieldTypes for the fields in this table then
# return the value
if ($FIELDS{$table}) {
sub find ($;$@) {
my ($self, $table, $condition, @fields) = @_;
-
+
=pod
=head2 find ($;$@)
$self->{url} = "$self->{uri}/record/?rcm.type=$table&"
. $self->_parseConditional ($table, $condition);
-
+
@fields = $self->_setFields ($table, @fields);
-
+
# Remove dbid for find
@fields = grep { $_ ne 'dbid' } @fields;
-
+
if (@fields) {
$self->{url} .= "&oslc_cm.properties=";
$self->{url} .= join ',', @fields;
} # if
-
+
# Save some fields for getNext
$self->{fields} = \@fields;
$self->{table} = $table;
-
+
$self->{url} .= "&oslc_cm.pageSize=1";
-
+
return $self->{url} unless wantarray;
-
+
# If the user wants an array then he wants ($reesult, $nbrRecs) and so we need
# to go out and get that info.
$self->_callREST ('get', $self->{url});
-
+
return (undef, 0) if $self->error;
# Now parse the results
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
return ($self->{url}, $result{'oslc_cm:totalCount'}{content});
} # find
sub getDBID ($$;@) {
my ($self, $table, $dbid, @fields) = @_;
-
+
=pod
=head2 get ($table, $key, @fields)
$url .= $self->_getRecordID ($table);
$url .= '-';
$url .= $dbid;
-
+
if (@fields) {
$url .= "?oslc_cm.properties=";
$url .= 'dbid,' unless grep { /dbid/i } @fields;
$url .= join ',', @fields;
} # if
-
+
return $self->_getRecord ($table, $url);
} # getDBID
sub getNext ($) {
my ($self, $result) = @_;
-
+
=pod
=head2 getNext ($)
=for html </blockquote>
=cut
-
+
return unless $self->{url};
-
+
my $url = $self->{url};
$self->_callREST ('get', $url);
-
+
return if $self->error;
# Now parse the results
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
# Get the next link
undef $self->{url};
-
+
if (ref $result{link} eq 'ARRAY') {
foreach (@{$result{link}}) {
if ($$_{rel} eq 'next') {
($self->{url}) = ($$_{href} =~ /^http.*$self->{server}(.*)/);
-
+
last;
} # if
} # foreach
} # if
-
+
my %record;
-
+
if (ref $result{entry}{content}{$self->{table}} eq 'HASH') {
%record = $self->_parseFields ($self->{table}, %{$result{entry}{content}{$self->{table}}});
} elsif (ref $result{entry} eq 'HASH') {
%record = $self->_getRecordURL ($self->{table}, $result{entry}{id}, @{$self->{fields}});
} # if
} # if
-
+
# Get dbid
if ($result{entry}{link}{href} =~ /-(\d+)$/) {
$record{dbid} = $1;
} # if
-
+
return %record;
} # getNext
sub key ($$) {
my ($self, $table, $dbid) = @_;
-
+
=pod
=head2 key ($$)
sub modify ($$$$;@) {
my ($self, $table, $key, $action, $values, @ordering) = @_;
-
+
=pod
=head2 modify ($table, $key, $action, $values, @ordering)
my %values = %$values;
my $xml = _startXML $table;
-
+
$action ||= 'Modify';
-
+
my $query = $self->_getInternalID ($table, $key);
-
+
# Remove host portion
$query =~ s/^http.*$self->{server}//;
-
+
# Add on action
$query .= "?rcm.action=$action";
-
+
# First process all fields in the @ordering, if specified
$xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
-
+
foreach my $field (keys %values) {
next if InArray $field, @ordering;
-
+
$xml .= $self->_setFieldValue ($table, $field, $values{$field});
} # foreach
-
+
$xml .= "</$table>";
$self->_callREST ('put', $query, $xml);
-
+
return $self->errmsg;
} # modify
sub modifyDBID ($$$$;@) {
my ($self, $table, $dbid, $action, $values, @ordering) = @_;
-
+
=pod
=head2 modifyDBID ($table, $dbid, $action, %update)
my %values = %$values;
my $xml = _startXML $table;
-
+
$action ||= 'Modify';
-
+
my $query = "$self->{uri}/record/";
$query .= $self->_getRecordID ($table);
$query .= '-';
$query .= $dbid;
-
+
# Add on action
$query .= "?rcm.action=$action";
-
+
# First process all fields in the @ordering, if specified
$xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
-
+
foreach my $field (keys %values) {
next if InArray $field, @ordering;
-
+
$xml .= $self->_setFieldValue ($table, $field, $values{$field});
} # foreach
-
+
$xml .= "</$table>";
$self->_callREST ('put', $query, $xml);
-
+
return $self->errmsg;
} # modifyDBID
sub new (;%) {
my ($class, $self) = @_;
-
+
=pod
=head2 new (%parms)
=cut
$self->{server} ||= $Clearquest::OPTS{CQ_SERVER};
-
+
$$self{base_url} = "$self->{server}/cqweb/oslc",
$$self{uri} = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}",
$$self{login} = {
Authorization => 'Basic '
. encode_base64 "$self->{username}:$self->{password}",
};
-
+
bless $self, $class;
-
+
# We create this UserAgent and Cookie Jar so we can set cookies to be
# remembered and passed back and forth automatically. By doing this we re-use
# the JSESSIONID cookie we allows us to reuse our login and to dispose of the
# login session properly when we are destroyed.
my $userAgent = LWP::UserAgent->new;
-
+
# Set the cookie jar to use in-memory cookie management, cookies can be
# persisted to disk, see HTTP::Cookies for more info.
$userAgent->cookie_jar (HTTP::Cookies->new);
-
+
$self->{rest} = REST::Client->new (
host => $self->{server},
timeout => 15,
sub records () {
my ($self) = @_;
-
+
=pod
=head2 records ()
=cut
return if %RECORDS;
-
+
my $url = "$self->{uri}/record-type/";
$self->_callREST ('get', $url);
-
+
unless ($self->error) {
my %result = %{XMLin ($self->{rest}->responseContent)};
foreach my $uri (keys %{$result{entry}}) {
my ($recordID) = ($uri =~ /\/(\d+)/);
-
+
$RECORDS{$result{entry}{$uri}{title}} = $recordID;
} # foreach
} # unless
-
+
return %RECORDS;
} # records
sub response () {
my ($self) = @_;
-
+
=pod
=head2 response ()
my ($class, %parms) = @_;
my $self;
-
+
$parms{CQ_DATABASE} ||= $Clearquest::OPTS{CQ_DATABASE};
$parms{CQ_USERNAME} ||= $Clearquest::OPTS{CQ_USERNAME};
$parms{CQ_PASSWORD} ||= $Clearquest::OPTS{CQ_PASSWORD};
$parms{CQ_DBSET} ||= $Clearquest::OPTS{CQ_DBSET};
$parms{CQ_SERVER} ||= $Clearquest::OPTS{CQ_SERVER};
$parms{CQ_PORT} ||= $Clearquest::OPTS{CQ_PORT};
-
+
$parms{CQ_MULTITHREADED} = $Clearquest::OPTS{CQ_MULTITHREADED}
unless defined $parms{CQ_MULTITHREADED};
$self->{port} = $parms{CQ_PORT};
$self->{module} = $parms{CQ_MODULE};
$self->{multithreaded} = $parms{CQ_MULTITHREADED};
-
+
return bless $self, $class;
} # new
my $tag = YMDHMS;
$tag .= ' ';
$tag .= $self->{pid} ? '[' . abs ($self->{pid}) . '] ' : '';
-
+
return "$tag$msg";
} # _tag
my ($self, $msg) = @_;
verbose $self->_tag ($msg);
-
+
return;
} # _verbose
sub _debug ($) {
my ($self, $msg) = @_;
-
+
debug $self->_tag ($msg);
-
+
return;
} # _debug
sub _log ($) {
my ($self, $msg) = @_;
-
+
display $self->_tag ($msg);
-
+
return;
} # log
sub _funeral () {
debug "Entered _funeral";
-
+
while (my $childpid = waitpid (-1, WNOHANG) > 0) {
my $status = $?;
-
+
if ($childpid != -1) {
local $SIG{CHLD} = \&_funeral;
if $status;
} # if
} # while
-
+
return;
} # _funeral
sub _endServer () {
display "Clearquest::Server V$VERSION shutdown at " . localtime;
-
+
# Kill process group
kill 'TERM', -$$;
-
+
# Wait for all children to die
while (wait != -1) {
# do nothing
} # while
-
+
# Now that we are alone, we can simply exit
exit;
} # _endServer
sub _restartServer () {
# Not sure what to do on a restart server
display 'Entered _restartServer';
-
+
return;
} # _restartServer
sub _printStatus ($) {
my ($self, $client) = @_;
-
+
my $status = $self->{clearquest}->error;
-
+
$status ||= 0;
-
+
$self->_debug ("Printing status: " . __PACKAGE__ . " Status: $status");
-
+
print $client __PACKAGE__ . " Status: $status\n";
-
+
$self->_debug ("After print");
-
+
return;
} # printStatus
sub _connectToClearquest ($$$$) {
my ($self, $database, $username, $password, $dbset) = @_;
-
+
my %parms;
-
+
$parms{CQ_DATABASE} = $database;
$parms{CQ_USERNAME} = $username;
$parms{CQ_PASSWORD} = $password;
$parms{CQ_DBSET} = $dbset;
-
+
# The server always uses the standard Clearquest API
$parms{CQ_MODULE} = 'api';
-
+
# Connect to Clearquest database
$self->{clearquest} = Clearquest->new (%parms);
. " for $self->{clientname}");
$self->{loggedin} = $self->{clearquest}->connect;
-
+
return $self->{loggedin};
} # _connectToClearquest
sub _processCommand ($$@) {
my ($self, $client, $call, @parms) = @_;
-
+
$self->_debug ("Client wishes to execute $call");
if ($call eq 'end') {
$self->_verbose ("Serviced requests from $self->{clientname}");
-
+
close $client;
$self->disconnectFromClient;
-
+
return 1;
} elsif ($call eq 'open') {
debug "connectToClearquest";
$self->_printStatus ($client);
} elsif ($call eq 'get') {
my %record = $self->{clearquest}->get (@parms);
-
+
unless ($self->{clearquest}->error) {
foreach my $field (keys %record) {
# TODO: Need to handle field types better...
foreach (@{$record{$field}}) {
# Change \n's to
s/\r\n/ /gm;
-
+
print $client "$field\@\@$_\n";
} # foreach
} else {
# Change \n's to
$record{$field} =~ s/\r\n/ /gm;
-
+
print $client "$field\@\@$record{$field}\n";
} # if
} # foreach
} else {
print $client $self->{clearquest}->errmsg . "\n";
} # unless
-
+
$self->_printStatus ($client);
} elsif ($call eq 'find') {
my ($result, $nbrRecs) = $self->{clearquest}->find (@parms);
} else {
# Store away $result so we can use it later
$self->{result} = $result;
-
+
print $client "$result\n$nbrRecs\n";
} # if
$self->_printStatus ($client);
} elsif ($call eq 'getnext') {
my %record = $self->{clearquest}->getNext ($self->{result});
-
+
unless ($self->{clearquest}->error) {
foreach my $field (keys %record) {
# TODO: Need to handle field types better...
foreach (@{$record{$field}}) {
# Change \n's to
s/\r\n/ /gm;
-
+
print $client "$field\@\@$_\n";
} # foreach
} else {
# Change \n's to
$record{$field} =~ s/\r\n/ /gm;
-
+
print $client "$field\@\@$record{$field}\n";
} # if
} # foreach
} else {
print $client $self->{clearquest}->errmsg . "\n";
} # unless
-
+
$self->_printStatus ($client);
} elsif ($call eq 'getdynamiclist') {
# TODO Better error handling/testing
my @entry = $self->{clearquest}->getDynamicList (@parms);
-
+
print $client "$_\n" foreach @entry;
-
+
$self->_printStatus ($client);
} elsif ($call eq 'dbsets') {
# TODO Better error handling/testing
print $client "$_\n" foreach ($self->{clearquest}->DBSets);
-
+
$self->_printStatus ($client);
} elsif ($call eq 'key') {
# TODO Better error handling/testing
print $client $self->{clearquest}->key (@parms) . "\n";
-
+
$self->_printStatus ($client);
} elsif ($call eq 'modify' or $call eq 'modifyDBID') {
my $table = shift @parms;
my $action = shift @parms;
# Need to turn off strict for eval here...
- my ($values, @ordering);
+ my ($values, @ordering);
no strict;
eval $parms[0];
-
+
$values = $VAR1;
use strict;
-
+
@ordering = @{$parms[1]} if ref $parms[1] eq 'ARRAY';
-
+
my $errmsg;
-
+
if ($call eq 'modify') {
$errmsg = $self->{clearquest}->modify ($table, $key, $action, $values, @ordering);
} elsif ($call eq 'modifyDBID') {
$errmsg = $self->{clearquest}->modifyDBID ($table, $key, $action, $values, @ordering);
} # if
-
+
print $client "$errmsg\n" if $errmsg ne '';
$self->_printStatus ($client);
} elsif ($call eq 'add') {
my $dbid = $self->{clearquest}->add (@parms);
-
+
if ($self->{clearquest}->error) {
print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
} # if
} else {
$self->{clearquest}->{errnbr} = -1;
$self->{clearquest}->{errmsg} = "Unknown call $call";
-
+
print $client $self->{clearquest}->errmsg . "\n";
-
+
$self->_printStatus ($client);
} # if
-
+
return;
} # _processCommand
# Set autoflush for client
$client->autoflush if $client;
-
+
my $line;
-
+
$self->_debug ("Reading request from client");
-
+
while ($line = <$client>) {
$self->_debug ("Request read: $line");
-
+
if ($line) {
chomp $line; chop $line if $line =~ /\r$/;
} else {
$self->_verbose ("Host $self->{clientname} went away!");
-
+
close $client;
-
+
return;
} # if
if ($line =~ /^shutdown/i) {
if ($self->{server}) {
$self->_verbose ("$self->{clientname} requested to shutdown the server");
-
+
print $client __PACKAGE__ . " Status: 0\n";
} # if
exit 1;
} # if
-
+
# Parse command line
my ($call, @parms);
-
+
if ($line =~ /^\s*(\S+)\s+(.*)/) {
$call = lc $1;
-
+
no strict;
eval $2;
-
+
@parms = @$VAR1;
use strict;
-
+
my $i = 0;
-
+
foreach (@parms) {
if (/^\$VAR1/) {
no strict;
eval;
-
+
$parms[$i++] = $VAR1;
use strict;
} else {
@parms = ();
} else {
my $errmsg = "Garbled command line: '$line'";
-
+
if ($self->{clearquest}) {
$self->{clearquest}->{errnbr} = -1;
$self->{clearquest}->{errmsg} = $errmsg;
} else {
print "$errmsg\n";
} # if
-
+
$self->_printStatus ($client);
-
+
return;
} # if
-
+
$self->_debug ("Processing command $call @parms");
-
+
last if $self->_processCommand ($client, $call, @parms);
} # while
-
+
return;
} # _serviceClient
my ($self, $newValue) = @_;
my $oldValue = $self->{multithreaded};
-
+
$self->{multithreaded} = $newValue if $newValue;
-
+
return $oldValue
} # multithreaded
$self->_verbose ("Disconnected from client $self->{clientname}")
if $self->{clientname};
-
+
undef $self->{clientname};
-
+
return;
} # disconnectFromClient
sub DESTROY () {
my ($self) = @_;
-
- $self->disconnectFromClient;
-
+
+ $self->disconnectFromClient;
+
if ($self->{socket}) {
- close $self->{socket};
-
- undef $self->{socket};
- } # if
+ close $self->{socket};
+
+ undef $self->{socket};
+ } # if
} # DESTROY
-
+
sub startServer () {
my ($self) = @_;
-
+
# Create new socket to communicate to clients with
$self->{socket} = IO::Socket::INET->new (
Proto => 'tcp',
# Announce ourselves
$self->_log (__PACKAGE__ . " V$VERSION accepting clients at " . localtime);
-
+
$SIG{HUP} = \&_endServer;
-
+
# Now wait for an incoming request
my $client;
} else {
error "Accept called failed (Error: $?) - $!", 1;
} # if
- } # if
-
+ } # if
+
my $hostinfo = gethostbyaddr $client->peeraddr;
-
+
$self->{clientname} = $hostinfo ? $hostinfo->name : $client->peerhost;
$self->_verbose ("$self->{clientname} is requesting service");
error "Can't fork: $!"
unless defined ($childpid = fork);
-
+
if ($childpid) {
$self->{pid} = $$;
} else {
# In child process - ServiceClient
$self->{pid} = $$;
-
+
# Now exec the caller but set STDIN to be the socket. Also pass
# -serviceClient to the caller which will need to handle that and call
# _serviceClient.
$self->_debug ("Client: $client");
open STDIN, '+<&', $client
or croak "Unable to dup client";
-
+
my $cmd = "cqperl \"$FindBin::Bin/$FindBin::Script -serviceClient=$self->{clientname} -verbose -debug";
-
+
$self->_debug ("Execing: $cmd");
-
+
exec 'cqperl', "\"$FindBin::Bin/$FindBin::Script\"", "-serviceClient=$self->{clientname}", '-verbose', '-debug'
or croak "Unable to exec $cmd";
} # if
$self->_serviceClient ($client);
} # if
} # while
-
+
# On Windows we can't catch SIGCHLD so we need to loop around. Ugly!
goto LOOP if $^O =~ /win/i;
} # startServer
--- /dev/null
+=pod\r
+\r
+=head1 NAME $RCSfile: Machines.pm,v $\r
+\r
+Object oriented interface to list of managed machines\r
+\r
+=head1 VERSION\r
+\r
+=over\r
+\r
+=item Author:\r
+\r
+Andrew DeFaria <Andrew@DeFaria.com>\r
+\r
+=item Revision:\r
+\r
+$Revision: 1.0 $\r
+\r
+=item Created:\r
+\r
+Thu, Jul 12, 2018 5:11:44 PM\r
+\r
+=item Modified:\r
+\r
+$Date: $\r
+\r
+=back\r
+\r
+=head1 SYNOPSIS\r
+\r
+Perl module to specify a list of managed machines for rexec.pl\r
+\r
+ $machines = Machines->new (filename => "/opt/clearscm/data/machines");\r
+\r
+ my @machines = $machines->all;\r
+\r
+ my @linux_machines = $machines->select(condition => 'OS = "linux"');\r
+\r
+=head1 DESCRIPTION\r
+\r
+Machines is an OO interface to a list of managed machines. By default it parses\r
+a file that contains machine names and other identifying information.\r
+\r
+=head1 ROUTINES\r
+\r
+The following routines are exported:\r
+\r
+=cut\r
+\r
+package Machines;\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use base 'Exporter';\r
+\r
+use Carp;\r
+\r
+sub _parseFile() {\r
+ my ($self) = @_;\r
+\r
+ my %machines;\r
+\r
+ # Simple parse for now\r
+ open my $machineFile, '<', $self->{filename}\r
+ or croak "Unable to open $self->{filename} - $!";\r
+\r
+ while (<$machineFile>) {\r
+ chomp;\r
+\r
+ next if /^#/; # Skip comments\r
+\r
+ my ($name, $model, $os, $ccver, $owner, $usage) = split /:/;\r
+\r
+ my %machineInfo = (\r
+ model => $model,\r
+ os => $os,\r
+ ccver => $ccver,\r
+ owner => $owner,\r
+ usage => $usage,\r
+ );\r
+\r
+ $machines{$name} = \%machineInfo;\r
+ } # while\r
+\r
+ close $machineFile;\r
+\r
+ return \%machines;\r
+} # _parseFile\r
+\r
+sub new(;%){\r
+ my ($class, %parms) = @_;\r
+\r
+=pod\r
+\r
+=head2 new (<parms>)\r
+\r
+Construct a new Machines object. The following OO style arguments are\r
+supported:\r
+\r
+Parameters:\r
+\r
+=for html <blockquote>\r
+\r
+=over\r
+\r
+=item filename:\r
+\r
+Filename to parse\r
+\r
+=item path:\r
+\r
+Path where file resides\r
+\r
+=back\r
+\r
+=for html </blockquote>\r
+\r
+Returns::\r
+\r
+=for html <blockquote>\r
+\r
+=over\r
+\r
+=item Machines object\r
+\r
+=back\r
+\r
+=for html </blockquote>\r
+\r
+=cut\r
+\r
+ $parms{filename} ||= 'machines';\r
+\r
+ if (! -r $parms{filename}) {\r
+ croak "Unable to read $parms{filename}";\r
+ } # if\r
+\r
+ my $self = bless {\r
+ filename => $parms{filename},\r
+ }, $class; # bless\r
+\r
+ # Parse file\r
+ $self->{machines} = $self->_parseFile;\r
+\r
+ return $self;\r
+} # new\r
+\r
+sub select(;$) {\r
+ my ($self, $condition) = @_;\r
+\r
+=pod\r
+\r
+=head3 select\r
+\r
+Return machines that qualify based on $condition\r
+\r
+Parameters:\r
+\r
+=for html <blockquote>\r
+\r
+=over\r
+\r
+=item $condition\r
+\r
+Condition to apply to machine list\r
+\r
+=back\r
+\r
+=for html </blockquote>\r
+\r
+Returns:\r
+\r
+=for html <blockquote>\r
+\r
+=over\r
+\r
+=item Array of qualifying machines\r
+\r
+=back\r
+\r
+=for html </blockquote>\r
+\r
+=cut\r
+\r
+ $condition //= '';\r
+\r
+ if ($condition) {\r
+ croak "Not supporting conditions yet";\r
+ } else {\r
+ return %{$self->{machines}};\r
+ } # if\r
+} # select\r
+\r
+sub GetSystem($) {\r
+ my ($self, $systemName) = @_;\r
+\r
+ return;\r
+} # getSystem\r
+\r
+sub AddSystem(%) {\r
+ my ($self, %system) = @_;\r
+\r
+ return;\r
+} # addSystem\r
+\r
+sub ChangeSystem(%){\r
+ my ($self, %system) = @_;\r
+\r
+ return;\r
+} # changeSystem\r
+\r
+sub DeleteSystem($) {\r
+ my ($self, $systemName) = @_;\r
+\r
+ return;\r
+} # deleteSystem\r
+\r
+sub DumpSystems(;$) {\r
+ my ($self, $filename) = @_;\r
+\r
+ $filename ||= 'machines';\r
+\r
+ open my $file, '>', $filename\r
+ or croak "Unable to open $filename for writing - $!";\r
+\r
+ # Write header\r
+ print $file <<"END";\r
+################################################################################\r
+#\r
+# File: $filename\r
+# Description: Dump of machines for use with rexec.pl\r
+# Author: Andrew\@DeFaria.com\r
+#\r
+################################################################################\r
+# Column 1 Machine name\r
+# Column 2 Alias\r
+# Column 3 Active\r
+# Column 4 Admin name\r
+# Column 5 Admin email\r
+# Column 6 OS version\r
+# Column 7 OS Type\r
+# Column 8 Last heard from\r
+# Column 9 Description\r
+END\r
+\r
+ # Write out machine info\r
+ my @fields = qw(name alias active admin email os type lastheardfrom description);\r
+\r
+ for my $record ($self->select) {\r
+ my %machine = %$record;\r
+\r
+ for (@fields) {\r
+ print $file "$machine{$_}|"\r
+ } # for\r
+\r
+ print $file "\n";\r
+ } # for\r
+\r
+ close $file;\r
+\r
+ return;\r
+} # DumpSystems\r
+\r
+sub ReadSystemsFile(;$) {\r
+ my ($self, $filename) = @_;\r
+\r
+ $filename ||= 'machines';\r
+\r
+ open my $file, '<', $filename\r
+ or croak "Unable to open $filename - $!";\r
+\r
+ my @systems;\r
+\r
+ while (<$file>) {\r
+ chomp;\r
+\r
+ next if /^#/;\r
+\r
+ my ($name, $model, $osver, $ccver, $owner, $usage) = split ':';\r
+ my %system = (\r
+ name => $name,\r
+ model => $model,\r
+ ccver => $ccver,\r
+ admin => $owner,\r
+ os => $osver,\r
+ type => 'Unix',\r
+ description => $usage,\r
+ );\r
+\r
+ push @systems, \%system;\r
+ } # while\r
+\r
+ close $file;\r
+\r
+ return @systems;\r
+} # ReadSystemsFile\r
+\r
+1;\r
+\r
+=pod\r
+\r
+=head2 CONFIGURATION AND ENVIRONMENT\r
+\r
+DEBUG: If set then $debug in this module is set.\r
+\r
+VERBOSE: If set then $verbose in this module is set.\r
+\r
+=head2 DEPENDENCIES\r
+\r
+=head3 Perl Modules\r
+\r
+L<File::Spec>\r
+\r
+L<IO::Handle>\r
+\r
+=head3 ClearSCM Perl Modules\r
+\r
+=for html <p><a href="/php/scm_man.php?file=lib/DateUtils.pm">DateUtils</a></p>\r
+\r
+=for html <p><a href="/php/scm_man.php?file=lib/Display.pm">Display</a></p>\r
+\r
+=for html <p><a href="/php/scm_man.php?file=lib/Mail.pm">Mail</a></p>\r
+\r
+=for html <p><a href="/php/scm_man.php?file=lib/OSDep.pm">OSDep</a></p>\r
+\r
+=for html <p><a href="/php/scm_man.php?file=lib/Utils.pm">Utils</a></p>\r
+\r
+=head2 INCOMPATABILITIES\r
+\r
+None yet...\r
+\r
+=head2 BUGS AND LIMITATIONS\r
+\r
+There are no known bugs in this module.\r
+\r
+Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.\r
+\r
+=head2 LICENSE AND COPYRIGHT\r
+\r
+This Perl Module is freely available; you can redistribute it and/or\r
+modify it under the terms of the GNU General Public License as\r
+published by the Free Software Foundation; either version 2 of the\r
+License, or (at your option) any later version.\r
+\r
+This Perl Module is distributed in the hope that it will be useful,\r
+but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\r
+General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more\r
+details.\r
+\r
+You should have received a copy of the GNU General Public License\r
+along with this Perl Module; if not, write to the Free Software Foundation,\r
+Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.\r
+reserved.\r
+\r
+=cut\r
--- /dev/null
+=pod\r
+\r
+=head1 NAME $RCSfile: MySQL.pm,v $\r
+\r
+MySQL Backend for Machines module\r
+\r
+=head1 VERSION\r
+\r
+=over\r
+\r
+=item Author\r
+\r
+Andrew DeFaria <Andrew@DeFaria.com>\r
+\r
+=item Revision\r
+\r
+$Revision: $\r
+\r
+=item Created\r
+\r
+Mon, Jul 16, 2018 10:13:12 AM\r
+\r
+=item Modified\r
+\r
+$Date: $\r
+\r
+=back\r
+\r
+=head1 SYNOPSIS\r
+\r
+Interfaces to a MySQL backend for machine information\r
+\r
+=head1 DESCRIPTION\r
+\r
+The rexec.pl script allows you to execute an arbitrary command on a set of\r
+machines, however what set of machines? Primative exeuction involves just a\r
+flat file with machine information listed in it. This module instead provides\r
+a MySQL backend for this machine data.\r
+\r
+=head1 ROUTINES\r
+\r
+The following methods are available:\r
+\r
+=cut\r
+\r
+package Machines::MySQL;\r
+\r
+use strict;\r
+use warnings;\r
+\r
+use Carp;\r
+use DBI;\r
+\r
+use parent qw(Machines);\r
+\r
+our $VERSION = '$Revision: 1.0 $';\r
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);\r
+\r
+my %MACHINEOPTS = (\r
+ SERVER => 'localhost',\r
+ USERNAME => 'machines',\r
+ PASSWORD => 'w0rk$harder',\r
+);\r
+\r
+sub _connect (;$) {\r
+ my ($self, $dbserver) = @_;\r
+\r
+ $dbserver ||= $MACHINEOPTS{SERVER};\r
+\r
+ my $dbname = 'machines';\r
+ my $dbdriver = 'mysql';\r
+\r
+ $self->{db} = DBI->connect (\r
+ "DBI:$dbdriver:$dbname:$dbserver",\r
+ $MACHINEOPTS{USERNAME},\r
+ $MACHINEOPTS{PASSWORD},\r
+ {PrintError => 0},\r
+ ) or croak (\r
+ "Couldn't connect to $dbname database "\r
+ . "as $MACHINEOPTS{USERNAME}\@$MACHINEOPTS{SERVER}"\r
+ );\r
+\r
+ $self->{dbserver} = $dbserver;\r
+\r
+ return;\r
+} # _connect\r
+\r
+sub _checkRequiredFields ($$) {\r
+ my ($fields, $rec) = @_;\r
+\r
+ for my $fieldname (@$fields) {\r
+ my $found = 0;\r
+\r
+ for (keys %$rec) {\r
+ if ($fieldname eq $_) {\r
+ $found = 1;\r
+ last;\r
+ } # if\r
+ } # for\r
+\r
+ return "$fieldname is required"\r
+ unless $found;\r
+ } # for\r
+\r
+ return;\r
+} # _checkRequiredFields\r
+\r
+# Internal methods\r
+sub _dberror ($$) {\r
+ my ($self, $msg, $statement) = @_;\r
+\r
+ my $dberr = $self->{db}->err;\r
+ my $dberrmsg = $self->{db}->errstr;\r
+\r
+ $dberr ||= 0;\r
+ $dberrmsg ||= 'Success';\r
+\r
+ my $message = '';\r
+\r
+ if ($dberr) {\r
+ my $function = (caller (1)) [3];\r
+\r
+ $message = "$function: $msg\nError #$dberr: $dberrmsg\n"\r
+ . "SQL Statement: $statement";\r
+ } # if\r
+\r
+ return $dberr, $message;\r
+} # _dberror\r
+\r
+sub _formatValues (@) {\r
+ my ($self, @values) = @_;\r
+\r
+ my @returnValues;\r
+\r
+ # Quote data values\r
+ push @returnValues, $_ eq '' ? 'null' : $self->{db}->quote ($_)\r
+ for (@values);\r
+\r
+ return @returnValues;\r
+} # _formatValues\r
+\r
+sub _formatNameValues (%) {\r
+ my ($self, %rec) = @_;\r
+\r
+ my @nameValueStrs;\r
+\r
+ push @nameValueStrs, "$_=" . $self->{db}->quote ($rec{$_})\r
+ for (keys %rec);\r
+\r
+ return @nameValueStrs;\r
+} # _formatNameValues\r
+\r
+sub _addRecord ($%) {\r
+ my ($self, $table, %rec) = @_;\r
+\r
+ my $statement = "insert into $table (";\r
+ $statement .= join ',', keys %rec;\r
+ $statement .= ') values (';\r
+ $statement .= join ',', $self->_formatValues (values %rec);\r
+ $statement .= ')';\r
+\r
+ my ($err, $msg);\r
+\r
+ $self->{db}->do ($statement);\r
+\r
+ return $self->_dberror ("Unable to add record to $table", $statement);\r
+} # _addRecord\r
+\r
+sub _getRecords ($;$) {\r
+ my ($self, $table, $condition) = @_;\r
+\r
+ my ($err, $msg);\r
+\r
+ my $statement = "select * from $table";\r
+\r
+ if ($condition) {\r
+ $condition .= ' and ';\r
+ } # if\r
+\r
+ $condition .= 'active = "true"';\r
+ $statement .= " where $condition";\r
+\r
+ my $sth = $self->{db}->prepare($statement);\r
+\r
+ unless ($sth) {\r
+ ($err, $msg) = $self->_dberror('Unable to prepare statement', $statement);\r
+\r
+ croak $msg;\r
+ } # if\r
+\r
+ my $status = $sth->execute;\r
+\r
+ ($err, $msg) = $self->_dberror ('Unable to execute statement', $statement);\r
+\r
+ return ($err, $msg) if $err;\r
+\r
+ my %records;\r
+\r
+ while (my $row = $sth->fetchrow_hashref) {\r
+ # Change undef to ''\r
+ $row->{$_} ||= '' for keys %$row;\r
+\r
+ my $name = delete $row->{name};\r
+\r
+ $records{$name} = $row;\r
+ } # while\r
+\r
+ return %records;\r
+} # _getRecord\r
+\r
+sub new (;$) {\r
+ my ($class, $db) = @_;\r
+\r
+ my $self = bless {}, $class;\r
+\r
+ $self->_connect ($db);\r
+\r
+ return $self;\r
+} # new\r
+\r
+sub select(;$) {\r
+ my ($self, $condition) = @_;\r
+\r
+ return $self->_getRecords('system', $condition);\r
+} # select\r
+\r
+sub AddSystem (%) {\r
+ my ($self, %system) = @_;\r
+\r
+ my @requiredFields = (\r
+ 'name',\r
+ 'type',\r
+ );\r
+\r
+ my $result = _checkRequiredFields \@requiredFields, \%system;\r
+\r
+ return -1, "AddSystem: $result" if $result;\r
+\r
+ return $self->_addRecord ('system', %system);\r
+} # AddSystem\r
+\r
+1;
\ No newline at end of file
[push]
default = simple
+[http]
+ sslVerify = false
################################################################################
#
# File: $RCSfile: system,v $
-# Revision: $Revision: 1.6 $
+# Revision: $Revision: 1.6 $
# Description: System specific settings
# Author: Andrew@DeFaria.com
# Created: Mon Aug 20 17:35:01 2001
projects / clearscm.git / commitdiff