Subversion Repositories DevTools

Rev

Rev 7387 | Rev 7394 | 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 
{
7389 dpurdie 601 
    return if $isS3Target;
6475 dpurdie 602 
    my ($blatBinData) = @_;
603 
 
604 
    my $blatBinList = getBlatBin();
605 
    foreach my $file ( keys %{$blatBinList} )
606 
    {
607 
        if (defined $blatBinData && exists $blatBinData->{$file}) {
608 
            if ($blatBinData->{$file} eq $blatBinList->{$file}) {
609 
                delete $blatBinList->{$file};
610 
            }
611 
        }
612 
    }
613 
#Utils::DebugDumpData ("blatBinList", $blatBinList);
614 
    transferBlatBin($blatBinList);
615 
}
616 
 
617 
#-------------------------------------------------------------------------------
1038 dpurdie 618 
# Function        : processReleaseList
619 
#
620 
# Description     : Process the release list
621 
#                       Determine if its time to process release list
622 
#                       Determine release list
623 
#                       Determine release content
624 
#                       Determine new items
625 
#
626 
# Inputs          : None
627 
#
628 
# Returns         : Nothing
629 
#
630 
sub processReleaseList
631 
{
632 
    #
1044 dpurdie 633 
    #   Is Release List Processing active
634 
    #   Can configure blat to disable release sync
635 
    #   This will then allow 'new' packages to be sent
636 
    #
7389 dpurdie 637 
    if ( $conf->{maxpackages} == 0 || $conf->{'synctime'} <= 0 )
1044 dpurdie 638 
    {
639 
        $logger->verbose2("processReleaseList disabled");
7387 dpurdie 640 
        $RemotePkgList = {};
1044 dpurdie 641 
        return;
642 
    }
643 
 
644 
    #
1038 dpurdie 645 
    #   Time to perform the scan
646 
    #   Will do at startup and every time period there after
647 
    #
1040 dpurdie 648 
    my $wtime = $releaseScanMode ? $conf->{'syncretry'} : $conf->{'synctime'};
649 
    return unless ( $now > ($lastReleaseScan + $wtime ));
1038 dpurdie 650 
    $logger->verbose("processReleaseList");
651 
    $lastReleaseScan = $now;
1040 dpurdie 652 
    $releaseScanMode = 1;                                   # Assume error
1038 dpurdie 653 
 
654 
    #
6772 dpurdie 655 
    #   Ensure that we have the basic tools for the transfer
656 
    #
657 
    checkForBasicTools();
658 
 
659 
    #
1038 dpurdie 660 
    #   Get list of packages from Remote site
661 
    #
662 
    my $remotePkgList;
5404 dpurdie 663 
    my $remoteData;
6320 dpurdie 664 
    my $blatBinData;
1038 dpurdie 665 
 
7389 dpurdie 666 
    #
667 
    #   Get Data from an S3 bucket
668 
    #   Can only get a part of the full data set. The timestamp can't be processed, so set it to -1
669 
    #
670 
    if ($isS3Target ) {
671 
        my $ph;
672 
        my $tgt_cmd = "aws s3 ls $conf->{'S3Bucket'}/";
673 
 
674 
        $logger->verbose2("processReleaseList:s3_cmd:$tgt_cmd");
675 
        open ($ph, "$tgt_cmd |");
676 
        while ( <$ph> )
1038 dpurdie 677 
        {
7389 dpurdie 678 
            chomp;
679 
            m~.*\s(.*)__(.*).tgz$~;
680 
            $remotePkgList->{$1}{$2}{s3} = 1;
1038 dpurdie 681 
        }
7389 dpurdie 682 
        close ($ph);
683 
 
684 
    } else {
685 
        # Get Data from a dpkg_archive maintained via ssh
686 
        #   Invoke a program on the remote site and parse the results
687 
        #
688 
        #   Returned data looks like:
689 
        #       Metadata avail="140100452"
690 
        #       BlatBin MD5="9e2c6e45af600a20a01dbcb7570da1f1" file="stat.pl"
691 
        #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
692 
        #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas" "link=latest"
693 
        #       time="1497954104" GMT="Tue Jun 20 10:21:44 2017" pname="ERGissaccounts" pver="1.0.7178.mas" deleted="0"
694 
 
695 
        my $ph;
696 
        my $tgt_cmd = "$conf->{'bindir'}/get_plist.pl";
697 
        my $ssh_cmd = sshCmd($tgt_cmd);
698 
 
699 
        $logger->verbose2("processReleaseList:ssh_cmd:$ssh_cmd");
700 
        open ($ph, "$ssh_cmd |");
701 
        while ( <$ph> )
6320 dpurdie 702 
        {
7389 dpurdie 703 
            chomp;
704 
            if ($_ =~ m~^Metadata\s+~)
5404 dpurdie 705 
            {
7389 dpurdie 706 
                parsePkgMetaData($_, \%{$remoteData});
5404 dpurdie 707 
            }
7389 dpurdie 708 
            elsif ($_ =~ m~^BlatBin\s+~)
709 
            {
710 
                parseBlatBinData($_, \%{$blatBinData})
711 
            }
5404 dpurdie 712 
            else
713 
            {
7389 dpurdie 714 
                if ( parsePkgList($_, \%{$remotePkgList} ) )
715 
                {
716 
                    $logger->verbose2("processReleaseList:Data: $_");
717 
                }
718 
                else
719 
                {
720 
                    $logger->warn("processReleaseList:Bad Data: $_");
721 
                }
5404 dpurdie 722 
            }
1038 dpurdie 723 
        }
7389 dpurdie 724 
        close ($ph);
1038 dpurdie 725 
    }
726 
    $logger->verbose("processReleaseList:End: $?");
6148 dpurdie 727 
    $RemotePkgList = $remotePkgList;
728 
 
3515 dpurdie 729 
    LogTxError ($?);
1038 dpurdie 730 
    if ( $? != 0 )
731 
    {
732 
        $logger->warn("Cannot retrieve package list: $?");
5398 dpurdie 733 
        $statistics{state} = 'No Remote Package List';
1038 dpurdie 734 
        return;
735 
    }
1042 dpurdie 736 
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
6320 dpurdie 737 
 
1038 dpurdie 738 
    #
6475 dpurdie 739 
    #   Ensure that the target bin folder is up to date
740 
    #
741 
    transferTargetBin($blatBinData);
6320 dpurdie 742 
 
743 
    #
1038 dpurdie 744 
    #   Determine the set of packages in the releases to be transferred
4456 dpurdie 745 
    #
746 
    my $pkgList;
747 
    if ( $conf->{'allArchive'} )
1040 dpurdie 748 
    {
4456 dpurdie 749 
        #   Examine entire archive
750 
        #
751 
        $pkgList = getArchiveList();
1040 dpurdie 752 
    }
4456 dpurdie 753 
    else
754 
    {
755 
        #   Examine Releases
756 
        #
757 
        my @rlist = getReleaseList();
758 
        unless ( @rlist )
759 
        {
760 
            $logger->verbose2("No Releases to Process");
5398 dpurdie 761 
            $statistics{state} = 'No Releases found';
6475 dpurdie 762 
 
763 
            #   Allow config with just specified packages
764 
            #
765 
            #   return;
766 
        } else {
767 
            $pkgList = getPkgList(@rlist);
4456 dpurdie 768 
        }
769 
    }
1038 dpurdie 770 
 
771 
    #
772 
    #   Append extra packages
773 
    #   These are packages that are specifically named by the user
774 
    #
6475 dpurdie 775 
    #   Note: If they are symbolic links, then the target of the
776 
    #         link is also added.
1038 dpurdie 777 
    #
778 
    #         Symlink MUST be within the same directory
3846 dpurdie 779 
    #           Used to transfer jats2_current
1038 dpurdie 780 
    #
781 
    while ( (my ($pname, $pvers)) = each %{$extraPkgs} ) {
782 
        while ( (my ($pver, $pdata) ) = each %{$pvers} ) {
783 
 
1040 dpurdie 784 
            my $epath = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
1038 dpurdie 785 
            if ( -l $epath )
786 
            {
787 
                my $lver = readlink( $epath );
788 
                if ( ! defined $lver )
789 
                {
3846 dpurdie 790 
                    $logger->warn("Can't resolve symlink: $pname, $pver");
1038 dpurdie 791 
                    next;
792 
                }
793 
 
794 
                if ( $lver =~ m ~/~ )
795 
                {
796 
                    $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
797 
                    next;
798 
                }
6098 dpurdie 799 
 
6475 dpurdie 800 
                #
801 
                #   Add the package the link points to
802 
                #
803 
                $logger->verbose2("Add linked package: $pname, $lver, $pdata");
804 
                $pkgList->{$pname}{$lver} = $pdata;
7389 dpurdie 805 
 
806 
                if ($isS3Target) {
807 
                    $logger->verbose2("Won't send symlink to S3: $pname, $pver, $lver");
808 
                    next;
809 
                }
810 
 
1038 dpurdie 811 
            }
812 
 
813 
            $logger->verbose2("Add extra package: $pname, $pver, $pdata");
814 
            $pkgList->{$pname}{$pver} = $pdata;
815 
        }
816 
    }
6475 dpurdie 817 
#Utils::DebugDumpData ("parsePkgList", $rv);
7389 dpurdie 818 
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
1038 dpurdie 819 
 
6475 dpurdie 820 
 
1040 dpurdie 821 
    #
822 
    #   If there are no packages to process, then assume that this is an error
823 
    #   condition. Retry the operation soon.
824 
    #
825 
    unless ( keys %{$pkgList} )
826 
    {
827 
 
828 
        $logger->verbose2("No packages to process");
5398 dpurdie 829 
        $statistics{state} = 'No Packages found';
1040 dpurdie 830 
        return;
831 
    }
832 
 
6475 dpurdie 833 
#   #
834 
#   #   Useful debug code
835 
#   #
836 
#   while ( (my ($pname, $pvers)) = each %{$pkgList} )
837 
#   {
838 
#       while ( (my ($pver, $ptime) ) = each %{$pvers} )
839 
#       {
840 
#           print "L-- $pname, $pver, $ptime \n";
1038 dpurdie 841 
#
6475 dpurdie 842 
#       }
843 
#   }
1038 dpurdie 844 
 
845 
    #
1040 dpurdie 846 
    #   Delete Excess Packages
1038 dpurdie 847 
    #       Packages not required on the target
1042 dpurdie 848 
    #           KLUDGE: Don't delete links to packages
849 
    #           Don't delete packages marked for deletion
1038 dpurdie 850 
    #
851 
    my $excessPkgList;
1048 dpurdie 852 
    my $excessPkgListCount = 0;
1038 dpurdie 853 
    if ( $conf->{deletePackages} )
854 
    {
855 
        while ( (my ($pname, $pvers)) = each %{$remotePkgList} )
856 
        {
857 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
858 
            {
859 
                if ( !exists $pkgList->{$pname}{$pver} )
860 
                {
1040 dpurdie 861 
                    if ( exists $excludePkgs->{$pname} )
862 
                    {
863 
                        $logger->verbose2("Keep Excluded package: ${pname}");
864 
                        next;
865 
                    }
866 
 
1042 dpurdie 867 
                    if ( exists $pdata->{deleted} )
868 
                    {
869 
                        if ( $conf->{deleteAge} )
870 
                        {
871 
                            if ( $pdata->{deleted} <= $conf->{deleteAge} )
872 
                            {
873 
                                $logger->verbose2("Already marked for future age deletion: ${pname}/${pver}, $pdata->{deleted}");
874 
                                next;
875 
                            }
876 
                            $pdata->{FORCEDELETE} = 1;
877 
                        }
878 
 
879 
                        if ( !$conf->{deleteImmediate} )
880 
                        {
881 
                            $logger->verbose2("Already marked for deletion: ${pname}/${pver}");
882 
                            next;
883 
                        }
884 
                    }
885 
 
886 
                    #
887 
                    #   Force deletion
888 
                    #       deleteImmediate mode
889 
                    #       target is a broken link
890 
                    #
891 
                    $pdata->{FORCEDELETE} = 1
892 
                        if ($conf->{deleteImmediate} || $pdata->{broken});
893 
 
1038 dpurdie 894 
                    $excessPkgList->{$pname}{$pver} = $pdata;
1048 dpurdie 895 
                    $excessPkgListCount++;
1038 dpurdie 896 
                    $logger->verbose("Excess package: ${pname}/${pver}");
897 
                }
1050 dpurdie 898 
#                else
899 
#                {
900 
#                        $logger->verbose3("Retain package: ${pname}/${pver}");
901 
#                }
1038 dpurdie 902 
            }
903 
        }
904 
    }
905 
 
906 
    #
907 
    #   Process the remote list and the local list
908 
    #   The remote time-stamp is the modification time of the packages descpkg file
909 
    #
910 
    #   Mark for transfer packages that
1040 dpurdie 911 
    #       Are in the local set but not the remote set
1038 dpurdie 912 
    #       Have a different time stamp
913 
    #
914 
    #   Ignore packages not in the local archive
915 
    #   Ignore packages that don't have a descpkg
916 
    #   Ignore packages that are writable - still being formed
917 
    #
918 
    my $needPkgList;
1048 dpurdie 919 
    my $needPkgListCount = 0;
920 
    my $filteredCount = 0;
921 
    my $missingCount = 0;
922 
    my $writableCount = 0;
923 
    my $excludeCount = 0;
5404 dpurdie 924 
    my $packageVersionCount = 0;
1038 dpurdie 925 
    while ( (my ($pname, $pvers)) = each %{$pkgList} )
926 
    {
1040 dpurdie 927 
        #
928 
        #   Ignore excluded packages
929 
        #
1048 dpurdie 930 
        if ( exists $excludePkgs->{$pname} )
931 
        {
932 
            $excludeCount++;
933 
            next;
934 
        }
1040 dpurdie 935 
 
1048 dpurdie 936 
        #
937 
        #   Ignore packages that are filtered out
938 
        #
939 
        if ( defined $conf->{'packageFilter'} )
940 
        {
941 
            unless ( $pname =~ m~$conf->{'packageFilter'}~ )
942 
            {
943 
                $logger->verbose3("Filtering out: ${pname}");
944 
                $filteredCount++;
945 
                next;
946 
            }
947 
        }
948 
 
1038 dpurdie 949 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
950 
        {
6475 dpurdie 951 
            my $must_transfer;
952 
            my $existsRemote = exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver});
953 
 
6148 dpurdie 954 
            #
955 
            #   Take care not to create an entry into $remotePkgList->{$pname}{$pver}
956 
            #   if it does not exist. Existence of {$pname}{$pver} is used later
957 
            #
7389 dpurdie 958 
            my $tmtime = undef;
6475 dpurdie 959 
            if ($existsRemote && exists ($remotePkgList->{$pname}{$pver}{time})) {
6148 dpurdie 960 
                $tmtime = $remotePkgList->{$pname}{$pver}{time};
961 
            }
5404 dpurdie 962 
            $packageVersionCount++;
1038 dpurdie 963 
 
964 
            # Package is present in both list
6475 dpurdie 965 
            my $localPackage = catdir( $conf->{'dpkg_archive'} , $pname, $pver );
966 
            my ($mtime, $mode) = Utils::mtime( catfile($localPackage, 'descpkg') );
1038 dpurdie 967 
            if ( $mtime == 0 )
968 
            {
969 
                # PackageVersion not in local archive (at least the descpkg file is not)
970 
                # Skip now - will pick it up later
971 
                $logger->verbose("Package not in dpkg_archive: $pname, $pver");
1048 dpurdie 972 
                $missingCount++;
1038 dpurdie 973 
                next;
974 
            }
975 
 
976 
            if ( $mode & 0222 )
977 
            {
978 
                # Descpkg file is writable
979 
                # Package may be in the process of being created
1048 dpurdie 980 
                # If the package has been writable for a long time, then
1038 dpurdie 981 
                # consider for transfer
982 
                my $age = $now - $mtime;
983 
                if ( $age < ($conf->{'writewindow '} || 600) )
984 
                {
985 
                    $logger->verbose("Package is writable: $pname, $pver, ", $now - $mtime);
1048 dpurdie 986 
                    $writableCount++;
1038 dpurdie 987 
                    next;
988 
                }
989 
            }
990 
 
7389 dpurdie 991 
            if (! $existsRemote ) {
992 
                #
993 
                #   Package does not exist in the remote, and is eligible for transfer
994 
                #
995 
                $logger->verbose("Package Needs to be transferred: $pname, $pver");
996 
                $must_transfer = 1;
997 
 
998 
            } elsif ( defined $tmtime && ($mtime != $tmtime) ) {
999 
                #
1000 
                #   Package exists in both source and target
1001 
                #   If the package-time is known, then ensure that they are the same
1002 
                #
6475 dpurdie 1003 
                $logger->verbose("Package Needs to be transferred: $pname, $pver, $mtime, $tmtime");
1004 
                $must_transfer = 1;
1005 
            }
7389 dpurdie 1006 
            else
1038 dpurdie 1007 
            {
6475 dpurdie 1008 
                #
1009 
                #   Package exists in both source and target
1010 
                #   Symlink test: Ensure symlinks are the same
1011 
                #
1012 
                my $localIsSymlink = -l $localPackage;
1013 
                my $remoteIsSymlink = exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver}) && exists ($remotePkgList->{$pname}{$pver}{link});
1014 
 
1015 
                if ($remoteIsSymlink && $localIsSymlink) {
1016 
                    #
1017 
                    #   Both are symlinks - check that they address the same item
1018 
                    #
1019 
                    my $targetLink = $remotePkgList->{$pname}{$pver}{link};
1020 
                    $logger->verbose2("Package is symlink: $pname, $pver -> $targetLink");
1021 
 
1022 
                    my $lver = readlink( $localPackage );
1023 
                    if ( ! defined $lver ) {
1024 
                        $logger->warn("Can't resolve symlink: $pname, $pver");
1025 
                        next;
1026 
                    }
1027 
                    if ($targetLink ne $lver ) {
1028 
                        $logger->verbose("Package symlinks differ: $pname, $pver, $targetLink, $lver");
1029 
                        $must_transfer = 3;
1030 
                    }
1031 
 
1032 
                } elsif ($remoteIsSymlink || $localIsSymlink ) {
1033 
                    #
1034 
                    #   Only one is a symlink - force transfer
1035 
                    #
1036 
                    $logger->warn("Packages versions not both symlink: $pname, $pver, L:$remoteIsSymlink R:$localIsSymlink");
1037 
                    $must_transfer = 2;
1038 
                }
1039 
            }
1040 
 
1041 
            #
1042 
            #   If we are forcing a package transfer then flag it and also remove it from the
1043 
            #   RemotePkgList so that it will be transferred - even if its present on target
1044 
            #
1045 
            if ($must_transfer) {
1038 dpurdie 1046 
                # Package not present on target, or timestamps differ
1047 
                $needPkgList->{$pname}{$pver} = $pdata;
6475 dpurdie 1048 
                delete $RemotePkgList->{$pname}{$pver};
1048 dpurdie 1049 
                $needPkgListCount++;
1038 dpurdie 1050 
                next;
1051 
            }
1052 
        }
1053 
    }
1054 
 
1048 dpurdie 1055 
 
1038 dpurdie 1056 
    #
1057 
    #   Debug output only
1058 
    #   Display what we need to transfer
1059 
    #
1060 
    if ( $conf->{verbose} > 2 )
1061 
    {
1062 
        while ( (my ($pname, $pvers)) = each %{$needPkgList} )
1063 
        {
1064 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
1065 
            {
1066 
                $logger->verbose("Need to transfer: $pname, $pver, $pdata");
1067 
            }
1068 
        }
1069 
    }
1048 dpurdie 1070 
    if ( $conf->{verbose}  )
1071 
    {
1072 
        $logger->verbose("Packages to transfer: $needPkgListCount");
1073 
        $logger->verbose("Packages to delete: $excessPkgListCount");
1074 
        $logger->verbose("Packages filtered out: $filteredCount");
1075 
        $logger->verbose("Packages missing: $missingCount");
1076 
        $logger->verbose("Packages still writable: $writableCount");
1077 
        $logger->verbose("Packages excluded: $excludeCount");
1078 
    }
1038 dpurdie 1079 
 
1080 
    #
5398 dpurdie 1081 
    #   Update stats
1082 
    #   At this point we are looking pretty good
1083 
    #
1084 
    $statistics{state} = 'OK';
5404 dpurdie 1085 
    $statistics{total} = $packageVersionCount;
5398 dpurdie 1086 
    $statistics{transfer} = $needPkgListCount;
1087 
    $statistics{delete} = $excessPkgListCount;
1088 
    $statistics{filtered} = $filteredCount;
1089 
    $statistics{missing} = $missingCount;
1090 
    $statistics{writable} = $writableCount;
1091 
    $statistics{excluded} = $excludeCount;
1092 
 
1093 
    #
1038 dpurdie 1094 
    #   Time to do the real work
1095 
    #   Transfer packages and delete excess packages
1096 
    #   Note: Perform the transfers first
1097 
    #         Limit the number of packages processed in one pass
1098 
    #
1099 
    my $txcount = $conf->{maxpackages};
1100 
 
1101 
    #
1102 
    #   Transfer packages that we have identified
1103 
    #
1104 
    send_pkgs:
1105 
    while ( (my ($pname, $pvers)) = each %{$needPkgList} )
1106 
    {
1107 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
1108 
        {
1109 
            if ( --$txcount <= 0 )
1110 
            {
1050 dpurdie 1111 
                $logger->warn("Max transfer count exceeded: $needPkgListCount transfer remaining");
1038 dpurdie 1112 
                $lastReleaseScan = 0;
1113 
                last send_pkgs;
1114 
            }
1289 dpurdie 1115 
 
1116 
            if ( readConfig() )
1117 
            {
1118 
                $logger->warn("Config file changed");
1119 
                $txcount = 0;
1120 
                last send_pkgs;
1121 
            }
1122 
 
6475 dpurdie 1123 
            transferPackage ($pname, $pver);
1048 dpurdie 1124 
            $needPkgListCount--;
6779 dpurdie 1125 
            reapChildren();
1038 dpurdie 1126 
        }
1127 
    }
1128 
 
1129 
    #
1130 
    #   Delete packages that have been identified as excess
1131 
    #
1132 
    delete_pkgs:
1133 
    while ( (my ($pname, $pvers)) = each %{$excessPkgList} )
1134 
    {
1135 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
1136 
        {
1137 
            if ( --$txcount <= 0 )
1138 
            {
1050 dpurdie 1139 
                $logger->warn("Max transfer count exceeded: $excessPkgListCount deletion remaining");
1038 dpurdie 1140 
                $lastReleaseScan = 0;
1141 
                last delete_pkgs;
1142 
            }
1289 dpurdie 1143 
 
1144 
            if ( readConfig() )
1145 
            {
1146 
                $logger->warn("Config file changed");
1147 
                $txcount = 0;
6779 dpurdie 1148 
                last delete_pkgs;
1289 dpurdie 1149 
            }
1150 
 
1044 dpurdie 1151 
            deletePackage ($pname, $pver, $pdata);
1048 dpurdie 1152 
            $excessPkgListCount--;
6779 dpurdie 1153 
            reapChildren();
1038 dpurdie 1154 
        }
1155 
    }
1156 
 
1157 
    #
1158 
    #   Send package list to the target
1159 
    #
1160 
    sendPackageList ($pkgList);
1040 dpurdie 1161 
 
1162 
    #
1163 
    #   On a successful transfer
1164 
    #       Force tag processing
1165 
    #       Set scan Mode to normal
1166 
    #
1167 
    $tagDirTime = 0;
1168 
    $releaseScanMode = 0;
1038 dpurdie 1169 
}
1170 
 
1171 
#-------------------------------------------------------------------------------
1172 
# Function        : sendPackageList
1173 
#
1174 
# Description     : Transfer package list to the target
1175 
#
1176 
# Inputs          : $pkgList            - Ref to hash of package names and versions
1177 
#
1040 dpurdie 1178 
# Returns         : Nothing
1179 
#                   Don't really care about any errors from this process
1180 
#                   Its not essential
1038 dpurdie 1181 
#
1182 
sub sendPackageList
1183 
{
7389 dpurdie 1184 
    return if $isS3Target;
1185 
 
1038 dpurdie 1186 
    my ($pkgList) = @_;
1187 
    my ($fh, $filename) = tempfile( "/tmp/blat.$$.XXXX", SUFFIX => '.txt');
1188 
    $logger->verbose("sendPackageList:TmpFile: $filename");
6776 dpurdie 1189 
 
1190 
    return if $conf->{'noTransfers'};
1038 dpurdie 1191 
 
1192 
    #
1193 
    #   Create a temp file with data
1194 
    #
1195 
    foreach my $pname ( sort keys %{$pkgList} )
1196 
    {
1197 
        foreach my $pver ( sort keys %{$pkgList->{$pname}} )
1198 
        {
1199 
            print $fh "$pname/$pver\n";
1200 
        }
1201 
    }
1202 
    close $fh;
1203 
 
1204 
    #
1205 
    #   Transfer to target
1206 
    #   Create the process pipe to transfer the file
1207 
    #   gzip the file and pipe the result through a ssh session to the target machine
3515 dpurdie 1208 
    #   gzip -c filename |  ssh  ... "./receive_file filename"
1038 dpurdie 1209 
    #
1210 
    my $ph;
3515 dpurdie 1211 
    my $gzip_cmd = "$gzip --no-name -c \"$filename\"";
1040 dpurdie 1212 
    my $tgt_cmd = "$conf->{'bindir'}/receive_file \"ArchiveList\"";
3515 dpurdie 1213 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 1214 
 
1215 
    $logger->verbose2("sendPackageList:gzip_cmd:$gzip_cmd");
1216 
    $logger->verbose2("sendPackageList:tgt_cmd:$tgt_cmd");
1217 
    $logger->verbose2("sendPackageList:ssh_cmd:$ssh_cmd");
1218 
 
1219 
    open ($ph, "$gzip_cmd | $ssh_cmd |");
1220 
    while ( <$ph> )
1221 
    {
1222 
        chomp;
1223 
        $logger->verbose2("sendPackageList:Data: $_");
1224 
    }
1225 
    close ($ph);
3515 dpurdie 1226 
    unlink $filename;
1038 dpurdie 1227 
    $logger->verbose("sendPackageList:End: $?");
3515 dpurdie 1228 
    LogTxError ($?);
1038 dpurdie 1229 
}
1230 
 
1231 
 
1232 
#-------------------------------------------------------------------------------
1233 
# Function        : getPkgList
1234 
#
1235 
# Description     : Determine a set of package versions within the list
1236 
#                   of provided releases
1237 
#
1238 
# Inputs          : @rlist              - A list of releases to examine
1239 
#
1240 
# Returns         : Ref to a hask of package versions
1241 
#
1242 
sub getPkgList
1243 
{
1244 
    my %pdata;
1245 
    my $RM_DB;
1246 
    connectRM(\$RM_DB);
1247 
    $logger->verbose("getPkgList");
1248 
 
1249 
    #
1250 
    #   Determine the releases that are in this project
1251 
    #   Build up an sql query
1252 
    #
6776 dpurdie 1253 
    my $m_rlist = join ',', @_;
1048 dpurdie 1254 
    my $m_sqlstr = "SELECT DISTINCT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, pv.IS_DEPLOYABLE" .
1038 dpurdie 1255 
                    " FROM RELEASE_MANAGER.RELEASE_CONTENT rc, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
6776 dpurdie 1256 
                    " WHERE ( RTAG_ID in ($m_rlist) ) AND rc.PV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID" .
1038 dpurdie 1257 
                    " ORDER by PKG_NAME DESC";
1258 
    $logger->verbose3("getPkgList:Sql:$m_sqlstr");
1259 
 
1260 
    my $sth = $RM_DB->prepare($m_sqlstr);
1261 
    if ( defined($sth) )
1262 
    {
1263 
        if ( $sth->execute( ) )
1264 
        {
1265 
            if ( $sth->rows )
1266 
            {
1267 
                while (my @row = $sth->fetchrow_array )
1268 
                {
1269 
                    $logger->verbose2("getPkgList:Data:@row");
1270 
                    $pdata{$row[1]}{$row[2]} = 1;
1271 
                }
1272 
            }
1273 
            $sth->finish();
1274 
        }
1275 
    }
1276 
    else
1277 
    {
1278 
        $logger->warn("getPkgList: SQL Prepare failure");
1279 
    }
1050 dpurdie 1280 
 
1281 
   disconnectRM(\$RM_DB);
1038 dpurdie 1282 
   return \%pdata;
1283 
}
1284 
 
1285 
 
1286 
#-------------------------------------------------------------------------------
1287 
# Function        : getReleaseList
1288 
#
1289 
# Description     : Determine the list of releases to be proccessed
1040 dpurdie 1290 
#                   From:
1291 
#                       Convert projects to a list of releases
1292 
#                       Configured list of releases
1038 dpurdie 1293 
#
1294 
# Inputs          : None
1295 
#
1296 
# Returns         : A list of releases to be processed
1297 
#
1298 
sub getReleaseList
1299 
{
1300 
    my $RM_DB;
1301 
    my %rlist;
1048 dpurdie 1302 
    my $m_sqlstr;
1038 dpurdie 1303 
    $logger->verbose("getReleaseList");
1304 
 
1305 
    #
1040 dpurdie 1306 
    #   Cache data
1307 
    #   Only for one cycle of the main loop
1308 
    #
1309 
    if ( exists $releaseData{getReleaseList} )
1310 
    {
1311 
        $logger->verbose3("getReleaseList:Cache hit");
1312 
        return @{$releaseData{getReleaseList}};
1313 
    }
1314 
 
1315 
    #
1048 dpurdie 1316 
    #   All projects
1038 dpurdie 1317 
    #
1048 dpurdie 1318 
    if ( $conf->{'allProjects'} )
1038 dpurdie 1319 
    {
1048 dpurdie 1320 
        $m_sqlstr = "SELECT rt.RTAG_ID" .
1321 
                    " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
1050 dpurdie 1322 
                    " WHERE rt.OFFICIAL != 'A'";
1323 
                    #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 1324 
    }
1325 
    else
1326 
    {
1038 dpurdie 1327 
        #
1048 dpurdie 1328 
        #   Convert list of projects into a list of releases
1038 dpurdie 1329 
        #
6776 dpurdie 1330 
        if ( @projectList )
1048 dpurdie 1331 
        {
1332 
            #
1333 
            #   Determine the releases that are in this project
1334 
            #   Build up an sql query
1335 
            #
6776 dpurdie 1336 
            my $m_plist = join ',', @projectList;
1048 dpurdie 1337 
            $m_sqlstr = "SELECT rt.RTAG_ID" .
1338 
                        " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
6776 dpurdie 1339 
                        " WHERE ( PROJ_ID in ( $m_plist) ) AND rt.OFFICIAL != 'A'";
5300 dpurdie 1340 
                        #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 1341 
        }
1342 
    }
1038 dpurdie 1343 
 
1048 dpurdie 1344 
    if ( defined $m_sqlstr )
1345 
    {
1038 dpurdie 1346 
        $logger->verbose3("getReleaseList:Sql:$m_sqlstr");
1048 dpurdie 1347 
        connectRM(\$RM_DB);
1038 dpurdie 1348 
        my $sth = $RM_DB->prepare($m_sqlstr);
1349 
        if ( defined($sth) )
1350 
        {
1351 
            if ( $sth->execute( ) )
1352 
            {
1353 
                if ( $sth->rows )
1354 
                {
1355 
                    while (my @row = $sth->fetchrow_array )
1356 
                    {
1357 
                        $logger->verbose2("getReleaseList:Data:@row");
1358 
                        $rlist{$row[0]} = 1;
1359 
                    }
1360 
                }
1361 
                $sth->finish();
6776 dpurdie 1362 
            } else {
1363 
                $logger->warn("getReleaseList: SQL Execute failure");
1038 dpurdie 1364 
            }
1365 
        }
1366 
        else
1367 
        {
1368 
            $logger->warn("getReleaseList: SQL Prepare failure");
1369 
        }
1050 dpurdie 1370 
        disconnectRM(\$RM_DB);
1038 dpurdie 1371 
    }
1372 
 
1373 
    #
1374 
    #   Add in the user specified list of releases
1375 
    #
6776 dpurdie 1376 
    $rlist{$_} = 1 foreach(@releaseList);
1038 dpurdie 1377 
 
1378 
    #
1379 
    #   Sort for pretty display only
1380 
    #
1040 dpurdie 1381 
    @{$releaseData{getReleaseList}} = sort {$a <=> $b} keys %rlist;
1382 
 
1383 
    return @{$releaseData{getReleaseList}};
1038 dpurdie 1384 
}
1385 
 
1040 dpurdie 1386 
#-------------------------------------------------------------------------------
3846 dpurdie 1387 
# Function        : getPackageVersions
1388 
#
1389 
# Description     : Get the list of package-versions available in the package
1390 
#                   store.
1391 
#
1392 
# Inputs          : pkgName             - The package name
1393 
#
1394 
# Returns         : Array of versions
1395 
#
1396 
sub getPackageVersions
1397 
{
1398 
    my ($pkgName) = @_;
1399 
    my @versionList;
1400 
 
1401 
    my $pkgDir = catfile($conf->{'dpkg_archive'} , $pkgName );
1402 
    my $dh;
1403 
 
1404 
    unless (opendir($dh, $pkgDir))
1405 
    {
1406 
        $logger->warn ("Can't opendir $pkgDir: $!");
1407 
        return @versionList;
1408 
    }
1409 
 
1410 
    #
1411 
    #   Process each entry
1412 
    #   Ignore those that start with a .
1413 
    #
1414 
    while (my $version = readdir($dh) )
1415 
    {
1416 
        next if ( $version =~ m~^\.~ );
1417 
        my $file = catfile($pkgDir, $version);
1418 
 
1419 
        next unless ( -d $file );
1420 
 
1421 
        push @versionList, $version;
1422 
        $logger->verbose3("getPackageVersions: $pkgName, $version");
1423 
    }
1424 
    closedir $dh;
1425 
    return @versionList;
1426 
}
1427 
 
1428 
#-------------------------------------------------------------------------------
4456 dpurdie 1429 
# Function        : getArchiveList
1430 
#
1431 
# Description     : Get the entire set of package versions in the archive
1432 
#
1433 
# Inputs          :
1434 
#
6475 dpurdie 1435 
# Returns         : Ref to a hash of package versions
4456 dpurdie 1436 
#
1437 
sub getArchiveList
1438 
{
1439 
    my $pkgDir = $conf->{'dpkg_archive'};
1440 
    my %archiveList;
1441 
    my $dh;
1442 
    my @pkgList;
1443 
 
1444 
    unless (opendir($dh, $pkgDir))
1445 
    {
1446 
        $logger->warn ("Can't opendir $pkgDir: $!");
1447 
        return \%archiveList;
1448 
    }
1449 
 
1450 
    #
1451 
    #   Process each entry
1452 
    #   Ignore those that start with a .
1453 
    #   Ignore files
1454 
    #
1455 
    while (my $pkgName = readdir($dh) )
1456 
    {
1457 
        next if ( $pkgName =~ m~^\.~ );
1458 
        my $file = catfile($pkgDir, $pkgName);
1459 
 
1460 
        next unless ( -d $file );
1461 
        $logger->verbose3("getArchiveList: $pkgName");
1462 
        push @pkgList, $pkgName;
1463 
    }
1464 
    closedir $dh;
1465 
 
1466 
    #   Now get the package versions
1467 
    #       Sort for pretty display
1468 
    foreach my $pname (sort @pkgList)
1469 
    {
1470 
        foreach my $pver (getPackageVersions($pname))
1471 
        {
1472 
            $archiveList{$pname}{$pver} = 1;
1473 
        }
1474 
    }
1475 
 
1476 
    return \%archiveList;
1477 
}
1478 
 
1479 
#-------------------------------------------------------------------------------
6320 dpurdie 1480 
# Function        : getBlatBin
1481 
#
1482 
# Description     : Get the list of files that should be in the targetbin directory
1483 
#
1484 
# Inputs          : Nothing
1485 
#
1486 
# Returns         : A hash of data
1487 
#
1488 
sub getBlatBin
1489 
{
1490 
    my $data;
1491 
    $logger->verbose("getBlatBin: $targetBinDir");
1492 
    if (opendir(DIR, $targetBinDir ) ) {
1493 
        my @vlist = readdir(DIR);
1494 
        closedir DIR;
1495 
 
1496 
        foreach my $vname ( sort @vlist )
1497 
        {
1498 
            next if ( $vname eq '.' );
1499 
            next if ( $vname eq '..' );
1500 
            next unless ( -f "$targetBinDir/$vname" );
1501 
 
1502 
            if (open FILE, "$targetBinDir/$vname") {
1503 
                $data->{$vname} = Digest::MD5->new->addfile(*FILE)->hexdigest;
1504 
                close (FILE);
1505 
            }
1506 
        }
1507 
    } else {
1508 
        $logger->warn("BlatBin Not Found: $targetBinDir");
1509 
    }
1510 
    return $data;
1511 
}
1512 
 
1513 
 
1514 
#-------------------------------------------------------------------------------
1040 dpurdie 1515 
# Function        : maintainTagList
1516 
#
1517 
# Description     : Maintain a data structure for the maintenance of the
1518 
#                   tags directory
1519 
#
1520 
# Inputs          : None
1521 
#
1522 
# Returns         : Nothing
1523 
#
1524 
sub maintainTagList
1525 
{
1526 
    #
1527 
    #   Time to perform the scan
1528 
    #   Will do at startup and every time period there after
1529 
    #
6779 dpurdie 1530 
    return unless ( $now > ($lastTagListUpdate + $conf->{tagListUpdate} ));
1040 dpurdie 1531 
    $logger->verbose("maintainTagList");
6779 dpurdie 1532 
    $lastTagListUpdate = $now;
1038 dpurdie 1533 
 
1040 dpurdie 1534 
    #
1535 
    #   Get list of things
1536 
    #
1537 
    my %config;
4457 dpurdie 1538 
    if ($conf->{'allArchive'} )
1539 
    {
1540 
        $config{allArchive} = 1
1541 
    }
1542 
    elsif ($conf->{'allProjects'} )
1543 
    {
1544 
        $config{allProjects} = 1;
1545 
    }
1546 
    else
1547 
    {
6776 dpurdie 1548 
        %{$config{projects}} = map { $_ => 1 } @projectList;
4457 dpurdie 1549 
        %{$config{releases}} = map { $_ => 1 } getReleaseList();
1550 
    }
1040 dpurdie 1551 
 
1552 
    #
1553 
    #   Save data
1554 
    #
1555 
    my $dump =  Data::Dumper->new([\%config], [qw(*config)]);
1556 
#print $dump->Dump;
1557 
#$dump->Reset;
1558 
 
1559 
    #
1560 
    #   Save config data
1561 
    #
1562 
    my $conf_file = catfile( $conf->{'tagdir'},'.config' );
1563 
    $logger->verbose3("maintainTagList: Writting $conf_file");
1564 
 
1565 
    my $fh;
1566 
    open ( $fh, '>', $conf_file ) or $logger->err("Can't create $conf_file: $!");
1567 
    print $fh $dump->Dump;
1568 
    close $fh;
1569 
}
1570 
 
1571 
 
1038 dpurdie 1572 
#-------------------------------------------------------------------------------
1573 
# Function        : processTags
1574 
#
1575 
# Description     : Process tags and send marked package versions to the target
1576 
#                       Determine if new tags are present
1577 
#                       Process each tag
1578 
#
1579 
# Inputs          : None
1580 
#
1581 
# Returns         : Nothing
1582 
#
1583 
sub processTags
1584 
{
6779 dpurdie 1585 
 
1038 dpurdie 1586 
    #
6779 dpurdie 1587 
    #   Is Tag Processing active
1588 
    #   Can configure blat to disable tag sync
1589 
    #
1590 
    if ( $conf->{'tagMaxPackages'} == 0 )
1591 
    {
1592 
        $logger->verbose2("processTags disabled");
1593 
        return;
1594 
    }
1595 
 
1596 
    #
1038 dpurdie 1597 
    #   Determine if new tags are present by examining the time
1598 
    #   that the directory was last modified.
1599 
    #
1600 
    #   Allow for a forced scan to catch packages that did not transfer
1601 
    #   on the first attempt
1602 
    #
5398 dpurdie 1603 
    my $tagCount = 0;
1038 dpurdie 1604 
    my ($mtime) = Utils::mtime($conf->{'tagdir'} );
1605 
    if ( ($mtime > $tagDirTime) || ($now > ($lastDirScan + $conf->{'forcedirscan'})) )
1606 
    {
1042 dpurdie 1607 
        $logger->verbose2("processTags: ",$conf->{'tagdir'}, $mtime - $tagDirTime, $now - $lastDirScan);
1038 dpurdie 1608 
        $tagDirTime = $mtime;
1609 
        $lastDirScan = $now;
6779 dpurdie 1610 
        my $txcount = $conf->{'tagMaxPackages'};
1038 dpurdie 1611 
 
6779 dpurdie 1612 
 
1038 dpurdie 1613 
        my $dh;
1614 
        unless (opendir($dh, $conf->{'tagdir'}))
1615 
        {
1616 
            $logger->warn ("can't opendir $conf->{'tagdir'}: $!");
1617 
            return;
1618 
        }
1619 
 
1620 
        #
1621 
        #   Process each entry
1622 
        #   Ignore those that start with a .
1623 
        #
6779 dpurdie 1624 
        my %tagPkgList;
1038 dpurdie 1625 
        while (my $tag = readdir($dh) )
1626 
        {
1627 
            next if ( $tag =~ m~^\.~ );
1628 
            my $file = "$conf->{'tagdir'}/$tag";
1042 dpurdie 1629 
            $logger->verbose3("processTags: $file");
1630 
 
1038 dpurdie 1631 
            next unless ( -f $file );
1632 
            next if ( $tag  eq 'ReleaseList' );
1633 
 
1634 
            if ( $tag =~ m~(.+)::(.+)~  )
1635 
            {
1636 
                my $package = $1;
1637 
                my $version = $2;
5398 dpurdie 1638 
                $tagCount++;
6779 dpurdie 1639 
                $tagPkgList{$package}{$version} = $file;
1640 
            }
1641 
        }
1642 
        $statistics{tagCount} = $tagCount;
1643 
        closedir $dh;
6098 dpurdie 1644 
 
6779 dpurdie 1645 
        #
1646 
        #   Process the packages located in the tags area
1647 
        #
1648 
        send_tags:
1649 
        while ( (my ($package, $pvers)) = each %{tagPkgList} )
1650 
        {
1651 
            while ( (my ($version, $file) ) = each %{$pvers} )
1652 
            {
1653 
                if ( --$txcount <= 0 )
1654 
                {
1655 
                    $logger->warn("Max tag transfer count exceeded: $tagCount transfer remaining");
1656 
                    $tagDirTime = 0;
1657 
                    last send_tags;
1658 
                }
1659 
 
1660 
                if ( readConfig() )
1661 
                {
1662 
                    $logger->warn("Config file changed");
1663 
                    $txcount = 0;
1664 
                    $tagDirTime = 0;
1665 
                    last send_tags;
1666 
                }
1667 
 
7389 dpurdie 1668 
#               #
1669 
#               #   Don't transfer 'extra' packages
1670 
#               #   Removed. It was casuing a tarZip to be triggered, but never transferred
1671 
#               #
1672 
#               if (exists ($extraPkgs->{$package}) )
1673 
#               {
1674 
#                   $logger->warn ("Delete excess package tag: $package::$version");
1675 
#                   unlink $file;
1676 
#
1677 
#               } else
1678 
                if ( transferPackage( $package, $version )) {
1038 dpurdie 1679 
                    unlink $file;
6098 dpurdie 1680 
                }
1038 dpurdie 1681 
                else
1682 
                {
7387 dpurdie 1683 
                    if ($conf->{'tagage'} > 0) {
1684 
                        my ($mtime) = Utils::mtime( $file );
1685 
                        if ( $now - $mtime > $conf->{'tagage'} )
1686 
                        {
1687 
                            $logger->warn ("Delete unsatisfied tag: $package::$version after $conf->{'tagage'}" );
1688 
                            unlink $file;
1689 
                            $statistics{staleTags}++;
1690 
                        }
1038 dpurdie 1691 
                    }
1692 
                }
6779 dpurdie 1693 
 
1694 
                $tagCount--;
1695 
                reapChildren();
1038 dpurdie 1696 
            }
1697 
        }
1698 
    }
1699 
}
1700 
 
1701 
#-------------------------------------------------------------------------------
6320 dpurdie 1702 
# Function        : transferBlatBin
1703 
#
1704 
# Description     : Transfer any of the Blat Bin files that are out of date
1705 
#                   on the target
1706 
#
1707 
# Inputs          : $fileHash       - A hash whose files are those that need
1708 
#                                     to be updated
1709 
#
1710 
# Returns         :
1711 
#
1712 
sub transferBlatBin
1713 
{
1714 
    my ($hash) = @_;
1715 
    $logger->verbose("transferBlatBin");
6776 dpurdie 1716 
 
1717 
    return if $conf->{'noTransfers'};
1718 
 
6320 dpurdie 1719 
    foreach my $file ( sort keys %{$hash})
1720 
    {
1721 
        $logger->logmsg("transferBlatBin: $file");
1722 
 
1723 
        #
1724 
        #   Transfer one file using only 'ssh'
1725 
        #   Create the target directory on the fly
1726 
        #   Manipulate file permissions
1727 
        #   Report errors
1728 
 
1729 
        my $tar_cmd = "cat \"$targetBinDir/$file\"";
6475 dpurdie 1730 
        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 1731 
        my $ssh_cmd = sshCmd($tgt_cmd);
1732 
        my $cat_cmd =
1733 
 
1734 
        $logger->verbose2("transferBlatBin:tar_cmd:$tar_cmd");
1735 
        $logger->verbose2("transferBlatBin:tgt_cmd:$tgt_cmd");
1736 
        $logger->verbose2("transferBlatBin:ssh_cmd:$ssh_cmd");
1737 
 
1738 
        my $ph;
1739 
        open ($ph, "$tar_cmd | $ssh_cmd |");
1740 
        while ( <$ph> )
1741 
        {
1742 
            chomp;
1743 
            $logger->verbose2("transferBlatBin:Data: $_");
1744 
        }
1745 
        close ($ph);
1746 
        $logger->verbose("transferBlatBin:End: $?");
1747 
 
1748 
        if ( $? != 0 )
1749 
        {
1750 
            $logger->warn("transferBlatBin:Transfer Error: $file, $?");
1751 
        }
1752 
        LogTxError ($?);
1753 
    }
1754 
}
1755 
 
1756 
 
1757 
#-------------------------------------------------------------------------------
1038 dpurdie 1758 
# Function        : transferPackage
1759 
#
1760 
# Description     : Transfer specified package to target system
6475 dpurdie 1761 
#                   If a symlink, then a symlink will be transferred
1038 dpurdie 1762 
#
1763 
# Inputs          : $pname          - Name of the package
1764 
#                   $pver           - Package version
1765 
#
1766 
# Returns         : true    - Package transferred
1767 
#                   false   - Package not transferred
1768 
#
1769 
sub transferPackage
1770 
{
6475 dpurdie 1771 
    my ($pname, $pver ) = @_;
1038 dpurdie 1772 
    my $rv = 0;
6776 dpurdie 1773 
    my $cmdRv = 0;
7389 dpurdie 1774 
    $logger->verbose("Enter transferPackage: @_");
6148 dpurdie 1775 
    my $startTime = time;
1038 dpurdie 1776 
 
1777 
    #
1040 dpurdie 1778 
    #   Do not transfer excluded files
1779 
    #
1780 
    if ( exists $excludePkgs->{$pname} )
1781 
    {
1048 dpurdie 1782 
        $logger->warn("transferPackage: Excluded package not transferred: $pname, $pver");
1040 dpurdie 1783 
        return 1;
1784 
    }
1048 dpurdie 1785 
 
1040 dpurdie 1786 
    #
1048 dpurdie 1787 
    #   Apply package filter
1788 
    #
1789 
    if ( defined $conf->{'packageFilter'} )
1790 
    {
1791 
        unless ( $pname =~ m~$conf->{'packageFilter'}~ )
1792 
        {
1793 
            $logger->warn("transferPackage: Filtered out package not transferred: $pname, $pver");
1794 
            return 1;
1795 
        }
1796 
    }
1797 
 
1798 
    #
6148 dpurdie 1799 
    #   If its known to be in the target archive, then we don't need to transfer it again
1800 
    #       It may have been transferred in this cycle
1801 
    #       It may have been in the archive anyway
1038 dpurdie 1802 
    #
6148 dpurdie 1803 
    if ( exists($RemotePkgList->{$pname}) && exists ($RemotePkgList->{$pname}{$pver})) {
1804 
        $logger->verbose("transferPackage: Already in archive");
6320 dpurdie 1805 
        #$logger->logmsg("transferPackage: $pname, $pver : Already in archive");
1038 dpurdie 1806 
        return 1;
1807 
    }
1808 
 
6475 dpurdie 1809 
    my $sdir = catfile( $conf->{'dpkg_archive'} , $pname );
1810 
    my $sfile = catfile( $sdir, $pver );
1038 dpurdie 1811 
    unless ( -d $sfile )
1812 
    {
1813 
        $logger->warn("transferPackage:Package not found: $pname, $pver");
1814 
        return $rv;
1815 
    }
1816 
 
7387 dpurdie 1817 
    my $tzdir = catfile( $conf->{'dpkg_archive'} , '.dpkg_archive', 'tarStore' );
1818 
    my $tzfile = $pname . '__' . $pver . '.tgz';
1819 
    my $tzpath = catfile($tzdir, $tzfile);
1820 
    unless (-f $tzpath) {
1821 
        $logger->verbose("transferPackage: tarZip not found - $tzpath");
1822 
 
1823 
        $conf->{'tagdir'} =~ m~^(.*)/~;
1824 
        my $tagRoot = $1;
1825 
        my $tag = "$pname::$pver";
7389 dpurdie 1826 
        my $zipTag = catfile($tagRoot, 'tarZip', $tag);
1827 
        my $myTag =  catfile($conf->{'tagdir'} , $tag);
1828 
 
1829 
        $logger->logmsg("transferPackage. Request Zip: @_") unless ( -f $zipTag && -f $myTag );
1830 
 
1831 
        Utils::TouchFile($conf, $myTag) unless -f $myTag;
1832 
        Utils::TouchFile($conf, $zipTag) unless -f $zipTag;
7387 dpurdie 1833 
        return 0;
1834 
    }
1835 
 
1836 
 
6475 dpurdie 1837 
    ###########################################################################
1838 
    #   Transfer the package / symlink
1038 dpurdie 1839 
    #
7389 dpurdie 1840 
    $logger->logmsg("transferPackage: @_");
1841 
    my $tzfsize = -s $tzpath;
7387 dpurdie 1842 
    if ($isS3Target) {
1843 
        $cmdRv = transferPackageS3($tzdir, $tzfile, $pname, $pver);
1844 
    } else {
1845 
        $cmdRv = transferPackageSsh($tzdir, $tzfile, $sfile, $pname, $pver);
1846 
    }
1847 
 
1848 
    #
7389 dpurdie 1849 
    #   Display the size of the package (tarZipped)
7387 dpurdie 1850 
    #       Diagnostic use
1851 
    #
1852 
    if ($conf->{txdetail}) {
7389 dpurdie 1853 
        my $size = sprintf "%.3f", $tzfsize / 1024 / 1024 / 1024 ;
7387 dpurdie 1854 
        my $duration = time - $startTime;
1855 
        $logger->logmsg("transferPackage: Stats: $pname, $pver, $size Gb, $duration Secs");
1856 
    }
1857 
 
1858 
    if ( $cmdRv == 0 ) {
1859 
        #
1860 
        #   Mark has having been transferred in the current cycle
1861 
        #
1862 
        $RemotePkgList->{$pname}{$pver}{transferred} = 1;
1863 
        $rv = 1;
1864 
        $statistics{txCount}++;
1865 
 
1866 
    } else {
1867 
        $logger->warn("transferPackage:Transfer Error: $pname, $pver, $?");
1868 
    }
1869 
 
1870 
    LogTxError ($?);
1871 
    return $rv;
1872 
}
1873 
 
1874 
#-------------------------------------------------------------------------------
1875 
# Function        : transferPackageSsh
1876 
#
1877 
# Description     : Transfer a package via an ssh connection
1878 
#
1879 
# Inputs          : $tzdir  - Directory that contains the tarZip file
1880 
#                   $tzname - Name of tarZip File
1881 
#                   $sfile  - Full path to the source file
1882 
#                   $pname  - Package Name
1883 
#                   $pver   - Package Version
1884 
#
1885 
# Returns         : Result Code
1886 
#                   0   - Transfer OK
1887 
#                   <0  - Skip transfer
1888 
#                   >0  - Command error code
1889 
#
1890 
sub transferPackageSsh
1891 
{
1892 
    my ($tzdir, $tzname, $sfile, $pname, $pver) = @_;
6475 dpurdie 1893 
    my $tgt_cmd;
1894 
    my $ssh_cmd;
7387 dpurdie 1895 
    my $cmdRv = 0;
1896 
    my $tzfile = catfile($tzdir, $tzname);
1897 
 
6475 dpurdie 1898 
    if (-l $sfile) {
1038 dpurdie 1899 
 
6475 dpurdie 1900 
        #
1901 
        #   Determine the value of the symlink
7387 dpurdie 1902 
        #   Only support simple symlinks - that are in the same directory
6475 dpurdie 1903 
        #
1904 
        my $lver = readlink( $sfile );
1905 
        if ( ! defined $lver ) {
1906 
            $logger->warn("Can't resolve symlink: $pname, $pver");
7387 dpurdie 1907 
            return -1;
6475 dpurdie 1908 
        }
1909 
 
1910 
        if ( $lver =~ m ~/~ ) {
1911 
            $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
7387 dpurdie 1912 
            return -1;
6475 dpurdie 1913 
        }
1914 
 
1915 
        $tgt_cmd = "$conf->{'bindir'}/receive_symlink \"$pname\" \"$pver\" \"$lver\"";
1916 
        $ssh_cmd = sshCmd($tgt_cmd);
1917 
 
1918 
    } else {
1919 
        #
1920 
        #   Create the process pipe to transfer the package
7387 dpurdie 1921 
        #   Pipe the tarZip of the package through a ssh session to the target machine
1922 
        #   cat $tzpath | ssh  ... "./receive_package pname pver"
6475 dpurdie 1923 
        #
1924 
        $tgt_cmd = "$conf->{'bindir'}/receive_package \"$pname\" \"$pver\"";
1925 
        $ssh_cmd = sshCmd($tgt_cmd);
7387 dpurdie 1926 
        $ssh_cmd .= " <$tzfile"
6475 dpurdie 1927 
    }
1928 
 
1038 dpurdie 1929 
    $logger->verbose2("transferPackage:tgt_cmd:$tgt_cmd");
1930 
    $logger->verbose2("transferPackage:ssh_cmd:$ssh_cmd");
1931 
 
6776 dpurdie 1932 
    unless ($conf->{'noTransfers'}) {
1933 
        my $ph;
7387 dpurdie 1934 
        open ($ph, "$ssh_cmd |");
6776 dpurdie 1935 
        while ( <$ph> )
1936 
        {
1937 
            chomp;
1938 
            $logger->verbose2("transferPackage:Data: $_");
1939 
        }
1940 
        close ($ph);
1941 
        $cmdRv = $?;
1942 
        $logger->verbose("transferPackage:End: $?");
1038 dpurdie 1943 
    }
6148 dpurdie 1944 
 
7387 dpurdie 1945 
    return $cmdRv;
1946 
}
1947 
 
1948 
#-------------------------------------------------------------------------------
1949 
# Function        : transferPackageS3
1950 
#
1951 
# Description     : Transfer a package to an AWS S3 bucket
1952 
#                   Requires that the package already be tarZip-ed
1953 
#
1954 
# Inputs          : $tzdir  - Directory that contains the tarZip file
1955 
#                   $tzfile - Name of tarZip File
1956 
#                   $pname  - Package Name
1957 
#                   $pver   - Package Version
1958 
#
1959 
# Returns         : Result Code
1960 
#                   0   - Transfer OK
1961 
#                   <0  - Skip transfer
1962 
#                   >0  - Command error code
1963 
#
1964 
sub transferPackageS3
1965 
{
1966 
    my ($tzdir, $tzfile, $pname, $pver) = @_;
1967 
    my $cmdRv = 0;
1968 
 
6148 dpurdie 1969 
    #
7387 dpurdie 1970 
    #   Locate the file on the dpkgArchive tarZip store
1971 
    #
1972 
    my $sfile = catfile($tzdir, $tzfile);
1973 
    if (-l $sfile) {
1974 
        $logger->warn("Will not transfer symlink: $pname, $pver");
1975 
        return -1;
1976 
    }
1977 
 
6148 dpurdie 1978 
    #
7387 dpurdie 1979 
    #   Create a command to transfer the file to AWS use the cli tools
1980 
    #   Note: Ive seen problem with this when used from Perth to AWS (Sydney)
1981 
    #         If this is an issue use curl - see the savePkgToS3.sh for an implementation
1982 
    #
1983 
    my $s3_cmd = "aws --profile $conf->{'S3Profile'} s3 cp $sfile s3://$conf->{'S3Bucket'}/$tzfile";
1984 
    $logger->verbose2("transferPackage:s3_cmd:$s3_cmd");
1985 
 
1986 
    unless ($conf->{'noTransfers'}) {
6776 dpurdie 1987 
        my $ph;
7387 dpurdie 1988 
        open ($ph, "$s3_cmd |");
1989 
        while ( <$ph> )
1990 
        {
1991 
            chomp;
1992 
            $logger->verbose2("transferPackage:Data: $_");
1993 
        }
1994 
        close ($ph);
1995 
        $cmdRv = $?;
1996 
        $logger->verbose("transferPackage:End: $?");
6475 dpurdie 1997 
    }
6148 dpurdie 1998 
 
7387 dpurdie 1999 
    return $cmdRv;
1038 dpurdie 2000 
}
2001 
 
7387 dpurdie 2002 
 
1038 dpurdie 2003 
#-------------------------------------------------------------------------------
2004 
# Function        : deletePackage
2005 
#
2006 
# Description     : Delete specified package to target system
2007 
#
2008 
# Inputs          : $pname          - Name of the package
2009 
#                   $pver           - Package version
1042 dpurdie 2010 
#                   $pdata          - Hash of extra data
1038 dpurdie 2011 
#
7389 dpurdie 2012 
# Returns         : true    - Package deleted
2013 
#                   false   - Package not deleted
1038 dpurdie 2014 
#
2015 
sub deletePackage
2016 
{
1042 dpurdie 2017 
    my ($pname, $pver, $pdata ) = @_;
1038 dpurdie 2018 
    my $rv = 0;
6776 dpurdie 2019 
    my $cmdRv = 0;
1042 dpurdie 2020 
    $logger->logmsg("deletePackage: $pname, $pver");
1038 dpurdie 2021 
 
7389 dpurdie 2022 
    if ($isS3Target) {
2023 
        #   Create the process pipe to delete the package
1038 dpurdie 2024 
 
7389 dpurdie 2025 
        my $tzfile = $pname . '__' . $pver . '.tgz';
2026 
        my $s3_cmd = "aws --profile $conf->{'S3Profile'} s3 rm s3://$conf->{'S3Bucket'}/$tzfile";
2027 
        $logger->verbose2("deletePackage:s3_cmd:$s3_cmd");
1038 dpurdie 2028 
 
7389 dpurdie 2029 
        my $ph;
2030 
        open ($ph, "$s3_cmd |");
6776 dpurdie 2031 
        while ( <$ph> )
2032 
        {
2033 
            chomp;
2034 
            $logger->verbose2("deletePackage:Data: $_");
2035 
        }
2036 
        close ($ph);
2037 
        $cmdRv = $?;
2038 
 
7389 dpurdie 2039 
    } else {
2040 
        #
2041 
        #   Create the process pipe to delete the package
2042 
        #   ssh  ... "./delete_package ${rx_opts} \"$pname\" \"$pver\""
2043 
        #
2044 
        unless ($conf->{'noTransfers'}) {
2045 
            my $ph;
2046 
            my $flags = $pdata->{FORCEDELETE}  ? '' : ' -T';
2047 
            my $tgt_cmd = "$conf->{'bindir'}/delete_package $flags \"$pname\" \"$pver\"";
2048 
            my $ssh_cmd = sshCmd($tgt_cmd);
2049 
 
2050 
            $logger->verbose2("deletePackage:tgt_cmd:$tgt_cmd");
2051 
            $logger->verbose2("deletePackage:ssh_cmd:$ssh_cmd");
2052 
 
2053 
            open ($ph, "$ssh_cmd |");
2054 
            while ( <$ph> )
2055 
            {
2056 
                chomp;
2057 
                $logger->verbose2("deletePackage:Data: $_");
2058 
            }
2059 
            close ($ph);
2060 
            $cmdRv = $?;
2061 
        }
1038 dpurdie 2062 
    }
6776 dpurdie 2063 
 
7389 dpurdie 2064 
    #
2065 
    #   Common code
2066 
    #
2067 
    $logger->verbose("deletePackage:End: $cmdRv");
6776 dpurdie 2068 
    if ( $cmdRv == 0 )
1038 dpurdie 2069 
    {
2070 
        $rv = 1;
5398 dpurdie 2071 
        $statistics{delCount}++;
6148 dpurdie 2072 
        delete $RemotePkgList->{$pname}{$pver};
1038 dpurdie 2073 
    }
2074 
    else
2075 
    {
2076 
        $logger->warn("deletePackage:Error: $pname, $pver, $?");
2077 
    }
3515 dpurdie 2078 
    LogTxError ($?);
1038 dpurdie 2079 
    return $rv;
2080 
}
2081 
 
3515 dpurdie 2082 
#-------------------------------------------------------------------------------
2083 
# Function        : sshCmd
2084 
#
2085 
# Description     : Generate a ssh based command
2086 
#
2087 
# Inputs          : Target command
2088 
#
2089 
# Returns         : An shh command string
2090 
#
2091 
sub sshCmd
2092 
{
2093 
    my ($tgt_cmd) = @_;
3847 dpurdie 2094 
    my $sshPort = '';
2095 
    $sshPort = "-p $conf->{'sshport'}"
2096 
        if ($conf->{'sshport'});
2097 
 
2098 
    return "ssh -o \"BatchMode yes\" -i $conf->{'identity'} ${sshPort} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";
3515 dpurdie 2099 
}
1038 dpurdie 2100 
 
3515 dpurdie 2101 
 
1038 dpurdie 2102 
#-------------------------------------------------------------------------------
1042 dpurdie 2103 
# Function        : parsePkgList
2104 
#
2105 
# Description     : Parse one line from a pkgList
2106 
#                   Lines are multiple item="data" items
6148 dpurdie 2107 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
6475 dpurdie 2108 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas" link="latest"
1042 dpurdie 2109 
#
2110 
# Inputs          : $line                   - Line of data
2111 
#                   $hashp                  - Ref to hash to populate
2112 
#
2113 
# Returns         : A hash of data items
2114 
#
2115 
sub parsePkgList
2116 
{
2117 
    my ($line, $hashp) = @_;
2118 
    my $rv;
2119 
 
2120 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
2121 
    {
2122 
        $rv->{$1} = $2;
2123 
        $line = $';
2124 
    }
2125 
#Utils::DebugDumpData ("parsePkgList", $rv);
2126 
 
2127 
    my $pname = $rv->{pname};
2128 
    my $pver =  $rv->{pver};
2129 
    return undef unless ( $pname && $pver );
2130 
 
2131 
    delete $rv->{pname};
2132 
    delete $rv->{pver};
2133 
    delete $rv->{GMT};
2134 
 
2135 
    $hashp->{$pname}{$pver} = $rv;
2136 
    return $hashp;
2137 
}
2138 
 
5398 dpurdie 2139 
#-------------------------------------------------------------------------------
5404 dpurdie 2140 
# Function        : parsePkgMetaData
2141 
#
2142 
# Description     : Parse one line of meta data from a pkgList
2143 
#                   Lines are multiple item="data" items
2144 
#
2145 
# Inputs          : $line                   - Line of data
2146 
#                   $hashp                  - Ref to hash to populate
2147 
#
2148 
# Returns         : Nothing
2149 
#
2150 
sub parsePkgMetaData
2151 
{
2152 
    my ($line, $hashp) = @_;
2153 
 
2154 
    if ( $line =~ m~\s+(.+?)="(.+?)"~ )
2155 
    {
2156 
        $hashp->{$1} = $2;
2157 
        $statistics{'Target.' . $1} = $2;
2158 
        $line = $';
2159 
 
2160 
        $logger->verbose2("parsePkgMetaData: $1 = $2");
2161 
    }
2162 
}
2163 
 
6320 dpurdie 2164 
#-------------------------------------------------------------------------------
2165 
# Function        : parseBlatBinData
2166 
#
2167 
# Description     : Parse one line of Blat Bin data from a pkgList
2168 
#                   Lines are of the form:
2169 
#                   BlatBin MD5="dbc4507f4db5b41f7358b28bce65a15d" file="ddp-gtar"
2170 
#
2171 
# Inputs          : $line                   - Line of data
2172 
#                   $hashp                  - Ref to hash to populate
2173 
#
2174 
# Returns         : Nothing
2175 
#
2176 
sub parseBlatBinData
2177 
{
2178 
    my ($line, $hashp) = @_;
5404 dpurdie 2179 
 
6320 dpurdie 2180 
    my $rv;
2181 
    $line =~ s~^\S+~~;
2182 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
2183 
    {
2184 
        $rv->{$1} = $2;
2185 
        $line = $';
2186 
    }
2187 
#Utils::DebugDumpData ("parseBlatBinData", $rv);
2188 
 
2189 
    my $fname = $rv->{file};
2190 
    my $md5 =  $rv->{MD5};
2191 
    return undef unless ( $fname && $md5 );
2192 
 
2193 
    $logger->verbose2("parseBlatBinData: $fname : $md5");
2194 
    $hashp->{$fname} = $md5;
2195 
}
2196 
 
5404 dpurdie 2197 
#-------------------------------------------------------------------------------
5398 dpurdie 2198 
# Function        : resetDailyStatistics
2199 
#
2200 
# Description     : Called periodically to reset the daily statistics
2201 
#
2202 
# Inputs          : $time       - Current time
2203 
#
2204 
# Returns         :
2205 
#
2206 
sub resetDailyStatistics
2207 
{
2208 
    my ($time) = @_;
1042 dpurdie 2209 
 
5398 dpurdie 2210 
    #
2211 
    #   Detect a new day
2212 
    #
2213 
    my $today = (localtime($time))[7];
2214 
    if ($yday != $today)
2215 
    {
2216 
        $yday = $today;
2217 
        $logger->logmsg('Resetting daily statistics' );
2218 
 
5404 dpurdie 2219 
        # Note: Must match @recoverTags in readStatistics
5398 dpurdie 2220 
        $statistics{dayStart} = $time;
2221 
        $statistics{txCount} = 0;
2222 
        $statistics{delCount} = 0;
2223 
        $statistics{staleTags} = 0;
2224 
        $statistics{linkErrors} = 0;
2225 
    }
2226 
}
2227 
 
1042 dpurdie 2228 
#-------------------------------------------------------------------------------
5404 dpurdie 2229 
# Function        : readStatistics
2230 
#
2231 
# Description     : Read in the last set of stats
2232 
#                   Used after a restart to recover daily statistics
2233 
#
2234 
# Inputs          :
2235 
#
2236 
# Returns         :
2237 
#
2238 
sub readStatistics
2239 
{
2240 
    my @recoverTags = qw(dayStart txCount delCount staleTags linkErrors);
2241 
 
2242 
    if ($conf->{'statsfile'} and -f $conf->{'statsfile'})
2243 
    {
2244 
        if (open my $fh, $conf->{'statsfile'})
2245 
        {
2246 
            while (<$fh>)
2247 
            {
2248 
                m~(.*):(.*)~;
2249 
                if ( grep( /^$1$/, @recoverTags ) )
2250 
                {
2251 
                    $statistics{$1} = $2;
6475 dpurdie 2252 
                    $logger->verbose("readStatistics $1, $2");
5404 dpurdie 2253 
                }
2254 
            }
2255 
            close $fh;
2256 
            $yday = (localtime($statistics{dayStart}))[7];
2257 
        }
2258 
    }
2259 
}
2260 
 
2261 
 
2262 
#-------------------------------------------------------------------------------
5398 dpurdie 2263 
# Function        : periodicStatistics
2264 
#
2265 
# Description     : Called on a regular basis to write out statistics
2266 
#                   Used to feed information into Nagios
2267 
#
2268 
#                   This function is called via an alarm and may be outside the normal
2269 
#                   processing loop. Don't make assumptions on the value of $now
2270 
#
2271 
# Inputs          :
2272 
#
2273 
# Returns         :
2274 
#
2275 
sub periodicStatistics
2276 
{
2277 
    #
2278 
    #   A few local stats
2279 
    #
2280 
    $statistics{SeqNum}++;
2281 
    $statistics{timeStamp} = time();
2282 
    $statistics{upTime} = $statistics{timeStamp} - $startTime;
2283 
 
2284 
    #   Reset daily accumulations - on first use each day
2285 
    resetDailyStatistics($statistics{timeStamp});
2286 
 
2287 
    #
2288 
    #   Write statistics to a file
2289 
    #       Write to a tmp file, then rename.
2290 
    #       Attempt to make the operation atomic - so that the file consumer
2291 
    #       doesn't get a badly formed file.
2292 
    #
2293 
    if ($conf->{'statsfiletmp'})
2294 
    {
2295 
        my $fh;
2296 
        unless (open ($fh, '>', $conf->{'statsfiletmp'}))
2297 
        {
2298 
            $fh = undef;
2299 
            $logger->warn("Cannot create temp stats file: $!");
2300 
        }
2301 
        else
2302 
        {
5404 dpurdie 2303 
            foreach my $key ( sort { lc($a) cmp lc($b) } keys %statistics)
5398 dpurdie 2304 
            {
2305 
                print $fh $key . ':' . $statistics{$key} . "\n";
2306 
                $logger->verbose2('Statistics:'. $key . ':' . $statistics{$key});
2307 
            }
2308 
            close $fh;
2309 
 
2310 
            # Rename temp to real file
2311 
            rename  $conf->{'statsfiletmp'},  $conf->{'statsfile'} ;
2312 
        }
2313 
    }
2314 
}
2315 
 
2316 
#-------------------------------------------------------------------------------
1038 dpurdie 2317 
# Function        : sighandlers
2318 
#
2319 
# Description     : Install signal handlers
2320 
#
2321 
# Inputs          : $conf           - System config
2322 
#
2323 
# Returns         : Nothing
2324 
#
2325 
sub sighandlers
2326 
{
5398 dpurdie 2327 
    my $conf = shift;
2328 
    my $logger = $conf->{logger};
1038 dpurdie 2329 
 
5398 dpurdie 2330 
    $SIG{TERM} = sub {
2331 
        # On shutdown
2332 
        $logger->logmsg('Received SIGTERM. Shutting down....' );
2333 
        unlink $conf->{'pidfile'} if (-f $conf->{'pidfile'});
2334 
        exit 0;
2335 
    };
1038 dpurdie 2336 
 
5398 dpurdie 2337 
    $SIG{HUP} = sub {
2338 
        # On logrotate
2339 
        $logger->logmsg('Received SIGHUP.');
2340 
        $logger->rotatelog();
2341 
    };
1038 dpurdie 2342 
 
5398 dpurdie 2343 
    $SIG{USR1} = sub {
2344 
        # On Force Archive Sync
2345 
        $logger->logmsg('Received SIGUSR1.');
1046 dpurdie 2346 
        $lastReleaseScan = 0;
6779 dpurdie 2347 
        $lastTagListUpdate = 0;
6776 dpurdie 2348 
        $lastRmConfRead = 0;
5398 dpurdie 2349 
    };
1038 dpurdie 2350 
 
7387 dpurdie 2351 
    alarm 60 unless $conf->{debug};
5398 dpurdie 2352 
    $SIG{ALRM} = sub {
2353 
        # On Dump Statistics
2354 
        $logger->verbose2('Received SIGUSR2.');
2355 
        periodicStatistics();
2356 
        alarm 60;
2357 
    };
2358 
 
1038 dpurdie 2359 
    $SIG{__WARN__} = sub { $logger->warn("@_") };
2360 
    $SIG{__DIE__} = sub { $logger->err("@_") };
2361 
}
2362 
 
2363 
#-------------------------------------------------------------------------------
3515 dpurdie 2364 
# Function        : LogTxError
2365 
#
2366 
# Description     : Detect restoration of communication and log such
2367 
#                   Don't log failures as the user will do that
2368 
#
2369 
# Inputs          : $state                  - 0 - All is well
2370 
#                                           !0  - Error
2371 
#
2372 
# Returns         : Nothing
2373 
#
2374 
sub LogTxError
2375 
{
2376 
    my ($state) = $@;
2377 
    if ( $state )
2378 
    {
5398 dpurdie 2379 
        $statistics{linkErrors}++ unless($comError);
3515 dpurdie 2380 
        $comError++;
5398 dpurdie 2381 
        $statistics{state} = 'No Communication';
3515 dpurdie 2382 
    }
2383 
    elsif ( $comError )
2384 
    {
2385 
        $logger->warn("Communication Restored");
2386 
        $comError = 0;
5398 dpurdie 2387 
        $statistics{state} = 'OK';
3515 dpurdie 2388 
    }
2389 
}
2390 
 
2391 
 
2392 
#-------------------------------------------------------------------------------
1038 dpurdie 2393 
# Function        : Error, Verbose, Warning
2394 
#
2395 
# Description     : Support for JatsRmApi
2396 
#
2397 
# Inputs          : Message
2398 
#
2399 
# Returns         : Nothing
2400 
#
2401 
sub Error
2402 
{
2403 
    $logger->err("@_");
2404 
}
2405 
 
2406 
sub Verbose
2407 
{
1042 dpurdie 2408 
    $logger->verbose2("@_");
1038 dpurdie 2409 
}
2410 
 
2411 
sub Warning
2412 
{
2413 
    $logger->warn("@_");
2414 
}
2415