Subversion Repositories DevTools

Rev

Rev 6098 | Rev 6320 | 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/;
25 
 
26 
use FindBin;                                    # Determine the current directory
27 
use lib "$FindBin::Bin/lib";                    # Allow local libraries
28 
 
29 
use Utils;
30 
use StdLogger;                                  # Log to sdtout
31 
use Logger;                                     # Log to file
32 
 
33 
#
34 
#   Database interface
35 
#   Pinched from jats and modified so that this software is not dependent on JATS
36 
#
37 
use IO::Handle;
38 
use JatsRmApi;
39 
use DBI;
40 
 
41 
#
42 
#   Globals
43 
#
44 
my $logger = StdLogger->new();                  # Stdout logger. Only during config
45 
my $name = basename( $ARGV[0]);
46 
   $name =~ s~.conf$~~;
47 
my $now = 0;
5398 dpurdie 48 
my $startTime = 0;
3515 dpurdie 49 
my $tar = 'tar';
50 
my $gzip = 'gzip';
1038 dpurdie 51 
my $tagDirTime = 0;
52 
my $lastDirScan = 0;
53 
my $lastReleaseScan = 0;
1040 dpurdie 54 
my $releaseScanMode = 0;
55 
my $lastTagListScan = 0;
1038 dpurdie 56 
my $mtimeConfig = 0;
57 
my $conf;
58 
my $extraPkgs;
1040 dpurdie 59 
my $excludePkgs;
60 
my %releaseData;
3515 dpurdie 61 
my $comError = 0;
5398 dpurdie 62 
my $yday = -1;
6148 dpurdie 63 
my $RemotePkgList = {};
1038 dpurdie 64 
 
65 
#
5398 dpurdie 66 
#   Contain statisics maintained while operating
67 
#       Can be dumped with a kill -USR2
68 
#       List here for documentation
69 
#
70 
 
71 
my %statistics = (
72 
    SeqNum => 0,                        # Bumped when $statistics are dumped
73 
    timeStamp => 0,                     # DateTime when statistics are dumped
74 
    upTime => 0,                        # Seconds since program start
75 
    Cycle => 0,                         # Major process loop counter
76 
    phase => 'Init',                    # Current phase of operation
77 
    state => 'OK',                      # Nagios state
78 
                                        #
79 
                                        # The following are reset each day
80 
    dayStart => 0,                      # DateTime when daily data was reset
81 
    txCount => 0,                       # Packages Transferred
82 
    delCount => 0,                      # Packages marked for deletion
83 
    staleTags => 0,                     # Stale Tags
84 
    linkErrors => 0,                    # Transfer errors
85 
                                        #
86 
                                        # Per Cycle Data - Calculated each processing Cycle
5399 dpurdie 87 
    total    => 0,                      # Packages to be synced
5398 dpurdie 88 
    delete   => 0,                      # Packages to delete
89 
    excluded => 0,                      # Packages excluded
90 
    filtered => 0,                      # Packages filtered out
91 
    missing  => 0,                      # Packages missing
92 
    transfer => 0,                      # Packages to transfer
93 
    writable => 0,                      # Packages still writable - thus not transferred
94 
    tagCount => 0,                      # Packages tagged to be transferred
5404 dpurdie 95 
                                        #
96 
                                        # Expected from the Target
97 
#   Target.Hostname => '',              # Target Hostname
98 
#   Target.avail    => 0,               # Information from 'df' 1Kblocks
99 
#   Target.pcent    => 0,
100 
#   Target.size     => 0,
101 
#   Target.used     => 0,
102 
#   Target.iavail   => 0,               # Inode information from 'df'
103 
#   Target.ipcent   => 0,
104 
#   Target.isize    => 0,
105 
#   Target.iused    => 0,
106 
#   Target.Total    => 0,               # Number of Package Versions in the archive
107 
#   Target.Damaged  => 0,               # Number that are damaged
108 
#   Target.Delete   => 0,               # Number marked for future deletion
109 
#   Target.Missing  => 0,               # Number missing
5398 dpurdie 110 
);
111 
 
1038 dpurdie 112 
#
5398 dpurdie 113 
#   Describe configuration parameters
114 
#
1038 dpurdie 115 
my %cdata = (
116 
    '.ignore'         => {'pkg\.(.+)' => 'pkgs' },
1048 dpurdie 117 
    'piddir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
118 
    'sleep'           => {'default'   => 5      , 'fmt' => 'period'},
119 
    'dpkg_archive'    => {'mandatory' => 1      , 'fmt' => 'dir'},
120 
    'logfile'         => {'mandatory' => 1      , 'fmt' => 'vfile'},
121 
    'logfile.size'    => {'default'   => '1M'   , 'fmt' => 'size'},
122 
    'logfile.count'   => {'default'   => 9      , 'fmt' => 'int'},
123 
    'verbose'         => {'default'   => 0      , 'fmt' => 'int'},
124 
    'user'            => {'mandatory' => 1      , 'fmt' => 'text'},
125 
    'hostname'        => {'mandatory' => 1      , 'fmt' => 'text'},
3847 dpurdie 126 
    'sshport'         => {'default'   => 0      , 'fmt' => 'int'},
1048 dpurdie 127 
    'identity'        => {'mandatory' => 1      , 'fmt' => 'file'},
128 
    'bindir'          => {'mandatory' => 1      , 'fmt' => 'text'},
129 
    'tagdir'          => {'mandatory' => 1      , 'fmt' => 'dir'},
130 
    'forcedirscan'    => {'default'   => 100    , 'fmt' => 'period'},
131 
    'tagage'          => {'default'   => '10m'  , 'fmt' => 'period'},
132 
    'tagListUpdate'   => {'default'   => '1h'   , 'fmt' => 'period'},
133 
    'synctime'        => {'default'   => '2h'   , 'fmt' => 'period'},
134 
    'syncretry'       => {'default'   => '5m'   , 'fmt' => 'period'},
135 
    'allProjects'     => {'default'   => 0      , 'fmt' => 'bool'},
4456 dpurdie 136 
    'allArchive'      => {'default'   => 0      , 'fmt' => 'bool'},
1048 dpurdie 137 
    'project'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
138 
    'release'         => {'mandatory' => 0      , 'fmt' => 'int_list'},
139 
    'writewindow'     => {'default'   => '3h'   , 'fmt' => 'period'},
140 
    'maxpackages'     => {'default'   => 5      , 'fmt' => 'int'},
141 
    'deletePackages'  => {'default'   => 0      , 'fmt' => 'bool'},
142 
    'deleteImmediate' => {'default'   => 0      , 'fmt' => 'bool'},
143 
    'deleteAge'       => {'default'   => 0      , 'fmt' => 'period'},
144 
    'packageFilter'   => {'default'   => undef  , 'fmt' => 'text'},
145 
    'active'          => {'default'   => 1      , 'fmt' => 'bool'},
1038 dpurdie 146 
);
147 
 
148 
 
149 
#
150 
#   Read in the configuration
151 
#       Set up a logger
152 
#       Write a pidfile - thats not used
153 
readConfig();
154 
Utils::writepid($conf);
155 
$logger->logmsg("Starting...");
5404 dpurdie 156 
readStatistics();
1038 dpurdie 157 
sighandlers($conf);
5398 dpurdie 158 
$startTime = time();
1038 dpurdie 159 
 
160 
#
161 
#   Main processing loop
162 
#   Will exit when terminated by parent
163 
#
3847 dpurdie 164 
while (1 )
1038 dpurdie 165 
{
166 
    $logger->verbose3("Processing");
5398 dpurdie 167 
    $statistics{Cycle}++;
1038 dpurdie 168 
    $now = time();
1040 dpurdie 169 
 
5398 dpurdie 170 
    $statistics{phase} = 'ReadConfig';
1038 dpurdie 171 
    readConfig();
1048 dpurdie 172 
    if ( $conf->{'active'} )
173 
    {
5398 dpurdie 174 
        $statistics{phase} = 'ProcessReleaseList';
1048 dpurdie 175 
        processReleaseList();
5398 dpurdie 176 
        $statistics{phase} = 'processTags';
1048 dpurdie 177 
        processTags();
5398 dpurdie 178 
        $statistics{phase} = 'maintainTagList';
1048 dpurdie 179 
        maintainTagList();
180 
    }
1040 dpurdie 181 
    %releaseData = ();
182 
 
5398 dpurdie 183 
    $statistics{phase} = 'Sleep';
1038 dpurdie 184 
    sleep( $conf->{'sleep'} );
1050 dpurdie 185 
 
186 
    #
187 
    #   Reap any and all dead children
188 
    #
5398 dpurdie 189 
    $statistics{phase} = 'Reaping';
1050 dpurdie 190 
    my $kid;
191 
    do {
192 
        $kid = waitpid(-1, WNOHANG);
193 
    } while ( $kid > 0 );
3847 dpurdie 194 
 
195 
    #   If my PID file ceases to be, then exit the daemon
196 
    #   Used to force daemon to restart
197 
    #
198 
    unless ( -f $conf->{'pidfile'} )
199 
    {
200 
        $logger->logmsg("Terminate. Pid file removed");
201 
        last;
202 
    }
1038 dpurdie 203 
}
5398 dpurdie 204 
$statistics{phase} = 'Terminated';
1038 dpurdie 205 
$logger->logmsg("Child End");
206 
exit 0;
207 
 
208 
#-------------------------------------------------------------------------------
209 
# Function        : readConfig
210 
#
211 
# Description     : Re read the config file if it modification time has changed
212 
#
213 
# Inputs          : Nothing
214 
#
1289 dpurdie 215 
# Returns         : 0       - Config not read
216 
#                   1       - Config read
217 
#                             Config file has changed
1038 dpurdie 218 
#
219 
sub readConfig
220 
{
221 
    my ($mtime) = Utils::mtime($ARGV[0]);
1289 dpurdie 222 
    my $rv = 0;
223 
 
1038 dpurdie 224 
    if ( $mtimeConfig != $mtime )
225 
    {
226 
        $logger->logmsg("Reading config file: $ARGV[0]");
227 
        $mtimeConfig = $mtime;
228 
        my $errors;
229 
        ($conf, $errors) = Utils::readconf ( $ARGV[0], \%cdata );
230 
        if ( scalar @{$errors} > 0 )
231 
        {
232 
            warn "$_\n" foreach (@{$errors});
233 
            die ("Config contained errors\n");
234 
        }
235 
 
236 
        #
237 
        #   Reset some information
238 
        #   Create a new logger
239 
        #
240 
        $logger = Logger->new($conf);
241 
        $conf->{logger} = $logger;
242 
        $conf->{'pidfile'} = $conf->{'piddir'} . '/' . $name . '.pid';
243 
        $logger->verbose("Log Levl: $conf->{verbose}");
244 
 
245 
        #
5398 dpurdie 246 
        #   Setup statistics filename
247 
        $conf->{'statsfile'} = $conf->{'piddir'} . '/' . $name . '.stats';
248 
        $conf->{'statsfiletmp'} = $conf->{'piddir'} . '/' . $name . '.stats.tmp';
249 
 
250 
        #
1038 dpurdie 251 
        #   Extract extra package config
252 
        #
253 
        $extraPkgs = {};
1040 dpurdie 254 
        $excludePkgs = {};
1038 dpurdie 255 
        while (my($key, $data) = each ( %{$conf->{pkgs}} ))
256 
        {
3846 dpurdie 257 
            if ( $data eq 'EXCLUDE' ) {
1040 dpurdie 258 
                $excludePkgs->{$key} = 1;
259 
                $logger->verbose("Exclude Pkg: $key");
3846 dpurdie 260 
 
261 
            } elsif ( $data eq 'ALL' ) {
262 
                foreach my $pver (getPackageVersions($key))
263 
                {
264 
                    $extraPkgs->{$key}{$pver} = 1;
265 
                    $logger->verbose("Extra Pkg: $key -> $pver");
266 
                }
267 
            } else {
1040 dpurdie 268 
                $extraPkgs->{$key}{$data} = 1;
269 
                $logger->verbose("Extra Pkg: $key -> $data");
270 
            }
1038 dpurdie 271 
        }
1046 dpurdie 272 
 
1048 dpurdie 273 
        $logger->verbose("Filter Packages: " . $conf->{'packageFilter'})
274 
            if ( defined $conf->{'packageFilter'} );
275 
 
3847 dpurdie 276 
        $logger->warn("Non standard ssh port: " . $conf->{'sshport'})
277 
            if ( $conf->{'sshport'} );
278 
 
1048 dpurdie 279 
        $logger->warn("Transfer session configured as not active")
280 
            unless ( $conf->{'active'} );
281 
 
282 
        $logger->warn("Transfer all projects packages")
1050 dpurdie 283 
            if ( $conf->{'allProjects'} );
4456 dpurdie 284 
        $logger->warn("Transfer entire package archive")
285 
            if ( $conf->{'allArchive'} );
1048 dpurdie 286 
 
4456 dpurdie 287 
 
1046 dpurdie 288 
        #
289 
        #   When config is read force some actions
290 
        #       - Force tagList to be created
1050 dpurdie 291 
        #       - Force release scan
1048 dpurdie 292 
        $lastTagListScan = 0;
1050 dpurdie 293 
        $lastReleaseScan = 0;
1289 dpurdie 294 
        $rv = 1;
1038 dpurdie 295 
    }
1289 dpurdie 296 
    return $rv;
1038 dpurdie 297 
}
298 
 
299 
 
300 
#-------------------------------------------------------------------------------
301 
# Function        : processReleaseList
302 
#
303 
# Description     : Process the release list
304 
#                       Determine if its time to process release list
305 
#                       Determine release list
306 
#                       Determine release content
307 
#                       Determine new items
308 
#
309 
# Inputs          : None
310 
#
311 
# Returns         : Nothing
312 
#
313 
sub processReleaseList
314 
{
315 
    #
1044 dpurdie 316 
    #   Is Release List Processing active
317 
    #   Can configure blat to disable release sync
318 
    #   This will then allow 'new' packages to be sent
319 
    #
320 
    if ( $conf->{maxpackages} == 0 || $conf->{'synctime'} <= 0)
321 
    {
322 
        $logger->verbose2("processReleaseList disabled");
323 
        return;
324 
    }
325 
 
326 
    #
1038 dpurdie 327 
    #   Time to perform the scan
328 
    #   Will do at startup and every time period there after
329 
    #
1040 dpurdie 330 
    my $wtime = $releaseScanMode ? $conf->{'syncretry'} : $conf->{'synctime'};
331 
    return unless ( $now > ($lastReleaseScan + $wtime ));
1038 dpurdie 332 
    $logger->verbose("processReleaseList");
333 
    $lastReleaseScan = $now;
1040 dpurdie 334 
    $releaseScanMode = 1;                                   # Assume error
1038 dpurdie 335 
 
336 
    #
337 
    #   Get list of packages from Remote site
338 
    #   Invoke a program on the remote site and parse the results
339 
    #
340 
    #   Returned data looks like:
6148 dpurdie 341 
    #       Metadata avail="140100452"
342 
    #       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
343 
    #       time="1497954104" GMT="Tue Jun 20 10:21:44 2017" pname="ERGissaccounts" pver="1.0.7178.mas" deleted="0"
1038 dpurdie 344 
    #
345 
    my $remotePkgList;
5404 dpurdie 346 
    my $remoteData;
1038 dpurdie 347 
    my $ph;
1040 dpurdie 348 
    my $tgt_cmd = "$conf->{'bindir'}/get_plist.pl";
3515 dpurdie 349 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 350 
 
351 
    $logger->verbose2("processReleaseList:ssh_cmd:$ssh_cmd");
352 
    open ($ph, "$ssh_cmd |");
353 
    while ( <$ph> )
354 
    {
355 
        chomp;
5404 dpurdie 356 
        if ($_ =~ m~^Metadata\s+~)
1038 dpurdie 357 
        {
5404 dpurdie 358 
            parsePkgMetaData($_, \%{$remoteData})
1038 dpurdie 359 
        }
360 
        else
361 
        {
5404 dpurdie 362 
            if ( parsePkgList($_, \%{$remotePkgList} ) )
363 
            {
364 
                $logger->verbose2("processReleaseList:Data: $_");
365 
            }
366 
            else
367 
            {
368 
                $logger->warn("processReleaseList:Bad Data: $_");
369 
            }
1038 dpurdie 370 
        }
371 
    }
372 
    close ($ph);
373 
    $logger->verbose("processReleaseList:End: $?");
6148 dpurdie 374 
    $RemotePkgList = $remotePkgList;
375 
 
3515 dpurdie 376 
    LogTxError ($?);
1038 dpurdie 377 
    if ( $? != 0 )
378 
    {
379 
        $logger->warn("Cannot retrieve package list: $?");
5398 dpurdie 380 
        $statistics{state} = 'No Remote Package List';
1038 dpurdie 381 
        return;
382 
    }
3515 dpurdie 383 
 
1042 dpurdie 384 
#Utils::DebugDumpData ("remotePkgList", $remotePkgList);
4456 dpurdie 385 
 
1038 dpurdie 386 
    #
387 
    #   Determine the set of packages in the releases to be transferred
4456 dpurdie 388 
    #
389 
    my $pkgList;
390 
    if ( $conf->{'allArchive'} )
1040 dpurdie 391 
    {
4456 dpurdie 392 
        #   Examine entire archive
393 
        #
394 
        $pkgList = getArchiveList();
1040 dpurdie 395 
    }
4456 dpurdie 396 
    else
397 
    {
398 
        #   Examine Releases
399 
        #
400 
        my @rlist = getReleaseList();
401 
        unless ( @rlist )
402 
        {
403 
            $logger->verbose2("No Releases to Process");
5398 dpurdie 404 
            $statistics{state} = 'No Releases found';
4456 dpurdie 405 
            return;
406 
        }
407 
        $pkgList = getPkgList(@rlist);
408 
    }
1038 dpurdie 409 
 
410 
    #
411 
    #   Append extra packages
412 
    #   These are packages that are specifically named by the user
413 
    #
414 
    #   Note: If there are symbolic links, then the target of the
415 
    #         link is treated used as the package name
416 
    #
417 
    #         Symlink MUST be within the same directory
3846 dpurdie 418 
    #           Used to transfer jats2_current
1038 dpurdie 419 
    #
420 
    my $pkgLink;
421 
    while ( (my ($pname, $pvers)) = each %{$extraPkgs} ) {
422 
        while ( (my ($pver, $pdata) ) = each %{$pvers} ) {
423 
 
1040 dpurdie 424 
            my $epath = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
1038 dpurdie 425 
            if ( -l $epath )
426 
            {
427 
                my $lver = readlink( $epath );
428 
                if ( ! defined $lver )
429 
                {
3846 dpurdie 430 
                    $logger->warn("Can't resolve symlink: $pname, $pver");
1038 dpurdie 431 
                    next;
432 
                }
433 
 
434 
                if ( $lver =~ m ~/~ )
435 
                {
436 
                    $logger->warn("Won't resolve symlink: $pname, $pver, $lver");
437 
                    next;
438 
                }
439 
                $pkgLink->{$pname}{$pver} = $lver;
440 
                $pdata = $pver;
441 
                $pver = $lver;
6098 dpurdie 442 
 
443 
                # Delete all instances of this package so that the symlink can be replicated correctly
444 
                delete $pkgList->{$pname};
1038 dpurdie 445 
            }
446 
 
447 
            $logger->verbose2("Add extra package: $pname, $pver, $pdata");
448 
            $pkgList->{$pname}{$pver} = $pdata;
449 
        }
450 
    }
451 
 
1040 dpurdie 452 
    #
453 
    #   If there are no packages to process, then assume that this is an error
454 
    #   condition. Retry the operation soon.
455 
    #
456 
    unless ( keys %{$pkgList} )
457 
    {
458 
 
459 
        $logger->verbose2("No packages to process");
5398 dpurdie 460 
        $statistics{state} = 'No Packages found';
1040 dpurdie 461 
        return;
462 
    }
463 
 
1038 dpurdie 464 
#    while ( (my ($pname, $pvers)) = each %{$pkgList} )
465 
#    {
466 
#        while ( (my ($pver, $ptime) ) = each %{$pvers} )
467 
#        {
468 
#            print "L-- $pname, $pver, $ptime \n";
469 
#
470 
#        }
471 
#    }
472 
 
473 
    #
1040 dpurdie 474 
    #   Delete Excess Packages
1038 dpurdie 475 
    #       Packages not required on the target
1042 dpurdie 476 
    #           KLUDGE: Don't delete links to packages
477 
    #           Don't delete packages marked for deletion
1038 dpurdie 478 
    #
479 
    my $excessPkgList;
1048 dpurdie 480 
    my $excessPkgListCount = 0;
1038 dpurdie 481 
    if ( $conf->{deletePackages} )
482 
    {
483 
        while ( (my ($pname, $pvers)) = each %{$remotePkgList} )
484 
        {
485 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
486 
            {
487 
                if ( !exists $pkgList->{$pname}{$pver} )
488 
                {
489 
                    if ( exists $pkgLink->{$pname}{$pver} )
490 
                    {
491 
                        $logger->verbose2("Keep Excess package-link: ${pname}/${pver}");
492 
                        next;
493 
                    }
1040 dpurdie 494 
 
495 
                    if ( exists $excludePkgs->{$pname} )
496 
                    {
497 
                        $logger->verbose2("Keep Excluded package: ${pname}");
498 
                        next;
499 
                    }
500 
 
1042 dpurdie 501 
                    if ( exists $pdata->{deleted} )
502 
                    {
503 
                        if ( $conf->{deleteAge} )
504 
                        {
505 
                            if ( $pdata->{deleted} <= $conf->{deleteAge} )
506 
                            {
507 
                                $logger->verbose2("Already marked for future age deletion: ${pname}/${pver}, $pdata->{deleted}");
508 
                                next;
509 
                            }
510 
                            $pdata->{FORCEDELETE} = 1;
511 
                        }
512 
 
513 
                        if ( !$conf->{deleteImmediate} )
514 
                        {
515 
                            $logger->verbose2("Already marked for deletion: ${pname}/${pver}");
516 
                            next;
517 
                        }
518 
                    }
519 
 
520 
                    #
521 
                    #   Force deletion
522 
                    #       deleteImmediate mode
523 
                    #       target is a broken link
524 
                    #
525 
                    $pdata->{FORCEDELETE} = 1
526 
                        if ($conf->{deleteImmediate} || $pdata->{broken});
527 
 
1038 dpurdie 528 
                    $excessPkgList->{$pname}{$pver} = $pdata;
1048 dpurdie 529 
                    $excessPkgListCount++;
1038 dpurdie 530 
                    $logger->verbose("Excess package: ${pname}/${pver}");
531 
                }
1050 dpurdie 532 
#                else
533 
#                {
534 
#                        $logger->verbose3("Retain package: ${pname}/${pver}");
535 
#                }
1038 dpurdie 536 
            }
537 
        }
538 
    }
539 
 
540 
    #
541 
    #   Process the remote list and the local list
542 
    #   The remote time-stamp is the modification time of the packages descpkg file
543 
    #
544 
    #   Mark for transfer packages that
1040 dpurdie 545 
    #       Are in the local set but not the remote set
1038 dpurdie 546 
    #       Have a different time stamp
547 
    #
548 
    #   Ignore packages not in the local archive
549 
    #   Ignore packages that don't have a descpkg
550 
    #   Ignore packages that are writable - still being formed
551 
    #
552 
    my $needPkgList;
1048 dpurdie 553 
    my $needPkgListCount = 0;
554 
    my $filteredCount = 0;
555 
    my $missingCount = 0;
556 
    my $writableCount = 0;
557 
    my $excludeCount = 0;
5404 dpurdie 558 
    my $packageVersionCount = 0;
1038 dpurdie 559 
    while ( (my ($pname, $pvers)) = each %{$pkgList} )
560 
    {
1040 dpurdie 561 
        #
562 
        #   Ignore excluded packages
563 
        #
1048 dpurdie 564 
        if ( exists $excludePkgs->{$pname} )
565 
        {
566 
            $excludeCount++;
567 
            next;
568 
        }
1040 dpurdie 569 
 
1048 dpurdie 570 
        #
571 
        #   Ignore packages that are filtered out
572 
        #
573 
        if ( defined $conf->{'packageFilter'} )
574 
        {
575 
            unless ( $pname =~ m~$conf->{'packageFilter'}~ )
576 
            {
577 
                $logger->verbose3("Filtering out: ${pname}");
578 
                $filteredCount++;
579 
                next;
580 
            }
581 
        }
582 
 
1038 dpurdie 583 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
584 
        {
6148 dpurdie 585 
            #
586 
            #   Take care not to create an entry into $remotePkgList->{$pname}{$pver}
587 
            #   if it does not exist. Existence of {$pname}{$pver} is used later
588 
            #
589 
            my $tmtime = 0;
590 
            if (exists($remotePkgList->{$pname}) && exists ($remotePkgList->{$pname}{$pver}) && exists ($remotePkgList->{$pname}{$pver}{time})) {
591 
                $tmtime = $remotePkgList->{$pname}{$pver}{time};
592 
            }
5404 dpurdie 593 
            $packageVersionCount++;
1038 dpurdie 594 
 
595 
            # Package is present in both list
1040 dpurdie 596 
            my ($mtime, $mode) = Utils::mtime( catfile( $conf->{'dpkg_archive'} , $pname, $pver, 'descpkg' ));
1038 dpurdie 597 
            if ( $mtime == 0 )
598 
            {
599 
                # PackageVersion not in local archive (at least the descpkg file is not)
600 
                # Skip now - will pick it up later
601 
                $logger->verbose("Package not in dpkg_archive: $pname, $pver");
1048 dpurdie 602 
                $missingCount++;
1038 dpurdie 603 
                next;
604 
            }
605 
 
606 
            if ( $mode & 0222 )
607 
            {
608 
                # Descpkg file is writable
609 
                # Package may be in the process of being created
1048 dpurdie 610 
                # If the package has been writable for a long time, then
1038 dpurdie 611 
                # consider for transfer
612 
                my $age = $now - $mtime;
613 
                if ( $age < ($conf->{'writewindow '} || 600) )
614 
                {
615 
                    $logger->verbose("Package is writable: $pname, $pver, ", $now - $mtime);
1048 dpurdie 616 
                    $writableCount++;
1038 dpurdie 617 
                    next;
618 
                }
619 
            }
620 
 
621 
            if ( $mtime != $tmtime )
622 
            {
623 
                # Package not present on target, or timestamps differ
624 
                $logger->verbose("Package Needs to be transferred: $pname, $pver, $mtime, $tmtime");
625 
                $needPkgList->{$pname}{$pver} = $pdata;
1048 dpurdie 626 
                $needPkgListCount++;
1038 dpurdie 627 
                next;
628 
            }
629 
        }
630 
    }
631 
 
1048 dpurdie 632 
 
1038 dpurdie 633 
    #
634 
    #   Debug output only
635 
    #   Display what we need to transfer
636 
    #
637 
    if ( $conf->{verbose} > 2 )
638 
    {
639 
        while ( (my ($pname, $pvers)) = each %{$needPkgList} )
640 
        {
641 
            while ( (my ($pver, $pdata) ) = each %{$pvers} )
642 
            {
643 
                $logger->verbose("Need to transfer: $pname, $pver, $pdata");
644 
            }
645 
        }
646 
    }
1048 dpurdie 647 
    if ( $conf->{verbose}  )
648 
    {
649 
        $logger->verbose("Packages to transfer: $needPkgListCount");
650 
        $logger->verbose("Packages to delete: $excessPkgListCount");
651 
        $logger->verbose("Packages filtered out: $filteredCount");
652 
        $logger->verbose("Packages missing: $missingCount");
653 
        $logger->verbose("Packages still writable: $writableCount");
654 
        $logger->verbose("Packages excluded: $excludeCount");
655 
    }
1038 dpurdie 656 
 
657 
    #
5398 dpurdie 658 
    #   Update stats
659 
    #   At this point we are looking pretty good
660 
    #
661 
    $statistics{state} = 'OK';
5404 dpurdie 662 
    $statistics{total} = $packageVersionCount;
5398 dpurdie 663 
    $statistics{transfer} = $needPkgListCount;
664 
    $statistics{delete} = $excessPkgListCount;
665 
    $statistics{filtered} = $filteredCount;
666 
    $statistics{missing} = $missingCount;
667 
    $statistics{writable} = $writableCount;
668 
    $statistics{excluded} = $excludeCount;
669 
 
670 
    #
1038 dpurdie 671 
    #   Time to do the real work
672 
    #   Transfer packages and delete excess packages
673 
    #   Note: Perform the transfers first
674 
    #         Limit the number of packages processed in one pass
675 
    #
676 
    my $txcount = $conf->{maxpackages};
677 
 
678 
    #
679 
    #   Transfer packages that we have identified
680 
    #
681 
    send_pkgs:
682 
    while ( (my ($pname, $pvers)) = each %{$needPkgList} )
683 
    {
684 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
685 
        {
686 
            if ( --$txcount <= 0 )
687 
            {
1050 dpurdie 688 
                $logger->warn("Max transfer count exceeded: $needPkgListCount transfer remaining");
1038 dpurdie 689 
                $lastReleaseScan = 0;
690 
                last send_pkgs;
691 
            }
1289 dpurdie 692 
 
693 
            if ( readConfig() )
694 
            {
695 
                $logger->warn("Config file changed");
696 
                $lastReleaseScan = 0;
697 
                $txcount = 0;
698 
                last send_pkgs;
699 
            }
700 
 
1044 dpurdie 701 
            transferPackage ($pname, $pver, $pdata);
1048 dpurdie 702 
            $needPkgListCount--;
1038 dpurdie 703 
        }
704 
    }
705 
 
706 
    #
707 
    #   Delete packages that have been identified as excess
708 
    #
709 
    delete_pkgs:
710 
    while ( (my ($pname, $pvers)) = each %{$excessPkgList} )
711 
    {
712 
        while ( (my ($pver, $pdata) ) = each %{$pvers} )
713 
        {
714 
            if ( --$txcount <= 0 )
715 
            {
1050 dpurdie 716 
                $logger->warn("Max transfer count exceeded: $excessPkgListCount deletion remaining");
1038 dpurdie 717 
                $lastReleaseScan = 0;
718 
                last delete_pkgs;
719 
            }
1289 dpurdie 720 
 
721 
            if ( readConfig() )
722 
            {
723 
                $logger->warn("Config file changed");
724 
                $lastReleaseScan = 0;
725 
                $txcount = 0;
726 
                last send_pkgs;
727 
            }
728 
 
1044 dpurdie 729 
            deletePackage ($pname, $pver, $pdata);
1048 dpurdie 730 
            $excessPkgListCount--;
1038 dpurdie 731 
        }
732 
    }
733 
 
734 
    #
735 
    #   Send package list to the target
736 
    #
737 
    sendPackageList ($pkgList);
1040 dpurdie 738 
 
739 
    #
740 
    #   On a successful transfer
741 
    #       Force tag processing
742 
    #       Set scan Mode to normal
743 
    #
744 
    $tagDirTime = 0;
745 
    $releaseScanMode = 0;
1038 dpurdie 746 
}
747 
 
748 
#-------------------------------------------------------------------------------
749 
# Function        : sendPackageList
750 
#
751 
# Description     : Transfer package list to the target
752 
#
753 
# Inputs          : $pkgList            - Ref to hash of package names and versions
754 
#
1040 dpurdie 755 
# Returns         : Nothing
756 
#                   Don't really care about any errors from this process
757 
#                   Its not essential
1038 dpurdie 758 
#
759 
sub sendPackageList
760 
{
761 
    my ($pkgList) = @_;
762 
    my ($fh, $filename) = tempfile( "/tmp/blat.$$.XXXX", SUFFIX => '.txt');
763 
    $logger->verbose("sendPackageList:TmpFile: $filename");
764 
 
765 
    #
766 
    #   Create a temp file with data
767 
    #
768 
    foreach my $pname ( sort keys %{$pkgList} )
769 
    {
770 
        foreach my $pver ( sort keys %{$pkgList->{$pname}} )
771 
        {
772 
            print $fh "$pname/$pver\n";
773 
        }
774 
    }
775 
    close $fh;
776 
 
777 
    #
778 
    #   Transfer to target
779 
    #   Create the process pipe to transfer the file
780 
    #   gzip the file and pipe the result through a ssh session to the target machine
3515 dpurdie 781 
    #   gzip -c filename |  ssh  ... "./receive_file filename"
1038 dpurdie 782 
    #
783 
    my $ph;
3515 dpurdie 784 
    my $gzip_cmd = "$gzip --no-name -c \"$filename\"";
1040 dpurdie 785 
    my $tgt_cmd = "$conf->{'bindir'}/receive_file \"ArchiveList\"";
3515 dpurdie 786 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 787 
 
788 
    $logger->verbose2("sendPackageList:gzip_cmd:$gzip_cmd");
789 
    $logger->verbose2("sendPackageList:tgt_cmd:$tgt_cmd");
790 
    $logger->verbose2("sendPackageList:ssh_cmd:$ssh_cmd");
791 
 
792 
    open ($ph, "$gzip_cmd | $ssh_cmd |");
793 
    while ( <$ph> )
794 
    {
795 
        chomp;
796 
        $logger->verbose2("sendPackageList:Data: $_");
797 
    }
798 
    close ($ph);
3515 dpurdie 799 
    unlink $filename;
1038 dpurdie 800 
    $logger->verbose("sendPackageList:End: $?");
3515 dpurdie 801 
    LogTxError ($?);
1038 dpurdie 802 
}
803 
 
804 
 
805 
#-------------------------------------------------------------------------------
806 
# Function        : getPkgList
807 
#
808 
# Description     : Determine a set of package versions within the list
809 
#                   of provided releases
810 
#
811 
# Inputs          : @rlist              - A list of releases to examine
812 
#
813 
# Returns         : Ref to a hask of package versions
814 
#
815 
sub getPkgList
816 
{
817 
    my %pdata;
818 
    my $RM_DB;
819 
    connectRM(\$RM_DB);
820 
    $logger->verbose("getPkgList");
821 
 
822 
    #
823 
    #   Determine the releases that are in this project
824 
    #   Build up an sql query
825 
    #
826 
    my @m_rlist;
827 
    push @m_rlist,"rc.RTAG_ID=$_" foreach ( @_ );
828 
    my $m_rlist = join ' OR ', @m_rlist;
1048 dpurdie 829 
    my $m_sqlstr = "SELECT DISTINCT pv.PV_ID, pkg.PKG_NAME, pv.PKG_VERSION, pv.IS_DEPLOYABLE" .
1038 dpurdie 830 
                    " FROM RELEASE_MANAGER.RELEASE_CONTENT rc, RELEASE_MANAGER.PACKAGE_VERSIONS pv, RELEASE_MANAGER.PACKAGES pkg" .
831 
                    " WHERE ( $m_rlist ) AND rc.PV_ID = pv.PV_ID AND pv.PKG_ID = pkg.PKG_ID" .
832 
                    " ORDER by PKG_NAME DESC";
833 
    $logger->verbose3("getPkgList:Sql:$m_sqlstr");
834 
 
835 
    my $sth = $RM_DB->prepare($m_sqlstr);
836 
    if ( defined($sth) )
837 
    {
838 
        if ( $sth->execute( ) )
839 
        {
840 
            if ( $sth->rows )
841 
            {
842 
                while (my @row = $sth->fetchrow_array )
843 
                {
844 
                    $logger->verbose2("getPkgList:Data:@row");
845 
                    $pdata{$row[1]}{$row[2]} = 1;
846 
                }
847 
            }
848 
            $sth->finish();
849 
        }
850 
    }
851 
    else
852 
    {
853 
        $logger->warn("getPkgList: SQL Prepare failure");
854 
    }
1050 dpurdie 855 
 
856 
   disconnectRM(\$RM_DB);
1038 dpurdie 857 
   return \%pdata;
858 
}
859 
 
860 
 
861 
#-------------------------------------------------------------------------------
862 
# Function        : getReleaseList
863 
#
864 
# Description     : Determine the list of releases to be proccessed
1040 dpurdie 865 
#                   From:
866 
#                       Convert projects to a list of releases
867 
#                       Configured list of releases
1038 dpurdie 868 
#
869 
# Inputs          : None
870 
#
871 
# Returns         : A list of releases to be processed
872 
#
873 
sub getReleaseList
874 
{
875 
    my $RM_DB;
876 
    my %rlist;
1048 dpurdie 877 
    my $m_sqlstr;
1038 dpurdie 878 
    $logger->verbose("getReleaseList");
879 
 
880 
    #
1040 dpurdie 881 
    #   Cache data
882 
    #   Only for one cycle of the main loop
883 
    #
884 
    if ( exists $releaseData{getReleaseList} )
885 
    {
886 
        $logger->verbose3("getReleaseList:Cache hit");
887 
        return @{$releaseData{getReleaseList}};
888 
    }
889 
 
890 
    #
1048 dpurdie 891 
    #   All projects
1038 dpurdie 892 
    #
1048 dpurdie 893 
    if ( $conf->{'allProjects'} )
1038 dpurdie 894 
    {
1048 dpurdie 895 
        $m_sqlstr = "SELECT rt.RTAG_ID" .
896 
                    " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
1050 dpurdie 897 
                    " WHERE rt.OFFICIAL != 'A'";
898 
                    #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 899 
    }
900 
    else
901 
    {
1038 dpurdie 902 
        #
1048 dpurdie 903 
        #   Convert list of projects into a list of releases
1038 dpurdie 904 
        #
1048 dpurdie 905 
        my @plist = split /[,\s]+/, $conf->{'project'} || '';
906 
        if ( @plist )
907 
        {
908 
            #
909 
            #   Determine the releases that are in this project
910 
            #   Build up an sql query
911 
            #
912 
            my @m_plist;
913 
            push @m_plist,"PROJ_ID=$_" foreach ( @plist );
914 
            my $m_plist = join ' OR ', @m_plist;
915 
            $m_sqlstr = "SELECT rt.RTAG_ID" .
916 
                        " FROM RELEASE_MANAGER.RELEASE_TAGS rt" .
5300 dpurdie 917 
                        " WHERE ( $m_plist ) AND rt.OFFICIAL != 'A'";
918 
                        #" AND rt.OFFICIAL != 'Y'";
1048 dpurdie 919 
        }
920 
    }
1038 dpurdie 921 
 
1048 dpurdie 922 
    if ( defined $m_sqlstr )
923 
    {
1038 dpurdie 924 
        $logger->verbose3("getReleaseList:Sql:$m_sqlstr");
1048 dpurdie 925 
        connectRM(\$RM_DB);
1038 dpurdie 926 
        my $sth = $RM_DB->prepare($m_sqlstr);
927 
        if ( defined($sth) )
928 
        {
929 
            if ( $sth->execute( ) )
930 
            {
931 
                if ( $sth->rows )
932 
                {
933 
                    while (my @row = $sth->fetchrow_array )
934 
                    {
935 
                        $logger->verbose2("getReleaseList:Data:@row");
936 
                        $rlist{$row[0]} = 1;
937 
                    }
938 
                }
939 
                $sth->finish();
940 
            }
941 
        }
942 
        else
943 
        {
944 
            $logger->warn("getReleaseList: SQL Prepare failure");
945 
        }
1050 dpurdie 946 
        disconnectRM(\$RM_DB);
1038 dpurdie 947 
    }
948 
 
949 
    #
950 
    #   Add in the user specified list of releases
951 
    #
952 
    my @rlist = split /[,\s]+/, $conf->{'release'} || '';
953 
    $rlist{$_} = 1 foreach(@rlist);
954 
 
955 
    #
956 
    #   Sort for pretty display only
957 
    #
1040 dpurdie 958 
    @{$releaseData{getReleaseList}} = sort {$a <=> $b} keys %rlist;
959 
 
960 
    return @{$releaseData{getReleaseList}};
1038 dpurdie 961 
}
962 
 
1040 dpurdie 963 
#-------------------------------------------------------------------------------
3846 dpurdie 964 
# Function        : getPackageVersions
965 
#
966 
# Description     : Get the list of package-versions available in the package
967 
#                   store.
968 
#
969 
# Inputs          : pkgName             - The package name
970 
#
971 
# Returns         : Array of versions
972 
#
973 
sub getPackageVersions
974 
{
975 
    my ($pkgName) = @_;
976 
    my @versionList;
977 
 
978 
    my $pkgDir = catfile($conf->{'dpkg_archive'} , $pkgName );
979 
    my $dh;
980 
 
981 
    unless (opendir($dh, $pkgDir))
982 
    {
983 
        $logger->warn ("Can't opendir $pkgDir: $!");
984 
        return @versionList;
985 
    }
986 
 
987 
    #
988 
    #   Process each entry
989 
    #   Ignore those that start with a .
990 
    #
991 
    while (my $version = readdir($dh) )
992 
    {
993 
        next if ( $version =~ m~^\.~ );
994 
        my $file = catfile($pkgDir, $version);
995 
 
996 
        next unless ( -d $file );
997 
 
998 
        push @versionList, $version;
999 
        $logger->verbose3("getPackageVersions: $pkgName, $version");
1000 
    }
1001 
    closedir $dh;
1002 
    return @versionList;
1003 
}
1004 
 
1005 
#-------------------------------------------------------------------------------
4456 dpurdie 1006 
# Function        : getArchiveList
1007 
#
1008 
# Description     : Get the entire set of package versions in the archive
1009 
#
1010 
# Inputs          :
1011 
#
1012 
# Returns         : Ref to a hask of package versions
1013 
#
1014 
sub getArchiveList
1015 
{
1016 
    my $pkgDir = $conf->{'dpkg_archive'};
1017 
    my %archiveList;
1018 
    my $dh;
1019 
    my @pkgList;
1020 
 
1021 
    unless (opendir($dh, $pkgDir))
1022 
    {
1023 
        $logger->warn ("Can't opendir $pkgDir: $!");
1024 
        return \%archiveList;
1025 
    }
1026 
 
1027 
    #
1028 
    #   Process each entry
1029 
    #   Ignore those that start with a .
1030 
    #   Ignore files
1031 
    #
1032 
    while (my $pkgName = readdir($dh) )
1033 
    {
1034 
        next if ( $pkgName =~ m~^\.~ );
1035 
        my $file = catfile($pkgDir, $pkgName);
1036 
 
1037 
        next unless ( -d $file );
1038 
        $logger->verbose3("getArchiveList: $pkgName");
1039 
        push @pkgList, $pkgName;
1040 
    }
1041 
    closedir $dh;
1042 
 
1043 
    #   Now get the package versions
1044 
    #       Sort for pretty display
1045 
    foreach my $pname (sort @pkgList)
1046 
    {
1047 
        foreach my $pver (getPackageVersions($pname))
1048 
        {
1049 
            $archiveList{$pname}{$pver} = 1;
1050 
        }
1051 
    }
1052 
 
1053 
    return \%archiveList;
1054 
}
1055 
 
1056 
#-------------------------------------------------------------------------------
1040 dpurdie 1057 
# Function        : maintainTagList
1058 
#
1059 
# Description     : Maintain a data structure for the maintenance of the
1060 
#                   tags directory
1061 
#
1062 
# Inputs          : None
1063 
#
1064 
# Returns         : Nothing
1065 
#
1066 
sub maintainTagList
1067 
{
1068 
    #
1069 
    #   Time to perform the scan
1070 
    #   Will do at startup and every time period there after
1071 
    #
1072 
    return unless ( $now > ($lastTagListScan + $conf->{tagListUpdate} ));
1073 
    $logger->verbose("maintainTagList");
1074 
    $lastTagListScan = $now;
1038 dpurdie 1075 
 
1040 dpurdie 1076 
    #
1077 
    #   Get list of things
1078 
    #
1079 
    my %config;
4457 dpurdie 1080 
    if ($conf->{'allArchive'} )
1081 
    {
1082 
        $config{allArchive} = 1
1083 
    }
1084 
    elsif ($conf->{'allProjects'} )
1085 
    {
1086 
        $config{allProjects} = 1;
1087 
    }
1088 
    else
1089 
    {
1090 
        %{$config{projects}} = map { $_ => 1 } split (/[,\s]+/, $conf->{'project'} || '');
1091 
        %{$config{releases}} = map { $_ => 1 } getReleaseList();
1092 
    }
1040 dpurdie 1093 
 
1094 
    #
1095 
    #   Save data
1096 
    #
1097 
    my $dump =  Data::Dumper->new([\%config], [qw(*config)]);
1098 
#print $dump->Dump;
1099 
#$dump->Reset;
1100 
 
1101 
    #
1102 
    #   Save config data
1103 
    #
1104 
    my $conf_file = catfile( $conf->{'tagdir'},'.config' );
1105 
    $logger->verbose3("maintainTagList: Writting $conf_file");
1106 
 
1107 
    my $fh;
1108 
    open ( $fh, '>', $conf_file ) or $logger->err("Can't create $conf_file: $!");
1109 
    print $fh $dump->Dump;
1110 
    close $fh;
1111 
}
1112 
 
1113 
 
1038 dpurdie 1114 
#-------------------------------------------------------------------------------
1115 
# Function        : processTags
1116 
#
1117 
# Description     : Process tags and send marked package versions to the target
1118 
#                       Determine if new tags are present
1119 
#                       Process each tag
1120 
#
1121 
# Inputs          : None
1122 
#
1123 
# Returns         : Nothing
1124 
#
1125 
sub processTags
1126 
{
1127 
    #
1128 
    #   Determine if new tags are present by examining the time
1129 
    #   that the directory was last modified.
1130 
    #
1131 
    #   Allow for a forced scan to catch packages that did not transfer
1132 
    #   on the first attempt
1133 
    #
5398 dpurdie 1134 
    my $tagCount = 0;
1038 dpurdie 1135 
    my ($mtime) = Utils::mtime($conf->{'tagdir'} );
1136 
    if ( ($mtime > $tagDirTime) || ($now > ($lastDirScan + $conf->{'forcedirscan'})) )
1137 
    {
1042 dpurdie 1138 
        $logger->verbose2("processTags: ",$conf->{'tagdir'}, $mtime - $tagDirTime, $now - $lastDirScan);
1038 dpurdie 1139 
        $tagDirTime = $mtime;
1140 
        $lastDirScan = $now;
1141 
 
1142 
        my $dh;
1143 
        unless (opendir($dh, $conf->{'tagdir'}))
1144 
        {
1145 
            $logger->warn ("can't opendir $conf->{'tagdir'}: $!");
1146 
            return;
1147 
        }
1148 
 
1149 
        #
1150 
        #   Process each entry
1151 
        #   Ignore those that start with a .
1152 
        #
1153 
        while (my $tag = readdir($dh) )
1154 
        {
1155 
            next if ( $tag =~ m~^\.~ );
1156 
            my $file = "$conf->{'tagdir'}/$tag";
1042 dpurdie 1157 
            $logger->verbose3("processTags: $file");
1158 
 
1038 dpurdie 1159 
            next unless ( -f $file );
1160 
            next if ( $tag  eq 'ReleaseList' );
1161 
 
1162 
            if ( $tag =~ m~(.+)::(.+)~  )
1163 
            {
1164 
                my $package = $1;
1165 
                my $version = $2;
5398 dpurdie 1166 
                $tagCount++;
6098 dpurdie 1167 
 
1168 
                #
1169 
                #   Don't transfer 'extra' packages
1170 
                #
1171 
                if (exists ($extraPkgs->{$package}) )
1038 dpurdie 1172 
                {
6098 dpurdie 1173 
                    $logger->warn ("Delete excess package tag: $tag");
1038 dpurdie 1174 
                    unlink $file;
1175 
                }
6098 dpurdie 1176 
                elsif ( transferPackage( $package, $version ))
1177 
                {
1178 
                    unlink $file;
1179 
                }
1038 dpurdie 1180 
                else
1181 
                {
1182 
                    my ($mtime) = Utils::mtime( $file );
1183 
                    if ( $now - $mtime > $conf->{'tagage'} )
1184 
                    {
1185 
                        $logger->warn ("Delete unsatisfied tag: $tag");
1186 
                        unlink $file;
5398 dpurdie 1187 
                        $statistics{staleTags}++;
1038 dpurdie 1188 
                    }
1189 
                }
1190 
            }
1191 
        }
1192 
        closedir $dh;
1193 
    }
5398 dpurdie 1194 
    $statistics{tagCount} = $tagCount;
1038 dpurdie 1195 
}
1196 
 
1197 
#-------------------------------------------------------------------------------
1198 
# Function        : transferPackage
1199 
#
1200 
# Description     : Transfer specified package to target system
1201 
#
1202 
# Inputs          : $pname          - Name of the package
1203 
#                   $pver           - Package version
1204 
#                   $plink          - (optional) Symlink in same package
1205 
#
1206 
# Returns         : true    - Package transferred
1207 
#                   false   - Package not transferred
1208 
#
1209 
sub transferPackage
1210 
{
1211 
    my ($pname, $pver, $plink ) = @_;
1212 
    my $rv = 0;
1213 
    $logger->logmsg("transferPackage: @_");
6148 dpurdie 1214 
    my $startTime = time;
1038 dpurdie 1215 
 
1216 
    #
1040 dpurdie 1217 
    #   Do not transfer excluded files
1218 
    #
1219 
    if ( exists $excludePkgs->{$pname} )
1220 
    {
1048 dpurdie 1221 
        $logger->warn("transferPackage: Excluded package not transferred: $pname, $pver");
1040 dpurdie 1222 
        return 1;
1223 
    }
1048 dpurdie 1224 
 
1040 dpurdie 1225 
    #
1048 dpurdie 1226 
    #   Apply package filter
1227 
    #
1228 
    if ( defined $conf->{'packageFilter'} )
1229 
    {
1230 
        unless ( $pname =~ m~$conf->{'packageFilter'}~ )
1231 
        {
1232 
            $logger->warn("transferPackage: Filtered out package not transferred: $pname, $pver");
1233 
            return 1;
1234 
        }
1235 
    }
1236 
 
1237 
    #
1038 dpurdie 1238 
    #   plink of 1 is not a symlink
1239 
    #
1240 
    $plink = undef if ( defined($plink) && $plink eq '1' );
1241 
 
1242 
    #
6148 dpurdie 1243 
    #   If its known to be in the target archive, then we don't need to transfer it again
1244 
    #       It may have been transferred in this cycle
1245 
    #       It may have been in the archive anyway
1038 dpurdie 1246 
    #
6148 dpurdie 1247 
    if ( exists($RemotePkgList->{$pname}) && exists ($RemotePkgList->{$pname}{$pver})) {
1248 
        $logger->verbose("transferPackage: Already in archive");
1249 
	#$logger->logmsg("transferPackage: $pname, $pver : Already in archive");
1038 dpurdie 1250 
        return 1;
1251 
    }
1252 
 
1040 dpurdie 1253 
    my $sfile = catfile( $conf->{'dpkg_archive'} , $pname, $pver );
1038 dpurdie 1254 
    unless ( -d $sfile )
1255 
    {
1256 
        $logger->warn("transferPackage:Package not found: $pname, $pver");
1257 
        return $rv;
1258 
    }
1259 
 
1260 
    #
4456 dpurdie 1261 
    #   Create the process pipe to transfer the package
1038 dpurdie 1262 
    #   Tar the directory and pipe the result through a ssh session to
1263 
    #   the target machine
3515 dpurdie 1264 
    #   $tar -czf - -C "$dpkg/${pname}/${pver}" . |  ssh  ... "./receive_package pname pver"
1038 dpurdie 1265 
    #
1266 
    my $ph;
3515 dpurdie 1267 
    my $tar_cmd = "$tar -czf - -C \"$sfile\" .";
1038 dpurdie 1268 
    my $tgt_opts = defined($plink) ? "\"-L$plink\"" : '';
1040 dpurdie 1269 
    my $tgt_cmd = "$conf->{'bindir'}/receive_package $tgt_opts \"$pname\" \"$pver\"";
3515 dpurdie 1270 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 1271 
 
1272 
    $logger->verbose2("transferPackage:tar_cmd:$tar_cmd");
1273 
    $logger->verbose2("transferPackage:tgt_cmd:$tgt_cmd");
1274 
    $logger->verbose2("transferPackage:ssh_cmd:$ssh_cmd");
1275 
 
1276 
    open ($ph, "$tar_cmd | $ssh_cmd |");
1277 
    while ( <$ph> )
1278 
    {
1279 
        chomp;
1280 
        $logger->verbose2("transferPackage:Data: $_");
1281 
    }
1282 
    close ($ph);
1283 
    $logger->verbose("transferPackage:End: $?");
6148 dpurdie 1284 
 
1285 
    #
1286 
    #   Display the size of the package
1287 
    #       Diagnostic use
1288 
    #
1289 
    #open ( $ph, "du -bs $sfile 2>/dev/null |" );
1290 
    #my $line = <$ph>;
1291 
    #$line =~ m/^([0-9]+)/;
1292 
    #$line = $1 || 0;
1293 
    #my $size = sprintf "%.3f", $line / 1024 / 1024 / 1024 ;
1294 
    #close $ph;
1295 
    #my $duration = time - $startTime;
1296 
    #$logger->logmsg("transferPackage:Stats: $pname, $pver, $size Gb, $duration Secs");
1297 
 
1038 dpurdie 1298 
    if ( $? == 0 )
1299 
    {
1300 
        #
1301 
        #   Mark has having been transferred in the current cycle
1302 
        #
6148 dpurdie 1303 
        $RemotePkgList->{$pname}{$pver}{transferred} = 1;
1038 dpurdie 1304 
        $rv = 1;
5398 dpurdie 1305 
        $statistics{txCount}++;
1038 dpurdie 1306 
    }
1307 
    else
1308 
    {
1309 
        $logger->warn("transferPackage:Transfer Error: $pname, $pver, $?");
1310 
    }
3515 dpurdie 1311 
    LogTxError ($?);
1038 dpurdie 1312 
    return $rv;
1313 
}
1314 
 
1315 
#-------------------------------------------------------------------------------
1316 
# Function        : deletePackage
1317 
#
1318 
# Description     : Delete specified package to target system
1319 
#
1320 
# Inputs          : $pname          - Name of the package
1321 
#                   $pver           - Package version
1042 dpurdie 1322 
#                   $pdata          - Hash of extra data
1038 dpurdie 1323 
#
1324 
# Returns         : true    - Package transferred
1325 
#                   false   - Package not transferred
1326 
#
1327 
sub deletePackage
1328 
{
1042 dpurdie 1329 
    my ($pname, $pver, $pdata ) = @_;
1038 dpurdie 1330 
    my $rv = 0;
1042 dpurdie 1331 
    $logger->logmsg("deletePackage: $pname, $pver");
1038 dpurdie 1332 
 
1333 
    #
1334 
    #   Create the process pipe to delete the package
3515 dpurdie 1335 
    #   ssh  ... "./delete_package ${rx_opts} \"$pname\" \"$pver\""
1038 dpurdie 1336 
    #
1337 
    my $ph;
1042 dpurdie 1338 
    my $flags = $pdata->{FORCEDELETE}  ? '' : ' -T';
1339 
    my $tgt_cmd = "$conf->{'bindir'}/delete_package $flags \"$pname\" \"$pver\"";
3515 dpurdie 1340 
    my $ssh_cmd = sshCmd($tgt_cmd);
1038 dpurdie 1341 
 
1040 dpurdie 1342 
    $logger->verbose2("deletePackage:tgt_cmd:$tgt_cmd");
1343 
    $logger->verbose2("deletePackage:ssh_cmd:$ssh_cmd");
1038 dpurdie 1344 
 
1345 
    open ($ph, "$ssh_cmd |");
1346 
    while ( <$ph> )
1347 
    {
1348 
        chomp;
1349 
        $logger->verbose2("deletePackage:Data: $_");
1350 
    }
1351 
    close ($ph);
1352 
    $logger->verbose("deletePackage:End: $?");
1353 
    if ( $? == 0 )
1354 
    {
1355 
        $rv = 1;
5398 dpurdie 1356 
        $statistics{delCount}++;
6148 dpurdie 1357 
        delete $RemotePkgList->{$pname}{$pver};
1038 dpurdie 1358 
    }
1359 
    else
1360 
    {
1361 
        $logger->warn("deletePackage:Error: $pname, $pver, $?");
1362 
    }
3515 dpurdie 1363 
    LogTxError ($?);
1038 dpurdie 1364 
    return $rv;
1365 
}
1366 
 
3515 dpurdie 1367 
#-------------------------------------------------------------------------------
1368 
# Function        : sshCmd
1369 
#
1370 
# Description     : Generate a ssh based command
1371 
#
1372 
# Inputs          : Target command
1373 
#
1374 
# Returns         : An shh command string
1375 
#
1376 
sub sshCmd
1377 
{
1378 
    my ($tgt_cmd) = @_;
3847 dpurdie 1379 
    my $sshPort = '';
1380 
    $sshPort = "-p $conf->{'sshport'}"
1381 
        if ($conf->{'sshport'});
1382 
 
1383 
    return "ssh -o \"BatchMode yes\" -i $conf->{'identity'} ${sshPort} $conf->{'user'}\@$conf->{'hostname'} \"$tgt_cmd\" 2>&1";
3515 dpurdie 1384 
}
1038 dpurdie 1385 
 
3515 dpurdie 1386 
 
1038 dpurdie 1387 
#-------------------------------------------------------------------------------
1042 dpurdie 1388 
# Function        : parsePkgList
1389 
#
1390 
# Description     : Parse one line from a pkgList
1391 
#                   Lines are multiple item="data" items
6148 dpurdie 1392 
#                       time="1497586865" GMT="Fri Jun 16 04:21:05 2017" pname="ERGissaccounts" pver="1.0.7169.mas"
1042 dpurdie 1393 
#
1394 
# Inputs          : $line                   - Line of data
1395 
#                   $hashp                  - Ref to hash to populate
1396 
#
1397 
# Returns         : A hash of data items
1398 
#
1399 
sub parsePkgList
1400 
{
1401 
    my ($line, $hashp) = @_;
1402 
    my $rv;
1403 
 
1404 
    while ( $line =~ m~\s*(.+?)="(.+?)"~ )
1405 
    {
1406 
        $rv->{$1} = $2;
1407 
        $line = $';
1408 
    }
1409 
#Utils::DebugDumpData ("parsePkgList", $rv);
1410 
 
1411 
    my $pname = $rv->{pname};
1412 
    my $pver =  $rv->{pver};
1413 
    return undef unless ( $pname && $pver );
1414 
 
1415 
    delete $rv->{pname};
1416 
    delete $rv->{pver};
1417 
    delete $rv->{GMT};
1418 
 
1419 
    $hashp->{$pname}{$pver} = $rv;
1420 
    return $hashp;
1421 
}
1422 
 
5398 dpurdie 1423 
#-------------------------------------------------------------------------------
5404 dpurdie 1424 
# Function        : parsePkgMetaData
1425 
#
1426 
# Description     : Parse one line of meta data from a pkgList
1427 
#                   Lines are multiple item="data" items
1428 
#
1429 
# Inputs          : $line                   - Line of data
1430 
#                   $hashp                  - Ref to hash to populate
1431 
#
1432 
# Returns         : Nothing
1433 
#
1434 
sub parsePkgMetaData
1435 
{
1436 
    my ($line, $hashp) = @_;
1437 
 
1438 
    if ( $line =~ m~\s+(.+?)="(.+?)"~ )
1439 
    {
1440 
        $hashp->{$1} = $2;
1441 
        $statistics{'Target.' . $1} = $2;
1442 
        $line = $';
1443 
 
1444 
        $logger->verbose2("parsePkgMetaData: $1 = $2");
1445 
    }
1446 
}
1447 
 
1448 
 
1449 
#-------------------------------------------------------------------------------
5398 dpurdie 1450 
# Function        : resetDailyStatistics
1451 
#
1452 
# Description     : Called periodically to reset the daily statistics
1453 
#
1454 
# Inputs          : $time       - Current time
1455 
#
1456 
# Returns         :
1457 
#
1458 
sub resetDailyStatistics
1459 
{
1460 
    my ($time) = @_;
1042 dpurdie 1461 
 
5398 dpurdie 1462 
    #
1463 
    #   Detect a new day
1464 
    #
1465 
    my $today = (localtime($time))[7];
1466 
    if ($yday != $today)
1467 
    {
1468 
        $yday = $today;
1469 
        $logger->logmsg('Resetting daily statistics' );
1470 
 
5404 dpurdie 1471 
        # Note: Must match @recoverTags in readStatistics
5398 dpurdie 1472 
        $statistics{dayStart} = $time;
1473 
        $statistics{txCount} = 0;
1474 
        $statistics{delCount} = 0;
1475 
        $statistics{staleTags} = 0;
1476 
        $statistics{linkErrors} = 0;
1477 
    }
1478 
}
1479 
 
1042 dpurdie 1480 
#-------------------------------------------------------------------------------
5404 dpurdie 1481 
# Function        : readStatistics
1482 
#
1483 
# Description     : Read in the last set of stats
1484 
#                   Used after a restart to recover daily statistics
1485 
#
1486 
# Inputs          :
1487 
#
1488 
# Returns         :
1489 
#
1490 
sub readStatistics
1491 
{
1492 
    my @recoverTags = qw(dayStart txCount delCount staleTags linkErrors);
1493 
 
1494 
    if ($conf->{'statsfile'} and -f $conf->{'statsfile'})
1495 
    {
1496 
        if (open my $fh, $conf->{'statsfile'})
1497 
        {
1498 
            while (<$fh>)
1499 
            {
1500 
                m~(.*):(.*)~;
1501 
                if ( grep( /^$1$/, @recoverTags ) )
1502 
                {
1503 
                    $statistics{$1} = $2;
1504 
                    $logger->verbose("readStatistics $1, $2\n");
1505 
                }
1506 
            }
1507 
            close $fh;
1508 
            $yday = (localtime($statistics{dayStart}))[7];
1509 
        }
1510 
    }
1511 
}
1512 
 
1513 
 
1514 
#-------------------------------------------------------------------------------
5398 dpurdie 1515 
# Function        : periodicStatistics
1516 
#
1517 
# Description     : Called on a regular basis to write out statistics
1518 
#                   Used to feed information into Nagios
1519 
#
1520 
#                   This function is called via an alarm and may be outside the normal
1521 
#                   processing loop. Don't make assumptions on the value of $now
1522 
#
1523 
# Inputs          :
1524 
#
1525 
# Returns         :
1526 
#
1527 
sub periodicStatistics
1528 
{
1529 
    #
1530 
    #   A few local stats
1531 
    #
1532 
    $statistics{SeqNum}++;
1533 
    $statistics{timeStamp} = time();
1534 
    $statistics{upTime} = $statistics{timeStamp} - $startTime;
1535 
 
1536 
    #   Reset daily accumulations - on first use each day
1537 
    resetDailyStatistics($statistics{timeStamp});
1538 
 
1539 
    #
1540 
    #   Write statistics to a file
1541 
    #       Write to a tmp file, then rename.
1542 
    #       Attempt to make the operation atomic - so that the file consumer
1543 
    #       doesn't get a badly formed file.
1544 
    #
1545 
    if ($conf->{'statsfiletmp'})
1546 
    {
1547 
        my $fh;
1548 
        unless (open ($fh, '>', $conf->{'statsfiletmp'}))
1549 
        {
1550 
            $fh = undef;
1551 
            $logger->warn("Cannot create temp stats file: $!");
1552 
        }
1553 
        else
1554 
        {
5404 dpurdie 1555 
            foreach my $key ( sort { lc($a) cmp lc($b) } keys %statistics)
5398 dpurdie 1556 
            {
1557 
                print $fh $key . ':' . $statistics{$key} . "\n";
1558 
                $logger->verbose2('Statistics:'. $key . ':' . $statistics{$key});
1559 
            }
1560 
            close $fh;
1561 
 
1562 
            # Rename temp to real file
1563 
            rename  $conf->{'statsfiletmp'},  $conf->{'statsfile'} ;
1564 
        }
1565 
    }
1566 
}
1567 
 
1568 
#-------------------------------------------------------------------------------
1038 dpurdie 1569 
# Function        : sighandlers
1570 
#
1571 
# Description     : Install signal handlers
1572 
#
1573 
# Inputs          : $conf           - System config
1574 
#
1575 
# Returns         : Nothing
1576 
#
1577 
sub sighandlers
1578 
{
5398 dpurdie 1579 
    my $conf = shift;
1580 
    my $logger = $conf->{logger};
1038 dpurdie 1581 
 
5398 dpurdie 1582 
    $SIG{TERM} = sub {
1583 
        # On shutdown
1584 
        $logger->logmsg('Received SIGTERM. Shutting down....' );
1585 
        unlink $conf->{'pidfile'} if (-f $conf->{'pidfile'});
1586 
        exit 0;
1587 
    };
1038 dpurdie 1588 
 
5398 dpurdie 1589 
    $SIG{HUP} = sub {
1590 
        # On logrotate
1591 
        $logger->logmsg('Received SIGHUP.');
1592 
        $logger->rotatelog();
1593 
    };
1038 dpurdie 1594 
 
5398 dpurdie 1595 
    $SIG{USR1} = sub {
1596 
        # On Force Archive Sync
1597 
        $logger->logmsg('Received SIGUSR1.');
1046 dpurdie 1598 
        $lastReleaseScan = 0;
1599 
        $lastTagListScan = 0;
5398 dpurdie 1600 
    };
1038 dpurdie 1601 
 
5398 dpurdie 1602 
    alarm 60;
1603 
    $SIG{ALRM} = sub {
1604 
        # On Dump Statistics
1605 
        $logger->verbose2('Received SIGUSR2.');
1606 
        periodicStatistics();
1607 
        alarm 60;
1608 
    };
1609 
 
1038 dpurdie 1610 
    $SIG{__WARN__} = sub { $logger->warn("@_") };
1611 
    $SIG{__DIE__} = sub { $logger->err("@_") };
1612 
}
1613 
 
1614 
#-------------------------------------------------------------------------------
3515 dpurdie 1615 
# Function        : LogTxError
1616 
#
1617 
# Description     : Detect restoration of communication and log such
1618 
#                   Don't log failures as the user will do that
1619 
#
1620 
# Inputs          : $state                  - 0 - All is well
1621 
#                                           !0  - Error
1622 
#
1623 
# Returns         : Nothing
1624 
#
1625 
sub LogTxError
1626 
{
1627 
    my ($state) = $@;
1628 
    if ( $state )
1629 
    {
5398 dpurdie 1630 
        $statistics{linkErrors}++ unless($comError);
3515 dpurdie 1631 
        $comError++;
5398 dpurdie 1632 
        $statistics{state} = 'No Communication';
3515 dpurdie 1633 
    }
1634 
    elsif ( $comError )
1635 
    {
1636 
        $logger->warn("Communication Restored");
1637 
        $comError = 0;
5398 dpurdie 1638 
        $statistics{state} = 'OK';
3515 dpurdie 1639 
    }
1640 
}
1641 
 
1642 
 
1643 
#-------------------------------------------------------------------------------
1038 dpurdie 1644 
# Function        : Error, Verbose, Warning
1645 
#
1646 
# Description     : Support for JatsRmApi
1647 
#
1648 
# Inputs          : Message
1649 
#
1650 
# Returns         : Nothing
1651 
#
1652 
sub Error
1653 
{
1654 
    $logger->err("@_");
1655 
}
1656 
 
1657 
sub Verbose
1658 
{
1042 dpurdie 1659 
    $logger->verbose2("@_");
1038 dpurdie 1660 
}
1661 
 
1662 
sub Warning
1663 
{
1664 
    $logger->warn("@_");
1665 
}
1666 
 
1667 
 
1668 
 
1669