use strict;
use diagnostics;

# #perl2exe_include C:\Perl\5.00502\lib\pod\perldiag.pod

# the preceding line is for perl2exe to include
# diagnostic messages in the .exe
use Carp;
use Cwd;

use Win32::Registry;
use Tk;
# need to list the following Tk modules separately
# so that perl2exe can find them when using "Scrolled" 
use Tk::Label;
use Tk::HList;
use Tk::Text;
use Tk::DialogBox;
use Tk::FileSelect;
use Tk::Menubutton;
use Tk::Checkbutton;
use Tk::Frame;

my $VERSION = "1.19";

my $HlpData = init_HlpData();
my ($List, @SrchRes, @Txt, $related_values, $to_find, $sr_num, @TopKeys);
$related_values = 0;

my $cmd_line = scalar @ARGV;
if (@ARGV) { 
    print "Sorry, Command Line use not implemented yet.\n"; exit(1); 
    # someday I'll get around to this.
    if ( $cmd_line > 1) {
        do_search(@ARGV);
        exit(0);
    }
    elsif ( $cmd_line == 1 ) {
        do_search(@ARGV, @TopKeys);
    }
}


my $out_txt;
my %reg_type = (
0 => 'REG_0',                           
1 => 'REG_SZ',
2 => 'REG_EXPAND_SZ',
3 => 'REG_BINARY',
4 => 'REG_DWORD',
5 => 'REG_DWORD_BIG_ENDIAN',
6 => 'REG_LINK',
7 => 'REG_MULTI_SZ',
8 => 'REG_RESOURCE_LIST',
9 => 'REG_FULL_RESOURCE_DESCRIPTION',
10 => 'REG_RESSOURCE_REQUIREMENT_MAP'
);


@TopKeys = ();
for ( sort (keys %main::)) {
   if ( /^HKEY_[A-Z_]*/ ) {
       push(@TopKeys,$_);
    }
}
# find the HKEY_ vars which Registry.pm puts into
# the main:: namespace

$| = 1;

my $mw = MainWindow->new(-title=>"REG v$VERSION");

my $HlpBttn = $mw->Button(-text=>"HELP",
                       -command=> sub { make_help(); }
                   );
$HlpBttn->pack();

sub make_help {
    my $HlpWin = $mw->Toplevel(-title=>'Help for REG',
                               -height=>10, -width=>50);
    $HlpWin->Label(-text=>'Help for Reg')->pack();
    my $HlpTxt= $HlpWin->Scrolled('Text',-scrollbars=>'e', -wrap=>'word');
    $HlpTxt->pack(-fill=>'both', -expand=>1);
    $HlpTxt->insert('end', $HlpData);
}

my $hlist = $mw->Scrolled('HList',-scrollbars=>'e',
                    -indent     => 10,
                -highlightcolor => 'green',
                    -height     => 20,
                    -width      => 70,
                    -itemtype   => 'text',
                    -separator  => '\\',
                    -selectmode => 'single',
                    -indicator  => 1,
                 -indicatorcmd  => sub { my $File = shift;
                                         my $S = shift;
                                         if ( $S eq "<Arm>" ) {
                                              drill($File);
                                         }
                                   },
                    -command    => sub { my $File = shift; make_list($File); },
                  );

TOPKEY:
for (@TopKeys) {
    my $Dir = '';
    my (@SubKeys, %data, );
    my $NewObj = undef;

    # check that the top level key is valid.  To be valid, the operation
    # must return a true (not 0 and not '') value.
    {
    no strict 'refs';
    ${$_}->Open($Dir, $NewObj) or next TOPKEY;
    # this is $HKEY_WHATEVER->Open($Dir, $NewObj);
    }

    $hlist->add($_, -text=>$_);
    $hlist->indicator('create', $_, -text=>'+');
}
$hlist->pack(-fill=>'both', -expand=>1);

my $frame1 = $mw->Frame(-relief=>'raised',
                       -borderwidth=>3)
                       ->pack(-fill=>'x');

my $frame2 = $mw->Frame(-relief=>'raised',
                       -borderwidth=>3)
                       ->pack(-fill=>'x');

my $label4 = $frame1->Label(-width=>0, -text=>"Search from roots:");
$label4->pack(-side=>'left');

$List = $frame1->Listbox(
                 -height=>0,
                 -width=>0,
                 -selectmode=>'extended',
             );
$List->pack(-side=>'left');

my $Bttn = $frame1->Button(-text=>"remove",
                    -command=> sub {
                                   my @Selected = $List->curselection;
                                   for (reverse @Selected) {
                                       $List->delete($_);
                                   }
                               }
                 );
$Bttn->pack(-side=>'left');

my $label2 = $frame2->Label(-width=>0, -text=>"Search Regex:");
$label2->pack(-side=>'left');

my $SrchEnt=  $frame2->Entry(-width=>30);
$SrchEnt->pack(-side=>'left');

my $Bttn2 = $frame2->Button(-text=>"search", 
                     -command=> sub {
                                    my @Roots = $List->get(0, 'end');
                                    my $SrchStr = $SrchEnt->get;
                                    if ( length($SrchStr) == 0 ) {
                                        $SrchStr = '.';
                                    }
                                    # if they ask for nothing, give them everything

                                    %main::ThisSeen = ();
                                    # Clear this hash so that multiple
                                    # searches per run work right.
                                    do_search($SrchStr, @Roots);
                                }
                  );
$Bttn2->pack(-side=>'left');
my $CkBttn = $frame2->Checkbutton(-text => 'Show Related Values',
                   -variable => \$main::related_values,
                   -onvalue  => 1,
                   -offvalue => 0);
$CkBttn->pack(-side=>'bottom');
$CkBttn->select;

MainLoop();

sub drill {
    # show subkeys in the main window.
    my $Dir = $_[0];
    my ($NewObj, @SubKeys, $OldDir, $RootDir, $DoReg, $PrevDir);
    if ( $hlist->info("children",$Dir) ) {
        $hlist->delete("offspring", $Dir);
        # if already 'drilled', undrill and reset indicator
        $hlist->indicator('create', $Dir, -text=>'+');
        return;
    }
    $hlist->indicator('create', $Dir, -text=>'-');
    $Dir =~ s/(^\\?HKEY[_A-Z]*)\\?//;
    #remove HKEY_whatever\
    $RootDir = $1;
    #save HKEY_whatever
    {
    no strict 'refs';
    ${$RootDir}->Open($Dir, $NewObj) or return;
    }      
    $NewObj->GetKeys(\@SubKeys); 
    $OldDir = ( $Dir  ? "$RootDir\\$Dir" : "$RootDir" );
    # add root and cur dir - avoid trailing '\' if
    # $Dir is null

    @SubKeys = map  { $_->[1] }
               sort { $a->[0] cmp $b->[0] }
               map  { [uc($_), $_] } @SubKeys;
    # sort sub-keys regardless of case, like regedt32,
    # but preserve case in display (like regedt32)
 
    for (@SubKeys) {
        $hlist->add("$OldDir\\$_", -text=>"$_");
        $hlist->indicator('create', "$OldDir\\$_", -text=>'+');
    }
}

sub make_list {
    # add to the list of "Search from roots"
    my $File = shift;
    $List->insert('end',$File);
}

sub do_search {
    $mw->Busy;
    # set up the search results window, then cycle through
    # the search routine starting at each entry in the "search from roots" list.
    $to_find = shift;
    $sr_num++;
    my @to_search = @_;
    $SrchRes[$sr_num] = $mw->Toplevel(-title=>"$sr_num: Search Results for '$to_find'",
                                -height=>10, -width=>50);

    my $menubar = $SrchRes[$sr_num]->Frame(-relief  => "raised",
                                    -borderwidth => 2
                                  )->pack (-anchor => "nw", -fill => "x");

    my $i = $sr_num; # create a closure so that each window has its index
                     # for file_save and destroy_window_SrchRes functions

    my $file_menu = $menubar->Menubutton(-text  => "File",
                                     -underline => 1,
                                     -menuitems => [
                    [ Button => "Save",-command => sub { file_save($i) }  ] ,
                                     -underline => 1,
      [ Button => "Close This Window", -command => sub { destroy_window_SrchRes($i) } ] ,
                                     -underline => 1,
      [ Button => "EXIT REG ENTIRELY", -command => \&file_exit ] 
                                                   ] 
                              )->pack(-side => "left");

    my $srch_info = "searching for '$to_find' in\n" 
                     . join("\n", @to_search) 
                     . "\non " .  (scalar localtime(time)) 
                     . ( $main::related_values
                         ? " with related values"
                         : ' WithOUT related values')
                     . "\n";

    $out_txt = '';
    actual_search('computername',
                   'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName',
                   $Txt[$sr_num]);
    $out_txt = (split("\n", $out_txt))[-1];
    $out_txt =~ s/ComputerName REG_SZ (.*)$/$1/;
    $srch_info .= "on machine \\\\" . $out_txt;
    
    my $label3 = $SrchRes[$sr_num]->Label(-text=>$srch_info);
    $label3->pack;
    
    $Txt[$sr_num] = $SrchRes[$sr_num]->Scrolled('Text',-width=>120, -height=>30, 
                              -scrollbars=>'ose', -wrap=>'word');
    $Txt[$sr_num]->pack(-fill=>'both', -expand=>1);

    $out_txt = '';
    $srch_info =~ s/\n/   /g;
    $srch_info .= "\n\n";
    out_add($srch_info);

    for (@to_search) {
        actual_search($to_find, $_, $Txt[$sr_num]);
    }
    out_put($sr_num);
    $mw->Unbusy;
}

sub actual_search {
    my ($to_find, $Dir, $Txt ) = @_;
    my $OldDir = $Dir;
    my ( $thing, $RootDir, $DoReg, $NewObj, @SubKeys, %data, $NewDir, 
         $Val, $ThisKey, $Tmp, $ShouldUse, $allval);
    undef $NewObj;
    $Dir =~ s/(^\\?HKEY[_A-Z]*)\\?//;
    # remove HKEY_WHATEVER\
    $RootDir = $1;
    # save HKEY_WHATEVER
    {
        no strict 'refs';
        if ( ${$RootDir}->Open($Dir, $NewObj) 
             and ref $NewObj eq 'Win32::Registry' ) {
            $NewObj->GetKeys(\@SubKeys); 
            $NewObj->GetValues(\%data);
        }
        else { return; }
        # only retrieve keys if return code from
        # from ->Open of key is true.  Proceed w/ rest of subroutine
        # so that we find out if the key matches.
    }
    
    @SubKeys = sort @SubKeys;
    
    $Val = "";     # all values which match the search regex.
    $allval = "";  # all values (used for 'related values'.
    # each value is actually a list of [name, type, value]
    foreach $thing ( sort keys %data){
        $Tmp = "";
        $ShouldUse = 0;
        my $val_type;
        for (0..2) {
            my $Xx = ${$data{$thing}}[$_];
 
            if ( /0/ ) { 
                if ( not $Xx )  { $Tmp .= "(Default) ";}
                else            { $Tmp .= "$Xx "; }
            }
            # if the name (1st element) is null, use "(Default)" ala regedt

            elsif ( /1/ ) {
                $val_type = $Xx;
                $Tmp .=  ( exists $reg_type{$val_type}
                           ? "$reg_type{$val_type} "
                           : "REG_UNKNOWN:($val_type) ");
            }

            elsif ( /2/ ) {
                if ( $Xx =~ /^ +$/ ) {
                    $Tmp .= '"' . $Xx . '" ' ;
                    # if the element is all space, wrap quotes around it
                }

                else {
                    if ( $val_type == 1 or $val_type == 2 ) { 
                        $Xx =~ s/\0/ /g;
                        $Tmp .=  "$Xx";
                    }    # REG_SZ or REG_EXPAND_SZ

                    elsif ( $val_type == 3 ) { 
                        $Tmp .= 
                        join " ",
                        map { sprintf("%02x" , $_) }
                        unpack("C*", $Xx);
                    }    # REG_BINARY; 

                    elsif ( $val_type == 4 ) {
                        $Tmp .= sprintf("0x%08x (%d)", $Xx, $Xx);
                    }    # REG_DWORD

                    elsif ( $val_type == 5 ) {
                        $Tmp .= sprintf("0x%08x (%d)", $Xx, $Xx);
                    }    # REG_DWORD_BIG_ENDIAN

                    elsif ( $val_type == 7 ) {
                        $Xx =~ s/\0$//;
                        $Xx =~ s/\0/"\n   "/eg; 
                        $Tmp .= $Xx;
                    }   # REG_MULTI_SZ - after 1st, list indented

                    elsif ( $val_type == 0 ) {
                    # REG_NONE - no action.
                    }

                    else {
                        $Tmp .= 
                        join " ",
                        map { sprintf("%02x" , $_) }
                        unpack("C*", $Xx);
                    }
                }
            }
        }

        if  ( $Tmp =~ /$to_find/i )  {
            $Val .= "$Tmp\n";
        }

        # save for if 'show related values' on
        if ( $main::related_values ) { 
            $allval .= "$Tmp\n";
        }
    }


    if ( $Val ) {
        if ($main::related_values) {
            out_add("$OldDir:\n$allval\n");
        }
        else {
            out_add("$OldDir:\n$Val\n");
        }
        $main::ThisSeen{$OldDir}++;
    }
    # if any of the values contained the regex, print the key
    # and the values that matched.  If 'show related values' checked,
    # print all the siblings too. 
    # also, remember the key, so that if it also matches,
    # we won't print it again later.

    foreach (@SubKeys) {
        $NewDir = $OldDir . "\\$_";
        # construct the key for the next recursion, 

        actual_search($to_find, $NewDir, $Txt);
        # follow it down another level
    }

    if (  $OldDir =~ /$to_find/i 
          and (not defined $main::ThisSeen{$OldDir}) ) {
        if ( $main::related_values ) {
            out_add("$OldDir:\n$allval\n");
        }

        else {
            out_add("$OldDir:\n\n");
        }
    # if the key matches the regex, and if we haven't already
    # seen it while printing values, print it.  If we're
    # printing 'related values' do so.
    }
    $NewObj->Close if defined $NewObj;
}

sub file_save {
    my $sr_num = shift;
    my $save_file = "";
    my $open_mode= ">";
    $save_file = $SrchRes[$sr_num]->getSaveFile;
    
    if ( $open_mode and $save_file) {
        my $what = $Txt[$sr_num]->get('1.0', 'end');
        open(OUTPUT, $open_mode . " " . $save_file) or die "can't open $save_file: $!\n";
        print OUTPUT "$what\n";
        close OUTPUT or die "can't close $save_file: $!\n";
    }
}

sub file_exit {
    exit();
}

sub destroy_window_SrchRes {
    my $sr_num = $_[0];
   $SrchRes[$sr_num]->destroy;
}


sub out_add {
    $out_txt .= $_[0];
}

sub out_put {
    my $sr_num = $_[0];
    my @lines = split("\n", $out_txt);
    my $line = 1;
    my $found = "found";
    my @hits = ();
    my $size;
    $Txt[$sr_num]->tagConfigure($found, -foreground => 'red');

    for (@lines) {
        $Txt[$sr_num]->insert('end', "$_\n");
        while ( m/($to_find)/ig ) {
            $size = length($1);;
            push @hits, [join(".", $line, pos($_) - $size), $size];
        }
        $line++;
    }

    for (@hits) {
        $Txt[$sr_num]->tagAdd($found, $_->[0], "$_->[0] + $_->[1] chars");
    }            
}                                                                       

sub init_HlpData {
my $HelpString = "CLICK INSIDE THIS WINDOW, THEN USE ARROW KEYS AND/OR PgUp/PgDn to navigate, 
or use the scrollbar. 

This is the help file for the 'reg' program.  

The reg program does a recursive search of the registry, starting at one or more 
points, looking for all keys or values (note that regedt32 only does keys) that match 
a string entered by the user.

The match is according to Perl's rules for 'regular expressions', 
so searches can be done for things that can't be expressed only as a literal string. 
For example, entering 'excel [45]' would match all keys and values containing 
'excel 4' or 'excel 5' but not 'excel 3' or excel 7'.  For more information 
on regular expressions, check your nearest Unix machine and/or geek. 


MAIN WINDOW:

The initial menu of Reg shows the toplevel Registry keys.  Each key or subkey 
in the window has a '+' or '-' sign, called an 'indicator', in front of it.  Single 
clicking the indicator of a key or subkey will open the next level of subkeys 
down ('drill down').  If the subkeys were already visible, 
they become hidden again. 


'SEARCH FROM ROOTS:' list:

When in the Main Window, double-clicking a key or subkey (or pressing enter while one is 
highlighted) copies it into the 'Search from roots: ' listbox below the main window. 
This is the list of startpoint(s) for recursive searches of the registry.  Multiple entries 
in this list causes the recursive search to be started from each in turn. 


'REMOVE' Button:

If you got something into the 'Search from roots:' list accidentally, highlight it 
then click the 'remove' button. 


'SEARCH REGEX' entry:

Once you've selected the search roots, you need only enter a string to search 
for and click the 'Search' button.  

The string for which to search is entered into the entry box labeled 'Search regex?'.  
This is called 
a regex because the string entered here will be used as a 'regular expresion' 
when matched against subkeys and values.  This means that a bewildering array 
of wildcards and other magical matching can be done.  If your only familiarity 
is with DOS wildcards, let me say that the regex equivalent of DOS's * is .* and 
the regex equivalent of DOS's ? is . which is a dot.  If you want to match a dot 
or an asterisk literally, precede the character with a backslash as in \\*.  This applies 
to most other punctuation characters as well. 

If you enter nothing into the 'Search Regex' entry field, the program will 
act as if you entered a period, which matches everything.


'SHOW RELATED VALUES' checkbox:

The search/match behavior is modified by the 'Show Related Values' check-box.  

If the 'show related values is not checked, the following happens:

When a value matches, the subkey containing that value will also be printed out, 
whether it matched or not.  If a subkey matches, it will be printed even if none of 
it's values matched. 

If the 'show related values is checked:

When a key matches, 
it *and* all it's values will be printed.  Additionally, when a value 
matches, all of its 'sibling' values (those under the same key) will 
be printed.


'SEARCH' button:

Pressing this starts the search.  The search is performed recursivley 
starting at each of the points in the 'Search From Roots' list.  
When the search is done the results will be shown in the 'Search Results Window'. 
Note that multiple searches can be performed - when the search button is 
clicked, it will start a new search based on the contents of the 
'search from roots' list and the 'search regex' entry, and put the results 
into a new numbered 'Search Results' window.


'SEARCH RESULTS' window:

The results of the search are shown here.  Text matched by the search regex will 
be highlighted in red.

The FILE menu of this window offers 3 options: 

SAVE, which allows the selection of
a file in whcih to save the contents of the window.  If the file selected  
already exists, the user will be prompted as to whether to overwrite the 
file or not.  The contents of 
the 'search results' window may be editted before saving.

CLOSE THIS WINDOW, which closes the 'Search Results' window from 
which it is invoked.

QUIT REG ENTIRELY which exits the reg program, closing all windows immeidately.


Notes:

All searching is done CASE INSENSITIVELY. (Making this an option may 
be a feature in the future.)

Be aware that searches from near the root of the tree can take several 
minutes. 

The strings matched by the regular expression will be highlighted in the 
search results window.  The results of this are sometimes surprising - 
it is quite possible to make a regex which will not match itself, while 
still matching other things.

You can copy and paste out of the search results window by highlighting 
text with the mouse (or by holding down the shift key while moving the cursor) then  
typing ctrl-C to copy the text to the clipboard, 
then going to other applications and pasting.

Other items to note: the program may complain about 'use of uninitialized variable 
in ...Registry.pm' when first run - this appears to be harmless.  It is due to
a bug in Registry.pm for which there is a patch. (The .exe version of this program 
should not exhibit this behaviour.)  It appears to be harmless.

If you decide that this software has a bug (translation: 'is cheesy garbage'), 
please email me at bobn\@interaccess.com with a complete rant, uh, bug report.  
Ditto on suggestions for added features.

I may or may not actually do anything about it, but you'll feel better.

- Bob Niederman, 12 Nov 1998

BUGS: (or, as some companies would have it, 'features'):

The highlighting of the matched strings in the Search Results window will 
sometimes start being on the wrong text part way through the window. 
This appears to be caused by non-printable characters existing in strings. 
Attempts have been made to fix this, remdying this on the machines I've 
tried this on, but that's not a very big sample.
";

$HelpString =~ s/([^\n])\n([^\n])/$1$2/gm; 
# remove newlines which ain't new paragraphs - let Tk::Text handle the wrap.

return $HelpString;
}

=head1 NAME

reg.pl - a script to aid in searching the Win32 Registry.

=head1 DESCRIPTION (See README)

=head1 README

The reg program does a recursive search of the registry, starting at one or more 
user-selected points, looking for all keys or values that match 
a string entered by the user.

The user interface is a GUI, through use of Tk.

The match is according to Perl's rules for 'regular expressions', 
allowing great versatility in how searches are done.

This application was created under the ActiveSate perl 5.00502.

For more information, run the script and click on 'HELP'.


=head1 Runs on the following OSs:

WinNT 4.0, Win95

=head1 Author

Bob Niederman, bobn@interaccess.com

=head1 Acknowledgements

Lots of folks whose names I don't know.

=head1 Copyright

This is free software.  Use it as you please, but please acknowledge 
credit where due.

=cut

=head1 CPAN Scripts Miscellanea:

=head1 SCRIPT CATEGORIES

C<Win32/Utilities>

=head1 PREREQUISITES

This script requires the following modules: 

 strict
 diagnostics
 Carp
 Cwd

 Win32::Registry

 Tk
 Tk::Label
 Tk::HList
 Tk::Text
 Tk::DialogBox
 Tk::Menubutton
 Tk::Checkbutton
 Tk::Frame

=head1 OSNAMES

C<WinNT>
C<Win95>

=head1 Changes

 01.15 Added less common reg types found in doc at 
       www.inforoute.capway.com
 01.16 Used Busy and Unbusy methods to get an hourglass 
       cursor while searching (with thanx to comp.lang.perl.tk!)
 01.17 Replaced use of FileSelect.pm w/ ->getSaveFile (native)
 01.18 Added checks to not use undef reg object - (folders
       that are 'grayed out' in regedt32).
 01.19 Added code to find computername and add it to listing.

=cut
__END__