Subversion Repositories DevTools

Rev

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