# Windows.pm: Class Used for Interfacing with Microsoft Windows

package RDA::Object::Windows;

# $Id: Windows.pm,v 1.22 2015/12/17 20:28:47 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Windows.pm,v 1.22 2015/12/17 20:28:47 RDA Exp $
#
# Change History
# 20151217  MSC  Improve the GMT time reporting.

=head1 NAME

RDA::Object::Windows - Class Used for Interfacing with Microsoft Windows

=head1 SYNOPSIS

 require RDA::Object::Windows;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Windows> class are used to interface with
Microsoft Windows. Limited operations remain available on other operating
systems.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Handle::Memory;
  use RDA::Handle::Vector;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Rda;
  use RDA::Object::View;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'convertUtf16'    => ['$[WIN]', 'convert_utf16'],
    'getCodePage'     => ['$[WIN]', 'get_code_page'],
    'getRegValue'     => ['$[WIN]', 'get_registry'],
    'getReg32Value'   => ['$[WIN]', 'get_registry32'],
    'getReg64Value'   => ['$[WIN]', 'get_registry64'],
    'getSysinfo'      => ['$[WIN]', 'get_systeminfo'],
    'getVersionInfo'  => ['$[WIN]', 'get_version'],
    'grepRegValue'    => ['$[WIN]', 'grep_registry'],
    'grepReg32Value'  => ['$[WIN]', 'grep_registry32'],
    'grepReg64Value'  => ['$[WIN]', 'grep_registry64'],
    'hasRegOption'    => ['$[WIN]', 'has_reg_option'],
    'isUtf16'         => ['$[WIN]', 'is_utf16'],
    'loadRegistry'    => ['$[WIN]', 'load_registry'],
    'writeEvents'     => ['$[WIN]', 'write_events',     '${CUR.O_REPORT}'],
    'writeFirewall'   => ['$[WIN]', 'write_firewall',   '${CUR.O_REPORT}'],
    'writeMsinfo'     => ['$[WIN]', 'write_msinfo',     '${CUR.O_REPORT}'],
    'writeRegistry'   => ['$[WIN]', 'write_registry',   '${CUR.O_REPORT}'],
    'writeRegistry32' => ['$[WIN]', 'write_registry32', '${CUR.O_REPORT}'],
    'writeRegistry64' => ['$[WIN]', 'write_registry64', '${CUR.O_REPORT}'],
    'writeSysinfo'    => ['$[WIN]', 'write_systeminfo', '${CUR.O_REPORT}'],
    'writeWinmsd'     => ['$[WIN]', 'write_winmsd',     '${CUR.O_REPORT}'],
    },
  beg => \&_begin_windows,
  inc => [qw(RDA::Object)],
  met => {
    'convert_utf16'    => {ret => 1},
    'get_code_page'    => {ret => 0},
    'get_info'         => {ret => 0},
    'get_registry'     => {ret => 0},
    'get_registry32'   => {ret => 0},
    'get_registry64'   => {ret => 0},
    'get_systeminfo'   => {ret => 0},
    'get_version'      => {ret => 0},
    'grep_registry'    => {ret => 1},
    'grep_registry32'  => {ret => 1},
    'grep_registry64'  => {ret => 1},
    'has_reg_option'   => {ret => 0},
    'is_utf16'         => {ret => 0},
    'load_command'     => {ret => 0},
    'load_registry'    => {ret => 0},
    'set_info'         => {ret => 0},
    'write_events'     => {ret => 0},
    'write_firewall'   => {ret => 0},
    'write_msinfo'     => {ret => 0},
    'write_registry'   => {ret => 0},
    'write_registry32' => {ret => 0},
    'write_registry64' => {ret => 0},
    'write_systeminfo' => {ret => 0},
    'write_winmsd'     => {ret => 0},
    },
  top => 'WIN',
  );

# Define the global private constants
my $BOC = "<code>\n";
my $BOV = "<verbatim>\n";
my $EOC = "</code>\n";
my $EOV = "</verbatim>\n";
my $WRK = 'win.txt';

my $REG   = q{};
my $REG32 = ' /reg:32';  ## no critic (Numbered)
my $REG64 = ' /reg:64';  ## no critic (Numbered)

# Define the global private variables
my %tb_cat = (
  0 => 'None',
  1 => 'General',
  2 => 'Disk',
  8 => 'Installation',
  );
my %tb_msi = (
  'ComponentsDisplay'         => ['Display' => 1],
  'ComponentsStorageDrives'   => ['Disks' => 1, 'Drives' => 1],
  'ComponentsNetworkProtocol' => ['Protocol' => 1],
  'Odbc'                      => ['ODBC Drivers' => 2],
  'ResourcesMemory'           => ['Memory' => 1],
  'SWEnvServices'             => ['Services' => 1],
  'SWEnvDrivers'              => ['System Drivers' => 1],
  'SWEnvEnvVars'              => ['Environment Variables' => 1],
  'SystemSummary'             => ['System Summary' => 1],
  );
my %tb_reg = (
  buf => [\&_get_buf, \&_grep_buf, \&_test_buf, \&_write_buf],
  fil => [\&_get_fil, \&_grep_fil, \&_test_fil, \&_write_fil],
  reg => [\&_get_reg, \&_grep_reg, \&_test_reg, \&_write_reg],
  );
my @tb_sys = (
  'host name',
  'os name',
  'os version',
  'os manufacturer',
  'os configuration',
  'os build type',
  'registered owner',
  'registered organization',
  'product id',
  'original install date',
  'system boot time',
  'system manufacturer',
  'system model',
  'system type',
  'processors',
  'bios version',
  'windows directory',
  'system directory',
  'boot device',
  'system locale',
  'input locale',
  'time zone',
  'total physical memory',
  'available physical memory',
  'max virtual memory',
  'available virtual memory',
  'virtual memory in use',
  'page file locations',
  'domain',
  'logon server',
  'hotfixes',
  'network cards',
  );

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Object::Windows-E<gt>new($collector)>

The object constructor. It takes the collector object reference as an argument.

C<RDA::Object::Windows> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'oid' > > Object identifier

=item S<    B<'_agt'> > Reference to the agent object

=item S<    B<'_buf'> > Registry hash

=item S<    B<'_col'> > Reference to the collector object

=item S<    B<'_cpg'> > Current code page

=item S<    B<'_msi'> > F<msinfo32> access method

=item S<    B<'_opt'> > REG option indicator

=item S<    B<'_reg'> > Registry access methods

=item S<    B<'_sys'> > F<systeminfo> cache

=item S<    B<'_utb'> > UTF-16 to UTF-8 / begin of file indicator

=item S<    B<'_utf'> > UTF-16 to UTF-8 / unpack format

=item S<    B<'_uth'> > UTF-16 to UTF-8 / input file handle

=item S<    B<'_uti'> > UTF-16 to UTF-8 / input array

=item S<    B<'_utl'> > UTF-16 to UTF-8 / character left from previous read

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, $col) = @_;
  my ($slf);

  # Create the object
  $slf = bless {
    oid  => $col->get_oid,
    _agt => $col->get_agent,
    _col => $col,
    }, ref($cls) || $cls;

  # Determine how access the registry and msinfo32
  if (RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin)
  { $slf->{'_buf'} = {};
    $slf->{'_reg'} =
      $tb_reg{$col->get_registry('windows.reg', \&_init_win_reg, $slf)};
    $slf->{'_opt'} =
      $col->get_registry('windows.opt', \&_has_reg_option, $slf);
    $slf->{'_msi'} = 1
      if $col->get_registry('windows.msi', \&_init_win_msi, $slf);
  }
  else
  { $slf->{'_buf'} = [];
    $slf->{'_cpg'} = undef;
    $slf->{'_reg'} = $tb_reg{'fil'};
    $slf->{'_sys'} = {};
  }

  # Return the object reference
  return $slf;
}

sub _init_win_msi
{ my ($slf) = @_;

  return &{$slf->{'_reg'}->[0]}($slf,
    'HKLM\Software\Microsoft\Windows NT\CurrentVersion', 'CurrentVersion',
    '5.1', $REG) =~ m/^6\./;
}

sub _init_win_reg
{ my ($slf) = @_;

  return _get_reg($slf,
    'HKLM\Software\Microsoft\Windows NT\CurrentVersion', 'ProductName',
    undef, $REG) ? 'reg' : 'buf';
}

=head2 S<$h-E<gt>convert_utf16($string[,$mode])>

This method converts the string from UTF-16 to UTF-8 and returns the result
as a line array. It supports the following modes:

=over 9

=item B<    'd' > Detects the byte order from the first bytes.

=item B<    'i' > Inverses the bytes.

=back

=cut

sub convert_utf16
{ my ($slf, $src, $flg) = @_;
  my ($lin, @lin);

  if (_init_utf16($slf, $src, $flg))
  { push(@lin, $lin) while defined($lin = _getl_utf16($slf));
    _close_utf16($slf);
  }
  return @lin;
}

=head2 S<$h-E<gt>get_code_page>

This method returns the current code page. It returns an undefined value
outside Windows platforms.

=cut

sub get_code_page
{ my ($slf) = @_;
  my ($set);

  return $slf->{'_cpg'} if exists($slf->{'_cpg'});

  $slf->{'_col'}->incr_usage('OS');
  ($set) = `cmd /c chcp`;
  return $slf->{'_cpg'} = ($set =~ m/\s(\d+)[\n\r\s]*$/) ? $1 : undef;
}

=head2 S<$h-E<gt>get_registry($key,$nam[,$dft])>

This method returns the value of a registry key name. It returns the default
value when not found.

When using a 32-bit Perl, the method extracts the key value from the 32-bit
registry, while a 64-bit Perl extracts the value from the 64-bit registry.

=head2 S<$h-E<gt>get_registry32($key,$nam[,$dft])>

This method returns the value of a registry key name from the 32-bit
registry. It returns the default value when not found.

=head2 S<$h-E<gt>get_registry64($key,$nam[,$dft])>

This method returns the value of a registry key name from the 64-bit
registry. It returns the default value when not found.

=cut

sub get_registry
{ return _get_registry($REG, @_);
}

sub get_registry32
{ return _get_registry($REG32, @_);  ## no critic (Numbered)
}

sub get_registry64
{ return _get_registry($REG64, @_);  ## no critic (Numbered)
}

sub _get_registry
{ my ($opt, $slf, $key, $nam, $val) = @_;

  return $val unless $key && $nam;
  return &{$slf->{'_reg'}->[0]}($slf, $key =~ m/^([^"]+)$/, $nam, $val, $opt);
}

=head2 S<$h-E<gt>get_systeminfo([$key[,$dft]])>

This method returns the value of the specified C<systeminfo> entry or the
default value when not found.

It returns a reference to a hash containing all entries when no entry is
specified.

=cut

sub get_systeminfo
{ my ($slf, $key, $dft) = @_;
  my ($itm, $tbl, $val, @itm, @lin, @val);

  # Get the systeminfo on first run
  unless (exists($slf->{'_sys'}))
  { $slf->{'_sys'} = $tbl = {};

    # Get the system information
    if (open(IN, 'systeminfo /FO CSV 2>&1 |'))  ## no critic (Handle,Open)
    { while (<IN>)
      { s/[\s\n\r]+$//;
        push(@lin, $1) if m/^"(.*)"$/;
      }
      close(IN);
      $slf->{'_col'}->incr_usage('OS');
    }
    return $dft unless (scalar @lin) == 2;

    # Decode the information
    @itm = @tb_sys;
    @val = split(/","/, $lin[1]);
    while (defined($itm = shift(@itm)) && defined($val = shift(@val)))
    { $tbl->{$itm} = ($itm =~ m/^(hotfixes|network|processors)/)
        ? [split(/,/, $val)]
        : $val;
    }
  }

  # Return the entry value
  return
    !defined($key)                            ? $slf->{'_sys'} :
    exists($slf->{'_sys'}->{$key = lc($key)}) ? $slf->{'_sys'}->{$key} :
                                                $dft;
}

=head2 S<$h-E<gt>get_version($file[,$flag])>

This method returns the version information of the specified file as a hash
reference. Unless the flag is set, it encodes the value of the entries ending
with C<version>. It returns an empty list when problems are encountered.

=cut

sub get_version
{ my ($slf, $fil, $flg) = @_;
  my ($ifh, $inf);

  $ifh = IO::File->new;
  $inf = {};
  if ($fil && $ifh->open("<$fil"))
  { binmode($ifh);
    _get_version($inf, $ifh, $flg);
    $ifh->close;
  }
  return $inf;
}

sub _get_version
{ my ($inf, $ifh, $flg) = @_;
  my ($bas, $buf, $cnt, $nxt, $off, $siz, @tbl);

  # Read the first block
  return unless $ifh->sysread($buf, 4096) == 4096;
  ($nxt) = unpack('V', substr($buf, 0, 4));
  return unless $nxt == 0x905a4d;  ## no critic (Number)

  # List the sections
  ($off) = unpack('V', substr($buf, 60, 4));
  ($cnt) = unpack('v', substr($buf, $off +  6, 2));
  ($siz) = unpack('v', substr($buf, $off + 20, 2));
  $nxt = 0;
  for ($off += 24 + $siz ; $cnt-- > 0 ; $off += 40)  ## no critic (Loop)
  { @tbl = unpack('Z8V4', substr($buf, $off, 40));
    ($nxt, $siz, $bas) = ($tbl[4], $tbl[3], $tbl[2]) if $tbl[0] eq '.rsrc';
  }

  # Read the resource block
  return unless $nxt && $siz && defined(sysseek($ifh, $nxt, 0))
    && $ifh->sysread($buf, $siz) == $siz;

  # Find the version information
  ($siz, $cnt) = unpack('v2', substr($buf, 12, 4));
  $nxt = 0;
  for ($off = 16 + $siz * 8 ; $cnt-- > 0 ; $off += 8)  ## no critic (Loop)
  { @tbl = unpack('v3', substr($buf, $off, 6));
    $nxt = $tbl[2] if $tbl[0] == 16;
  }
  return unless $nxt;

  ($off) = unpack('v', substr($buf, $nxt + 20, 2));
  ($off) = unpack('v', substr($buf, $off + 20, 2));
  ($off, $siz) = unpack('V2', substr($buf, $off, 8));

  # Decode the file information
  @tbl = unpack('v*', substr($buf, $off - $bas, $siz));
  _ext_version($inf, \@tbl, 0, $flg) if $siz == $tbl[0];
  return;
}

sub _ext_version
{ my ($inf, $tbl, $off, $flg) = @_;
  my ($beg, $dat, $end, $key, $siz, $str, $typ, @str);

  $beg = $off;
  $siz = $tbl->[$off++];
  $end = $beg + $siz / 2;
  $dat = $tbl->[$off++];
  $typ = $tbl->[$off++];

  # Extract the associated key
  push(@str, $tbl->[$off++]) while $tbl->[$off];
  ++$off if ++$off & 1;  ## no critic (Bit)
  $key = _ext_ver_str(\@str);

  # Extract the value
  if ($typ == 0)
  { $off += int(($dat + 1) / 2);
    ++$off if $off & 1;  ## no critic (Bit)
  }
  elsif ($dat)
  { @str = ();
    push(@str, $tbl->[$off++]) while $tbl->[$off];
    ++$off if ++$off & 1;  ## no critic (Bit)
    $str = _ext_ver_str(\@str);
    $str =~ s/\./&#46;/g
      unless $flg || $key !~ m/version$/i;  ## no critic (Unless)
    $inf->{$key} = $str;
    return $off;
  }

  $off = _ext_version($inf, $tbl, $off, $flg) while $off < $end;
  return $off;
}

sub _ext_ver_str
{ my ($buf, $chr, @inp);

  _cnv_utf16(\@inp, shift);
  $buf = q{};
  $buf .= chr($chr) while defined($chr = shift(@inp)) && $chr;
  return $buf;
}

=head2 S<$h-E<gt>grep_registry($key,$nam[,$flg])>

This method returns the list of registry keys that contain the specified value
name. When the flag is set, it returns C<key|name> pairs.

When using a 32-bit Perl, the method extracts the key value from the 32-bit
registry, while a 64-bit Perl extracts the value from the 64-bit registry.

=head2 S<$h-E<gt>grep_registry32($key,$nam[,$flg])>

This method returns the list of registry keys from the 32-bit registry
that contain the specified value name. When the flag is set, it returns
C<key|name> pairs.

=head2 S<$h-E<gt>grep_registry64($key,$nam[,$flg])>

This method returns the list of registry keys from the 64-bit registry
that contain the specified value name. When the flag is set, it returns
C<key|name> pairs.

=cut

sub grep_registry
{ return _grep_registry($REG, @_);
}

sub grep_registry32
{ return _grep_registry($REG32, @_);  ## no critic (Numbered)
}

sub grep_registry64
{ return _grep_registry($REG64, @_);  ## no critic (Numbered)
}

sub _grep_registry
{ my ($opt, $slf, $key, $nam, $flg) = @_;

  return () unless $key && $nam;
  return &{$slf->{'_reg'}->[1]}($slf, $key =~ m/^([^"]+)$/, $nam, $flg, $opt);
}

=head2 S<$h-E<gt>has_reg_option>

This method indicates whether both 32-bit and 64-bit parts of the registry are
accessible.

=cut

sub has_reg_option
{ return shift->{'_opt'};
}

sub _has_reg_option
{ my ($slf) = @_;

  return &{$slf->{'_reg'}->[2]}($slf);
}

=head2 S<$h-E<gt>is_utf16($string)>

This method indicates that the content of the string could be UTF-16 characters.

=cut

sub is_utf16
{ my ($slf, $str) = @_;

  $str = join(q{}, @{$str}) if ref($str) eq 'ARRAY';
  if (defined($str) || (length($str) % 2) == 0)
  { return 1
      if $str =~ m/\000\015\000\012/s
      || $str =~ m/\A\377\376/
      || $str =~ m/\A\376\377/
      || $str =~ m/(\000[^\000]){3}/m;
  }
  return 0;
}

=head2 S<$h-E<gt>load_command($command)>

This method executes the specified command and converts all lines to UTF-8. It
returns a line buffer containing the results or an undefined value in case of
problems.

=cut

sub load_command
{ my ($slf, $cmd) = @_;
  my ($buf);

  # Abort when the command is missing
  return unless $cmd
    && (RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin);

  # Load the command result
  $buf =_load_command($slf, $cmd);

  # Remove the temporary file
  $slf->{'_col'}->clean_work($WRK);

  # Return the execution results
  return $buf;
}

sub _load_command
{ my ($slf, $cmd) = @_;
  my ($arg, $buf, $lin, $out, $tmp);

  # Write the command output to a temporary file
  local $SIG{'PIPE'}     = 'IGNORE';
  local $SIG{'__WARN__'} = sub { };

  $tmp = $slf->{'_col'}->get_work($WRK, 1);
  $out = RDA::Object::Rda->quote($tmp);
  $arg = $cmd;
  $arg =~ s{(\s+2>&1)?\s*$}{ >$out $1};
  if (RDA::Object::Rda->is_windows)
  { $arg =~ s{/dev/null}{NUL}g;
  }
  else
  { $arg = qq{exec $arg};
  }
  return unless open(OUT, qq{| $arg});  ## no critic (Handle,Open)
  close(OUT);
  $slf->{'_col'}->incr_usage('OS');

  # Load the command result
  return unless _open_utf16($slf, $tmp);
  $buf = [];
  push(@{$buf}, $lin) while defined($lin = _getl_utf16($slf));
  _close_utf16($slf);
  return RDA::Object::Buffer->new('L', $buf);
}

=head2 S<$h-E<gt>load_registry($fil)>

This method loads the registry data from a file.

=cut

sub load_registry
{ my ($slf, $fil) = @_;
  my ($ifh, $lin, $reg);

  $ifh = IO::File->new;
  return 0 unless $ifh->open("<$fil");
  $slf->{'_buf'} = $reg = [];
  $lin = q{};
  while (<$ifh>)
  { s/[\n\r]+$//;
    $lin .= $_;
    next if $lin =~ s/\\$//;
    if ($lin =~ m/^\[([^\]]*)\]/)
    { push(@{$reg}, "HKEY_LOCAL_MACHINE\\$1");
    }
    elsif ($lin =~ s/\s+=\s+\((REG_[A-Z_]+)\)\s+"?/ $1 /)
    { $lin =~ s/"?\s*$//;
      push(@{$reg}, $lin)
    }
    $lin = q{};
  }
  $ifh->close;
  $slf->{'_reg'} = $tb_reg{'fil'};
  return 1;
}

=head2 S<$h-E<gt>write_events($rpt,$fil[,$src[,$age[,$full]]])>

This method extracts events from the specified event log and writes them to
the report file. You can filter events by using a regular expression to
indicate which sources are relevant. When a number greater than zero is
specified as age, then only the events more recent than that number of days
are considered. By default, it includes main fields only in the report. This
is controlled by the last argument.

It returns the number of the events written.

=cut

sub write_events  ## no critic (Complex)
{ my ($slf, $rpt, $fil, $flt, $age, $all) = @_;
  my ($cnt, $ifh);

  # Initialize the filter
  $age = ($age && $age > 0) ? time - 86400 * $age : 0;
  $flt = RDA::Object::View->is_pattern($flt) if $flt;

  # Treat the event log file
  $cnt = 0;
  $ifh = IO::File->new;
  if ($ifh->open("<$fil"))
  { my ($buf, $cmp, $dat, $evt, $lgt, $nxt, $off, $siz, $src, $str);

    # Load the file content
    binmode($ifh);
    $off = 0;
    $off += $lgt while ($lgt = read($ifh, $dat, 65536, $off));
    close($ifh);

    # Create the circular buffer
    $evt = RDA::Handle::Memory->new(\$dat);
    $evt->setlim(unpack('L', $dat));

    # Find and load the end record
    return 0 unless _find_end_evt($evt, \$dat);
    $lgt = $evt->sysread($buf, 4);
    $evt->sysseek($off = unpack('L',$buf), 0);

    # Treat all events
    for ($nxt = 4  ## no critic (Loop)
         ; ($lgt = $nxt) && $evt->sysread($buf, $lgt) == $lgt
         ;)
    { # Determine the size of the next record
      ($nxt) = unpack('L', substr($buf,-4));
      next if $lgt == 4;

      # Analyze the header
      ## no critic (Numbered)
      my ($sig, $rec, $tmc, $tmw, $eid, $typ, $num, $flg, $cat,
          $end, $off1, $lgt2, $off2, $lgt3, $off3) = unpack('L4S4L7', $buf);
      last unless $sig == 0x654c664c;  ## no critic (Number)

      # Filter the event on its age
      next if $age && $tmc < $age;

      # Filter the event on its source
      if (($siz = $off1 - 56) > 0)
      { my (@src, @tbl);
        @src = unpack('v*', substr($buf, 52, $siz));
        _cnv_utf16(\@tbl, \@src);
        $src = _ext_evt_txt(\@tbl);
        $cmp = _ext_evt_txt(\@tbl);
      }
      else
      { $cmp = $src = q{};
      }
      next if $flt && $src !~ $flt;

      # Print the event
      $str = ($cnt++) ? qq{| ||\n} : q{};
      $str .= q{|*Record Number*|}.$rec.qq{ |\n} if $all;
      $str .= q{|*Event Id*|}.$eid
        .qq{ |\n|*Created*|}.RDA::Object::Rda->get_gmtime($tmc)
        .qq{ |\n};
      $str .= q{|*Written*|}.RDA::Object::Rda->get_gmtime($tmw)
        .qq{ |\n|*Type*|}.sprintf('0x%04x', $typ)
        .qq{ |\n|*Flag*|}.sprintf('0x%04x', $flg)
        .qq{ |\n} if $all;
      $str .= q{|*Category*|}.($tb_cat{$cat} || qq{($cat)}).qq{ |\n};
      $str .= q{|*Source*|}.$src.qq{ |\n|*Computer*|}.$cmp.qq{ |\n}
        if $src || $cmp;
      if (($siz = $off3 - $off1) > 0)
      { my (@src, @tbl);
        @src = unpack('v*', substr($buf, $off1 - 4, $siz));
        _cnv_utf16(\@tbl, \@src);
        $str .= q{|*Description*|}._ext_evt_txt(\@tbl).qq{ |\n}
      }
      $str .= q{|*String*|}._ext_evt_str(substr($buf, $off3 - 4, $lgt3))
        .qq{ |\n} if $lgt3;
      $str .= q{|*SID*|}._dump_evt_data(substr($buf, $off2 - 4, $lgt2))
        .qq{ |\n} if $lgt2;
      $rpt->write($str);
    }
    $evt->close;
  }
  return $cnt;
}

sub _dump_evt_data
{ my ($str) = @_;
  my ($buf, $sep);

  $sep = $buf = q{};
  foreach my $chr (split(//, $str))
  { $buf .= $sep.sprintf('%02x', ord($chr));
    $sep = q{ };
  }
  return qq{``$buf``};
}

sub _ext_evt_str
{ my ($str) = @_;

  # Detect a string in UTF-16
  if ($str =~ m/^\r\000\n\000/)
  { my (@src, @tbl);
    @src = unpack('v*', $str);
    _cnv_utf16(\@tbl, \@src);
    return q{``}._ext_evt_txt(\@tbl).q{``};
  }

  # Detect a binary string
  return _dump_evt_data($str) if $str =~ m/^.?[\000-\037]/;

  # Treat a string
  return _fmt_evt_str($str);
}

sub _ext_evt_txt
{ my $src = shift;
  my $buf = q{};
  my $chr;

  while (defined($chr = shift(@{$src})))
  { last unless $chr;
    $buf .= chr($chr);
  }
  return _fmt_evt_str($buf);
}

sub _find_end_evt
{ my ($evt, $dat) = @_;
  ## no critic (Numbered)
  my ($buf, $off, $sig1, $sig2);

  $sig1 = pack('H*','11111111');
  $sig2 = pack('H*','11111111222222223333333344444444');
  for ($off = 0  ## no critic (Loop)
       ; ($off = index($$dat, $sig1, $off)) > 0
       ; ++$off)
  { unless ($off & 3)  ## no critic (Bit)
    { $evt->sysseek($off, 0);
      return 0 unless $evt->sysread($buf, 16) == 16;
      return $off if $buf eq $sig2;
    }
  }
  return 0;
}

sub _fmt_evt_str
{ my ($str) = @_;

  $str =~ s/^\r//g;
  $str =~ s/^[\n\s]+//;
  $str =~ s/[\n\s]+$//;
  $str =~ s/\n+/\%BR\%/g;
  $str =~ s/\&/&amp;/g;
  $str =~ s/\'/&#39;/g;
  $str =~ s/\*/&#42;/g;
  $str =~ s/\`/&#96;/g;
  $str =~ s/\|/&#124;/g;
  return $str;
}

=head2 S<$h-E<gt>write_firewall($rpt[,$flg])>

This method writes the firewall configuration to the report file. It returns
the number of the lines written. When the flag is set, the subsections do
not contribute to the table of contents.

=cut

sub write_firewall
{ my ($slf, $rpt, $toc) = @_;
  my ($buf, $cnt, $flg, $lvl, $scp);

  return 0 unless RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin;

  $cnt = 0;
  if (open(IN,  ## no critic (Handle,Open)
    'netsh firewall show state verbose=enable |'))
  { # Reformat the command output
    $buf = q{};
    $toc = $toc ? q{+!!} : q{};
    while (<IN>)
    { s/[\s\n\r]+$//;
      if (m/^(.*):$/)
      { $buf .= qq{\n---+$toc $1};
        ++$cnt;
        $flg = $lvl = 2;
        $scp = ($1 =~ m/ICMP settings/) ? 0 : -1;
      }
      elsif (s/\s+=\s/ |/)
      { $buf .= qq{\n|$_ |};
        ++$cnt;
      }
      elsif ($flg && s/\s{2,}/* |*/g)
      { $lvl = tr/\|/\|/;
        $buf .= qq{\n|*$_* |};
        ++$cnt;
        if ($scp)
        { $buf .= q{*Scope* |};
          $scp = 1;
        }
      }
      elsif (s/\s{2,}/ |/g)
      { $buf .= qq{\n|$_ |};
        ++$cnt;
      }
      elsif (m/^-+$/)
      { $flg = 0;
      }
      elsif (m/^\s+Scope:\s+(.*)/)
      { $buf .= q{Scope: } if $scp < 0;
        $buf .= qq{$1 |};
      }
      else
      { $buf .= qq{\n$_};
        ++$cnt;
      }
    }
    $buf .= qq{\n};
    $rpt->write($buf);
    ++$cnt;
    close(IN);
    $slf->{'_col'}->incr_usage('OS');
  }

  # Return the number of lines written
  return $cnt;
}

=head2 S<$h-E<gt>write_msinfo($rpt,$ttl[,$cat,...])>

This method writes the result of C<msinfo32> categories to the report file. It
returns the number of the lines written.

=cut

sub write_msinfo  ## no critic (Complex)
{ my ($slf, $rpt, $ttl, @arg) = @_;
  my ($buf, $cat, $cnt, $flg, $hdr, $nxt, $pgm, $pre, $skp, $tbl, $tmp);

  return 0 unless RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin;

  if (exists($slf->{'_msi'}))
  { # Determine the category list
    $tbl = (scalar @arg)
      ? {map {@{exists($tb_msi{$_}) ? $tb_msi{$_} : []}} @arg}
      : {'System Summary' => 1};

    # Get the msinfo32 report on the first call
    $tmp = RDA::Object::Rda->cat_native($slf->{'_col'}->get_work('msi.txt', 1));
    unless (-f $tmp)
    { $pgm = RDA::Object::Rda->cat_file(
        $slf->{'_agt'}->get_env('COMMONPROGRAMFILES') =~ m/^([^"]+)$/,
        'Microsoft Shared', 'MSInfo', 'msinfo32.exe');
      $pgm = q{"}.$pgm.q{"} if RDA::Object::Rda->is_windows;
      $slf->{'_col'}->incr_usage('OS');
      eval {
        local $SIG{'__WARN__'} = sub { };

        system($pgm, '/report', $tmp);
        };
      return 0 if $@;
    }
  }
  else
  { # Determine the category list
    $cat = (scalar @arg) ? join(q{+}, @arg) : 'SystemSummary';

    # Get the information in a temporary file
    $tmp = RDA::Object::Rda->cat_native($slf->{'_col'}->get_work($WRK, 1));
    $pgm = RDA::Object::Rda->cat_file(
      $slf->{'_agt'}->get_env('COMMONPROGRAMFILES') =~ m/^([^"]+)$/,
      'Microsoft Shared', 'MSInfo', 'msinfo32.exe');
    return 0 unless -f $pgm;
    $pgm = q{"}.$pgm.q{"} if RDA::Object::Rda->is_windows;
    $slf->{'_col'}->incr_usage('OS');
    eval {
      local $SIG{'__WARN__'} = sub { };

      system($pgm, '/categories', "+$cat", '/report', $tmp);
      };
    return 0 if $@;
  }

  # Open the file
  return 0 unless _open_utf16($slf, "<$tmp");

  # Reformat the information
  $flg = $skp = 1;
  $cnt = $nxt = 0;
  $hdr = q{};
  $pre = "---+ $ttl\n";
  while (defined($_ = _getl_utf16($slf)))
  { s/\&/&amp;/g;
    s/</&lt;/g;
    s/>/&gt;/g;
    if (s/ *\t */ |/g)
    { next if $skp;
      s/^ \| \|/ ||/g;
      s/^/|/;
      s/([^\|])$/$1|/;
      s/^(\|[^\|]+\|)$/$1|/;
      s/\'/&#39;/g;
      s/\*/&#42;/g;
      s/\`/&#96;/g;
      if ($flg)
      { s/\|/*|*/g;
        s/^\*//;
        s/\*$//;
      }
    }
    elsif (m/^\[(.*)\]$/)
    { if (!$tbl)
      { $skp = ($1 eq 'System Summary' && $cat ne 'SystemSummary');
      }
      elsif (exists($tbl->{$1}))
      { $skp = 0;
        $nxt = $tbl->{$1};
      }
      elsif ($nxt)
      { $skp = (--$nxt) ? 0 : 1;
      }
      else
      { $skp = 1;
      }
      $hdr = ($1 eq $ttl) ? q{} : "---++!! $1\n";
      next;
    }
    else
    { $flg = 1;
      next;
    }
    $buf = $pre.$hdr.$_.qq{\n};
    $rpt->write($buf);
    if ($hdr)
    { ++$cnt;
      $hdr = q{};
    }
    ++$cnt;
    $flg = $pre = q{};
  }
  _close_utf16($slf);
  $slf->{'_col'}->clean_work($WRK) unless $tbl;

  # Return the number of lines written
  return $cnt;
}

=head2 S<$h-E<gt>write_registry($rpt,$key[,$lvl])>

This method writes the registry key to the report file. The level (starting
from 0) indicates the highest branch level to include in the report table of
contents. By default, it takes one more than the level of the specified key.
It returns the number of the lines written.

When using a 32-bit Perl, the method extracts the key value from the 32-bit
registry, while a 64-bit Perl extracts the value from the 64-bit registry.

=head2 S<$h-E<gt>write_registry32($rpt,$key[,$lvl])>

This method writes the registry key from the 32-bit registry to the report
file. The level (starting from 0) indicates the highest branch level to
include in the report table of contents. By default, it takes one more than
the level of the specified key. It returns the number of the lines written.

=head2 S<$h-E<gt>write_registry64($rpt,$key[,$lvl])>

This method writes the registry key from the 64-bit registry to the report
file. The level (starting from 0) indicates the highest branch level to
include in the report table of contents. By default, it takes one more than
the level of the specified key. It returns the number of the lines written.

=cut

sub write_registry
{ return _write_registry($REG, @_);
}

sub write_registry32
{ return _write_registry($REG32, @_);  ## no critic (Numbered)
}

sub write_registry64
{ return _write_registry($REG64, @_);  ## no critic (Numbered)
}

sub _write_registry
{ my ($opt, $slf, $rpt, $key, $lvl) = @_;

  # Determine the indexation level
  $lvl = 1 + ($key =~ tr/\\/\\/) unless defined($lvl);

  # Write the registry key and return the number of lines written
  return &{$slf->{'_reg'}->[3]}($slf, $rpt, $key =~ m/^([^"]+)$/, $lvl, $opt);
}

=head2 S<$h-E<gt>write_systeminfo($rpt)>

This method writes the C<systeminfo> information to the report file.

=cut

sub write_systeminfo
{ my ($slf, $rpt) = @_;
  my ($buf, $cnt, $itm, $nam, $val, @itm, @lin, @nam, @val);

  return 0 unless RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin;

  # Get the systeminfo output
  $cnt = 0;
  if (open(IN, q{systeminfo /FO CSV 2>&1 |}))  ## no critic (Handle,Open)
  { while (<IN>)
    { s/[\s\n\r]+$//;
      push(@lin, $1) if m/^"(.*)"$/;
    }
    close(IN);
    $slf->{'_col'}->incr_usage('OS');
  }
  return 0 unless (scalar @lin) == 2;

  # Decode the information
  @itm = split(/","/, $lin[0]);
  @nam = @tb_sys;
  @val = split(/","/, $lin[1]);

  # Output the information
  while (defined($itm = shift(@itm)) && defined($val = shift(@val)))
  { $nam = shift(@nam) || q{};
    if ($itm =~ m/^(Hotfix|Network|Processor)/i ||
        $nam =~ m/^(hotfixes|network|processors)/)
    { $val = join('%BR%', @{$slf->{'_sys'}->{$nam} = [split(/,/, $val)]});
    }
    else
    { $slf->{'_sys'}->{$nam} = $val;
    }
    $val =~ s/^\s+/&nbsp;&nbsp;&nbsp;&nbsp;/g;
    $buf = "|$itm |$val |\n";
    $rpt->write($buf);
    ++$cnt;
  }

  # Return the number of lines written
  return $cnt;
}

=head2 S<$h-E<gt>write_winmsd($rpt)>

This method writes the result of C<winmsd> to the report file. It returns the
number of the lines written.

=cut

sub write_winmsd
{ my ($slf, $rpt) = @_;
  my ($buf, $cnt, $flg, $hdr, $skp, $tmp);

  return 0 unless RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin;

  # Get the information in a temporary file
  $tmp = $slf->{'_agt'}->get_env('COMPUTERNAME').q{.txt};
  eval {
    local $SIG{'__WARN__'} = sub { };
    system('winmsd /a /f');
    $slf->{'_col'}->incr_usage('OS');
  };
  return 0 if $@;

  # Open the file
  return 0 unless _open_utf16($slf, qq{<$tmp});

  # Reformat the information
  $cnt = $skp = 0;
  $flg = 1;
  $hdr = q{};
  while (defined($_ = _getl_utf16($slf)))
  { s/[\s]+$//;
    if ($hdr)
    { next if $flg && m/^(?:-+)?$/;
      $buf = q{};
      if (m/^$hdr\s/)
      { $buf .= $EOV unless $flg;
        $buf .= qq{---++ $_};
        $flg = 1;
      }
      elsif (m/^$/)  ## no critic (Fixed)
      { next if $skp++;
      }
      else
      { $buf .= $BOV if $flg;
        $buf .= $_;
        $skp = $flg = 0;
      }
      $buf .= qq{\n};
      $rpt->write($buf);
      ++$cnt;
    }
    else
    { $hdr = $1 if m/^(\w+)\s/;
    }
  }
  _close_utf16($slf);
  $rpt->write($EOV) unless $flg;
  1 while unlink($tmp);

  # Return the number of lines written
  return $cnt;
}

# --- UTF-16 to UTF-8 conversion methods --------------------------------------

sub _init_utf16
{ my ($slf, $str, $mod) = @_;

  return 0 unless defined($str);
  $mod = q{} unless defined($mod);
  $slf->{'_utb'} = $mod eq 'd';
  $slf->{'_uth'} = RDA::Handle::Vector->new($str);
  $slf->{'_uti'} = [];
  $slf->{'_utl'} = q{};
  $slf->{'_utf'} = ($mod eq 'i') ? 'n*' : 'v*';
  $slf->{'_uth'}->setinfo('eol', q{});
  return 1;
}

sub _open_utf16
{ my ($slf, $fil) = @_;
  my ($cnt);

  $slf->{'_utb'} = 1;
  $slf->{'_utf'} = 'v*';
  $slf->{'_uth'} = IO::File->new;
  $slf->{'_uti'} = [];
  $slf->{'_utl'} = q{};
  $cnt = 10;
  while (!$slf->{'_uth'}->open($fil))
  { return 0 unless $cnt--;
    sleep(1);
  }
  return 1;
}

sub _close_utf16
{ my ($slf) = @_;

  close($slf->{'_uth'});
  return;
}

sub _getl_utf16
{ my ($slf) = @_;
  my ($chr, @lin);

  while (defined($chr = $slf->_getc_utf16))
  { return pack('C*', @lin) if $chr == 10;
    push(@lin, $chr) unless $chr == 13;
  }
  return (scalar @lin) ? pack('C*', @lin) : undef;
}

sub _getc_utf16
{ my ($slf) = @_;
  my ($buf, $chr, $inp, $lgt, @src);

  # Return a character from the input buffer
  $inp = $slf->{'_uti'};
  return $chr if defined($chr = shift(@{$inp}));

  # Read a block and convert it
  while ($lgt = $slf->{'_uth'}->sysread($buf, 2048))
  { # Get an even number of characters
    $lgt = length($buf = $slf->{'_utl'}.$buf);
    if ($lgt & 1)  ## no critic (Bit)
    { $slf->{'_utl'} = substr($buf, -1);
      next unless --$lgt;
      $buf = substr($buf, 0, $lgt);
    }
    else
    { $slf->{'_utl'} = q{};
    }

    # Determine the byte order at the beginning of the file
    if ($slf->{'_utb'})
    { $slf->{'_utb'} = 0;
      if ($buf =~ m/^\377\376/)
      { $slf->{'_utf'} = 'v*';
        $buf = substr($buf, 2);
        next if $lgt < 2;
      }
      elsif ($buf =~ m/^\376\377/)
      { $slf->{'_utf'} = 'n*';
        $buf = substr($buf, 2);
        next if $lgt < 2;
      }
    }

    # Decode the buffer
    @src = unpack($slf->{'_utf'}, $buf);
    _cnv_utf16($inp, \@src);
    return $chr if defined($chr = shift(@{$inp}));
  }

  # Indicate the end of the file
  return;
}

sub _cnv_utf16
{ my ($inp, $src) = @_;
  my ($chr, $low);

  while (defined($chr = shift(@{$src})))
  { # Detect surrogate
    ## no critic (Bit,Number,Zero)
    if ($chr >= 0xD800 && $chr <= 0xDFFF)
    { $low = shift(@{$src}) || 0;
      if ($chr >= 0xDC00 || $low < 0xDC00 || $low > 0xDFFF)
      { unshift(@{$src}, $low);
        next;
      }
      else
      { $chr = ($chr - 0xD800) * 0x400 + ($low - 0xDC00) + 0x10000;
      }
    }

    # Convert the character
    if ($chr < 0x80)
    { push(@{$inp}, $chr);
    }
    elsif ($chr < 0x800)
    { push(@{$inp}, (($chr >> 6)   | 0300),
                  (($chr & 0077) | 0200));
    }
    elsif ($chr < 0x10000)
    { push(@{$inp}, (( $chr >> 12)         | 0340),
                  ((($chr >>  6) & 0077) | 0200),
                  (( $chr        & 0077) | 0200));
    }
    elsif ($chr < 0x200000)
    { push(@{$inp}, (( $chr >> 18)         | 0360),
                  ((($chr >> 12) & 0077) | 0200),
                  ((($chr >>  6) & 0077) | 0200),
                  (( $chr        & 0077) | 0200));
    }
  }
  return;
}

#--- File query methods ------------------------------------------------------

# Get a registry value
sub _get_fil
{ my ($slf, $key, $nam, $val) = @_;
  my $flg;

  if ($key && $nam)
  { # Normalize the key
    $key =~ s{^HKCU\\}{HKEY_CURRENT_USER\\}i;
    $key =~ s{^HKLM\\}{HKEY_LOCAL_MACHINE\\}i;
    $key =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;
    $nam =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;

    # Get the value
    for (@{$slf->{'_buf'}})
    { if ($flg && m/^\s+$nam\s/i)
      { s/[\s\n\r]+$//;
        my @tbl = split(/\s+/, $_, 4);
        $val = $tbl[3] if defined($tbl[3]);
      }
      elsif (m/^$key$/i)
      { $flg = 1;
      }
      elsif (m/^[A-Z]/)
      { $flg = 0;
      }
    }
  }
  return $val;
}

# Grep all registry keys containing a name
sub _grep_fil
{ my ($slf, $key, $nam, $flg) = @_;
  my ($lst, @tbl);

  if ($key && $nam)
  { # Normalize the key
    $key =~ s{^HKCU\\}{HKEY_CURRENT_USER\\}i;
    $key =~ s{^HKLM\\}{HKEY_LOCAL_MACHINE\\}i;
    $key =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;

    # Search in the buffer
    for (@{$slf->{'_buf'}})
    { if (m/^\s+($nam)\s/i)
      { push(@tbl, $flg ? "$lst|$1" : $lst) if $lst;
      }
      elsif (m/^$key/i)
      { $lst = $_;
      }
      elsif (m/^[A-Z]/)
      { $lst = undef;
      }
    }
  }
  return @tbl;
}

# Test access to both registry parts
sub _test_fil
{ return 0;
}

# Write registry information
sub _write_fil
{ my ($slf, $rpt, $key, $lvl) = @_;
  my ($buf, $cnt, $flg, $hit, $nam, $toc, $typ, $val);

  # Normalize the key
  $key =~ s{^HKCU\\}{HKEY_CURRENT_USER\\}i;
  $key =~ s{^HKLM\\}{HKEY_LOCAL_MACHINE\\}i;
  $key =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;

  # Write the registry key
  $cnt = 0;
  if (@{$slf->{'_buf'}})
  { # Reformat the command output
    for (@{$slf->{'_buf'}})
    { s/[\s\n\r]+$//;
      next if m/^$/ || m/^!/ || m/^Error:/;  ## no critic (Fixed)
      if (m/^[A-Z]/)
      { $buf = q{};
        $buf .= $EOC if $flg;
        $flg = 0;
        next unless $hit = m/^$key/i;
        $toc = tr/\\/\\/;
        $toc = ($toc > $lvl) ? q{+!!} : q{};
        $buf .= qq{\n---++$toc ``[$_]``\n};
        $rpt->write($buf);
        ++$cnt;
      }
      elsif ($hit && m/^\s+(.*)\sREG_([A-Z_]+)\s(.*)$/)
      { ($buf, $nam, $typ, $val) = (q{}, $1, $2, $3);
        $buf .= $BOC unless $flg++;
        $nam = '(Default)' if $nam eq '<NO NAME>';
        if ($typ =~ m/SZ$/)
        { $buf .= qq{$nam = "$val"\n};
        }
        else
        { $typ = lc($typ);
          $buf .= qq{$nam = $typ:$val\n};
        }
        $rpt->write($buf);
        ++$cnt;
      }
    }
    close(IN);
  }
  $rpt->write($EOC) if $flg;

  # Return the number of lines written
  return $cnt;
}

#--- Reg query methods -------------------------------------------------------

# Get a registry value
sub _get_reg
{ my ($slf, $key, $nam, $val, $opt) = @_;

  if (open(REG, qq{reg query "$key" /v }  ## no critic (Handle,Open)
    .RDA::Object::Rda->quote($nam)
    .($slf->{'_opt'} ? $opt : $REG).q{ 2>&1 |}))
  { $nam =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;
    while (<REG>)
    { $val = $1 if m/^\s+$nam\s+\S+\s+(.*?)[\s\n\r]+$/i;
    }
    close(REG);
    $slf->{'_col'}->incr_usage('OS');
  }
  return $val;
}

# Grep all registry keys containing a name
sub _grep_reg
{ my ($slf, $key, $nam, $flg, $opt) = @_;
  my ($lst, @tbl);
  if (open(REG, qq{reg query "$key" /s}  ## no critic (Handle,Open)
    .($slf->{'_opt'} ? $opt : $REG).q{ 2>&1 |}))
  { while (<REG>)
    { s/[\s\n\r]+$//;
      if ($lst && m/^\s+($nam)\s/i)
      { push(@tbl, $flg ? "$lst|$1" : $lst);
      }
      elsif (m/^[A-Z]/)
      { $lst = $_;
      }
    }
    close(REG);
    $slf->{'_col'}->incr_usage('OS');
  }
  return @tbl;
}

# Test access to both registry parts
sub _test_reg
{ my ($slf) = @_;

  return 0 unless open(REG,  ## no critic (Handle,Open)
    q{reg query "HKLM" /reg:64 2>&1 |});
  while (<REG>)
  { next unless m/^Error:/i;
    close(REG);
    return 0;
  }
  close(REG);
  return 1;
}

# Write registry information
sub _write_reg
{ my ($slf, $rpt, $key, $lvl, $opt) = @_;
  my ($buf, $cnt, $cod, $nam, $toc, $typ, $val);

  # Write the registry key
  $cnt = 0;
  if (open(IN, qq{reg query "$key" /s}  ## no critic (Handle,Open)
    .($slf->{'_opt'} ? $opt : $REG).q{ 2>&1 |}))
  { # Reformat the command output
    while (<IN>)
    { s/[\s\n\r]+$//;
      next if m/^$/ || m/^!/ || m/^Error:/i;  ## no critic (Fixed)
      if (m/^[A-Z]/)
      { $toc = tr/\\/\\/;
        $toc = ($toc > $lvl) ? q{+!!} : q{};
        $buf = q{};
        $buf .= $EOC if $cod;
        $buf .= qq{\n---++$toc ``[$_]``\n};
        $rpt->write($buf);
        ++$cnt;
        $cod = 0;
      }
      elsif (m/^\s+(.*\S)\s+REG_([A-Z_]+)\s+(.*)$/)
      { ($buf, $nam, $typ, $val) = (q{}, $1, $2, $3);
        $buf .= $BOC unless $cod++;
        $nam = '(Default)' if $nam eq '<NO NAME>';
        if ($typ =~ m/SZ$/)
        { $val =~ s/\./&#46;/g if $nam =~ m/version$/i;
          $buf .= qq{$nam = "$val"\n};
        }
        else
        { $typ = lc($typ);
          $buf .= qq{$nam = $typ:$val\n};
        }
        $rpt->write($buf);
        ++$cnt;
      }
    }
    close(IN);
    $slf->{'_col'}->incr_usage('OS');
  }
  $rpt->write($EOC) if $cod;

  # Return the number of lines written
  return $cnt;
}

#--- Regedit methods ---------------------------------------------------------

# Get a registry value
sub _get_buf
{ my ($slf, $key, $nam, $val) = @_;
  my ($flg, $reg);

  ($key, $reg) = _key_buf($key);
  $nam =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;
  for (@{$slf->_sel_buf($key)})
  { if ($flg && m/^\s+$nam\s+\S+\s+(.*?)[\s\n\r]+$/i)
    { $val = $1;
      last;
    }
    elsif (m/^[A-Z]/)
    { last if $flg;
      $flg = $_ =~ m/^$reg$/i;
    }
  }
  return $val;
}

# Grep all registry keys containing a name
sub _grep_buf
{ my ($slf, $key, $nam, $flg) = @_;
  my ($lst, $reg, @tbl);

  ($key, $reg) = _key_buf($key);
  for (@{$slf->_sel_buf($key)})
  { if ($lst && m/^\s+($nam)\s/i)
    { push(@tbl, $flg ? qq{$lst|$1} : $lst);
    }
    elsif (m/^[A-Z]/)
    { if (m/^$reg/i)
      { $lst = $_;
      }
      elsif ($lst)
      { last;
      }
    }
  }
  return @tbl;
}

# Reformat the key for searching in buffer
sub _key_buf
{ my ($key) = @_;
  my ($reg);

  $key =~ s/^HKCU/HKEY_CURRENT_USER/i;
  $key =~ s/^HKLM/HKEY_LOCAL_MACHINE/;
  $reg = $key;
  $reg =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$])}{\\$1}g;
  return ($key, $reg);
}

# Load a registry key in memory
sub _load_buf
{ my ($slf, $key) = @_;
  my ($buf, $flg, $lin, $nam, $tmp, $typ);

  # Export the registry key
  $tmp = RDA::Object::Rda->cat_native($slf->{'_col'}->get_work($WRK, 1));
  $slf->{'_buf'}->{uc($key)} = $buf = [];
  system(q{regedit /e "}.$tmp.q{" "}.$key.q{"});
  unless ($?)
  { # Load the registry key
    $flg = 0;
    $lin = q{};
    if (_open_utf16($slf, "<$tmp"))
    { while (defined($_ = _getl_utf16($slf)))
      { s/\s+$//;
        s/^\s+//;
        $lin .= $_;
        next if $lin =~ s/\\$//;
        $lin =~ s/\s+$//;
        next if $lin =~ m/^$/;  ## no critic (Fixed)
        if ($lin =~ m/^\[([^\]]+)/)
        { push(@{$buf}, $1);
          $flg = 1;
        }
        elsif ($flg)
        { $nam = ($lin =~ s/^"([^"]*)"=//) ? $1 :
                 ($lin =~ s/@=//) ? '<NO NAME>' :
                 q{?};
          if ($lin =~ s/^"([^"]*)"/$1/)
          { $typ = 'REG_SZ ';
            $lin =~ s/\\(.)/$1/g;
          }
          elsif ($lin =~ s/^hex\(0\)://i)
          { $typ = 'REG_NONE';
          }
          elsif ($lin =~ s/^hex://i)
          { $typ = 'REG_BINARY ';
            $lin =~ s/,//g;
            $lin = uc($lin);
          }
          elsif ($lin =~ s/^hex\(2\)://i)
          { $typ = 'REG_EXPAND_SZ ';
            $lin =~ s/00,?//g;
            $lin =~ s/([\dA-Fa-f]{2}),?/chr(oct('0x'.$1))/eg;
          }
          elsif ($lin =~ s/^dword://i)
          { $typ = 'REG_DWORD 0x';
            $lin =~ s/^0+(\d)/$1/;
          }
          else
          { $typ = q{?};
          }
          push(@{$buf}, "    $nam $typ$lin");
        }
        $lin = q{};
      }
      _close_utf16($slf);
    }
  }
  $slf->{'_col'}->incr_usage('OS');

  # Delete the temporary file
  $slf->{'_col'}->clean_work($WRK);

  # Return the buffer
  return $buf;
}

# Select the buffer
sub _sel_buf
{ my ($slf, $key) = @_;

  my $ref = uc($key);
  foreach my $cur (sort {length($a) <=> length($b)} keys(%{$slf->{'_buf'}}))
  { return $slf->{'_buf'}->{$cur} if $cur eq substr($ref, 0, length($cur));
  }
  return $slf->_load_buf($key);
}

# Test access to both registry parts
sub _test_buf
{ return 0;
}

# Write registry information
sub _write_buf
{ my ($slf, $rpt, $key, $lvl) = @_;
  my ($buf, $cnt, $cod, $flg, $nam, $ref, $reg, $toc, $typ, $val);

  # Write the registry key
  ($key, $reg) = _key_buf($key);
  $ref = $slf->_sel_buf($key);
  $cnt = 0;
  if (@{$ref})
  { # Reformat the command output
    for (@{$ref})
    { if (m/^[A-Z]/)
      { if (m/^$reg/i)
        { $flg = 1;
        }
        elsif ($flg)
        { last;
        }
        $toc = tr/\\/\\/;
        $toc = ($toc > $lvl) ? '+!!' : q{};
        $buf = q{};
        $buf .= $EOC if $cod;
        $buf .= "\n---++$toc ``[$_]``\n";
        $rpt->write($buf);
        ++$cnt;
        $cod = 0;
      }
      elsif ($flg && m/^\s+(.*\S)\s+REG_([A-Z_]+)\s+(.*)$/)
      { ($buf, $nam, $typ, $val) = (q{}, $1, $2, $3);
        $buf .= $BOC unless $cod++;
        $nam = '(Default)' if $nam eq '<NO NAME>';
        if ($typ =~ m/SZ$/)
        { $val =~ s/\./&#46;/g if $nam =~ m/version$/i;
          $buf .= "$nam = \"$val\"\n";
        }
        else
        { $typ = lc($typ);
          $buf .= "$nam = $typ:$val\n";
        }
        $rpt->write($buf);
        ++$cnt;
      }
    }
  }
  $rpt->write($EOC) if $cod;

  # Return the number of lines written
  return $cnt;
}

# --- SDCL extensions ---------------------------------------------------------

# Define a global variable to access the interface object
sub _begin_windows
{ my ($pkg) = @_;

  $pkg->set_top('WIN', RDA::Object::Windows->new($pkg->get_collector));
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Handle::Memory|RDA::Handle::Memory>,
L<RDA::Handle::Vector|RDA::Handle::Vector>,
L<RDA::Object::Buffer|RDA::Object::Buffer>
L<RDA::Object::Collect|RDA::Object::Collect>
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Report|RDA::Object::Report>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut