#!/usr/bin/perl -w -- # -*-Perl-*-
#
# pmnewnodes
# Shendal, November 2000
#
# Tk browser to look at newest nodes
#
# Requires zzamboni's PerlMonk.pm version 2 or greater
#
# To-do:
# - right-click currently does nothing. Would be nice to have it do s
+omething
# Along the same line of thought, perhaps have ctl-click, shift-cli
+ck, etc,
# do something as well?
# - Allow user to set order of top nodes and which to include/exclude
# - 'Mark All Read' is confusing. I need a more clear way to say, "ma
+rk these
# nodes read locally" vs. updating perlmonks.
# - Colorize nodes written by logged-in user?
# - Add a way to login in as a user - currently, it relies on a pre-e
+xisting
# cookie.
# - Looks like update of PerlMonks date isn't working right...
#
# Version history:
# 0.5 11/2/00
# - Uses new functions in PerlMonks.pm for keeping track of read/unre
+ad nodes
# - Modes for a node are: Top (titles), new, read, unread or flagged.
+ Each has
# its own associated color (user-defineable, naturally).
# - After double clicking on a node, the thread is marked as read. Th
+is is user
# configurable via a menu option.
# - Number of unread nodes is now shown in the status bar
# - Buttons now use bitmap icons to represent their action instead of
+ words. Added
# balloon tool tips to show novice users what they do. Simply hover
+ over the icon.
# - Added previous and next unread buttons.
# - Option to launch browser on next/previous added (default is on).
# - Redraw Tree moved to a debug menu enabled by -debug command line
+option.
#
# 0.4 9/22/00
# - Now uses a browser window that's already open, if available
# - Support for colorization added
# - F5 updates
#
# 0.3 9/7/00
# - Update no longer collapses all nodes
#
# 0.2 9/7/00
# - Enabled Mark All Read button
# - When launching browser, now goes to node_id instead of node's tit
+le
#
# 0.1 9/6/00
# - initial version
#
use strict; # always
use PerlMonks::NewestNodes;
use SDBM_File;
use Fcntl;
use Getopt::Long;
# Tk libs
use Tk 8.0;
use Tk::Tree;
use Tk::LabEntry;
use Tk::FileSelect;
use Tk::ItemStyle;
use Tk::Balloon;
# Unbuffered output to STDOUT
$|++;
# declarations
my $version = '0.5';
my $p; # PerlMonks::NewestNodes object
my $Window; # Window Tk widget
my $tree; # scrolled tree Tk widget
my $statusbar; # status bar label widget
my $choosebrowser_w; # choose browser window
my $browserfield; # choose browser field
my %options; # options hash
my %styles; # item styles hash for colorization
my $status_idle = "pmnewnodes version $version idle"; # idle status te
+xt
# list of all the valid types with "nice" names
my %nodetypes = ( 'poem' => 'Poems',
'categorized question' => 'Categorized Questions',
'monkdiscuss' => 'Perlmonks Discussion',
'perlcraft' => 'Perl Craft',
'categorized answer' => 'Categorized Answers',
'obfuscated' => 'Obfuscated Perl',
'snippet' => 'Code Snippets',
'sourcecode' => 'Code Catacombs',
'review' => 'Reviews',
'perlmeditation' => 'Meditations',
'perlnews' => 'Perl News',
'perlquestion' => 'Seekers of Perl Wisdom',
'user' => 'User',
'note' => 'Notes & Replies');
# URL to use for links into perlmonks & cpan
my $perlmonksURL = 'http://www.perlmonks.org/index.pl?node=';
my $perlmonksURL_id = 'http://www.perlmonks.org/index.pl?node_id=';
# options hash
tie(%options,'SDBM_File',"$ENV{HOME}/.monknewnodes",O_RDWR|O_CREAT,064
+0);
my %default_options = (browser => undef,
background => 'white',
auto_mark_read => 1,
auto_launch => 1,
color_top => 'black',
color_unread => 'black',
color_read => '#adadad',
color_new => 'blue',
color_flag => 'red',
);
# images
my %bitmaps = ('previous' => '#define previous_width 16
#define previous_height 16
static unsigned char previous_bits[] = {
0x08, 0x10, 0x08, 0x18, 0x08, 0x1c, 0x08, 0x1e, 0x08, 0x1f, 0x88, 0
+x1f,
0xc8, 0x1f, 0xe8, 0x1f, 0xc8, 0x1f, 0x88, 0x1f, 0x08, 0x1f, 0x08, 0
+x1e,
0x08, 0x1c, 0x08, 0x18, 0x08, 0x10, 0x00, 0x00};
',
'next' => '#define next_width 16
#define next_height 16
static unsigned char next_bits[] = {
0x08, 0x10, 0x18, 0x10, 0x38, 0x10, 0x78, 0x10, 0xf8, 0x10, 0xf8, 0
+x11,
0xf8, 0x13, 0xf8, 0x17, 0xf8, 0x13, 0xf8, 0x11, 0xf8, 0x10, 0x78, 0
+x10,
0x38, 0x10, 0x18, 0x10, 0x08, 0x10, 0x00, 0x00};
',
'update' => '#define update_width 16
#define update_height 16
static unsigned char update_bits[] = {
0x00, 0x00, 0x00, 0x00, 0xc0, 0x01, 0xf0, 0x07, 0x38, 0x0e, 0x1c, 0
+x1c,
0x0c, 0x1c, 0x0e, 0x1c, 0x0e, 0x1c, 0x86, 0xff, 0x06, 0x7f, 0x06, 0
+x3e,
0x0c, 0x1c, 0x00, 0x08, 0x00, 0x00, 0x00, 0x00};
',
'mark' => '#define /home/dharrel/mark.bmp_width 16
#define /home/dharrel/mark.bmp_height 16
static unsigned char /home/dharrel/mark.bmp_bits[] = {
0x00, 0x00, 0x00, 0x70, 0x00, 0x3c, 0x00, 0x0e, 0x00, 0x07, 0x00, 0
+x03,
0x80, 0x01, 0x9c, 0x01, 0xbe, 0x00, 0xf8, 0x00, 0xf0, 0x00, 0xe0, 0
+x00,
0xc0, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00};
',
'markthread' => '#define markthread_width 16
#define markthread_height 16
static unsigned char markthread_bits[] = {
0x00, 0x00, 0x00, 0x38, 0x00, 0x1e, 0x00, 0x07, 0x80, 0x03, 0x80, 0
+x01,
0xc0, 0x08, 0xce, 0x08, 0x5f, 0x08, 0x7c, 0x7f, 0x78, 0x08, 0x70, 0
+x08,
0x60, 0x08, 0x60, 0x00, 0x00, 0x00, 0x00, 0x00};
',
'markall' => '#define markall_width 16
#define markall_height 16
static unsigned char markall_bits[] = {
0x00, 0x00, 0x00, 0x70, 0x00, 0x3c, 0x00, 0x0e, 0x00, 0x07, 0x00, 0
+x03,
0x80, 0x01, 0x9c, 0x01, 0xbe, 0x00, 0xf8, 0xa4, 0xf0, 0xaa, 0xe0, 0
+xae,
0xc0, 0xaa, 0xc0, 0xaa, 0x00, 0x00, 0x00, 0x00};
',
'expandall' => '#define expandall_width 16
#define expandall_height 16
static unsigned char expandall_bits[] = {
0x00, 0x00, 0xfe, 0x03, 0x02, 0x02, 0x22, 0x1e, 0x22, 0x12, 0xfa, 0
+x72,
0x22, 0x52, 0x22, 0x52, 0x02, 0x52, 0x02, 0x52, 0xfe, 0x53, 0x08, 0
+x50,
0xf8, 0x5f, 0x20, 0x40, 0xe0, 0x7f, 0x00, 0x00};
',
'collapseall' => '#define collapseall_width 16
#define collapseall_height 16
static unsigned char collapseall_bits[] = {
0x00, 0x00, 0xfe, 0x03, 0x02, 0x02, 0x02, 0x1e, 0x02, 0x12, 0xfa, 0
+x72,
0x02, 0x52, 0x02, 0x52, 0x02, 0x52, 0x02, 0x52, 0xfe, 0x53, 0x08, 0
+x50,
0xf8, 0x5f, 0x20, 0x40, 0xe0, 0x7f, 0x00, 0x00};
',
);
# set options to default unless they have alreayd been set
foreach (keys %default_options) {
next if (/^browser$/);
unless (defined $_ && defined $options{$_} ) {
$options{$_} = $default_options{$_};
}
}
# parse options
use vars '$debug'; # debug mode
GetOptions("debug" => \$debug)
or die "Only supported option is -debug.\n";
######################################################################
+##########
# go
&initWindow;
&getInfo;
&buildTree;
MainLoop();
######################################################################
+##########
sub initWindow { $Window = MainWindow->new(-title => "Perlmonks Newest
+Nodes");
# add menubar
my $menu = $Window->Menu;
$Window->configure(-menu => $menu);
# build menubar
my $file_menu = $menu->cascade(-label => '~File',
-tearoff => 0);
my $action_menu = $menu->cascade(-label => '~Action',
-tearoff => 0);
my $options_menu = $menu->cascade(-label => '~Options',
-tearoff => 0);
my $debug_menu = $menu->cascade(-label => '~Debug',
-tearoff => 0) if ($debug);
# build individual menus
$file_menu->command (-label => 'Exit',
-underline => 1,
-command => sub { exit; });
$action_menu->command (-label => 'Mark Node Read',
-underline => 10,
-command => sub { &mark('read'); } );
$action_menu->command (-label => 'Mark Node Unread',
-underline => 10,
-command => sub { &mark('unread'); } );
$action_menu->command (-label => 'Mark Node New',
-underline => 10,
-command => sub { &mark('new'); } );
$action_menu->command (-label => 'Flag Node',
-underline => 1,
-command => sub { &mark('flag'); } );
$action_menu->separator();
$action_menu->command (-label => 'Mark Thread Read',
-underline => 5,
-command => sub { &markThread('read'); } );
$action_menu->command (-label => 'Mark Thread Unread',
-command => sub { &markThread('unread'); } );
$action_menu->command (-label => 'Mark Thread New',
-command => sub { &markThread('new'); } );
$action_menu->command (-label => 'Flag Thread',
-command => sub { &markThread('flag'); } );
$action_menu->separator();
$action_menu->command (-label => 'Mark All Read',
-underline => 5,
-command => sub { &markAllRead; } );
$action_menu->command (-label => 'Update Perlmonks All-read Ti
+me',
-underline => 7,
-command => sub { &markAllRead; $p->clear_nn; } );
$action_menu->separator();
$action_menu->command (-label => 'Expand All',
-underline => 0,
-command => sub { &expandAll; } );
$action_menu->command (-label => 'Collapse All',
-underline => 0,
-command => sub { &collapseAll; } );
$action_menu->separator();
$action_menu->command (-label => 'Update',
-command => sub { &getInfo; &buildTree; });
$options_menu->command(-label => 'Topnode Color',
-underline => 0,
-command => sub { &setColor('top'); } );
$options_menu->command(-label => 'Read Color',
-underline => 0,
-command => sub { &setColor('read'); } );
$options_menu->command(-label => 'Unread Color',
-underline => 0,
-command => sub { &setColor('unread'); } );
$options_menu->command(-label => 'New Color',
-underline => 0,
-command => sub { &setColor('new'); } );
$options_menu->command(-label => 'Flagged Color',
-underline => 0,
-command => sub { &setColor('flag'); } );
$options_menu->command(-label => 'Background Color',
-underline => 0,
-command => sub { &setBackground; } );
$options_menu->separator();
$options_menu->command(-label => 'Reset Colors to Default',
-command => sub { &resetColors; });
$options_menu->command(-label => 'Save Color Settings',
-underline => 0,
-command => sub { &saveColors; });
$options_menu->separator();
$options_menu->checkbutton(-label => 'Auto Mark Threads as R
+ead on Dbl-Click',
-onvalue => 1,
-offvalue => 0,
-indicatoron => 1,
-underline => 0,
-variable => \$options{auto_mark_read});
$options_menu->checkbutton(-label => 'Auto Launch Browser on
+ Next/Previous',
-onvalue => 1,
-offvalue => 0,
-indicatoron => 1,
-underline => 0,
-variable => \$options{auto_launch});
$options_menu->command(-label => 'Choose Browser',
-underline => 0,
-command => \&chooseBrowser);
# Only show debug menu in debug mode
if ($debug) {
$debug_menu->command (-label => 'Redraw Tree',
-command => sub { $tree->delete('all'); &getInfo;
+&buildTree; });
}
# create frames
my $uframe =$Window->Frame()->pack(-side => 'top',
-fill => 'both',
-expand => 1);
my $mframe =$Window->Frame()->pack(-side =>'top',
-fill => 'x');
my $bframe =$Window->Frame()->pack(-side =>'top',
-fill => 'x');
# tree
$tree = $uframe->Scrolled("Tree",
-width => 80,
-height => 5,
-background => "$options{background}",
-selectbackground => "$options{background}",
-itemtype => 'text',
-separator => '.',
-selectmode => 'single',
-relief => 'sunken',
-scrollbars => 'osoe',
-command => \&command,
)->pack(-side => 'top',
-fill => 'both',
-expand => 1);
# status bar
$statusbar = $bframe->Label(-text => "$status_idle",
-relief => 'sunken',
)->pack(-side => 'left',
-fill => 'x',
-expand => 1);
# button bitmaps
foreach (keys %bitmaps) { $Window->Bitmap($_,-data => $bitmaps{$_}
+); }
# buttons
my $btn_expandAll = $mframe->Button(-text => "Expand All
+",
-image => 'expandall',
-command => \&expandAll,
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_collapseAll = $mframe->Button(-text => "Collapse A
+ll",
-image => 'collapseall',
-command => \&collapseAll,
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_mark = $mframe->Button(-text => "Mark",
-image => 'mark',
-command => sub { &mark('read'); },
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_markThread = $mframe->Button(-text => "Mark Threa
+d",
-image => 'markthread',
-command => sub { &markThread('read'); },
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_markAllRead = $mframe->Button(-text => "Mark All R
+ead",
-image => 'markall',
-command => sub { &markAllRead; },
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_update = $mframe->Button(-text => "Update",
-image => 'update',
-command => sub { &getInfo; &buildTree; },
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_previous = $mframe->Button(-text => "Previous",
-image => 'previous',
-command => sub { &previousUnread; },
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
my $btn_next = $mframe->Button(-text => "Next",
-image => 'next',
-command => sub { &nextUnread; },
-height => 16,
-width => 16,
)->pack(-side => 'left',
-padx => 2,
-pady => 2);
# Button Balloons
my $balloon = $Window->Balloon;
$balloon->attach($btn_expandAll, -balloonmsg => 'Expand All Threa
+ds');
$balloon->attach($btn_collapseAll,-balloonmsg => 'Collapse All Thr
+eads');
$balloon->attach($btn_mark, -balloonmsg => 'Mark Node Read')
+;
$balloon->attach($btn_markThread, -balloonmsg => 'Mark Thread Read
+');
$balloon->attach($btn_markAllRead,-balloonmsg => 'Mark All Nodes R
+ead');
$balloon->attach($btn_update, -balloonmsg => 'Update from Perl
+Monks.org');
$balloon->attach($btn_previous, -balloonmsg => 'Previous Unread
+Node');
$balloon->attach($btn_next, -balloonmsg => 'Next Unread Node
+');
# define item styles for colorization
foreach (keys %options) {
next unless (/^color_/);
$styles{$_} = $tree->ItemStyle('text',
-stylename => "$_",
-foreground => "$options{$_}",
-selectforeground => "$options{$_}",
-background => "$options{background}",
-selectbackground => "$options{background}");
}
# key bindings
$Window->bind('<F5>',sub { &getInfo; &buildTree; });
}
######################################################################
+##########
sub status {
my $msg = shift;
unless ($msg) {
my $entryPath = 1;
my $unread = 0;
while ($tree->info('exists',$entryPath)) {
my $href = $tree->info('data',$entryPath);
if (defined $href) {
$unread++ unless ($p->is_read($tree->info('data',$entryPath)->
+{node_id}));
}
$entryPath = $tree->info('next',$entryPath);
}
$msg = "$status_idle ($unread unread)";
}
$statusbar->configure(-text => "$msg");
$statusbar->update;
}
######################################################################
+##########
sub getInfo {
&status("Getting info...");
unless (defined $p) {
$p = PerlMonks::NewestNodes->new();
$p->add_cookies;
}
$p->refresh_nn;
&status;
}
######################################################################
+##########
sub buildTree {
&status("Building tree...");
my $pos = 1;
foreach my $nodetype (keys %nodetypes) {
# if the top node doesn't exist in the tree, add it
unless ($tree->info('exists',$pos)) {
$tree->add($pos,
-text => "$nodetypes{$nodetype}",
-style => 'color_top');
}
$p->visit_threads("$nodetype",sub { &callback(@_,$pos); } );
if ($tree->info('children',$pos)) {
$tree->show('entry',$pos) if ($pos =~ /^\d+$/); # make sure to
+pnode is shown
if ($tree->getmode($pos) eq 'none') {
$tree->setmode($pos,'close');
$tree->close($pos);
}
} else {
$tree->hide('entry',$pos);
}
$pos++;
}
# set proper mode everywhere
my $entryPath = 1;
while ($tree->info('exists',$entryPath)) {
my $prevEntryPath = $entryPath;
$entryPath = $tree->info('next',$prevEntryPath);
next unless ($tree->getmode($prevEntryPath) eq 'none');
next unless ($tree->info('children',$prevEntryPath));
$tree->setmode($prevEntryPath,'close');
$tree->close($prevEntryPath);
}
&status;
}
sub callback {
my $href = shift;
my $parent = shift;
die "Internal hemmorage at callback!\n" unless ($href && $parent);
my $author = $p->{cache_nn}->{AUTHOR}->{ $href->{author_user} }->{
+content};
my $date = "$href->{createtime}";
# reformat date string -- this is a guess, don't know if it's righ
+t
$date =~ s/^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/$2\/$3\/$1 $
+4:$5:$6/;
my$item = "$href->{content} ($author) [$date]";
# check for existence of child before just adding it by checking i
+f
# any of the $parent's nodes have the same value for data as the $
+href
# we're trying to add
my $entryPath = 0;
foreach ($tree->info('children',$parent)) {
if ($tree->info('data',$_) eq $href) { $entryPath = $_; last; }
}
# unless the kid's already there, add it
unless ($entryPath) {
my $color = $p->is_read($href->{node_id}) ? 'color_read' : 'color_
+new';
$entryPath = $tree->addchild($parent,
-text => "$item",
-data => $href,
-style => $color);
$href->{entryPath} = $entryPath;
}
# if the kid's got kids, recurse
if (exists ($href->{kids})) {
foreach my $kid (@{$href->{kids}}) {
callback($kid,$entryPath);
}
}
}
######################################################################
+##########
sub command {
# invoked when user double-clicks an entry
my $entryPath = shift;
my $href = $tree->info('data',$entryPath);
return unless ($href);
$tree->configure(-selectforeground => $options{color_read});
unless ($^O =~ /MSWin32/i || defined $options{'browser'}) {
print STDERR "No browser defined\n";
print STDERR "Use Options->Choose browser menu to define one.\n";
return -1;
}
my $url = $perlmonksURL_id . $href->{node_id};
&status("Launch browser to \"$url\"!");
my $browser = $options{'browser'} || '';
if ($^O =~ /MSWin32/i) {
my $process;
$browser =~ s/\\/\\\\/g;
$browser =~ s/\"//g;
$browser =~ /\\(\S+)$/;
my $pgm = $1;
eval '
use Win32::Process;
Win32::Process::Create($process,
"$ENV{SYSTEMROOT}\\\\system32\\\\cm
+d.exe",
"cmd.exe /c start $url",
0,DETACHED_PROCESS,".") ||
printError("Unable to launch browser: " . Win32::FormatMessa
+ge(Win32::GetLastError()));
';
} else {
eval '
my $pid = fork;
$url =~ s/\s/+/g;
if ($pid == 0) {
exec "$browser $url";
}';
}
if ($@) { print STDERR "Error launching: $@\n"; }
# Mark read if auto_mark_read is set
&markThread('read',$entryPath) if ($options{'auto_mark_read'});
&status;
}
######################################################################
+##########
sub expandAll {
my $entryPath = 1;
while ($tree->info('exists',$entryPath)) {
$tree->open($entryPath);
$entryPath = $tree->info('next',$entryPath);
}
$tree->update; # forces scrollbar to update
}
######################################################################
+##########
sub collapseAll {
my $entryPath = 1;
while ($tree->info('exists',$entryPath)) {
$tree->close($entryPath);
$entryPath = $tree->info('next',$entryPath);
}
$tree->selectionClear;
$tree->update; # forces scrollbar to update
}
######################################################################
+##########
sub mark {
my $type = shift;
my @entryPaths = @_;
@_ = ();
push @entryPaths, $tree->info('selection') unless (@entryPaths);
return unless (@entryPaths);
&status("Marking nodes...");
my @topnodes = $tree->info('children');
foreach my $entryPath (@entryPaths) {
next if (grep /^$entryPath$/, @topnodes);
if ($type eq 'read') {
my $href = $tree->info('data',$entryPath);
$p->mark_read_nodes($href->{node_id}) if ($href);
$tree->entryconfigure($entryPath,
-style => 'color_read');
} elsif ($type eq 'unread') {
my $href = $tree->info('data',$entryPath);
$p->mark_unread_nodes($href->{node_id}) if ($href);
$tree->entryconfigure($entryPath,
-style => 'color_unread');
} else {
$tree->entryconfigure($entryPath,
-style => "color_$type");
}
}
&status;
}
######################################################################
+##########
sub markThread {
my $type = shift;
my @entryPaths = @_;
push @entryPaths, $tree->info('selection') unless (@entryPaths);
return unless (@entryPaths);
push @entryPaths, &getChildren(@entryPaths);
&mark($type,@entryPaths);
}
######################################################################
+##########
sub markAllRead {
&markThread('read',$tree->info('children'));
}
######################################################################
+##########
sub getChildren {
my @entryPaths = @_;
return unless (@entryPaths);
my @kids;
foreach my $entryPath (@entryPaths) {
push @kids, $tree->info('children',$entryPath);
push @kids, &getChildren($tree->info('children',$entryPath));
}
return @kids;
}
######################################################################
+##########
sub nextUnread {
my $entryPath = $tree->info('selection') || 1;
while ($entryPath = $tree->info('next',$entryPath)) {
last unless $entryPath;
my $href = $tree->info('data',$entryPath);
next unless ($href->{node_id});
unless ($p->is_read($href->{node_id})) {
# We found the next unread node, so show it!
&select($entryPath);
last;
}
}
}
######################################################################
+##########
sub previousUnread {
my $entryPath = $tree->info('selection');
unless ($entryPath) {
# We don't have a selection, so find the last entryPath
$entryPath = 1;
while (1) {
my $next = $tree->info('next',$entryPath);
last unless $next;
$entryPath = $next;
}
} else {
$entryPath = $tree->info('prev',$entryPath);
}
while ($entryPath) {
my $href = $tree->info('data',$entryPath);
if ($href->{node_id} && ! $p->is_read($href->{node_id})) {
# We found the next unread node, so show it!
&select($entryPath);
last;
}
$entryPath = $tree->info('prev',$entryPath);
}
}
######################################################################
+##########
sub select {
my $entryPath = shift;
return unless ($tree->info('exists',$entryPath));
my $parent = $entryPath;
$tree->open($parent) while ($parent = $tree->info('parent',$parent
+));
$tree->selectionClear;
$tree->see($entryPath);
$tree->selectionSet($entryPath);
$tree->update;
&command($entryPath) if ($options{'auto_launch'});
}
######################################################################
+##########
# Prompts the user to select the browser executable
sub chooseBrowser {
&status("Updating browser information...");
if (!$choosebrowser_w) {
$choosebrowser_w = $Window->Toplevel(-takefocus=>1,
-title => "Choose browser executable");
$choosebrowser_w->withdraw();
$choosebrowser_w->transient($Window);
$browserfield = $choosebrowser_w->LabEntry(-label => "Executab
+le:",
-width => 40,
-labelPack => [-side => 'left' ]
)->pack;
$choosebrowser_w->Button(-text => "Browse",
-command => sub { my $fsref = $choosebrowser_w->File
+Select;
my $file = $fsref->Show;
$browserfield->configure(-textvariable=>\$
+file);
}
)->pack(-side => 'left',
-padx => 5,
-pady => 2);
$choosebrowser_w->Button (-text => "Ok",
-command => \&chooseBrowser_ok
)->pack(-side => 'right',
-padx => 5,
-pady => 2);
$choosebrowser_w->Button(-text => "Cancel",
-command => sub { $choosebrowser_w->grabRelease;
$choosebrowser_w->withdraw;
}
)->pack(-side => 'right',
-padx => 5,
-pady => 2);
}
$browserfield->configure(-textvariable=>\$options{'browser'}) if (
+defined $options{'browser'});
$choosebrowser_w->Popup;
$browserfield->focus;
$choosebrowser_w->protocol('WM_DELETE_WINDOW',sub {;}); #handle wi
+ndow 'x' button
$choosebrowser_w->grabGlobal;
&status;
}
sub chooseBrowser_ok {
my $potential_browser = $browserfield->get;
$potential_browser =~ s/\//\\/g if ($^O =~ /Win32/i);
unless ($potential_browser) {
print STDERR "No browser specified. Nothing changed.\n";
$choosebrowser_w->grabRelease;
$choosebrowser_w->withdraw;
return;
}
if (! -e "$potential_browser") {
print STDERR "Could not locate browser executable.\n";
} else {
$options{'browser'} = $potential_browser;
}
$choosebrowser_w->grabRelease;
$choosebrowser_w->withdraw;
}
######################################################################
+##########
sub setColor {
my $type = shift;
my $color = $Window->chooseColor(-initialcolor => $options{"color_
+$type"},
-title => ucfirst($type) . ' Color');
return unless $color;
$styles{"color_$type"}->configure(-foreground => $color,
-selectforeground => $color);
}
######################################################################
+##########
sub setBackground {
my $color = $Window->chooseColor(-initialcolor => $tree->cget(-bg)
+,
-title => 'Background Color');
$tree->configure(-bg => $color);
foreach (keys %styles) {
$styles{$_}->configure(-background => $color,
-selectbackground => $color);
}
}
######################################################################
+##########
sub resetColors {
foreach (keys %default_options) {
next unless (/^color_/);
$styles{$_}->configure(-foreground => $default_options{$_},
-selectforeground => $default_options{$_},
-background => $default_options{background},
-selectbackground => $default_options{background},)
+;
$options{$_} = $default_options{$_};
}
$tree->configure(-bg => $default_options{'background'});
$options{'background'} = $default_options{'background'};
}
######################################################################
+##########
sub saveColors {
foreach (keys %styles) {
$options{$_} = $styles{$_}->cget(-foreground);
}
$options{'background'} = $tree->cget(-bg);
}
|
