Initial commit
This commit is contained in:
commit
103d08f96a
164
cfgparser.pm
Normal file
164
cfgparser.pm
Normal file
|
|
@ -0,0 +1,164 @@
|
||||||
|
package cfgparser;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
require Exporter;
|
||||||
|
@cfgparser::ISA = qw(Exporter);
|
||||||
|
@cfgparser::EXPORT = qw(
|
||||||
|
parse_structure
|
||||||
|
parse_cfg_file
|
||||||
|
);
|
||||||
|
|
||||||
|
use logging;
|
||||||
|
use JSON;
|
||||||
|
use Data::Dumper;
|
||||||
|
|
||||||
|
sub check_structure ($$$);
|
||||||
|
|
||||||
|
sub check_structure ($$$)
|
||||||
|
{
|
||||||
|
my ($label, $structure, $grammar) = @_;
|
||||||
|
|
||||||
|
my $stype = ref($structure);
|
||||||
|
my $gtype = $$grammar{Type};
|
||||||
|
if ($gtype eq 'or') {
|
||||||
|
my $options = $$grammar{Options};
|
||||||
|
if ($stype eq 'LIST') {
|
||||||
|
foreach my $subgrammar (@$options) {
|
||||||
|
my $gtype = $$subgrammar{Type};
|
||||||
|
if ($gtype eq 'list') {
|
||||||
|
return check_structure($label, $structure, $subgrammar);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
print_log('config', ERROR, 'Found LIST, not expecting this at %s', $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
elsif ($stype eq 'HASH') {
|
||||||
|
foreach my $subgrammar (@$options) {
|
||||||
|
my $gtype = $$subgrammar{Type};
|
||||||
|
if ($gtype eq 'map' || $gtype eq 'struct') {
|
||||||
|
return check_structure($label, $structure, $subgrammar);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
print_log('config', ERROR, 'Found HASH, not expecting this at %s', $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
elsif ($stype eq '') {
|
||||||
|
foreach my $subgrammar (@$options) {
|
||||||
|
my $gtype = $$subgrammar{Type};
|
||||||
|
if ($gtype eq 'string' || $gtype eq 'integer') {
|
||||||
|
return check_structure($label, $structure, $subgrammar);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
print_log('config', ERROR, 'Found SCALAR, not expecting this at %s', $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
print_log('config', ERROR, 'Found %s, not expecting this at %s', $stype, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if ($gtype eq 'map') {
|
||||||
|
if ($stype ne 'HASH') {
|
||||||
|
print_log('config', ERROR, 'Expecting HASH, found %s at %s', $stype, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
my $sublabel = $label;
|
||||||
|
$sublabel .= '/' unless $sublabel eq '/';
|
||||||
|
foreach my $key (keys %$structure) {
|
||||||
|
return 0 unless check_structure($sublabel.$key, $$structure{$key}, $$grammar{Elements});
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
if ($gtype eq 'struct') {
|
||||||
|
if ($stype ne 'HASH') {
|
||||||
|
print_log('config', ERROR, 'Expecting HASH, found %s at %s', $stype, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
my $sublabel = $label;
|
||||||
|
$sublabel .= '/' unless $sublabel eq '/';
|
||||||
|
my $keywords = $$grammar{Keywords};
|
||||||
|
foreach my $key (keys %$structure) {
|
||||||
|
my $kw = $$keywords{$key};
|
||||||
|
if (! defined $kw) {
|
||||||
|
print_log('config', ERROR, 'Unknown keyword %s at %s', $key, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
return 0 unless check_structure($sublabel.$key, $$structure{$key}, $kw);
|
||||||
|
}
|
||||||
|
foreach my $key (keys %$keywords) {
|
||||||
|
my $kw = $$keywords{$key};
|
||||||
|
next unless defined $$kw{Mandatory} && $$kw{Mandatory};
|
||||||
|
if (! defined $$structure{$key}) {
|
||||||
|
print_log('config', ERROR, 'Missing mandatory keyword %s at %s', $key, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
my $checkfunc = $$grammar{Check};
|
||||||
|
return 0 if defined $checkfunc && ! &{$checkfunc}($structure, $label);
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
if ($gtype eq 'list') {
|
||||||
|
if ($stype ne 'ARRAY') {
|
||||||
|
print_log('config', ERROR, 'Expecting ARRAY, found %s at %s', $stype, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
my $index = 0;
|
||||||
|
foreach my $element (@$structure) {
|
||||||
|
$index++;
|
||||||
|
return 0 unless check_structure($label.'['.$index.']', $element, $$grammar{Elements});
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
if ($stype ne '') {
|
||||||
|
print_log('config', ERROR, 'Expecting SCALAR, found %s at %s', $stype, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
if ($gtype eq 'string') {
|
||||||
|
print_log('config', DEBUG2, 'Found string value %s at %s', $structure, $label);
|
||||||
|
}
|
||||||
|
elsif ($gtype eq 'integer') {
|
||||||
|
if ($structure !~ /^\d+$/o) {
|
||||||
|
print_log('config', ERROR, 'Expecting integer value, found %s at %s', $structure, $label);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
print_log('config', DEBUG2, 'Found integer value %s at %s', $structure, $label);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
print_log('config', ERROR, 'Unknown grammar element type: %s', $gtype);
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parse_structure ($$$)
|
||||||
|
{
|
||||||
|
my ($path, $contents, $grammar) = @_;
|
||||||
|
|
||||||
|
my $structure = eval { decode_json($contents) };
|
||||||
|
if (! defined $structure) {
|
||||||
|
my $error = $@;
|
||||||
|
print_log('config', ERROR, 'Cannot parse config file %s: %s', $path, $error);
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
return undef unless check_structure('/', $structure, $grammar);
|
||||||
|
return $structure;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parse_cfg_file ($$)
|
||||||
|
{
|
||||||
|
my ($path, $grammar) = @_;
|
||||||
|
|
||||||
|
if (! open(FILE, '<', $path)) {
|
||||||
|
print_log('config', ERROR, 'Cannot open file %s: %s', $path, $!);
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
my $contents = '';
|
||||||
|
while (<FILE>) {
|
||||||
|
$contents .= $_;
|
||||||
|
}
|
||||||
|
close(FILE);
|
||||||
|
return parse_structure($path, $contents, $grammar);
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
230
cmdline.pm
Normal file
230
cmdline.pm
Normal file
|
|
@ -0,0 +1,230 @@
|
||||||
|
package cmdline;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
require Exporter;
|
||||||
|
@cmdline::ISA = qw(Exporter);
|
||||||
|
@cmdline::EXPORT = qw(
|
||||||
|
parse_cmdline
|
||||||
|
print_usage
|
||||||
|
);
|
||||||
|
|
||||||
|
use logging;
|
||||||
|
|
||||||
|
sub store_option_value ($$$)
|
||||||
|
{
|
||||||
|
my ($spec, $arg, $value) = @_;
|
||||||
|
|
||||||
|
my $storeinto = $$spec{StoreInto};
|
||||||
|
if (defined $storeinto && ref($storeinto) eq 'SCALAR') {
|
||||||
|
print_log('global', DEBUG1, 'Storing option %s value: %s', $arg, $value);
|
||||||
|
$$storeinto = $value;
|
||||||
|
}
|
||||||
|
my $storefunc = $$spec{StoreFunc};
|
||||||
|
if (defined $storefunc && ref($storefunc) eq 'CODE') {
|
||||||
|
print_log('global', DEBUG1, 'Storing option %s value: %s', $arg, $value);
|
||||||
|
&{$storefunc}($value);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub check_option_value ($$$)
|
||||||
|
{
|
||||||
|
my ($spec, $arg, $value) = @_;
|
||||||
|
|
||||||
|
my $type = $$spec{Type};
|
||||||
|
if ($type eq 'integer') {
|
||||||
|
if ($value !~ /^\d+$/o) {
|
||||||
|
print STDERR 'Invalid integer parameter for option '.$arg.': '.$value."\n";
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if ($type eq 'keyvalue') {
|
||||||
|
if ($value !~ /^[^=]+=/o) {
|
||||||
|
print STDERR 'Invalid key=value parameter syntax for option '.$arg.': '.$value."\n";
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parse_cmdline ($)
|
||||||
|
{
|
||||||
|
my ($specs) = @_;
|
||||||
|
|
||||||
|
my $general = 0;
|
||||||
|
my $found = {};
|
||||||
|
my $shorts = {};
|
||||||
|
my $longs = {};
|
||||||
|
foreach my $spec (@$specs) {
|
||||||
|
$general++ if defined $$spec{General};
|
||||||
|
my $short = $$spec{Short};
|
||||||
|
my $long = $$spec{Long};
|
||||||
|
$$shorts{$short} = $spec if defined $short;
|
||||||
|
$$longs{$long} = $spec if defined $long;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $left = [];
|
||||||
|
|
||||||
|
my $i = 0;
|
||||||
|
my $options = 1;
|
||||||
|
while (1) {
|
||||||
|
my $arg = $ARGV[$i++];
|
||||||
|
last unless defined $arg;
|
||||||
|
print_log('global', DEBUG2, 'Checking argument %s', $arg);
|
||||||
|
|
||||||
|
if ($options && $arg =~ /^--(.*)$/o) {
|
||||||
|
my $long = $1;
|
||||||
|
if ($long eq '') {
|
||||||
|
print_log('global', DEBUG2, 'No more options');
|
||||||
|
$options = 0;
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
my $spec = $$longs{$long};
|
||||||
|
if (! defined $spec) {
|
||||||
|
print STDERR 'Unknown long option: '.$arg."\n";
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
print_log('global', DEBUG2, 'Found long option: %s', $long);
|
||||||
|
my $param;
|
||||||
|
if ($$spec{Type} eq 'flag') {
|
||||||
|
$param = 1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$param = $ARGV[$i++];
|
||||||
|
if (! defined $param) {
|
||||||
|
print STDERR 'Missing parameter for long option: '.$arg."\n";
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
return undef unless check_option_value($spec, $arg, $param);
|
||||||
|
}
|
||||||
|
$$found{$arg} = 1;
|
||||||
|
store_option_value($spec, $arg, $param);
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
if ($options && $arg =~ /^-(.*)$/o) {
|
||||||
|
my $list = $1;
|
||||||
|
my $j = 0;
|
||||||
|
while ($j < length($list)) {
|
||||||
|
my $short = substr($list, $j++, 1);
|
||||||
|
if ($short eq '-') {
|
||||||
|
print_log('global', DEBUG2, 'No more options');
|
||||||
|
$options = 0;
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
my $opt = '-'.$short;
|
||||||
|
my $spec = $$shorts{$short};
|
||||||
|
if (! defined $spec) {
|
||||||
|
print STDERR 'Unknown short option: '.$opt."\n";
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
print_log('global', DEBUG2, 'Found short option: %s', $short);
|
||||||
|
my $param;
|
||||||
|
if ($$spec{Type} eq 'flag') {
|
||||||
|
$param = 1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$param = $ARGV[$i++];
|
||||||
|
if (! defined $param) {
|
||||||
|
print STDERR 'Missing parameter for short option: '.$opt."\n";
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
return undef unless check_option_value($spec, $opt, $param);
|
||||||
|
}
|
||||||
|
$$found{$opt} = 1;
|
||||||
|
store_option_value($spec, $opt, $param);
|
||||||
|
}
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
if (! $general) {
|
||||||
|
print STDERR 'Unexpected general parameter: '.$arg."\n";
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
print_log('global', DEBUG1, 'Adding general cli parameter %s', $arg);
|
||||||
|
push @$left, $arg;
|
||||||
|
}
|
||||||
|
|
||||||
|
foreach my $spec (@$specs) {
|
||||||
|
next if defined $$spec{General};
|
||||||
|
my $default = $$spec{Default};
|
||||||
|
next unless defined $default;
|
||||||
|
my $arg;
|
||||||
|
my $long = $$spec{Long};
|
||||||
|
if (defined $long) {
|
||||||
|
$arg = '--'.$long;
|
||||||
|
next if defined $$found{$arg};
|
||||||
|
}
|
||||||
|
my $short = $$spec{Short};
|
||||||
|
if (defined $short) {
|
||||||
|
$arg = '-'.$short;
|
||||||
|
next if defined $$found{$arg};
|
||||||
|
}
|
||||||
|
print_log('global', DEBUG1, 'Using default for option %s: %s', $arg, $default);
|
||||||
|
store_option_value($spec, $arg, $default);
|
||||||
|
}
|
||||||
|
|
||||||
|
return $left;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub print_usage ($)
|
||||||
|
{
|
||||||
|
my ($specs) = @_;
|
||||||
|
|
||||||
|
my $general = '';
|
||||||
|
my $longest = 0;
|
||||||
|
foreach my $spec (@$specs) {
|
||||||
|
my $len = 0;
|
||||||
|
if (defined $$spec{General}) {
|
||||||
|
my $option = $$spec{Option};
|
||||||
|
my $optional = $$spec{Optional};
|
||||||
|
$optional = defined $optional && $optional;
|
||||||
|
$len = length($option);
|
||||||
|
$general .= ' '.($optional ? '[' : '').$option.($optional ? ']' : '')
|
||||||
|
if $len > 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $short = $$spec{Short};
|
||||||
|
my $long = $$spec{Long};
|
||||||
|
my $shortlen = defined $short ? length($short) + 1 : 0;
|
||||||
|
my $longlen = defined $long ? length($long) + 2 : 0;
|
||||||
|
$len = $shortlen + $longlen;
|
||||||
|
$len += 2 if $shortlen > 0 && $longlen > 0;
|
||||||
|
}
|
||||||
|
$longest = $len if $len > $longest;
|
||||||
|
}
|
||||||
|
|
||||||
|
print STDERR 'Usage: '.$0.' [<options>]'.$general."\n";
|
||||||
|
foreach my $spec (@$specs) {
|
||||||
|
my $buffer = '';
|
||||||
|
my $desc = $$spec{Description};
|
||||||
|
if (defined $$spec{General}) {
|
||||||
|
my $option = $$spec{Option};
|
||||||
|
|
||||||
|
$buffer .= $option;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $short = $$spec{Short};
|
||||||
|
my $long = $$spec{Long};
|
||||||
|
my $type = $$spec{Type};
|
||||||
|
$type = '['.$type.']' if defined $type;
|
||||||
|
$desc = $desc.' '.$type if defined $type;
|
||||||
|
my $default = $$spec{Default};
|
||||||
|
$default = 'set' if $type eq 'Flag' && defined $default && $default;
|
||||||
|
$default = '(Default:'.$default.')' if defined $default;
|
||||||
|
$desc = $desc.' '.$default if defined $default;
|
||||||
|
$short = '-'.$short if defined $short;
|
||||||
|
$long = '--'.$long if defined $long;
|
||||||
|
|
||||||
|
$buffer .= $short if defined $short;
|
||||||
|
$buffer .= ', ' if defined $short && defined $long;
|
||||||
|
$buffer .= $long if defined $long;
|
||||||
|
}
|
||||||
|
|
||||||
|
$buffer .= ' ' x ($longest - length($buffer)) if length($buffer) < $longest;
|
||||||
|
$buffer = ' '.$buffer;
|
||||||
|
$buffer .= $longest + 4 + length($desc) < 80 ?
|
||||||
|
' '.$desc."\n" : "\n".' '.$desc."\n";
|
||||||
|
print STDERR $buffer
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
627
logging.pm
Normal file
627
logging.pm
Normal file
|
|
@ -0,0 +1,627 @@
|
||||||
|
package logging;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
require Exporter;
|
||||||
|
@logging::ISA = qw(Exporter);
|
||||||
|
@logging::EXPORT = qw(
|
||||||
|
VARIABLE
|
||||||
|
FATAL
|
||||||
|
ERROR
|
||||||
|
WARNING
|
||||||
|
INFO
|
||||||
|
DEBUG1
|
||||||
|
DEBUG2
|
||||||
|
DEBUG3
|
||||||
|
DEBUG4
|
||||||
|
DEBUG5
|
||||||
|
DEBUG
|
||||||
|
set_pkgtool_dir
|
||||||
|
set_verbose_flag
|
||||||
|
set_log_level
|
||||||
|
set_log_base_dir
|
||||||
|
set_current_pkg_name
|
||||||
|
get_win_version
|
||||||
|
get_default_vars
|
||||||
|
set_datetime_vars
|
||||||
|
compare_versions
|
||||||
|
substitute_variables
|
||||||
|
close_all_log_files
|
||||||
|
print_log
|
||||||
|
set_log_defs
|
||||||
|
);
|
||||||
|
|
||||||
|
use POSIX;
|
||||||
|
use File::Spec;
|
||||||
|
require Win32;
|
||||||
|
|
||||||
|
sub print_stderr_log ($$);
|
||||||
|
sub print_to_log_file ($$);
|
||||||
|
|
||||||
|
my $orig_stdout;
|
||||||
|
my $orig_stderr;
|
||||||
|
|
||||||
|
if (! open($orig_stdout, '>&STDOUT')) {
|
||||||
|
print STDERR 'Cannot dup STDOUT: '.$!."\n";
|
||||||
|
exit(1);
|
||||||
|
}
|
||||||
|
if (! open($orig_stderr, '>&', \*STDERR)) {
|
||||||
|
print STDERR 'Cannot dup STDERR: '.$!."\n";
|
||||||
|
exit(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub VARIABLE { return -99; }
|
||||||
|
sub FATAL { return -3; }
|
||||||
|
sub ERROR { return -2; }
|
||||||
|
sub WARNING { return -1; }
|
||||||
|
sub INFO { return 0; }
|
||||||
|
sub DEBUG1 { return 1; }
|
||||||
|
sub DEBUG2 { return 2; }
|
||||||
|
sub DEBUG3 { return 3; }
|
||||||
|
sub DEBUG4 { return 4; }
|
||||||
|
sub DEBUG5 { return 5; }
|
||||||
|
sub DEBUG { return 99; }
|
||||||
|
|
||||||
|
my $pkgtool_dir;
|
||||||
|
my $verbose_flag;
|
||||||
|
my $log_level;
|
||||||
|
my $log_base_dir;
|
||||||
|
my $fallback_log_def = {
|
||||||
|
type => 'stderr',
|
||||||
|
channel => {
|
||||||
|
global => 'variable'
|
||||||
|
}
|
||||||
|
};
|
||||||
|
my $fallback_log_file = {
|
||||||
|
Definition => $fallback_log_def,
|
||||||
|
LogFunc => \&print_stderr_log,
|
||||||
|
Channels => {
|
||||||
|
global => VARIABLE,
|
||||||
|
config => VARIABLE,
|
||||||
|
pkg => VARIABLE
|
||||||
|
}
|
||||||
|
};
|
||||||
|
my $log_defs = [];
|
||||||
|
my $current_pkg_name;
|
||||||
|
my $global_log_files = {};
|
||||||
|
my $package_log_files = {};
|
||||||
|
|
||||||
|
sub set_pkgtool_dir ($)
|
||||||
|
{
|
||||||
|
my ($dir) = @_;
|
||||||
|
|
||||||
|
$pkgtool_dir = $dir;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_verbose_flag ($)
|
||||||
|
{
|
||||||
|
my ($verbose) = @_;
|
||||||
|
|
||||||
|
$verbose_flag = $verbose;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_log_level ($)
|
||||||
|
{
|
||||||
|
my ($level) = @_;
|
||||||
|
|
||||||
|
$log_level = $level;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_log_base_dir ($)
|
||||||
|
{
|
||||||
|
my ($dir) = @_;
|
||||||
|
|
||||||
|
$log_base_dir = $dir;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub level2str ($)
|
||||||
|
{
|
||||||
|
my ($level) = @_;
|
||||||
|
|
||||||
|
return 'VARIABLE' if ($level == VARIABLE);
|
||||||
|
return 'FATAL' if ($level == FATAL);
|
||||||
|
return 'ERROR' if ($level == ERROR);
|
||||||
|
return 'WARNING' if ($level == WARNING);
|
||||||
|
return 'INFO' if ($level == INFO);
|
||||||
|
return 'DEBUG1' if ($level == DEBUG1);
|
||||||
|
return 'DEBUG2' if ($level == DEBUG2);
|
||||||
|
return 'DEBUG3' if ($level == DEBUG3);
|
||||||
|
return 'DEBUG4' if ($level == DEBUG4);
|
||||||
|
return 'DEBUG5' if ($level == DEBUG5);
|
||||||
|
return 'DEBUG' if ($level == DEBUG);
|
||||||
|
return $level;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub str2level ($)
|
||||||
|
{
|
||||||
|
my ($level) = @_;
|
||||||
|
|
||||||
|
return $level if $level =~ /^-?\d+$/o;
|
||||||
|
return VARIABLE if $level =~ /^variable$/io;
|
||||||
|
return FATAL if $level =~ /^fatal$/io;
|
||||||
|
return ERROR if $level =~ /^error$/io;
|
||||||
|
return WARNING if $level =~ /^warning$/io;
|
||||||
|
return INFO if $level =~ /^info$/io;
|
||||||
|
return DEBUG1 if $level =~ /^debug1$/io;
|
||||||
|
return DEBUG2 if $level =~ /^debug2$/io;
|
||||||
|
return DEBUG3 if $level =~ /^debug3$/io;
|
||||||
|
return DEBUG4 if $level =~ /^debug4$/io;
|
||||||
|
return DEBUG5 if $level =~ /^debug5$/io;
|
||||||
|
return DEBUG if $level =~ /^debug$/io;
|
||||||
|
return VARIABLE;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub compare_levels ($$)
|
||||||
|
{
|
||||||
|
my ($reference, $level) = @_;
|
||||||
|
|
||||||
|
if ($reference == VARIABLE) {
|
||||||
|
$reference = defined $log_level && $log_level > 0 ? $log_level :
|
||||||
|
defined $verbose_flag && $verbose_flag ? INFO : WARNING;
|
||||||
|
}
|
||||||
|
elsif ($reference == DEBUG) {
|
||||||
|
$reference = defined $log_level && $log_level > 0 ? $log_level : INFO;
|
||||||
|
}
|
||||||
|
return $level <=> $reference;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub compare_versions ($$)
|
||||||
|
{
|
||||||
|
my ($a, $b) = @_;
|
||||||
|
|
||||||
|
my $alist = [split(/\./, $a)];
|
||||||
|
my $blist = [split(/\./, $b)];
|
||||||
|
while (1) {
|
||||||
|
my $acomponent = shift @$alist;
|
||||||
|
my $bcomponent = shift @$blist;
|
||||||
|
if (defined $acomponent) {
|
||||||
|
return 1 unless defined $acomponent;
|
||||||
|
my $rc;
|
||||||
|
if ($acomponent =~ /^\d+$/o && $bcomponent =~ /^\d+$/o) {
|
||||||
|
$rc = $acomponent <=> $bcomponent;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$rc = $acomponent cmp $bcomponent;
|
||||||
|
}
|
||||||
|
return $rc if $rc;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return 0 unless defined $bcomponent;
|
||||||
|
return -1;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_win_version ()
|
||||||
|
{
|
||||||
|
my ($osver, $osmajor, $osminor, $osbuild) = Win32::GetOSVersion();
|
||||||
|
|
||||||
|
return $osmajor.'.'.$osminor;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_default_vars (;$)
|
||||||
|
{
|
||||||
|
my ($config) = @_;
|
||||||
|
|
||||||
|
my $genericvars = defined $config ? $$config{'generic-variables'} : undef;
|
||||||
|
my $globals = defined $config ? $$config{'global-variables'} : undef;
|
||||||
|
|
||||||
|
my $arch = $ENV{'PROCESSOR_ARCHITECTURE'} =~ /AMD64/io ? 'x64' : '';
|
||||||
|
my $xarch = $ENV{'PROCESSOR_ARCHITECTURE'} =~ /AMD64/io ? 'x64' : 'x86';
|
||||||
|
my $programfiles = $ENV{'ProgramFiles'};
|
||||||
|
my $programfiles32 = $ENV{'ProgramFiles(x86)'};
|
||||||
|
$programfiles32 = $programfiles unless defined $programfiles32;
|
||||||
|
|
||||||
|
my $vars = {};
|
||||||
|
foreach my $key (keys %ENV) {
|
||||||
|
$$vars{lc($key)} = $ENV{$key};
|
||||||
|
}
|
||||||
|
$$vars{arch} = $arch;
|
||||||
|
$$vars{xarch} = $xarch;
|
||||||
|
$$vars{osversion} = get_win_version();
|
||||||
|
$$vars{programfiles32} = $programfiles32;
|
||||||
|
$$vars{pkgtooldir} = $pkgtool_dir;
|
||||||
|
$$vars{logdir} = $log_base_dir if defined $log_base_dir;
|
||||||
|
|
||||||
|
if (defined $genericvars) {
|
||||||
|
foreach my $genvar (@$genericvars) {
|
||||||
|
my $varname = $$genvar{variable};
|
||||||
|
my $expression = $$genvar{expression};
|
||||||
|
|
||||||
|
my $value = eval $expression;
|
||||||
|
my $error = $@;
|
||||||
|
next if defined $error && $error ne '';
|
||||||
|
$$vars{$varname} = $value;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if (defined $globals) {
|
||||||
|
foreach my $varname (keys %$globals) {
|
||||||
|
my $value = $$globals{$varname};
|
||||||
|
$$vars{$varname} = $value;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return $vars;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_datetime_vars ($;$)
|
||||||
|
{
|
||||||
|
my ($vars, $now) = @_;
|
||||||
|
|
||||||
|
$now = time() unless defined $now;
|
||||||
|
my $date = strftime('%Y%m%d', localtime($now));
|
||||||
|
my $time = strftime('%H%M%S', localtime($now));
|
||||||
|
my $datetime = $date.'-'.$time;
|
||||||
|
$$vars{date} = $date;
|
||||||
|
$$vars{time} = $time;
|
||||||
|
$$vars{datetime} = $datetime;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub substitute_variables ($$$;$$)
|
||||||
|
{
|
||||||
|
my ($vars, $expr, $ispath, $basedir, $channel) = @_;
|
||||||
|
|
||||||
|
print_log($channel, DEBUG3, 'Substitute_variables for: %s', $expr) if defined $channel;
|
||||||
|
|
||||||
|
$expr =~ s/\//\\/go if $ispath;
|
||||||
|
$expr =~ s/%([^%]+)%/defined $$vars{lc($1)} ? $$vars{lc($1)} : ''/ge;
|
||||||
|
$expr =~ s/%%/%/go;
|
||||||
|
if ($ispath && defined $basedir && $expr !~ /^[^:]:/o) {
|
||||||
|
print_log($channel, DEBUG3, 'Basedir: %s expr: %s', $basedir, $expr) if defined $channel;
|
||||||
|
if ($expr =~ /^\\/o) {
|
||||||
|
if ($basedir =~ /^([^:]:)/o) {
|
||||||
|
my $drive = $1;
|
||||||
|
$expr = $drive.$expr;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$basedir .= '\\' unless $basedir =~ /\\$/o;
|
||||||
|
$expr = $basedir.$expr;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
print_log($channel, DEBUG3, 'Result: %s', $expr) if defined $channel;
|
||||||
|
return $expr;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub init_log_file ($)
|
||||||
|
{
|
||||||
|
my ($logdef) = @_;
|
||||||
|
|
||||||
|
my $ispkg = 0;
|
||||||
|
my $spec;
|
||||||
|
my $func;
|
||||||
|
my $type = $$logdef{type};
|
||||||
|
if ($type eq 'stderr') {
|
||||||
|
$spec = '<STDERR>';
|
||||||
|
$func = \&print_stderr_log;
|
||||||
|
}
|
||||||
|
elsif ($type eq 'file') {
|
||||||
|
$spec = $$logdef{path};
|
||||||
|
$func = \&print_to_log_file;
|
||||||
|
$ispkg = is_pkg_only_path($spec);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
print_log('global', ERROR, 'Unknown log type %s', $type);
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($ispkg) {
|
||||||
|
return undef unless defined $current_pkg_name;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $log_file_registry;
|
||||||
|
if ($ispkg) {
|
||||||
|
$log_file_registry = $package_log_files;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$log_file_registry = $global_log_files;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $lfchan = {};
|
||||||
|
my $channels = $$logdef{channel};
|
||||||
|
foreach my $ch (keys %$channels) {
|
||||||
|
$$lfchan{$ch} = str2level($$channels{$ch});
|
||||||
|
}
|
||||||
|
|
||||||
|
if (defined $$log_file_registry{$spec}) {
|
||||||
|
print_log('global', ERROR, 'Trying to reinitialize %s log type %s%s',
|
||||||
|
$type, (defined $ispkg ? 'application '.$current_pkg_name : 'global'),
|
||||||
|
($type eq 'file' ? ' path '.$$logdef{path} : ''));
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
my $lf = {
|
||||||
|
Definition => $logdef,
|
||||||
|
LogFunc => $func,
|
||||||
|
Channels => $lfchan
|
||||||
|
};
|
||||||
|
$$lf{PackageName} = $current_pkg_name if defined $current_pkg_name;
|
||||||
|
$$log_file_registry{$spec} = $lf;
|
||||||
|
$$logdef{Initialized} = 1;
|
||||||
|
return $lf;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub close_all_log_files ($)
|
||||||
|
{
|
||||||
|
my ($pkgonly) = @_;
|
||||||
|
|
||||||
|
my $speclist = [keys %$package_log_files];
|
||||||
|
foreach my $spec (@$speclist) {
|
||||||
|
my $lf = $$package_log_files{$spec};
|
||||||
|
delete $$package_log_files{$spec};
|
||||||
|
my $def = $$lf{Definition};
|
||||||
|
delete $$def{Initialized} if defined $def;
|
||||||
|
close_log_file($lf);
|
||||||
|
}
|
||||||
|
return if $pkgonly;
|
||||||
|
$speclist = [keys %$global_log_files];
|
||||||
|
foreach my $spec (@$speclist) {
|
||||||
|
my $lf = $$global_log_files{$spec};
|
||||||
|
delete $$global_log_files{$spec};
|
||||||
|
my $def = $$lf{Definition};
|
||||||
|
delete $$def{Initialized} if defined $def;
|
||||||
|
close_log_file($lf);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub init_log_files ()
|
||||||
|
{
|
||||||
|
foreach my $def (@$log_defs) {
|
||||||
|
next if defined $$def{Initialized};
|
||||||
|
init_log_file($def);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub is_pkg_only_path ($)
|
||||||
|
{
|
||||||
|
my ($path) = @_;
|
||||||
|
|
||||||
|
return $path =~ /%(pkgname)%/io;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub is_timebased_path ($)
|
||||||
|
{
|
||||||
|
my ($path) = @_;
|
||||||
|
|
||||||
|
return $path =~ /%(date|time|datetime)%/io;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_current_pkg_name ($)
|
||||||
|
{
|
||||||
|
my ($pkgname) = @_;
|
||||||
|
|
||||||
|
if (defined $current_pkg_name) {
|
||||||
|
return if defined $pkgname && $current_pkg_name eq $pkgname;
|
||||||
|
close_all_log_files(1);
|
||||||
|
}
|
||||||
|
$current_pkg_name = $pkgname;
|
||||||
|
init_log_files();
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_log_file_name ($$)
|
||||||
|
{
|
||||||
|
my ($pkgname, $path) = @_;
|
||||||
|
|
||||||
|
my $vars = get_default_vars();
|
||||||
|
set_datetime_vars($vars);
|
||||||
|
$$vars{pkgname} = $pkgname if defined $pkgname;
|
||||||
|
return substitute_variables($vars, $path, 1, $log_base_dir);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_log_template_name ($$)
|
||||||
|
{
|
||||||
|
my ($pkgname, $path) = @_;
|
||||||
|
|
||||||
|
my $vars = get_default_vars();
|
||||||
|
$$vars{date} = '????????';
|
||||||
|
$$vars{time} = '??????';
|
||||||
|
$$vars{datetime} = '????????-??????';
|
||||||
|
$$vars{pkgname} = $pkgname if defined $pkgname;
|
||||||
|
return substitute_variables($vars, $path, 1, $log_base_dir);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub generate_log_file_name ($)
|
||||||
|
{
|
||||||
|
my ($lf) = @_;
|
||||||
|
|
||||||
|
if (! defined $$lf{CurrentFileName}) {
|
||||||
|
my $def = $$lf{Definition};
|
||||||
|
$$lf{CurrentFileName} = get_log_file_name($$lf{PackageName}, $$def{path});
|
||||||
|
}
|
||||||
|
return $$lf{CurrentFileName};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub open_log_file ($)
|
||||||
|
{
|
||||||
|
my ($lf) = @_;
|
||||||
|
|
||||||
|
return 1 if defined $$lf{Handle};
|
||||||
|
my $path = generate_log_file_name($lf);
|
||||||
|
local *LH;
|
||||||
|
return 0 unless open(LH, '>>', $path);
|
||||||
|
LH->autoflush(1);
|
||||||
|
$$lf{Handle} = *LH;
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub close_log_file ($)
|
||||||
|
{
|
||||||
|
my ($lf) = @_;
|
||||||
|
|
||||||
|
if (defined $$lf{Handle}) {
|
||||||
|
close($$lf{Handle});
|
||||||
|
delete $$lf{Handle};
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub rotate_log_file ($)
|
||||||
|
{
|
||||||
|
my ($lf) = @_;
|
||||||
|
|
||||||
|
return unless defined $$lf{Handle};
|
||||||
|
my $def = $$lf{Definition};
|
||||||
|
return unless defined $def && defined $$def{type} && $$def{type} eq 'file';
|
||||||
|
|
||||||
|
my $rotate = $$def{rotate};
|
||||||
|
return unless defined $rotate;
|
||||||
|
my $template = $$rotate{name};
|
||||||
|
next unless defined $template;
|
||||||
|
$template = File::Spec->canonpath($template);
|
||||||
|
my $maxsize = $$rotate{'max-kb'};
|
||||||
|
return unless defined $maxsize && $maxsize > 0;
|
||||||
|
$maxsize *= 1024;
|
||||||
|
my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size) =
|
||||||
|
stat($$lf{Handle});
|
||||||
|
return unless defined $size && $size >= $maxsize;
|
||||||
|
close_log_file($lf);
|
||||||
|
|
||||||
|
if (! is_timebased_path($$def{path})) {
|
||||||
|
my $newname = get_log_file_name($$lf{PackageName}, $template);
|
||||||
|
my $oldname = $$lf{CurrentFileName};
|
||||||
|
rename($oldname, $newname);
|
||||||
|
}
|
||||||
|
delete $$lf{CurrentFileName};
|
||||||
|
|
||||||
|
my $maxhist = $$rotate{'max-num'};
|
||||||
|
if (defined $maxhist && $maxhist > 0) {
|
||||||
|
my ($vol, $dir, $file) = File::Spec->splitpath(get_log_template_name($$lf{PackageName}, $template));
|
||||||
|
$dir = $vol.$dir;
|
||||||
|
return if $dir =~ /\?/o;
|
||||||
|
if (opendir(DIR, $dir)) {
|
||||||
|
$dir .= '\\' unless $dir =~ /\\$/o;
|
||||||
|
$file =~ s/\./\\./go;
|
||||||
|
$file =~ s/\?/[0-9]/go;
|
||||||
|
my $list = [];
|
||||||
|
while (1) {
|
||||||
|
my $entry = readdir(DIR);
|
||||||
|
last unless defined $entry;
|
||||||
|
next if $entry eq '.' || $entry eq '..';
|
||||||
|
next unless $entry =~ /^$file$/;
|
||||||
|
push @$list, $entry;
|
||||||
|
}
|
||||||
|
closedir(DIR);
|
||||||
|
if (scalar @$list > $maxhist) {
|
||||||
|
$list = [sort @$list];
|
||||||
|
while (1) {
|
||||||
|
my $filename = $dir;
|
||||||
|
$filename .= shift @$list;
|
||||||
|
unlink($filename);
|
||||||
|
last if scalar @$list <= $maxhist;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
open_log_file($lf);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub setup_log_msg_prefix ($)
|
||||||
|
{
|
||||||
|
my ($msg) = @_;
|
||||||
|
|
||||||
|
return if defined $$msg{Prefix};
|
||||||
|
my $levelstr = $$msg{LevelStr};
|
||||||
|
$levelstr = $$msg{LevelStr} = level2str($$msg{Level}) unless defined $levelstr;
|
||||||
|
$$msg{Prefix} = strftime('%Y-%m-%d %H:%M:%S', localtime($$msg{TimeStamp})).
|
||||||
|
' ['.$$msg{Channel}.'/'.$levelstr.'] ';
|
||||||
|
}
|
||||||
|
|
||||||
|
sub process_log_msg ($)
|
||||||
|
{
|
||||||
|
my ($msg) = @_;
|
||||||
|
|
||||||
|
return if defined $$msg{Output};
|
||||||
|
$$msg{Output} = sprintf($$msg{Message}, @{$$msg{Parameters}});
|
||||||
|
}
|
||||||
|
|
||||||
|
sub print_to_log_file ($$)
|
||||||
|
{
|
||||||
|
my ($lf, $msg) = @_;
|
||||||
|
|
||||||
|
return 0 unless open_log_file($lf);
|
||||||
|
rotate_log_file($lf);
|
||||||
|
setup_log_msg_prefix($msg);
|
||||||
|
process_log_msg($msg);
|
||||||
|
print { $$lf{Handle} } $$msg{Prefix}.$$msg{Output}."\n";
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub print_stderr_log ($$)
|
||||||
|
{
|
||||||
|
my ($lf, $msg) = @_;
|
||||||
|
|
||||||
|
process_log_msg($msg);
|
||||||
|
print $orig_stderr $$msg{Output}."\n";
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub print_log_into_logfile ($$)
|
||||||
|
{
|
||||||
|
my ($lf, $msg) = @_;
|
||||||
|
|
||||||
|
my $func = $$lf{LogFunc};
|
||||||
|
return 0 unless defined $func;
|
||||||
|
my $channels = $$lf{Channels};
|
||||||
|
return 0 unless defined $channels;
|
||||||
|
my $minlevel = $$channels{$$msg{Channel}};
|
||||||
|
return 0 unless defined $minlevel;
|
||||||
|
return 1 unless compare_levels($minlevel, $$msg{Level}) <= 0;
|
||||||
|
return &{$func}($lf, $msg);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub print_log ($$$@)
|
||||||
|
{
|
||||||
|
my ($channel, $level, $message, @params) = @_;
|
||||||
|
|
||||||
|
my $msg = {
|
||||||
|
TimeStamp => time(),
|
||||||
|
Channel => $channel,
|
||||||
|
Level => $level,
|
||||||
|
Message => $message,
|
||||||
|
Parameters => [@params]
|
||||||
|
};
|
||||||
|
|
||||||
|
my $list = [values %$global_log_files];
|
||||||
|
push @$list, values %$package_log_files if $channel eq 'pkg';
|
||||||
|
my $ok = 0;
|
||||||
|
foreach my $lf (@$list) {
|
||||||
|
$ok = 1 if print_log_into_logfile($lf, $msg);
|
||||||
|
}
|
||||||
|
return if $ok;
|
||||||
|
print_log_into_logfile($fallback_log_file, $msg);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_log_defs ($)
|
||||||
|
{
|
||||||
|
my ($defs) = @_;
|
||||||
|
|
||||||
|
$log_defs = $defs;
|
||||||
|
init_log_files();
|
||||||
|
}
|
||||||
|
|
||||||
|
use Carp;
|
||||||
|
|
||||||
|
$SIG{__DIE__} = sub {
|
||||||
|
die @_ unless defined $^S && $^S == 0 && defined Carp::longmess;
|
||||||
|
print_log('global', FATAL, '%s',
|
||||||
|
join(', ', map {
|
||||||
|
my $x = $_;
|
||||||
|
$x =~ s/\r?\n[ \t]*$//os;
|
||||||
|
$x =~ s/\.\r?\n[ \t]*/. /gos;
|
||||||
|
$x =~ s/\r?\n[ \t]*/, /gos;
|
||||||
|
$x =~ s/^ +//o;
|
||||||
|
$x
|
||||||
|
} Carp::longmess(@_)));
|
||||||
|
die 'Fatal error: exiting'."\n";
|
||||||
|
};
|
||||||
|
$SIG{__WARN__} = sub {
|
||||||
|
print_log('global', WARNING, '%s',
|
||||||
|
join(', ', map {
|
||||||
|
my $x = $_;
|
||||||
|
$x =~ s/\r?\n[ \t]*$//os;
|
||||||
|
$x =~ s/\.\r?\n[ \t]*/. /gos;
|
||||||
|
$x =~ s/\r?\n[ \t]*/, /gos;
|
||||||
|
$x =~ s/^ +//o;
|
||||||
|
$x
|
||||||
|
} @_));
|
||||||
|
};
|
||||||
|
|
||||||
|
1;
|
||||||
274
pkgtool.pl
Normal file
274
pkgtool.pl
Normal file
|
|
@ -0,0 +1,274 @@
|
||||||
|
#!perl -w
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
my $DEFAULT_DOMAIN_NAME = 'karinthy.hu';
|
||||||
|
my $DEFAULT_CONFIG_FILE_NAME = 'pkgtool.cfg';
|
||||||
|
|
||||||
|
my $base_directory;
|
||||||
|
|
||||||
|
BEGIN {
|
||||||
|
$base_directory = $0;
|
||||||
|
if ($^O eq 'MSWin32') {
|
||||||
|
if ($base_directory =~ /^(.*[\/\\])[^\/\\]*$/o) {
|
||||||
|
$base_directory = $1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$base_directory = '.';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
if ($base_directory =~ /^(.*\/)[^\/]*$/o) {
|
||||||
|
$base_directory = $1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$base_directory = '.';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
push @INC, $base_directory if -d $base_directory;
|
||||||
|
}
|
||||||
|
|
||||||
|
use logging;
|
||||||
|
use cmdline;
|
||||||
|
use cfgparser;
|
||||||
|
use pkgtool;
|
||||||
|
|
||||||
|
my $print_help;
|
||||||
|
my $config_file_name;
|
||||||
|
my $proxycmd = $base_directory.'\\install.cmd';
|
||||||
|
my $standalone = 0;
|
||||||
|
my $globals = {};
|
||||||
|
|
||||||
|
sub set_standalone_flag ($)
|
||||||
|
{
|
||||||
|
my ($param) = @_;
|
||||||
|
|
||||||
|
$standalone = $param;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_global ($)
|
||||||
|
{
|
||||||
|
my ($param) = @_;
|
||||||
|
|
||||||
|
if ($param =~ /^([^=]+)=(.*)$/o) {
|
||||||
|
my $key = $1;
|
||||||
|
my $value = $2;
|
||||||
|
$$globals{$key} = $value;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $CONFIG_OPTIONS = [{
|
||||||
|
General => 1,
|
||||||
|
Option => '<command>',
|
||||||
|
Description => 'Command: list, status, update'
|
||||||
|
}, {
|
||||||
|
Short => 'c',
|
||||||
|
Long => 'config',
|
||||||
|
Description => 'Config file name',
|
||||||
|
Type => 'string',
|
||||||
|
Default => $DEFAULT_CONFIG_FILE_NAME,
|
||||||
|
StoreInto => \$config_file_name
|
||||||
|
}, {
|
||||||
|
Short => 'd',
|
||||||
|
Long => 'debug',
|
||||||
|
Description => 'Debug log level (0=off)',
|
||||||
|
Type => 'integer',
|
||||||
|
Default => 0,
|
||||||
|
StoreFunc => \&set_log_level
|
||||||
|
}, {
|
||||||
|
Short => 'g',
|
||||||
|
Long => 'global',
|
||||||
|
Description => 'Set generic variable (key=value)',
|
||||||
|
Type => 'keyvalue',
|
||||||
|
StoreFunc => \&set_global
|
||||||
|
}, {
|
||||||
|
Short => 'h',
|
||||||
|
Long => 'help',
|
||||||
|
Description => 'Print usage',
|
||||||
|
Type => 'flag',
|
||||||
|
Default => 0,
|
||||||
|
StoreInto => \$print_help
|
||||||
|
}, {
|
||||||
|
Short => 's',
|
||||||
|
Long => 'standalone',
|
||||||
|
Description => 'Skip accessing install server',
|
||||||
|
Type => 'flag',
|
||||||
|
StoreFunc => \&set_standalone_flag
|
||||||
|
}, {
|
||||||
|
Short => 'v',
|
||||||
|
Long => 'verbose',
|
||||||
|
Description => 'Verbose logging',
|
||||||
|
Type => 'flag',
|
||||||
|
Default => 0,
|
||||||
|
StoreFunc => \&set_verbose_flag
|
||||||
|
}];
|
||||||
|
|
||||||
|
set_pkgtool_dir($base_directory);
|
||||||
|
my $commands = parse_cmdline($CONFIG_OPTIONS);
|
||||||
|
if (! defined $commands || scalar @$commands < 1 || $print_help) {
|
||||||
|
print_usage($CONFIG_OPTIONS);
|
||||||
|
exit(1);
|
||||||
|
}
|
||||||
|
my $cmd = $$commands[0];
|
||||||
|
if ($cmd ne 'list' && $cmd ne 'status' && $cmd ne 'update') {
|
||||||
|
print_log('global', ERROR, 'Unknown command: %s', $cmd);
|
||||||
|
print_usage($CONFIG_OPTIONS);
|
||||||
|
exit(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
my $dns_domain = get_default_dnsdomain();
|
||||||
|
$dns_domain = $DEFAULT_DOMAIN_NAME unless defined $dns_domain;
|
||||||
|
my $install_host = 'install.'.$dns_domain;
|
||||||
|
|
||||||
|
my $config = parse_cfg_file(substitute_variables({}, $config_file_name,
|
||||||
|
1, $base_directory, 'global'), get_cfg_syntax());
|
||||||
|
exit(1) unless defined $config;
|
||||||
|
$$config{'generic-variables'} = [] unless defined $$config{'generic-variables'};
|
||||||
|
$$config{'proxy-command'} = $proxycmd;
|
||||||
|
$$config{'install-host'} = $install_host;
|
||||||
|
set_log_base_dir(substitute_variables(get_default_vars(),
|
||||||
|
$$config{'log-directory'}, 1, $base_directory, 'global'));
|
||||||
|
set_log_defs($$config{logging}) if defined $$config{logging};
|
||||||
|
if ($standalone) {
|
||||||
|
print_log('global', INFO, 'Skipping install server');
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
print_log('global', INFO, 'Install server: %s', $install_host);
|
||||||
|
my $error = get_install_sets($config);
|
||||||
|
exit(1) if defined $error;
|
||||||
|
}
|
||||||
|
my $error = scan_package_dirs($config, $base_directory);
|
||||||
|
exit(1) if defined $error;
|
||||||
|
$$config{'package-def'} = {} unless defined $$config{'package-def'};
|
||||||
|
$$config{'global-variables'} = $globals;
|
||||||
|
|
||||||
|
my $db = {};
|
||||||
|
read_installed_packages($db);
|
||||||
|
read_installed_patches($db);
|
||||||
|
|
||||||
|
my $counters = {
|
||||||
|
RebootFlag => 0,
|
||||||
|
InstalledList => [],
|
||||||
|
InstalledCount => 0,
|
||||||
|
RemovedList => [],
|
||||||
|
RemovedCount => 0,
|
||||||
|
FailList => [],
|
||||||
|
FailCount => 0,
|
||||||
|
SkipList => [],
|
||||||
|
SkipCount => 0,
|
||||||
|
ToInstallList => [],
|
||||||
|
ToInstallCount => 0,
|
||||||
|
ToRemoveList => [],
|
||||||
|
ToRemoveCount => 0
|
||||||
|
};
|
||||||
|
|
||||||
|
my $stats;
|
||||||
|
my $results;
|
||||||
|
if ($cmd eq 'list') {
|
||||||
|
print_log('global', INFO, '== Listing packages');
|
||||||
|
my $pkgdefs = $$config{'package-def'};
|
||||||
|
foreach my $key (sort keys %$pkgdefs) {
|
||||||
|
my $def = $$pkgdefs{$key};
|
||||||
|
next unless defined $def;
|
||||||
|
print_log('global', INFO, 'Definition: %s "%s"', $key, $$def{description});
|
||||||
|
}
|
||||||
|
my $installed = $$db{Installed};
|
||||||
|
foreach my $instname (sort keys %$installed) {
|
||||||
|
my $inst = $$installed{$instname};
|
||||||
|
next unless defined $inst && defined $$inst{DisplayName} && defined $$inst{DisplayVersion};
|
||||||
|
print_log('global', INFO, 'Installed: %s "%s" "%s" "%s"',
|
||||||
|
$$inst{UserPackage} ? 'user' : 'global', $instname, $$inst{DisplayName}, $$inst{DisplayVersion});
|
||||||
|
}
|
||||||
|
$installed = $$db{InstalledSpec};
|
||||||
|
foreach my $instname (sort keys %$installed) {
|
||||||
|
my $inst = $$installed{$instname};
|
||||||
|
next unless defined $inst && defined $$inst{DisplayName} && defined $$inst{DisplayVersion};
|
||||||
|
print_log('global', INFO, 'Installed: %s "%s" "%s" "%s"',
|
||||||
|
$$inst{UserPackage} ? 'user' : 'global', $instname, $$inst{DisplayName}, $$inst{DisplayVersion});
|
||||||
|
}
|
||||||
|
print_log('global', INFO, '== Listing patches');
|
||||||
|
my $patches = $$db{Patches};
|
||||||
|
foreach my $kb (sort { ${$$patches{$a}}{Number} <=> ${$$patches{$b}}{Number} } keys %$patches) {
|
||||||
|
my $patch = $$patches{$kb};
|
||||||
|
next unless defined $patch;
|
||||||
|
print_log('global', INFO, 'Installed: %s %s %s %s',
|
||||||
|
$$patch{KB},
|
||||||
|
($$patch{Type} eq 'OS' ? 'OS' : 'Packages('.join(',', sort keys %{$$patch{Packages}}).')'),
|
||||||
|
($$patch{Original} ? 'original' : 'update'),
|
||||||
|
($$patch{Current} ? 'current' : 'obsoleted'));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
elsif ($cmd eq 'status') {
|
||||||
|
print_log('global', INFO, '== Displaying package status');
|
||||||
|
my $pkgdefs = $$config{'package-def'};
|
||||||
|
my $pkgs = $$config{'packages'};
|
||||||
|
foreach my $pkg (@$pkgs) {
|
||||||
|
handle_pkg($config, $base_directory, $db, $pkg, $counters, 0);
|
||||||
|
}
|
||||||
|
$stats = '';
|
||||||
|
}
|
||||||
|
elsif ($cmd eq 'update') {
|
||||||
|
my $pkgname = $$commands[1];
|
||||||
|
print_log('global', INFO, '== Updating packages/patches: %s', defined $pkgname ? $pkgname : 'all');
|
||||||
|
my $pkgdefs = $$config{'package-def'};
|
||||||
|
my $pkgs = $$config{'packages'};
|
||||||
|
foreach my $pkg (@$pkgs) {
|
||||||
|
my $name = $$pkg{name};
|
||||||
|
next if defined $pkgname && $name ne $pkgname;
|
||||||
|
handle_pkg($config, $base_directory, $db, $pkg, $counters, 1);
|
||||||
|
}
|
||||||
|
$stats = '';
|
||||||
|
}
|
||||||
|
if (defined $stats) {
|
||||||
|
$results = '';
|
||||||
|
if ($$counters{SkipCount} > 0) {
|
||||||
|
$stats .= $stats eq '' ? 'S' : ', s';
|
||||||
|
$stats .= sprintf('kipping %d', $$counters{SkipCount});
|
||||||
|
$results .= $results eq '' ? 'S' : ', s';
|
||||||
|
$results .= 'kipping: '.join(',', @{$$counters{SkipList}});
|
||||||
|
}
|
||||||
|
if ($$counters{FailCount} > 0) {
|
||||||
|
$stats .= $stats eq '' ? 'F' : ', f';
|
||||||
|
$stats .= sprintf('ailed %d', $$counters{FailCount});
|
||||||
|
$results .= $results eq '' ? 'F' : ', f';
|
||||||
|
$results .= 'ailed: '.join(',', @{$$counters{FailList}});
|
||||||
|
}
|
||||||
|
if ($$counters{ToInstallCount} > 0) {
|
||||||
|
$stats .= $stats eq '' ? 'To ' : ', to ';
|
||||||
|
$stats .= sprintf('install %d', $$counters{ToInstallCount});
|
||||||
|
$results .= $results eq '' ? 'To ' : ', to ';
|
||||||
|
$results .= 'install: '.join(',', @{$$counters{ToInstallList}});
|
||||||
|
}
|
||||||
|
if ($$counters{ToRemoveCount} > 0) {
|
||||||
|
$stats .= $stats eq '' ? 'To ' : ', to ';
|
||||||
|
$stats .= sprintf('remove %d', $$counters{ToRemoveCount});
|
||||||
|
$results .= $results eq '' ? 'To ' : ', to ';
|
||||||
|
$results .= 'remove: '.join(',', @{$$counters{ToRemoveList}});
|
||||||
|
}
|
||||||
|
if ($cmd eq 'update') {
|
||||||
|
$stats .= $stats eq '' ? 'I' : ', i';
|
||||||
|
$stats .= sprintf('nstalled %d, removed %d', $$counters{InstalledCount}, $$counters{RemovedCount});
|
||||||
|
$results .= $results eq '' ? 'I' : ', i';
|
||||||
|
if (scalar @{$$counters{InstalledList}} > 0) {
|
||||||
|
$results .= 'nstalled: '.join(',', @{$$counters{InstalledList}});
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$results .= 'nstalled: -';
|
||||||
|
}
|
||||||
|
if (scalar @{$$counters{RemovedList}} > 0) {
|
||||||
|
$results .= ', removed: '.join(',', @{$$counters{RemovedList}});
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$results .= ', removed: -';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if ($$counters{RebootFlag}) {
|
||||||
|
$stats .= $stats eq '' ? 'R' : ', r';
|
||||||
|
$stats .= sprintf('eboot needed!');
|
||||||
|
}
|
||||||
|
}
|
||||||
|
print_log('global', WARNING, 'Package/patch statistics: %s', $stats) if defined $stats;
|
||||||
|
print_log('global', INFO, '%s', $results) if defined $results;
|
||||||
|
|
||||||
|
close_all_log_files(0);
|
||||||
|
exit(0);
|
||||||
2851
pkgtool.pm
Normal file
2851
pkgtool.pm
Normal file
File diff suppressed because it is too large
Load diff
Loading…
Reference in a new issue