| 7539 |
dpurdie |
1 |
#! /usr/bin/perl
|
|
|
2 |
########################################################################
|
|
|
3 |
# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
|
|
|
4 |
#
|
|
|
5 |
# Module name : blatQuarantine.pl
|
|
|
6 |
# Module type :
|
|
|
7 |
# Compiler(s) : Perl
|
|
|
8 |
# Environment(s):
|
|
|
9 |
#
|
|
|
10 |
# Description : Age outpackages from dpkg_archive
|
|
|
11 |
# A replacement for the original quarantine process
|
|
|
12 |
#
|
|
|
13 |
# Usage : ARGV[0] - Path to config file for this instance
|
|
|
14 |
#
|
|
|
15 |
#! /usr/bin/perl
|
|
|
16 |
#......................................................................#
|
|
|
17 |
|
|
|
18 |
require 5.008_002;
|
|
|
19 |
use strict;
|
|
|
20 |
use warnings;
|
|
|
21 |
use Getopt::Long;
|
|
|
22 |
use File::Basename;
|
|
|
23 |
use Data::Dumper;
|
|
|
24 |
use File::Spec::Functions;
|
|
|
25 |
use POSIX ":sys_wait_h";
|
|
|
26 |
use File::Temp qw/tempfile/;
|
|
|
27 |
#use Digest::MD5 qw(md5_base64 md5_hex);
|
|
|
28 |
#use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
|
|
|
29 |
|
|
|
30 |
use FindBin; # Determine the current directory
|
|
|
31 |
use lib "$FindBin::Bin/lib"; # Allow local libraries
|
|
|
32 |
|
|
|
33 |
use Utils;
|
|
|
34 |
use StdLogger; # Log to sdtout
|
|
|
35 |
use Logger; # Log to file
|
|
|
36 |
|
|
|
37 |
#
|
|
|
38 |
# Database interface
|
|
|
39 |
# Pinched from jats and modified so that this software is not dependent on JATS
|
|
|
40 |
#
|
|
|
41 |
use IO::Handle;
|
|
|
42 |
use JatsRmApi;
|
|
|
43 |
use DBI;
|
|
|
44 |
|
|
|
45 |
#
|
|
|
46 |
# Globals
|
|
|
47 |
#
|
|
|
48 |
my $logger = StdLogger->new(); # Stdout logger. Only during config
|
|
|
49 |
$logger->err("No config file specified") unless (defined $ARGV[0]);
|
|
|
50 |
$logger->err("Config File does not exist: $ARGV[0]") unless (-f $ARGV[0]);
|
|
|
51 |
my $name = basename( $ARGV[0]);
|
|
|
52 |
$name =~ s~.conf$~~;
|
|
|
53 |
my $now = 0;
|
|
|
54 |
my $startTime = 0;
|
|
|
55 |
my $nextQScan = 0;
|
|
|
56 |
my $lastS3Refresh = 0;
|
|
|
57 |
my $lastTagListUpdate = 0;
|
|
|
58 |
my $mtimeConfig = 0;
|
|
|
59 |
my $conf;
|
|
|
60 |
my $yday = -1;
|
|
|
61 |
my $linkUp = 1;
|
|
|
62 |
my $dbUp = 1;
|
|
|
63 |
my $RM_DB;
|
|
|
64 |
my $DM_DB;
|
|
|
65 |
my $activeReleases;
|
|
|
66 |
my $RMerror = 0; # Error on last RM DB access
|
|
|
67 |
my $ignorePkg; # Ref to hash of packages to ignore
|
|
|
68 |
my $explainFh; # Per quarantine info
|
|
|
69 |
|
|
|
70 |
#
|
|
|
71 |
# Contain statisics maintained while operating
|
|
|
72 |
# Can be dumped with a kill -USR2
|
|
|
73 |
# List here for documentation
|
|
|
74 |
#
|
|
|
75 |
|
|
|
76 |
my %statistics = (
|
|
|
77 |
SeqNum => 0, # Bumped when $statistics are dumped
|
|
|
78 |
timeStamp => 0, # DateTime when statistics are dumped
|
|
|
79 |
upTime => 0, # Seconds since program start
|
|
|
80 |
Cycle => 0, # Major process loop counter
|
|
|
81 |
phase => 'Init', # Current phase of operation
|
|
|
82 |
state => 'OK', # Nagios state
|
|
|
83 |
wedged => 0, # Wedge indication - main loop not cycling
|
|
|
84 |
#
|
|
|
85 |
# The following are reset each day
|
|
|
86 |
dayStart => 0, # DateTime when daily data was reset
|
|
|
87 |
linkErrors => 0, # Transfer (S3) errors
|
|
|
88 |
dbErrors => 0, # Database errors
|
|
|
89 |
processLoops => 0, # Number of time the quarantine process was run
|
| 7544 |
dpurdie |
90 |
QuarantineCount => 0, # Packages quarantined today
|
|
|
91 |
QuarantineTxRequested => 0, # Requests for transfer to S3 (unexpected)
|
|
|
92 |
QuarantineError => 0, # Errors encountered today
|
|
|
93 |
|
| 7539 |
dpurdie |
94 |
);
|
|
|
95 |
|
|
|
96 |
#
|
|
|
97 |
# Stats gatthered during the quarantine process
|
|
|
98 |
# Held in a seperate structure to simplify handling
|
| 7544 |
dpurdie |
99 |
# Per Cycle Data - Calculated each processing Cycle
|
| 7539 |
dpurdie |
100 |
#
|
|
|
101 |
my %qStats = (
|
|
|
102 |
# Error counters
|
|
|
103 |
QuarantineError => 0,
|
|
|
104 |
|
|
|
105 |
# Major Statistics
|
| 7544 |
dpurdie |
106 |
Quarantine => 0, # Total packages to be quarantined
|
|
|
107 |
QuarantineCount => 0, # Packages quarantined in this cycle
|
|
|
108 |
QuarantineTxRequested => 0, # Requests for transfer to S3 (unexpected)
|
|
|
109 |
QuarantineToDo => 0, # Remaining to be processed
|
| 7539 |
dpurdie |
110 |
|
|
|
111 |
# Minor Statistics
|
| 7544 |
dpurdie |
112 |
# Reasons that packages are retained
|
|
|
113 |
ReasonFileNotInReleaseManager => 0,
|
|
|
114 |
ReasonInDeploymentManager => 0,
|
|
|
115 |
ReasonInSdk => 0,
|
|
|
116 |
ReasonIsPatch => 0,
|
|
|
117 |
ReasonManualBuild => 0,
|
|
|
118 |
ReasonRetainTime => 0,
|
|
|
119 |
ReasonNoBuildStandard => 0,
|
|
|
120 |
ReasonNoPackageEntry => 0,
|
|
|
121 |
ReasonNoPVid => 0,
|
|
|
122 |
ReasonNotInArchive => 0,
|
|
|
123 |
ReasonNotInReleaseManager => 0,
|
|
|
124 |
ReasonNotLocked => 0,
|
|
|
125 |
ReasonSecondLevelPackage => 0,
|
|
|
126 |
ReasonTopLevelPackage => 0,
|
|
|
127 |
ReasonTotalPackages => 0,
|
| 7539 |
dpurdie |
128 |
|
| 7544 |
dpurdie |
129 |
DpkgPackageCount => 0, # Number of packages in dpkg_archive
|
|
|
130 |
DpkgArchiveCount => 0, # Number of package-versions in dpkg_archive
|
| 7539 |
dpurdie |
131 |
ReleaseCount => 0, # Number of releases to process
|
|
|
132 |
RmPackageCount => 0, # Number of packages extracted from RM
|
| 7544 |
dpurdie |
133 |
TopLevelCount => 0, # Number of top level packages extracted from RM
|
|
|
134 |
DmPackageCount => 0, # Number of packages from Recent DM SBoms
|
|
|
135 |
SdkCount => 0, # Number of packages in SDKs
|
| 7539 |
dpurdie |
136 |
StrayCount => 0, # Number of stray packages discovered
|
|
|
137 |
);
|
|
|
138 |
|
|
|
139 |
#
|
|
|
140 |
# Describe configuration parameters
|
|
|
141 |
#
|
|
|
142 |
my %cdata = (
|
|
|
143 |
'.ignore' => {'pkg\.(.+)' => 'pkgs' },
|
|
|
144 |
|
|
|
145 |
'piddir' => {'mandatory' => 1 , 'fmt' => 'dir'},
|
|
|
146 |
'sleep' => {'default' => 5 , 'fmt' => 'period'},
|
|
|
147 |
'sleepLinkDown' => {'default' => '1m' , 'fmt' => 'period'},
|
|
|
148 |
'dpkg_archive' => {'mandatory' => 1 , 'fmt' => 'dir'},
|
|
|
149 |
'logfile' => {'mandatory' => 1 , 'fmt' => 'vfile'},
|
|
|
150 |
'logfile.size' => {'default' => '1M' , 'fmt' => 'size'},
|
|
|
151 |
'logfile.count' => {'default' => 9 , 'fmt' => 'int'},
|
|
|
152 |
'wedgeTime' => {'default' => '120m' , 'fmt' => 'period'}, # Can take a long time to process
|
|
|
153 |
|
|
|
154 |
'verbose' => {'default' => 0 , 'fmt' => 'int'}, # Debug ...
|
|
|
155 |
'active' => {'default' => 1 , 'fmt' => 'bool'}, # Disable alltogether
|
|
|
156 |
'debug' => {'default' => 0 , 'fmt' => 'bool'}, # Log to screen
|
|
|
157 |
'txdetail' => {'default' => 0 , 'fmt' => 'bool'}, # Show transfer times
|
|
|
158 |
'noTransfers' => {'default' => 0 , 'fmt' => 'bool'}, # Debugging option to prevent transfers
|
|
|
159 |
|
|
|
160 |
'test' => {'default' => 0 , 'fmt' => 'bool'}, # Used to test parts of the code
|
|
|
161 |
|
|
|
162 |
'tagdir' => {'mandatory' => 1 , 'fmt' => 'mkdir'},
|
|
|
163 |
|
|
|
164 |
'runTime' => {'default' => undef , 'fmt' => 'period'}, # Time after midnight to run the quarantine process
|
|
|
165 |
'forcedirscan' => {'default' => '24h' , 'fmt' => 'period'}, # Period to run quantine scan
|
|
|
166 |
|
|
|
167 |
'forces3update' => {'default' => '30m' , 'fmt' => 'period'},
|
|
|
168 |
'tagListUpdate' => {'default' => '1h' , 'fmt' => 'period'},
|
|
|
169 |
'S3Bucket' => {'mandatory' => 1 , 'fmt' => 'text'},
|
|
|
170 |
'S3Profile' => {'mandatory' => 1 , 'fmt' => 'text'},
|
|
|
171 |
'S3Region' => {'default' => undef , 'fmt' => 'text'},
|
|
|
172 |
|
|
|
173 |
'snapAge' => {'default' => '1' , 'fmt' => 'int'}, # Days not a time
|
|
|
174 |
'retainNoRm' => {'default' => '31d' , 'fmt' => 'period'},
|
|
|
175 |
'retain' => {'default' => '10d' , 'fmt' => 'period'},
|
|
|
176 |
|
|
|
177 |
'explain' => {'default' => 1 , 'fmt' => 'bool'},
|
|
|
178 |
);
|
|
|
179 |
|
|
|
180 |
|
|
|
181 |
#
|
|
|
182 |
# Read in the configuration
|
|
|
183 |
# Set up a logger
|
|
|
184 |
# Write a pidfile - thats not used
|
|
|
185 |
$now = $startTime = time();
|
|
|
186 |
readConfig();
|
|
|
187 |
Utils::writepid($conf);
|
|
|
188 |
$logger->logmsg("Starting...");
|
|
|
189 |
readStatistics();
|
|
|
190 |
sighandlers();
|
|
|
191 |
$nextQScan = setQuarantineRunTime(0);
|
|
|
192 |
|
|
|
193 |
#
|
|
|
194 |
# Main processing loop
|
|
|
195 |
# Will exit when terminated by parent
|
|
|
196 |
#
|
|
|
197 |
while (1)
|
|
|
198 |
{
|
|
|
199 |
$logger->verbose3("Processing");
|
|
|
200 |
$statistics{Cycle}++;
|
|
|
201 |
$now = time();
|
|
|
202 |
Utils::resetWedge();
|
|
|
203 |
|
|
|
204 |
$statistics{phase} = 'ReadConfig';
|
|
|
205 |
readConfig();
|
|
|
206 |
if ( $conf->{'active'} )
|
|
|
207 |
{
|
|
|
208 |
$statistics{phase} = 'Refresh S3 Info';
|
|
|
209 |
refreshS3Info();
|
|
|
210 |
if( $linkUp )
|
|
|
211 |
{
|
|
|
212 |
$statistics{phase} = 'Process Packages';
|
|
|
213 |
processPackages();
|
|
|
214 |
|
|
|
215 |
$statistics{phase} = 'maintainTagList';
|
|
|
216 |
maintainTagList();
|
|
|
217 |
}
|
|
|
218 |
}
|
|
|
219 |
|
|
|
220 |
$statistics{phase} = 'Sleep';
|
|
|
221 |
sleep( ($linkUp && $dbUp) ? $conf->{'sleep'} : $conf->{'sleepLinkDown'} );
|
|
|
222 |
reapChildren();
|
|
|
223 |
|
|
|
224 |
# If my PID file ceases to be, then exit the daemon
|
|
|
225 |
# Used to force daemon to restart
|
|
|
226 |
#
|
|
|
227 |
unless ( -f $conf->{'pidfile'} )
|
|
|
228 |
{
|
|
|
229 |
$logger->logmsg("Terminate. Pid file removed");
|
|
|
230 |
last;
|
|
|
231 |
}
|
|
|
232 |
}
|
|
|
233 |
$statistics{phase} = 'Terminated';
|
|
|
234 |
$logger->logmsg("Child End");
|
|
|
235 |
exit 0;
|
|
|
236 |
|
|
|
237 |
#-------------------------------------------------------------------------------
|
|
|
238 |
# Function : reapChildren
|
|
|
239 |
#
|
|
|
240 |
# Description : Reap any and all dead children
|
|
|
241 |
# Call in major loops to prevent zombies accumulating
|
|
|
242 |
#
|
|
|
243 |
# Inputs : None
|
|
|
244 |
#
|
|
|
245 |
# Returns :
|
|
|
246 |
#
|
|
|
247 |
sub reapChildren
|
|
|
248 |
{
|
|
|
249 |
my $currentPhase = $statistics{phase};
|
|
|
250 |
$statistics{phase} = 'Reaping';
|
|
|
251 |
|
|
|
252 |
my $kid;
|
|
|
253 |
do {
|
|
|
254 |
$kid = waitpid(-1, WNOHANG);
|
|
|
255 |
} while ( $kid > 0 );
|
|
|
256 |
|
|
|
257 |
$statistics{phase} = $currentPhase;
|
|
|
258 |
}
|
|
|
259 |
|
|
|
260 |
|
|
|
261 |
#-------------------------------------------------------------------------------
|
|
|
262 |
# Function : readConfig
|
|
|
263 |
#
|
|
|
264 |
# Description : Re read the config file if it modification time has changed
|
|
|
265 |
#
|
|
|
266 |
# Inputs : Nothing
|
|
|
267 |
#
|
|
|
268 |
# Returns : 0 - Config not read
|
|
|
269 |
# 1 - Config read
|
|
|
270 |
# Config file has changed
|
|
|
271 |
#
|
|
|
272 |
sub readConfig
|
|
|
273 |
{
|
|
|
274 |
my ($mtime) = Utils::mtime($ARGV[0]);
|
|
|
275 |
my $rv = 0;
|
|
|
276 |
|
|
|
277 |
if ( $mtimeConfig != $mtime )
|
|
|
278 |
{
|
|
|
279 |
$logger->logmsg("Reading config file: $ARGV[0]");
|
|
|
280 |
$mtimeConfig = $mtime;
|
|
|
281 |
my $errors;
|
|
|
282 |
($conf, $errors) = Utils::readconf ( $ARGV[0], \%cdata );
|
|
|
283 |
if ( scalar @{$errors} > 0 )
|
|
|
284 |
{
|
|
|
285 |
warn "$_\n" foreach (@{$errors});
|
|
|
286 |
die ("Config contained errors\n");
|
|
|
287 |
}
|
|
|
288 |
|
|
|
289 |
#
|
|
|
290 |
# Reset some information
|
|
|
291 |
# Create a new logger
|
|
|
292 |
#
|
|
|
293 |
$logger = Logger->new($conf) unless $conf->{debug};
|
|
|
294 |
$conf->{logger} = $logger;
|
|
|
295 |
$conf->{'pidfile'} = $conf->{'piddir'} . '/' . $name . '.pid';
|
|
|
296 |
$logger->setVerbose($conf->{verbose});
|
|
|
297 |
$logger->verbose("Log Levl: $conf->{verbose}");
|
|
|
298 |
|
|
|
299 |
#
|
|
|
300 |
# Setup statistics filename
|
|
|
301 |
$conf->{'statsfile'} = $conf->{'piddir'} . '/' . $name . '.stats';
|
|
|
302 |
$conf->{'statsfiletmp'} = $conf->{'piddir'} . '/' . $name . '.stats.tmp';
|
|
|
303 |
|
|
|
304 |
#
|
|
|
305 |
# Process 'pkgs' entry and set up $ignorePkg
|
|
|
306 |
#
|
|
|
307 |
$ignorePkg = {};
|
|
|
308 |
while (my($key, $data) = each ( %{$conf->{pkgs}} ))
|
|
|
309 |
{
|
|
|
310 |
if ( $data eq 'KEEP' ) {
|
|
|
311 |
$ignorePkg->{$key} = 1;
|
|
|
312 |
$logger->verbose("Keep Pkg: $key");
|
|
|
313 |
|
|
|
314 |
} else {
|
|
|
315 |
$logger->warn("Unknown pkg mode: $key, $data");
|
|
|
316 |
}
|
|
|
317 |
}
|
|
|
318 |
|
|
|
319 |
#
|
|
|
320 |
# When config is read force some actions
|
|
|
321 |
# - Force tagList to be created
|
|
|
322 |
# - Force refresh from S3
|
|
|
323 |
$lastTagListUpdate = 0;
|
|
|
324 |
$lastS3Refresh = 0;
|
|
|
325 |
$rv = 1;
|
|
|
326 |
|
|
|
327 |
#
|
|
|
328 |
# When config is read force some actions
|
|
|
329 |
#Utils::DebugDumpData ("Config", $conf);
|
|
|
330 |
|
|
|
331 |
$logger->warn("All Transfers disabled") if ( $conf->{'noTransfers'} );
|
|
|
332 |
$logger->warn("Package quarantine is inactive") unless ( $conf->{'active'} );
|
|
|
333 |
$logger->warn("TEST MODE") if ( $conf->{'test'} );
|
|
|
334 |
}
|
|
|
335 |
|
|
|
336 |
return $rv;
|
|
|
337 |
}
|
|
|
338 |
|
|
|
339 |
#-------------------------------------------------------------------------------
|
|
|
340 |
# Function : refreshS3Info
|
|
|
341 |
#
|
|
|
342 |
# Description : At startup, and at time after startup examine the S3 bucket
|
|
|
343 |
# and recover information from it
|
|
|
344 |
#
|
|
|
345 |
# Inputs :
|
|
|
346 |
#
|
|
|
347 |
# Returns : 0 - Gross error ( Bucket access)
|
|
|
348 |
#
|
|
|
349 |
sub refreshS3Info
|
|
|
350 |
{
|
|
|
351 |
my $rv = 1;
|
|
|
352 |
if ( !$linkUp || ($now > ($lastS3Refresh + $conf->{'forces3update'})) )
|
|
|
353 |
{
|
|
|
354 |
$logger->verbose("refreshS3Info");
|
|
|
355 |
$lastS3Refresh = $now;
|
|
|
356 |
|
|
|
357 |
#
|
|
|
358 |
# Examine the s3 bucket and extract useful information
|
|
|
359 |
#
|
|
|
360 |
my $startTime = time;
|
|
|
361 |
$rv = examineS3Bucket();
|
|
|
362 |
unless ($rv) {
|
|
|
363 |
$statistics{linkErrors}++;
|
|
|
364 |
$linkUp = 0;
|
|
|
365 |
} else {
|
|
|
366 |
$linkUp = 1;
|
|
|
367 |
}
|
|
|
368 |
|
|
|
369 |
#
|
|
|
370 |
# Display the duration of the refresh
|
|
|
371 |
# Diagnostic use
|
|
|
372 |
#
|
|
|
373 |
if ($conf->{txdetail}) {
|
|
|
374 |
my $duration = time - $startTime;
|
|
|
375 |
$logger->logmsg("refreshS3Info: Stats: $duration Secs");
|
|
|
376 |
}
|
|
|
377 |
|
|
|
378 |
}
|
|
|
379 |
return $rv;
|
|
|
380 |
}
|
|
|
381 |
|
|
|
382 |
#-------------------------------------------------------------------------------
|
|
|
383 |
# Function : examineS3Bucket
|
|
|
384 |
#
|
|
|
385 |
# Description : Scan the S3 bucket
|
|
|
386 |
# Currently only validates that the bucket exist
|
|
|
387 |
# and that the link is up.
|
|
|
388 |
#
|
|
|
389 |
# Inputs : Nothing
|
|
|
390 |
#
|
|
|
391 |
# Returns : 0 - Gross error ( Bucket access)
|
|
|
392 |
#
|
|
|
393 |
sub examineS3Bucket
|
|
|
394 |
{
|
|
|
395 |
my $bucket;
|
|
|
396 |
my $prefix;
|
|
|
397 |
|
|
|
398 |
if ($conf->{'S3Bucket'} =~ m~(.*?)/(.*)~) {
|
|
|
399 |
$bucket = $1;
|
|
|
400 |
$prefix = $2;
|
|
|
401 |
} else {
|
|
|
402 |
$bucket = $conf->{'S3Bucket'};
|
|
|
403 |
}
|
|
|
404 |
|
|
|
405 |
my $s3_cmd = "aws --profile $conf->{'S3Profile'} --output json";
|
|
|
406 |
$s3_cmd .= " --region $conf->{'S3Region'}" if (defined $conf->{'S3Region'});
|
|
|
407 |
$s3_cmd .= " s3api head-bucket --bucket $bucket";
|
|
|
408 |
|
|
|
409 |
$logger->verbose2("examineS3Bucket:s3_cmd:$s3_cmd");
|
|
|
410 |
|
|
|
411 |
my $ph;
|
|
|
412 |
my $jsontxt = "";
|
|
|
413 |
open ($ph, "$s3_cmd 2>&1 |");
|
|
|
414 |
while ( <$ph> ) {
|
|
|
415 |
chomp;
|
|
|
416 |
$logger->verbose3("examineS3Bucket:Data: $_");
|
|
|
417 |
}
|
|
|
418 |
close ($ph);
|
|
|
419 |
my $cmdRv = $?;
|
|
|
420 |
if ($cmdRv != 0) {
|
|
|
421 |
$logger->warn("Cannot read S3 Bucket Data");
|
|
|
422 |
return 0;
|
|
|
423 |
}
|
|
|
424 |
|
|
|
425 |
#Utils::DebugDumpData("activeReleases",$activeReleases);
|
|
|
426 |
return 1;
|
|
|
427 |
}
|
|
|
428 |
|
|
|
429 |
#-------------------------------------------------------------------------------
|
|
|
430 |
# Function : processPackages
|
|
|
431 |
#
|
|
|
432 |
# Description : Process packages - the bulk of the quarantine effort
|
|
|
433 |
# This is simply time based
|
|
|
434 |
#
|
|
|
435 |
# Inputs : None
|
|
|
436 |
#
|
|
|
437 |
# Returns : Nothing
|
|
|
438 |
#
|
|
|
439 |
sub processPackages
|
|
|
440 |
{
|
|
|
441 |
#
|
|
|
442 |
# Determine if new tags are present by examining the time
|
|
|
443 |
# that the directory was last modified.
|
|
|
444 |
#
|
|
|
445 |
# Allow for a forced scan to catch packages that did not transfer
|
|
|
446 |
# on the first attempt
|
|
|
447 |
#
|
|
|
448 |
if ($now > $nextQScan)
|
|
|
449 |
{
|
|
|
450 |
$logger->verbose2("processPackages");
|
|
|
451 |
$statistics{processLoops}++;
|
|
|
452 |
resetData(1);
|
|
|
453 |
|
|
|
454 |
|
|
|
455 |
my $fileExplain = $conf->{tagdir} . '/explain.txt';
|
|
|
456 |
open ($explainFh, '>', $fileExplain);
|
|
|
457 |
|
|
|
458 |
connectRM(\$RM_DB);
|
|
|
459 |
connectDM(\$DM_DB);
|
|
|
460 |
getReleaseDetails();
|
|
|
461 |
GetAllPackageData();
|
|
|
462 |
getTopLevelPackages();
|
|
|
463 |
GetRecentDMPackages();
|
|
|
464 |
LocateStrays();
|
|
|
465 |
GetSdkPackageData();
|
|
|
466 |
disconnectDM(\$DM_DB);
|
|
|
467 |
disconnectRM(\$RM_DB);
|
|
|
468 |
|
|
|
469 |
DumpInternalData();
|
|
|
470 |
GeneratePvidLookup();
|
|
|
471 |
processDpkgArchive();
|
|
|
472 |
|
|
|
473 |
calcPkgsToQuarantine();
|
|
|
474 |
doQuarantine();
|
|
|
475 |
|
|
|
476 |
# reportMissingPkgs();
|
|
|
477 |
# reportStats();
|
|
|
478 |
close $explainFh;
|
|
|
479 |
resetData(0);
|
|
|
480 |
|
|
|
481 |
#
|
|
|
482 |
# Reset the scan time triggers
|
|
|
483 |
#
|
|
|
484 |
$nextQScan = setQuarantineRunTime(1);
|
|
|
485 |
}
|
|
|
486 |
}
|
|
|
487 |
|
|
|
488 |
#-------------------------------------------------------------------------------
|
|
|
489 |
# Function : getDataFromRm
|
|
|
490 |
#
|
|
|
491 |
# Description : Get an array of data from RM
|
|
|
492 |
# Normally an array of arrays
|
|
|
493 |
#
|
|
|
494 |
# Inputs : $name - Query Name
|
|
|
495 |
# $m_sqlstr - Query
|
|
|
496 |
# $options - Ref to a hash of options
|
|
|
497 |
# sql - show sql
|
|
|
498 |
# data - show data
|
|
|
499 |
# dump - show results
|
|
|
500 |
# oneRow - Only fetch one row
|
|
|
501 |
# error - Must find data
|
|
|
502 |
#
|
|
|
503 |
# Returns : ref to array of data
|
|
|
504 |
#
|
|
|
505 |
sub getDataFromRm
|
|
|
506 |
{
|
|
|
507 |
my ($name,$m_sqlstr, $options ) = @_;
|
|
|
508 |
my @row;
|
|
|
509 |
my $data;
|
|
|
510 |
$RMerror = 0;
|
|
|
511 |
|
|
|
512 |
if (ref $options ne 'HASH') {
|
|
|
513 |
$options = {};
|
|
|
514 |
}
|
|
|
515 |
|
|
|
516 |
if ($options->{sql}) {
|
|
|
517 |
$logger->logmsg("$name: $m_sqlstr")
|
|
|
518 |
}
|
|
|
519 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
520 |
if ( defined($sth) )
|
|
|
521 |
{
|
|
|
522 |
if ( $sth->execute( ) ) {
|
|
|
523 |
if ( $sth->rows ) {
|
|
|
524 |
while ( @row = $sth->fetchrow_array ) {
|
|
|
525 |
if ($options->{data}) {
|
|
|
526 |
$logger->warn ("$name: @row");
|
|
|
527 |
}
|
|
|
528 |
#Debug0("$name: @row");
|
|
|
529 |
push @{$data}, [@row];
|
|
|
530 |
|
|
|
531 |
last if $options->{oneRow};
|
|
|
532 |
}
|
|
|
533 |
}
|
|
|
534 |
$sth->finish();
|
|
|
535 |
} else {
|
|
|
536 |
$logger->warn("Execute failure:$name: $m_sqlstr", $sth->errstr() );
|
|
|
537 |
$RMerror++;
|
|
|
538 |
$statistics{dbErrors}++;
|
|
|
539 |
}
|
|
|
540 |
} else {
|
|
|
541 |
$logger->warn("Prepare failure:$name" );
|
|
|
542 |
$RMerror++;
|
|
|
543 |
$statistics{dbErrors}++;
|
|
|
544 |
}
|
|
|
545 |
|
|
|
546 |
if (!$data && $options->{error}) {
|
|
|
547 |
$logger->warn( $options->{error} );
|
|
|
548 |
}
|
|
|
549 |
|
|
|
550 |
if ($data && $options->{oneRow}) {
|
|
|
551 |
$data = $data->[0];
|
|
|
552 |
}
|
|
|
553 |
|
|
|
554 |
if ($options->{dump}) {
|
|
|
555 |
Utils::DebugDumpData("$name", $data);
|
|
|
556 |
}
|
|
|
557 |
return $data;
|
|
|
558 |
}
|
|
|
559 |
|
|
|
560 |
#-------------------------------------------------------------------------------
|
|
|
561 |
# Function : executeRmQuery
|
|
|
562 |
#
|
|
|
563 |
# Description : Execute a simple RM query. One that does not expect any return data
|
|
|
564 |
# Assume DB connection has been established
|
|
|
565 |
#
|
|
|
566 |
# Inputs : $fname - OprName, for error reporting
|
|
|
567 |
# $m_sqlstr - SQL String
|
|
|
568 |
#
|
|
|
569 |
# Returns : 1 - on Error
|
|
|
570 |
# 0 - All good
|
|
|
571 |
#
|
|
|
572 |
#
|
|
|
573 |
sub executeRmQuery
|
|
|
574 |
{
|
|
|
575 |
my ($fname, $m_sqlstr) = @_;
|
|
|
576 |
|
|
|
577 |
$logger->verbose3('ExecuteQuery:', $fname);
|
|
|
578 |
$RMerror = 0;
|
|
|
579 |
#
|
|
|
580 |
# Create the full SQL statement
|
|
|
581 |
#
|
|
|
582 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
583 |
if ( defined($sth) )
|
|
|
584 |
{
|
|
|
585 |
if ( $sth->execute() )
|
|
|
586 |
{
|
|
|
587 |
$sth->finish();
|
|
|
588 |
}
|
|
|
589 |
else
|
|
|
590 |
{
|
|
|
591 |
$logger->warn("$fname: Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
592 |
$RMerror++;
|
|
|
593 |
$statistics{dbErrors}++;
|
|
|
594 |
return 1;
|
|
|
595 |
}
|
|
|
596 |
}
|
|
|
597 |
else
|
|
|
598 |
{
|
|
|
599 |
$logger->warn("$fname: Prepare failure");
|
|
|
600 |
$RMerror++;
|
|
|
601 |
$statistics{dbErrors}++;
|
|
|
602 |
return 1;
|
|
|
603 |
}
|
|
|
604 |
|
|
|
605 |
return 0;
|
|
|
606 |
}
|
|
|
607 |
|
|
|
608 |
#-------------------------------------------------------------------------------
|
|
|
609 |
# Function : maintainTagList
|
|
|
610 |
#
|
|
|
611 |
# Description : Maintain a data structure for the maintenance of the
|
|
|
612 |
# tags directory
|
|
|
613 |
#
|
|
|
614 |
# Inputs : None
|
|
|
615 |
#
|
|
|
616 |
# Returns : Nothing
|
|
|
617 |
#
|
|
|
618 |
sub maintainTagList
|
|
|
619 |
{
|
|
|
620 |
#
|
|
|
621 |
# Time to perform the scan
|
|
|
622 |
# Will do at startup and every time period there after
|
|
|
623 |
#
|
|
|
624 |
return unless ( $now > ($lastTagListUpdate + $conf->{tagListUpdate} ));
|
|
|
625 |
$logger->verbose("maintainTagList");
|
|
|
626 |
$lastTagListUpdate = $now;
|
|
|
627 |
|
|
|
628 |
#
|
|
|
629 |
# Generate new configuration
|
|
|
630 |
#
|
|
|
631 |
my %config;
|
|
|
632 |
$config{s3Manifest} = 1; # Indicate that it may be special
|
|
|
633 |
|
|
|
634 |
%{$config{releases}} = map { $_ => 1 } keys %{$activeReleases};
|
|
|
635 |
|
|
|
636 |
#
|
|
|
637 |
# Save data
|
|
|
638 |
#
|
|
|
639 |
my $dump = Data::Dumper->new([\%config], [qw(*config)]);
|
|
|
640 |
#print $dump->Dump;
|
|
|
641 |
#$dump->Reset;
|
|
|
642 |
|
|
|
643 |
#
|
|
|
644 |
# Save config data
|
|
|
645 |
#
|
|
|
646 |
my $conf_file = catfile( $conf->{'tagdir'},'.config' );
|
|
|
647 |
$logger->verbose3("maintainTagList: Writting $conf_file");
|
|
|
648 |
|
|
|
649 |
my $fh;
|
|
|
650 |
open ( $fh, '>', $conf_file ) or $logger->err("Can't create $conf_file: $!");
|
|
|
651 |
print $fh $dump->Dump;
|
|
|
652 |
close $fh;
|
|
|
653 |
}
|
|
|
654 |
|
|
|
655 |
#-------------------------------------------------------------------------------
|
|
|
656 |
# Function : resetDailyStatistics
|
|
|
657 |
#
|
|
|
658 |
# Description : Called periodically to reset the daily statistics
|
|
|
659 |
#
|
|
|
660 |
# Inputs : $time - Current time
|
|
|
661 |
#
|
|
|
662 |
# Returns :
|
|
|
663 |
#
|
|
|
664 |
sub resetDailyStatistics
|
|
|
665 |
{
|
|
|
666 |
my ($time) = @_;
|
|
|
667 |
|
|
|
668 |
#
|
|
|
669 |
# Detect a new day
|
|
|
670 |
#
|
|
|
671 |
my $today = (localtime($time))[7];
|
|
|
672 |
if ($yday != $today)
|
|
|
673 |
{
|
|
|
674 |
$yday = $today;
|
|
|
675 |
$logger->logmsg('Resetting daily statistics' );
|
|
|
676 |
|
|
|
677 |
# Note: Must match @recoverTags in readStatistics
|
|
|
678 |
$statistics{dayStart} = $time;
|
|
|
679 |
$statistics{linkErrors} = 0;
|
|
|
680 |
$statistics{dbErrors} = 0;
|
|
|
681 |
$statistics{processLoops} = 0;
|
| 7544 |
dpurdie |
682 |
$statistics{QuarantineCount} = 0;
|
|
|
683 |
$statistics{QuarantineTxRequested} = 0;
|
|
|
684 |
$statistics{QuarantineError} = 0;
|
| 7539 |
dpurdie |
685 |
}
|
|
|
686 |
}
|
|
|
687 |
|
|
|
688 |
#-------------------------------------------------------------------------------
|
|
|
689 |
# Function : readStatistics
|
|
|
690 |
#
|
|
|
691 |
# Description : Read in the last set of stats
|
|
|
692 |
# Used after a restart to recover daily statistics
|
|
|
693 |
#
|
|
|
694 |
# Inputs :
|
|
|
695 |
#
|
|
|
696 |
# Returns :
|
|
|
697 |
#
|
|
|
698 |
sub readStatistics
|
|
|
699 |
{
|
| 7544 |
dpurdie |
700 |
my @recoverTags = qw(dayStart linkErrors dbErrors processLoops QuarantineCount QuarantineTxRequested QuarantineError);
|
| 7539 |
dpurdie |
701 |
|
|
|
702 |
if ($conf->{'statsfile'} and -f $conf->{'statsfile'})
|
|
|
703 |
{
|
|
|
704 |
if (open my $fh, $conf->{'statsfile'})
|
|
|
705 |
{
|
|
|
706 |
while (<$fh>)
|
|
|
707 |
{
|
|
|
708 |
m~(.*):(.*)~;
|
|
|
709 |
if ( grep( /^$1$/, @recoverTags ) )
|
|
|
710 |
{
|
|
|
711 |
$statistics{$1} = $2;
|
|
|
712 |
$logger->verbose("readStatistics $1, $2");
|
|
|
713 |
}
|
|
|
714 |
}
|
|
|
715 |
close $fh;
|
|
|
716 |
$yday = (localtime($statistics{dayStart}))[7];
|
|
|
717 |
}
|
|
|
718 |
}
|
|
|
719 |
}
|
|
|
720 |
|
|
|
721 |
|
|
|
722 |
#-------------------------------------------------------------------------------
|
|
|
723 |
# Function : periodicStatistics
|
|
|
724 |
#
|
|
|
725 |
# Description : Called on a regular basis to write out statistics
|
|
|
726 |
# Used to feed information into Nagios
|
|
|
727 |
#
|
|
|
728 |
# This function is called via an alarm and may be outside the normal
|
|
|
729 |
# processing loop. Don't make assumptions on the value of $now
|
|
|
730 |
#
|
|
|
731 |
# Inputs :
|
|
|
732 |
#
|
|
|
733 |
# Returns :
|
|
|
734 |
#
|
|
|
735 |
sub periodicStatistics
|
|
|
736 |
{
|
|
|
737 |
#
|
|
|
738 |
# A few local stats
|
|
|
739 |
#
|
|
|
740 |
$statistics{SeqNum}++;
|
|
|
741 |
$statistics{timeStamp} = time();
|
|
|
742 |
$statistics{upTime} = $statistics{timeStamp} - $startTime;
|
|
|
743 |
$statistics{wedged} = Utils::isWedged($conf);
|
|
|
744 |
|
|
|
745 |
if ( $statistics{wedged}) {
|
|
|
746 |
$statistics{state} = 'Wedged';
|
|
|
747 |
} elsif(!$dbUp){
|
|
|
748 |
$statistics{state} = 'RM Access error';
|
|
|
749 |
} elsif(!$linkUp){
|
|
|
750 |
$statistics{state} = 'S3 Bucket Read Error';
|
| 7544 |
dpurdie |
751 |
} elsif($statistics{QuarantineError}){
|
|
|
752 |
$statistics{state} = 'Error quarantining a package';
|
| 7539 |
dpurdie |
753 |
} else {
|
|
|
754 |
$statistics{state} = 'OK';
|
|
|
755 |
}
|
|
|
756 |
|
|
|
757 |
|
|
|
758 |
# Reset daily accumulations - on first use each day
|
|
|
759 |
resetDailyStatistics($statistics{timeStamp});
|
|
|
760 |
|
|
|
761 |
#
|
|
|
762 |
# Write statistics to a file
|
|
|
763 |
# Write to a tmp file, then rename.
|
|
|
764 |
# Attempt to make the operation atomic - so that the file consumer
|
|
|
765 |
# doesn't get a badly formed file.
|
|
|
766 |
#
|
|
|
767 |
if ($conf->{'statsfiletmp'})
|
|
|
768 |
{
|
|
|
769 |
my $fh;
|
|
|
770 |
unless (open ($fh, '>', $conf->{'statsfiletmp'}))
|
|
|
771 |
{
|
|
|
772 |
$fh = undef;
|
|
|
773 |
$logger->warn("Cannot create temp stats file: $!");
|
|
|
774 |
}
|
|
|
775 |
else
|
|
|
776 |
{
|
|
|
777 |
foreach my $key ( sort { lc($a) cmp lc($b) } keys %statistics)
|
|
|
778 |
{
|
|
|
779 |
print $fh $key . ':' . $statistics{$key} . "\n";
|
|
|
780 |
$logger->verbose2('Statistics:'. $key . ':' . $statistics{$key});
|
|
|
781 |
}
|
|
|
782 |
|
|
|
783 |
#
|
|
|
784 |
# Also dump the stats related to the current (last)
|
|
|
785 |
#
|
|
|
786 |
foreach my $key ( sort { lc($a) cmp lc($b) } keys %qStats)
|
|
|
787 |
{
|
| 7544 |
dpurdie |
788 |
my $txt = 'Qstats' . $key . ':' . $qStats{$key};
|
| 7539 |
dpurdie |
789 |
print $fh $txt . "\n";
|
|
|
790 |
$logger->verbose2('Statistics:'. $txt);
|
|
|
791 |
}
|
|
|
792 |
#
|
|
|
793 |
|
|
|
794 |
close $fh;
|
|
|
795 |
|
|
|
796 |
# Rename temp to real file
|
|
|
797 |
rename $conf->{'statsfiletmp'}, $conf->{'statsfile'} ;
|
|
|
798 |
}
|
|
|
799 |
}
|
|
|
800 |
}
|
|
|
801 |
|
|
|
802 |
#-------------------------------------------------------------------------------
|
|
|
803 |
# Function : sighandlers
|
|
|
804 |
#
|
|
|
805 |
# Description : Install signal handlers
|
|
|
806 |
#
|
|
|
807 |
# Inputs : Uses gobals
|
|
|
808 |
#
|
|
|
809 |
# Returns : Nothing
|
|
|
810 |
#
|
|
|
811 |
sub sighandlers
|
|
|
812 |
{
|
|
|
813 |
$SIG{TERM} = sub {
|
|
|
814 |
# On shutdown
|
|
|
815 |
$logger->logmsg('Received SIGTERM. Shutting down....' );
|
|
|
816 |
unlink $conf->{'pidfile'} if (-f $conf->{'pidfile'});
|
|
|
817 |
exit 0;
|
|
|
818 |
};
|
|
|
819 |
|
|
|
820 |
$SIG{HUP} = sub {
|
|
|
821 |
# On logrotate
|
|
|
822 |
$logger->logmsg('Received SIGHUP.');
|
|
|
823 |
$logger->rotatelog();
|
|
|
824 |
};
|
|
|
825 |
|
|
|
826 |
$SIG{USR1} = sub {
|
|
|
827 |
# On Force Rescans
|
|
|
828 |
$logger->logmsg('Received SIGUSR1.');
|
|
|
829 |
$lastTagListUpdate = 0;
|
|
|
830 |
$lastS3Refresh = 0;
|
|
|
831 |
$nextQScan = 0;
|
|
|
832 |
};
|
|
|
833 |
|
|
|
834 |
alarm 60;
|
|
|
835 |
$SIG{ALRM} = sub {
|
|
|
836 |
# On Dump Statistics
|
|
|
837 |
$logger->verbose2('Received SIGUSR2.');
|
|
|
838 |
periodicStatistics();
|
|
|
839 |
alarm 60;
|
|
|
840 |
};
|
|
|
841 |
|
|
|
842 |
$SIG{__WARN__} = sub { $logger->warn("@_") };
|
|
|
843 |
$SIG{__DIE__} = sub { $logger->err("@_") };
|
|
|
844 |
}
|
|
|
845 |
|
|
|
846 |
|
|
|
847 |
#-------------------------------------------------------------------------------
|
|
|
848 |
# Function : Error, Verbose, Warning
|
|
|
849 |
#
|
|
|
850 |
# Description : Support for JatsRmApi
|
|
|
851 |
#
|
|
|
852 |
# Inputs : Message
|
|
|
853 |
#
|
|
|
854 |
# Returns : Nothing
|
|
|
855 |
#
|
|
|
856 |
sub Error
|
|
|
857 |
{
|
|
|
858 |
$logger->err("@_");
|
|
|
859 |
}
|
|
|
860 |
|
|
|
861 |
sub Verbose
|
|
|
862 |
{
|
|
|
863 |
$logger->verbose2("@_");
|
|
|
864 |
}
|
|
|
865 |
|
|
|
866 |
sub Warning
|
|
|
867 |
{
|
|
|
868 |
$logger->warn("@_");
|
|
|
869 |
}
|
|
|
870 |
|
|
|
871 |
###############################################################################
|
|
|
872 |
#
|
|
|
873 |
# Quarintine specific bits
|
|
|
874 |
#
|
|
|
875 |
my @quarantineItems;
|
|
|
876 |
my @StrayPackages;
|
|
|
877 |
|
|
|
878 |
our %Releases;
|
|
|
879 |
our %Packages;
|
|
|
880 |
my %pkgPvid;
|
|
|
881 |
|
|
|
882 |
#-------------------------------------------------------------------------------
|
|
|
883 |
# Function : resetData
|
|
|
884 |
#
|
|
|
885 |
# Description : Delete all the collected data so that we can run the process
|
|
|
886 |
# again
|
|
|
887 |
#
|
|
|
888 |
# Inputs : mode - true. Reset quarantine stats too
|
|
|
889 |
#
|
|
|
890 |
# Returns :
|
|
|
891 |
#
|
|
|
892 |
sub resetData
|
|
|
893 |
{
|
|
|
894 |
my ($mode) = @_;
|
|
|
895 |
|
|
|
896 |
@quarantineItems = ();
|
|
|
897 |
@StrayPackages = ();
|
|
|
898 |
%Releases = ();
|
|
|
899 |
%Packages = ();
|
|
|
900 |
%pkgPvid = ();
|
|
|
901 |
|
|
|
902 |
if ($mode) {
|
|
|
903 |
# Reset Stats for this run
|
|
|
904 |
foreach my $key ( keys %qStats ) {
|
|
|
905 |
$qStats{$key} = 0;
|
|
|
906 |
}
|
|
|
907 |
}
|
|
|
908 |
}
|
|
|
909 |
|
|
|
910 |
#-------------------------------------------------------------------------------
|
|
|
911 |
# Function : setQuarantineRunTime
|
|
|
912 |
#
|
|
|
913 |
# Description : Set the runtime for the next run of the quarantine process
|
|
|
914 |
# Can configure the time at which the process will run
|
|
|
915 |
# In this mode it will run once a day at the specified time
|
|
|
916 |
#
|
|
|
917 |
# Inputs : $mode : True: Calc next time
|
|
|
918 |
#
|
|
|
919 |
# From conf.
|
|
|
920 |
# runTime - Time past midnight to run the process
|
|
|
921 |
# forcedirscan - Delay to next run
|
|
|
922 |
#
|
|
|
923 |
#
|
|
|
924 |
# Returns : Next time to run the quarantine
|
|
|
925 |
#
|
|
|
926 |
sub setQuarantineRunTime
|
|
|
927 |
{
|
|
|
928 |
my ($mode) = @_;
|
|
|
929 |
my $nextRunTime;
|
|
|
930 |
if (defined $conf->{runTime}) {
|
|
|
931 |
#
|
|
|
932 |
# Calc midnight
|
|
|
933 |
#
|
|
|
934 |
my @time = localtime();
|
|
|
935 |
my $secsSinceMidnight = ($time[2] * 3600) + ($time[1] * 60) + $time[0];
|
|
|
936 |
my $midnight = time() - $secsSinceMidnight;
|
|
|
937 |
if ($mode) {
|
|
|
938 |
$midnight += 24*60*60;
|
|
|
939 |
}
|
|
|
940 |
|
|
|
941 |
#
|
|
|
942 |
# Calc next run time
|
|
|
943 |
#
|
|
|
944 |
$nextRunTime = $midnight + $conf->{runTime};
|
|
|
945 |
} else {
|
|
|
946 |
$nextRunTime = time() + $conf->{forcedirscan};
|
|
|
947 |
}
|
|
|
948 |
$logger->verbose("setQuarantineRunTime: $nextRunTime, (" . localtime($nextRunTime) . ")");
|
|
|
949 |
return $nextRunTime;
|
|
|
950 |
}
|
|
|
951 |
|
|
|
952 |
|
|
|
953 |
#-------------------------------------------------------------------------------
|
|
|
954 |
# Function : getReleaseDetails
|
|
|
955 |
#
|
|
|
956 |
# Description : Determine all candiate releases
|
|
|
957 |
# Assume connected to database
|
|
|
958 |
#
|
|
|
959 |
# Inputs :
|
|
|
960 |
#
|
|
|
961 |
# Returns :
|
|
|
962 |
#
|
|
|
963 |
sub getReleaseDetails
|
|
|
964 |
{
|
|
|
965 |
my (@row);
|
|
|
966 |
|
|
|
967 |
$logger->verbose("Determine all Release Names");
|
|
|
968 |
|
|
|
969 |
# Get all Releases
|
|
|
970 |
# From non-archived releases
|
|
|
971 |
my $m_sqlstr = "SELECT prj.PROJ_NAME, rt.RTAG_NAME, rt.PROJ_ID, rt.RTAG_ID, rt.official, TRUNC (SYSDATE - rt.official_stamp) as OFFICIAL_STAMP_DAYS, TRUNC (SYSDATE - rt.created_stamp) as CREATED_STAMP_DAYS" .
|
|
|
972 |
" FROM release_manager.release_tags rt, release_manager.projects prj" .
|
|
|
973 |
" WHERE prj.PROJ_ID = rt.PROJ_ID " .
|
|
|
974 |
" AND rt.official != 'A' ORDER BY UPPER(prj.PROJ_NAME), UPPER(rt.RTAG_NAME)";
|
|
|
975 |
# " AND rt.official != 'Y'" .
|
|
|
976 |
|
|
|
977 |
$logger->verbose2("getReleaseDetails: $m_sqlstr");
|
|
|
978 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
979 |
if ( defined($sth) )
|
|
|
980 |
{
|
|
|
981 |
if ( $sth->execute( ) )
|
|
|
982 |
{
|
|
|
983 |
if ( $sth->rows )
|
|
|
984 |
{
|
|
|
985 |
while ( @row = $sth->fetchrow_array )
|
|
|
986 |
{
|
|
|
987 |
my $rtag_id =$row[3];
|
|
|
988 |
my $proj_id = $row[2];
|
|
|
989 |
my $official = $row[4];
|
|
|
990 |
my $age = defined($row[5]) ? $row[5] : $row[6];
|
|
|
991 |
|
|
|
992 |
# Only retain recent snapshot
|
|
|
993 |
if ($official eq 'S' && $age > $conf->{snapAge}) {
|
|
|
994 |
next;
|
|
|
995 |
}
|
|
|
996 |
|
|
|
997 |
#if ( $official eq 'Y' ) {
|
|
|
998 |
# Information("Closed Age ($proj_id) : $age : $row[0], $row[1]");
|
|
|
999 |
#}
|
|
|
1000 |
# if ( $official eq 'Y' && $age && $age > 300 )
|
|
|
1001 |
# {
|
|
|
1002 |
# next;
|
|
|
1003 |
# }
|
|
|
1004 |
|
|
|
1005 |
$Releases{$rtag_id}{pName} = $row[0];
|
|
|
1006 |
$Releases{$rtag_id}{name} = $row[1];
|
|
|
1007 |
$Releases{$rtag_id}{proj_id} = $proj_id;
|
|
|
1008 |
$Releases{$rtag_id}{rtag_id} = $rtag_id;
|
|
|
1009 |
$Releases{$rtag_id}{official} = $row[4];
|
|
|
1010 |
$Releases{$rtag_id}{officialDays} = defined($row[5]) ? $row[5] : $row[6] ;
|
|
|
1011 |
$Releases{$rtag_id}{createdDays} = $row[6];
|
|
|
1012 |
|
|
|
1013 |
#print join (',',@row), "\n" if ($opt_verbose > 2);
|
|
|
1014 |
}
|
|
|
1015 |
}
|
|
|
1016 |
$sth->finish();
|
|
|
1017 |
}
|
|
|
1018 |
else
|
|
|
1019 |
{
|
|
|
1020 |
$logger->warn("getReleaseDetails:Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
1021 |
}
|
|
|
1022 |
}
|
|
|
1023 |
else
|
|
|
1024 |
{
|
|
|
1025 |
$logger->warn("getReleaseDetails:Prepare failure" );
|
|
|
1026 |
}
|
|
|
1027 |
|
|
|
1028 |
$qStats{ReleaseCount} = scalar keys %Releases;
|
|
|
1029 |
}
|
|
|
1030 |
|
|
|
1031 |
#-------------------------------------------------------------------------------
|
|
|
1032 |
# Function : GetAllPackageData
|
|
|
1033 |
#
|
|
|
1034 |
# Description : Extract all package data
|
|
|
1035 |
#
|
|
|
1036 |
# Inputs :
|
|
|
1037 |
#
|
|
|
1038 |
# Returns :
|
|
|
1039 |
#
|
|
|
1040 |
|
|
|
1041 |
sub GetAllPackageData
|
|
|
1042 |
{
|
|
|
1043 |
my (@row);
|
|
|
1044 |
my $count = 0;
|
|
|
1045 |
|
|
|
1046 |
$logger->verbose ("Extract all package data");
|
|
|
1047 |
|
|
|
1048 |
# First get all packages
|
|
|
1049 |
# From non-archived releases
|
|
|
1050 |
|
|
|
1051 |
my $m_sqlstr = "SELECT DISTINCT " .
|
|
|
1052 |
"pv.PV_ID, " . #[0]
|
|
|
1053 |
"pkg.PKG_NAME, " . #[1]
|
|
|
1054 |
"pv.PKG_VERSION, " . #[2]
|
|
|
1055 |
"pv.DLOCKED, " . #[3]
|
|
|
1056 |
"pv.PKG_ID," . #[4]
|
|
|
1057 |
"pv.is_patch," . #[5]
|
|
|
1058 |
"pv.build_type,". #[6]
|
|
|
1059 |
"pbi.bsa_id," . #[7]
|
|
|
1060 |
# "pv.CREATOR_ID, " . #[8]
|
|
|
1061 |
# "pv.MODIFIED_STAMP, " . #[9]
|
|
|
1062 |
# "release_manager.PK_RMAPI.return_vcs_tag(pv.PV_ID), " . #[10]
|
|
|
1063 |
"999" .
|
|
|
1064 |
" FROM RELEASE_MANAGER.PACKAGE_VERSIONS pv,".
|
|
|
1065 |
"RELEASE_MANAGER.PACKAGES pkg,".
|
|
|
1066 |
"release_manager.package_build_info pbi" .
|
|
|
1067 |
" WHERE pv.PKG_ID = pkg.PKG_ID" .
|
|
|
1068 |
" AND pv.pv_id = pbi.pv_id(+)";
|
|
|
1069 |
|
|
|
1070 |
$logger->verbose2("GetAllPackageData: $m_sqlstr");
|
|
|
1071 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
1072 |
if ( defined($sth) )
|
|
|
1073 |
{
|
|
|
1074 |
if ( $sth->execute( ) )
|
|
|
1075 |
{
|
|
|
1076 |
if ( $sth->rows )
|
|
|
1077 |
{
|
|
|
1078 |
while ( @row = $sth->fetchrow_array )
|
|
|
1079 |
{
|
|
|
1080 |
$count++;
|
|
|
1081 |
#print join (',',@row), "\n" if ($opt_verbose > 2);
|
|
|
1082 |
my $pvid = $row[0];
|
|
|
1083 |
unless ( exists $Packages{$pvid}{name} )
|
|
|
1084 |
{
|
|
|
1085 |
$Packages{$pvid}{name} = $row[1];
|
|
|
1086 |
$Packages{$pvid}{version} = $row[2];
|
|
|
1087 |
$Packages{$pvid}{locked} = $row[3];
|
|
|
1088 |
$Packages{$pvid}{pkgid} = $row[4];
|
|
|
1089 |
$Packages{$pvid}{isPatch} = $row[5] || 0;
|
|
|
1090 |
$Packages{$pvid}{buildType} = $row[6] || 0;
|
|
|
1091 |
$Packages{$pvid}{buildStandard} = $row[7] || 0;
|
|
|
1092 |
|
|
|
1093 |
#$Packages{$pvid}{Creator} = $row[8];
|
|
|
1094 |
#$Packages{$pvid}{Age} = $row[9];
|
|
|
1095 |
#$Packages{$pvid}{vcstag} = $row[10];
|
|
|
1096 |
|
|
|
1097 |
}
|
|
|
1098 |
}
|
|
|
1099 |
}
|
|
|
1100 |
$sth->finish();
|
|
|
1101 |
}
|
|
|
1102 |
else
|
|
|
1103 |
{
|
|
|
1104 |
$logger->warn("GetAllPackageData:Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
1105 |
}
|
|
|
1106 |
}
|
|
|
1107 |
else
|
|
|
1108 |
{
|
|
|
1109 |
$logger->warn("GetAllPackageData:Prepare failure" );
|
|
|
1110 |
}
|
|
|
1111 |
|
|
|
1112 |
$logger->verbose ("All Packages: $count rows");
|
|
|
1113 |
$qStats{RmPackageCount} = $count;
|
|
|
1114 |
}
|
|
|
1115 |
|
|
|
1116 |
#-------------------------------------------------------------------------------
|
|
|
1117 |
# Function : getTopLevelPackages
|
|
|
1118 |
#
|
|
|
1119 |
# Description : Extract top level packages from active releases
|
|
|
1120 |
#
|
|
|
1121 |
# Inputs :
|
|
|
1122 |
#
|
|
|
1123 |
# Returns :
|
|
|
1124 |
#
|
|
|
1125 |
|
|
|
1126 |
sub getTopLevelPackages
|
|
|
1127 |
{
|
|
|
1128 |
my (@row);
|
|
|
1129 |
my $count = 0;
|
|
|
1130 |
|
|
|
1131 |
$logger->verbose ("Extract toplevel dependencies");
|
|
|
1132 |
|
|
|
1133 |
# First get all packages that are referenced in a Release
|
|
|
1134 |
# This will only get the top level packages
|
|
|
1135 |
# From non-archived releases
|
|
|
1136 |
|
|
|
1137 |
my $m_sqlstr = "SELECT DISTINCT " .
|
|
|
1138 |
"rc.PV_ID, " . #[0]
|
|
|
1139 |
"rt.RTAG_ID, " . #[1]
|
|
|
1140 |
"prj.PROJ_ID, " . #[2]
|
|
|
1141 |
"rt.official, " . #[3]
|
|
|
1142 |
"TRUNC (SYSDATE - rt.official_stamp),". #[4]
|
|
|
1143 |
"TRUNC (SYSDATE - rt.created_stamp)" . #[5]
|
|
|
1144 |
" FROM RELEASE_MANAGER.RELEASE_CONTENT rc, ".
|
|
|
1145 |
"release_manager.release_tags rt,".
|
|
|
1146 |
"release_manager.projects prj" .
|
|
|
1147 |
" WHERE prj.PROJ_ID = rt.PROJ_ID" .
|
|
|
1148 |
" and rt.RTAG_ID = rc.RTAG_ID" .
|
|
|
1149 |
" AND rt.official != 'A'";
|
|
|
1150 |
|
|
|
1151 |
$logger->verbose2("getTopLevelPackages: $m_sqlstr");
|
|
|
1152 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
1153 |
if ( defined($sth) )
|
|
|
1154 |
{
|
|
|
1155 |
if ( $sth->execute( ) )
|
|
|
1156 |
{
|
|
|
1157 |
if ( $sth->rows )
|
|
|
1158 |
{
|
|
|
1159 |
while ( @row = $sth->fetchrow_array )
|
|
|
1160 |
{
|
|
|
1161 |
my $pvid = $row[0];
|
|
|
1162 |
my $rtag_id = $row[1];
|
|
|
1163 |
my $proj_id = $row[2];
|
|
|
1164 |
my $official = $row[3];
|
|
|
1165 |
my $age = defined($row[4]) ? $row[4] : $row[6];
|
|
|
1166 |
|
|
|
1167 |
# Only retain recent snapshot
|
|
|
1168 |
if ($official eq 'S' && $age > $conf->{snapAge}) {
|
|
|
1169 |
next;
|
|
|
1170 |
}
|
|
|
1171 |
|
|
|
1172 |
$count++;
|
|
|
1173 |
$Packages{$pvid}{tlp} = 1;
|
|
|
1174 |
push @StrayPackages, $pvid;
|
|
|
1175 |
|
|
|
1176 |
push @{$Packages{$pvid}{release}}, $rtag_id;
|
|
|
1177 |
|
|
|
1178 |
push @{$Packages{$pvid}{projects}}, $proj_id
|
|
|
1179 |
unless (grep {$_ eq $proj_id} @{$Packages{$pvid}{projects}});
|
|
|
1180 |
|
|
|
1181 |
}
|
|
|
1182 |
}
|
|
|
1183 |
$sth->finish();
|
|
|
1184 |
}
|
|
|
1185 |
else
|
|
|
1186 |
{
|
|
|
1187 |
$logger->warn("getTopLevelPackages:Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
1188 |
}
|
|
|
1189 |
}
|
|
|
1190 |
else
|
|
|
1191 |
{
|
|
|
1192 |
$logger->warn("getTopLevelPackages:Prepare failure" );
|
|
|
1193 |
}
|
|
|
1194 |
|
|
|
1195 |
$logger->verbose ("Extract toplevel dependencies: $count rows");
|
| 7544 |
dpurdie |
1196 |
$qStats{TopLevelCount} = $count;
|
| 7539 |
dpurdie |
1197 |
}
|
|
|
1198 |
|
|
|
1199 |
#-------------------------------------------------------------------------------
|
|
|
1200 |
# Function : GetRecentDMPackages
|
|
|
1201 |
#
|
|
|
1202 |
# Description : Extract Packages that referenced in Deployment Manager
|
|
|
1203 |
# Want all package-versions from the last two BOMS in each state
|
|
|
1204 |
# of all projects.
|
|
|
1205 |
#
|
|
|
1206 |
# Inputs :
|
|
|
1207 |
#
|
|
|
1208 |
# Returns :
|
|
|
1209 |
#
|
|
|
1210 |
|
|
|
1211 |
sub GetRecentDMPackages
|
|
|
1212 |
{
|
|
|
1213 |
my (@row);
|
|
|
1214 |
my $count = 0;
|
|
|
1215 |
|
|
|
1216 |
$logger->verbose ("Extract DM Packages");
|
|
|
1217 |
|
|
|
1218 |
# Get all packages that are a part of a non-deprecated SDK
|
|
|
1219 |
# Only get the 'exposed' packages
|
|
|
1220 |
|
|
|
1221 |
my $m_sqlstr =
|
|
|
1222 |
"SELECT DISTINCT pv.pv_id," . #[0]
|
|
|
1223 |
" pkg.pkg_name," . #[1]
|
|
|
1224 |
" pv.pkg_version" . #[2]
|
|
|
1225 |
" FROM DEPLOYMENT_MANAGER.bom_contents bc," .
|
|
|
1226 |
" DEPLOYMENT_MANAGER.operating_systems os," .
|
|
|
1227 |
" DEPLOYMENT_MANAGER.os_contents osc," .
|
|
|
1228 |
" DEPLOYMENT_MANAGER.PACKAGES pkg," .
|
|
|
1229 |
" DEPLOYMENT_MANAGER.PACKAGE_VERSIONS pv," .
|
|
|
1230 |
" DEPLOYMENT_MANAGER.PRODUCT_DETAILS pd" .
|
|
|
1231 |
" WHERE osc.os_id = os.os_id" .
|
|
|
1232 |
" AND os.node_id = bc.node_id" .
|
|
|
1233 |
" AND bc.bom_id IN" .
|
|
|
1234 |
" (SELECT bom_id" .
|
|
|
1235 |
" FROM" .
|
|
|
1236 |
" (SELECT bs.bom_id, b.branch_id, state_id, bn.bom_name ," .
|
|
|
1237 |
" RANK() OVER (PARTITION BY bs.state_id,b.branch_id, bn.bom_name ORDER BY bs.bom_id DESC) SRLNO" .
|
|
|
1238 |
" FROM DEPLOYMENT_MANAGER.bom_state bs ," .
|
|
|
1239 |
" DEPLOYMENT_MANAGER.boms b," .
|
|
|
1240 |
" DEPLOYMENT_MANAGER.bom_names bn" .
|
|
|
1241 |
" WHERE bs.bom_id = b.bom_id" .
|
|
|
1242 |
" AND b.BOM_NAME_ID = bn.BOM_NAME_ID" .
|
|
|
1243 |
" )" .
|
|
|
1244 |
" WHERE SRLNO <= 3" .
|
|
|
1245 |
" )" .
|
|
|
1246 |
" AND pd.PROD_ID (+) = osc.PROD_ID" .
|
|
|
1247 |
" AND pv.pkg_id = pkg.pkg_id" .
|
|
|
1248 |
" AND osc.prod_id = pv.pv_id" .
|
|
|
1249 |
" ORDER BY UPPER(pkg.pkg_name), " .
|
|
|
1250 |
" UPPER(pv.PKG_VERSION)";
|
|
|
1251 |
|
|
|
1252 |
$logger->verbose2("GetRecentDMPackages: $m_sqlstr");
|
|
|
1253 |
my $sth = $DM_DB->prepare($m_sqlstr);
|
|
|
1254 |
if ( defined($sth) )
|
|
|
1255 |
{
|
|
|
1256 |
if ( $sth->execute( ) )
|
|
|
1257 |
{
|
|
|
1258 |
if ( $sth->rows )
|
|
|
1259 |
{
|
|
|
1260 |
while ( @row = $sth->fetchrow_array )
|
|
|
1261 |
{
|
|
|
1262 |
$count++;
|
|
|
1263 |
#print join (',',@row), "\n" if ($opt_verbose > 2);
|
|
|
1264 |
my $pvid = $row[0];
|
|
|
1265 |
$Packages{$pvid}{dm} = 1;
|
|
|
1266 |
unless ( exists $Packages{$pvid}{name} )
|
|
|
1267 |
{
|
|
|
1268 |
$Packages{$pvid}{name} = $row[1];
|
|
|
1269 |
$Packages{$pvid}{version} = $row[2];
|
|
|
1270 |
}
|
|
|
1271 |
push @StrayPackages, $pvid;
|
|
|
1272 |
}
|
|
|
1273 |
}
|
|
|
1274 |
$sth->finish();
|
|
|
1275 |
}
|
|
|
1276 |
else
|
|
|
1277 |
{
|
|
|
1278 |
$logger->warn("GetRecentDMPackages:Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
1279 |
}
|
|
|
1280 |
}
|
|
|
1281 |
else
|
|
|
1282 |
{
|
|
|
1283 |
$logger->warn("GetRecentDMPackages:Prepare failure" );
|
|
|
1284 |
}
|
|
|
1285 |
|
|
|
1286 |
$logger->verbose ("Extract Deployed Packages: $count rows");
|
| 7544 |
dpurdie |
1287 |
$qStats{DmPackageCount} = $count;
|
| 7539 |
dpurdie |
1288 |
}
|
|
|
1289 |
|
|
|
1290 |
#-------------------------------------------------------------------------------
|
|
|
1291 |
# Function : LocateStrays
|
|
|
1292 |
#
|
|
|
1293 |
# Description : Locate stray packages
|
|
|
1294 |
# Try to do several (200) at a time to speed up processing
|
|
|
1295 |
#
|
|
|
1296 |
# Inputs :
|
|
|
1297 |
#
|
|
|
1298 |
# Returns :
|
|
|
1299 |
#
|
|
|
1300 |
sub LocateStrays
|
|
|
1301 |
{
|
|
|
1302 |
$logger->verbose ("Locate indirectly referenced packages");
|
|
|
1303 |
my $count = 0;
|
|
|
1304 |
while ( $#StrayPackages >= 0 )
|
|
|
1305 |
{
|
|
|
1306 |
$logger->verbose3 ("Strays Remaining: " . scalar @StrayPackages );
|
|
|
1307 |
|
|
|
1308 |
my @plist;
|
|
|
1309 |
while ( $#plist <= 200 && @StrayPackages )
|
|
|
1310 |
{
|
|
|
1311 |
my $pv_id = pop @StrayPackages;
|
|
|
1312 |
next if ( exists $Packages{$pv_id}{done} );
|
|
|
1313 |
push @plist, $pv_id;
|
|
|
1314 |
}
|
|
|
1315 |
|
|
|
1316 |
GetDepends(@plist) if @plist;
|
|
|
1317 |
|
|
|
1318 |
foreach ( @plist)
|
|
|
1319 |
{
|
|
|
1320 |
$Packages{$_}{done} = 1;
|
|
|
1321 |
$count++;
|
|
|
1322 |
}
|
|
|
1323 |
}
|
|
|
1324 |
|
|
|
1325 |
$qStats{StrayCount} = $count;
|
|
|
1326 |
}
|
|
|
1327 |
|
|
|
1328 |
#-------------------------------------------------------------------------------
|
|
|
1329 |
# Function : GetDepends
|
|
|
1330 |
#
|
|
|
1331 |
# Description :
|
|
|
1332 |
#
|
|
|
1333 |
# Inputs : @plist - list of pvid's to process
|
|
|
1334 |
#
|
|
|
1335 |
# Returns :
|
|
|
1336 |
#
|
|
|
1337 |
sub GetDepends
|
|
|
1338 |
{
|
|
|
1339 |
my (@plist) = @_;
|
|
|
1340 |
|
|
|
1341 |
#
|
|
|
1342 |
# Now extract the package dependacies
|
|
|
1343 |
# There may not be any
|
|
|
1344 |
#
|
|
|
1345 |
my $m_sqlstr = "SELECT ".
|
|
|
1346 |
" pd.PV_ID, ".
|
|
|
1347 |
" pd.DPV_ID " .
|
|
|
1348 |
" FROM RELEASE_MANAGER.PACKAGE_DEPENDENCIES pd ".
|
|
|
1349 |
" WHERE pd.PV_ID in ( " . join(',', @plist) . " )";
|
|
|
1350 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
1351 |
if ( defined($sth) )
|
|
|
1352 |
{
|
|
|
1353 |
if ( $sth->execute( ) )
|
|
|
1354 |
{
|
|
|
1355 |
if ( $sth->rows )
|
|
|
1356 |
{
|
|
|
1357 |
while ( my @row = $sth->fetchrow_array )
|
|
|
1358 |
{
|
|
|
1359 |
my $pvid = $row[0];
|
|
|
1360 |
my $dpvid = $row[1];
|
|
|
1361 |
push @StrayPackages, $dpvid;
|
|
|
1362 |
push @{$Packages{$dpvid}{usedBy}}, $pvid;
|
|
|
1363 |
$Packages{$dpvid}{slp} = 1 unless exists $Packages{$dpvid}{tlp};
|
|
|
1364 |
|
|
|
1365 |
#print join (',','GetDepends',@row), "\n" if ($opt_verbose > 2);
|
|
|
1366 |
}
|
|
|
1367 |
}
|
|
|
1368 |
$sth->finish();
|
|
|
1369 |
}
|
|
|
1370 |
else
|
|
|
1371 |
{
|
|
|
1372 |
$logger->warn("GetDepends:Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
1373 |
}
|
|
|
1374 |
}
|
|
|
1375 |
else
|
|
|
1376 |
{
|
|
|
1377 |
$logger->warn("GetDepends:Prepare failure" );
|
|
|
1378 |
}
|
|
|
1379 |
}
|
|
|
1380 |
|
|
|
1381 |
#-------------------------------------------------------------------------------
|
|
|
1382 |
# Function : GetSdkPackageData
|
|
|
1383 |
#
|
|
|
1384 |
# Description : Extract Packages that are a part of a non-deprecated SDK
|
|
|
1385 |
# Only want the exposed packages
|
|
|
1386 |
#
|
|
|
1387 |
# Don't care about the dependencies, so don't add them
|
|
|
1388 |
# to strays
|
|
|
1389 |
#
|
|
|
1390 |
# Inputs :
|
|
|
1391 |
#
|
|
|
1392 |
# Returns :
|
|
|
1393 |
#
|
|
|
1394 |
|
|
|
1395 |
sub GetSdkPackageData
|
|
|
1396 |
{
|
|
|
1397 |
my (@row);
|
|
|
1398 |
my $count = 0;
|
|
|
1399 |
|
|
|
1400 |
$logger->verbose ("Extract SDK Packages");
|
|
|
1401 |
|
|
|
1402 |
# Get all packages that are a part of a non-deprecated SDK
|
|
|
1403 |
# Only get the 'exposed' packages
|
|
|
1404 |
|
|
|
1405 |
my $m_sqlstr = "SELECT sc.pv_id, " . #[0]
|
|
|
1406 |
" p.PKG_NAME, " . #[1]
|
|
|
1407 |
" pv.PKG_VERSION" . #[2]
|
|
|
1408 |
" FROM RELEASE_MANAGER.SDK_CONTENT sc," .
|
|
|
1409 |
" RELEASE_MANAGER.sdk_tags st," .
|
|
|
1410 |
" RELEASE_MANAGER.package_versions pv," .
|
|
|
1411 |
" RELEASE_MANAGER.PACKAGES p" .
|
|
|
1412 |
" WHERE sc.SDKTAG_ID = st.SDKTAG_ID" .
|
|
|
1413 |
" AND p.PKG_ID = pv.PKG_ID" .
|
|
|
1414 |
" AND pv.PV_ID = sc.pv_id" .
|
|
|
1415 |
" AND sc.SDKPKG_STATE = 'E'" .
|
|
|
1416 |
" AND st.SDK_STATE NOT IN ('D')" ;
|
|
|
1417 |
|
|
|
1418 |
$logger->verbose2("GetSdkPackageData: $m_sqlstr");
|
|
|
1419 |
my $sth = $RM_DB->prepare($m_sqlstr);
|
|
|
1420 |
if ( defined($sth) )
|
|
|
1421 |
{
|
|
|
1422 |
if ( $sth->execute( ) )
|
|
|
1423 |
{
|
|
|
1424 |
if ( $sth->rows )
|
|
|
1425 |
{
|
|
|
1426 |
while ( @row = $sth->fetchrow_array )
|
|
|
1427 |
{
|
|
|
1428 |
$count++;
|
|
|
1429 |
#print join (',',@row), "\n" if ($opt_verbose > 2);
|
|
|
1430 |
my $pvid = $row[0];
|
|
|
1431 |
$Packages{$pvid}{sdk} = 1;
|
|
|
1432 |
unless ( exists $Packages{$pvid}{name} )
|
|
|
1433 |
{
|
|
|
1434 |
$Packages{$pvid}{name} = $row[1];
|
|
|
1435 |
$Packages{$pvid}{version} = $row[2];
|
|
|
1436 |
}
|
|
|
1437 |
}
|
|
|
1438 |
}
|
|
|
1439 |
$sth->finish();
|
|
|
1440 |
}
|
|
|
1441 |
else
|
|
|
1442 |
{
|
|
|
1443 |
$logger->warn("GetSdkPackageData:Execute failure: $m_sqlstr", $sth->errstr() );
|
|
|
1444 |
}
|
|
|
1445 |
}
|
|
|
1446 |
else
|
|
|
1447 |
{
|
|
|
1448 |
$logger->warn("GetSdkPackageData:Prepare failure" );
|
|
|
1449 |
}
|
|
|
1450 |
|
|
|
1451 |
$logger->verbose ("Extract SDK Packages: $count rows");
|
| 7544 |
dpurdie |
1452 |
$qStats{SdkCount} = $count;
|
| 7539 |
dpurdie |
1453 |
}
|
|
|
1454 |
|
|
|
1455 |
#-------------------------------------------------------------------------------
|
|
|
1456 |
# Function : GeneratePvidLookup
|
|
|
1457 |
#
|
|
|
1458 |
# Description : Populate $pkgPvid (hash)
|
|
|
1459 |
#
|
|
|
1460 |
# Inputs :
|
|
|
1461 |
#
|
|
|
1462 |
# Returns :
|
|
|
1463 |
#
|
|
|
1464 |
sub GeneratePvidLookup
|
|
|
1465 |
{
|
|
|
1466 |
#
|
|
|
1467 |
# Create a lookup from package name/version to pvid
|
|
|
1468 |
#
|
|
|
1469 |
foreach my $pvid ( keys %Packages )
|
|
|
1470 |
{
|
|
|
1471 |
my $name = $Packages{$pvid}{name};
|
|
|
1472 |
my $version = $Packages{$pvid}{version};
|
|
|
1473 |
if ( $name && $version )
|
|
|
1474 |
{
|
|
|
1475 |
$pkgPvid{$name}{$version}{pvid} = $pvid;
|
|
|
1476 |
}
|
|
|
1477 |
}
|
|
|
1478 |
}
|
|
|
1479 |
|
|
|
1480 |
#-------------------------------------------------------------------------------
|
|
|
1481 |
# Function : processDpkgArchive
|
|
|
1482 |
#
|
|
|
1483 |
# Description : Scan dpkg_archive
|
|
|
1484 |
#
|
|
|
1485 |
# Inputs :
|
|
|
1486 |
#
|
|
|
1487 |
# Returns :
|
|
|
1488 |
#
|
|
|
1489 |
sub processDpkgArchive
|
|
|
1490 |
{
|
|
|
1491 |
$logger->verbose ("Scanning dpkg_archive");
|
|
|
1492 |
unless (opendir( PKGS, $conf->{dpkg_archive} ) ) {
|
|
|
1493 |
$logger->warn("Cannot open dpkg_archive: $conf->{dpkg_archive}");
|
|
|
1494 |
return;
|
|
|
1495 |
}
|
|
|
1496 |
|
|
|
1497 |
while ( my $pkgName = readdir(PKGS) )
|
|
|
1498 |
{
|
|
|
1499 |
next if ( $pkgName eq '.' );
|
|
|
1500 |
next if ( $pkgName eq '..' );
|
|
|
1501 |
next if ( $pkgName eq 'lost+found' );
|
|
|
1502 |
next if ( exists $ignorePkg->{$pkgName} );
|
|
|
1503 |
|
|
|
1504 |
my $pkgDir = join('/', $conf->{dpkg_archive}, $pkgName );
|
|
|
1505 |
if ( -d $pkgDir )
|
|
|
1506 |
{
|
|
|
1507 |
if (opendir (PV, $pkgDir ) )
|
|
|
1508 |
{
|
| 7544 |
dpurdie |
1509 |
$qStats{DpkgPackageCount}++;
|
| 7539 |
dpurdie |
1510 |
while ( my $pkgVersion = readdir(PV) )
|
|
|
1511 |
{
|
|
|
1512 |
next if ( $pkgVersion eq '.' );
|
|
|
1513 |
next if ( $pkgVersion eq '..' );
|
|
|
1514 |
next if ( $pkgVersion eq 'latest' ); # Keep latest (often symlink for build system)
|
| 7544 |
dpurdie |
1515 |
$qStats{DpkgArchiveCount}++;
|
| 7539 |
dpurdie |
1516 |
|
|
|
1517 |
my $pkgPath = join('/', $conf->{dpkg_archive}, $pkgName,$pkgVersion );
|
|
|
1518 |
my $mtime = checkTime($pkgPath);
|
|
|
1519 |
|
|
|
1520 |
my $pvid;
|
|
|
1521 |
if ( exists ($pkgPvid{$pkgName}) && exists($pkgPvid{$pkgName}{$pkgVersion} ) )
|
|
|
1522 |
{
|
|
|
1523 |
$pvid = $pkgPvid{$pkgName}{$pkgVersion}{pvid};
|
|
|
1524 |
$Packages{$pvid}{dpkg_archive} = 1;
|
|
|
1525 |
$pkgPvid{$pkgName}{$pkgVersion}{mtime} = $mtime;
|
|
|
1526 |
}
|
|
|
1527 |
else
|
|
|
1528 |
{
|
|
|
1529 |
#
|
|
|
1530 |
# Package is in dpkg-archive, but not in Release
|
|
|
1531 |
# Manager. Allow for a short while
|
|
|
1532 |
#
|
| 7544 |
dpurdie |
1533 |
$qStats{ReasonTotalPackages}++;
|
|
|
1534 |
$qStats{'Reason' . 'NotInReleaseManager'}++;
|
| 7539 |
dpurdie |
1535 |
if ( $mtime > $conf->{retainNoRm} )
|
|
|
1536 |
{
|
|
|
1537 |
#Log("Package not in RM: $pkgName, $pkgVersion, Age: $mtime");
|
|
|
1538 |
quarantineItem( 'X', $pkgName, $pkgVersion );
|
|
|
1539 |
}
|
|
|
1540 |
|
|
|
1541 |
explain ("Reason:-, $pkgName, $pkgVersion, Reason:NotInReleaseManager");
|
|
|
1542 |
}
|
|
|
1543 |
|
|
|
1544 |
#Message("$pkgName, $pkgVersion, $pkgPvid{$pkgName}{$pkgVersion}{mtime}");
|
|
|
1545 |
}
|
|
|
1546 |
close(PV);
|
|
|
1547 |
}
|
|
|
1548 |
}
|
|
|
1549 |
elsif ( -f $pkgDir )
|
|
|
1550 |
{
|
|
|
1551 |
$logger->warn("Unexpected file in dpkg_archive: $pkgName");
|
|
|
1552 |
|
|
|
1553 |
# Ideally we should delete the file
|
|
|
1554 |
# quarantineItem( 'F', -1, $pkgDir );
|
| 7544 |
dpurdie |
1555 |
$qStats{'Reason' .'FileNotInReleaseManager'}++;
|
|
|
1556 |
explain("Reason:-, $pkgDir, -, Reason:FileNotInReleaseManager");
|
| 7539 |
dpurdie |
1557 |
}
|
|
|
1558 |
else
|
|
|
1559 |
{
|
|
|
1560 |
$logger->warn("Unexpected entry in dpkg_archive: $pkgName");
|
|
|
1561 |
}
|
|
|
1562 |
}
|
|
|
1563 |
close(PKGS);
|
|
|
1564 |
}
|
|
|
1565 |
|
|
|
1566 |
#-------------------------------------------------------------------------------
|
|
|
1567 |
# Function : calcPkgsToQuarantine
|
|
|
1568 |
#
|
|
|
1569 |
# Description : Calculate the packages to be quarantined
|
|
|
1570 |
#
|
|
|
1571 |
# Inputs :
|
|
|
1572 |
#
|
|
|
1573 |
# Returns :
|
|
|
1574 |
#
|
|
|
1575 |
sub calcPkgsToQuarantine
|
|
|
1576 |
{
|
|
|
1577 |
#
|
|
|
1578 |
#
|
|
|
1579 |
# Scan all packages found in dpkg_archive and see if we should keep it
|
|
|
1580 |
# Quarantine those we cannot find a reason to keep
|
|
|
1581 |
#
|
|
|
1582 |
foreach my $pkgName ( sort keys %pkgPvid )
|
|
|
1583 |
{
|
|
|
1584 |
foreach my $pkgVersion ( sort keys %{$pkgPvid{$pkgName}} )
|
|
|
1585 |
{
|
|
|
1586 |
my $mtime = $pkgPvid{$pkgName}{$pkgVersion}{mtime} || 0;
|
|
|
1587 |
my $pvid = $pkgPvid{$pkgName}{$pkgVersion}{pvid};
|
|
|
1588 |
my $keepReason = '';
|
|
|
1589 |
my $entry = $Packages{$pvid};
|
|
|
1590 |
|
|
|
1591 |
{
|
|
|
1592 |
# Examine entry. Determine a reason to keep the package
|
|
|
1593 |
# Some reasons to keep a package are no longer needed now that versions are pumped into S3
|
|
|
1594 |
|
|
|
1595 |
unless ($entry) { $keepReason ='NoPackageEntry'; last;}
|
|
|
1596 |
unless ($entry->{dpkg_archive}) { $keepReason ='NotInArchive'; last;}
|
|
|
1597 |
unless ($pvid) { $keepReason = 'NoPVid'; last;}
|
|
|
1598 |
if (exists $entry->{tlp}) { $keepReason = 'TopLevelPackage'; last;}
|
|
|
1599 |
if (exists $entry->{slp}) { $keepReason = 'SecondLevelPackage'; last;}
|
| 7544 |
dpurdie |
1600 |
if (exists $entry->{sdk}) { $keepReason ='InSdk'; last;}
|
|
|
1601 |
if (exists $entry->{dm}) { $keepReason = 'InDeploymentManager'; last;}
|
|
|
1602 |
if ($entry->{isPatch}) { $keepReason = 'IsPatch'; last;}
|
| 7539 |
dpurdie |
1603 |
if ($mtime <= $conf->{retain}) { $keepReason ='RetainTime:' . ($conf->{retain} - $mtime); last;}
|
|
|
1604 |
#unless ($entry->{buildStandard}) { $keepReason ='NoBuildStandard:' . $mtime; last;}
|
|
|
1605 |
if ($entry->{locked} ne 'Y') { $keepReason ='NotLocked:' . $entry->{locked}; last;}
|
|
|
1606 |
#if ($entry->{buildType} eq 'M') { $keepReason ='ManualBuild:' . $entry->{buildType}; last;}
|
|
|
1607 |
|
|
|
1608 |
$pkgPvid{$pkgName}{$pkgVersion}{keepReason} = $keepReason;
|
|
|
1609 |
}
|
|
|
1610 |
|
|
|
1611 |
unless ( $keepReason )
|
|
|
1612 |
{
|
|
|
1613 |
$logger->verbose2("Quarantine:$pvid, $pkgName, $pkgVersion, Age:$mtime, Lock:$entry->{locked}, Patch:$entry->{isPatch}, BS:$entry->{buildStandard}, BT:$entry->{buildType}");
|
|
|
1614 |
quarantineItem( 'Q', $mtime, $pkgName, $pkgVersion) ;
|
|
|
1615 |
$keepReason = 'Quarantine';
|
|
|
1616 |
}
|
|
|
1617 |
|
|
|
1618 |
explain("Reason:$pvid, $pkgName, $pkgVersion, Reason:$keepReason");
|
|
|
1619 |
|
|
|
1620 |
#
|
|
|
1621 |
# Maintain Stats
|
|
|
1622 |
# Only use the Base Reason - remove details after the ':' character
|
|
|
1623 |
#
|
|
|
1624 |
my $sReason = $keepReason;
|
|
|
1625 |
$sReason =~ s~:.*$~~;
|
| 7544 |
dpurdie |
1626 |
$qStats{'Reason' . $sReason}++;
|
|
|
1627 |
$qStats{ReasonTotalPackages}++;
|
| 7539 |
dpurdie |
1628 |
}
|
|
|
1629 |
}
|
|
|
1630 |
}
|
|
|
1631 |
|
|
|
1632 |
#-------------------------------------------------------------------------------
|
|
|
1633 |
# Function : quarantineItem
|
|
|
1634 |
#
|
|
|
1635 |
# Description : Add item to the list of stuff to be quarantined
|
|
|
1636 |
#
|
|
|
1637 |
# Inputs : $reason - Reason
|
|
|
1638 |
# $age - Age
|
|
|
1639 |
# $pkgName - Package Nname
|
|
|
1640 |
# $pkgVersion - Package Version
|
|
|
1641 |
#
|
|
|
1642 |
# Returns :
|
|
|
1643 |
#
|
|
|
1644 |
sub quarantineItem
|
|
|
1645 |
{
|
|
|
1646 |
my ($reason, $age, $pkgName, $pkgVersion ) = @_;
|
|
|
1647 |
my %data;
|
|
|
1648 |
$data{reason} = $reason;
|
|
|
1649 |
$data{age} = $age ;
|
|
|
1650 |
$data{name} = $pkgName;
|
|
|
1651 |
$data{version} = $pkgVersion;
|
|
|
1652 |
|
|
|
1653 |
push @quarantineItems, \%data;
|
| 7544 |
dpurdie |
1654 |
$qStats{'Quarantine'}++;
|
| 7539 |
dpurdie |
1655 |
}
|
|
|
1656 |
|
|
|
1657 |
#-------------------------------------------------------------------------------
|
|
|
1658 |
# Function : checkTime
|
|
|
1659 |
#
|
|
|
1660 |
# Description : Seconds since modification of a path
|
|
|
1661 |
#
|
|
|
1662 |
# Inputs : Path elements
|
|
|
1663 |
#
|
|
|
1664 |
# Returns : Days since modification
|
|
|
1665 |
#
|
|
|
1666 |
|
|
|
1667 |
sub checkTime
|
|
|
1668 |
{
|
|
|
1669 |
my ($path) = @_;
|
|
|
1670 |
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
|
|
|
1671 |
$atime,$mtime,$ctime,$blksize,$blocks) = stat($path);
|
|
|
1672 |
|
|
|
1673 |
unless(defined $mtime)
|
|
|
1674 |
{
|
|
|
1675 |
$logger->warn("Bad stat for $path");
|
|
|
1676 |
$mtime = 0;
|
|
|
1677 |
}
|
|
|
1678 |
|
|
|
1679 |
return $now - $mtime;
|
|
|
1680 |
}
|
|
|
1681 |
#-------------------------------------------------------------------------------
|
|
|
1682 |
# Function : DumpInternalData
|
|
|
1683 |
#
|
|
|
1684 |
# Description : Save data for examination
|
|
|
1685 |
# Has out of memory issues
|
|
|
1686 |
#
|
|
|
1687 |
# Inputs :
|
|
|
1688 |
#
|
|
|
1689 |
# Returns :
|
|
|
1690 |
#
|
|
|
1691 |
sub DumpInternalData
|
|
|
1692 |
{
|
|
|
1693 |
# my $fh;
|
|
|
1694 |
# my $fileName = $conf->{tagdir} . '/releases.txt';
|
|
|
1695 |
# $logger->logmsg("Dump Releases: $fileName");
|
|
|
1696 |
# open ($fh, '>', $fileName);
|
|
|
1697 |
# print $fh Data::Dumper->Dump ( [\%Releases] );
|
|
|
1698 |
# close $fh;
|
|
|
1699 |
#
|
|
|
1700 |
# $fileName = $conf->{tagdir} . '/packages.txt';
|
|
|
1701 |
# $logger->logmsg("Dump Packages: $fileName");
|
|
|
1702 |
# open ($fh, '>', $fileName);
|
|
|
1703 |
# print $fh Data::Dumper->Dump ( [\%Packages] );
|
|
|
1704 |
# close $fh;
|
|
|
1705 |
}
|
|
|
1706 |
|
|
|
1707 |
#-------------------------------------------------------------------------------
|
|
|
1708 |
# Function : doQuarantine
|
|
|
1709 |
#
|
|
|
1710 |
# Description : Quarantine files and folders that have been queued up
|
|
|
1711 |
# If the tar zip of the package exists in the s3 bucket - then delete it
|
|
|
1712 |
# Otherwise request that a tar zip be created. Should be picked up on the
|
|
|
1713 |
# next scan.
|
|
|
1714 |
#
|
|
|
1715 |
# Inputs : None
|
|
|
1716 |
#
|
|
|
1717 |
# Returns :
|
|
|
1718 |
#
|
|
|
1719 |
sub doQuarantine
|
|
|
1720 |
{
|
|
|
1721 |
my $testMsg = $conf->{test} ? 'Test,' : '';
|
|
|
1722 |
|
|
|
1723 |
# Process entries - oldest first
|
|
|
1724 |
#
|
|
|
1725 |
$qStats{'QuarantineToDo'} = ( scalar @quarantineItems );
|
|
|
1726 |
$logger->logmsg ("Packages to quarantine: $qStats{'QuarantineToDo'}");
|
|
|
1727 |
foreach my $entry (sort {$b->{age} <=> $a->{age} } @quarantineItems)
|
|
|
1728 |
{
|
|
|
1729 |
my $emsg = '';
|
|
|
1730 |
if (pkgInS3($entry->{name}, $entry->{version}) ) {
|
|
|
1731 |
# Package is safely in S3 - can simply delete it
|
|
|
1732 |
if ($conf->{test}) {
|
|
|
1733 |
$emsg = ' - Not deleted in test mode';
|
|
|
1734 |
$qStats{'QuarantineCount'}++;
|
| 7544 |
dpurdie |
1735 |
$statistics{'QuarantineCount'}++;
|
| 7539 |
dpurdie |
1736 |
|
|
|
1737 |
} else {
|
|
|
1738 |
delete_version($entry->{name}, $entry->{version});
|
|
|
1739 |
my $path = join('/', $conf->{dpkg_archive}, $entry->{name}, $entry->{version} );
|
|
|
1740 |
if (-d $path) {
|
|
|
1741 |
$logger->warn("Could not delete package: $path");
|
|
|
1742 |
$qStats{'QuarantineError'}++;
|
| 7544 |
dpurdie |
1743 |
$statistics{'QuarantineError'}++;
|
| 7539 |
dpurdie |
1744 |
$emsg = ' - Delete error';
|
|
|
1745 |
|
|
|
1746 |
} else {
|
|
|
1747 |
$qStats{'QuarantineCount'}++;
|
| 7544 |
dpurdie |
1748 |
$statistics{'QuarantineCount'}++;
|
| 7539 |
dpurdie |
1749 |
$emsg = '';
|
|
|
1750 |
}
|
|
|
1751 |
}
|
|
|
1752 |
|
|
|
1753 |
} else {
|
|
|
1754 |
# Package has not been transferred to S3
|
|
|
1755 |
# Would have thought this to be very unlikely, but still
|
|
|
1756 |
# Since the package is not safely stored away we can't delete it at this point in time
|
|
|
1757 |
# Request that it be transferred
|
|
|
1758 |
# With luck (or by design) the package will be in S3 by the time the process runs again.
|
|
|
1759 |
#
|
|
|
1760 |
requestS3Transfer($entry->{name}, $entry->{version});
|
|
|
1761 |
$qStats{'QuarantineTxRequested'}++;
|
| 7544 |
dpurdie |
1762 |
$statistics{'QuarantineTxRequested'}++;
|
| 7539 |
dpurdie |
1763 |
$emsg = ' - Not in S3. Transfer requested';
|
|
|
1764 |
}
|
|
|
1765 |
|
|
|
1766 |
# Log operation with frills
|
|
|
1767 |
$logger->logmsg (sprintf("Quarantined:%s%s,%10.10s,%s %s%s", $testMsg, $entry->{reason}, $entry->{age}, $entry->{name}, $entry->{version}, $emsg ));
|
|
|
1768 |
$qStats{'QuarantineToDo'}--;
|
|
|
1769 |
}
|
|
|
1770 |
$logger->verbose("End doQuarantine");
|
|
|
1771 |
}
|
|
|
1772 |
|
|
|
1773 |
#-------------------------------------------------------------------------------
|
|
|
1774 |
# Function : requestS3Transfer
|
|
|
1775 |
#
|
|
|
1776 |
# Description : Request that another blat daemon transfer a package to S3
|
|
|
1777 |
#
|
|
|
1778 |
# Inputs : $pname
|
|
|
1779 |
# $pver
|
|
|
1780 |
#
|
|
|
1781 |
# Returns : Nothing
|
|
|
1782 |
#
|
|
|
1783 |
sub requestS3Transfer
|
|
|
1784 |
{
|
|
|
1785 |
my ($pname, $pver) = @_;
|
|
|
1786 |
|
|
|
1787 |
$conf->{'tagdir'} =~ m~^(.*)/~;
|
|
|
1788 |
my $tagRoot = $1;
|
|
|
1789 |
my $tag = "$pname::$pver";
|
|
|
1790 |
my $s3TransferTagDir = catfile($tagRoot, 's3Transfer' );
|
|
|
1791 |
my $s3TransferTag = catfile($s3TransferTagDir, $tag);
|
|
|
1792 |
$logger->warn ("requestS3Transfer: Invalid directory: $s3TransferTagDir") unless -d $s3TransferTagDir;
|
|
|
1793 |
|
|
|
1794 |
if ( $conf->{'noTransfers'} ) {
|
|
|
1795 |
$logger->logmsg("Request S3 transfer DISABLED: $s3TransferTag")
|
|
|
1796 |
} else {
|
|
|
1797 |
$logger->logmsg("Request S3 transfer: $s3TransferTag");
|
|
|
1798 |
Utils::TouchFile($conf, $s3TransferTag) unless -f $s3TransferTag;
|
|
|
1799 |
}
|
|
|
1800 |
}
|
|
|
1801 |
|
|
|
1802 |
#-------------------------------------------------------------------------------
|
|
|
1803 |
# Function : pkgInS3
|
|
|
1804 |
#
|
|
|
1805 |
# Description : Check that a specified package-versions exists in the dpkg_archive
|
|
|
1806 |
# S3 bucket
|
|
|
1807 |
#
|
|
|
1808 |
# Inputs : $pname
|
|
|
1809 |
# $pversion
|
|
|
1810 |
#
|
|
|
1811 |
# Returns : 1 - Package is in S3
|
|
|
1812 |
# 0 - Package not found
|
|
|
1813 |
#
|
|
|
1814 |
sub pkgInS3
|
|
|
1815 |
{
|
|
|
1816 |
my ($pname, $pversion) = @_;
|
|
|
1817 |
my $objKey = $pname . '__' . $pversion . '.tgz';
|
|
|
1818 |
|
|
|
1819 |
|
|
|
1820 |
my $s3_cmd = "aws --profile $conf->{'S3Profile'} --output json";
|
|
|
1821 |
$s3_cmd .= " s3api head-object --bucket vix-dpkg-archive --key $objKey";
|
|
|
1822 |
|
|
|
1823 |
$logger->verbose2("pkgInS3:s3_cmd:$s3_cmd");
|
|
|
1824 |
|
|
|
1825 |
my $ph;
|
|
|
1826 |
my $jsontxt = "";
|
|
|
1827 |
if (open ($ph, "$s3_cmd 2>/dev/null |") )
|
|
|
1828 |
{
|
|
|
1829 |
while ( <$ph> ) {
|
|
|
1830 |
chomp;
|
|
|
1831 |
$logger->verbose2("pkgInS3:Data: $_");
|
|
|
1832 |
$jsontxt .= $_;
|
|
|
1833 |
}
|
|
|
1834 |
close ($ph);
|
|
|
1835 |
}
|
|
|
1836 |
if ($jsontxt) {
|
|
|
1837 |
$logger->verbose2("pkgInS3: $pname, $pversion Found");
|
|
|
1838 |
return 1;
|
|
|
1839 |
}
|
|
|
1840 |
|
|
|
1841 |
$logger->verbose2("pkgInS3: $pname, $pversion Not Found");
|
|
|
1842 |
return 0;
|
|
|
1843 |
}
|
|
|
1844 |
|
|
|
1845 |
#-------------------------------------------------------------------------------
|
|
|
1846 |
# Function : delete_version
|
|
|
1847 |
#
|
|
|
1848 |
# Description : Delete one version of one package
|
|
|
1849 |
#
|
|
|
1850 |
# Inputs : $pname
|
|
|
1851 |
# $pver
|
|
|
1852 |
#
|
|
|
1853 |
# Returns : Not used
|
|
|
1854 |
#
|
|
|
1855 |
sub delete_version {
|
|
|
1856 |
my($pname, $pver) = @_;
|
|
|
1857 |
#
|
|
|
1858 |
# Need to use a helper utilty to delete the package-version
|
|
|
1859 |
# The helper is run as root as it greatly simplified the deletion process
|
|
|
1860 |
# The helper is run via sudo
|
|
|
1861 |
my $cmd = "sudo -n ./delete_package.sh $conf->{dpkg_archive} $pname $pver";
|
|
|
1862 |
if (open (my $ph, "$cmd 2>&1 |") ) {
|
|
|
1863 |
while ( <$ph> ) {
|
|
|
1864 |
chomp;
|
|
|
1865 |
$logger->verbose2("delete_version: $_");
|
|
|
1866 |
}
|
|
|
1867 |
close ($ph);
|
|
|
1868 |
}
|
|
|
1869 |
}
|
|
|
1870 |
|
|
|
1871 |
#-------------------------------------------------------------------------------
|
|
|
1872 |
# Function : explain
|
|
|
1873 |
#
|
|
|
1874 |
# Description : Display / log the reason a package is being processed
|
|
|
1875 |
#
|
|
|
1876 |
# Inputs : $txt
|
|
|
1877 |
#
|
|
|
1878 |
# Returns : Nothinf
|
|
|
1879 |
#
|
|
|
1880 |
sub explain
|
|
|
1881 |
{
|
|
|
1882 |
my($txt) = @_;
|
|
|
1883 |
if ($conf->{explain})
|
|
|
1884 |
{
|
|
|
1885 |
$logger->verbose2($txt);
|
|
|
1886 |
print $explainFh $txt . "\n";
|
|
|
1887 |
}
|
|
|
1888 |
}
|
|
|
1889 |
|