Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!/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); }

In reply to Perl/Tk Newest Nodes Client by Shendal

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (3)
    As of 2019-07-21 09:33 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?
      If you were the first to set foot on the Moon, what would be your epigram?






      Results (7 votes). Check out past polls.

      Notices?