#!/Perl
# NAME: regclass.pl
# AIM: To explore the File Type associations in the registry,
# printing out all extensions found, and then enumerating the
# association to each extension (suffix if you will).
# geoff mclane - http:\\geoffmclane.com - updated 20070402, commenced 20070120
# NOTES:
# This is in Windows XP Pro - it enumerates HKEY_CLASSES_ROOT
# It does NOT resolve the indirect 'openwith' entries
# There are 'warnings' about using an uninitialised values, if use warnings uncommented ;=))
# Turning on $dbg1 will show LOTS of enumeration ouput.
# It was mainly written as an 'exercise' in enumerating the registry, recursively ...
# It uses my logfile.pl, but this could be removed, 
# by adding a sub prt{my ($m) = shift; print $m;} service ...
use strict;
##use warnings;
use Win32::Registry;
use Data::Dumper;

require 'logfile.pl' or die "ERROR: Unable to load logfile.pl ...\n";
# log file stuff
my ($LF);
my $outfile = 'temp.'.$0.'.txt';
open_log($outfile);
prt( "$0 ... Hello, World ...\n" );
# debug
my $dbg1 = 0;	# do output during enumeration

my %TYPES = (
  &REG_SZ         =>  "REG_SZ",
  &REG_EXPAND_SZ  =>  "REG_EXPAND_SZ",
  &REG_MULTI_SZ   =>  "REG_MULTI_SZ",
  &REG_DWORD      =>  "REG_DWORD",
  &REG_BINARY     =>  "REG_BINARY"
);

my $keypath = '';
my $keyroot = $HKEY_CLASSES_ROOT;
my $acnt = 0;
my %assoc = (); # association for each extension
my %apps = ();
my $maxext = 0;
my $maxass = 0;
my $maxnum = 0;

sub show_keys {
	my ($k,$p,$lev) = @_;
	my $Key;
	my %Values;
    my @KeyList;
	my $msg = '';
	my $sdp = get_short_dump($p);
	if (length($sdp) == 0) {
		$sdp = '<none>';
	}
	if ($lev == 1) {
		prt("\n") if ($dbg1);
	}
	if( $k->Open( $p, $Key ) ) {
		$Key->GetKeys( \@KeyList );
		my $pc = scalar @KeyList;
		my $cnt = 0;
		if( $Key->GetValues( \%Values ) ) {
			my $vcnt = scalar keys(%Values);
			if ($vcnt > 0) {
				prt( "Found $vcnt values on path [$sdp] ... ($lev)\n" ) if ($dbg1);
				$vcnt = 0;	# reset count
				foreach my $ValueName ( sort( keys( %Values ) ) ) {
					$vcnt++;
					my $Name = $Values{$ValueName}->[0];
					my $Type = $Values{$ValueName}->[1];
					my $Data = $Values{$ValueName}->[2];
					my $tname = $TYPES{$Type};
					my $nm = $Name;
					my $len = length($Data);
					if (length($nm) == 0) {
						$nm = '<none>';
					}
					prt( "$vcnt [$sdp] [$nm] ($tname) Data = [$Data] ($lev)\n" ) if ($dbg1);
					if (($lev == 1) && ($vcnt == 1)) {
						if ( defined($assoc{$sdp}) ) {
							$assoc{$sdp} = $Data;
						} else {
							prt( "NOTE: Creating NEW extension, association!!!\n" ) if ($dbg1);
							$assoc{$sdp} = $Data;
						}
						$maxass = $len if ($len > $maxass);
					}
				}
			} else {
				prt( "Found NO values on path [$sdp] ... ($lev)\n" ) if ($dbg1);
			}
		}
		prt( "Found $pc keys on path [$sdp] ... ($lev)\n" ) if ($dbg1);
		$msg = '';
		foreach my $k2 (@KeyList) {
			if ($lev == 0) {
				if ($k2 =~ /^\./) {	# ONLY want the EXTENSION list - ie .something
					$cnt++;
					$msg .= " $k2";
					if ( defined($assoc{$k2}) ) {
						if ( length($msg) ) {
							prt( "$cnt $msg ($lev)\n" );
							$msg = '';
						}
						prt( "\nWARNING: Extension [$k2] already exists ... ($lev)\n" );
					}
					$assoc{$k2} = 'unknown';	# start out UNKNOWN!
					$maxext = length($k2) if (length($k2) > $maxext);
				}
			} else {
				$cnt++;
				$msg .= " $k2";
			}
			if (length($msg) > 76) {
				prt( "$cnt $msg ($lev)\n" ) if ($dbg1);
				$msg = '';
			}
		}
		prt( "$cnt $msg ($lev)\n" ) if (length($msg) && $dbg1);
		prt( "Found $cnt extensions. Now explore associations ...\n" ) if ($lev == 0);
		$Key->Close();
	    $p .= "\\" unless ( "" eq $p );
	    foreach my $SubKey ( sort ( @KeyList ) ) {
			if ($lev == 0) {
				if ($SubKey =~ /^\./) {
					show_keys( $k, $p . $SubKey, ($lev + 1) );
				}
			} else {
				show_keys( $k, $p . $SubKey, ($lev + 1) );
			}
		}
	} else {
		prt( "Failed to open path [$sdp] ... ($lev)\n" );
	}
}

# start at the root
show_keys($keyroot, $keypath, 0);
$acnt = scalar keys %assoc; # association for each extension
prt( "\nDone - Have $acnt extensions to list ...\n" );
if ($acnt > 99999) {
	$maxnum = 6;
} elsif ($acnt > 9999) {
	$maxnum = 5;
} elsif ($acnt > 999) {
	$maxnum = 4;
} elsif ($acnt > 99) {
	$maxnum = 3;
} elsif ($acnt > 9) {
	$maxnum = 2;
} else {
	$maxnum = 1;
}

sub prt31 {
	my ($n, $k, $v) = @_;
	my $m = "$n";
	while (length($m) < $maxnum) {
		$m = ' '.$m;
	}
	while (length($k) < $maxext) {
		$k .= ' ';
	}
	prt( "$m $k = $v\n" );
}
sub prt32 {
	my ($n, $k, $v) = @_;
	my $m = "$n";
	while (length($m) < $maxnum) {
		$m = ' '.$m;
	}
	while (length($k) < $maxass) {
		$k .= ' ';
	}
	prt( "$m $k = $v\n" );
}

$acnt = 0;
prt( "First - unknown or <blank> values ...\n" );
foreach my $key (keys %assoc) {
	my $val = trimall($assoc{$key});
	if ((length($val) == 0) || ($val eq 'unknown')) {
		$acnt++;
		prt31( $acnt, $key, $val );
	} else {
		###prt( "$acnt $key = $val\n" );
	}
}
prt( "\nThen apparently VALID associations ...\n" );
my $vcnt = 0;
foreach my $key (keys %assoc) {
	my $val = trimall($assoc{$key});
	if ((length($val) == 0) || ($val eq 'unknown')) {
		###prt( "$acnt $key = $val\n" );
	} else {
		$acnt++;
		if ( defined( $apps{$val} ) ) {
			$apps{$val} .= ', '.$key;
		} else {
			$apps{$val} = $key;
		}
		prt31( $acnt, $key, $val );
		###prt( "$acnt $key = $val\n" );
		$vcnt++;
	}
}
prt( "Done list $acnt extensions ... $vcnt with associated applications ...\n" );
$acnt = scalar keys %apps;
prt( "\nThese $vcnt extensions are associated to $acnt applications ...\n" );
$acnt = 0;
foreach my $key (keys %apps) {
	my $val = $apps{$key};
	$acnt++;
	#prt( "$acnt $key = $val\n" );
	prt32( $acnt, $key, $val );
}
prt( "Done list $acnt applications ...\n" );
close_log($outfile,1);
exit(0);

# take something like -
# $VAR1 = bless( {
#                 'handle' => '-2147483648'
#               }, 'Win32::Registry' );
# and RETURN one line, like
# bless( { 'handle' => '-2147483648' }, 'Win32::Registry' );
sub get_short_dump {
	my ($v) = shift;
	my $d = Dumper($v);
	my @lns = split(/\n/, $d);
	my $cnt = scalar @lns;
	my $res = '';
	my @a = ();
	my $i = 0;
	if ($cnt > 1) {
		for ($i = 0; $i < $cnt; $i++) {
			$res .= ' ' if (length($res));
			if ($i == 0) {
				@a = split(/=/, trimall( $lns[$i] ));
				$res = trimall( $a[-1] );
			} else {
				$res .= trimall( $lns[$i] );
			}
		}
	} else {
		@a = split(/=/, trimall( $lns[$i] ));
		$res = trimall( $a[-1] );
		$res =~ s/'//g;
		$res =~ s/;$//;
	}
	return $res;
}

sub trimall {
	my ($ln) = shift;
	chomp $ln;			# remove CR (\n)
	$ln =~ s/\r$//;		# remove LF (\r)
	$ln =~ s/\t/ /g;	# TAB(s) to a SPACE
	while ($ln =~ /\s\s/) {
		$ln =~ s/\s\s/ /g;	# all double space to SINGLE
	}
	while ($ln =~ /^\s/) {
		$ln = substr($ln,1); # remove all LEADING space
	}
	while ($ln =~ /\s$/) {
		$ln = substr($ln,0, length($ln) - 1); # remove all TRAILING space
	}
	return $ln;
}

# eof - regclass.pl