Subversion Repositories DevTools

Rev

Rev 6779 | Rev 7389 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
1038 dpurdie 1 
#! /usr/bin/perl
2 
########################################################################
3 
# Copyright (C) 2011 Vix-ERG Limited, All rights reserved
4 
#
5 
# Module name   : blatDaemon.pl
6 
# Module type   :
7 
# Compiler(s)   : Perl
8 
# Environment(s):
9 
#
10 
# Description   :
11 
#
12 
# Usage         :   ARGV[0] - Path to config file for this instance
13 
#
14 
#......................................................................#
15 
 
16 
require 5.008_002;
17 
use strict;
18 
use warnings;
19 
use Getopt::Long;
20 
use File::Basename;
1040 dpurdie 21 
use Data::Dumper;
22 
use File::Spec::Functions;
1038 dpurdie 23 
use POSIX ":sys_wait_h";
24 
use File::Temp qw/tempfile/;
6320 dpurdie 25 
use Digest::MD5;
1038 dpurdie 26 
 
27 
use FindBin;                                    # Determine the current directory
28 
use lib "$FindBin::Bin/lib";                    # Allow local libraries
29 
 
30 
use Utils;
31 
use StdLogger;                                  # Log to sdtout
32 
use Logger;                                     # Log to file
33 
 
34 
#
35 
#   Database interface
36 
#   Pinched from jats and modified so that this software is not dependent on JATS
37 
#
38 
use IO::Handle;
39 
use JatsRmApi;
40 
use DBI;
41 
 
42 
#
43 
#   Globals
44 
#
45 
my $logger = StdLogger->new();                  # Stdout logger. Only during config
6475 dpurdie 46 
$logger->err("No config file specified") unless (defined $ARGV[0]);
7387 dpurdie 47 
$logger->err("Config File does not exist: $ARGV[0]") unless (-f $ARGV[0]);
1038 dpurdie 48 
my $name = basename( $ARGV[0]);
49 
   $name =~ s~.conf$~~;
50 
my $now = 0;
5398 dpurdie 51 
my $startTime = 0;
3515 dpurdie 52 
my $tar = 'tar';
53 
my $gzip = 'gzip';
1038 dpurdie 54 
my $tagDirTime = 0;
55 
my $lastDirScan = 0;
56 
my $lastReleaseScan = 0;
1040 dpurdie 57 
my $releaseScanMode = 0;
6779 dpurdie 58 
my $lastTagListUpdate = 0;
6776 dpurdie 59 
my $lastRmConfRead = 0;
60 
my $lastRmConfFullRead = 0;
61 
my $lastRmSeqNum = 0;
1038 dpurdie 62 
my $mtimeConfig = 0;
63 
my $conf;
64 
my $extraPkgs;
1040 dpurdie 65 
my $excludePkgs;
66 
my %releaseData;
3515 dpurdie 67 
my $comError = 0;
5398 dpurdie 68 
my $yday = -1;
6148 dpurdie 69 
my $RemotePkgList = {};
6320 dpurdie 70 
my $targetBinDir = "$FindBin::Bin/targetBin";
6776 dpurdie 71 
my $server_id;
72 
my @projectList;
73 
my @releaseList;
7387 dpurdie 74 
my $isS3Target;
1038 dpurdie 75 
 
76 
#
5398 dpurdie 77 
#   Contain statisics maintained while operating
78 
#       Can be dumped with a kill -USR2
79 
#       List here for documentation
80 
#
81 
 
82 
my %statistics = (
83 
    SeqNum => 0,                        # Bumped when $statistics are dumped
84 
    timeStamp => 0,                     # DateTime when statistics are dumped
85 
    upTime => 0,                        # Seconds since program start
86 
    Cycle => 0,                         # Major process loop counter
87 
    phase => 'Init',                    # Current phase of operation
88 
    state => 'OK',                      # Nagios state
89 
                                        #
90 
                                        # The following are reset each day
91 
    dayStart => 0,                      # DateTime when daily data was reset
92 
    txCount => 0,                       # Packages Transferred
93 
    delCount => 0,                      # Packages marked for deletion
94 
    staleTags => 0,                     # Stale Tags
95 
    linkErrors => 0,                    # Transfer errors
96 
                                        #
97 
                                        # Per Cycle Data - Calculated each processing Cycle
5399 dpurdie 98 
    total    => 0,                      # Packages to be synced
5398 dpurdie 99 
    delete   => 0,                      # Packages to delete
100 
    excluded => 0,                      # Packages excluded
101 
    filtered => 0,                      # Packages filtered out
102 
    missing  => 0,                      # Packages missing
103 
    transfer => 0,                      # Packages to transfer
104 
    writable => 0,                      # Packages still writable - thus not transferred
105 
    tagCount => 0,                      # Packages tagged to be transferred
5404 dpurdie 106 
                                        #
107 
                                        # Expected from the Target
108 
#   Target.Hostname => '',              # Target Hostname
109 
#   Target.avail    => 0,               # Information from 'df' 1Kblocks
110 
#   Target.pcent    => 0,
111 
#   Target.size     => 0,
112 
#   Target.used     => 0,
113 
#   Target.iavail   => 0,               # Inode information from 'df'
114 
#   Target.ipcent   => 0,
115 
#   Target.isize    => 0,
116 
#   Target.iused    => 0,
117 
#   Target.Total    => 0,               # Number of Package Versions in the archive
118 
#   Target.Damaged  => 0,               # Number that are damaged
119 
#   Target.Delete   => 0,               # Number marked for future deletion
120 
#   Target.Missing  => 0,               # Number missing
5398 dpurdie 121 
);
122 
 
1038 dpurdie 123 
#
5398 dpurdie 124 
#   Describe configuration parameters
125 
#
1038 dpurdie 126 
my %cdata = (
127 
    '.ignore'         => {'pkg\.(.+)' => 'pkgs' },
7387 dpurdie 128 
    '.oneOf'          => [['hostname','S3Bucket']] ,
129 
 
1048 dpurdie 130 
    'piddir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
131 
    'sleep'           => {'default'   => 5      , 'fmt' => 'period'},
132 
    'dpkg_archive'    => {'mandatory' => 1      , 'fmt' => 'dir'},
133 
    'logfile'         => {'mandatory' => 1      , 'fmt' => 'vfile'},
134 
    'logfile.size'    => {'default'   => '1M'   , 'fmt' => 'size'},
135 
    'logfile.count'   => {'default'   => 9      , 'fmt' => 'int'},
136 
    'verbose'         => {'default'   => 0      , 'fmt' => 'int'},
6776 dpurdie 137 
    'rmHostName'      => {'default'   => undef  , 'fmt' => 'text'},
3847 dpurdie 138 
    'sshport'         => {'default'   => 0      , 'fmt' => 'int'},
1048 dpurdie 139 
    'tagdir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
140 
    'forcedirscan'    => {'default'   => 100    , 'fmt' => 'period'},
141 
    'tagage'          => {'default'   => '10m'  , 'fmt' => 'period'},
142 
    'tagListUpdate'   => {'default'   => '1h'   , 'fmt' => 'period'},
7387 dpurdie 143 
    'tagMaxPackages'  => {'default'   => 10     , 'fmt' => 'int'},
6776 dpurdie 144 
    'rmConfigCheck'   => {'default'   => '60'   , 'fmt' => 'period'},
145 
    'rmConfFullRead'  => {'default'   => '1h'   , 'fmt' => 'period'},
1048 dpurdie 146 
    'synctime'        => {'default'   => '2h'   , 'fmt' => 'period'},
147 
    'syncretry'       => {'default'   => '5m'   , 'fmt' => 'period'},
148 
    'allProjects'     => {'default'   => 0      , 'fmt' => 'bool'},
4456 dpurdie 149 
    'allArchive'      => {'default'   => 0      , 'fmt' => 'bool'},
1048 dpurdie 150 
    'project'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
151 
    'release'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
152 
    'writewindow'     => {'default'   => '3h'   , 'fmt' => 'period'},
153 
    'maxpackages'     => {'default'   => 5      , 'fmt' => 'int'},
154 
    'deletePackages'  => {'default'   => 0      , 'fmt' => 'bool'},
155 
    'deleteImmediate' => {'default'   => 0      , 'fmt' => 'bool'},
156 
    'deleteAge'       => {'default'   => 0      , 'fmt' => 'period'},
157 
    'packageFilter'   => {'default'   => undef  , 'fmt' => 'text'},
158 
    'active'          => {'default'   => 1      , 'fmt' => 'bool'},
6475 dpurdie 159 
    'debug'           => {'default'   => 0      , 'fmt' => 'bool'},                 # Log to screen
160 
    'txdetail'        => {'default'   => 0      , 'fmt' => 'bool'},
6776 dpurdie 161 
    'noTransfers'     => {'default'   => 0      , 'fmt' => 'bool'},                 # Debugging option to prevent transfers
7387 dpurdie 162 
 
163 
    #
164 
    #   Transfer via ssh
165 
    #   Cannot be used in conjunction with S3Bucket
166 
    #
167 
    'hostname'        => {'fmt' => 'text', requires => 'user,identity,bindir'},
168 
    'user'            => {'fmt' => 'text', requires => 'hostname'},
169 
    'identity'        => {'fmt' => 'file'},
170 
    'bindir'          => {'fmt' => 'text'},
171 
 
172 
    #
173 
    #   Transfer to S3 configuration items
174 
    #       Cannot be used in conjunction with hostname
175 
    #       Many other options will be ignored
176 
    #
177 
    'S3Bucket'        => {'fmt' => 'text', requires => 'S3Profile'},
178 
    'S3Profile'       => {'fmt' => 'text', requires => 'S3Bucket' },
1038 dpurdie 179 
);
180 
 
181 
 
182 
#
183 
#   Read in the configuration
184 
#       Set up a logger
185 
#       Write a pidfile - thats not used
6776 dpurdie 186 
$now = $startTime = time();
1038 dpurdie 187 
readConfig();
188 
Utils::writepid($conf);
189 
$logger->logmsg("Starting...");
5404 dpurdie 190 
readStatistics();
1038 dpurdie 191 
sighandlers($conf);
192 
 
193 
#
194 
#   Main processing loop
195 
#   Will exit when terminated by parent
196 
#
6779 dpurdie 197 
while (1)
1038 dpurdie 198 
{
199 
    $logger->verbose3("Processing");
5398 dpurdie 200 
    $statistics{Cycle}++;
1038 dpurdie 201 
    $now = time();
1040 dpurdie 202 
 
5398 dpurdie 203 
    $statistics{phase} = 'ReadConfig';
1038 dpurdie 204 
    readConfig();
1048 dpurdie 205 
    if ( $conf->{'active'} )
206 
    {
5398 dpurdie 207 
        $statistics{phase} = 'ProcessReleaseList';
1048 dpurdie 208 
        processReleaseList();
5398 dpurdie 209 
        $statistics{phase} = 'processTags';
1048 dpurdie 210 
        processTags();
5398 dpurdie 211 
        $statistics{phase} = 'maintainTagList';
1048 dpurdie 212 
        maintainTagList();
213 
    }
1040 dpurdie 214 
    %releaseData = ();
215 
 
5398 dpurdie 216 
    $statistics{phase} = 'Sleep';
1038 dpurdie 217 
    sleep( $conf->{'sleep'} );
6779 dpurdie 218 
    reapChildren();
1050 dpurdie 219 
 
3847 dpurdie 220 
    #   If my PID file ceases to be, then exit the daemon
221 
    #   Used to force daemon to restart
222 
    #
223 
    unless ( -f $conf->{'pidfile'} )
224 
    {
225 
        $logger->logmsg("Terminate. Pid file removed");
226 
        last;
227 
    }
1038 dpurdie 228 
}
5398 dpurdie 229 
$statistics{phase} = 'Terminated';
1038 dpurdie 230 
$logger->logmsg("Child End");
231 
exit 0;
232 
 
233 
#-------------------------------------------------------------------------------
6779 dpurdie 234 
# Function        : reapChildren
235 
#
236 
# Description     : Reap any and all dead children
237 
#                   Call in major loops to prevent zombies accumulating
238 
#
239 
# Inputs          : None
240 
#
241 
# Returns         :
242 
#
243 
sub reapChildren
244 
{
245 
    my $currentPhase = $statistics{phase};
246 
    $statistics{phase} = 'Reaping';
247 
 
248 
    my $kid;
249 
    do {
250 
        $kid = waitpid(-1, WNOHANG);
251 
    } while ( $kid > 0 );
252 
 
253 
    $statistics{phase} = $currentPhase;
254 
}
255 
 
256 
 
257 
#-------------------------------------------------------------------------------
1038 dpurdie 258 
# Function        : readConfig
259 
#
260 
# Description     : Re read the config file if it modification time has changed
261 
#
262 
# Inputs          : Nothing
263 
#
1289 dpurdie 264 
# Returns         : 0       - Config not read
265 
#                   1       - Config read
266 
#                             Config file has changed
1038 dpurdie 267 
#
268 
sub readConfig
269 
{
270 
    my ($mtime) = Utils::mtime($ARGV[0]);
1289 dpurdie 271 
    my $rv = 0;
272 
 
1038 dpurdie 273 
    if ( $mtimeConfig != $mtime )
274 
    {
275 
        $logger->logmsg("Reading config file: $ARGV[0]");
276 
        $mtimeConfig = $mtime;
277 
        my $errors;
278 
        ($conf, $errors) = Utils::readconf ( $ARGV[0], \%cdata );
279 
        if ( scalar @{$errors} > 0 )
280 
        {
281 
            warn "$_\n" foreach (@{$errors});
282 
            die ("Config contained errors\n");
283 
        }
7387 dpurdie 284 
        $isS3Target = defined $conf->{'S3Bucket'};
1038 dpurdie 285 
 
286 
        #
287 
        #   Reset some information
288 
        #   Create a new logger
289 
        #
7387 dpurdie 290 
        $logger = Logger->new($conf) unless $conf->{debug};
1038 dpurdie 291 
        $conf->{logger} = $logger;
292 
        $conf->{'pidfile'} = $conf->{'piddir'} . '/' . $name . '.pid';
7387 dpurdie 293 
        $logger->setVerbose($conf->{verbose});
1038 dpurdie 294 
        $logger->verbose("Log Levl: $conf->{verbose}");
295 
 
296 
        #
5398 dpurdie 297 
        #   Setup statistics filename
298 
        $conf->{'statsfile'} = $conf->{'piddir'} . '/' . $name . '.stats';
299 
        $conf->{'statsfiletmp'} = $conf->{'piddir'} . '/' . $name . '.stats.tmp';
300 
 
301 
        #
1038 dpurdie 302 
        #   Extract extra package config
6475 dpurdie 303 
        #       Ignore ALL and Version info if transferring the entire archive
304 
        #       Honor the EXCLUDE - for bandwidth reasons
7387 dpurdie 305 
        #
306 
        #   NOTE: Package inclusion will not be processed in allArchive mode
307 
        #   BUG:  This processing should be done after the RmConfig has been included
1038 dpurdie 308 
        #
309 
        $extraPkgs = {};
1040 dpurdie 310 
        $excludePkgs = {};
1038 dpurdie 311 
        while (my($key, $data) = each ( %{$conf->{pkgs}} ))
312 
        {
3846 dpurdie 313 
            if ( $data eq 'EXCLUDE' ) {
1040 dpurdie 314 
                $excludePkgs->{$key} = 1;
315 
                $logger->verbose("Exclude Pkg: $key");
3846 dpurdie 316 
 
317 
            } elsif ( $data eq 'ALL' ) {
6475 dpurdie 318 
                next if ( $conf->{'allArchive'} );
3846 dpurdie 319 
                foreach my $pver (getPackageVersions($key))
320 
                {
321 
                    $extraPkgs->{$key}{$pver} = 1;
322 
                    $logger->verbose("Extra Pkg: $key -> $pver");
323 
                }
324 
            } else {
6475 dpurdie 325 
                next if ( $conf->{'allArchive'} );
326 
                foreach (split(/[,\s]+/, $data))
327 
                {
328 
                    $extraPkgs->{$key}{$_} = 1;
329 
                    $logger->verbose("Extra Pkg: $key -> $_");
330 
                }
1040 dpurdie 331 
            }
1038 dpurdie 332 
        }
1046 dpurdie 333 
 
1048 dpurdie 334 
        $logger->verbose("Filter Packages: " . $conf->{'packageFilter'})
335 
            if ( defined $conf->{'packageFilter'} );
336 
 
3847 dpurdie 337 
        $logger->warn("Non standard ssh port: " . $conf->{'sshport'})
338 
            if ( $conf->{'sshport'} );
1048 dpurdie 339 
 
6776 dpurdie 340 
        #
341 
        #   Save Text based config for use in RmConfig
342 
        #
343 
        $conf->{'BaseActive'} = $conf->{'active'};
1048 dpurdie 344 
 
6776 dpurdie 345 
        #
346 
        #   Flag config has changed / been read
347 
        #   Force full RM data fetch
348 
        #
349 
        $rv = 1;
350 
        $lastRmSeqNum = 0;
351 
        $lastRmConfRead = 0;
352 
    }
4456 dpurdie 353 
 
6776 dpurdie 354 
    #
355 
    #   Read the Release Manager configuration too
356 
    #
357 
    $rv |= ReadRmConfig();
358 
 
359 
    #
360 
    #   When config is read force some actions
361 
    #       - Force tagList to be created
362 
    #       - Force release scan
363 
    if ($rv) {
6779 dpurdie 364 
        $lastTagListUpdate = 0;
1050 dpurdie 365 
        $lastReleaseScan = 0;
6776 dpurdie 366 
 
367 
        #
368 
        #   Update global Project/Release list - only on change
369 
        @projectList = split /[,\s]+/, $conf->{'project'} || '';
370 
        @releaseList = split /[,\s]+/, $conf->{'release'} || '';
371 
 
372 
        $logger->logmsg("projectList: ". join(',',@projectList));
373 
        $logger->logmsg("releaseList: ". join(',',@releaseList));
374 
 
375 
#Utils::DebugDumpData ("Config", $conf);
376 
 
377 
        $logger->warn("Transfer session configured as not active") unless ( $conf->{'active'} );
378 
        $logger->warn("Transfer all project packages") if ( $conf->{'allProjects'} );
379 
        $logger->warn("Transfer entire package archive") if ( $conf->{'allArchive'} );
380 
        $logger->warn("All Transfers disabled") if ( $conf->{'noTransfers'} );
7387 dpurdie 381 
        $logger->warn("Transfer to AWS S3 Bucket") if ( $isS3Target );
6776 dpurdie 382 
    }
383 
 
384 
    return $rv;
385 
}
386 
 
387 
#-------------------------------------------------------------------------------
388 
# Function        : ReadRmConfig
389 
#
390 
# Description     : Read Configuration information from Release Manager
391 
#                   If Rm configuration is to be used then it will override
392 
#                   the project/release configuration in the text file
393 
#
394 
#
395 
# Inputs          : Nothing
396 
#
397 
# Returns         : 0       - Config not read
398 
#                   1       - Config read
399 
#                             Config file has changed
400 
#
401 
sub ReadRmConfig
402 
{
403 
    #
404 
    #   Time to perform a database read
405 
    #   Will do at startup and every time period there after
406 
    #
407 
    return 0 unless $conf->{'rmHostName'};
408 
    return 0 unless $conf->{'BaseActive'};
409 
    return 0 unless ( $now > ($lastRmConfRead + $conf->{rmConfigCheck} ));
410 
    $logger->verbose("ReadRmConfig");
411 
    $lastRmConfRead = $now;
412 
 
413 
    my $rv = 0;
414 
    my $RM_DB;
415 
    my ($blat_seqnum, $blat_mode, $found);
416 
    my $server_enabled = 1;
417 
 
418 
    #
419 
    #   Read the BLAT_SERVER record from Release Manager
420 
    #
421 
    my $m_sqlstr = "select blat_id, blat_enable, blat_seqnum, blat_mode from RELEASE_MANAGER.blat_servers WHERE UPPER(BLAT_SERVER_NAME) = UPPER('$conf->{'rmHostName'}')";
422 
 
423 
    connectRM(\$RM_DB);
424 
    my $sth = $RM_DB->prepare($m_sqlstr);
425 
    if ( defined($sth) )
426 
    {
427 
        if ( $sth->execute( ) )
428 
        {
429 
            if ( $sth->rows )
430 
            {
431 
                while (my @row = $sth->fetchrow_array )
432 
                {
433 
                    $logger->verbose2("ReadRmConfig:Data:@row");
434 
 
435 
                    $server_id = $row[0] || 0;
436 
                    $server_enabled = ($row[1] || 'N') eq 'Y';
437 
                    $blat_seqnum = $row[2] || 0;
438 
                    $blat_mode = ($row[3] || 'N');
439 
                    $found = 1;
440 
                    last;
441 
                }
442 
            }
443 
            $sth->finish();
444 
        }
445 
        else
446 
        {
447 
            $logger->warn("ReadRmConfig: SQL Execute failure");
448 
        }
449 
    }
450 
    else
451 
    {
452 
        $logger->warn("ReadRmConfig: SQL Prepare failure");
453 
    }
454 
    disconnectRM(\$RM_DB);
455 
 
456 
    #
457 
    #   Process the extracted data
458 
    #
459 
    if ( !$found) {
460 
        $logger->warn("No Release Manager configuration for:" . $conf->{'rmHostName'});
461 
        $server_id = 0;
462 
        $lastRmSeqNum = 0;
463 
        return 0;
464 
    }
465 
 
466 
    #       Check for a change in config
467 
    #
468 
    if ($lastRmSeqNum != $blat_seqnum) {
1289 dpurdie 469 
        $rv = 1;
6776 dpurdie 470 
        $lastRmSeqNum = $blat_seqnum;
1038 dpurdie 471 
    }
6776 dpurdie 472 
 
473 
    #
474 
    #   Insert server configuration into the global config table
475 
    #   Rm Config will override the text config
476 
    #
477 
    $conf->{'active'} = $server_enabled;
478 
    $conf->{'allProjects'} = $blat_mode eq 'P';
479 
    $conf->{'allArchive'} =  $blat_mode eq 'E';
480 
 
481 
    #
482 
    #   If the config has changed, then read the Project and Release records from the database
483 
    #   Insert these into the config provided by the text file confing
484 
    #
485 
    my $forceFullRead;
486 
    if ( $now > ($lastRmConfFullRead + $conf->{rmConfFullRead} )) {
487 
        $logger->verbose("ForceReadRmConfig");
488 
        $lastRmConfFullRead = $now;
489 
        $forceFullRead = 1;
490 
    }
491 
 
492 
    if ($rv || $forceFullRead) {
493 
        connectRM(\$RM_DB);
494 
        my @projects;
495 
        my @releases;
496 
 
497 
        my $m_sqlstr = "select proj_id as proj_id, null as rtag_id from release_manager.blat_projects where blat_id = $server_id and UPPER(bp_enabled) = 'Y'" .
498 
                       " UNION " .
499 
                       "select null as proj_id, rtag_id rtag_id from release_manager.blat_releases where blat_id = $server_id and UPPER(br_enabled) = 'Y'";
500 
 
501 
        my $sth = $RM_DB->prepare($m_sqlstr);
502 
        if ( defined($sth) )
503 
        {
504 
            if ( $sth->execute( ) )
505 
            {
506 
                if ( $sth->rows )
507 
                {
508 
                    while (my @row = $sth->fetchrow_array )
509 
                    {
510 
                        $logger->verbose2("ReadRmConfig:Data:@row");
511 
                        push (@projects, $row[0]) if ($row[0]);
512 
                        push (@releases, $row[1]) if ($row[1] );
513 
                    }
514 
                }
515 
                $sth->finish();
516 
            }
517 
            else
518 
            {
519 
                $logger->warn("ReadRmConfig: SQL Execute failure");
520 
            }
521 
        }
522 
        else
523 
        {
524 
            $logger->warn("ReadRmConfig: SQL Prepare failure");
525 
        }
526 
        disconnectRM(\$RM_DB);
527 
 
528 
        #
529 
        #   Reform the projects and releases into a comma separated list and detect changes
530 
        #
531 
        my $projects = join(',', sort @projects);
532 
        my $releases = join(',', sort @releases);
533 
 
534 
        if ((($projects || '') ne ($conf->{'project'} || '')) || (($releases || '') ne  ($conf->{'release'} || ''))) {
535 
            $conf->{'project'} = $projects;
536 
            $conf->{'release'} = $releases;
537 
            $rv = 1;
538 
        }
539 
    }
540 
 
541 
    # Indicate if the config has changed
1289 dpurdie 542 
    return $rv;
1038 dpurdie 543 
}
544 
 
6475 dpurdie 545 
#-------------------------------------------------------------------------------
546 
# Function        : checkForBasicTools
547 
#
548 
# Description     : Check that the target has the basic tools are installed
549 
#                   Can populate the target's bin directory with tools
550 
#
551 
# Inputs          : None
552 
#
553 
# Returns         : Nothing
554 
#
555 
sub checkForBasicTools
556 
{
7387 dpurdie 557 
    return if $isS3Target;
558 
 
6475 dpurdie 559 
    my $ph;
560 
    my $found;
561 
    my $tgt_cmd = "if [ -x  $conf->{'bindir'}/get_plist.pl ] ; then echo :FOUND:; fi";
562 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 563 
 
6475 dpurdie 564 
    $logger->verbose2("checkForBasicTools:ssh_cmd:$ssh_cmd");
565 
    open ($ph, "$ssh_cmd |");
566 
    while ( <$ph> )
567 
    {
568 
        chomp;
569 
        if (m~:FOUND:~) {
570 
            $found = 1;
571 
        }
572 
        $logger->verbose2("checkForBasicTools:Data: $_");
573 
    }
574 
    close ($ph);
575 
    my $exitCode = $? >> 8;
576 
    $logger->verbose2("checkForBasicTools:End: $exitCode, $?");
577 
 
578 
    unless ( $found )
579 
    {
580 
        $logger->warn("checkForBasicTools: None found, $?");
581 
 
582 
        #
583 
        #   The 'get_plist.pl' program was not found
584 
        #   Assume that the entire directory does not exist and transfer all
585 
        #
586 
        transferTargetBin();
587 
    }
588 
}
589 
 
1038 dpurdie 590 
#-------------------------------------------------------------------------------
6475 dpurdie 591 
# Function        : transferTargetBin
592 
#
593 
# Description     : Ensure that the targets 'bin' folder is upto date
594 
#
595 
# Inputs          : $blatBinData    - Ref to array of target data file info
596 
#
597 
# Returns         :
598 
#
599 
sub transferTargetBin
600 
{
601 
    my ($blatBinData) = @_;
602 
 
603 
    my $blatBinList = getBlatBin();
604 
    foreach my $file ( keys %{$blatBinList} )
605 
    {
606 
        if (defined $blatBinData && exists $blatBinData->{$file}) {
607 
            if ($blatBinData->{$file} eq $blatBinList->{$file}) {
608 
                delete $blatBinList->{$file};
609 
            }
610 
        }
611 
    }
612 
#Utils::DebugDumpData ("blatBinList", $blatBinList);
613 
    transferBlatBin($blatBinList);
614 
}
615 
 
616 
#-------------------------------------------------------------------------------
1038 dpurdie 617 
# Function        : processReleaseList
618 
#
619 
# Description     : Process the release list
620 
#                       Determine if its time to process release list
621 
#                       Determine release list
622 
#                       Determine release content
623 
#                       Determine new items
624 
#
625 
# Inputs          : None
626 
#
627 
# Returns         : Nothing
628 
#
629 
sub processReleaseList
630 
{
631 
    #
1044 dpurdie 632 
    #   Is Release List Processing active
633 
    #   Can configure blat to disable release sync
634 
    #   This will then allow 'new' packages to be sent
635 
    #
7387 dpurdie 636 
    if ( $conf->{maxpackages} == 0 || $conf->{'synctime'} <= 0 || $isS3Target )
1044 dpurdie 637 
    {
638 
        $logger->verbose2("processReleaseList disabled");
7387 dpurdie 639 
        $RemotePkgList = {};
1044 dpurdie 640 
        return;
641 
    }
642 
 
643 
    #
1038 dpurdie 644 
    #   Time to perform the scan
645 
    #   Will do at startup and every time period there after
646 
    #
1040 dpurdie 647 
    my $wtime = $releaseScanMode ? $conf->{'syncretry'} : $conf->{'synctime'};
648 
    return unless ( $now > ($lastReleaseScan + $wtime ));
1038 dpurdie 649 
    $logger->verbose("processReleaseList");
650 
    $lastReleaseScan = $now;
1040 dpurdie 651 
    $releaseScanMode = 1;                                   # Assume error
1038 dpurdie 652 
 
653 
    #
6772 dpurdie 654 
    #   Ensure that we have the basic tools for the transfer
655 
    #
656 
    checkForBasicTools();
657 
 
658 
    #
1038 dpurdie 659 
    #   Get list of packages from Remote site
660 
    #   Invoke a program on the remote site and parse the results
661 
    #
662 
    #   Returned data looks like:
6148 dpurdie 663 
    #       Metadata avail="140100452"
6320 dpurdie 664 
    #       BlatBin MD5="9e2c6e45af600a20a01dbcb7570da1f1" file="stat.pl"
6148 dpurdie 665 
    #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
6475 dpurdie 666 
    #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas" "link=latest"
6148 dpurdie 667 
    #       time="1497954104" GMT="Tue Jun 20 10:21:44 2017" pname="ERGissaccounts" pver="1.0.7178.mas" deleted="0"
1038 dpurdie 668 
    #
669 
    my $remotePkgList;
5404 dpurdie 670 
    my $remoteData;
6320 dpurdie 671 
    my $blatBinData;
1038 dpurdie 672 
    my $ph;
1040 dpurdie 673 
    my $tgt_cmd = "$conf->{'bindir'}/get_plist.pl";
3515 dpurdie 674 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 675 
 
676 
    $logger->verbose2("processReleaseList:ssh_cmd:$ssh_cmd");
677 
    open ($ph, "$ssh_cmd |");
678 
    while ( <$ph> )
679 
    {
680 
        chomp;
5404 dpurdie 681 
        if ($_ =~ m~^Metadata\s+~)
1038 dpurdie 682 
        {
6320 dpurdie 683 
            parsePkgMetaData($_, \%{$remoteData});
1038 dpurdie 684 
        }
6320 dpurdie 685 
        elsif ($_ =~ m~^BlatBin\s+~)
686 
        {
687 
            parseBlatBinData($_, \%{$blatBinData})
688 
        }
1038 dpurdie 689 
        else
690 
        {
5404 dpurdie 691 
            if ( parsePkgList($_, \%{$remotePkgList} ) )
692 
            {
693 
                $logger->verbose2("processReleaseList:Data: $_");
694 
            }
695 
            else
696 
            {
697 
                $logger->warn("processReleaseList:Bad Data: $_");
698 
            }
1038 dpurdie 699 
        }
700 
    }
701 
    close ($ph);
702 
    $logger->verbose("processReleaseList:End: $?");
6148 dpurdie 703 
    $RemotePkgList = $remotePkgList;
704 
 
3515 dpurdie 705 
    LogTxError ($?);
1038 dpurdie 706 
    if ( $? != 0 )
707 
    {
708 
        $logger->warn("Cannot retrieve package list: $?");
5398 dpurdie 709 
        $statistics{state} = 'No Remote Package List';
1038 dpurdie 710 
        return;
711 
    }
1042 dpurdie 712 
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
6320 dpurdie 713 
 
1038 dpurdie 714 
    #
6475 dpurdie 715 
    #   Ensure that the target bin folder is up to date
716 
    #
717 
    transferTargetBin($blatBinData);
6320 dpurdie 718 
 
719 
    #
1038 dpurdie 720 
    #   Determine the set of packages in the releases to be transferred
4456 dpurdie 721 
    #
722 
    my $pkgList;
723 
    if ( $conf->{'allArchive'} )
1040 dpurdie 724 
    {
4456 dpurdie 725 
        #   Examine entire archive
726 
        #
727 
        $pkgList = getArchiveList();
1040 dpurdie 728 
    }
4456 dpurdie 729 
    else
730 
    {
731 
        #   Examine Releases
732 
        #
733 
        my @rlist = getReleaseList();
734 
        unless ( @rlist )
735 
        {
736 
            $logger->verbose2("No Releases to Process");
5398 dpurdie 737 
            $statistics{state} = 'No Releases found';
6475 dpurdie 738 
 
739 
            #   Allow config with just specified packages
740 
            #
741 
            #   return;
742 
        } else {
743 
            $pkgList = getPkgList(@rlist);
4456 dpurdie 744 
        }
745 
    }
1038 dpurdie 746 
 
747 
    #
748 
    #   Append extra packages
749 
    #   These are packages that are specifically named by the user
750 
    #
6475 dpurdie 751 
    #   Note: If they are symbolic links, then the target of the
752 
    #         link is also added.
1038 dpurdie 753 
    #
754 
    #         Symlink MUST be within the same directory
3846 dpurdie 755 
    #           Used to transfer jats2_current
1038 dpurdie 756 
    #
757 
    while ( (my ($pname, $pvers)) = each %{$extraPkgs} ) {
758 
        while ( (my ($pver, $pdata) ) = each %{$pvers} ) {
759 
 
1040 dpurdie 760 
            my $epath = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
1038 dpurdie 761 
            if ( -l $epath )
762 
            {
763 
                my $lver = readlink( $epath );
764 
                if ( ! defined $lver )
765 
                {
3846 dpurdie 766 
                    $logger->warn("Can't resolve symlink: $pname, $pver");
1038 dpurdie 767 
                    next;
768 
                }
769 
 
770 
                if ( $lver =~ m ~/~ )
771 
                {
772 
                    $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
773 
                    next;
774 
                }
6098 dpurdie 775 
 
6475 dpurdie 776 
                #
777 
                #   Add the package the link points to
778 
                #
779 
                $logger->verbose2("Add linked package: $pname, $lver, $pdata");
780 
                $pkgList->{$pname}{$lver} = $pdata;
1038 dpurdie 781 
            }
782 
 
783 
            $logger->verbose2("Add extra package: $pname, $pver, $pdata");
784 
            $pkgList->{$pname}{$pver} = $pdata;
785 
        }
786 
    }
6475 dpurdie 787 
#Utils::DebugDumpData ("parsePkgList", $rv);
1038 dpurdie 788 
 
6475 dpurdie 789 
 
1040 dpurdie 790 
    #
791 
    #   If there are no packages to process, then assume that this is an error
792 
    #   condition. Retry the operation soon.
793 
    #
794 
    unless ( keys %{$pkgList} )
795 
    {
796 
 
797 
        $logger->verbose2("No packages to process");
5398 dpurdie 798 
        $statistics{state} = 'No Packages found';
1040 dpurdie 799 
        return;
800 
    }
801 
 
6475 dpurdie 802 
#   #
803 
#   #   Useful debug code
804 
#   #
805 
#   while ( (my ($pname, $pvers)) = each %{$pkgList} )
806 
#   {
807 
#       while ( (my ($pver, $ptime) ) = each %{$pvers} )
808 
#       {
809 
#           print "L-- $pname, $pver, $ptime \n";
1038 dpurdie 810 
#
6475 dpurdie 811 
#       }
812 
#   }
1038 dpurdie 813 
 
814 
    #
1040 dpurdie 815 
    #   Delete Excess Packages
1038 dpurdie 816 
    #       Packages not required on the target
1042 dpurdie 817 
    #           KLUDGE: Don't delete links to packages
818 
    #           Don't delete packages marked for deletion
1038 dpurdie 819 
    #
820 
    my $excessPkgList;
1048 dpurdie 821 
    my $excessPkgListCount = 0;
1038 dpurdie 822 
    if ( $conf->{deletePackages} )
823 
    {
824 
        while ( (my ($pname, $pvers)) = each %{$remotePkgList} )
825 
        {
826 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
827 
            {
828 
                if ( !exists $pkgList->{$pname}{$pver} )
829 
                {
1040 dpurdie 830 
                    if ( exists $excludePkgs->{$pname} )
831 
                    {
832 
                        $logger->verbose2("Keep Excluded package: ${pname}");
833 
                        next;
834 
                    }
835 
 
1042 dpurdie 836 
                    if ( exists $pdata->{deleted} )
837 
                    {
838 
                        if ( $conf->{deleteAge} )
839 
                        {
840 
                            if ( $pdata->{deleted} <= $conf->{deleteAge} )
841 
                            {
842 
                                $logger->verbose2("Already marked for future age deletion: ${pname}/${pver}, $pdata->{deleted}");
843 
                                next;
844 
                            }
845 
                            $pdata->{FORCEDELETE} = 1;
846 
                        }
847 
 
848 
                        if ( !$conf->{deleteImmediate} )
849 
                        {
850 
                            $logger->verbose2("Already marked for deletion: ${pname}/${pver}");
851 
                            next;
852 
                        }
853 
                    }
854 
 
855 
                    #
856 
                    #   Force deletion
857 
                    #       deleteImmediate mode
858 
                    #       target is a broken link
859 
                    #
860 
                    $pdata->{FORCEDELETE} = 1
861 
                        if ($conf->{deleteImmediate} || $pdata->{broken});
862 
 
1038 dpurdie 863 
                    $excessPkgList->{$pname}{$pver} = $pdata;
1048 dpurdie 864 
                    $excessPkgListCount++;
1038 dpurdie 865 
                    $logger->verbose("Excess package: ${pname}/${pver}");
866 
                }
1050 dpurdie 867 
#                else
868 
#                {
869 
#                        $logger->verbose3("Retain package: ${pname}/${pver}");
870 
#                }
1038 dpurdie 871 
            }
872 
        }
873 
    }
874 
 
875 
    #
876 
    #   Process the remote list and the local list
877 
    #   The remote time-stamp is the modification time of the packages descpkg file
878 
    #
879 
    #   Mark for transfer packages that
1040 dpurdie 880 
    #       Are in the local set but not the remote set
1038 dpurdie 881 
    #       Have a different time stamp
882 
    #
883 
    #   Ignore packages not in the local archive
884 
    #   Ignore packages that don't have a descpkg
885 
    #   Ignore packages that are writable - still being formed
886 
    #
887 
    my $needPkgList;
1048 dpurdie 888 
    my $needPkgListCount = 0;
889 
    my $filteredCount = 0;
890 
    my $missingCount = 0;
891 
    my $writableCount = 0;
892 
    my $excludeCount = 0;
5404 dpurdie 893 
    my $packageVersionCount = 0;
1038 dpurdie 894 
    while ( (my ($pname, $pvers)) = each %{$pkgList} )
895 
    {
1040 dpurdie 896 
        #
897 
        #   Ignore excluded packages
898 
        #
1048 dpurdie 899 
        if ( exists $excludePkgs->{$pname} )
900 
        {
901 
            $excludeCount++;
902 
            next;
903 
        }
1040 dpurdie 904 
 
1048 dpurdie 905 
        #
906 
        #   Ignore packages that are filtered out
907 
        #
908 
        if ( defined $conf->{'packageFilter'} )
909 
        {
910 
            unless ( $pname =~ m~$conf->{'packageFilter'}~ )
911 
            {
912 
                $logger->verbose3("Filtering out: ${pname}");
913 
                $filteredCount++;
914 
                next;
915 
            }
916 
        }
917 
 
1038 dpurdie 918 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
919 
        {
6475 dpurdie 920 
            my $must_transfer;
921 
            my $existsRemote = exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver});
922 
 
6148 dpurdie 923 
            #
924 
            #   Take care not to create an entry into $remotePkgList->{$pname}{$pver}
925 
            #   if it does not exist. Existence of {$pname}{$pver} is used later
926 
            #
927 
            my $tmtime = 0;
6475 dpurdie 928 
            if ($existsRemote && exists ($remotePkgList->{$pname}{$pver}{time})) {
6148 dpurdie 929 
                $tmtime = $remotePkgList->{$pname}{$pver}{time};
930 
            }
5404 dpurdie 931 
            $packageVersionCount++;
1038 dpurdie 932 
 
933 
            # Package is present in both list
6475 dpurdie 934 
            my $localPackage = catdir( $conf->{'dpkg_archive'} , $pname, $pver );
935 
            my ($mtime, $mode) = Utils::mtime( catfile($localPackage, 'descpkg') );
1038 dpurdie 936 
            if ( $mtime == 0 )
937 
            {
938 
                # PackageVersion not in local archive (at least the descpkg file is not)
939 
                # Skip now - will pick it up later
940 
                $logger->verbose("Package not in dpkg_archive: $pname, $pver");
1048 dpurdie 941 
                $missingCount++;
1038 dpurdie 942 
                next;
943 
            }
944 
 
945 
            if ( $mode & 0222 )
946 
            {
947 
                # Descpkg file is writable
948 
                # Package may be in the process of being created
1048 dpurdie 949 
                # If the package has been writable for a long time, then
1038 dpurdie 950 
                # consider for transfer
951 
                my $age = $now - $mtime;
952 
                if ( $age < ($conf->{'writewindow '} || 600) )
953 
                {
954 
                    $logger->verbose("Package is writable: $pname, $pver, ", $now - $mtime);
1048 dpurdie 955 
                    $writableCount++;
1038 dpurdie 956 
                    next;
957 
                }
958 
            }
959 
 
6475 dpurdie 960 
            if ( $mtime != $tmtime ) {
961 
                $logger->verbose("Package Needs to be transferred: $pname, $pver, $mtime, $tmtime");
962 
                $must_transfer = 1;
963 
            }
964 
            elsif ($existsRemote)
1038 dpurdie 965 
            {
6475 dpurdie 966 
                #
967 
                #   Package exists in both source and target
968 
                #   Symlink test: Ensure symlinks are the same
969 
                #
970 
                my $localIsSymlink = -l $localPackage;
971 
                my $remoteIsSymlink = exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver}) && exists ($remotePkgList->{$pname}{$pver}{link});
972 
 
973 
                if ($remoteIsSymlink && $localIsSymlink) {
974 
                    #
975 
                    #   Both are symlinks - check that they address the same item
976 
                    #
977 
                    my $targetLink = $remotePkgList->{$pname}{$pver}{link};
978 
                    $logger->verbose2("Package is symlink: $pname, $pver -> $targetLink");
979 
 
980 
                    my $lver = readlink( $localPackage );
981 
                    if ( ! defined $lver ) {
982 
                        $logger->warn("Can't resolve symlink: $pname, $pver");
983 
                        next;
984 
                    }
985 
                    if ($targetLink ne $lver ) {
986 
                        $logger->verbose("Package symlinks differ: $pname, $pver, $targetLink, $lver");
987 
                        $must_transfer = 3;
988 
                    }
989 
 
990 
                } elsif ($remoteIsSymlink || $localIsSymlink ) {
991 
                    #
992 
                    #   Only one is a symlink - force transfer
993 
                    #
994 
                    $logger->warn("Packages versions not both symlink: $pname, $pver, L:$remoteIsSymlink R:$localIsSymlink");
995 
                    $must_transfer = 2;
996 
                }
997 
            }
998 
 
999 
            #
1000 
            #   If we are forcing a package transfer then flag it and also remove it from the
1001 
            #   RemotePkgList so that it will be transferred - even if its present on target
1002 
            #
1003 
            if ($must_transfer) {
1038 dpurdie 1004 
                # Package not present on target, or timestamps differ
1005 
                $needPkgList->{$pname}{$pver} = $pdata;
6475 dpurdie 1006 
                delete $RemotePkgList->{$pname}{$pver};
1048 dpurdie 1007 
                $needPkgListCount++;
1038 dpurdie 1008 
                next;
1009 
            }
1010 
        }
1011 
    }
1012 
 
1048 dpurdie 1013 
 
1038 dpurdie 1014 
    #
1015 
    #   Debug output only
1016 
    #   Display what we need to transfer
1017 
    #
1018 
    if ( $conf->{verbose} > 2 )
1019 
    {
1020 
        while ( (my ($pname, $pvers)) = each %{$needPkgList} )
1021 
        {
1022 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
1023 
            {
1024 
                $logger->verbose("Need to transfer: $pname, $pver, $pdata");
1025 
            }
1026 
        }
1027 
    }
1048 dpurdie 1028 
    if ( $conf->{verbose}  )
1029 
    {
1030 
        $logger->verbose("Packages to transfer: $needPkgListCount");
1031 
        $logger->verbose("Packages to delete: $excessPkgListCount");
1032 
        $logger->verbose("Packages filtered out: $filteredCount");
1033 
        $logger->verbose("Packages missing: $missingCount");
1034 
        $logger->verbose("Packages still writable: $writableCount");
1035 
        $logger->verbose("Packages excluded: $excludeCount");
1036 
    }
1038 dpurdie 1037 
 
1038 
    #
5398 dpurdie 1039 
    #   Update stats
1040 
    #   At this point we are looking pretty good
1041 
    #
1042 
    $statistics{state} = 'OK';
5404 dpurdie 1043 
    $statistics{total} = $packageVersionCount;
5398 dpurdie 1044 
    $statistics{transfer} = $needPkgListCount;
1045 
    $statistics{delete} = $excessPkgListCount;
1046 
    $statistics{filtered} = $filteredCount;
1047 
    $statistics{missing} = $missingCount;
1048 
    $statistics{writable} = $writableCount;
1049 
    $statistics{excluded} = $excludeCount;
1050 
 
1051 
    #
1038 dpurdie 1052 
    #   Time to do the real work
1053 
    #   Transfer packages and delete excess packages
1054 
    #   Note: Perform the transfers first
1055 
    #         Limit the number of packages processed in one pass
1056 
    #
1057 
    my $txcount = $conf->{maxpackages};
1058 
 
1059 
    #
1060 
    #   Transfer packages that we have identified
1061 
    #
1062 
    send_pkgs:
1063 
    while ( (my ($pname, $pvers)) = each %{$needPkgList} )
1064 
    {
1065 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
1066 
        {
1067 
            if ( --$txcount <= 0 )
1068 
            {
1050 dpurdie 1069 
                $logger->warn("Max transfer count exceeded: $needPkgListCount transfer remaining");
1038 dpurdie 1070 
                $lastReleaseScan = 0;
1071 
                last send_pkgs;
1072 
            }
1289 dpurdie 1073 
 
1074 
            if ( readConfig() )
1075 
            {
1076 
                $logger->warn("Config file changed");
1077 
                $txcount = 0;
1078 
                last send_pkgs;
1079 
            }
1080 
 
6475 dpurdie 1081 
            transferPackage ($pname, $pver);
1048 dpurdie 1082 
            $needPkgListCount--;
6779 dpurdie 1083 
            reapChildren();
1038 dpurdie 1084 
        }
1085 
    }
1086 
 
1087 
    #
1088 
    #   Delete packages that have been identified as excess
1089 
    #
1090 
    delete_pkgs:
1091 
    while ( (my ($pname, $pvers)) = each %{$excessPkgList} )
1092 
    {
1093 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
1094 
        {
1095 
            if ( --$txcount <= 0 )
1096 
            {
1050 dpurdie 1097 
                $logger->warn("Max transfer count exceeded: $excessPkgListCount deletion remaining");
1038 dpurdie 1098 
                $lastReleaseScan = 0;
1099 
                last delete_pkgs;
1100 
            }
1289 dpurdie 1101 
 
1102 
            if ( readConfig() )
1103 
            {
1104 
                $logger->warn("Config file changed");
1105 
                $txcount = 0;
6779 dpurdie 1106 
                last delete_pkgs;
1289 dpurdie 1107 
            }
1108 
 
1044 dpurdie 1109 
            deletePackage ($pname, $pver, $pdata);
1048 dpurdie 1110 
            $excessPkgListCount--;
6779 dpurdie 1111 
            reapChildren();
1038 dpurdie 1112 
        }
1113 
    }
1114 
 
1115 
    #
1116 
    #   Send package list to the target
1117 
    #
1118 
    sendPackageList ($pkgList);
1040 dpurdie 1119 
 
1120 
    #
1121 
    #   On a successful transfer
1122 
    #       Force tag processing
1123 
    #       Set scan Mode to normal
1124 
    #
1125 
    $tagDirTime = 0;
1126 
    $releaseScanMode = 0;
1038 dpurdie 1127 
}
1128 
 
1129 
#-------------------------------------------------------------------------------
1130 
# Function        : sendPackageList
1131 
#
1132 
# Description     : Transfer package list to the target
1133 
#
1134 
# Inputs          : $pkgList            - Ref to hash of package names and versions
1135 
#
1040 dpurdie 1136 
# Returns         : Nothing
1137 
#                   Don't really care about any errors from this process
1138 
#                   Its not essential
1038 dpurdie 1139 
#
1140 
sub sendPackageList
1141 
{
1142 
    my ($pkgList) = @_;
1143 
    my ($fh, $filename) = tempfile( "/tmp/blat.$$.XXXX", SUFFIX => '.txt');
1144 
    $logger->verbose("sendPackageList:TmpFile: $filename");
6776 dpurdie 1145 
 
1146 
    return if $conf->{'noTransfers'};
1038 dpurdie 1147 
 
1148 
    #
1149 
    #   Create a temp file with data
1150 
    #
1151 
    foreach my $pname ( sort keys %{$pkgList} )
1152 
    {
1153 
        foreach my $pver ( sort keys %{$pkgList->{$pname}} )
1154 
        {
1155 
            print $fh "$pname/$pver\n";
1156 
        }
1157 
    }
1158 
    close $fh;
1159 
 
1160 
    #
1161 
    #   Transfer to target
1162 
    #   Create the process pipe to transfer the file
1163 
    #   gzip the file and pipe the result through a ssh session to the target machine
3515 dpurdie 1164 
    #   gzip -c filename |  ssh  ... "./receive_file filename"
1038 dpurdie 1165 
    #
1166 
    my $ph;
3515 dpurdie 1167 
    my $gzip_cmd = "$gzip --no-name -c \"$filename\"";
1040 dpurdie 1168 
    my $tgt_cmd = "$conf->{'bindir'}/receive_file \"ArchiveList\"";
3515 dpurdie 1169 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 1170 
 
1171 
    $logger->verbose2("sendPackageList:gzip_cmd:$gzip_cmd");
1172 
    $logger->verbose2("sendPackageList:tgt_cmd:$tgt_cmd");
1173 
    $logger->verbose2("sendPackageList:ssh_cmd:$ssh_cmd");
1174 
 
1175 
    open ($ph, "$gzip_cmd | $ssh_cmd |");
1176 
    while ( <$ph> )
1177 
    {
1178 
        chomp;
1179 
        $logger->verbose2("sendPackageList:Data: $_");
1180 
    }
1181 
    close ($ph);
3515 dpurdie 1182 
    unlink $filename;
1038 dpurdie 1183 
    $logger->verbose("sendPackageList:End: $?");
3515 dpurdie 1184 
    LogTxError ($?);
1038 dpurdie 1185 
}
1186 
 
1187 
 
1188 
#-------------------------------------------------------------------------------
1189 
# Function        : getPkgList
1190 
#
1191 
# Description     : Determine a set of package versions within the list
1192 
#                   of provided releases
1193 
#
1194 
# Inputs          : @rlist              - A list of releases to examine
1195 
#
1196 
# Returns         : Ref to a hask of package versions
1197 
#
1198 
sub getPkgList
1199 
{
1200 
    my %pdata;
1201 
    my $RM_DB;
1202 
    connectRM(\$RM_DB);
1203 
    $logger->verbose("getPkgList");
1204 
 
1205 
    #
1206 
    #   Determine the releases that are in this project
1207 
    #   Build up an sql query
1208 
    #
6776 dpurdie 1209 
    my $m_rlist = join ',', @_;
1048 dpurdie 1210 
    my $m_sqlstr = "SELECT DISTINCT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, pv.IS_DEPLOYABLE" .
1038 dpurdie 1211 
                    " FROM RELEASE_MANAGER.RELEASE_CONTENT rc, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
6776 dpurdie 1212 
                    " WHERE ( RTAG_ID in ($m_rlist) ) AND rc.PV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID" .
1038 dpurdie 1213 
                    " ORDER by PKG_NAME DESC";
1214 
    $logger->verbose3("getPkgList:Sql:$m_sqlstr");
1215 
 
1216 
    my $sth = $RM_DB->prepare($m_sqlstr);
1217 
    if ( defined($sth) )
1218 
    {
1219 
        if ( $sth->execute( ) )
1220 
        {
1221 
            if ( $sth->rows )
1222 
            {
1223 
                while (my @row = $sth->fetchrow_array )
1224 
                {
1225 
                    $logger->verbose2("getPkgList:Data:@row");
1226 
                    $pdata{$row[1]}{$row[2]} = 1;
1227 
                }
1228 
            }
1229 
            $sth->finish();
1230 
        }
1231 
    }
1232 
    else
1233 
    {
1234 
        $logger->warn("getPkgList: SQL Prepare failure");
1235 
    }
1050 dpurdie 1236 
 
1237 
   disconnectRM(\$RM_DB);
1038 dpurdie 1238 
   return \%pdata;
1239 
}
1240 
 
1241 
 
1242 
#-------------------------------------------------------------------------------
1243 
# Function        : getReleaseList
1244 
#
1245 
# Description     : Determine the list of releases to be proccessed
1040 dpurdie 1246 
#                   From:
1247 
#                       Convert projects to a list of releases
1248 
#                       Configured list of releases
1038 dpurdie 1249 
#
1250 
# Inputs          : None
1251 
#
1252 
# Returns         : A list of releases to be processed
1253 
#
1254 
sub getReleaseList
1255 
{
1256 
    my $RM_DB;
1257 
    my %rlist;
1048 dpurdie 1258 
    my $m_sqlstr;
1038 dpurdie 1259 
    $logger->verbose("getReleaseList");
1260 
 
1261 
    #
1040 dpurdie 1262 
    #   Cache data
1263 
    #   Only for one cycle of the main loop
1264 
    #
1265 
    if ( exists $releaseData{getReleaseList} )
1266 
    {
1267 
        $logger->verbose3("getReleaseList:Cache hit");
1268 
        return @{$releaseData{getReleaseList}};
1269 
    }
1270 
 
1271 
    #
1048 dpurdie 1272 
    #   All projects
1038 dpurdie 1273 
    #
1048 dpurdie 1274 
    if ( $conf->{'allProjects'} )
1038 dpurdie 1275 
    {
1048 dpurdie 1276 
        $m_sqlstr = "SELECT rt.RTAG_ID" .
1277 
                    " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
1050 dpurdie 1278 
                    " WHERE rt.OFFICIAL != 'A'";
1279 
                    #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 1280 
    }
1281 
    else
1282 
    {
1038 dpurdie 1283 
        #
1048 dpurdie 1284 
        #   Convert list of projects into a list of releases
1038 dpurdie 1285 
        #
6776 dpurdie 1286 
        if ( @projectList )
1048 dpurdie 1287 
        {
1288 
            #
1289 
            #   Determine the releases that are in this project
1290 
            #   Build up an sql query
1291 
            #
6776 dpurdie 1292 
            my $m_plist = join ',', @projectList;
1048 dpurdie 1293 
            $m_sqlstr = "SELECT rt.RTAG_ID" .
1294 
                        " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
6776 dpurdie 1295 
                        " WHERE ( PROJ_ID in ( $m_plist) ) AND rt.OFFICIAL != 'A'";
5300 dpurdie 1296 
                        #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 1297 
        }
1298 
    }
1038 dpurdie 1299 
 
1048 dpurdie 1300 
    if ( defined $m_sqlstr )
1301 
    {
1038 dpurdie 1302 
        $logger->verbose3("getReleaseList:Sql:$m_sqlstr");
1048 dpurdie 1303 
        connectRM(\$RM_DB);
1038 dpurdie 1304 
        my $sth = $RM_DB->prepare($m_sqlstr);
1305 
        if ( defined($sth) )
1306 
        {
1307 
            if ( $sth->execute( ) )
1308 
            {
1309 
                if ( $sth->rows )
1310 
                {
1311 
                    while (my @row = $sth->fetchrow_array )
1312 
                    {
1313 
                        $logger->verbose2("getReleaseList:Data:@row");
1314 
                        $rlist{$row[0]} = 1;
1315 
                    }
1316 
                }
1317 
                $sth->finish();
6776 dpurdie 1318 
            } else {
1319 
                $logger->warn("getReleaseList: SQL Execute failure");
1038 dpurdie 1320 
            }
1321 
        }
1322 
        else
1323 
        {
1324 
            $logger->warn("getReleaseList: SQL Prepare failure");
1325 
        }
1050 dpurdie 1326 
        disconnectRM(\$RM_DB);
1038 dpurdie 1327 
    }
1328 
 
1329 
    #
1330 
    #   Add in the user specified list of releases
1331 
    #
6776 dpurdie 1332 
    $rlist{$_} = 1 foreach(@releaseList);
1038 dpurdie 1333 
 
1334 
    #
1335 
    #   Sort for pretty display only
1336 
    #
1040 dpurdie 1337 
    @{$releaseData{getReleaseList}} = sort {$a <=> $b} keys %rlist;
1338 
 
1339 
    return @{$releaseData{getReleaseList}};
1038 dpurdie 1340 
}
1341 
 
1040 dpurdie 1342 
#-------------------------------------------------------------------------------
3846 dpurdie 1343 
# Function        : getPackageVersions
1344 
#
1345 
# Description     : Get the list of package-versions available in the package
1346 
#                   store.
1347 
#
1348 
# Inputs          : pkgName             - The package name
1349 
#
1350 
# Returns         : Array of versions
1351 
#
1352 
sub getPackageVersions
1353 
{
1354 
    my ($pkgName) = @_;
1355 
    my @versionList;
1356 
 
1357 
    my $pkgDir = catfile($conf->{'dpkg_archive'} , $pkgName );
1358 
    my $dh;
1359 
 
1360 
    unless (opendir($dh, $pkgDir))
1361 
    {
1362 
        $logger->warn ("Can't opendir $pkgDir: $!");
1363 
        return @versionList;
1364 
    }
1365 
 
1366 
    #
1367 
    #   Process each entry
1368 
    #   Ignore those that start with a .
1369 
    #
1370 
    while (my $version = readdir($dh) )
1371 
    {
1372 
        next if ( $version =~ m~^\.~ );
1373 
        my $file = catfile($pkgDir, $version);
1374 
 
1375 
        next unless ( -d $file );
1376 
 
1377 
        push @versionList, $version;
1378 
        $logger->verbose3("getPackageVersions: $pkgName, $version");
1379 
    }
1380 
    closedir $dh;
1381 
    return @versionList;
1382 
}
1383 
 
1384 
#-------------------------------------------------------------------------------
4456 dpurdie 1385 
# Function        : getArchiveList
1386 
#
1387 
# Description     : Get the entire set of package versions in the archive
1388 
#
1389 
# Inputs          :
1390 
#
6475 dpurdie 1391 
# Returns         : Ref to a hash of package versions
4456 dpurdie 1392 
#
1393 
sub getArchiveList
1394 
{
1395 
    my $pkgDir = $conf->{'dpkg_archive'};
1396 
    my %archiveList;
1397 
    my $dh;
1398 
    my @pkgList;
1399 
 
1400 
    unless (opendir($dh, $pkgDir))
1401 
    {
1402 
        $logger->warn ("Can't opendir $pkgDir: $!");
1403 
        return \%archiveList;
1404 
    }
1405 
 
1406 
    #
1407 
    #   Process each entry
1408 
    #   Ignore those that start with a .
1409 
    #   Ignore files
1410 
    #
1411 
    while (my $pkgName = readdir($dh) )
1412 
    {
1413 
        next if ( $pkgName =~ m~^\.~ );
1414 
        my $file = catfile($pkgDir, $pkgName);
1415 
 
1416 
        next unless ( -d $file );
1417 
        $logger->verbose3("getArchiveList: $pkgName");
1418 
        push @pkgList, $pkgName;
1419 
    }
1420 
    closedir $dh;
1421 
 
1422 
    #   Now get the package versions
1423 
    #       Sort for pretty display
1424 
    foreach my $pname (sort @pkgList)
1425 
    {
1426 
        foreach my $pver (getPackageVersions($pname))
1427 
        {
1428 
            $archiveList{$pname}{$pver} = 1;
1429 
        }
1430 
    }
1431 
 
1432 
    return \%archiveList;
1433 
}
1434 
 
1435 
#-------------------------------------------------------------------------------
6320 dpurdie 1436 
# Function        : getBlatBin
1437 
#
1438 
# Description     : Get the list of files that should be in the targetbin directory
1439 
#
1440 
# Inputs          : Nothing
1441 
#
1442 
# Returns         : A hash of data
1443 
#
1444 
sub getBlatBin
1445 
{
1446 
    my $data;
1447 
    $logger->verbose("getBlatBin: $targetBinDir");
1448 
    if (opendir(DIR, $targetBinDir ) ) {
1449 
        my @vlist = readdir(DIR);
1450 
        closedir DIR;
1451 
 
1452 
        foreach my $vname ( sort @vlist )
1453 
        {
1454 
            next if ( $vname eq '.' );
1455 
            next if ( $vname eq '..' );
1456 
            next unless ( -f "$targetBinDir/$vname" );
1457 
 
1458 
            if (open FILE, "$targetBinDir/$vname") {
1459 
                $data->{$vname} = Digest::MD5->new->addfile(*FILE)->hexdigest;
1460 
                close (FILE);
1461 
            }
1462 
        }
1463 
    } else {
1464 
        $logger->warn("BlatBin Not Found: $targetBinDir");
1465 
    }
1466 
    return $data;
1467 
}
1468 
 
1469 
 
1470 
#-------------------------------------------------------------------------------
1040 dpurdie 1471 
# Function        : maintainTagList
1472 
#
1473 
# Description     : Maintain a data structure for the maintenance of the
1474 
#                   tags directory
1475 
#
1476 
# Inputs          : None
1477 
#
1478 
# Returns         : Nothing
1479 
#
1480 
sub maintainTagList
1481 
{
1482 
    #
1483 
    #   Time to perform the scan
1484 
    #   Will do at startup and every time period there after
1485 
    #
6779 dpurdie 1486 
    return unless ( $now > ($lastTagListUpdate + $conf->{tagListUpdate} ));
1040 dpurdie 1487 
    $logger->verbose("maintainTagList");
6779 dpurdie 1488 
    $lastTagListUpdate = $now;
1038 dpurdie 1489 
 
1040 dpurdie 1490 
    #
1491 
    #   Get list of things
1492 
    #
1493 
    my %config;
4457 dpurdie 1494 
    if ($conf->{'allArchive'} )
1495 
    {
1496 
        $config{allArchive} = 1
1497 
    }
1498 
    elsif ($conf->{'allProjects'} )
1499 
    {
1500 
        $config{allProjects} = 1;
1501 
    }
1502 
    else
1503 
    {
6776 dpurdie 1504 
        %{$config{projects}} = map { $_ => 1 } @projectList;
4457 dpurdie 1505 
        %{$config{releases}} = map { $_ => 1 } getReleaseList();
1506 
    }
1040 dpurdie 1507 
 
1508 
    #
1509 
    #   Save data
1510 
    #
1511 
    my $dump =  Data::Dumper->new([\%config], [qw(*config)]);
1512 
#print $dump->Dump;
1513 
#$dump->Reset;
1514 
 
1515 
    #
1516 
    #   Save config data
1517 
    #
1518 
    my $conf_file = catfile( $conf->{'tagdir'},'.config' );
1519 
    $logger->verbose3("maintainTagList: Writting $conf_file");
1520 
 
1521 
    my $fh;
1522 
    open ( $fh, '>', $conf_file ) or $logger->err("Can't create $conf_file: $!");
1523 
    print $fh $dump->Dump;
1524 
    close $fh;
1525 
}
1526 
 
1527 
 
1038 dpurdie 1528 
#-------------------------------------------------------------------------------
1529 
# Function        : processTags
1530 
#
1531 
# Description     : Process tags and send marked package versions to the target
1532 
#                       Determine if new tags are present
1533 
#                       Process each tag
1534 
#
1535 
# Inputs          : None
1536 
#
1537 
# Returns         : Nothing
1538 
#
1539 
sub processTags
1540 
{
6779 dpurdie 1541 
 
1038 dpurdie 1542 
    #
6779 dpurdie 1543 
    #   Is Tag Processing active
1544 
    #   Can configure blat to disable tag sync
1545 
    #
1546 
    if ( $conf->{'tagMaxPackages'} == 0 )
1547 
    {
1548 
        $logger->verbose2("processTags disabled");
1549 
        return;
1550 
    }
1551 
 
1552 
    #
1038 dpurdie 1553 
    #   Determine if new tags are present by examining the time
1554 
    #   that the directory was last modified.
1555 
    #
1556 
    #   Allow for a forced scan to catch packages that did not transfer
1557 
    #   on the first attempt
1558 
    #
5398 dpurdie 1559 
    my $tagCount = 0;
1038 dpurdie 1560 
    my ($mtime) = Utils::mtime($conf->{'tagdir'} );
1561 
    if ( ($mtime > $tagDirTime) || ($now > ($lastDirScan + $conf->{'forcedirscan'})) )
1562 
    {
1042 dpurdie 1563 
        $logger->verbose2("processTags: ",$conf->{'tagdir'}, $mtime - $tagDirTime, $now - $lastDirScan);
1038 dpurdie 1564 
        $tagDirTime = $mtime;
1565 
        $lastDirScan = $now;
6779 dpurdie 1566 
        my $txcount = $conf->{'tagMaxPackages'};
1038 dpurdie 1567 
 
6779 dpurdie 1568 
 
1038 dpurdie 1569 
        my $dh;
1570 
        unless (opendir($dh, $conf->{'tagdir'}))
1571 
        {
1572 
            $logger->warn ("can't opendir $conf->{'tagdir'}: $!");
1573 
            return;
1574 
        }
1575 
 
1576 
        #
1577 
        #   Process each entry
1578 
        #   Ignore those that start with a .
1579 
        #
6779 dpurdie 1580 
        my %tagPkgList;
1038 dpurdie 1581 
        while (my $tag = readdir($dh) )
1582 
        {
1583 
            next if ( $tag =~ m~^\.~ );
1584 
            my $file = "$conf->{'tagdir'}/$tag";
1042 dpurdie 1585 
            $logger->verbose3("processTags: $file");
1586 
 
1038 dpurdie 1587 
            next unless ( -f $file );
1588 
            next if ( $tag  eq 'ReleaseList' );
1589 
 
1590 
            if ( $tag =~ m~(.+)::(.+)~  )
1591 
            {
1592 
                my $package = $1;
1593 
                my $version = $2;
5398 dpurdie 1594 
                $tagCount++;
6779 dpurdie 1595 
                $tagPkgList{$package}{$version} = $file;
1596 
            }
1597 
        }
1598 
        $statistics{tagCount} = $tagCount;
1599 
        closedir $dh;
6098 dpurdie 1600 
 
6779 dpurdie 1601 
        #
1602 
        #   Process the packages located in the tags area
1603 
        #
1604 
        send_tags:
1605 
        while ( (my ($package, $pvers)) = each %{tagPkgList} )
1606 
        {
1607 
            while ( (my ($version, $file) ) = each %{$pvers} )
1608 
            {
1609 
                if ( --$txcount <= 0 )
1610 
                {
1611 
                    $logger->warn("Max tag transfer count exceeded: $tagCount transfer remaining");
1612 
                    $tagDirTime = 0;
1613 
                    last send_tags;
1614 
                }
1615 
 
1616 
                if ( readConfig() )
1617 
                {
1618 
                    $logger->warn("Config file changed");
1619 
                    $txcount = 0;
1620 
                    $tagDirTime = 0;
1621 
                    last send_tags;
1622 
                }
1623 
 
1624 
 
6098 dpurdie 1625 
                #
1626 
                #   Don't transfer 'extra' packages
1627 
                #
1628 
                if (exists ($extraPkgs->{$package}) )
1038 dpurdie 1629 
                {
6779 dpurdie 1630 
                    $logger->warn ("Delete excess package tag: $package::$version");
1038 dpurdie 1631 
                    unlink $file;
6779 dpurdie 1632 
 
1633 
                } elsif ( transferPackage( $package, $version )) {
6098 dpurdie 1634 
                    unlink $file;
1635 
                }
1038 dpurdie 1636 
                else
1637 
                {
7387 dpurdie 1638 
                    if ($conf->{'tagage'} > 0) {
1639 
                        my ($mtime) = Utils::mtime( $file );
1640 
                        if ( $now - $mtime > $conf->{'tagage'} )
1641 
                        {
1642 
                            $logger->warn ("Delete unsatisfied tag: $package::$version after $conf->{'tagage'}" );
1643 
                            unlink $file;
1644 
                            $statistics{staleTags}++;
1645 
                        }
1038 dpurdie 1646 
                    }
1647 
                }
6779 dpurdie 1648 
 
1649 
                $tagCount--;
1650 
                reapChildren();
1038 dpurdie 1651 
            }
1652 
        }
1653 
    }
1654 
}
1655 
 
1656 
#-------------------------------------------------------------------------------
6320 dpurdie 1657 
# Function        : transferBlatBin
1658 
#
1659 
# Description     : Transfer any of the Blat Bin files that are out of date
1660 
#                   on the target
1661 
#
1662 
# Inputs          : $fileHash       - A hash whose files are those that need
1663 
#                                     to be updated
1664 
#
1665 
# Returns         :
1666 
#
1667 
sub transferBlatBin
1668 
{
1669 
    my ($hash) = @_;
1670 
    $logger->verbose("transferBlatBin");
6776 dpurdie 1671 
 
1672 
    return if $conf->{'noTransfers'};
1673 
 
6320 dpurdie 1674 
    foreach my $file ( sort keys %{$hash})
1675 
    {
1676 
        $logger->logmsg("transferBlatBin: $file");
1677 
 
1678 
        #
1679 
        #   Transfer one file using only 'ssh'
1680 
        #   Create the target directory on the fly
1681 
        #   Manipulate file permissions
1682 
        #   Report errors
1683 
 
1684 
        my $tar_cmd = "cat \"$targetBinDir/$file\"";
6475 dpurdie 1685 
        my $tgt_cmd = "mkdir -p ~/bin && if [ -f \"~/bin/$file\" ] ; then chmod +x+w \"~/bin/$file\"; fi && cat > \"~/bin/$file\" && chmod +x-w \"~/bin/$file\" || exit 1";
6320 dpurdie 1686 
        my $ssh_cmd = sshCmd($tgt_cmd);
1687 
        my $cat_cmd =
1688 
 
1689 
        $logger->verbose2("transferBlatBin:tar_cmd:$tar_cmd");
1690 
        $logger->verbose2("transferBlatBin:tgt_cmd:$tgt_cmd");
1691 
        $logger->verbose2("transferBlatBin:ssh_cmd:$ssh_cmd");
1692 
 
1693 
        my $ph;
1694 
        open ($ph, "$tar_cmd | $ssh_cmd |");
1695 
        while ( <$ph> )
1696 
        {
1697 
            chomp;
1698 
            $logger->verbose2("transferBlatBin:Data: $_");
1699 
        }
1700 
        close ($ph);
1701 
        $logger->verbose("transferBlatBin:End: $?");
1702 
 
1703 
        if ( $? != 0 )
1704 
        {
1705 
            $logger->warn("transferBlatBin:Transfer Error: $file, $?");
1706 
        }
1707 
        LogTxError ($?);
1708 
    }
1709 
}
1710 
 
1711 
 
1712 
#-------------------------------------------------------------------------------
1038 dpurdie 1713 
# Function        : transferPackage
1714 
#
1715 
# Description     : Transfer specified package to target system
6475 dpurdie 1716 
#                   If a symlink, then a symlink will be transferred
1038 dpurdie 1717 
#
1718 
# Inputs          : $pname          - Name of the package
1719 
#                   $pver           - Package version
1720 
#
1721 
# Returns         : true    - Package transferred
1722 
#                   false   - Package not transferred
1723 
#
1724 
sub transferPackage
1725 
{
6475 dpurdie 1726 
    my ($pname, $pver ) = @_;
1038 dpurdie 1727 
    my $rv = 0;
6776 dpurdie 1728 
    my $cmdRv = 0;
1038 dpurdie 1729 
    $logger->logmsg("transferPackage: @_");
6148 dpurdie 1730 
    my $startTime = time;
1038 dpurdie 1731 
 
1732 
    #
1040 dpurdie 1733 
    #   Do not transfer excluded files
1734 
    #
1735 
    if ( exists $excludePkgs->{$pname} )
1736 
    {
1048 dpurdie 1737 
        $logger->warn("transferPackage: Excluded package not transferred: $pname, $pver");
1040 dpurdie 1738 
        return 1;
1739 
    }
1048 dpurdie 1740 
 
1040 dpurdie 1741 
    #
1048 dpurdie 1742 
    #   Apply package filter
1743 
    #
1744 
    if ( defined $conf->{'packageFilter'} )
1745 
    {
1746 
        unless ( $pname =~ m~$conf->{'packageFilter'}~ )
1747 
        {
1748 
            $logger->warn("transferPackage: Filtered out package not transferred: $pname, $pver");
1749 
            return 1;
1750 
        }
1751 
    }
1752 
 
1753 
    #
6148 dpurdie 1754 
    #   If its known to be in the target archive, then we don't need to transfer it again
1755 
    #       It may have been transferred in this cycle
1756 
    #       It may have been in the archive anyway
1038 dpurdie 1757 
    #
6148 dpurdie 1758 
    if ( exists($RemotePkgList->{$pname}) && exists ($RemotePkgList->{$pname}{$pver})) {
1759 
        $logger->verbose("transferPackage: Already in archive");
6320 dpurdie 1760 
        #$logger->logmsg("transferPackage: $pname, $pver : Already in archive");
1038 dpurdie 1761 
        return 1;
1762 
    }
1763 
 
6475 dpurdie 1764 
    my $sdir = catfile( $conf->{'dpkg_archive'} , $pname );
1765 
    my $sfile = catfile( $sdir, $pver );
1038 dpurdie 1766 
    unless ( -d $sfile )
1767 
    {
1768 
        $logger->warn("transferPackage:Package not found: $pname, $pver");
1769 
        return $rv;
1770 
    }
1771 
 
7387 dpurdie 1772 
    my $tzdir = catfile( $conf->{'dpkg_archive'} , '.dpkg_archive', 'tarStore' );
1773 
    my $tzfile = $pname . '__' . $pver . '.tgz';
1774 
    my $tzpath = catfile($tzdir, $tzfile);
1775 
    unless (-f $tzpath) {
1776 
        $logger->verbose("transferPackage: tarZip not found - $tzpath");
1777 
 
1778 
        $conf->{'tagdir'} =~ m~^(.*)/~;
1779 
        my $tagRoot = $1;
1780 
        my $tag = "$pname::$pver";
1781 
        Utils::TouchFile($conf, catfile($tagRoot, 'tarZip', $tag));
1782 
        return 0;
1783 
    }
1784 
 
1785 
 
6475 dpurdie 1786 
    ###########################################################################
1787 
    #   Transfer the package / symlink
1038 dpurdie 1788 
    #
7387 dpurdie 1789 
    if ($isS3Target) {
1790 
        $cmdRv = transferPackageS3($tzdir, $tzfile, $pname, $pver);
1791 
    } else {
1792 
        $cmdRv = transferPackageSsh($tzdir, $tzfile, $sfile, $pname, $pver);
1793 
    }
1794 
 
1795 
    #
1796 
    #   Display the size of the package
1797 
    #       Diagnostic use
1798 
    #
1799 
    if ($conf->{txdetail}) {
1800 
        my $ph;
1801 
        open ( $ph, "du -bs $sfile 2>/dev/null |" );
1802 
        my $line = <$ph>;
1803 
        $line =~ m/^([0-9]+)/;
1804 
        $line = $1 || 0;
1805 
        my $size = sprintf "%.3f", $line / 1024 / 1024 / 1024 ;
1806 
        close $ph;
1807 
        my $duration = time - $startTime;
1808 
        $logger->logmsg("transferPackage: Stats: $pname, $pver, $size Gb, $duration Secs");
1809 
    }
1810 
 
1811 
    if ( $cmdRv == 0 ) {
1812 
        #
1813 
        #   Mark has having been transferred in the current cycle
1814 
        #
1815 
        $RemotePkgList->{$pname}{$pver}{transferred} = 1;
1816 
        $rv = 1;
1817 
        $statistics{txCount}++;
1818 
 
1819 
    } else {
1820 
        $logger->warn("transferPackage:Transfer Error: $pname, $pver, $?");
1821 
    }
1822 
 
1823 
    LogTxError ($?);
1824 
    return $rv;
1825 
}
1826 
 
1827 
#-------------------------------------------------------------------------------
1828 
# Function        : transferPackageSsh
1829 
#
1830 
# Description     : Transfer a package via an ssh connection
1831 
#
1832 
# Inputs          : $tzdir  - Directory that contains the tarZip file
1833 
#                   $tzname - Name of tarZip File
1834 
#                   $sfile  - Full path to the source file
1835 
#                   $pname  - Package Name
1836 
#                   $pver   - Package Version
1837 
#
1838 
# Returns         : Result Code
1839 
#                   0   - Transfer OK
1840 
#                   <0  - Skip transfer
1841 
#                   >0  - Command error code
1842 
#
1843 
sub transferPackageSsh
1844 
{
1845 
    my ($tzdir, $tzname, $sfile, $pname, $pver) = @_;
6475 dpurdie 1846 
    my $tgt_cmd;
1847 
    my $ssh_cmd;
7387 dpurdie 1848 
    my $cmdRv = 0;
1849 
    my $tzfile = catfile($tzdir, $tzname);
1850 
 
6475 dpurdie 1851 
    if (-l $sfile) {
1038 dpurdie 1852 
 
6475 dpurdie 1853 
        #
1854 
        #   Determine the value of the symlink
7387 dpurdie 1855 
        #   Only support simple symlinks - that are in the same directory
6475 dpurdie 1856 
        #
1857 
        my $lver = readlink( $sfile );
1858 
        if ( ! defined $lver ) {
1859 
            $logger->warn("Can't resolve symlink: $pname, $pver");
7387 dpurdie 1860 
            return -1;
6475 dpurdie 1861 
        }
1862 
 
1863 
        if ( $lver =~ m ~/~ ) {
1864 
            $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
7387 dpurdie 1865 
            return -1;
6475 dpurdie 1866 
        }
1867 
 
1868 
        $tgt_cmd = "$conf->{'bindir'}/receive_symlink \"$pname\" \"$pver\" \"$lver\"";
1869 
        $ssh_cmd = sshCmd($tgt_cmd);
1870 
 
1871 
    } else {
1872 
        #
1873 
        #   Create the process pipe to transfer the package
7387 dpurdie 1874 
        #   Pipe the tarZip of the package through a ssh session to the target machine
1875 
        #   cat $tzpath | ssh  ... "./receive_package pname pver"
6475 dpurdie 1876 
        #
1877 
        $tgt_cmd = "$conf->{'bindir'}/receive_package \"$pname\" \"$pver\"";
1878 
        $ssh_cmd = sshCmd($tgt_cmd);
7387 dpurdie 1879 
        $ssh_cmd .= " <$tzfile"
6475 dpurdie 1880 
    }
1881 
 
1038 dpurdie 1882 
    $logger->verbose2("transferPackage:tgt_cmd:$tgt_cmd");
1883 
    $logger->verbose2("transferPackage:ssh_cmd:$ssh_cmd");
1884 
 
6776 dpurdie 1885 
    unless ($conf->{'noTransfers'}) {
1886 
        my $ph;
7387 dpurdie 1887 
        open ($ph, "$ssh_cmd |");
6776 dpurdie 1888 
        while ( <$ph> )
1889 
        {
1890 
            chomp;
1891 
            $logger->verbose2("transferPackage:Data: $_");
1892 
        }
1893 
        close ($ph);
1894 
        $cmdRv = $?;
1895 
        $logger->verbose("transferPackage:End: $?");
1038 dpurdie 1896 
    }
6148 dpurdie 1897 
 
7387 dpurdie 1898 
    return $cmdRv;
1899 
}
1900 
 
1901 
#-------------------------------------------------------------------------------
1902 
# Function        : transferPackageS3
1903 
#
1904 
# Description     : Transfer a package to an AWS S3 bucket
1905 
#                   Requires that the package already be tarZip-ed
1906 
#
1907 
# Inputs          : $tzdir  - Directory that contains the tarZip file
1908 
#                   $tzfile - Name of tarZip File
1909 
#                   $pname  - Package Name
1910 
#                   $pver   - Package Version
1911 
#
1912 
# Returns         : Result Code
1913 
#                   0   - Transfer OK
1914 
#                   <0  - Skip transfer
1915 
#                   >0  - Command error code
1916 
#
1917 
sub transferPackageS3
1918 
{
1919 
    my ($tzdir, $tzfile, $pname, $pver) = @_;
1920 
    my $cmdRv = 0;
1921 
 
6148 dpurdie 1922 
    #
7387 dpurdie 1923 
    #   Locate the file on the dpkgArchive tarZip store
1924 
    #
1925 
    my $sfile = catfile($tzdir, $tzfile);
1926 
    if (-l $sfile) {
1927 
        $logger->warn("Will not transfer symlink: $pname, $pver");
1928 
        return -1;
1929 
    }
1930 
 
6148 dpurdie 1931 
    #
7387 dpurdie 1932 
    #   Create a command to transfer the file to AWS use the cli tools
1933 
    #   Note: Ive seen problem with this when used from Perth to AWS (Sydney)
1934 
    #         If this is an issue use curl - see the savePkgToS3.sh for an implementation
1935 
    #
1936 
    my $s3_cmd = "aws --profile $conf->{'S3Profile'} s3 cp $sfile s3://$conf->{'S3Bucket'}/$tzfile";
1937 
    $logger->verbose2("transferPackage:s3_cmd:$s3_cmd");
1938 
 
1939 
    unless ($conf->{'noTransfers'}) {
6776 dpurdie 1940 
        my $ph;
7387 dpurdie 1941 
        open ($ph, "$s3_cmd |");
1942 
        while ( <$ph> )
1943 
        {
1944 
            chomp;
1945 
            $logger->verbose2("transferPackage:Data: $_");
1946 
        }
1947 
        close ($ph);
1948 
        $cmdRv = $?;
1949 
        $logger->verbose("transferPackage:End: $?");
6475 dpurdie 1950 
    }
6148 dpurdie 1951 
 
7387 dpurdie 1952 
    return $cmdRv;
1038 dpurdie 1953 
}
1954 
 
7387 dpurdie 1955 
 
1038 dpurdie 1956 
#-------------------------------------------------------------------------------
1957 
# Function        : deletePackage
1958 
#
1959 
# Description     : Delete specified package to target system
1960 
#
1961 
# Inputs          : $pname          - Name of the package
1962 
#                   $pver           - Package version
1042 dpurdie 1963 
#                   $pdata          - Hash of extra data
1038 dpurdie 1964 
#
1965 
# Returns         : true    - Package transferred
1966 
#                   false   - Package not transferred
1967 
#
1968 
sub deletePackage
1969 
{
1042 dpurdie 1970 
    my ($pname, $pver, $pdata ) = @_;
1038 dpurdie 1971 
    my $rv = 0;
6776 dpurdie 1972 
    my $cmdRv = 0;
1042 dpurdie 1973 
    $logger->logmsg("deletePackage: $pname, $pver");
1038 dpurdie 1974 
 
1975 
    #
1976 
    #   Create the process pipe to delete the package
3515 dpurdie 1977 
    #   ssh  ... "./delete_package ${rx_opts} \"$pname\" \"$pver\""
1038 dpurdie 1978 
    #
6776 dpurdie 1979 
    unless ($conf->{'noTransfers'}) {
1980 
        my $ph;
1981 
        my $flags = $pdata->{FORCEDELETE}  ? '' : ' -T';
1982 
        my $tgt_cmd = "$conf->{'bindir'}/delete_package $flags \"$pname\" \"$pver\"";
1983 
        my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 1984 
 
6776 dpurdie 1985 
        $logger->verbose2("deletePackage:tgt_cmd:$tgt_cmd");
1986 
        $logger->verbose2("deletePackage:ssh_cmd:$ssh_cmd");
1038 dpurdie 1987 
 
6776 dpurdie 1988 
        open ($ph, "$ssh_cmd |");
1989 
        while ( <$ph> )
1990 
        {
1991 
            chomp;
1992 
            $logger->verbose2("deletePackage:Data: $_");
1993 
        }
1994 
        close ($ph);
1995 
        $cmdRv = $?;
1996 
 
1997 
        $logger->verbose("deletePackage:End: $?");
1038 dpurdie 1998 
    }
6776 dpurdie 1999 
 
2000 
    if ( $cmdRv == 0 )
1038 dpurdie 2001 
    {
2002 
        $rv = 1;
5398 dpurdie 2003 
        $statistics{delCount}++;
6148 dpurdie 2004 
        delete $RemotePkgList->{$pname}{$pver};
1038 dpurdie 2005 
    }
2006 
    else
2007 
    {
2008 
        $logger->warn("deletePackage:Error: $pname, $pver, $?");
2009 
    }
3515 dpurdie 2010 
    LogTxError ($?);
1038 dpurdie 2011 
    return $rv;
2012 
}
2013 
 
3515 dpurdie 2014 
#-------------------------------------------------------------------------------
2015 
# Function        : sshCmd
2016 
#
2017 
# Description     : Generate a ssh based command
2018 
#
2019 
# Inputs          : Target command
2020 
#
2021 
# Returns         : An shh command string
2022 
#
2023 
sub sshCmd
2024 
{
2025 
    my ($tgt_cmd) = @_;
3847 dpurdie 2026 
    my $sshPort = '';
2027 
    $sshPort = "-p $conf->{'sshport'}"
2028 
        if ($conf->{'sshport'});
2029 
 
2030 
    return "ssh -o \"BatchMode yes\" -i $conf->{'identity'} ${sshPort} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";
3515 dpurdie 2031 
}
1038 dpurdie 2032 
 
3515 dpurdie 2033 
 
1038 dpurdie 2034 
#-------------------------------------------------------------------------------
1042 dpurdie 2035 
# Function        : parsePkgList
2036 
#
2037 
# Description     : Parse one line from a pkgList
2038 
#                   Lines are multiple item="data" items
6148 dpurdie 2039 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
6475 dpurdie 2040 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas" link="latest"
1042 dpurdie 2041 
#
2042 
# Inputs          : $line                   - Line of data
2043 
#                   $hashp                  - Ref to hash to populate
2044 
#
2045 
# Returns         : A hash of data items
2046 
#
2047 
sub parsePkgList
2048 
{
2049 
    my ($line, $hashp) = @_;
2050 
    my $rv;
2051 
 
2052 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
2053 
    {
2054 
        $rv->{$1} = $2;
2055 
        $line = $';
2056 
    }
2057 
#Utils::DebugDumpData ("parsePkgList", $rv);
2058 
 
2059 
    my $pname = $rv->{pname};
2060 
    my $pver =  $rv->{pver};
2061 
    return undef unless ( $pname && $pver );
2062 
 
2063 
    delete $rv->{pname};
2064 
    delete $rv->{pver};
2065 
    delete $rv->{GMT};
2066 
 
2067 
    $hashp->{$pname}{$pver} = $rv;
2068 
    return $hashp;
2069 
}
2070 
 
5398 dpurdie 2071 
#-------------------------------------------------------------------------------
5404 dpurdie 2072 
# Function        : parsePkgMetaData
2073 
#
2074 
# Description     : Parse one line of meta data from a pkgList
2075 
#                   Lines are multiple item="data" items
2076 
#
2077 
# Inputs          : $line                   - Line of data
2078 
#                   $hashp                  - Ref to hash to populate
2079 
#
2080 
# Returns         : Nothing
2081 
#
2082 
sub parsePkgMetaData
2083 
{
2084 
    my ($line, $hashp) = @_;
2085 
 
2086 
    if ( $line =~ m~\s+(.+?)="(.+?)"~ )
2087 
    {
2088 
        $hashp->{$1} = $2;
2089 
        $statistics{'Target.' . $1} = $2;
2090 
        $line = $';
2091 
 
2092 
        $logger->verbose2("parsePkgMetaData: $1 = $2");
2093 
    }
2094 
}
2095 
 
6320 dpurdie 2096 
#-------------------------------------------------------------------------------
2097 
# Function        : parseBlatBinData
2098 
#
2099 
# Description     : Parse one line of Blat Bin data from a pkgList
2100 
#                   Lines are of the form:
2101 
#                   BlatBin MD5="dbc4507f4db5b41f7358b28bce65a15d" file="ddp-gtar"
2102 
#
2103 
# Inputs          : $line                   - Line of data
2104 
#                   $hashp                  - Ref to hash to populate
2105 
#
2106 
# Returns         : Nothing
2107 
#
2108 
sub parseBlatBinData
2109 
{
2110 
    my ($line, $hashp) = @_;
5404 dpurdie 2111 
 
6320 dpurdie 2112 
    my $rv;
2113 
    $line =~ s~^\S+~~;
2114 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
2115 
    {
2116 
        $rv->{$1} = $2;
2117 
        $line = $';
2118 
    }
2119 
#Utils::DebugDumpData ("parseBlatBinData", $rv);
2120 
 
2121 
    my $fname = $rv->{file};
2122 
    my $md5 =  $rv->{MD5};
2123 
    return undef unless ( $fname && $md5 );
2124 
 
2125 
    $logger->verbose2("parseBlatBinData: $fname : $md5");
2126 
    $hashp->{$fname} = $md5;
2127 
}
2128 
 
5404 dpurdie 2129 
#-------------------------------------------------------------------------------
5398 dpurdie 2130 
# Function        : resetDailyStatistics
2131 
#
2132 
# Description     : Called periodically to reset the daily statistics
2133 
#
2134 
# Inputs          : $time       - Current time
2135 
#
2136 
# Returns         :
2137 
#
2138 
sub resetDailyStatistics
2139 
{
2140 
    my ($time) = @_;
1042 dpurdie 2141 
 
5398 dpurdie 2142 
    #
2143 
    #   Detect a new day
2144 
    #
2145 
    my $today = (localtime($time))[7];
2146 
    if ($yday != $today)
2147 
    {
2148 
        $yday = $today;
2149 
        $logger->logmsg('Resetting daily statistics' );
2150 
 
5404 dpurdie 2151 
        # Note: Must match @recoverTags in readStatistics
5398 dpurdie 2152 
        $statistics{dayStart} = $time;
2153 
        $statistics{txCount} = 0;
2154 
        $statistics{delCount} = 0;
2155 
        $statistics{staleTags} = 0;
2156 
        $statistics{linkErrors} = 0;
2157 
    }
2158 
}
2159 
 
1042 dpurdie 2160 
#-------------------------------------------------------------------------------
5404 dpurdie 2161 
# Function        : readStatistics
2162 
#
2163 
# Description     : Read in the last set of stats
2164 
#                   Used after a restart to recover daily statistics
2165 
#
2166 
# Inputs          :
2167 
#
2168 
# Returns         :
2169 
#
2170 
sub readStatistics
2171 
{
2172 
    my @recoverTags = qw(dayStart txCount delCount staleTags linkErrors);
2173 
 
2174 
    if ($conf->{'statsfile'} and -f $conf->{'statsfile'})
2175 
    {
2176 
        if (open my $fh, $conf->{'statsfile'})
2177 
        {
2178 
            while (<$fh>)
2179 
            {
2180 
                m~(.*):(.*)~;
2181 
                if ( grep( /^$1$/, @recoverTags ) )
2182 
                {
2183 
                    $statistics{$1} = $2;
6475 dpurdie 2184 
                    $logger->verbose("readStatistics $1, $2");
5404 dpurdie 2185 
                }
2186 
            }
2187 
            close $fh;
2188 
            $yday = (localtime($statistics{dayStart}))[7];
2189 
        }
2190 
    }
2191 
}
2192 
 
2193 
 
2194 
#-------------------------------------------------------------------------------
5398 dpurdie 2195 
# Function        : periodicStatistics
2196 
#
2197 
# Description     : Called on a regular basis to write out statistics
2198 
#                   Used to feed information into Nagios
2199 
#
2200 
#                   This function is called via an alarm and may be outside the normal
2201 
#                   processing loop. Don't make assumptions on the value of $now
2202 
#
2203 
# Inputs          :
2204 
#
2205 
# Returns         :
2206 
#
2207 
sub periodicStatistics
2208 
{
2209 
    #
2210 
    #   A few local stats
2211 
    #
2212 
    $statistics{SeqNum}++;
2213 
    $statistics{timeStamp} = time();
2214 
    $statistics{upTime} = $statistics{timeStamp} - $startTime;
2215 
 
2216 
    #   Reset daily accumulations - on first use each day
2217 
    resetDailyStatistics($statistics{timeStamp});
2218 
 
2219 
    #
2220 
    #   Write statistics to a file
2221 
    #       Write to a tmp file, then rename.
2222 
    #       Attempt to make the operation atomic - so that the file consumer
2223 
    #       doesn't get a badly formed file.
2224 
    #
2225 
    if ($conf->{'statsfiletmp'})
2226 
    {
2227 
        my $fh;
2228 
        unless (open ($fh, '>', $conf->{'statsfiletmp'}))
2229 
        {
2230 
            $fh = undef;
2231 
            $logger->warn("Cannot create temp stats file: $!");
2232 
        }
2233 
        else
2234 
        {
5404 dpurdie 2235 
            foreach my $key ( sort { lc($a) cmp lc($b) } keys %statistics)
5398 dpurdie 2236 
            {
2237 
                print $fh $key . ':' . $statistics{$key} . "\n";
2238 
                $logger->verbose2('Statistics:'. $key . ':' . $statistics{$key});
2239 
            }
2240 
            close $fh;
2241 
 
2242 
            # Rename temp to real file
2243 
            rename  $conf->{'statsfiletmp'},  $conf->{'statsfile'} ;
2244 
        }
2245 
    }
2246 
}
2247 
 
2248 
#-------------------------------------------------------------------------------
1038 dpurdie 2249 
# Function        : sighandlers
2250 
#
2251 
# Description     : Install signal handlers
2252 
#
2253 
# Inputs          : $conf           - System config
2254 
#
2255 
# Returns         : Nothing
2256 
#
2257 
sub sighandlers
2258 
{
5398 dpurdie 2259 
    my $conf = shift;
2260 
    my $logger = $conf->{logger};
1038 dpurdie 2261 
 
5398 dpurdie 2262 
    $SIG{TERM} = sub {
2263 
        # On shutdown
2264 
        $logger->logmsg('Received SIGTERM. Shutting down....' );
2265 
        unlink $conf->{'pidfile'} if (-f $conf->{'pidfile'});
2266 
        exit 0;
2267 
    };
1038 dpurdie 2268 
 
5398 dpurdie 2269 
    $SIG{HUP} = sub {
2270 
        # On logrotate
2271 
        $logger->logmsg('Received SIGHUP.');
2272 
        $logger->rotatelog();
2273 
    };
1038 dpurdie 2274 
 
5398 dpurdie 2275 
    $SIG{USR1} = sub {
2276 
        # On Force Archive Sync
2277 
        $logger->logmsg('Received SIGUSR1.');
1046 dpurdie 2278 
        $lastReleaseScan = 0;
6779 dpurdie 2279 
        $lastTagListUpdate = 0;
6776 dpurdie 2280 
        $lastRmConfRead = 0;
5398 dpurdie 2281 
    };
1038 dpurdie 2282 
 
7387 dpurdie 2283 
    alarm 60 unless $conf->{debug};
5398 dpurdie 2284 
    $SIG{ALRM} = sub {
2285 
        # On Dump Statistics
2286 
        $logger->verbose2('Received SIGUSR2.');
2287 
        periodicStatistics();
2288 
        alarm 60;
2289 
    };
2290 
 
1038 dpurdie 2291 
    $SIG{__WARN__} = sub { $logger->warn("@_") };
2292 
    $SIG{__DIE__} = sub { $logger->err("@_") };
2293 
}
2294 
 
2295 
#-------------------------------------------------------------------------------
3515 dpurdie 2296 
# Function        : LogTxError
2297 
#
2298 
# Description     : Detect restoration of communication and log such
2299 
#                   Don't log failures as the user will do that
2300 
#
2301 
# Inputs          : $state                  - 0 - All is well
2302 
#                                           !0  - Error
2303 
#
2304 
# Returns         : Nothing
2305 
#
2306 
sub LogTxError
2307 
{
2308 
    my ($state) = $@;
2309 
    if ( $state )
2310 
    {
5398 dpurdie 2311 
        $statistics{linkErrors}++ unless($comError);
3515 dpurdie 2312 
        $comError++;
5398 dpurdie 2313 
        $statistics{state} = 'No Communication';
3515 dpurdie 2314 
    }
2315 
    elsif ( $comError )
2316 
    {
2317 
        $logger->warn("Communication Restored");
2318 
        $comError = 0;
5398 dpurdie 2319 
        $statistics{state} = 'OK';
3515 dpurdie 2320 
    }
2321 
}
2322 
 
2323 
 
2324 
#-------------------------------------------------------------------------------
1038 dpurdie 2325 
# Function        : Error, Verbose, Warning
2326 
#
2327 
# Description     : Support for JatsRmApi
2328 
#
2329 
# Inputs          : Message
2330 
#
2331 
# Returns         : Nothing
2332 
#
2333 
sub Error
2334 
{
2335 
    $logger->err("@_");
2336 
}
2337 
 
2338 
sub Verbose
2339 
{
1042 dpurdie 2340 
    $logger->verbose2("@_");
1038 dpurdie 2341 
}
2342 
 
2343 
sub Warning
2344 
{
2345 
    $logger->warn("@_");
2346 
}
2347