Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

Tk Find In Files

by msemtd (Scribe)
on May 30, 2003 at 17:54 UTC ( [id://261906]=sourcecode: print w/replies, xml ) Need Help??
Category: Win32 Stuff
Author/Contact Info michael.erskine@tecspy.com
Description: A graphical "find in files" or find -exec grep thingy for feature-poor Win32 systems. This was written as an exercise in the use of the grid layout manager and some neat Tk tricks such as most-recently-used lists stored in the registry. There are 3 files as it has been modularised - tkfif.pl fif.pm & MRUList.pm. Hmmm, I'm not sure how to post 3 files here! Anyhow, here it is...
#! perl -w
#
# tkfif - A Tk front-ended find-in-files for win32.
#
# This app has been designed and written as an exercise for the author
+.
#
# Features: -
# * grid layout with stretchy entry widgets
# * good looking Menu widget fonts on Win32
# * The most recently used values from the entry widgets are stored 
#    in the registry and can be recalled -- a more attractive combobox
#    has been costructed with a Menubutton.
#
use strict;
use warnings;
#use diagnostics;
# Some hot handles...
select((select(STDOUT), $| = 1)[0]);
select((select(STDERR), $| = 1)[0]);
use Getopt::Long;
use Cwd;
use Tk;
use Tk::Menubutton;
use Tk::Checkbutton;
## use Tk::Text::SuperText;
use Tk::TextUndo;
use Tk::Radiobutton;
use Win32::FileOp;
use MRUList;
use fif;
use Data::Dumper;

my $title = "Tk Find in Files - MSEmtd";
my $version = "v2.1 - 20/06/01";

my ($patsMRU, $dirsMRU, $fpatsMRU);
my (@pats, @dirs, @fpats);
CreateMRULists();
my ($pat, $dir, $fpat, $ins, $exit, $count, $tree);
my $msgwin; # <-- current output window
ReadArgs();
$pat = $pat || $pats[0] || "something";
$dir = $dir || $dirs[0] || cwd();
$fpat = $fpat || $fpats[0] || ".+";
$tree = $tree || 0;
$ins = $ins || 0;
# todo check valid dirs and patterns
################################################
## Build the GUI
my $mw = new MainWindow(-title => $title);
$mw->protocol('WM_DELETE_WINDOW' => \&ExitApp);
my %images;
MakeImages();
my $findxpm = $mw->Pixmap( -data =>  $images{'find'} );
$mw->Icon(-image => $findxpm);
my $btnbm = $mw->Pixmap( -data =>  $images{'arrow'} );
my $folderxpm = $mw->Pixmap( -data =>  $images{'folder'} );

my $frtop = $mw->Frame(
#-background => 'yellow', 
)->pack(-side => 'top', -expand => 1, -fill => 'x');

## The grid of controls...
my $g = $frtop->Frame(-relief => 'groove', -borderwidth => 2)->pack(-s
+ide => 'left', -expand => 1, -fill => 'both');
## Frame of action buttons...
my $frbtns = $frtop->Frame()->pack(-side => 'left', -padx => 5, -pady 
+=> 5);
$frbtns->Button( -text => "Search", -command => \&Search )->pack(-padx
+ => 5, -pady => 5);
$frbtns->Button( -text => "Exit", -command => \&ExitApp)->pack(-padx =
+> 5, -pady => 5);

## Populate grid...
my ($r, $c) = (0,0);
my ($mb, $menu);
$g->Label(-text => 'Search for:')
->grid(-row => $r, -column => $c++, -sticky => 'w');
$g->Entry(-textvariable => \$pat, -width => 32)
->grid(-row => $r, -column => $c++, -sticky => 'ew');
my $mb_pat = $g->Menubutton(-image => $btnbm, -direction => 'right', -
+tearoff => 0)
->grid(-row => $r, -column => $c++, -sticky => 'w');
RemakeMenu( $mb_pat, \@pats, \$pat );

$c++; # <-- empty cell
$g->Checkbutton(-text => 'Case-insensitive?', -variable => \$ins)
->grid(-row => $r, -column => $c++, -sticky => 'w');

$r++; $c=0;
$g->Label(-text => 'Directory:')
->grid(-row => $r, -column => $c++, -sticky => 'w');
$g->Entry(-textvariable => \$dir)
->grid(-row => $r, -column => $c++, -sticky => 'ew');

my $mb_dir = $g->Menubutton(-image => $btnbm, -direction => 'right', -
+tearoff => 0)
->grid(-row => $r, -column => $c++, -sticky => 'w');
RemakeMenu( $mb_dir, \@dirs, \$dir );

$g->Button(-relief => 'flat', -image => $folderxpm, -command => \&Pick
+Dir)
->grid(-row => $r, -column => $c++, -sticky => 'w');
$g->Checkbutton(-text => 'Search subdirs?', -variable => \$tree)
->grid(-row => $r, -column => $c++, -sticky => 'w');

$r++; $c=0;
$g->Label(-text => 'Filespec:')
->grid(-row => $r, -column => $c++, -sticky => 'w');
$g->Entry(-textvariable => \$fpat)
->grid(-row => $r, -column => $c++, -sticky => 'ew');
my $mb_fpat = $g->Menubutton(-image => $btnbm, -direction => 'right', 
+-tearoff => 0)
->grid(-row => $r, -column => $c++, -sticky => 'w');
RemakeMenu( $mb_fpat, \@fpats, \$fpat );

## The entry column is resizeable...
$g->gridColumnconfigure(1, -weight=>1);

## OK, run...
MainLoop();

###########################################################
sub ExitApp {
   ## print "\n\nSomebody asked me to exit...\n";
   SaveMRULists();
   ## print "OK, byeeeeeee!\n\n"; #<-- camp exit!
   exit;
}
sub Search {
   ## Now add values to recent menus unless already there...
   @pats = $patsMRU->add($pat);
   @dirs = $dirsMRU->add($dir);
   @fpats = $fpatsMRU->add($fpat);
   RemakeMenu( $mb_pat, \@pats, \$pat );
   RemakeMenu( $mb_dir, \@dirs, \$dir );
   RemakeMenu( $mb_fpat, \@fpats, \$fpat );
   if( not $exit ) {
      ## Create a new output window...
      my $mw = new MainWindow(-title => "results");
      my $resultsxpm = $mw->Pixmap( -data =>  $images{'results'} );
      $mw->Icon(-image => $resultsxpm);
      $mw->focusmodel('active');
      # Choose a fixed-width font for the listbox...
      $mw->fontCreate('listboxfont', -family => 'courier', -size => '8
+');
      $msgwin = $mw->Scrolled('Listbox', -scrollbars => 'se',
         -font => 'listboxfont',
         -width => '80', -height => '30',
         -exportselection => 0,
       )->pack(-expand => 'yes', -fill => 'both');
      $msgwin->bind('<Double-1>', sub{ OpenFile($msgwin->get('active')
+); });
      $msgwin->focus();
      $mw->raise;
      $mw->focus;
   }

   ## do search...
   fif::FindInFiles( -pat => $pat, -dir => $dir, -fpat => $fpat, 
                        -ins => $ins, -tree => $tree, 
                        -opref => \&MsgOut );
   ## Exit after first search if command line is set...
   ExitApp() if $exit;
}
## CreateMRULists : Set up the MRU lists from the registry
sub CreateMRULists {
   my %mruargs = (
   -groupname => "MSEmtd", 
   -appname => "tkfif",
   -maxrecent => 8,
   );
   $patsMRU = new MRUList( -recentname => "recent_pats", %mruargs );
   $dirsMRU = new MRUList( -recentname => "recent_dirs", %mruargs );
   $fpatsMRU = new MRUList( -recentname => "recent_fpats", %mruargs );
   @pats = $patsMRU->load;
   @dirs = $dirsMRU->load;
   @fpats = $fpatsMRU->load;
}
## SaveMRULists : Save the MRU Lists to the registry.
sub SaveMRULists {
   @pats = $patsMRU->save;
   @dirs = $dirsMRU->save;
   @fpats = $fpatsMRU->save;
}
###################
## RemakeMenu : set up a MRU list menubutton.
## arg 1 is the menubutton
## arg 2 is the array of things (ref)
## arg 3 is the text variable (ref)
sub RemakeMenu {
   my ($mb, $aref, $textvarref) = @_;
   my $menu = $mb->menu();
   ## Fix up the font...
   $menu->configure( -font => $mb->cget('-font') );
   ## Clear the menu...
   $menu->delete( 0, 'end' );
   ## Make entries in the menu and closures to set the value of the 
   ## text variable...
   foreach my $thing (@$aref) {
      $mb->command( -label => $thing, 
                           -command => sub{ $$textvarref = $thing } );
   }
}
###################
## OpenFile
## Open a file that was double-clicked in an output window
## expects a single arg in the pattern of fif::FindInFiles output
sub OpenFile {
   local $_ = shift or return;
   return unless /^([^\(]+)\((\d+)\):'(.*)'$/;
   my( $file, $line, $text ) = ($1, $2, $3);
   #print STDOUT "\$file = '$file'\n";
   #print STDOUT "\$line = '$line'\n";
   #print STDOUT "\$text = '$text'\n";
   if( ! open(FILE, "< $file") ) {
      MsgOut("WARNING: can't open '$file': $!");
      return;
   }
   ## Create a new output window...
   my $mw = new MainWindow(-title => $file);
   my $textxpm = $mw->Pixmap( -data =>  $images{'text'} );
   $mw->Icon(-image => $textxpm);

   $mw->focusmodel('active');
   # Choose a fixed-width font...
   $mw->fontCreate('listboxfont', -family => 'courier', -size => '8');
   $text = $mw->Scrolled('TextUndo', -scrollbars => 'se',
      -font => 'listboxfont',
      -width => '80', -height => '40'
    )->pack(-expand => 'yes', -fill => 'both');
   ## actually get hold of the scrolled widget...
   ## $text = $text->Subwidget('scrolled');
   while (<FILE>) {
      $text->insert( 'end', $_ );
   }
   close FILE;
#   $text->Load($file);
   $text->see("1.0");
   $mw->update();
   $mw->raise;
   $mw->focus;
   $text->see("$line.0");
   $text->markSet('insert', "$line.0");
   $text->tagConfigure('hilite', 
      -background => 'yellow', 
      -foreground => 'blue');
   $text->tagAdd('hilite', "insert linestart", "insert lineend");
   ##$text->selectionSet($line);
   $text->focus;
=for later   
   my $srchcount = 0;
   my @srchargs = ('-forward', '-count', '$srchcount', '--', $pat, 'in
+sert');
   unshift @srchargs, ('-nocase') if ( $ins );
   my $srchindex = $text->search(@srchargs);
   if( $srchindex ) {
      $text->see($srchindex);
      $text->markSet('insert', $srchindex);
      $text->tagAdd('sel', "$srchindex + $srchcount chars");
   }
=cut
   #print Dumper($text);
}
###################
## is_valid_pattern
## Check the given pattern for validity.
## (from the Perl Cookbook)
sub is_valid_pattern {
    my $pat = shift;
    return eval { "" =~ /$pat/; 1 } || 0;
}
###################
## PickDir : pick a directory upon which to operate.
## Win32 style
sub PickDir {
   my $res = BrowseForFolder("Choose a directory for the root of the s
+earch",
                                          CSIDL_DRIVES, BIF_RETURNONLY
+FSDIRS );
   return unless $res;
   $dir = $res;
}
sub MsgOut {
   my $msg = "@_";
   if(! $msgwin) {
      print STDOUT $msg."\n";
      return;
   } else {
      $msgwin->insert('end', $msg);
      $msgwin->see('end');
      $msgwin->update();
   }
}
###################
## Usage
## Print out the program usage and die.
sub Usage
{
   my $usage = "$title $version\n";
   $usage .= "by Michael Erskine (michael.erskine\@tecspy.com)\n";
   $usage .= <<'EOF';
usage:
tkfif [-i] [-r] [-p=<pattern>] [-d=<directory>] [-f=<filename_pattern>
+]

e.g.: -
findinfiles -d="c:\projects" -f="\.(cpp|c|h|rc|dct)$" -p="\bchar\b\s+\
+w+\s*\[\d+\]"
(searches for character array declarations in some C/C++ source files)

args...
-p=<pattern> -- a regular expression (regex) to search for
-f=<filename_pattern> -- a regex for the matching of a filename
   e.g. "\.(c|h|cpp|hpp|rc|dct)$" which will be applied 
   insensitively(!).
-d=<directory> -- directory (must be absolute).
-exit -- when passed, the application will do a single search, print 
   the results to STDOUT and exit.
-i -- case insensitive matching
-r -- recursive subdir searching
-h|-help|-? -- print this!

EOF

   die($usage);
}
###################
## ReadArgs
## Process, validate and setup command line args.
sub ReadArgs
{
   my( $cl_fpat, $cl_dir, $cl_pat, $cl_ins, $cl_help, $cl_tree, $cl_ex
+it );
   my $retval = GetOptions(
      "help|?|h" => \$cl_help,
      "p:s" => \$cl_pat,
      "i" => \$cl_ins,
      "r" => \$cl_tree,
      "f:s" => \$cl_fpat,
      "d:s" => \$cl_dir,
      "exit" => \$cl_exit
   );
   if( ! $retval ) {
      print STDERR "ERROR: did you supply all the required options?\n"
+;
      Usage();
   }
   if( $cl_ins ) {
      $ins = 1;
   }
   if( $cl_tree ) {
      $tree = 1;
   }
   if( $cl_exit ) {
      $exit = 1;
   }
   if( $cl_fpat ) {
       die "ERROR: filename pattern arg '$cl_fpat' is not a valid rege
+x.\n"
         unless is_valid_pattern( $cl_fpat );
      $fpat = $cl_fpat;
   }
   if( $cl_dir ) {
       die "ERROR: directory arg '$cl_dir' is not a valid directory.\n
+"
         unless -d $cl_dir;
      $dir = $cl_dir;
   }
   if( $cl_pat ) {
      die "ERROR: search pattern arg '$cl_pat' is not a valid regex.\n
+"
         unless is_valid_pattern( $cl_pat );
      $pat = $cl_pat;
   }
   if( $cl_help ) {
      Usage();
   }
}
################################
sub MakeImages
{
   $images{ 'folder' } = <<'EOXPM';
/* XPM */
static char *folder[] = {
/* width height num_colors chars_per_pixel */
"    19    17        8            1",
/* colors */
"` c #000000",
". c #9d9d00",
"# c #cece61",
"a c none",
"b c #ffce9d",
"c c #ffff9d",
"d c #ffffce",
"e c #f6f6f6",
/* pixels */
"aaaaaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaaaaa",
"aaaa.....`aaaaaaaaa",
"aaa.eddcc.`aaaaaaaa",
"aa.#######......aaa",
"aa.dddddddddddc#`aa",
"aa.dccccccccccb#`aa",
"aa.dcccccccbcbc#`aa",
"aa.dccccccccbcb#`aa",
"aa.dcccccbcbcbc#`aa",
"aa.dccccccbcbcb#`aa",
"aa.dcccbcbcbcbb#`aa",
"aa.dbcbcbcbcbbb#`aa",
"aa.#############`aa",
"aaa``````````````aa",
"aaaaaaaaaaaaaaaaaaa",
"aaaaaaaaaaaaaaaaaaa"
};
EOXPM
   $images{ 'arrow' } = <<'EOXPM';
/* XPM */
static char *arrow[] = {
/* width height num_colors chars_per_pixel */
"     9    16       16            1",
/* colors */
"` c #000000",
". c #007bbd",
"# c #21adff",
"a c #4abdff",
"b c #636363",
"c c #6bc6ff",
"d c #84ffff",
"e c #8cd6ff",
"f c #b5b5b5",
"g c #ffffff",
"h c #ffffff",
"i c #ffffff",
"j c #ffffff",
"k c #ffffff",
"l c #ffffff",
"m c none",
/* pixels */
"mffmmmmmm",
"fbbfmmmmm",
"b``bfmmmm",
"b`e`bfmmm",
"b`ce`bfmm",
"b`ace`bfm",
"b`aace`bf",
"b`aaace`b",
"b`aaa#.`b",
"b`#a#.`bf",
"b`##.`bfm",
"b`#.`bfmm",
"b`.`bfmmm",
"b``bfmmmm",
"fbbfmmmmm",
"mffmmmmmm"
};
EOXPM
   $images{ 'text' } = <<'EOXPM';
/* XPM */
static char *text[] = {
/* width height num_colors chars_per_pixel */
"    32    32        2            1",
/* colors */
"# c #bfbf00",
". c #ffffff",
/* pixels */
"################################",
"################################",
"################################",
"################################",
"####........................####",
"####........................####",
"####........................####",
"####........................####",
"####....################....####",
"####....################....####",
"####....################....####",
"####....################....####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####..........####..........####",
"####........................####",
"####........................####",
"####........................####",
"####........................####",
"################################",
"################################",
"################################",
"################################"
};
EOXPM
   $images{ 'results' } = <<'EOXPM';
/* XPM */
static char *results[] = {
/* width height num_colors chars_per_pixel */
"    32    32        2            1",
/* colors */
"# c #bfbf00",
". c #ffffff",
/* pixels */
"################################",
"################################",
"################################",
"################################",
"####........................####",
"####........................####",
"####........................####",
"####........................####",
"####....##############......####",
"####....##############......####",
"####....################....####",
"####....################....####",
"####....####........####....####",
"####....####........####....####",
"####....####......######....####",
"####....####......######....####",
"####....##############......####",
"####....##############......####",
"####....############........####",
"####....############........####",
"####....####....######......####",
"####....####....######......####",
"####....####......######....####",
"####....####......######....####",
"####........................####",
"####........................####",
"####........................####",
"####........................####",
"################################",
"################################",
"################################",
"################################"
};
EOXPM
   $images{ 'find' } = <<'EOXPM';
/* XPM */
static char *find[] = {
/* width height num_colors chars_per_pixel */
"    32    32       2             1",
/* colors */
"# c #bfbf00",
". c #ffffff",
/* pixels */
"################################",
"################################",
"################################",
"################################",
"####........................####",
"####........................####",
"####........................####",
"####........................####",
"####....################....####",
"####....################....####",
"####....################....####",
"####....################....####",
"####....####................####",
"####....####................####",
"####....####................####",
"####....####................####",
"####....############........####",
"####....############........####",
"####....############........####",
"####....############........####",
"####....####................####",
"####....####................####",
"####....####................####",
"####....####................####",
"####........................####",
"####........................####",
"####........................####",
"####........................####",
"################################",
"################################",
"################################",
"################################"
};
EOXPM

}
__END__
=head1 AUTHOR

Michael Erskine michael.erskine@tecspy.com

=head1 COPYRIGHT AND DISCLAIMER

This program is Copyright 2001 by Michael Erskine.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

If you do not have a copy of the GNU General Public License write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
MA 02139, USA.

=cut
package fif;
## fif : 'find in files' -- a package to do "find -exec grep" on 
## feature-poor architectures (e.g. Win32)
use strict;
use warnings;
use Carp;
use File::Find;
use Cwd;
my $version = "1.1";
my ($pat, $dir, $fpat, $ins, $tree, $opref, $count, $dbg);

###################
## FindInFiles
## do "find -exec grep" on a dir or tree
## with Perl REs
sub FindInFiles {
   my %args = @_;
   $pat = $args{-pat} or croak "-pat arg not given";
   $dir = ( $args{-dir} or cwd() );
   $fpat = ( $args{-fpat} or '.+');
   $ins = ( $args{-ins} or 0 );
   $tree = ( $args{-tree} or 0 );
   $dbg = ( $args{-dbg} or 0 );
   if( ($opref = $args{-opref}) and (ref($opref) ne 'CODE') ) {
      croak( "-opref arg is not a reference to code");
   }
   
   if( ! is_valid_pattern( $pat ) ) {
      msgout("Invalid pattern '$pat'");
      return;
   }
   if( ! is_valid_pattern( $fpat ) ) {
      msgout("Invalid file pattern '$fpat'");
      return;
   }
   $dir =~ s/[\\\/]$//; #<-- strip a trailing slash from dir.
   if( ! -d $dir ) {
      msgout("Not a directory '$dir'.");
      return;
   }
   $count=0;
   if( $tree ) {
      find({wanted => \&ExamineFile, no_chdir => 1}, ($dir));
   } else {
      if(! opendir(DIR, $dir)){
         msgout("Can't opendir $dir: $!");
         return
      }
      my @files = readdir DIR;
      closedir DIR;
      foreach my $file (@files){
         local $_ = $dir.'/'.$file;
         ExamineFile();
      }
   }
   msgout("Files found: $count");
   return $count;
}
###################
## ExamineFile
## Called by the file finder to process a file
sub ExamineFile
{
   ## Only consider plain files that match the filename pattern...
   return unless -f;
   return unless /$fpat/i;

   if( $dbg ) {
      msgout("DEBUG: Found: '$_'");
   }

   my $file = $_;
   {
      ## Local line counter $. and default arg $_ so as not to mess
      ## with File::Find...
      local $_;
      local $.;
      if( ! open(FILE, "< $file") ) {
         msgout("WARNING: can't open '$file': $!");
         return;
      }
      ## Translate slashes to backslashes for output...
      $file =~ tr/\//\\/;
      while(<FILE>) {
         if( $ins ) {
            next unless /$pat/i;
         } else {
            next unless /$pat/;
         }
         chomp;
         msgout("$file($.):'$_'");
         $count++;
      }
      close FILE;
   }
}
###################
## is_valid_pattern
## Check the given pattern for validity.
## (from the Perl Cookbook)
sub is_valid_pattern {
    my $pat = shift;
    return eval { "" =~ /$pat/; 1 } || 0;
}
###################
## msgout
## function for output of messages to STDOUT 
## or a delegate function
sub msgout {
   my $msg = "@_";
   if( $opref ) {
      &$opref( $msg );
      return;
   }
   print STDOUT $msg."\n";
}

1;
__END__
=head1 SYNOPSIS

   use fif;
   ## Do directory-recursive search...
   fif::FindInFiles( -pat => 'erskine',
                        -dir => 'D:/msemtd/Perl/fif', 
                        -fpat => '\.(pl|pm|pod)$',
                        -tree => 1);
   ## Do non-recursive search of current dir...
   fif::FindInFiles( -pat => '^\#include',
                        -fpat => '\.(c|cpp|h)$');

=head1 AUTHOR

Michael Erskine michael.erskine@tecspy.com

=head1 COPYRIGHT AND DISCLAIMER

This program is Copyright 2001 by Michael Erskine.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

If you do not have a copy of the GNU General Public License write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
MA 02139, USA.

=cut
package MRUList;
require 5.005_62;
use strict;
use warnings;
use Carp;
my $version = "0.3";
use Win32::TieRegistry( Delimiter=>"/" );

sub new {
   my $class = shift;
   croak('Odd number of args'."$class->new(" . join(',',@_) .')') if @
+_ % 2;
   ## TODO: complain about unrecognised args.
   my $self  = {};         # allocate new hash for object
   bless($self, $class);
   ## Initialise members from params...
   my %params = @_;
   $self->{MAXRECENT} = checkmaxrecent($params{-maxrecent});
   $self->{GROUPNAME} = ( $params{-groupname} or 'MRUList');
   $self->{APPNAME} = ( $params{-appname} or 'MRUList');
   $self->{RECENTNAME} = ( $params{-recentname} or 'MRUList');
   $self->{RECENTVALS} = [];
   my $valsref = $params{-values};
   if (ref($valsref) eq 'ARRAY') {
      @$valsref = @{$self->{RECENTVALS}};
   }
   return $self;
}

sub DESTROY {
   my $self = shift;
   ## printf("$self dying at %s\n", scalar localtime);
}

## Accessors (simple)...
sub groupname {
   my $self = shift;
   my $prev = $self->{GROUPNAME};
    if (@_) { $self->{GROUPNAME} = shift } 
    return $prev;
}
sub appname {
   my $self = shift;
   my $prev = $self->{APPNAME};
    if (@_) { $self->{APPNAME} = shift } 
    return $prev;
}
sub recentname {
   my $self = shift;
   my $prev = $self->{RECENTNAME};
    if (@_) { $self->{RECENTNAME} = shift } 
    return $prev;
}
sub maxrecent {
   my $self = shift;
   my $prev = $self->{MAXRECENT};
   my $new = shift or return $prev;
   $self->{MAXRECENT} = checkmaxrecent($new);
   return $new;
}
## Local validator function for maxrecent.
sub checkmaxrecent {
   my $defaultval = 10;
   my $new = shift or return $defaultval;
   if( $new !~ /^\d+$/ ) {
      warn "maxrecent: Not a natural integer value.\n";
      return $defaultval;
   }
   if( $new < 1 ) {
      warn "maxrecent: less that 1.\n";
      return $defaultval;
   }
   return $new;
}
## Get a copy of the list...
sub get {
   my $self = shift;
   return @{$self->{RECENTVALS}};
}
## Add the new items to the top of the list...
sub add {
   my $self = shift;
   return if not scalar @_;
   my $vr = $self->{RECENTVALS};
   my $max = $self->{MAXRECENT};
   ## Add the new items to the top of the list...
   unshift @{$vr}, @_;
   ## Tidy up and return either new length or values...
   my $len = deldupetrim($vr, $max);
   return $len unless wantarray();
   return @{$self->{RECENTVALS}};
}
## deldupetrim : Given a list reference and a length, remove 
## duplicates and trim whilst retaining original list order.
## A generic function.
sub deldupetrim {
   my ($vr, $max) = @_;
   ## Remove duplicate items...
   my %seen = ();
   @{$vr} = grep { ! $seen{$_} ++ } @{$vr};
   ## Trim list to max length - oldest values are lost...
   if( scalar(@{$vr}) > $max){
      $#$vr = $max - 1
   }
   ## Return the new length...
   return scalar @{$vr};
}

sub load {
   my $self = shift;
   ## Get the software key...
   my $swkey = $Registry->{"CUser/Software/"};
   if( ! $swkey ) {
      warn "couldn't open the software key -- too bad.\n";
      return;
   }
   my $groupname = $self->{GROUPNAME};
   my $appname = $self->{APPNAME};
   my $recentname = $self->{RECENTNAME};
   my $recent = $swkey->{"$groupname/$appname/$recentname/"};
   if( ! $recent ) {
      warn "couldn't open recent key $recentname -- too bad: $^E\n";
      return;
   }
   my $max = $self->{MAXRECENT};
   my $vr = $self->{RECENTVALS};
   ## Empty the values list...
   @{$vr} = ();
   ## Access each name in an ordered fashion...
   foreach(  sort keys %$recent ) {
      ## The names have to be digits only...
      if( ! /^\/\d+$/ ) {
         warn "bad name '$_' in recent.\n";
      } else {
         my $val = $recent->{$_};
         push @$vr, $val;
      }
   }
   ## Tidy up and return either new length or values...
   my $len = deldupetrim($vr, $max);
   return $len unless wantarray();
   return @{$self->{RECENTVALS}};
}

sub save {
   my $self = shift;
   ## Get the software key...
   my $swkey = $Registry->{"CUser/Software/"};
   if( ! $swkey ) {
      warn "couldn't open the software key -- too bad.\n";
      return;
   }
   my $groupname = $self->{GROUPNAME};
   my $appname = $self->{APPNAME};
   my $maxrecent = $self->{MAXRECENT};
   my $recentname = $self->{RECENTNAME};
   my $refvals = $self->{RECENTVALS};
   
   ## Blast the original data...
   my $recent = $swkey->{"$groupname/$appname/$recentname/"};
   undef %$recent;
   
   my $i;
   for( $i = 0; $i <@$refvals; $i++ ) {
      $swkey->{"$groupname/"}= {
         "$appname/" => {
            "$recentname/" => {
               "/$i" => $refvals->[$i],
            }
         }
      };
      last if $i >= $maxrecent;
   }
   ## Return the number of vals...
   return scalar @$refvals;
}

1;
__END__

# Below is the documentation for the module.

=head1 NAME

MRUList - Perl extension for storing and retrieving 
Most-Recently-Used lists in the Windows Registry.

=head1 SYNOPSIS

   use MRUList;
   my $recentfiles = new MRUList( -maxrecent => '4', 
                                   -recentname => 'RecentFiles',
                                   -appname => 'MyEditor',
                                   -groupname => 'MySoftwareHouse',
                                   -values => ['c:/boot.ini', 'c:/conf
+ig.sys', 'c:/temp/tmp1.txt'] );
   ## Write to registry...
   $recentfiles->save; 
   
   ## Add new entries - the oldest entries will be lost if maxrecent i
+s 
   ## reached...
   $recentfiles->add( 'c:/hat.txt', 'c:/coat.txt' );
   
   ## Some other time - load values from the registry...
   my $recentfiles = new MRUList( -maxrecent => '4', 
                                   -recentname => 'RecentFiles',
                                   -appname => 'MyEditor',
                                   -groupname => 'MySoftwareHouse',);
   $recentfiles->load;

=head1 DESCRIPTION

This module is a registry-stored Most-Recently-Used list (and hence is
Win32-specific) which I find to be a common requirement of many of my 
apps. When used thus...

   my $mru  = new MRUList;
   $mru ->add( qw( hat coat scarf ));
   $mru ->add( qw( car boat ship ));
   $mru ->save;

...one would find some numbered registry keys populated thus...

   [HKEY_CURRENT_USER\Software\MRUList\MRUList\MRUList]
   "0"="car"
   "1"="boat"
   "2"="ship"
   "3"="hat"
   "4"="coat"
   "5"="scarf"

The "\MRUList\MRUList\MRUList" branch is the default key which can 
be adjusted by setting the 3 members "groupname", "appname", and 
"recentname" accordingly which I find allows the separation and 
granularity I generally need: e.g. one can be set the software vendor 
name in "groupname" say, "SuperPerlSoft", the particular application 
name can be set in "appname" say, "GoodEditor", and "recentname" 
allows multiple lists per application such as 
"MostRecentlyTrashedFiles"...

   use MRUList;
   my $recentfiles = new MRUList( 
      -maxrecent => '10', 
      -recentname => 'RecentFiles',
      -appname => 'MyEditor',
      -groupname => 'MySoftwareHouse',
      -values => ['c:/boot.ini', 'c:/config.sys', 'c:/temp/tmp1.txt'] 
   );
   $recentfiles->save;

...would result in the following registry key being populated...

   [HKEY_CURRENT_USER\Software\MySoftwareHouse\MyEditor\RecentFiles]
   "0"="c:/boot.ini"
   "1"="c:/config.sys"
   "2"="c:/temp/tmp1.txt"

...and a corresponding "load" method retrieves these values from the 
registry and the dump method simply uses Data::Dumper...

   use MRUList;
   my $recentfiles = new MRUList( -maxrecent => '10', 
                                   -groupname => 'MySoftwareHouse',
                                   -appname => 'MyEditor',
                                   -recentname => 'RecentFiles',
                                   );
   my @files = $recentfiles->load;
   print "Recent files = \n".join("\n", @files)."\n";

...would result in...

   Recent files = 
   c:/boot.ini
   c:/config.sys
   c:/temp/tmp1.txt 

Now, although this module is an exercise in learning for the author, 
I believe this to be of wider use if it were to be made a little less 
Win32-specific (BTW: the load & save methods need never be used!).
I am appealing to anyone interested to cast an eye over it 
and perhaps suggest some improvements.

My next step is to wrap this in a 
number of Tk widgets (a menu, a comboentry, etc.) to provide some 
persistent dynamic GUI element features that I often require.

=head2 EXPORT

None by default.

=head1 BUGS

Should be Win32::MRUList because it is Win32-specific but the fact 
that it is Win32-specific is a bug in itself! The aim is to make this
package work on other platforms (perhaps with .rc files or simillar).

=head1 SEE ALSO

perl(1). Win32::TieRegistry

=head1 AUTHOR

Michael Erskine michael.erskine@tecspy.com

=head1 COPYRIGHT AND DISCLAIMER

This program is Copyright 2001 by Michael Erskine.
This program is free software; you can redistribute it and/or
modify it under the terms of the Perl Artistic License or the
GNU General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

If you do not have a copy of the GNU General Public License write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
MA 02139, USA.

=cut

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://261906]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (6)
As of 2024-03-28 09:55 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found