Beefy Boxes and Bandwidth Generously Provided by pair Networks Frank
Just another Perl shrine
 
PerlMonks  

Perl/Tk Newest Nodes Client

by Shendal (Hermit)
on Sep 07, 2000 at 01:02 UTC ( #31325=sourcecode: print w/ replies, xml ) Need Help??

Category: PerlMonks.org Related Scripts
Author/Contact Info Shendal
Description: Uses zzamboni's PerlMonks.pm 2.0 to check newest nodes and put them in a graphical tree format.
Features:
- Tree format (expand/collapse)
- Colorization
- Launch browser by double clicking
- User preferences are saved
- Uses existing browser window, if available
#!/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);
}

Comment on Perl/Tk Newest Nodes Client
Download Code
RE: Perl/Tk Newest Nodes Client
by ZZamboni (Curate) on Sep 08, 2000 at 00:53 UTC
    This is just the kind of interface I had in mind when I wrote PerlMonks::NewestNodes, and the kind of interface I had been waiting for for a longe time. Thanks, Shendal! Shendal++

    I've been using it today for surfing PM, and it's very useful. A few suggestions I have (more like "requests for features"):

    • * Mark "read nodes" (the ones you double-click on) with a different color (a dim gray, maybe?) so that they can be distinguished from nodes you haven't read.
    • * If you do the above, have an option for having the whole subtree marked as read when you double-click on its top node (since, when you view a node, you can also read all of its replies on the same page).
    • Make it not "re-collapse" the whole tree when you hit refresh, only add the new nodes. I don't know how hard this is, since I'm not familiar with the Tk::Tree widget.
    • * Coupled with the above, mark "new nodes" (the ones that appeared in the last "refresh" with a different color.
    • When you reduce the window's width, the rightmost buttons start to disappear. I think it'd be better if all the buttons shrank proportionally, or if the status line shrank instead.
    • The "reviews" category of nodes refers to reviews in general (modules, books, etc.), so it may be more appropriately called "Reviews" instead of "Book Reviews".
    • Make it so that it's possible to collapse/expand a whole subtree in one click. For example, have it so that if you click on the +/- indicator with the middle button, the operation applies to all the subtrees of the current node.
    • Have an option for automatically refreshing periodically.
    The items I marked with "*" are the ones for which I believe I can add support in PerlMonks::NewestNodes (for example, being able to identify the "new nodes" from a flag in the node, similarly for "read nodes"). I'll be adding those things shortly.

    --ZZamboni

Re: Perl/Tk Newest Nodes Client
by epoptai (Curate) on Apr 30, 2001 at 02:30 UTC
    I borrowed the %nodetypes hash from this script for a CGI client and found that it didn't contain all types, some must have been added since it was written. The original contains 14, this 19:

    my %nodetypes = ( 'bookreview' => 'Book Reviews', 'categorized answer' => 'Categorized Answers', 'categorized question' => 'Categorized Questions', 'CUFP' => 'Cool Uses for Perl', 'modulereview' => 'Reviews', 'monkdiscuss' => 'Perlmonks Discussion', 'note' => 'Reply', 'obfuscated' => 'Obfuscated Perl', 'perlcraft' => 'Perl Craft', 'perlmeditation' => 'Meditations', 'perlnews' => 'Perl News', 'perltutorial' => 'Tutorials', 'perlquestion' => 'Seekers of Perl Wisdom', 'poem' => 'Poems', 'review' => 'Reviews', 'snippet' => 'Code Snippets', 'sourcecode' => 'Code Catacombs', 'tutorial' => 'Tutorials', 'user' => 'Users', );
      I believe you have tutorial listed twice...

      Greetz
      Beatnik
      ... Quidquid perl dictum sit, altum viditur.
        I looked around Tutorials and found two different nodetypes, 'perltutorial' and 'document' (but have never seen 'document' in newest nodes). Checking the nodetypes is labor intensive (get id from title, then lookup with node_id=37150&nodes=860,62782) so most were not.

        This list only reflects what was seen in newest nodes for a number of weeks. I understand there are many more nodetypes, most of which don't show up on newest nodes, but some that might. I can't say if 'tutorial' is a valid nodetype, but since its on the list and doesn't cause a problem am inclined to leave it (having also received some official verification of this list).

        Your vigilance is appreciated 8^}

        --
        Check out my Perlmonks Related Scripts like framechat, reputer, and xNN.

Re: Perl/Tk Newest Nodes Client
by BinBerliner (Novice) on May 31, 2001 at 19:11 UTC
    Help! While the Win32-GUI and TK chat clients work fine with the Perl installation on my machine, newest node unfortunately fails as follows:
    C:\test>perl newestnodes.pl Use of uninitialized value in concatenation (.) at C:/Perl/site/lib/Pe +rlMonks.pm line 41. Use of uninitialized value in concatenation (.) at newestnodes.pl line + 101. Use of uninitialized value in concatenation (.) at C:/Perl/site/lib/Pe +rlMonks.pm line 35. Use of uninitialized value in concatenation (.) at C:/Perl/site/lib/Pe +rlMonks.pm line 154. Use of uninitialized value in concatenation (.) at C:/Perl/site/lib/Pe +rlMonks.pm line 41. Could not find in at C:/Perl/site/lib/PerlMonks/NewestNodes.pm line 202
    Any ideas?
Re: Perl/Tk Newest Nodes Client
by pjf (Curate) on Oct 09, 2001 at 07:37 UTC
    Very nice! You get my vote when it finally refreshes. ;)

    If you don't mind feature requests, I'd love a "hide read threads" feature. If I've completely read a thread, chances are that I'm not interested in seeing it.

    Great program, exactly the sort of thing I've been looking for.

    Cheers,
    Paul

Re: Perl/Tk Newest Nodes Client
by pfaut (Priest) on Jan 05, 2003 at 16:37 UTC

    I just found this yesterday and installed it. Today, I got caught up on overnight posts in record time. This thing is great!

    I put together this little script and set it as my browser in the configuration. It passes url requests to a running Mozilla browser. I suppose it would work just as well with Netscape.

    #!/bin/sh /usr/local/mozilla/mozilla -remote "openURL(\"$1\")"
    --- print map { my ($m)=1<<hex($_)&11?' ':''; $m.=substr('AHJPacehklnorstu',hex($_),1) } split //,'2fde0abe76c36c914586c';

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (8)
As of 2014-04-18 00:30 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (460 votes), past polls