Subversion Repositories DevTools

Rev

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