This script displays a "live" widget that displays a list of Perl subs and packages in the current Textpad file. Clicking the widget will jump to the corresponding code. That's it. The current file is taken from Textpad's title bar, so whenever you switch files in Textpad, the widget will update. Also, updates should appear when a file is saved.
Pretty much everything should be configurable via the constants at the top of the file. All modules can be found on CPAN.
The window should follow Textpad to foreground, and should hide to systray when Textpad loses focus. This keeps it out of the way when using other apps. You can also force hiding with the systray menu.
Recommended usage (i.e. the way I run) is to keep Textpad maximized. I keep the "Tool output" and "Search results" windows docked on bottom of screen. Tool output is on the left, ~75% of total window. Search results is on right. This script is sized and positioned to perfectly cover the Search results window (I dont use SearchResults)
Recommend using hstart.exe to run script "hidden". I leave it running constantly in the systray.
http://www.ntwind.com/software/utilities/hstart.html
cmd (note "s): hstart.exe /NOCONSOLE "perl perlparser.pl"
I hope someone out there can use this.
-Jon
Code: Select all
#!/perl
###############################################################################
#
# FILE $RCSfile: perlparser.pl,v $
#
# RCS REVISION $Revision: 1.8 $
#
# NOTES
# This script displays a "live" widget that displays a list
# of Perl subs and packages in the current Textpad file.
# Clicking the widget will jump to the corresponding code.
# That's it.
#
# Pretty much everything should be configurable via the
# constants at the top of the file.
#
# The window should follow Textpad to foreground, and should
# hide to systray when Textpad loses focus. This keeps it
# out of the way when using other apps. You can also force
# hiding with the systray menu.
#
# Recommended usage (i.e. the way I run) is to keep Textpad
# maximized. I keep the "Tool output" and "Search results"
# windows docked on bottom of screen. Tool output is on
# the left, ~75% of total window. Search results is on
# right. This script is sized and positioned to perfectly
# cover the Search results window (I dont use SearchResults)
#
# Recommend using hstart.exe to run script "hidden".
# http://www.ntwind.com/software/utilities/hstart.html
# cmd: hstart.exe /NOCONSOLE "perl perlparser.pl" (note "s)
#
# KNOWN ISSUES - Embedded POD may cause false-positives.
#
###############################################################################
use constant DEFAULT_ICON => "perlcamel.ico"; # Can be any icon
use constant DEFAULT_GEOMETRY => "200x220-0-80"; # Initial size/position
use constant DEFAULT_WIDTH => 30; # Play with value
use constant DEFAULT_HEIGHT => 14; # Play with value
use constant DEFAULT_REFRESH => 200; # Polling time (ms)
use strict;
use Carp;
use Win32;
use Win32::GuiTest qw(:ALL);
use Win32::SysTray;
use Hash::Util qw(lock_keys);
use File::stat qw(:FIELDS);
use File::Basename;
use File::Spec::Functions qw(rel2abs file_name_is_absolute);
use YAML qw(DumpFile);
use Tk;
use Tk::Tree;
use Tk::NoteBook;
use Tk::after;
use Tk::StayOnTop;
# Main Window
my %widgets;
my $mw;
# Force to systray, or allow window to display?
my $stay_hidden = 0;
# Store info of currently parsed file
my $working_filename;
my $working_filetime;
# Store the Textpad window handle
my $textpad_hwnd;
# Arrays-of-Hashes to store parsed file info
my @packages;
my @subs;
# Kick things off...
initialize();
# Let Tk do its thing...
MainLoop;
# When the MainWindow goes down, exit.
exit 0;
# Given a filename, will parse the file and populate the
# dropdown list widgets
sub parse_file($) {
my $filename = shift;
# Clear out the listboxes
$widgets{PACKAGES_LIST}->delete('all');
$widgets{SUBS_LIST}->delete('all');
return unless -f $filename;
# Read in file
open(INFILE, "<${filename}");
my @lines = (<INFILE>);
close(INFILE);
# Clear out any previous subs/packages
@packages = ();
@subs = ();
my $tmp_href;
# Parse the input file
for (my $linenum = 0; $linenum < @lines; $linenum++) {
my $line = $lines[$linenum];
if ($line =~ /^\s*use\s+([a-zA-Z0-9_:]+)[ \t;]/) {
push(@packages, {'id'=>$1, 'line'=>$linenum+1}) unless grep(/^$1$/, @packages);
}
if ($line =~ /^\s*sub\s+(\S+)([ \t;]|$)/) {
push(@subs, {'id'=>$1, 'line'=>$linenum+1}) unless grep(/^$1$/, @subs);
}
}
# Sort packages and subs alphabetically by name (case insensitive)
@packages = sort {uc($a->{'id'}) cmp uc($b->{'id'})} @packages;
@subs = sort {uc($a->{'id'}) cmp uc($b->{'id'})} @subs;
# Populate the PACKAGES Tree
foreach my $package (@packages) {
next unless $package;
# Add package root
my $pkgfile = get_package_filename($package->{id});
next unless -f $pkgfile;
$widgets{PACKAGES_LIST}->add($package->{id}, -text=>"$package->{id}", -data=>"$pkgfile,") unless $widgets{PACKAGES_LIST}->info('exists', $package->{id});
# For each package file, parse it and add its subs to Tree
open(TMPFILE, "<".get_package_filename($package->{id}));
my @lines = (<TMPFILE>);
for (my $linenum = 0; $linenum < @lines; $linenum++) {
my $line = $lines[$linenum];
if ($line =~ /^\s*sub\s+(\S+)[ \t;]/) {
$widgets{PACKAGES_LIST}->add("$package->{id}/$1", -text=>$1, -data=>"$pkgfile,$linenum") unless $widgets{PACKAGES_LIST}->info('exists', "$package->{id}/$1");
}
}
close(TMPFILE);
}
# If no entries were added, add <none>
$widgets{PACKAGES_LIST}->add("<none>", -text=>"<none>") unless $widgets{PACKAGES_LIST}->info('children', "");
# Default all tree entries to 'closed'
$widgets{PACKAGES_LIST}->autosetmode();
foreach ($widgets{PACKAGES_LIST}->info('children', '')) {
$widgets{PACKAGES_LIST}->close($_);
}
# Populate the SUBS Tree
foreach my $sub (@subs) {
next unless $sub;
# Add sub root (that's all for subs)
$widgets{SUBS_LIST}->add($sub->{id}, -text=>$sub->{id}, -data=>"$working_filename,$sub->{line}") unless $widgets{SUBS_LIST}->info('exists', $sub->{id});
}
# If no entries were added, add <none>
$widgets{SUBS_LIST}->add("<none>", -text=>"<none>") unless $widgets{SUBS_LIST}->info('children', "");
}
# Builds the main GUI window and performs default bindings
sub initialize() {
$mw = new MainWindow;
$mw->title("Perl browser");
$mw->iconbitmap(DEFAULT_ICON);
$mw->waitVisibility();
$mw->stayOnTop;
$mw->overrideredirect(1); # Turn off frame
$mw->geometry(DEFAULT_GEOMETRY); # Bottom-right corner of Textpad
$widgets{MW} = $mw;
my $width = DEFAULT_WIDTH;
my $height = DEFAULT_HEIGHT;
# Create radiobuttons to choose the device
$widgets{NOTEBOOK} = $mw->NoteBook()->pack(-side=>'top', -anchor=>'w');
my @tabs = qw(SUBS PACKAGES);
# Create the GUI elements and bindings for each tab. Will create:
# - $widgets{<TAB>_FRM}: A reference to the frame in the Notebook
# - $widgets{<TAB>_LIST}: A reference to the listbox
# - &{handle_<tab>_click} Must be defined to handle the listbox click
foreach my $tab (@tabs) {
$widgets{uc "${tab}_FRM"} = $widgets{NOTEBOOK}->add("$tab", -label=>"$tab");
$widgets{uc "${tab}_LIST"} = $widgets{uc "${tab}_FRM"}->Scrolled('Tree', -scrollbars=>"e", -width=>$width, -height=>$height, -selectmode=>'single')->pack( -side=>'top', -anchor=>'w' );
$widgets{uc "${tab}_LIST"}->bind("<Button-4>", sub { $widgets{uc "${tab}_LIST"}->yviewScroll( 1,"units") });
$widgets{uc "${tab}_LIST"}->bind("<Button-5>", sub { $widgets{uc "${tab}_LIST"}->yviewScroll(-1,"units") });
$widgets{uc "${tab}_LIST"}->configure(
-separator => '/',
-drawbranch => 'true',
-indicator => 'true',
-selectborderwidth => '0',
-selectmode => 'extended',
-command => sub{open_file($widgets{uc "${tab}_LIST"}->info('data',shift))},
#-browsecmd => sub {},
#-opencmd => sub {print "Open\n"},
);
}
# Bind the "close X" button to minimize instead of exit
$mw->protocol('WM_DELETE_WINDOW', sub {$stay_hidden = 1; minimize_to_systray();});
# Refresh status periodically
$mw->repeat(DEFAULT_REFRESH, sub{find_filename()});
#$win32_mw->AddNotifyIcon(
$widgets{SYSTRAY} = new Win32::SysTray (
'name' => 'Perl browser',
'icon' => DEFAULT_ICON,
'single' => 1,
#'onClick' => sub { print "Click\n" },
) or croak "Could not create systray";
# Set systray popup menu
$widgets{SYSTRAY}->setMenu (
"> &Hide" => sub { $working_filename = '', $stay_hidden = 1; minimize_to_systray(); },
"> &Restore" => sub { $working_filename = '', $stay_hidden = 0; restore_from_systray(1); },
">-" => 0,
"> Toggle frame" => sub { toggle_frame(); },
">-" => 0,
"> Save settings" => sub { save_settings(); },
"> Load settings" => sub { load_settings(); },
">-" => 0,
"> E&xit" => sub { $mw->destroy(); },
);
# All widgets are created.
# Flag any attempt to access non-existing widgets.
lock_keys(%widgets);
load_settings();
}
# Given a Perl package name (ex File::Basename),
# will return the associated PM file by searching @INC.
# Undef if not found.
sub get_package_filename($) {
my $pkg_name = shift;
my $pkg_file = "${pkg_name}.pm";
$pkg_file =~ s|::|/|g;
foreach my $dir (@INC) {
my $filename = "${dir}/${pkg_file}";
$filename = (dirname($working_filename) . "/$filename") unless file_name_is_absolute($filename);
#print "Checking for $filename\n";
if (-f $filename) {
return $filename;
}
}
return;
}
# Open a text file with an editor (at an optional line number);
sub open_file($;$) {
my $filename = shift;
my $linenum = shift;
print "opening '$filename'\n";
# Data may be passed as "FILENAME,LINENUM"
if (my @tmp = split(/,/, $filename)) {
$filename = $tmp[0];
$linenum = $tmp[1];
}
unless (-f $filename) {
carp "'$filename' does not exist";
return;
}
$linenum = sprintf("(%u)", $linenum+1) if defined $linenum;
# TODO: When running in PAR package mode, this briefly pops a command window
my $cmd = "start textpad.exe \"${filename}${linenum}\"";
print "Running $cmd\n";
system $cmd;
}
# Look for the TextPad window title. Extract the filename
# from the title, and update widgets accordingly.
sub find_filename() {
my $searchString = 'TextPad';
# Get the foreground window title
my $fg_wnd = GetForegroundWindow();
my $title = GetWindowText($fg_wnd);
my $parent_title = GetWindowText(GetParent($fg_wnd));
my $is_child = ($parent_title =~ /TextPad - \[(.+)\]/);
# Check if it is Textpad and extract filename
if( $title =~ /TextPad - \[(.+)\]/ ) {
$textpad_hwnd = $fg_wnd;
# Capture filename and remove "unsaved" mark
my $filename = $1;
$filename =~ s/ \*$//;
# We want to check the modified time
stat($filename);
my $filetime = $st_mtime;
# Only update if something changed (new filename or modified file)
if (($filename ne $working_filename) or ($filetime > $working_filetime)) {
$working_filename = $filename;
$working_filetime = $filetime;
restore_from_systray();
SetForegroundWindow($fg_wnd);
parse_file($filename);
}
} elsif ($is_child) {
# Do nothing
# Don't do anything if our GUI comes into focus
} elsif ($title eq $mw->title()) {
# do nothing
# If any other window comes into focus, minimize to tray
} else {
$working_filename = '';
minimize_to_systray();
}
}
# Toggle frame
sub toggle_frame() {
$mw->overrideredirect( not $mw->overrideredirect() );
}
# Save settings
sub save_settings() {
open(SETTINGS, ">perlparser.conf") || carp "Could not open settings";
print SETTINGS "HIDEFRAME=", $mw->overrideredirect(), "\n";
print SETTINGS "GEOMETRY=", $mw->geometry(), "\n";
close(SETTINGS);
}
# load settings
sub load_settings() {
open(SETTINGS, "<perlparser.conf") || carp "Could not open settings";
while (my $line = <SETTINGS>) {
chomp $line;
if ($line =~ /^GEOMETRY=(.+)$/i) {
$mw->geometry( $1 );
} elsif ($line =~ /^HIDEFRAME=(.+)$/i) {
$mw->overrideredirect( $1 );
}
}
close(SETTINGS);
}
# Minimize to tray
sub minimize_to_systray() {
$mw->withdraw;
}
# Restore
sub restore_from_systray(;$) {
my $force = shift;
if ($force or (not $stay_hidden and ($mw->state eq 'withdrawn'))) {
$mw->deiconify;
$mw->raise;
}
}
## ===========================
## CHANGE HISTORY
## $Log: perlparser.pl,v $
## Revision 1.8 2009/03/17 05:09:14 Jon
## Updated to handle '.' directory in @INC.
##
## Revision 1.7 2009/03/17 04:39:02 Jon
## Changed icon filename.
##
## Revision 1.6 2009/03/17 03:08:45 Jon
## Updated to use constants for easy configuration.
## Added comments.
##
## Revision 1.5 2009/03/17 02:03:05 Jon
## Updated comments.
##
## Revision 1.4 2009/03/16 23:08:53 Jon
## Changed Icon.
## Updated sub matching to accept endline immediately after sub name.
##
## Revision 1.3 2009/03/16 23:06:06 Jon
## Added logic to check if fg_wnd is a Textpad child.
##
## Revision 1.2 2009/03/15 20:06:12 Jon
## Updated to use Tk::Tree widget instead of ListBox. This is
## more appropriate for package viewer, and mousewheel scrolling works.
##
## Revision 1.1 2009/03/15 06:16:18 Jon
## Initial revision
##
##