#!/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).
# 23/10/2010 - Review, and add input of an extension
# geoff mclane - http:\\geoffmclane.com - updated 20070402, commenced 20070120
# NOTES:
# This is in Windows XP Pro - it enumerates HKEY_CLASSES_ROOT
# The four top-level objects are: $HKEY_CLASSES_ROOT  $HKEY_CURRENT_USER  $HKEY_LOCAL_MACHINE $HKEY_USERS
# It does NOT resolve the indirect 'openwith' entries
# 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...
use strict;
use warnings;
use Win32::Registry;
use Data::Dumper;
my $perl_dir = 'C:\GTools\perl';
unshift(@INC, $perl_dir);
require 'logfile.pl' or die "ERROR: Unable to load logfile.pl ...\n";

# log file stuff
my ($LF);
my $pgmname = $0;
if ($pgmname =~ /(\\|\/)/) {
    my @tmpsp = split(/(\\|\/)/,$pgmname);
    $pgmname = $tmpsp[-1];
}
my $outfile = $perl_dir."\\temp.$pgmname.txt";
open_log($outfile);

# features
my $load_log = 0;
my $in_file = '';
my $show_all = 0;

# debug
my $debug_on = 0;
my $def_file = '.dsp';
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 $vcnt = 0;
my %assoc = (); # association for each extension
my %apps = ();
my $maxext = 0;
my $maxass = 0;
my $maxnum = 0;
my ($key,$val);
my $ext_cnt = 0;

my @warnings = ();
my $os = $^O;

sub show_warnings($) {
    my ($val) = @_;
    if (@warnings) {
        prt( "\nGot ".scalar @warnings." WARNINGS...\n" );
        foreach my $itm (@warnings) {
           prt("$itm\n");
        }
        prt("\n");
    } else {
        #prt( "\nNo warnings issued.\n\n" );
    }
}

sub pgm_exit($$) {
    my ($val,$msg) = @_;
    if (length($msg)) {
        $msg .= "\n" if (!($msg =~ /\n$/));
        prt($msg);
    }
    show_warnings($val);
    close_log($outfile,$load_log);
    exit($val);
}


sub prtw($) {
   my ($tx) = shift;
   $tx =~ s/\n$//;
   prt("$tx\n");
   push(@warnings,$tx);
}

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;
}

# 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 show_keys($$$);
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 = 0;
                    if (defined $Data) {
    					$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" );
	}
}

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" );
}

# ===============================================
# ### MAIN ###

parse_args(@ARGV);

# start at the root - enumerate key list
prt("Enumerating key list of [HKEY_CLASSES_ROOT]...\n");
show_keys($keyroot, $keypath, 0);
$acnt = scalar keys %assoc; # association for each extension
$ext_cnt = $acnt;
prt( "Done - Have $ext_cnt 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;
}

$acnt = 0;
if (length($in_file)) {
    my $fnd = 0;
    foreach $key (keys %assoc) {
        $acnt++;
        $val = trimall($assoc{$key});
        if ((length($val) == 0) || ($val eq 'unknown')) {
            $val = 'Unknown';
        }
        if ($key eq $in_file) {
    		prt31( $acnt, $key, $val );
            $fnd++;
        }
    }
    prt("Extension [$in_file] NOT found in $acnt keys...\n") if ($fnd == 0);
}

if ($show_all) {
    $acnt = 0;
    prt( "First - unknown or <blank> values ...\n" );
    foreach $key (sort keys %assoc) {
        $val = trimall($assoc{$key});
        if ((length($val) == 0) || ($val eq 'unknown')) {
            $acnt++;
            prt31( $acnt, $key, $val );
        }
    }
    prt( "\nThen apparently VALID associations ...\n" );
    $vcnt = 0;
    foreach $key (sort keys %assoc) {
        $val = trimall($assoc{$key});
        if ((length($val) == 0) || ($val eq 'unknown')) {
            ### done
        } else {
            $acnt++;
            if ( defined( $apps{$val} ) ) {
                $apps{$val} .= ', '.$key;
            } else {
                $apps{$val} = $key;
            }
            prt31( $acnt, $key, $val );
            $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 $key (sort keys %apps) {
        $val = $apps{$key};
        $acnt++;
        prt32( $acnt, $key, $val );
    }
    prt( "Done list $acnt applications... for $ext_cnt extensions found...\n" );
}

pgm_exit(0,"");
# ===================================================

########################################
sub give_help {
    prt("$pgmname: version 0.0.3 2010-10-23\n");
    prt("Usage: $pgmname [options] [extension]\n");
    prt("Options:\n");
    prt(" --help (-h or -?) = This help, and exit 0.\n");
    prt(" --load-log   (-l) = Load log file at end.\n");
    prt(" --show-all   (-s) = Show the full list of extensions, and associations.\n");
    prt("Purpose:\n");
    prt(" To enumerate the HKEY_CLASSES_ROOT registry key, and find\n");
    prt(" the given extension, like say '.dsp'. If no 'extension' given, then will\n");
    prt(" default to showing ALL.\n");
}

sub need_arg {
    my ($arg,@av) = @_;
    pgm_exit(1,"ERROR: [$arg] must have following argument!\n") if (!@av);
}

sub parse_args {
    my (@av) = @_;
    my ($arg,$sarg);
    while (@av) {
        $arg = $av[0];
        if ($arg =~ /^-/) {
            $sarg = substr($arg,1);
            $sarg = substr($sarg,1) while ($sarg =~ /^-/);
            if (($sarg =~ /^h/i)||($sarg eq '?')) {
                give_help();
                pgm_exit(0,"Help exit(0)");
            } elsif ($sarg =~ /^l/i) {
                $load_log = 1;
            } elsif ($sarg =~ /^s/i) {
                $show_all = 1;
            } else {
                pgm_exit(1,"ERROR: Invalid argument [$arg]! Try -?\n");
            }
        } else {
            $in_file = $arg;
            prt("Set input extension [$in_file]\n");
        }
        shift @av;
    }

    if ((length($in_file) ==  0) && $debug_on) {
        $in_file = $def_file;
    }
    if (length($in_file) ==  0) {
        prtw("WARNING: No input extension found in command! Will show ALL...\n");
        $show_all = 1;
        $load_log = 1;
    }
}


# eof - regclass.pl