Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

comment on

( [id://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":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others pondering the Monastery: (6)
As of 2024-03-28 14:58 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found