Subversion Repositories DevTools

Rev

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