commit 103d08f96a18f5380879c54e024e0384b2ff9e72 Author: Valko Laszlo Date: Sun Nov 12 07:29:03 2017 +0100 Initial commit diff --git a/README.md b/README.md new file mode 100644 index 0000000..e69de29 diff --git a/cfgparser.pm b/cfgparser.pm new file mode 100644 index 0000000..644ddbf --- /dev/null +++ b/cfgparser.pm @@ -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 () { + $contents .= $_; + } + close(FILE); + return parse_structure($path, $contents, $grammar); +} + +1; diff --git a/cmdline.pm b/cmdline.pm new file mode 100644 index 0000000..a3436aa --- /dev/null +++ b/cmdline.pm @@ -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.' []'.$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; diff --git a/logging.pm b/logging.pm new file mode 100644 index 0000000..6b4fa80 --- /dev/null +++ b/logging.pm @@ -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 = ''; + $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; diff --git a/pkgtool.pl b/pkgtool.pl new file mode 100644 index 0000000..3d52048 --- /dev/null +++ b/pkgtool.pl @@ -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 => '', + 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); diff --git a/pkgtool.pm b/pkgtool.pm new file mode 100644 index 0000000..f7ab0fe --- /dev/null +++ b/pkgtool.pm @@ -0,0 +1,2851 @@ +package pkgtool; + +use strict; + +require Exporter; +@pkgtool::ISA = qw(Exporter); +@pkgtool::EXPORT = qw( + get_cfg_syntax + get_hostname + get_default_dnsdomain + read_installed_patches + read_installed_packages + scan_package_dirs + handle_pkg + get_install_sets +); + +use logging; +use cfgparser; + +use Symbol 'gensym'; +use Cwd; +use Fcntl qw(:DEFAULT :mode);; +use File::Spec; +use Sys::Hostname; +use IPC::Open3; +use Win32; +use Win32::File; +use Win32::IPConfig; +use Win32::API; +use Win32::TieRegistry; +use Win32::File::VersionInfo; +use Win32API::File qw(:Func :Misc :FILE_SHARE_ :GENERIC_); +use LWP::UserAgent; + +my $pkgdef_syntax = { + Type => 'map', + Elements => { + Type => 'struct', + Check => \&check_cfg_pkgdef, + Keywords => { + 'description' => { + Type => 'string', + Mandatory => 1 + }, + 'source-directory' => { + Type => 'string', + Mandatory => 1 + }, + 'user-product' => { + Type => 'integer' + }, + 'available' => { + Type => 'string' + }, + 'patching-version' => { + Type => 'string' + }, + 'install-check' => { + Type => 'string' + }, + 'match' => { + Type => 'list', + Elements => { + Type => 'struct', + Keywords => { + 'expression' => { + Type => 'string', + Mandatory => 1 + } + } + } + }, + 'version-source' => { + Type => 'string' + }, + 'extract-version-field' => { + Type => 'integer' + }, + 'extract-version-regex' => { + Type => 'string' + }, + 'extract-version' => { + Type => 'list', + Elements => { + Type => 'struct', + Check => \&check_cfg_extract_step, + Keywords => { + 'type' => { + Type => 'string', + Mandatory => 1 + }, + 'variable' => { + Type => 'string' + }, + 'expression' => { + Type => 'string' + } + } + } + }, + 'match-version-condition' => { + Type => 'string' + }, + 'match-version' => { + Type => 'string' + }, + 'install' => { + Type => 'list', + Elements => { + Type => 'struct', + Check => \&check_cfg_install_step, + Keywords => { + 'type' => { + Type => 'string', + Mandatory => 1 + }, + 'condition' => { + Type => 'string' + }, + 'ignore-failure' => { + Type => 'integer' + }, + 'background' => { + Type => 'integer' + }, + 'recurse' => { + Type => 'integer' + }, + 'chdir' => { + Type => 'string' + }, + 'variable' => { + Type => 'string' + }, + 'filename' => { + Type => 'string' + }, + 'expression' => { + Type => 'string' + }, + 'source-file' => { + Type => 'string' + }, + 'target-file' => { + Type => 'string' + }, + 'parameters' => { + Type => 'list', + Elements => { + Type => 'string' + } + } + } + } + }, + 'remove-parameters' => { + Type => 'list', + Elements => { + Type => 'string' + } + }, + 'package-versions' => { + Type => 'map', + Elements => { + Type => 'or', + Options => [{ + Type => 'string' + }, { + Type => 'struct', + Check => \&check_cfg_pkg_version_struct, + Keywords => { + 'type' => { + Type => 'string', + Mandatory => 1 + }, + 'expression' => { + Type => 'string' + } + } + }] + } + } + } + } +}; + +my $patchdef_syntax = { + Type => 'map', + Elements => { + Type => 'struct', + Keywords => { + 'description' => { + Type => 'string', + Mandatory => 1 + }, + 'base-directory' => { + Type => 'string', + Mandatory => 1 + }, + 'available' => { + Type => 'string' + }, + 'patches' => { + Type => 'list', + Mandatory => 1, + Elements => { + Type => 'struct', + Check => \&check_cfg_patchdef, + Keywords => { + 'source-directory' => { + Type => 'string', + Mandatory => 1 + }, + 'source-file' => { + Type => 'string' + }, + 'available' => { + Type => 'string' + }, + 'chdir' => { + Type => 'string', + }, + 'packages' => { + Type => 'list', + Elements => { + Type => 'string' + } + }, + 'kb' => { + Type => 'list', + Mandatory => 1, + Elements => { + Type => 'string' + } + }, + 'style' => { + Type => 'string', + Mandatory => 1 + }, + 'kbname' => { + Type => 'string' + }, + 'prefix' => { + Type => 'string' + }, + 'edition' => { + Type => 'string' + }, + 'arch' => { + Type => 'string' + }, + 'suffix' => { + Type => 'string' + }, + 'parameters' => { + Type => 'list', + Elements => { + Type => 'string' + } + } + } + } + } + } + } +}; + +my $pkgdef_cfg_syntax = { + Type => 'struct', + Keywords => { + 'base-directory' => { + Type => 'string', + }, + 'available' => { + Type => 'string' + }, + 'package-def' => $pkgdef_syntax, + 'patch-def' => $patchdef_syntax + } +}; + +my $global_cfg_syntax = { + Type => 'struct', + Keywords => { + 'install-server' => { + Type => 'string', + Mandatory => 1 + }, + 'install-share' => { + Type => 'string', + Mandatory => 1 + }, + 'install-path' => { + Type => 'string', + Mandatory => 1 + }, + 'log-directory' => { + Type => 'string', + Mandatory => 1 + }, + 'generic-msi-parameters' => { + Type => 'list', + Elements => { + Type => 'string' + } + }, + 'generic-variables' => { + Type => 'list', + Elements => { + Type => 'struct', + Keywords => { + 'variable' => { + Type => 'string', + Mandatory => 1 + }, + 'expression' => { + Type => 'string', + Mandatory => 1 + } + } + } + + }, + 'logging' => { + Type => 'list', + Elements => { + Type => 'struct', + Keywords => { + 'type' => { + Type => 'string', + Mandatory => 1, + }, + 'channel' => { + Type => 'map', + Mandatory => 1, + Elements => { + Type => 'string' + } + }, + 'path' => { + Type => 'string' + }, + 'rotate' => { + Type => 'struct', + Keywords => { + 'name' => { + Type => 'string', + Mandatory => 1, + }, + 'max-kb' => { + Type => 'integer' + }, + 'max-num' => { + Type => 'integer' + } + } + } + } + } + }, + 'scan' => { + Type => 'struct', + Keywords => { + 'filename' => { + Type => 'string', + Mandatory => 1 + }, + 'max-depth' => { + Type => 'integer' + }, + 'directories' => { + Type => 'list', + Mandatory => 1, + Elements => { + Type => 'string' + } + } + } + }, + 'mbr-drive' => { + Type => 'string' + }, + 'package-sets' => { + Type => 'map', + Elements => { + Type => 'list', + Elements => { + Type => 'string' + } + } + }, + 'packages' => { + Type => 'list', + Mandatory => 1, + Elements => { + Type => 'struct', + Keywords => { + 'name' => { + Type => 'string', + Mandatory => 1 + }, + 'condition' => { + Type => 'string' + }, + 'mbr-source-file' => { + Type => 'string' + }, + 'remove-version' => { + Type => 'string' + }, + 'install-version' => { + Type => 'string' + }, + 'patch-packages' => { + Type => 'list', + Elements => { + Type => 'string' + } + }, + 'user' => { + Type => 'string' + }, + 'password' => { + Type => 'string' + }, + 'fullname' => { + Type => 'string' + }, + 'pwexpires' => { + Type => 'string' + }, + 'pwchange' => { + Type => 'integer' + }, + 'deleted' => { + Type => 'integer' + }, + 'enabled' => { + Type => 'integer' + } + } + } + } + } +}; + +sub get_cfg_syntax () +{ + return $global_cfg_syntax; +} + +#$Registry->Delimiter('/'); +$Registry->ArrayValues(1); + +sub get_hostname () +{ + return hostname(); +} + +sub get_default_dnsdomain () +{ + my $hostname = get_hostname(); + return undef unless defined $hostname; + my $ipconfig = Win32::IPConfig->new($hostname); + return undef unless defined $ipconfig; + my $found; + foreach my $adapter ($ipconfig->get_adapters()) { + my $domain = $adapter->get_domain(); + next unless defined $domain; + $found = $domain; + last; + } + return $found; +} + +sub get_registry_value ($) +{ + my ($node) = @_; + + my $value = $$node[0]; + return undef unless defined $value; + my $type = $$node[1]; + if ($type == 4 && $value =~ /^0x[0-9a-f]+$/oi) { + # REG_DWORD + return hex($value); + } + return $value; +} + +sub read_os_patches ($$) +{ + my ($patches, $registry) = @_; + + foreach my $name ($registry->SubKeyNames) { + my $sub = $registry->{$name}; + next unless defined $sub; + my $installname = get_registry_value($sub->{'InstallName'}); + my $installclient = get_registry_value($sub->{'InstallClient'}); + my $state = get_registry_value($sub->{'CurrentState'}); + next unless defined $installname && defined $installclient; + next unless $installname =~ /^[^~]*KB(\d[0-9a-zA-Z]+)~/o; + my $original = $installclient eq 'DISM Package Manager Provider'; + my $update = $installclient eq 'WindowsUpdateAgent'; + next unless $original || $update; + my $kb = $1; + my $number = $kb =~ /^(\d+)/o ? $1 : $kb; + my $p = $$patches{$kb}; + if (! defined $p) { + $p = $$patches{$kb} = { + Type => 'OS', + Packages => { OS => 1 }, + InstallName => $name, + InstallClient => $installclient, + Original => $original, + Update => $update, + KB => $kb, + Number => $number, + Current => 0, + Flags => 0 + }; + } + if (defined $state) { + $$p{Flags} |= $state; + $$p{Current} = 1 if $state & 0x20; + } + } +} + +sub xread_pkg_patches ($$) +{ + my ($patches, $registry) = @_; + + foreach my $pkgname ($registry->SubKeyNames) { + my $pkg = $registry->{$pkgname}; + next unless defined $pkg; + foreach my $kbname ($pkg->SubKeyNames) { + next unless defined $kbname && $kbname =~ /KB(\d[0-9a-zA-Z]+)/o; + my $kb =$1; + my $sub = $pkg->{$kbname}; + next unless defined $sub; + my $installername = get_registry_value($sub->{'InstallerName'}); + my $state = get_registry_value($sub->{'ThisVersionInstalled'}); + my $update = defined $installername && $installername eq 'Windows Installer'; + my $number = $kb =~ /^(\d+)/o ? $1 : $kb; + my $p = $$patches{$kb}; + if (! defined $p) { + $p = $$patches{$kb} = { + Type => 'Package', + Packages => {}, + InstallClient => $installername, + Original => ! $update, + Update => $update, + KB => $kb, + Number => $number, + Flags => 0 + }; + } + ${$$p{Packages}}{$pkgname} = 1; + if (defined $state && $state eq 'Y') { + $$p{Flags} |= 0x20; + $$p{Current} = 1; + } + } + } +} + +sub read_pkg_patches ($$) +{ + my ($patches, $registry) = @_; + + foreach my $id ($registry->SubKeyNames) { + my $pkg = $registry->{$id}; + next unless defined $pkg; + my $props = $pkg->{'InstallProperties'}; + next unless defined $props; + my $regpatches = $pkg->{'Patches'}; + next unless defined $regpatches; + my $pkgname = get_registry_value($props->{'DisplayName'}); + next unless defined $pkgname; + foreach my $patchid ($regpatches->SubKeyNames) { + my $patch = $regpatches->{$patchid}; + next unless defined $patch; + my $dispname = get_registry_value($patch->{'DisplayName'}); + my $url = get_registry_value($patch->{'MoreInfoURL'}); + my $kb; + if (defined $dispname && $dispname =~ /KB(\d[0-9a-zA-Z]+)/o) { + $kb = $1; + } + elsif (defined $url && $url =~ /^http.*\/kb\/(\d[0-9a-zA-Z]+)$/o) { + $kb = $1; + } + else { + next; + } + my $state = get_registry_value($patch->{'State'}); + my $number = $kb =~ /^(\d+)/o ? $1 : $kb; + my $p = $$patches{$kb}; + if (! defined $p) { + $p = $$patches{$kb} = { + Type => 'Package', + Packages => {}, + Original => 0, + Update => 1, + KB => $kb, + Number => $number, + Current => 0, + Flags => 0 + }; + } + ${$$p{Packages}}{$pkgname} = 1; + if (defined $state && $state =~ /^1$/o) { + $$p{Flags} |= 0x20; + $$p{Current} = 1; + } + } + } +} + +sub read_packages ($$$$) +{ + my ($packages, $registry, $wow6432, $userdata) = @_; + + foreach my $name ($registry->SubKeyNames) { + my $sub = $registry->{$name}; + next unless defined $sub; + if ($userdata) { + $sub = $sub->{'InstallProperties'}; + next unless defined $sub; + } + my $pub = get_registry_value($sub->{'Publisher'}); + my $dispname = get_registry_value($sub->{'DisplayName'}); + my $dispver = get_registry_value($sub->{'DisplayVersion'}); + my $instdate = get_registry_value($sub->{'InstallDate'}); + my $instloc = get_registry_value($sub->{'InstallLocation'}); + my $syscomp = get_registry_value($sub->{'SystemComponent'}); + my $parentkeyname = get_registry_value($sub->{'ParentKeyName'}); + my $wininst = get_registry_value($sub->{'WindowsInstaller'}); + my $reltype = get_registry_value($sub->{'ReleaseType'}); + my $uninst = get_registry_value($sub->{'UninstallString'}); + my $quninst = get_registry_value($sub->{'QuietUninstallString'}); +# next if defined $syscomp && $syscomp && ! $userdata; + next if defined $parentkeyname; + + my $winid; + if ($name =~ /^\{([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])-([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])-([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])-([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])-([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])([0-9A-F])\}$/oi) { + $winid = $8.$7.$6.$5.$4.$3.$2.$1.$12.$11.$10.$9.$16.$15.$14.$13.$18.$17.$20.$19.$22.$21.$24.$23.$26.$25.$28.$27.$30.$29.$32.$31; + } + my $inst = { + Name => $name, + WinID => $winid, + Publisher => $pub, + DisplayName => $dispname, + DisplayVersion =>$dispver, + InstallDate => $instdate, + InstallLocation => $instloc, + SystemComponent => $syscomp, + WindowsInstaller => $wininst, + ReleaseType => $reltype, + Type => $wow6432 ? 'wow6432' : 'normal', + Uninstall => $uninst, + QUninstall => $uninst, + UserPackage => $userdata + }; + $$packages{$name} = $inst; + } +} + +sub get_exe_version ($$) +{ + my ($channel, $path) = @_; + + print_log($channel, DEBUG3, 'Trying to get package version from exe %s', $path); + my $info = GetFileVersionInfo($path); + return undef unless defined $info; + print_log($channel, DEBUG3, 'Found version number %s', $info->{'ProductVersion'}); + return $info->{'ProductVersion'}; +} + +sub read_installed_patches ($) +{ + my ($db) = @_; + + delete $$db{PatchesChanged}; + my $patches = {}; + my $winver = get_win_version(); + if ($winver ge '6.0') { + my $cbspatches = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Component Based Servicing\\Packages\\', { Access => 'KEY_READ' }); + if (! defined $cbspatches) { + print_log('global', ERROR, 'Cannot find registry entry: %s', 'HKLM\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Component Based Servicing\\Packages'); + return undef; + } + read_os_patches($patches, $cbspatches); + } +# my $updates = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Updates\\', { Access => 'KEY_READ' }); +# if (! defined $updates) { +# print_log('global', ERROR, 'Cannot find registry entry: %s', 'HKLM\\SOFTWARE\\Microsoft\\Updates'); +# return undef; +# } + my $updates = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Installer\\UserData\\S-1-5-18\\Products\\', { Access => 'KEY_READ' }); + if (! defined $updates) { + print_log('global', ERROR, 'Cannot find registry entry: %s', 'HKLM\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Installer\\UserData\\S-1-5-18\\Products'); + return undef; + } + read_pkg_patches($patches, $updates); + $$db{Patches} = $patches; + return $db; + +} + +sub refresh_installed_patches ($) +{ + my ($db) = @_; + + print_log('global', DEBUG4, 'Refreshing patches'); + if (defined $$db{Patches}) { + return unless defined $$db{PatchesChanged}; + print_log('global', DEBUG1, 'Rereading changed patch database from registry'); + } + read_installed_patches($db); +} + +sub read_installed_packages ($) +{ + my ($db) = @_; + + delete $$db{Changed}; + my $packages = {}; + my $uninst = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\', { Access => 'KEY_READ' }); + if (! defined $uninst) { + print_log('global', ERROR, 'Cannot find registry entry: %s', 'HKLM\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall'); + return undef; + } + read_packages($packages, $uninst, 0, 0); + $uninst = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Wow6432Node\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\', { Access => 'KEY_READ' }); + if (defined $uninst) { + read_packages($packages, $uninst, 1, 0); + } + $uninst = $Registry->Open('HKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\', { Access => 'KEY_READ' }); + if (defined $uninst) { + read_packages($packages, $uninst, 0, 0); + } + $uninst = $Registry->Open('HKEY_CURRENT_USER\\Software\\Wow6432Node\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\', { Access => 'KEY_READ' }); + if (defined $uninst) { + read_packages($packages, $uninst, 1, 0); + } + my $specpackages = {}; + my $products = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Installer\\UserData\\S-1-5-18\\Products\\', { Access => 'KEY_READ' }); + if (defined $products) { + read_packages($specpackages, $products, 0, 1); + } + $products = $Registry->Open('HKEY_LOCAL_MACHINE\\SOFTWARE\\Wow6432Node\\Microsoft\\Windows\\CurrentVersion\\Installer\\UserData\\S-1-5-18\\Products\\', { Access => 'KEY_READ' }); + if (defined $products) { + read_packages($specpackages, $products, 1, 1); + } + $$db{Installed} = $packages; + $$db{InstalledSpec} = $specpackages; + return $db; +} + +sub refresh_installed_packages ($) +{ + my ($db) = @_; + + if (defined $$db{Installed}) { + return unless defined $$db{Changed}; + print_log('global', DEBUG1, 'Rereading changed package database from registry'); + } + read_installed_packages($db); +} + +sub check_cfg_pkgdef ($$) +{ + my ($install, $label) = @_; + + if (! defined $$install{'install-check'} && ! defined $$install{'match'}) { + print_log('pkg', ERROR, 'Package definition "match" or "install-check" at %s', $label); + return 0; + } + if (! defined $$install{'match-version-condition'} && ! defined $$install{'match-version'}) { + print_log('pkg', ERROR, 'Package definition "match-version" or "match-version-condition" at %s', $label); + return 0; + } + + return 1; +} + +sub check_cfg_patchdef ($$) +{ + my ($patch, $label) = @_; + + my $style = $$patch{style}; + if ($style eq 'exe') { + } + elsif ($style eq 'msu') { + } + elsif ($style eq 'msp') { + } + else { + print_log('pkg', ERROR, 'Unknown patch style at %s', $label.': '.$style); + return 0; + } + + return 1; +} + +sub check_cfg_extract_step ($$) +{ + my ($install, $label) = @_; + + my $type = $$install{type}; + + if ($type eq 'setvar') { + if (! defined $$install{'variable'} || $$install{'variable'} eq '') { + print_log('pkg', ERROR, 'Version extraction step missing "variable" at %s', $label); + return 0; + } + if (! defined $$install{'expression'} && ! defined $$install{'filename'}) { + print_log('pkg', ERROR, 'Version extraction step missing "expression" or "filename" at %s', $label); + return 0; + } + } + else { + print_log('pkg', ERROR, 'Unknown install step type at %s', $label.': '.$type); + return 0; + } + + return 1; +} + +sub check_cfg_install_step ($$) +{ + my ($install, $label) = @_; + + my $type = $$install{type}; + + if ($type eq 'setvar') { + if (! defined $$install{'variable'} || $$install{'variable'} eq '') { + print_log('pkg', ERROR, 'Install step missing "variable" at %s', $label); + return 0; + } + if (! defined $$install{'expression'} && ! defined $$install{'filename'}) { + print_log('pkg', ERROR, 'Install step missing "expression" or "filename" at %s', $label); + return 0; + } + } + elsif ($type eq 'msi') { + if (! defined $$install{'source-file'} || $$install{'source-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "source-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'msp') { + if (! defined $$install{'source-file'} || $$install{'source-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "source-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'run') { + if (! defined $$install{'source-file'} || $$install{'source-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "source-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'file') { + if (! defined $$install{'source-file'} || $$install{'source-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "source-file" at %s', $label); + return 0; + } + if (! defined $$install{'target-file'} || $$install{'target-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "target-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'delete-file') { + if (! defined $$install{'target-file'} || $$install{'target-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "target-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'delete-dir') { + if (! defined $$install{'target-file'} || $$install{'target-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "target-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'reg') { + if (! defined $$install{'source-file'} || $$install{'source-file'} eq '') { + print_log('pkg', ERROR, 'Install step missing "source-file" at %s', $label); + return 0; + } + } + elsif ($type eq 'remove-pkg') { + } + else { + print_log('pkg', ERROR, 'Unknown install step type at %s', $label.': '.$type); + return 0; + } + + return 1; +} + +sub check_cfg_pkg_version_struct ($$) +{ + my ($option, $label) = @_; + + my $type = $$option{type}; + + if ($type eq 'expression') { + if (! defined $$option{'expression'}) { + print_log('pkg', ERROR, 'Package version option missing "expression" at %s', $label); + return 0; + } + } + else { + print_log('pkg', ERROR, 'Unknown package version option type at %s', $label.': '.$type); + return 0; + } + + return 1; +} + +sub evaluate_expression ($$$$) +{ + my ($channel, $vars, $inst, $expression) = @_; + + my $value = eval $expression; + my $error = $@; + if (defined $error && $error ne '') { + $error =~ s/\r?\n[ \t]*$//os; + $error =~ s/\r?\n[ \t]*/ /gos; + return (undef, $error); + } + return ($value, undef); +} + +sub check_condition ($$$) +{ + my ($channel, $vars, $condition) = @_; + + my ($value, $error) = evaluate_expression($channel, $vars, {}, $condition); + + if (defined $error && $error ne '') { + return (undef, sprintf('Evaluating condition expression %s failed: %s', + $condition, $error)); + } + print_log($channel, DEBUG2, 'Condition expression result: %s', defined $value ? $value : ''); + return (defined $value && $value ? 1 : 0); +} + +sub match_package_version ($$$$) +{ + my ($def, $inst, $instver, $desired) = @_; + + my $vars = { + pkgversion => $desired + }; + my $matchvercond = $$def{'match-version-condition'}; + my $matchversion = $$def{'match-version'}; + if (defined $matchvercond) { + my ($value, $error) = evaluate_expression('global', $vars, { version => $instver }, $matchvercond); + + if (defined $error && $error ne '') { + print_log('global', WARNING, 'Evaluating version match condition expression %s failed: %s', + $matchvercond, $error); + return 0; + } + print_log('global', DEBUG2, 'Version match condition expression result: %s', defined $value ? $value : ''); + return 1 if defined $value && $value; + } + else { + my $matchversubst = substitute_variables($vars, $matchversion, 0); + + return 1 if $instver =~ /^${matchversubst}$/i; + } + + return 0; +} + +sub set_extract_var ($$$$$) +{ + my ($channel, $vars, $inst, $varname, $expression) = @_; + + my ($value, $error) = evaluate_expression($channel, $vars, $inst, $expression); + + if (defined $error && $error ne '') { + return sprintf('Evaluating variable %s expression %s failed: %s', + $varname, $expression, $error); + } + print_log($channel, DEBUG3, 'Expression result: %s', defined $value ? $value : ''); + if (defined $value) { + $$vars{$varname} = $value; + } + else { + delete $$vars{$varname}; + } + return undef; +} + +sub extract_package_version ($$$$$) +{ + my ($channel, $def, $inst, $basedir, $config) = @_; + + my $dispname = $$inst{DisplayName}; + return undef unless defined $dispname; + my $dispver = $$inst{DisplayVersion}; + $dispver = defined $dispver && $dispver ne '' ? ' ('.$dispver.')' : ''; + print_log($channel, DEBUG3, 'Extracting version number for %s%s', $dispname, $dispver); + + my $extractsteps = $$def{'extract-version'}; + if (defined $extractsteps) { + my $vars = get_default_vars($config); + my $appdir = substitute_variables($vars, $$def{'source-directory'}, 1, $basedir, 'pkg'); + $$vars{appdir} = $appdir; + + my $i = 0; + foreach my $step (@$extractsteps) { + my $type = $$step{type}; + $i++; + print_log($channel, DEBUG3, 'Extract step #%d type %s', $i, $type); + + my $error; + if ($type eq 'setvar') { + my $varname = $$step{variable}; + my $expression = $$step{expression}; + print_log($channel, DEBUG3, 'Evaluating variable %s expression %s in step #%d', + $varname, $expression, $i); + $error = set_extract_var($channel, $vars, $inst, $varname, $expression); + } + if (defined $error) { + print_log($channel, ERROR, 'Version extraction failed in step #%d: %s', $i, $error); + return undef; + } + my $pkgversion = $$vars{pkgversion}; + return $pkgversion if defined $pkgversion && $pkgversion ne ''; + } + print_log($channel, DEBUG3, 'No steps resulted in valid package version'); + } + + my $sourcename = $$def{'version-source'}; + $sourcename = 'DisplayVersion' unless defined $sourcename; + my $sourcever = $$inst{$sourcename}; + if (! defined $sourcever) { + print_log($channel, DEBUG3, 'No package version source empty'); + return undef; + } + print_log($channel, DEBUG3, 'Source version number field %s: %s', $sourcename, $sourcever); + my $extract = $$def{'extract-version-regex'}; + if (defined $extract) { + my $field = $$def{'extract-version-field'}; + $field = 1 unless defined $field && $field =~ /^\d+$/o; + print_log($channel, DEBUG3, 'Extracting with regex "%s" from match %s', $extract, $field); + $field-- if $field > 0; + my $results = [$sourcever =~ /^${extract}$/]; + my $result = $$results[$field]; + $sourcever = $result if defined $result; + } + print_log($channel, DEBUG3, 'Result: %s', $sourcever); + return $sourcever; +} + +sub match_package_def ($$$) +{ + my ($def, $inst, $vars) = @_; + + my $dispname = $$inst{DisplayName}; + return 0 unless defined $dispname; + my $dispver = $$inst{DisplayVersion}; + $dispver = defined $dispver && $dispver ne '' ? ' ('.$dispver.')' : ''; + + print_log('global', DEBUG4, 'Trying to match package %s%s to definition %s', + $dispname, $dispver, $$def{description}); + my $matchlist = $$def{'match'}; + foreach my $matchentry (@$matchlist) { + my $expression = $$matchentry{expression}; + my ($value, $error) = evaluate_expression('global', $vars, $inst, $expression); + + if (defined $error && $error ne '') { + print_log('global', DEBUG4, 'Evaluating match expression %s failed: %s', + $expression, $error); + next; + } + print_log('global', DEBUG4, 'Expression result: %s', defined $value ? $value : ''); + return 1 if defined $value && $value; + } + return 0; +} + +sub sort_package ($$) +{ + my ($a, $b) = @_; + + my $auninst = $$a{Uninstall}; + my $aquninst = $$a{QUninstall}; + $auninst = $aquninst if defined $aquninst; + my $buninst = $$b{Uninstall}; + my $bquninst = $$b{QUninstall}; + $buninst = $aquninst if defined $bquninst; + + if (! defined $a) { + return 0 unless defined $b; + return 1; + } + return -1 unless defined $b; + + my $amsi = $auninst =~ /msiexec/io; + my $bmsi = $buninst =~ /msiexec/io; + if (! $amsi) { + return 0 unless defined $bmsi; + return 1; + } + return -1 unless defined $bmsi; + + return $$a{Name} cmp $$b{Name}; +} + +sub sort_packages_to_remove ($) +{ + my ($pkglist) = @_; + + return [sort sort_package @$pkglist]; +} + +sub find_installed_packages ($$$$$$$) +{ + my ($channel, $def, $db, $name, $basedir, $config, $userproduct) = @_; + + my $vars = get_default_vars($config); + set_datetime_vars($vars); + my $appdir = substitute_variables($vars, $$def{'source-directory'}, 1, $basedir, $channel); + $$vars{appdir} = $appdir; + + my $list = []; + if (defined $$def{'match'}) { + refresh_installed_packages($db); + my $installed = $$db{Installed}; + foreach my $instname (sort keys %$installed) { + my $inst = $$installed{$instname}; + next unless defined $inst; + push @$list, $inst if match_package_def($def, $inst, $vars); + } + if ($userproduct) { + my $installed = $$db{InstalledSpec}; + foreach my $instname (sort keys %$installed) { + my $inst = $$installed{$instname}; + next unless defined $inst; + push @$list, $inst if match_package_def($def, $inst, $vars); + } + } + } + elsif (defined $$def{'install-check'}) { + my $check = $$def{'install-check'}; + + print_log($channel, DEBUG2, 'Evaluating install check expression %s', $check); + my ($result, $error) = check_condition($channel, $vars, $check); + if (! defined $result) { + print_log($channel, INFO, 'Ignoring package %s install check: %s', $name, $error); + next; + } + print_log($channel, INFO, 'Package %s install check: %s', $name, ($check ? 'found' : 'not found')); + if ($check) { + push @$list, { + DisplayName => $$def{description} + }; + } + } + else { + print_log($channel, ERROR, 'Invalid package definition %s (neither "match", nor "install-check" defined)', $name); + return undef; + } + return $list; +} + +sub unflag_file ($$) +{ + my ($channel, $path) = @_; + + my $attrs = 0; + if (! Win32::File::GetAttributes($path, $attrs)) { + return 'Cannot read attributes for '.$path; + } + my $newattrs = $attrs & ~(SYSTEM|HIDDEN|READONLY); + return undef if $attrs == $newattrs; + print_log($channel, DEBUG3, 'Trying to clear attributes for %s', $path); + if (! Win32::File::SetAttributes($path, $newattrs)) { + return 'Cannot set attributes for '.$path; + } + return undef; +} + +sub create_directory_for ($$) +{ + my ($channel, $path) = @_; + + $path = File::Spec->canonpath($path); + my ($vol, $dir, $file) = File::Spec->splitpath($path); + $dir =~ s/^\\//o; + $dir =~ s/\\$//o; + my $base = $vol; + foreach my $subdirname (split(/\\/, $dir)) { + $base .= '\\'.$subdirname; + print_log($channel, DEBUG3, 'Checking %s', $base); + next if -d $base; + return sprintf('Cannot create directory %s: %s', $base, $!) + unless mkdir($base); + print_log($channel, DEBUG3, 'Created directory %s', $base); + } + return undef; +} + +sub clear_sub_dir ($$$); + +sub clear_sub_dir ($$$) +{ + my ($channel, $parent, $filename) = @_; + + return sprintf('Cannot read directory %s: %s', $parent, $!) + unless opendir(DIR, $parent); + $filename =~ s/\\/\\\\/o; + $filename =~ s/\./\\\./o; + $filename =~ s/\*/\.\*/o; + $filename =~ s/\?/\.\?/o; + $filename =~ s/\(/\\\(/o; + $filename =~ s/\)/\\\)/o; + my $subdirs = []; + my $files = []; + print_log($channel, DEBUG3, 'Scanning directory %s for %s', $parent, $filename); + while (1) { + my $name = readdir(DIR); + last unless defined $name; + next if $name eq '.' || $name eq '..'; + my $path = $parent.'\\'.$name; + my $matches = $name =~ /^${filename}$/; + print_log($channel, DEBUG3, 'Found %s%s', $path, $matches ? ' - matches' : ''); + next unless $matches; + if (-d $path) { + push @$subdirs, $path; + } + else { + push @$files, $path; + } + } + closedir(DIR); + foreach my $subdir (@$subdirs) { + clear_sub_dir($channel, $subdir, '*'); + print_log($channel, DEBUG3, 'Removing directory %s', $subdir); + my $error = unflag_file($channel, $subdir); + return $error if defined $error; + return sprintf('Cannot remove directory %s: %s', $subdir, $!) + unless rmdir($subdir); + } + foreach my $file (@$files) { + print_log($channel, DEBUG3, 'Removing file %s', $file); + my $error = unflag_file($channel, $file); + return $error if defined $error; + return sprintf('Cannot remove file %s: %s', $file, $!) + unless unlink($file); + } +} + +sub delete_dir_file ($$$$) +{ + my ($direntry, $channel, $recurse, $targetfile) = @_; + + print_log($channel, DEBUG1, 'Deleting %s%s %s', + $direntry ? 'directory' : 'file', $recurse ? ' recursively' : '', $targetfile); + + my $path = File::Spec->canonpath($targetfile); + my ($vol, $dir, $file) = File::Spec->splitpath($path); + if ($file eq '') { + return sprintf('Invalid empty last component in path: %s', $targetfile); + } + $dir =~ s/\\$//o; + clear_sub_dir($channel, $vol.$dir, $file); + return undef; +} + +sub copy_file ($$$) +{ + my ($channel, $sourcefile, $targetfile) = @_; + + print_log($channel, DEBUG1, 'Copying file %s to %s', $sourcefile, $targetfile); + + return sprintf('Cannot open source file %s for copying: %s', $sourcefile, $!) + unless sysopen(SOURCE, $sourcefile, O_RDONLY); + + my $error = create_directory_for($channel, $targetfile); + if (defined $error) { + close(SOURCE); + return $error; + } + if (-f $targetfile) { + $error = unflag_file($channel, $targetfile); + if (defined $error) { + close(SOURCE); + return $error; + } + } + if (! sysopen(TARGET, $targetfile, O_RDWR|O_CREAT|O_TRUNC)) { + $error = sprintf('Cannot create target file %s for copying: %s', $targetfile, $!); + close(SOURCE); + return $error; + } + while (1) { + my $buffer; + my $len = sysread(SOURCE, $buffer, 65536); + if (! defined $len) { + $error = sprintf('Error reading source file %s for copying: %s', $sourcefile, $!); + close(TARGET); + close(SOURCE); + unlink($targetfile); + return $error; + } + last if $len == 0; + my $sofar = 0; + while ($sofar < $len) { + my $done = syswrite(TARGET, $buffer, $len - $sofar, $sofar); + if (! defined $done) { + $error = sprintf('Error writing target file %s for copying: %s', $targetfile, $!); + close(TARGET); + close(SOURCE); + unlink($targetfile); + return $error; + } + last if $done == 0; + $sofar += $done; + } + } + close(TARGET); + close(SOURCE); + return undef; +} + +sub run_exe ($$$$$$$;$) +{ + my ($channel, $db, $vars, $chdir, $program, $paramlist, $bg, $getresult) = @_; + + my $params = ''; + if (defined $paramlist && scalar @$paramlist > 0) { + foreach my $param (@$paramlist) { + $param = substitute_variables($vars, $param, 0, undef, $channel) + if defined $vars && $param =~ /%[^%]*%/o; + $params .= ' '.$param; + } + } + if (defined $chdir) { + print_log($channel, DEBUG1, 'Changing current directory to %s', $chdir); + return (sprintf('Cannot change current directory to %s: %s', $chdir, $!), -1) + unless chdir($chdir); + } + print_log($channel, DEBUG1, 'Running exe %s%s', $program, $params); + + return (sprintf('Cannot find executable file %s: %s', $program, $!), -1) + unless -f $program; + return (sprintf('Cannot dup STDIN: %s', $!), -1) + unless open(IN, '<&STDIN'); + return (sprintf('Cannot dup STDERR: %s', $!), -1) + unless open(ERR, '>&STDERR'); + eval { + my $reader = $bg ? undef : gensym; + my $pid = open3('<&IN', $bg ? '>&ERR' : $reader, $bg ? '>&ERR' : $reader, $program, @$paramlist); + if (defined $db) { + $$db{Changed} = 1; + $$db{PatchesChanged} = 1; + print_log('global', DEBUG4, 'Invalidating packages & patches'); + } + if (! $bg) { + while (<$reader>) { + s/\r?\n$//o; + print_log($channel, INFO, '%s', $_); + push @$getresult, $_ if defined $getresult && ref($getresult) eq 'ARRAY'; + } + } + waitpid($pid, 0) unless $bg; + close($reader) unless $bg; + }; + my $exitcode; + if ($bg) { + $exitcode = 0; + print_log($channel, DEBUG1, 'Leaving process in background'); + } + else { + $exitcode = $? >> 8; + my $signal = $? & 255; + print_log($channel, DEBUG1, 'Exit code: %d, signal: %d', $exitcode, $signal); + } + close(IN); + close(ERR); + return (sprintf('Executable %s exit code: %d', $program, $exitcode), $exitcode) if $exitcode; + return (undef, undef); +} + +sub remove_packages ($$$$$$$$$$) +{ + my ($channel, $vars, $def, $paramlist, $list, $condition, $db, $basedir, $config, $counters) = @_; + + my $params; + my $exename; + $list = sort_packages_to_remove($list); + foreach my $inst (@$list) { + my $ver = extract_package_version($channel, $def, $inst, $basedir, $config); + $ver = $$inst{DisplayVersion} unless defined $ver; + my $printver = defined $ver ? ' ('.$ver.')' : ''; + if (defined $condition) { + $$vars{'installed-version'} = $ver; + + print_log($channel, DEBUG2, 'Evaluating package removal condition expression %s', $condition); + my ($result, $error) = check_condition($channel, $vars, $condition); + if (! defined $result) { + print_log($channel, INFO, 'Ignoring package %s%s: %s', + $$inst{DisplayName}, $printver, $error); + next; + } + if (! $result) { + print_log($channel, INFO, 'Ignoring package %s%s with false condition', + $$inst{DisplayName}, $printver); + next; + } + } + + print_log($channel, DEBUG1, 'Removing package %s%s%s', $$inst{DisplayName}, $printver, + defined $condition ? ' with true condition' : ''); + + my $uninst = $$inst{Uninstall}; + my $quninst = $$inst{QUninstall}; + return sprintf('Cannot remove package %s%s, no UninstallString registry entry found', + $$inst{DisplayName}, $ver) unless defined $uninst || defined $quninst; + $uninst = $quninst if defined $quninst; + $uninst =~ s/(msiexec[^ ]* )\/i/$1\/X/io; + $uninst =~ s/(msiexec[^ ]* )/$1\/qb \/norestart \/passive /io; + print_log($channel, DEBUG2, 'Uninstall command: %s', $uninst); + $exename = substitute_variables($vars, '%systemroot%/System32/cmd.exe', 1, undef, 'pkg') + unless defined $exename; + if (! defined $params) { + $params = ''; + if (defined $paramlist && scalar @$paramlist > 0) { + foreach my $param (@$paramlist) { + $param = substitute_variables($vars, $param, 0, undef, $channel) + if $param =~ /%[^%]*%/o; + $params .= ' '.$param; + } + } + $params = ' '.$params unless $params eq ''; + } + $uninst .= $params; + my ($error, $exitcode) = run_exe($channel, $db, $vars, undef, $exename, ['/C', $uninst], 0); + if (defined $error) { + if (defined $exitcode && $exitcode == 194) { + print_log($channel, INFO, 'Ignoring package %s%s removal exit code: %s', + $$inst{DisplayName}, $printver, $exitcode); + $$counters{RebootFlag} = 1; + } + else { + push @{$$counters{FailList}}, $$inst{DisplayName}; + $$counters{FailCount}++; + return $error; + } + } + push @{$$counters{RemovedList}}, $$inst{DisplayName}; + $$counters{RemovedCount}++; + } + return undef; +} + +sub set_install_var ($$$$) +{ + my ($channel, $vars, $varname, $expression) = @_; + + my ($value, $error) = evaluate_expression($channel, $vars, {}, $expression); + + if (defined $error && $error ne '') { + return sprintf('Evaluating variable %s expression %s failed: %s', + $varname, $expression, $error); + } + print_log($channel, DEBUG2, 'Expression result: %s', defined $value ? $value : ''); + if (defined $value) { + $$vars{$varname} = $value; + } + else { + delete $$vars{$varname}; + } + return undef; +} + +sub remove_package ($$$$$$$) +{ + my ($db, $def, $name, $list, $basedir, $config, $counters) = @_; + + set_current_pkg_name($name); + + my $vars = get_default_vars($config); + set_datetime_vars($vars); + $$vars{pkgname} = $name; + my $appdir = substitute_variables($vars, $$def{'source-directory'}, 1, $basedir, 'pkg'); + $$vars{appdir} = $appdir; + + my $paramlist = $$def{'remove-parameters'}; + $paramlist = [] unless defined $paramlist; + my $error = remove_packages('pkg', $vars, $def, $paramlist, + [map { $$_[1] } @$list], undef, $db, $basedir, $config, $counters); + print_log('pkg', ERROR, 'Package removal failed: %s', $error) if defined $error; + + set_current_pkg_name(undef); + return defined $error ? 0 : 1; +} + +sub install_package ($$$$$$$$$) +{ + my ($db, $def, $inst, $name, $version, $basedir, $genericmsiparams, $config, $counters) = @_; + + my $installsteps = $$def{install}; + if (! defined $installsteps) { + push @{$$counters{DoneList}}, $name; + $$counters{DoneCount}++; + return 1; + } + + set_current_pkg_name($name); + + print_log('pkg', INFO, 'Installing package %s version %s', $name, $version); + + my $vars = get_default_vars($config); + set_datetime_vars($vars); + $$vars{pkgname} = $name; + $$vars{pkgversion} = $version; + my $appdir = substitute_variables($vars, $$def{'source-directory'}, 1, $basedir, 'pkg'); + $$vars{appdir} = $appdir; + + my $i = 0; + foreach my $step (@$installsteps) { + my $type = $$step{type}; + $i++; + print_log('pkg', DEBUG2, 'Install step #%d type %s', $i, $type); + + my $error; + my $exitcode; + my $ignore = $$step{'ignore-failure'}; + $ignore = 0 unless defined $ignore; + + my $condition = $$step{condition}; + if (defined $condition && $type ne 'remove-pkg') { + print_log('pkg', DEBUG2, 'Evaluating condition expression %s in step #%d', + $condition, $i); + ($condition, $error) = check_condition('pkg', $vars, $condition); + if (! defined $condition) { + print_log('pkg', INFO, 'Ignoring step #%d: %s', $i, $error); + next; + } + if (! $condition) { + print_log('pkg', INFO, 'Ignoring step #%d with false condition', $i); + next; + } + print_log('pkg', INFO, 'Executing step #%d with true condition', $i); + } + + if ($type eq 'remove-pkg') { + my $paramlist = $$step{parameters}; + $paramlist = [] unless defined $paramlist; + my $list = find_installed_packages('pkg', $def, $db, $name, $basedir, $config, 0); + if (defined $list) { + $error = remove_packages('pkg', $vars, $def, $paramlist, $list, $condition, $db, $basedir, $config, $counters); + delete $$vars{'installed-version'}; + } + else { + $error = 'Invalid package definition'; + } + } + elsif ($type eq 'run') { + my $bg = defined $$step{background} && $$step{background}; + my $chdir = defined $$step{chdir} ? + substitute_variables($vars, $$step{chdir}, 1, $appdir, 'pkg') : undef; + my $sourcefile = substitute_variables($vars, $$step{'source-file'}, 1, $appdir, 'pkg'); + my $paramlist = $$step{parameters}; + $paramlist = [] unless defined $paramlist; + ($error, $exitcode) = run_exe('pkg', $db, $vars, $chdir, $sourcefile, $paramlist, $bg); + } + elsif ($type eq 'msi') { + my $sourcefile = substitute_variables($vars, $$step{'source-file'}, 1, $appdir, 'pkg'); + my $exename = substitute_variables($vars, '%systemroot%/System32/msiexec.exe', 1, undef, 'pkg'); + my $paramlist = $$step{parameters}; + $paramlist = [] unless defined $paramlist; + unshift @$paramlist, '/i', $sourcefile; + if (-f $sourcefile) { + push @$paramlist, @$genericmsiparams if defined $genericmsiparams; + ($error, $exitcode) = run_exe('pkg', $db, $vars, undef, $exename, $paramlist, 0); + } + else { + $error = sprintf('Cannot find MSI file %s: %s', $sourcefile, $!); + $exitcode = -1; + } + } + elsif ($type eq 'msp') { + my $sourcefile = substitute_variables($vars, $$step{'source-file'}, 1, $appdir, 'pkg'); + my $exename = substitute_variables($vars, '%systemroot%/System32/msiexec.exe', 1, undef, 'pkg'); + my $paramlist = $$step{parameters}; + $paramlist = [] unless defined $paramlist; + unshift @$paramlist, '/p', $sourcefile; + if (-f $sourcefile) { + ($error, $exitcode) = run_exe('pkg', $db, $vars, undef, $exename, $paramlist, 0); + } + else { + $error = sprintf('Cannot find MSP file %s: %s', $sourcefile, $!); + $exitcode = -1; + } + } + elsif ($type eq 'reg') { + my $sourcefile = substitute_variables($vars, $$step{'source-file'}, 1, $appdir, 'pkg'); + my $exename = substitute_variables($vars, '%systemroot%/System32/reg.exe', 1, undef, 'pkg'); + my $paramlist = ['import', $sourcefile]; + if (-f $sourcefile) { + ($error, $exitcode) = run_exe('pkg', $db, $vars, undef, $exename, $paramlist, 0); + } + else { + $error = sprintf('Cannot find REG file %s: %s', $sourcefile, $!); + $exitcode = -1; + } + } + elsif ($type eq 'file') { + my $sourcefile = substitute_variables($vars, $$step{'source-file'}, 1, $appdir, 'pkg'); + my $targetfile = substitute_variables($vars, $$step{'target-file'}, 1); + $error = copy_file('pkg', $sourcefile, $targetfile); + } + elsif ($type eq 'delete-file') { + my $recurse = $$step{recurse}; + $recurse = defined $recurse && $recurse; + my $targetfile = substitute_variables($vars, $$step{'target-file'}, 1); + $error = delete_dir_file(0, 'pkg', $recurse, $targetfile); + } + elsif ($type eq 'delete-dir') { + my $recurse = $$step{recurse}; + $recurse = defined $recurse && $recurse; + my $targetfile = substitute_variables($vars, $$step{'target-file'}, 1); + $error = delete_dir_file(1, 'pkg', $recurse, $targetfile); + } + elsif ($type eq 'setvar') { + my $varname = $$step{variable}; + my $expression = $$step{expression}; + my $filename = $$step{filename}; + if (defined $expression) { + print_log('pkg', DEBUG2, 'Evaluating variable %s expression %s in step #%d', + $varname, $expression, $i); + $error = set_install_var('pkg', $vars, $varname, $expression); + } + else { + print_log('pkg', DEBUG2, 'Evaluating variable %s filename %s in step #%d', + $varname, $filename, $i); + my $file = substitute_variables($vars, $filename, 1, $appdir, 'pkg'); + $$vars{$varname} = $file; + } + } + if (defined $error) { + $ignore = 1 if defined $exitcode && $exitcode == 194; + if (! $ignore) { + print_log('pkg', ERROR, 'Installation failed in step #%d: %s', $i, $error); + set_current_pkg_name(undef); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + print_log('pkg', INFO, 'Ignoring failed step #%d: %s', $i, $error); + } + } + + print_log('pkg', INFO, 'Finished installing package %s version %s', $name, $version); + set_current_pkg_name(undef); + push @{$$counters{InstalledList}}, $name; + $$counters{InstalledCount}++; + return 1; +} + +sub pkgdef_get_desired_version ($$$$$) +{ + my ($config, $name, $base_directory, $def, $version) = @_; + + return undef unless defined $version; + my $versions = $$def{'package-versions'}; + if (defined $versions) { + my $found = $$versions{$version}; + if (defined $found) { + if (ref($found) eq 'HASH') { + my $etype = $$found{type}; + print_log('global', DEBUG4, 'Evaluating desired version %s %s in definition %s', + $etype, $version, $$def{description}); + if ($etype eq 'expression') { + my $vars = get_default_vars($config); + set_datetime_vars($vars); + $$vars{pkgname} = $name; + $$vars{packageversion} = $version; + my $appdir = substitute_variables($vars, $$def{'source-directory'}, 1, $base_directory, 'pkg'); + $$vars{appdir} = $appdir; + + my $expression = $$found{expression}; + my ($value, $error) = evaluate_expression('global', $vars, $def, $expression); + + if (defined $error && $error ne '') { + print_log('global', DEBUG4, 'Evaluating desired version expression %s failed: %s', + $expression, $error); + return undef; + } + print_log('global', DEBUG4, 'Desired version expression result: %s', defined $value ? $value : ''); + return $value; + } + } + return $found; + } + } + return $version; +} + +sub pkgdef_check_availability ($$$) +{ + my ($def, $name, $config) = @_; + + my $condition = $$def{available}; + return (undef, undef) unless defined $condition; + + print_log('global', DEBUG2, 'Evaluating condition expression %s for package %s', + $condition, $name); + my $vars = get_default_vars($config); + $$vars{pkgname} = $name; + my $error; + ($condition, $error) = check_condition('global', $vars, $condition); + return (undef, $error) unless defined $condition; + return ($condition); +} + +sub patchsetdef_check_availability ($$$) +{ + my ($pdef, $name, $config) = @_; + + my $condition = $$pdef{available}; + return (undef, undef) unless defined $condition; + + print_log('global', DEBUG2, 'Evaluating condition expression %s for patch set %s', + $condition, $name); + my $vars = get_default_vars($config); + $$vars{patchsetname} = $name; + my $error; + ($condition, $error) = check_condition('global', $vars, $condition); + return (undef, $error) unless defined $condition; + return ($condition); +} + +sub patchdef_check_availability ($$$$) +{ + my ($pdef, $patchdef, $name, $config) = @_; + + my $condition = $$patchdef{available}; + return (undef, undef) unless defined $condition; + + print_log('global', DEBUG2, 'Evaluating condition expression %s for patch set %s patches %s', + $condition, $name, join(',', @{$$patchdef{kb}})); + my $vars = get_default_vars($config); + $$vars{patchsetname} = $name; + my $error; + ($condition, $error) = check_condition('global', $vars, $condition); + return (undef, $error) unless defined $condition; + return ($condition); +} + +sub pkg_check_condition ($$$) +{ + my ($pkg, $name, $config) = @_; + + my $condition = $$pkg{condition}; + return (undef, undef) unless defined $condition; + + print_log('global', DEBUG2, 'Evaluating condition expression %s for package/patch %s', + $condition, $name); + my $vars = get_default_vars($config); + $$vars{pkgname} = $name; + my $error; + ($condition, $error) = check_condition('global', $vars, $condition); + return (undef, $error) unless defined $condition; + return ($condition); +} + +sub scan_dir ($$$$); + +sub scan_dir ($$$$) +{ + my ($config, $dir, $maxdepth, $filename) = @_; + + print_log('global', DEBUG1, 'Scanning package directory %s for %d levels', $dir, $maxdepth); + + if (! opendir(DIR, $dir)) { + print_log('global', 'ERROR', 'Cannot scan directory %s', $dir); + return 1; + } + my $subdirs = []; + my $files = []; + while (1) { + my $name = readdir(DIR); + last unless defined $name; + next if $name eq '.' || $name eq '..'; + my $path = $dir.'\\'.$name; + push @$subdirs, $path if $maxdepth > 0 && -d $path; + push @$files, $path if $name eq $filename; + } + closedir(DIR); + + $maxdepth--; + foreach my $path (@$subdirs) { + my $error = scan_dir($config, $path, $maxdepth, $filename); + return $error if defined $error; + } + + my $pkgdefs = $$config{'package-def'}; + my $patchdefs = $$config{'patch-def'}; + foreach my $path (@$files) { + print_log('global', DEBUG1, 'Found package definition file %s', $path); + my $addconfig = parse_cfg_file($path, $pkgdef_cfg_syntax); + return 1 unless defined $addconfig; + my $addpkgdefs = $$addconfig{'package-def'}; + if (defined $addpkgdefs) { + foreach my $key (keys %$addpkgdefs) { + my $def = $$addpkgdefs{$key}; + $pkgdefs = $$config{'package-def'} = {} unless defined $pkgdefs; + if (defined $$pkgdefs{$key}) { + print_log('global', WARNING, 'Found package re-definition for %s in file %s', $key, $path); + next; + } + $$def{'definition-directory'} = $dir; + $$pkgdefs{$key} = $def; + print_log('global', DEBUG3, 'Found package definition for %s (%s) in file %s', $key, $$def{description}, $path); + } + } + my $addpatchdefs = $$addconfig{'patch-def'}; + if (defined $addpatchdefs) { + foreach my $key (keys %$addpatchdefs) { + my $def = $$addpatchdefs{$key}; + $patchdefs = $$config{'patch-def'} = {} unless defined $patchdefs; + if (defined $$patchdefs{$key}) { + print_log('global', WARNING, 'Found patch set re-definition for %s in file %s', $key, $path); + next; + } + $$def{'definition-directory'} = $dir; + $$patchdefs{$key} = $def; + print_log('global', DEBUG3, 'Found patch set definition for %s (%s) in file %s', $key, $$def{description}, $path); + } + } + } + + return undef; +} + +sub scan_package_dirs ($$) +{ + my ($config, $basedir) = @_; + + my $scan = $$config{scan}; + return undef unless defined $scan; + + my $filename = $$scan{filename}; + my $maxdepth = $$scan{'max-depth'}; + my $dirs = $$scan{directories}; + return undef unless defined $filename && defined $dirs; + $maxdepth = 1 unless defined $maxdepth; + + print_log('global', INFO, 'Scanning package directories'); + + my $vars = get_default_vars($config); + foreach my $dir (@$dirs) { + my $scandir = substitute_variables($vars, $dir, 1, $basedir, 'global'); + my $error = scan_dir($config, $scandir, $maxdepth, $filename); + return $error if defined $error; + } + return undef; +} + +sub match_package_version_for_processing ($$$) +{ + my ($instver, $op, $ver) = @_; + + return 1 if $op eq '*'; + return $instver eq $ver if $op eq '='; + if ($op eq '~') { + return 0 unless substr($instver, 0, length($ver)) eq $ver; + return length($instver) == length($ver) || + substr($instver, length($ver), 1) =~ /^[^0-9]$/o; + } + my $splitinstver = [split(/\./, $instver)]; + my $splitremovever = [split(/\./, $ver)]; + while (1) { + my $a = shift @$splitinstver; + my $b = shift @$splitremovever; + $a = '' unless defined $a; + $b = '' unless defined $b; + my $rc = $a =~ /^\d+$/o && $b =~ /^\d+$/o ? $a <=> $b : $a cmp $b; + return $op =~ /^/o if $rc > 0; + } + return $op =~ /=$/o; +} + +sub assess_pkg ($$$$$$$$) +{ + my ($config, $base_directory, $db, $name, $desired, $remove, $def, $update) = @_; + + my $removeop; + my $removever; + if (defined $remove) { + my $removeversion = pkgdef_get_desired_version($config, $name, $base_directory, $def, $remove); + $remove = $removeversion if defined $removeversion; + if ($remove =~ /^(\*|<|>|<=|>=|=|~)(.*)$/o) { + $removeop = $1; + $removever = $2; + } + else { + $removeop = '~'; + $removever = $remove; + } + } + my $patching = $$def{'patching-version'}; + my $patchingop; + my $patchingver; + if (defined $patching) { + my $patchingversion = pkgdef_get_desired_version($config, $name, $base_directory, $def, $patching); + $patching = $patchingversion if defined $patchingversion; + if ($patching =~ /^(\*|<|>|<=|>=|=|~)(.*)$/o) { + $patchingop = $1; + $patchingver = $2; + } + else { + $patchingop = '~'; + $patchingver = $patching; + } + } + my $list = find_installed_packages('global', $def, $db, $name, $base_directory, $config, 0); + return (undef, undef, undef) unless defined $list; + my $found; + my $foundtopatch = defined $patching ? [] : undef; + my $toinstall; + my $toremove = []; + if (scalar @$list > 0) { + my $ok = 0; + my $instlist = []; + foreach my $inst (@$list) { + my $instver = extract_package_version('global', $def, $inst, + $base_directory, $config); + next unless defined $instver; + push @$instlist, $instver; + if (defined $desired && + match_package_version($def, $inst, $instver, $desired)) { + $found = $inst; + $ok = 1; + } + if (defined $foundtopatch && + match_package_version_for_processing($instver, $patchingop, $patchingver)) { + push @$foundtopatch, [$instver, $inst]; + } + if (defined $removever && + match_package_version_for_processing($instver, $removeop, $removever)) { + push @$toremove, [$instver, $inst]; + } + } + my $todo = ''; + my $param = ''; + my $rtodo = ''; + my $rparam = ''; + if (scalar @$toremove > 0) { + $rtodo = $update ? ' - removing version ' : ' REMOVE '; + $rparam = join(', ', sort map { $$_[0] } @$toremove); + } + if ($ok) { + $todo = ' OK' if $rtodo eq ''; + } + elsif (! defined $desired) { + $todo = $update ? ' - nothing to do' : '' if $rtodo eq ''; + } + elsif (defined $foundtopatch) { + if (scalar @$foundtopatch > 0) { + $todo = $update ? ' - installing version ' : ' INSTALL '; + $param = $desired; + $toinstall = $desired; + } + else { + $todo = ' - no versions found to patch to version '; + $param = $desired; + } + } + else { + $todo = $update ? ' - installing version ' : ' INSTALL '; + $param = $desired; + $toinstall = $desired; + } + print_log('global', WARNING, 'Package %s installed: %s%s%s%s%s', + $name, + join(', ', sort @$instlist), + $rtodo, $rparam, $todo, $param); + } + else { + my $todo; + my $param = ''; + my $leave = 0; + if (! defined $desired) { + $todo = $update ? ' - nothing to do' : ''; + } + else { + $todo = $update ? ' - installing version ' : ' INSTALL '; + $param = $desired; + $toinstall = $desired; + } + print_log('global', WARNING, 'Package %s not installed%s%s', + $name, $todo, $param); + } + return ($found, $toinstall, $toremove); +} + +sub drop_pkg_cache ($) +{ + my ($db) = @_; + + delete $$db{PkgCache}; +} + +sub get_pkg_instances ($$$$$) +{ + my ($config, $base_directory, $db, $name, $def) = @_; + + my $cache = $$db{PkgCache}; + $cache = $$db{PkgCache} = {} unless defined $cache; + + my $instance = $$cache{$name}; + if (! defined $instance) { + my $list = find_installed_packages('global', $def, $db, $name, $base_directory, $config, 1); + $list = [] unless defined $list; + $instance = { + Found => $list + }; + $$cache{$name} = $instance; + } + return $instance; +} + +sub assess_patch ($$$$$$$$$) +{ + my ($config, $base_directory, $db, $name, $pdef, $patchdef, $kb, $update, $counters) = @_; + + my $pkgdefs = $$config{'package-def'}; + my $pkglist = $$patchdef{packages}; + my $foundpkgs = {}; + if (defined $pkglist) { + foreach my $pkgname (@$pkglist) { + if ($pkgname eq 'OS') { + print_log('global', DEBUG3, 'Patch %s references OS (always present)', $kb); + $$foundpkgs{OS} = { + OS => 'OS' + }; + next; + } + my $def = $$pkgdefs{$pkgname}; + if (! defined $def) { + print_log('global', DEBUG3, 'Patch %s references package %s (no definition)', $kb, $pkgname); + next; + } + my $instance = get_pkg_instances($config, $base_directory, $db, $pkgname, $def); + if (! defined $instance) { + print_log('global', DEBUG3, 'Patch %s references package %s (no instance returned)', $kb, $pkgname); + next; + } + my $list = $$instance{Found}; + if (! defined $list) { + print_log('global', DEBUG3, 'Patch %s references package %s (no instance list returned)', $kb, $pkgname); + next; + } + if (scalar @$list > 0) { + my $found = {}; + foreach my $inst (@$list) { + my $dispname = $$inst{DisplayName}; + next unless defined $dispname && $dispname ne ''; + $$found{$dispname} = $pkgname; + } + $$foundpkgs{$pkgname} = $found; + print_log('global', DEBUG3, 'Patch %s references package %s (present): %s', + $kb, $pkgname, join(',', sort keys %$found)); + } + else { + print_log('global', DEBUG3, 'Patch %s references package %s (not present)', $kb, $pkgname); + } + } + } + else { + print_log('global', DEBUG3, 'Patch %s has no package reference (OS referenced - always present)', $kb); + $pkglist = ['OS']; + $$foundpkgs{OS} = { + OS => 'OS' + }; + } + if (scalar keys %$foundpkgs == 0) { + print_log('global', WARNING, 'Patch %s: no referenced packages found - NOT NEEDED', $kb); + return 1; + } + + my $vars = get_default_vars($config); + set_datetime_vars($vars); + my $basedir = substitute_variables($vars, $$pdef{'base-directory'}, 1, $base_directory, 'pkg'); + $$vars{basedir} = $basedir; + my $patchdir = substitute_variables($vars, $$patchdef{'source-directory'}, 1, $basedir, 'pkg'); + $$vars{patchdir} = $patchdir; + $$vars{patch} = $kb; + my $number = $kb =~ /^(\d+)/o ? $1 : $kb; + my $extra = $kb =~ /^\d+([^0-9].*)$/o ? '-'.$1 : ''; + $$vars{patchnum} = $number; + $$vars{patchextra} = $extra; + + refresh_installed_patches($db); + + my $patches = $$db{Patches}; + my $foundpatch = $$patches{$kb}; + + if (defined $foundpatch) { + my $foundforpkgs = $$foundpatch{Packages}; + my $missing = []; + my $found = []; + foreach my $dispname (sort keys %$foundforpkgs) { + print_log('global', DEBUG4, 'Patch %s found installed for package (%s)', $kb, $dispname); + } + foreach my $pkgname (sort keys %$foundpkgs) { + my $founddispnames = $$foundpkgs{$pkgname}; + my $any = 0; + foreach my $dispname (sort keys %$founddispnames) { + if (defined $$foundforpkgs{$dispname}) { + print_log('global', DEBUG4, 'Patch %s found installed for referenced package %s (%s)', + $kb, $pkgname, $dispname); + $any = 1; + last; + } + } + if ($any) { + push @$found, $pkgname; + print_log('global', DEBUG3, 'Patch %s installed for referenced package %s', $kb, $pkgname); + } + else { + push @$missing, $pkgname; + print_log('global', DEBUG3, 'Patch %s not installed for any referenced package %s', $kb, $pkgname); + } + } + if (scalar @$missing == 0) { + print_log('global', WARNING, 'Patch %s: installed for all required packages - OK', $kb); + return 1; + } + print_log('global', WARNING, 'Patch %s: %s%s%smissing for packages %s - %s', + $kb, (scalar @$found > 0 ? 'installed for ' : ''), + join(',', @$found), (scalar @$found > 0 ? ', ' : ''), + join(',', @$missing), $update ? 'installing' : 'NEEDED'); + } + else { + print_log('global', WARNING, 'Patch %s: not installed - %s', + $kb, $update ? 'installing' : 'NEEDED'); + } + push @{$$counters{ToInstallList}}, $kb; + $$counters{ToInstallCount}++; + return 0; +} + +sub install_patch ($$$$$$$) +{ + my ($config, $base_directory, $db, $pdef, $patchdef, $kb, $counters) = @_; + + my $name = 'patch'; + set_current_pkg_name($name); + + print_log('pkg', INFO, 'Installing patch %s', $kb); + + my $vars = get_default_vars($config); + set_datetime_vars($vars); + $$vars{pkgname} = $name; + $$vars{patch} = $kb; + my $number = $kb =~ /^(\d+)/o ? $1 : $kb; + my $extra = $kb =~ /^\d+([^0-9].*)$/o ? '-'.$1 : ''; + $$vars{patchnum} = $number; + $$vars{patchextra} = $extra; + my $basedir = substitute_variables($vars, $$pdef{'base-directory'}, 1, $base_directory, 'pkg'); + $$vars{basedir} = $basedir; + my $patchdir = substitute_variables($vars, $$patchdef{'source-directory'}, 1, $basedir, 'pkg'); + $$vars{patchdir} = $patchdir; + $$vars{patchprefix} = defined $$patchdef{prefix} ? $$patchdef{prefix} : 'Windows'.get_win_version().'-'; + $$vars{patchkbname} = defined $$patchdef{kbname} ? $$patchdef{kbname} : 'KB'; + $$vars{patchedition} = defined $$patchdef{edition} ? $$patchdef{edition} : ''; + $$vars{patcharch} = defined $$patchdef{arch} ? $$patchdef{arch} : '-'.$$vars{xarch}; + $$vars{patchsuffix} = defined $$patchdef{suffix} ? $$patchdef{suffix} : ''; + + my $style = $$patchdef{style}; + $$vars{patchext} = $style eq 'exe' ? '.exe' : $style eq 'msu' ? '.msu' : $style eq 'msp' ? '.msp' : ''; + + my $sourcespec = $$patchdef{'source-file'}; + $sourcespec = '%patchprefix%%patchkbname%%patchnum%%patchextra%%patchedition%%patcharch%%patchsuffix%%patchext%' unless defined $sourcespec; + my $sourcefile = substitute_variables($vars, $sourcespec, 1, $patchdir, 'pkg'); + + my $error; + my $exitcode; + if ($style eq 'exe') { + my $chdir = defined $$patchdef{chdir} ? + substitute_variables($vars, $$patchdef{chdir}, 1, $patchdir, 'pkg') : undef; + my $paramlist = $$patchdef{parameters}; + $paramlist = ['/quiet', '/norestart'] unless defined $paramlist; + unshift @$paramlist, $sourcefile; + my $sourcefile = $$config{'proxy-command'}; + ($error, $exitcode) = run_exe('pkg', $db, $vars, $chdir, $sourcefile, $paramlist, 0); + } + elsif ($style eq 'msu') { + my $exename = substitute_variables($vars, '%systemroot%/System32/wusa.exe', 1, undef, 'pkg'); + my $paramlist = $$patchdef{parameters}; + $paramlist = ['/quiet', '/norestart'] unless defined $paramlist; + unshift @$paramlist, $sourcefile; + if (-f $sourcefile) { + ($error, $exitcode) = run_exe('pkg', $db, $vars, undef, $exename, $paramlist, 0); + } + else { + $error = sprintf('Cannot find MSU file %s: %s', $sourcefile, $!); + $exitcode = -1; + } + } + elsif ($style eq 'msp') { + my $exename = substitute_variables($vars, '%systemroot%/System32/msiexec.exe', 1, undef, 'pkg'); + my $paramlist = $$patchdef{parameters}; + $paramlist = ['REINSTALL=ALL', 'REINSTALLMODE=omus'] unless defined $paramlist; + unshift @$paramlist, '/p', $sourcefile; + push @$paramlist, '/quiet', '/norestart'; + if (-f $sourcefile) { + ($error, $exitcode) = run_exe('pkg', $db, $vars, undef, $exename, $paramlist, 0); + } + else { + $error = sprintf('Cannot find MSP file %s: %s', $sourcefile, $!); + $exitcode = -1; + } + } + if (defined $error) { + if (defined $exitcode && $exitcode == 194) { + print_log('pkg', INFO, 'Ignoring patch %s installation exit code: %s', $kb, $exitcode); + $$counters{RebootFlag} = 1; + } + else { + print_log('pkg', ERROR, 'Patch %s installation failed: %s', $kb, $error); + set_current_pkg_name(undef); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + } + + print_log('pkg', INFO, 'Finished installing patch %s', $kb); + set_current_pkg_name(undef); + push @{$$counters{InstalledList}}, $name; + $$counters{InstalledCount}++; + return 1; +} + +sub parse_header ($) +{ + my ($line) = @_; + + my $list = []; + my $keywords = {}; + my $index = 0; + $line =~ s/^\s+//o; + while ($line =~ /^([^\s]+)(\s*)(.*)$/o) { + my $name = $1; + my $post = $2; + $line = $3; + my $length = length($name) + length($post); + if (! defined $$keywords{$name}) { + push @$list, $name; + $$keywords{$name} = { + Name => $name, + StartPos => $index, + Length => $length + }; + } + $index += $length; + } + return ($list, $keywords); +} + +sub parse_line ($$$) +{ + my ($header, $keywords, $line) = @_; + + my $row = {}; + foreach my $name (@$header) { + my $kw = $$keywords{$name}; + next unless defined $kw; + if ($$kw{StartPos} < length($line)) { + my $value = substr($line, $$kw{StartPos}, $$kw{Length}); + if (defined $value) { + $value =~ s/^\s+//o; + $value =~ s/\s+$//o; + $$row{$name} = $value; + } + } + } + return $row; +} + +sub parse_wmic ($) +{ + my ($result) = @_; + + my $header; + my $keywords; + my $list = []; + foreach my $line (@$result) { + next if $line =~ /^ *$/o; + if (! defined $header) { + ($header, $keywords) = parse_header($line); + next; + } + push @$list, parse_line($header, $keywords, $line); + } + return ($header, $list); +} + +sub do_net_user ($$;$$$$) +{ + my ($username, $delete, $password, $fullname, $enabled, $pwchange) = @_; + + my $sourcefile = $ENV{systemroot}.'\\System32\\net.exe'; + my $paramlist = ['user', $username]; + if (! $delete) { + push @$paramlist, '"'.$password.'"' if defined $password; + push @$paramlist, '/expires:never'; + push @$paramlist, '/passwordchg:'.($pwchange ? 'yes' : 'no'); + push @$paramlist, '/active:'.($enabled ? 'yes' : 'no'); + push @$paramlist, '/fullname:"'.$fullname.'"'; + } + push @$paramlist, $delete ? '/delete' : '/add'; + my ($error, $exitcode) = run_exe('global', undef, undef, undef, $sourcefile, $paramlist, 0); + if (defined $error) { + print_log('global', ERROR, 'Error %s user %s: %s', + $delete ? 'deleting' : 'creating', $username, $error); + return 0; + } + if ($delete) { + print_log('global', DEBUG1, 'Deleted user entry %s', $username); + } + else { + print_log('global', DEBUG1, 'Created user entry %s', $username); + } + return 1; +} + +sub do_modify_user ($$$$$) +{ + my ($username, $fullname, $enabled, $pwchange, $pwexpires) = @_; + + my $sourcefile = $ENV{systemroot}.'\\System32\\wbem\\wmic.exe'; + my $paramlist = ['useraccount', 'where', '"Name=\''.$username.'\'"']; + my $first = 1; + if (defined $fullname) { + push @$paramlist, $first ? 'set' : ','; + push @$paramlist, 'FullName="'.$fullname.'"'; + $first = 0; + } + if (defined $enabled) { + push @$paramlist, $first ? 'set' : ','; + push @$paramlist, 'Disabled='.($enabled ? 'FALSE' : 'TRUE'); + $first = 0; + } + if (defined $pwexpires) { + push @$paramlist, $first ? 'set' : ','; + push @$paramlist, 'PasswordExpires='.($pwexpires ? 'TRUE' : 'FALSE'); + $first = 0; + } + if (defined $pwchange) { + push @$paramlist, $first ? 'set' : ','; + push @$paramlist, 'PasswordChangeable='.($pwchange ? 'TRUE' : 'FALSE'); + $first = 0; + } + my ($error, $exitcode) = run_exe('global', undef, undef, undef, $sourcefile, $paramlist, 0); + if (defined $error) { + print_log('global', ERROR, 'Error modifying user %s: %s', $username, $error); + return 0; + } + print_log('global', DEBUG1, 'Modified user entry %s', $username); + return 1; +} + +sub read_mbr_file ($$) +{ + my ($config, $pkg) = @_; + + my $vars = get_default_vars($config); + set_datetime_vars($vars); + + my $sourcefile = substitute_variables($vars, $$pkg{'mbr-source-file'}, 1, $$vars{pkgtooldir}, 'global'); + if (! -f $sourcefile) { + print_log('global', ERROR, 'Cannot find MBR template file %s: %s', $sourcefile, $!); + return undef; + } + if (! sysopen(MBR, $sourcefile, O_RDONLY)) { + print_log('global', ERROR, 'Cannot open MBR template file %s: %s', $sourcefile, $!); + return undef; + } + my $buffer = ''; + my $offs = 0; + while (1) { + my $into; + my $rc = sysread(MBR, $into, 4096, $offs); + if (! defined $rc) { + print_log('global', ERROR, 'Cannot read MBR template file %s: %s', $sourcefile, $!); + close(MBR); + return undef; + } + last unless $rc; + $buffer .= $into; + } + close(MBR); + print_log('global', DEBUG1, 'Finished reading MBR template of %d bytes', length($buffer)); + return $buffer; +} + +sub print_mbr ($$$$) +{ + my ($channel, $level, $caption, $content) = @_; + + print_log($channel, $level, '%s', $caption); + my $len = length($content); + for (my $offs = 0; $offs < $len; $offs += 16) { + my $index; + my $buf = sprintf("%04.4x ", $offs); + for ($index = 0; $index < 16 && $offs + $index < $len; $index++) { + my $chr = substr($content, $offs + $index, 1); + $buf .= sprintf(" %02.2x", ord($chr)); + } + for (; $index < 16; $index++) { + $buf .= " "; + } + $buf .= " "; + for ($index = 0; $index < 16 && $offs + $index < $len; $index++) { + my $chr = substr($content, $offs + $index, 1); + $chr = '.' if ord($chr) < 32 || ord($chr) >= 127; + $buf .= $chr; + } + print_log($channel, $level, '%s', $buf); + } +} + +sub handle_mbr ($$$$) +{ + my ($config, $pkg, $counters, $update) = @_; + + my $name = $$pkg{name}; + my $mbrdrive = $$config{'mbr-drive'}; + if (! defined $mbrdrive || $mbrdrive eq '') { + print_log('global', INFO, 'Skipping MBR check because MBR drive is not specified'); + push @{$$counters{SkipList}}, $name; + $$counters{SkipCount}++; + return 0; + } + my $mbrtemplate = read_mbr_file($config, $pkg); + if (! defined $mbrtemplate) { + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + my $readsize = int((length($mbrtemplate) + 511) / 512) * 512; + if (! $readsize) { + print_log('global', INFO, 'Skipping MBR check because MBR template is empty'); + push @{$$counters{SkipList}}, $name; + $$counters{SkipCount}++; + return 0; + } + my $fh = CreateFile($mbrdrive, GENERIC_READ()|GENERIC_WRITE(), FILE_SHARE_READ()|FILE_SHARE_WRITE(), [], OPEN_EXISTING(), 0, []); + if (! $fh) { + print_log('global', ERROR, 'Error opening MBR drive %s: %s', $mbrdrive, fileLastError()); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + my $mbrblock; + if (! ReadFile($fh, $mbrblock, $readsize, [], [])) { + print_log('global', ERROR, 'Error reading MBR drive %s: %s', $mbrdrive, fileLastError()); + CloseHandle($fh); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + if (length($mbrblock) < $readsize) { + print_log('global', ERROR, 'Short read of %d bytes instead of %d from MBR drive %s: %s', + length($mbrblock), $readsize, $mbrdrive, fileLastError()); + CloseHandle($fh); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + print_log('global', DEBUG1, 'Finished reading MBR of %d bytes', length($mbrblock)); + print_mbr('global', DEBUG3, 'MBR found:', $mbrblock); + if (substr($mbrblock, 0, length($mbrtemplate)) eq $mbrtemplate) { + print_log('global', WARNING, 'MBR template %s checked: OK', $name); + CloseHandle($fh); + return 1; + } + print_log('global', WARNING, 'MBR template %s checked - %s', $name, $update ? 'installing' : 'INSTALL'); + if ($update) { + if (! SetFilePointer($fh, 0, 0, FILE_BEGIN)) { + print_log('global', ERROR, 'Error seeking to beginning of MBR drive %s: %s', + $mbrdrive, fileLastError()); + CloseHandle($fh); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + if (length($mbrblock) > length($mbrtemplate)) { + $mbrtemplate .= substr($mbrblock, length($mbrtemplate), length($mbrblock)-length($mbrtemplate)); + print_mbr('global', DEBUG3, 'MBR to write:', $mbrtemplate); + } + my $written = 0; + if (! WriteFile($fh, $mbrtemplate, length($mbrblock), $written, [])) { + print_log('global', ERROR, 'Error writing MBR drive %s: %s', $mbrdrive, fileLastError()); + CloseHandle($fh); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + if ($written < length($mbrblock)) { + print_log('global', ERROR, 'Short write of %d bytes instead of %d from MBR drive %s: %s', + $written, length($mbrblock), $mbrdrive, fileLastError()); + CloseHandle($fh); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + push @{$$counters{InstalledList}}, $name; + $$counters{InstalledCount}++; + } + else { + push @{$$counters{ToInstallList}}, $name; + $$counters{ToInstallCount}++; + } + CloseHandle($fh); + return 1; +} + +sub handle_user ($$$) +{ + my ($pkg, $counters, $update) = @_; + + my $name = $$pkg{name}; + my $username = $$pkg{'user'}; + my $password = $$pkg{'password'}; + my $deleted = $$pkg{'deleted'}; + $deleted = defined $deleted && $deleted; + my $enabled = $$pkg{'enabled'}; + $enabled = defined $enabled && $enabled; + my $pwchange = $$pkg{'pwchange'}; + $pwchange = defined $pwchange && $pwchange; + my $fullname = $$pkg{'fullname'}; + $fullname = '' unless defined $fullname; + my $pwexpires = $$pkg{'pwexpires'}; + $pwexpires = defined $pwexpires && $pwexpires; + + my $sourcefile = $ENV{systemroot}.'\\System32\\wbem\\wmic.exe'; + my $paramlist = ['useraccount', 'where', '"name=\''.$username.'\'"']; + my $result = []; + my ($error, $exitcode) = run_exe('global', undef, undef, undef, $sourcefile, $paramlist, 0, $result); + if (defined $error) { + print_log('global', ERROR, 'Error checking for user %s: %s', $username, $error); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + my $header; + my $found; + if (defined $$result[0] && $$result[0] !~ /No Instance/o) { + my $lcusername = lc($username); + ($header, $result) = parse_wmic($result); + foreach my $row (@$result) { + my $rowname = $$row{Name}; + next unless defined $rowname; + $found = $row if lc($rowname) eq $username; + last; + } + } + if (defined $found) { + my $rowname = $$found{Name}; + my $rowdis = $$found{Disabled}; + my $rowfullname = $$found{FullName}; + my $rowpwexpires = $$found{PasswordExpires}; + my $rowpwchange = $$found{PasswordChangeable}; + $rowfullname = '' unless defined $rowfullname; + $rowpwexpires = defined $rowpwexpires && $rowpwexpires =~ /TRUE/io; + $rowdis = defined $rowdis && $rowdis =~ /TRUE/io; + $rowpwchange = defined $rowpwchange && $rowpwchange =~ /TRUE/io; + print_log('global', DEBUG1, 'Found user entry name:%s %s fullname:%s pwexpires:%s pwchangeable:%s', + $rowname, $rowdis ? 'disabled' : 'enabled', $rowfullname, + $rowpwexpires ? 'yes' : 'no', $rowpwchange ? 'yes' : 'no'); + if ($deleted) { + print_log('global', WARNING, 'User %s to delete: account %s exists - %s', + $name, $username, $update ? 'deleting' : 'DELETE'); + if ($update) { + my $rc = do_net_user($username, 1); + if (! $rc) { + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + push @{$$counters{RemovedList}}, $name; + $$counters{RemovedCount}++; + } + else { + push @{$$counters{ToRemoveList}}, $name; + $$counters{ToRemoveCount}++; + } + } + else { + my $changedis = ($rowdis && $enabled) || (! $rowdis && ! $enabled); + my $changepwchange = ($rowpwchange && ! $pwchange) || (! $rowpwchange && $pwchange); + my $changepwexpires = ($rowpwexpires && ! $pwexpires) || (! $rowpwexpires && $pwexpires); + my $changefullname = $rowfullname ne $fullname; + if ($changedis || $changepwchange || $changepwexpires || $changefullname) { + print_log('global', WARNING, 'User %s to create: account %s exists, needs modification - %s', + $name, $username, $update? 'modifying' : 'MODIFY'); + if ($update) { + my $rc = do_modify_user($username, $changefullname ? $fullname : undef, + $changedis ? $enabled : undef, + $changepwchange ? $pwchange : undef, + $changepwexpires ? $pwexpires : undef); + if (! $rc) { + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + push @{$$counters{InstalledList}}, $name; + $$counters{InstalledCount}++; + } + else { + push @{$$counters{ToInstallList}}, $name; + $$counters{ToInstallCount}++; + } + } + else { + print_log('global', WARNING, 'User %s to create: account %s exists - OK', + $name, $username); + } + } + } + else { + print_log('global', DEBUG1, 'User entry %s not found', $username); + if ($deleted) { + print_log('global', WARNING, 'User %s to delete: account %s does not exist - OK', + $name, $username); + } + else { + print_log('global', WARNING, 'User %s to create: account %s does not exist - %s', + $name, $username, $update? 'creating' : 'CREATE'); + if ($update) { + my $rc = do_net_user($username, 0, $password, $fullname, $enabled, $pwchange); + $rc = do_modify_user($username, undef, undef, undef, $pwexpires) if $rc; + if (! $rc) { + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return 0; + } + push @{$$counters{InstalledList}}, $name; + $$counters{InstalledCount}++; + } + else { + push @{$$counters{ToInstallList}}, $name; + $$counters{ToInstallCount}++; + } + } + } + return 1; +} + +sub handle_pkg ($$$$$$) +{ + my ($config, $base_directory, $db, $pkg, $counters, $update) = @_; + + my $name = $$pkg{name}; + my ($condcheck, $error) = pkg_check_condition($pkg, $name, $config); + if (defined $error) { + print_log('global', INFO, 'Ignoring package/patch %s: %s', $name, $error); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return; + } + if (defined $condcheck) { + if (! $condcheck) { + print_log('global', INFO, 'Skipping package/patch %s on false condition', $name); + push @{$$counters{SkipList}}, $name; + $$counters{SkipCount}++; + return; + } + print_log('global', DEBUG1, 'Considering package/patch %s with true condition', $name); + } + + if (defined $$pkg{'user'}) { + return handle_user($pkg, $counters, $update); + } + if (defined $$pkg{'mbr-source-file'}) { + return handle_mbr($config, $pkg, $counters, $update); + } + + my $pkgdefs = $$config{'package-def'}; + my $patchdefs = $$config{'patch-def'}; + my $def = $$pkgdefs{$name}; + my $pdef = $$patchdefs{$name}; + if (! defined $def && ! defined $pdef) { + print_log('global', WARNING, 'No package or patch definition %s found', $name); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return; + } + + if (defined $def) { + my ($condcheck, $error) = pkgdef_check_availability($def, $name, $config); + if (defined $error) { + print_log('global', INFO, 'Ignoring package %s: %s', $name, $error); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return; + } + if (defined $condcheck) { + if (! $condcheck) { + print_log('global', INFO, 'Skipping package %s on false condition', $name); + push @{$$counters{SkipList}}, $name; + $$counters{SkipCount}++; + return; + } + print_log('global', DEBUG1, 'Considering package %s with true condition', $name); + } + + my $desired = pkgdef_get_desired_version($config, $name, $base_directory, $def, $$pkg{'install-version'}); + my ($found, $toinstall, $toremove) = assess_pkg($config, $base_directory, $db, + $name, $desired, $$pkg{'remove-version'}, $def, $update); + if (! defined $found && ! defined $toinstall && ! defined $toremove) { + print_log('global', INFO, 'Ignoring package %s: Invalid package', $name); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return; + } + if (scalar @$toremove > 0) { + push @{$$counters{ToRemoveList}}, $name; + $$counters{ToRemoveCount} += scalar @$toremove; + } + if (defined $toinstall) { + push @{$$counters{ToInstallList}}, $name; + $$counters{ToInstallCount}++; + } + if ($update) { + remove_package($db, $def, $name, $toremove, $base_directory, $config, $counters) + if scalar @$toremove > 0; + install_package($db, $def, $found, $name, $desired, $base_directory, + $$config{'generic-msi-parameters'}, $config, $counters) + if defined $toinstall; + } + } + if (defined $pdef) { + my ($condcheck, $error) = patchsetdef_check_availability($pdef, $name, $config); + if (defined $error) { + print_log('global', INFO, 'Ignoring patch set %s: %s', $name, $error); + push @{$$counters{FailList}}, $name; + $$counters{FailCount}++; + return; + } + if (defined $condcheck) { + if (! $condcheck) { + print_log('global', INFO, 'Skipping patch set %s on false condition', $name); + push @{$$counters{SkipList}}, $name; + $$counters{SkipCount}++; + return; + } + print_log('global', DEBUG1, 'Considering patch set %s with true condition', $name); + } + drop_pkg_cache($db); + my $patchlist = $$pdef{patches}; + foreach my $patchdef (@$patchlist) { + ($condcheck, $error) = patchdef_check_availability($pdef, $patchdef, $name, $config); + if (defined $error) { + print_log('global', INFO, 'Ignoring patch set %s patches %s: %s', $name, join(',', @{$$patchdef{kb}}), $error); + push @{$$counters{FailList}}, @{$$patchdef{kb}}; + $$counters{FailCount} += scalar @{$$patchdef{kb}}; + return; + } + if (defined $condcheck) { + if (! $condcheck) { + print_log('global', INFO, 'Skipping patch set %s patches %s on false condition', $name, join(',', @{$$patchdef{kb}})); + push @{$$counters{SkipList}}, @{$$patchdef{kb}}; + $$counters{SkipCount} += @{$$patchdef{kb}}; + return; + } + print_log('global', DEBUG1, 'Considering patch set %s patches %s with true condition', $name, join(',', @{$$patchdef{kb}})); + } + + foreach my $kb (@{$$patchdef{kb}}) { + my $leave = assess_patch($config, $base_directory, $db, $name, $pdef, $patchdef, $kb, $update, $counters); + if ($update && ! $leave) { + install_patch($config, $base_directory, $db, $pdef, $patchdef, $kb, $counters); + } + } + } + } +} + +sub get_install_sets ($) +{ + my ($config) = @_; + + my $url = 'http://'.$$config{'install-host'}.$$config{'install-path'}; + print_log('global', DEBUG1, 'Getting package configuration from \'%s\'', $url); + my $ua = LWP::UserAgent->new; + my $response = $ua->get($url); + if (! $response->is_success) { + print_log('global', ERROR, 'Error getting package configuration from \'%s\': %s', $url, $response->status_line); + return 1; + } + my $flags = {}; + my $pkgsets = $$config{'package-sets'}; + $pkgsets = {} unless defined $pkgsets; + foreach my $line (split /\n/, $response->decoded_content) { + chomp $line; + print_log('global', DEBUG3, 'Received response line: %s', $line); + next unless $line =~ /^([^=]+)=(.*)$/o; + my $key = $1; + my $value = $2; + if ($key eq 'pkgset') { + my $pkgset = $$pkgsets{$value}; + if (defined $pkgset) { + print_log('global', DEBUG1, 'Found package set %s', $value); + foreach my $pkgflag (@$pkgset) { + if (! defined $$flags{$pkgflag}) { + print_log('global', DEBUG1, 'Adding package flag %s', $pkgflag); + $$flags{$pkgflag} = 1; + } + } + } + else { + print_log('global', ERROR, 'Undefined packaget set %s', $value); + } + next; + } + if ($key eq 'pkg') { + if (! defined $$flags{$value}) { + print_log('global', DEBUG1, 'Adding package flag %s', $value); + $$flags{$value} = 1; + } + } + } + my $genvars = $$config{'generic-variables'}; + foreach my $pkgflag (keys %$flags) { + push @$genvars, { + variable => 'set-'.$pkgflag, + expression => 1 + }; + } + return undef; +} + +1;