Subversion Repositories DevTools

Rev

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