$VERSION = '0.18'; =pod =head1 NAME Adso.pl - A modern PerlMonks client, in Perl/Tk =head1 DESCRIPTION A multi-purpose PerlMonks client. Lets you keep up with PM actvity in real time. You know when you get new private messages, when new nodes get posted, when users come and go. Also lets you read and post in the Chatterbox. Includes a configurable alert mechanism, to notify you when messages containing any pattern come across the cb. It also has the ability to display RSS feeds (currently, demo only). Features (partial list): Selectable anonymous / login mode Selectable tickers PM-style shortcuts are recognized, and launch in your browser CB pre-loads its window with the content from [cbhistory] Pops up an alert window when your user-defined pattern is seen in the CB Also functions as a RSS news reader This script has been tested with ActiveState Perl build 808 (Perl 5.8.2), on both Windows 2000 and Linux (SuSE 9.1). It has no dependencies on any software not included in AS Perl 808. On other platforms, you may need to install some modules. =head1 AUTHOR /msg jdporter jdporter@CPAN.org =head1 HISTORY 0.18 s/Schlepper/Channel/g. (However, the method is still named 'schlep'.) s/DataDisplay/Viewer/g. This is part of a refactoring which moves the 'writeln' calls (and any 'clear' calls) to the Viewer class. It is now the Viewer's responsibility to decide what items get listed, how. You can now configure a window to use a channel after the channel has already been activated. Channel::RSS now knows how to handle RSS1/RDF vs RSS2/RSS0.9x automatically. No need to specify the key_by field at construct time. Just throw in a URL and it should "just work". All the Channel types manage data lists uniformly now. Now their only responsibility is to convert the datastructure into that uniform list format. Fixed a bug with link visibility. 0.17 Watchers are configured to watch different fields of the input records. The knowledge of this field set is in the Channel, naturally. Eliminated DataSource concrete classes; merged them into their corresponding Channel concrete subclasses. Now DataSource is only a base class. Note that DataSource now assumes it's being realized in a concrete Channel class, due to that its methods call things like $self->username. Merged the get() subs (from DataSource) into the schlep() subs; cleaned up the schlep() subs, changing the way some of them decide what to render. Now, when you create a new tab, it is raised immediately. ChatterBox re-horks the cbhistory each time it's turned on, not just the first time. When a channel is turned on, it doesn't start schlepping immediately; it has an initial delay (currently 1 sec). 0.16 fixed bug that prevents re-using a tab name. added scrollbars to text widgets. Tk app now shows busy cursor (hourglass) during schleps. Ctrl-A in a text widget now selects all (as it should). more pm shortcut schemes recognized: wp, lj, dict. Channel::RSS now uses an internal display list. (Other channels will follow suit.) To support this, Channels now want to know which field in the incoming records to key by, and (optionally) which to group by. These are specified to the constructor. fixed display formatting issues in rss and rn. 0.15 Changed UI to Viewer. Changed AppContext::Tk to AppContext::StandaloneTkNotebookApp. Moved a bunch of stuff from UI to AppContext (i.e. from Viewer::TkTabbedText to AppContext::StandaloneTkNotebookApp). Moved the Tk-specific stuff out of the main program into AppContext::StandaloneTkNotebookApp. Somewhere along the line we nixed the ability to specify your desired login level. Moved the "main program" into method main() of class Adso. Renamed the Channel implementation classes to reflect the fact that they're Viewer-neutral, to let the PM-specific ones reflect that fact in their names, and to not use acronyms. Moved the locus of knowledge of what class of DataSource each Channel class wants, into the Channel class itself. Moved the tab configure button(s) into the bottom of the tab page itself, rather than dinking with the mainwindow's menubar. Separated channel selection from talkbox management. in certain Entry widgets invokes 'OK'. 0.14 2005-08-19 Changed alerts to be configured on a per-channel basis, rather on a per-tab basis. (Or in source-code speak: Changed watchers to be configured on a per-channel basis, rather on a per-viewer basis.) Every DataSource now has its own UA, cookie jar, etc. (Used to be global for all DataSources. Not good!) Changed TkGui to AppContext::Tk. 0.13 2005-08-17 Bug fixes. Made Adso a (non-data) class. Also made a TkGui class to manage all the tk-app-specific context. 0.12 2005-08-15 You can create more than one talk box (sender channel) under a chatterbox; each has its own creds set. (There is now no benefit to setting creds on the chatterbox channel itself.) Each viewer (that is, tab) can be an output for EVERY channel instance. (This allows each data source to render in multiple windows.) So now channels and viewers are many-to-many. Channel config/control is separate from any viewer concerns. Channels are now listed on the "main" tab, each with a button that pops up a config dialog. Channel config/control and viewer config/control have been split into separate dialogs. 0.11 2004-09-02 Specified font size as 12, because on some systems, the default size for 'Times' is way too small. Changed text hiding to use the -elide property rather than the -state property. -state appears to be fairly new in Tk, and is missing even on some fairly recent environments. 0.10 2004-09-01 Added a status bar at the bottom of each ticker window. Currently its only use is to show the link target ("url") of any link when the pointer passes over it -- pretty much the way any web browser does it. This is good feedback now that links are displayed as text only, no "url" part. 0.9 2004-09-01 Links, as displayed, consist only of the text; the "url" part is hidden. That is, "[foo|bar]" shows only as "bar" (blue, underlined). This is designed to be easily togglable, but no Viewer control exists yet to do it. Text widgets now use 'Times' instead of the default (which is probably 'Courier', at least on Windows). In Chatterbox, we now take advantage of the id= tag which was recently added (by [pfaut], at my request) to the information in the [cbhistory] stream. This means we now do reliable dupe filtering when merging the [cbhistory] stream with the first fetch from the cb. Radio and check buttons now use standard background even when selected. 0.8 2004-08-25 Replaced the query URL for kobesearch. (Thanks to Randy Kobes for alerting me of the improvement.) =cut use strict; use warnings; ###################################### START of Adso class ########################################### { package Adso; # All functions in package Adso are CLASS METHODS! # there is no such thing as an Adso object (yet, anyway.) sub launch_url { my $pkg = shift; my $url = shift; if ( $^O =~ /Win32/ ) { require Win32; # for spawn my $pid; #### XXX configurable code: Win32::Spawn( 'C:\PROGRA~1\MOZILL~1\FIREFOX.EXE', qq(-url "$url"), $pid ); # Win32::Spawn( 'E:\PROGRA~1\MOZILL~1\FIREFOX.EXE', qq(-url "$url"), $pid ); } else { my $pid = fork; if ( ! defined $pid ) { warn "Fork failed - $!\n"; } elsif ( $pid ) { warn "Spawned $pid\n"; } else { exec qq( mozilla -remote "openurl($url,new-tab)" ); } } } sub appcontext_class { 'AppContext::StandaloneTkNotebookApp' } sub event_scheduler_class { 'EventScheduler::Tk' } sub watcher_class { 'Watcher::WatchCB_PopupTk' } my %all_viewers; my %all_channels; sub viewers # setter/getter { my( $self, $name, $obj ) = @_; defined $name or die; defined $obj and $all_viewers{$name} = $obj; $all_viewers{$name} } sub forget_viewer { my( $self, $dd ) = @_; delete $all_viewers{ ref $dd ? $dd->name : $dd }; } sub channels # setter/getter { my( $self, $s ) = @_; defined $s or return values %all_channels; ref $s ? ( $all_channels{$s->name} = $s ) # it's a channel; set it into the list : $all_channels{$s} # it's a name; retrieve that one from the list. } sub channel_names { keys %all_channels } my $event_scheduler; sub event_scheduler # setter/getter { my $self = shift; @_ and $event_scheduler = shift; $event_scheduler } my $app_context; # SINGLETON! sub app_context # setter/getter { my $self = shift; @_ and $app_context = shift; $app_context } my %monk2id; my %id2monk; sub remember_perlmonk_id { my( $self, $monk, $id ) = @_; if ( defined $monk && defined $id ) { $monk2id{$monk} = $id; $id2monk{$id} = $monk; } } sub id_of_perlmonk { my( $self, $monk ) = @_; $monk2id{$monk} } sub perlmonk_of_id { my( $self, $id ) = @_; $id2monk{$id} } sub _rss { my %args; $args{'name'} = shift; $args{'url'} = shift; $args{'group_by'} = shift if @_; new Channel::RSS %args } sub _rss_set { map { /^[^#]/ ? _rss( split ) : () } split /\n/, $_[0] } sub main { my $adso = shift; # probably just the pkg name. $adso->app_context( $adso->appcontext_class->new ); $adso->channels($_) for Channel::PerlMonks::InBox->new(), Channel::PerlMonks::OtherUsers->new(), Channel::PerlMonks::UserNodes->new(), Channel::PerlMonks::RecentNodes->new(), Channel::PerlMonks::ChatterBox->new(), #Channel::POP->new( host => 'pop.your.isp', username => 'you', password => 'foo', ), _rss_set( <watcher( $adso->watcher_class->new( name => $_->name." watcher", fields => $_->watchable_fields, ) ) for $adso->channels; $adso->app_context->add_channel_configure_command($_) for sort { $a-> name cmp $b->name } $adso->channels; $adso->event_scheduler( $adso->event_scheduler_class->new ); $adso->app_context->run; } } ###################################### END of Adso class ############################################# ###################################### START EventScheduler classes ######################################### { package EventScheduler; } { package EventScheduler::Tk; use base 'EventScheduler'; use Tk; sub new { my $pkg = shift; my $mw = Adso->app_context->mw; # presumes it's some kind of Tk AppContext... bless { mw => $mw }, $pkg } sub after # returns timer ID, which can be passed to afterCancel. { my( $self, $wait_secs, $handler ) = @_; $self->{'mw'}->after( $wait_secs * 1000, $handler ) } sub afterCancel { my( $self, $id ) = @_; $self->{'mw'}->afterCancel( $id ); } } ###################################### END EventScheduler classes ########################################### ###################################### START of DataSource classes ########################################## { { package DataSource; # base class. In fact, it's HTTP specific. Which is why POP3 doesn't use one. use LWP::UserAgent; use HTTP::Cookies; use XML::Simple; use Data::Dumper; use Carp; # utility method, used in some/all DataSource subclasses: sub force_arrayref { my( $self, $ar ) = @_; defined $ar or return []; ref($ar) && $ar =~ /ARRAY/ ? $ar : [ $ar ] } sub ua { my $self = shift; unless ( $self->{'ds.user_agent'} ) # initialize { $self->{'ds.user_agent'} = LWP::UserAgent->new( agent => 'Adso/1.0', ); $self->{'ds.user_agent'}->env_proxy; } $self->{'ds.user_agent'} } sub cookie_jar { my $self = shift; unless ( $self->{'ds.cookie_jar'} ) # initialize { $self->{'ds.cookie_jar'} = HTTP::Cookies->new(); } $self->{'ds.cookie_jar'} } sub channel { my $this_ds = shift; @_ and $this_ds->{'channel'} = shift; $this_ds->{'channel'} } sub get_datastructure { my $this_ds = shift; # must have a 'url' data member my $url = $this_ds->url; $this_ds->{'debug_url'} and print "$url\n"; $this_ds->{'response'} = $this_ds->ua->get( $url ); unless ( $this_ds->{'response'}->is_success ) { warn "Error fetching XML from web site '$url'\n" . $this_ds->{'response'}->status_line; return(); } my $xml = $this_ds->{'response'}->content; unless ( $xml =~ /\S/ ) { warn "HTTP success, but returned no content!"; return(); } $this_ds->{'debug_xml'} and print "\n################ XML (initial chunk): ######################\n", substr($xml,0,200), "\n\n################# (final chunk): ############################\n", substr($xml,-200), "\n\n########################### END #############################\n"; my $struct = XMLin( $xml ); unless ( $struct ) { warn "Failed to convert XML stream to data structure!"; return(); } $this_ds->{'debug_ds'} and print Dumper $struct; $struct } sub url # overridable { my $this_ds = shift; # must have a 'url' data member $this_ds->{'url'} or croak "Missing required data member 'url'"; } sub get_login_cookie { my $self = shift; $self->username && $self->password or croak "Error - can't log in without login info!"; my %args = ( op => 'login', node_id => 227820, displaytype => 'xml', user => $self->username, passwd => $self->password, ); $self->{'request'} = HTTP::Request->new( GET => "http://perlmonks.org/index.pl?" . join '&', map { "$_=$args{$_}" } keys %args ); #warn "About to send request:\n", $self->{'request'}->as_string, "\n"; $self->{'response'} = $self->ua->request( $self->{'request'} ); #warn "Received response:\n", $self->{'response'}->as_string, "\n"; my $before = $self->cookie_jar->as_string; $self->cookie_jar->extract_cookies( $self->{'response'} ); my $after = $self->cookie_jar->as_string; if ( $before eq $after ) { delete $self->{'ds.cookie_jar'}; die "Error logging in!"; } #warn "Extracted cookies:\n", $self->cookie_jar->as_string, "\n"; $self->{'logged_in'} = 1; } sub send_perlmonks_message # NOT meant to be overridden! { my $self = shift; $self->username && $self->password or croak "Error - can't send message without login info!"; my %args = ( op => 'message', node_id => 227820, displaytype => 'raw', ); $args{'message'} = shift; $args{'message'} =~ s/(.)/ sprintf "%%%02X", ord($1) /ge; # escape EVERYTHING. $args{'message'} gt '' or return(); $self->{'logged_in'} or $self->get_login_cookie; $self->{'request'} = HTTP::Request->new( POST => "http://perlmonks.org/index.pl" ); $self->{'request'}->content_type( 'application/x-www-form-urlencoded' ); $self->{'request'}->content( join '&', map { "$_=$args{$_}" } keys %args ); $self->cookie_jar->add_cookie_header( $self->{'request'} ); warn "\nSending PerlMonks Message:\n", $self->{'request'}->as_string, "\n"; $self->{'response'} = $self->ua->request( $self->{'request'} ); my $content = $self->{'response'}->as_string; $content =~ /Chatter accepted/ or warn("Error:\n$content\n"), return; #warn "Received response:\n$content\n"; $content } } } ###################################### END of DataSource classes ############################################ ###################################### START of Viewer classes ######################################### { # Conceptually, a "Viewer" encapsulates an input/output mechanism for channel content/interaction. # In a windowing/gui application, a Viewer could be a scrolling Text widget. # In a textmode/console application, a Viewer could be a wrapper for the console itself. # In a web server application, a Viewer could be a web page/form. package Viewer; use URI::Escape; my %pm_shortcuts = ( http => sub { my $x = shift; "http://$x" }, id => sub { my $x = shift; "http://perlmonks.org/index.pl?node_id=$x" }, pad => sub { my $x = shift; "http://perlmonks.org/index.pl?node_id=108949;user=$x" }, lucky => sub { my $x = shift; $x = uri_escape(qq("$x")); "http://www.google.com/search?btnI=I&q=$x" }, google => sub { my $x = shift; $x = uri_escape(qq("$x")); "http://www.google.com/search?q=$x" }, cpan => sub { my $x = shift; $x = uri_escape(qq("$x")); "http://search.cpan.org/search?mode=module&query=$x" }, doc => sub { my $x = shift; $x = uri_escape($x); $x =~ /^perl/ ? "http://www.perldoc.com/perl5.8.0/pod/$x.html" : "http://www.perldoc.com/perl5.8.0/pod/func/$x.html" }, perldoc => sub { my $x = shift; $x = uri_escape($x); "http://www.perldoc.com/cgi-bin/htsearch?&words=$x" }, kobes => sub { my $x = shift; $x = uri_escape(qq("$x")); "http://cpan.uwinnipeg.ca/search?mode=dist&query=$x" }, kobe => sub { my $x = shift; $x = uri_escape(qq("$x")); "http://cpan.uwinnipeg.ca/search?mode=dist&query=$x" }, isbn => sub { my $x = shift; $x = uri_escape(qq("$x")); "http://isbn.nu/$x" }, jargon => sub { my $x = shift; $x = uri_escape(qq("$x")); #"http://www.science.uva.nl/cng/search/htsearch.CGI?words=$x&restrict=%2F%7Emes%2Fjargon%2F" "http://www.google.com/search?hl=en&ie=UTF-8&q=$x+site%3Acatb.org+up+home+prev+next&btnI=I" }, dict => sub { my $x = shift; # should escape? "http://www.m-w.com/cgi-bin/dictionary?book=Dictionary&va=$x" }, lj => sub { my $x = shift; "http://livejournal.com/users/$x" }, wp => sub { my $x = shift; "http://en.wikipedia.org/wiki/$x" }, ); sub substitute_shortcuts { my( $self, $link_target ) = @_; my( $scheme, $addr ) = split m#://#, $link_target; $pm_shortcuts{$scheme} ? $pm_shortcuts{$scheme}->( $addr ) : "http://perlmonks.org/index.pl?node=$link_target" } sub name { $_[0]{'name'} } sub add_channel { my( $this_viewer, @chan ) = @_; for my $chan ( @chan ) { # skip it if it's already been added. unless ( $this_viewer->{'channels'}{$chan} ) { $this_viewer->{'channels'}{$chan} = $chan; $chan->add_viewer( $this_viewer ); $this_viewer->channel_updated($chan); $this_viewer->set_changes_flag(1); } } $this_viewer } sub remove_channel { my( $this_viewer, @chan ) = @_; for my $chan ( @chan ) { if ( $this_viewer->{'channels'}{$chan} ) { #$chan->stop; $chan->remove_viewer($this_viewer); delete $this_viewer->{'channels'}{$chan}; } } $this_viewer } sub channels { my $this_viewer = shift; values %{ $this_viewer->{'channels'} || {} } } sub get_config { my $this_viewer = shift; my %chan = map { ( $_->name => 1 ) } $this_viewer->channels; { name => $this_viewer->name, links_visible => $this_viewer->link_target_visibility, channels => \%chan, } } sub edit_channel_set { my $self = shift; Adso->app_context->edit_viewer_channels( $self->get_config, $self ); } } { # ostensibly realizes a theoretical parent class Viewer::SubmissionEntry... package Viewer::TkSubmissionEntry; use base 'Viewer'; use Tk; sub new { my $pkg = shift; # required args: channel (Channel obj), entry (Entry widget) my %args = @_; $args{'entry'} or die "Error - missing required 'entry' - an Entry widget"; $args{'channel'} or die "Error - missing required 'channel' - a Channel object"; my $self = bless { %args }, $pkg; $self->{'entry'}->bind( '' => sub { $self->{'channel'}->schlep; } ); $self } sub get { my $self = shift; $self->{'entry'}->get } sub set { my $self = shift; my $text = shift; $self->{'entry'}->delete( '0', 'end' ); $self->{'entry'}->insert( '0', $text ); } sub clear { my $self = shift; $self->{'entry'}->delete( '0', 'end' ); $self } } { package Viewer::TkTabbedText; use base 'Viewer'; use Tk::ROText; use Tk::Font; # note that in the case of this Viewer class, the instance's name is identical to the name of its tab. # required args: name (str); gui (so far, only a AppContext::Tk object) sub new { my $pkg = shift; my $name = shift; my %args = @_; defined $name or die "Error - Missing required parameter (name) in $pkg new()"; my $self = bless { link_targets_hidden => 1, %args, name => $name, }, $pkg; $self->{'tab_frame'} = Adso->app_context->realize_viewer( $self->name ); $self->{'tab_button_frame'} = $self->{'tab_frame'}->Frame->pack( -side => 'bottom' ); $self->{'tab_main_frame'} = $self->{'tab_frame'}->Frame( -borderwidth => 2, -relief => 'sunken' )->pack( -expand => 1, -fill => 'both' ); $self->{'bottom_widget'} = $self->{'text'} = $self->{'tab_main_frame'}->Scrolled( 'ROText', -scrollbars => 'osoe', -wrap => 'word', -font => $self->{'tab_main_frame'}->Font( -family => 'Times', -size => 12, ) )->pack( -side => 'bottom', -expand => 1, -fill => 'both' ); $self->{'text'}->bind( '' => sub { $self->select_all_text } ); $self->{'text'}->bind( '' => sub { $self->select_all_text } ); $self->{'tab_button_frame'}->Button( -text => "Channels", -command => sub { $self->edit_channel_set; } )->grid( -row => 0, -column => 0, -padx => 20, -pady => 2 ); $self->{'tab_button_frame'}->Button( -text => "Add Talkbox", -command => sub { $self->add_talkbox } )->grid( -row => 0, -column => 1, -padx => 20, -pady => 2 ); $self->{'tab_button_frame'}->Button( -text => "Close Tab", -command => sub { Adso->app_context->destroy_viewer($self); } )->grid( -row => 0, -column => 2, -padx => 20, -pady => 2 ); $self->{'statusbar'} = $self->add_widget( sub { $_[0]->Label( -anchor => 'nw', -justify => 'left', ) } ); # raise the newly created tab! Adso->app_context->activate_viewer( $self->name ); $self } sub select_all_text { $_[0]->{'text'}->selectAll } sub kill { my $self = shift; $self->remove_channel($_) for $self->channels; Adso->app_context->delete_notebook_tab( $self->name ); } # add_widget stacks new widgets up from the bottom in the tab window. sub add_widget { my( $self, $creator_cb ) = @_; my $w = $creator_cb->( $self->{'tab_main_frame'} ); # pass the parent, get the child. $w->pack( -side => 'bottom', -before => $self->{'bottom_widget'}, -expand => 0, -fill => 'x', ); $self->{'bottom_widget'} = $w; } sub set_status { my( $self, $status_msg ) = @_; $self->{'statusbar'}->configure( -text => $status_msg ); } sub set_changes_flag { my( $self, $state ) = @_; my $ch = $state ? '*' : ' '; Adso->app_context->change_notebook_tab_label( $self->name, sub { s/.$/$ch/ } ); } sub clear { my $self = shift; $self->{'text'}->delete( '1.0', 'end' ); $self } my $shortcut_tag_name = 't000000'; sub writeln { my( $self, $string ) = @_; my $Text = $self->{'text'}; $Text->markSet( insert => 'end' ); my @p = split /\[(.*?)\]/, $string; for my $pi ( 0 .. $#p ) { if ( $pi & 1 ) # odd = shortcut { my $shortcut_rawtext = $p[$pi]; my $start_index = $Text->index( 'insert' ); $Text->insert( insert => $p[$pi] ); my $end_index = $Text->index( 'insert' ); my $link_tag_name = ++$shortcut_tag_name; $Text->tagAdd( $link_tag_name, $start_index, $end_index ); $Text->tagConfigure( $link_tag_name, -foreground => 'blue', -underline => 1 ); my( $link_target, $link_text ); if ( $shortcut_rawtext =~ /\|/ ) { ( $link_target, $link_text ) = ( $`, $' ); # create a tag that covers just the target (and the bar) ( my $subtag_end = $start_index ) =~ s/(\d+)$/ $1 + length($link_target) + 1 /e; my $target_tag_name = ++$shortcut_tag_name; $Text->tagAdd( $target_tag_name, $start_index, $subtag_end ); my $elide = ! $self->link_target_visibility; warn "printing a link with elide => $elide\n"; $Text->tagConfigure( $target_tag_name, -elide => $elide ); $self->add_link_target_tag( $target_tag_name ); } else { $link_target = $link_text = $shortcut_rawtext; } Adso->id_of_perlmonk($link_target) and $link_target = "id://" . Adso->id_of_perlmonk($link_target); my $url = $self->substitute_shortcuts( $link_target ); $Text->tagBind( $link_tag_name, '' => sub { Adso->launch_url( $url ); } ); $Text->tagBind( $link_tag_name, '' => sub { $self->set_status($link_target); } ); $Text->tagBind( $link_tag_name, '' => sub { $self->set_status(''); } ); } else # even = plain text { $Text->insert( insert => $p[$pi] ); } $Text->see( 'end' ); } $self } sub add_link_target_tag { my( $self, $tagname ) = @_; $self->{'link_target_tags'}{$tagname}++; } sub link_target_visibility { my( $self, $visible ) = @_; if ( defined $visible ) { my $Text = $self->{'text'}; $self->{'link_targets_hidden'} = $visible ? 0 : 1; while ( my( $tagname, $v ) = each %{ $self->{'link_target_tags'} } ) { $Text->tagConfigure( $tagname, -elide => $self->{'link_targets_hidden'} ); } } ! $self->{'link_targets_hidden'} } sub set_config { my( $this_viewer, $config ) = @_; my $old_config = $this_viewer->get_config; for my $chan_name ( keys %{ $config->{'channels'} } ) { if ( $config->{'channels'}{$chan_name} ) # to be active { unless ( $old_config->{'channels'}{$chan_name} ) { $this_viewer->add_channel( Adso->channels($chan_name) ); } } else # to be inactive { if ( $old_config->{'channels'}{$chan_name} ) { $this_viewer->remove_channel( Adso->channels($chan_name) ); } } } $this_viewer->link_target_visibility( $config->{'links_visible'} ); for my $talkbox_username ( keys %{ $config->{'talkboxes'} } ) { unless ( $old_config->{'talkboxes'}{$talkbox_username} ) { # } } }; sub show_chat_creds_editor { my $self = shift; my $channel = shift; # since there could be more than one in the caller my $callback = shift; ref($callback) eq 'CODE' or $callback = sub { $channel->creds(@_); }; my $dlg = Adso->app_context->create_dialog; $dlg->title("Message Sender Credentials"); my $button_fr = $dlg->Frame->pack( -side => 'bottom' ); my $OK_button = $button_fr->Button( -text => "OK", -command => sub { $dlg->destroy; $callback->( @{ $self->{'tmp.creds'} } ); @{ $self->{'tmp.creds'} } = (); } )->grid( -row => 0, -column => 0 ); $button_fr->Button( -text => "Cancel", -command => sub { $dlg->destroy; } )->grid( -row => 0, -column => 1 ); my $login_fr = $dlg->Frame()->pack( -side => 'bottom' ); my $login_fr2 = $login_fr->LabFrame( -label => 'Login Creds', -labelside => 'acrosstop' )->pack( -side => 'left' ); $self->{'tmp.creds'} = ['','']; my $fr2a = $login_fr2->Frame->pack; $fr2a->Label( -text => 'username:' )->pack( -side => 'left' ); my $username_entry = $fr2a->Entry( -textvariable => \( $self->{'tmp.creds'}[0] ) )->pack( -side => 'left' ); my $fr2b = $login_fr2->Frame->pack; $fr2b->Label( -text => 'password:' )->pack( -side => 'left' ); my $password_entry = $fr2b->Entry( -textvariable => \( $self->{'tmp.creds'}[1] ), -show => '*' )->pack( -side => 'left' ); $username_entry->focus; $username_entry->bind( '' => sub { $OK_button->invoke } ); $password_entry->bind( '' => sub { $OK_button->invoke } ); $dlg->grab; } # add a talk box below the main display. # note that this creates its own private channel! sub add_talkbox { my $this_viewer = shift; my $msgsend_channel = Channel::PerlMonks::MessageSender->new; $this_viewer->show_chat_creds_editor( $msgsend_channel, sub { $msgsend_channel->creds( @_ ); $this_viewer->add_widget( sub { my $parent = shift; my $fr = $parent->Frame; $fr->Label( -text => 'Send message as '.$msgsend_channel->username.':' )->pack( -side => 'left' ); $msgsend_channel->add_viewer( Viewer::TkSubmissionEntry->new( channel => $msgsend_channel, entry => $fr->Entry->pack( -fill => 'x', -side => 'left', -expand => 1 ), ) ); $fr } ); } ); } # update this one viewer from all its channels sub refresh { my $self = shift; # punt: $self->channel_updated($_) for $self->channels; } # refresh myself for one changed channel sub channel_updated { my( $this_viewer, $channel ) = @_; warn "viewer ".$this_viewer->name." updating from channel ".$channel->name."\n"; if ( $channel->updating_style eq 'add_only' ) { # simply append the new items on the display, sorted by key (string-wise). # go get the 'new_items' for my $id ( sort keys %{ $channel->{'new_items'} } ) # hashref. key=id, val=msg_struct(hashref) { $this_viewer->writeln( $channel->{'new_items'}{$id}{'rendered'} . "\n" ); } } elsif ( $channel->updating_style eq 'add_and_remove' ) { $this_viewer->clear; if ( keys %{ $channel->{'items'} } ) { $this_viewer->writeln( "Previously in ".$channel->name.":\n" ); for my $id ( sort keys %{ $channel->{'items'} } ) { $this_viewer->writeln( $channel->{'items'}{$id}{'rendered'} . " " ); } if ( %{ $channel->{'new_items'} } ) { $this_viewer->writeln( "\n\n" ); } } if ( %{ $channel->{'new_items'} } ) { $this_viewer->writeln( "New in ".$channel->name.":\n" ); for my $id ( sort keys %{ $channel->{'new_items'} } ) { $this_viewer->writeln( $channel->{'new_items'}{$id}{'rendered'} . " " ); } } } } } # end Viewer::TkTabbedText; ###################################### END of Viewer classes #################################################### ###################################### START of Watcher classes ############################################# { package Watcher; # caller should give at least these named fields on construct: # name = string # fields = array(ref) of strings sub new { my( $pkg, %args ) = @_; $args{'name'} or die "$pkg->new : missing required arg 'name' - string"; $args{'fields'} or die "$pkg->new : missing required arg 'fields' - array(ref) of strings"; bless { hits => [], %args, }, $pkg } sub regex { my $self = shift; @_ and warn "Setting watch on $_[0]\n"; @_ and $self->{'regex'} = shift; $self->{'regex'} } # pass a list of items to scan. each is hashref - flat data structure. sub watch { my $self = shift; #warn "Watching /$self->{'regex'}/, ".scalar(@_)." lines.\n"; my $re = $self->{'regex'} or return(); @{$self->{'hits'}} = map /($re)/, map join( "\0", @{$_}{ @{ $self->{'fields'} } } ), @_; @{$self->{'hits'}} and $self->notify_watch_hit; } sub notify_watch_hit { # no-op? or exception? } } { package Watcher::WatchCB_PopupTk; use base 'Watcher'; sub notify_watch_hit { my $self = shift; my $msg = join "\n\t", $self->{'name'}." hit the following strings:", @{ $self->{'hits'} }; unless ( $self->{'alert_tl'} ) { my $dlg = Adso->app_context->create_dialog; $dlg->title( $self->{'name'} . " Alert!"); $dlg->focusmodel('active'); $dlg->protocol( WM_DELETE_WINDOW => sub { $dlg->withdraw } ); $dlg->OnDestroy( sub { warn "\ndestroying toplevel!\n\n" } ); my $fr = $dlg->Frame ->pack( -expand => 1, -fill => 'both' ); $fr->Label( -bitmap => 'warning', ) ->pack( -side => 'left', -padx => 20, -pady => 20, ); $self->{'alert_lbl'} = $fr->Label( -anchor => 'nw', -justify => 'left' ) ->pack( -side => 'left', -expand => 1, -fill => 'both', -padx => 20, -pady => 20 ); $self->{'alert_tl'} = $dlg; } $self->{'alert_lbl'}->configure( -text => $msg ); $self->{'alert_tl'}->deiconify; $self->{'alert_tl'}->raise; $self->{'alert_tl'}->focus; Adso->event_scheduler->after( 10, sub { $self->{'alert_tl'}->withdraw } ); } } ###################################### END of Watcher classes ############################################### ###################################### START of Channel classes ########################################### { # an unused channel has an undef (or non-existent) 'viewer' member. { package Channel; use Carp; sub new { my $pkg = shift; bless { items => {}, @_ }, $pkg } # use the object's key_by field. # returns the number of items finally in 'new_items' sub collect_newA { my( $self, $source_ar ) = @_; defined $source_ar or croak "missing arg"; # but if it's not an array, wrap it in one. NOT FATAL! ref($source_ar) && $source_ar =~ /ARRAY/ or $source_ar = [ $source_ar ]; my $old_hr = $self->{'items'} or die; my $new_hr = $self->{'new_items'} or die; my $key_field = $self->{'key_by'} or die; for my $it ( @$source_ar ) { my $k = $it->{$key_field}; exists $new_hr->{$k} || exists $old_hr->{$k} and next; # add new item: $new_hr->{$k} = $it; if ( $self->{'normalizable_time_fields'} ) { for my $ntf ( @{ $self->{'normalizable_time_fields'} } ) { $it->{$ntf} =~ s/(....)(..)(..)(..)(..)(..)/$1-$2-$3 $4:$5:$6/; } } if ( $self->{'monkid_vector'} ) { my( $f1, $f2 ) = @{ $self->{'monkid_vector'} }; Adso->remember_perlmonk_id( $it->{$f1}, $it->{$f2} ); } $it->{'title'} && $it->{'link'} and $self->normalize_description($it); } scalar( keys %{ $self->{'new_items'} } ) } # use the hash's keys. # returns the number of items finally in 'new_items' sub collect_newH { my( $self, $source_hr ) = @_; my $n = keys %$source_hr; # to reset the iterator, and force an exception on wrong arg type. my $old_hr = $self->{'items'} or die; my $new_hr = $self->{'new_items'} or die; my $key_field = $self->{'key_by'} or die; while ( my($k,$v) = each %$source_hr ) { exists $new_hr->{$k} || exists $old_hr->{$k} or $new_hr->{$k} = $v; } # ensure the `key_by` field exists within each record, not just # as the key above the record: for ( keys %$new_hr ) { exists $new_hr->{$_}{$key_field} or $new_hr->{$_}{$key_field} = $_; } scalar( keys %{ $self->{'new_items'} } ) } sub name { $_[0]{'name'} } sub watchable_fields { die "@_ - watchable_fields not overridden!" } sub updating_style { 'add_only' } # the default sub on_connect_viewer { # in the base class, a no-op. } sub add_viewer { my( $this_chan, @viewers ) = @_; # skip it if it's already been added here. for my $viewer ( grep { ! $this_chan->{'viewer'}{$_} } @viewers ) { $this_chan->{'viewer'}{$viewer} = $viewer; $this_chan->on_connect_viewer($viewer); } $this_chan } sub remove_viewer { my( $this_chan, @viewers ) = @_; delete $this_chan->{'viewer'}{$_} for @viewers; $this_chan } sub viewers # returns a list of object references (Viewer objects) { my $this_chan = shift; my @dd = values %{ $this_chan->{'viewer'} || {} }; wantarray ? @dd : $dd[0] } sub username { my $self = shift; #warn "$self.username <= (@_)\n"; @_ and $self->{'username'} = shift; $self->{'username'} } sub password { my $self = shift; #warn "$self.password <= (@_)\n"; @_ and $self->{'password'} = shift; $self->{'password'} } sub creds { my $self = shift; if ( @_ == 2 ) { ( $self->{'username'}, $self->{'password'} ) = @_; } elsif ( @_ == 4 ) { my %h = @_; ( $self->{'username'}, $self->{'password'} ) = ( $h{'username'}, $h{'password'} ); } elsif ( @_ == 1 and ref($_[0]) ) { my($hr) = @_; ( $self->{'username'}, $self->{'password'} ) = ( $hr->{'username'}, $hr->{'password'} ); } elsif ( @_ ) { local $" = ', '; carp "ERROR: channel.creds( @_ ) invalid call!"; } ( $self->{'username'}, $self->{'password'} ) } sub watcher { my $self = shift; @_ and $self->{'watcher'} = shift; $self->{'watcher'} } sub interval { my $self = shift; @_ and $self->{'interval'} = shift; $self->{'interval'} } sub schlep # special: base class. { my $self = shift; die "Error! $self does not define the 'schlep' method!"; } sub recurrent_schlep { my $self = shift; Adso->app_context->busy_up; $self->schlep; Adso->app_context->busy_down; my $int = $self->interval + int(rand 2); # occasionally add 1 warn $self->name,": rescheduled for t+$int sec.\n"; $self->{'schedule_id'} = Adso->event_scheduler->after( $int, sub { $self->recurrent_schlep } ); } sub pre_schlep # this could be moved down, if an intermediate class is introduced. { my $self = shift; # copy previous new into old: $self->{'items'}{$_} = $self->{'new_items'}{$_} for keys %{ $self->{'new_items'} }; # clear new: $self->{'new_items'} = {}; $self->{'ds'} = $self->get_datastructure; $self->{'info'} = $self->{'ds'}{'INFO'} if $self->{'ds'}{'INFO'}; $self->{'info'} = $self->{'ds'}{'info'} if $self->{'ds'}{'info'}; # update our polling interval defined $self->{'info'}{'min_poll_seconds'} && $self->{'interval'} != $self->{'info'}{'min_poll_seconds'} and $self->{'interval'} = $self->{'info'}{'min_poll_seconds'}; } sub post_schlep { my $self = shift; $_->{'rendered'} = $self->render_item($_) for values %{ $self->{'new_items'} }; my $changes = keys %{ $self->{'new_items'} }; $_->channel_updated($self) for $self->viewers; $_->set_changes_flag($changes) for $self->viewers; $self->watcher and $self->watcher->watch( values %{ $self->{'new_items'} } ); } sub running { $_[0]{'schedule_id'} ? 1 : 0 } sub start { my( $self, $wait ) = @_; $self->{'schedule_id'} and return $self; $self->can('on_start') and $self->on_start; if ( defined $wait and $wait > 0 ) { warn $self->name,": starting recurrent schlep after $wait seconds...\n"; $self->{'schedule_id'} = Adso->event_scheduler->after( $wait, sub { $self->recurrent_schlep } ); } else { warn $self->name,": starting recurrent schlep immediately...\n"; $self->recurrent_schlep; } $self } sub stop { my $self = shift; if ( $self->{'schedule_id'} ) { warn $self->name,": stopping.\n"; Adso->event_scheduler->afterCancel( $self->{'schedule_id'} ); $self->{'schedule_id'} = undef; } $self } sub set_state { my( $self, $act ) = @_; $act ? $self->start(1) : $self->stop } sub get_config { my $self = shift; { name => $self->name, username => $self->username, password => $self->password, interval => $self->interval, running => $self->running, url => $self->url, 'watcher.regex' => $self->watcher ? $self->watcher->regex : undef, } } # creates a data structure and passes it to edit_channel_config; # set_config receives this exact same data structure. sub edit_config { my $self = shift; Adso->app_context->edit_channel_config( $self->get_config, $self ); } sub set_config { my( $self, $config ) = @_; $self->creds($config); $self->interval($config->{'interval'}); $self->set_state($config->{'running'}); $self->watcher->regex($config->{'watcher.regex'}) if defined $config->{'watcher.regex'}; } sub normalize_description { my( $self, $item ) = @_; $item->{'description'} = '' unless defined $item->{'description'}; # should only happen when it's an empty hash, and that happens when the description element is empty: $item->{'description'} = '' if ref $item->{'description'}; $item->{'description'} =~ s/\s+/ /g; $item->{'description'} =~ s/^ //g; $item->{'description'} =~ s/ $//g; } } { package Channel::PerlMonks::MessageSender; # CbMessageSender to SubmissionEntry use base 'Channel'; use base 'DataSource'; # when calling new(), # 'viewer' should be a SubmissionEntry Viewer. sub watchable_fields { [] } # not used sub remove_viewer { my $self = shift; die "ERROR! PerlMonks::MessageSender.remove_viewer not allowed!"; } sub schlep # special: MessageSender { my $self = shift; eval { my $msg = $self->viewers->get; #warn "Sending msg '$msg' \n"; my $response = $self->send_perlmonks_message( $msg ); $response =~ s/\s+/ /g; #$self->viewers->clear; $self->viewers->set( $response ); }; if ( $@ ) { $self->viewers->set( $@ ); } else { $self->viewers->clear; } } } { package Channel::PerlMonks::ChatterBox; use base 'Channel'; use base 'DataSource'; sub on_start { $_[0]{'do_hist'} = 1; } sub read_cbhistory { my $self = shift; my $response = $self->ua->get( 'http://nbpfaus.net/~pfau/cbhistory.cgi?site=PM&plain=1' ); $response->is_success or warn("Error getting chhistory - ".$response->status_line."\n"), return(); my $html = $response->as_string; =pod
perlfan 2004-08-30 15:58:41-04
I am actually trying to highlight perl code in a php based blog
=cut my( $dl ) = $html =~ m#
(.*?)
#s; my @recs; while ( $dl =~ m#
(.*?)
.*?(.*?)#gs ) { my( $dt, $info, $msg ) = ( $1, $2, $3 ); my( $msg_id ) = $dt =~ /id="(\d+)"/; my( $perlmonk_id, $username, $date, $time ) = $info =~ m#node_id=(\d+)">(.*?)\s*(\S+) (\S+)#; $msg =~ s/'/'/g; $msg =~ s/"/"/g; $time =~ s/-\d\d$//; push @recs, { message_id => $msg_id, user_id => $perlmonk_id, author => $username, date => $date, time => $time, text => $msg }; } \@recs } sub watchable_fields { [qw( text )] } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} ||= 'Chatterbox'; $self->{'interval'} ||= 9; $self->{'key_by'} = 'message_id'; $self->{'monkid_vector'} = [qw( author user_id )]; # for DataSource: $self->{'items'} ||= {}; $self->{'url'} ||= 'http://perlmonks.org/index.pl?node_id=207304'; $self } sub schlep { my $self = shift; $self->SUPER::pre_schlep; $self->collect_newA( $self->{'ds'}{'message'} ); # this condition should be made smarter: if ( $self->{'do_hist'} ) { $self->collect_newA( $self->read_cbhistory ); $self->{'do_hist'}--; } $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; $item->{'text'} =~ s#^\s*/me## ? "$item->{'time'} [$item->{'author'}]$item->{'text'}" : "$item->{'time'} [$item->{'author'}]: $item->{'text'}" } } { package Channel::PerlMonks::InBox; use base 'Channel'; use base 'DataSource'; sub url { my $self = shift; # must have a 'url' data member my( $username, $password ) = $self->creds; my $u = $self->{'url'}; $self->{'max_id'} and $u .= ";since_id=$self->{'max_id'}"; $username && $password and $u .= ";user=$username;passwd=$password"; warn "Inbox url = \n\t$u\n"; $u } sub watchable_fields { [qw( content )] } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} ||= 'Inbox'; $self->{'interval'} ||= 30; $self->{'key_by'} = 'message_id'; $self->{'normalizable_time_fields'} = [qw( time )]; $self->{'monkid_vector'} = [qw( author user_id )]; # for DataSource: $self->{'url'} ||= "http://perlmonks.org/index.pl?node_id=15848;archived=no;op=login;ticker=yes;xmlstyle=flat"; $self } =pod example: { message_id => '541960964', status => 'active', time => '20050904153705', content => '...concert and everyone had a good time.', author => 'DigitalKitty', user_id => '153214' } =cut sub schlep { my $self = shift; $self->SUPER::pre_schlep; $self->collect_newA( $self->{'ds'}{'message'} ); $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; "$item->{'time'} [$item->{'author'}] $item->{'content'}" } } { package Channel::PerlMonks::OtherUsers; use base 'Channel'; use base 'DataSource'; sub watchable_fields { [qw( username )] } sub updating_style { 'add_and_remove' } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} ||= 'OtherUsers'; $self->{'interval'} ||= 30; $self->{'key_by'} = 'user_id'; $self->{'monkid_vector'} = [qw( username user_id )]; # for DataSource: $self->{'url'} ||= 'http://perlmonks.org/index.pl?node_id=15851'; $self } sub schlep { my $self = shift; $self->SUPER::pre_schlep; $self->collect_newA( $self->{'ds'}{'user'} ); $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; "[$item->{'username'}]" } } { package Channel::PerlMonks::UserNodes; use base 'Channel'; use base 'DataSource'; sub watchable_fields { [qw( content )] } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} ||= 'UserNodes'; $self->{'interval'} ||= 30; $self->{'key_by'} = 'node_id'; # for DataSource: $self->{'url'} ||= "http://perlmonks.org/index.pl?node_id=32704;op=login;ticker=yes"; $self } sub url { my $self = shift; # must have a 'url' data member my( $username, $password ) = $self->creds; $username ||= '$USERNAME'; $password ||= '$PASSWORD'; my $url = $self->{'url'} . ";user=$username;passwd=$password"; $url } =pod '415722' => { 'lastupdate' => '', 'lastedit' => '20041217130843', # seems to be the same date/time as createtime! 'reputation' => '10', 'content' => 'Re^2: Don\'t Retitle This Node', 'createtime' => '2004-12-17 13:08:43' } =cut sub schlep { my $self = shift; $self->SUPER::pre_schlep; $self->collect_newH( $self->{'ds'}{'NODE'} ); $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; "[id://$item->{'node_id'}|$item->{'content'}]" } } { package Channel::PerlMonks::RecentNodes; use base 'Channel'; use base 'DataSource'; sub watchable_fields { [qw( content )] } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} ||= 'RecentNodes'; $self->{'interval'} ||= 60; $self->{'key_by'} = 'node_id'; $self->{'normalizable_time_fields'} = [qw( createtime )]; # for DataSource: $self->{'url'} ||= "http://perlmonks.org/index.pl?node_id=30175;xmlstyle=flat"; $self->{'lastcheck'} ||= 0; $self } sub url { my $self = shift; # must have a 'url' data member $self->{'lastcheck'} ? "$self->{'url'};sinceunixtime=".($self->{'lastcheck'}-60) # a minute : $self->{'url'} } =pod { node_id => '380092', content => 'Time Zones', nodetype => 'monkdiscuss', author_user => '378444', createtime => '20040804152300' } =cut sub schlep { my $self = shift; $self->SUPER::pre_schlep; $self->collect_newA( $self->{'ds'}{'NODE'} ); Adso->remember_perlmonk_id( $_->{'content'}, $_->{'node_id'} ) for @{( $self->force_arrayref( $self->{'ds'}{'AUTHOR'} ) )}; # supplement each record with this datum: $_->{'author'} = Adso->perlmonk_of_id( $_->{'author_user'} ) for values %{ $self->{'new_items'} }; $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; join ' ', $item->{'createtime'}, "[$item->{'author'}]", "($item->{'nodetype'})", "[id://$item->{'node_id'}|$item->{'content'}]"; } } { package Channel::RSS; use base 'Channel'; use base 'DataSource'; sub watchable_fields { [qw( title description )] } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} or die "name is not optional when creating an RSS object!"; $self->{'interval'} ||= 60*60; # 1 hour $self->{'key_by'} ||= 'link'; $self } sub schlep { my $self = shift; $self->SUPER::pre_schlep; my $is_rss2 = $self->{'ds'}{'version'} && $self->{'ds'}{'version'} =~ /^2/; $self->{'key_by'} ||= $is_rss2 ? 'guid' : 'link'; $self->collect_newA( $is_rss2 ? $self->{'ds'}{'channel'}{'item'} : $self->{'ds'}{'item'} ); $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; my @s = ( "[$item->{'link'}|$item->{'title'}] $item->{'description'}" ); # prepend the value of the group_by field, if possible: $self->{'group_by'} && $item->{$self->{'group_by'}} and unshift @s, $item->{$self->{'group_by'}}; join ': ', @s } } { package Channel::POP; use base 'Channel'; # this one's a little different, in that it's not pulling XML via HTTP. use Net::POP3; sub watchable_fields { [] } # TBD sub updating_style { 'add_and_remove' } sub new { my $pkg = shift; my $self = bless $pkg->SUPER::new( @_ ), $pkg; $self->{'name'} ||= 'POP'; $self->{'key_by'} = 'msgnum'; # arbitrary. For setting, not getting. $self } sub get_datastructure # we DON'T use the one in DataSource. It is not our parent. { my $self = shift; # OPEN: $self->{'pop3'} = Net::POP3->new( $self->{'host'} ); $self->{'pop3'}->apop( $self->{'username'}, $self->{'password'} ) or warn("Failed to log into pop server $self->{'host'} as $self->{'username'}!"), return(); # GET DATA: # note that "new" here is the POP server's notion of new, not ours. # the number will only increase until the user actually reads some # of the messages in her inbox! my %info; ( $info{'new'}, $info{'total'} ) = $self->{'pop3'}->ping( $self->{'username'} ); $info{'last'} = $self->{'pop3'}->last; $info{'list'} = $self->{'pop3'}->list; # key=msgnum, val=size # ideally, we'd like to use the pop connection to get a little more info about each new msg. # e.g. use top() to get the header lines. # CLOSE: $self->{'pop3'}->quit; undef $self->{'pop3'}; # convert each value into a record (hash) with one field: $info{'list'}{$_} = { size => $info{'list'}{$_} } for keys %{$info{'list'}}; \%info } sub schlep # special: POP { my $self = shift; $self->SUPER::pre_schlep; $self->collect_newH( $self->{'ds'}{'list'} ); $self->SUPER::post_schlep; } sub render_item { my( $self, $item ) = @_; "$item->{'msgnum'} $item->{'size'}" } } } ###################################### END of Channel classes ############################################# ###################################### START of AppContext classes ########################################### { # # The AppContext class (which is an interface) and its subclasses (which implement the interface) # are intended to encapsulate the context of the windowing graphical user interface in # which the program is running. # This is distinct from the concept of a "Viewer", which encapsulates an input/output # mechanism for channel content/interaction. # { package AppContext; sub viewer_class { die } # must be overridden in child! sub update { $_[0] } # default: no-op } { package AppContext::StandaloneTkNotebookApp; # singleton in the program! use base 'AppContext'; use Tk; use Tk::NoteBook; use Tk::LabFrame; # When you call AppContext::StandaloneTkNotebookApp->new, you can pass a MainWindow object as the 'mw' named arg, # or you can have the AppContext::StandaloneTkNotebookApp object create one later with create_mainwindow. # similarly for a notebook ('nb') and menubar ('mb'). my $singleton_app_context; sub viewer_class { 'Viewer::TkTabbedText' } sub new { my $pkg = shift; @_ and die "Error! $pkg is singleton in the program!"; $singleton_app_context and return $singleton_app_context; my $self = bless { @_ }, $pkg; $self->{'mw'} ||= MainWindow->new; $self->{'nb'} ||= $self->{'mw'}->NoteBook( -dynamicgeometry => 1 )->pack( -expand => 1, -fill => 'both' ); $self->{'mb'} ||= $self->{'mw'}->Menu( -type => 'menubar' ); $self->{'mw'}->configure( -menu => $self->{'mb'} ); # apparently, a notebook with no pages is a freakazoid ready to splode. $self->{'about_page'} = $self->add_notebook_tab( 'Configure' => sub { $self->set_viewer_menus_state(0); } ); $self->{'chan_fr'} = $self->{'about_page'}->LabFrame( -labelside => 'acrosstop', -label => 'Configure Channels:' )->pack( -anchor => 'nw' ); $self->mb->add( 'command', -label => 'New Tab', -command => sub { $self->prompt_new_viewer(); } ); $singleton_app_context = $self } sub add_channel_configure_command { my( $self, $channel ) = @_; $self->{'chan_fr'}->Button( -text => $channel->name, -anchor => 'w', -command => sub { $channel->edit_config } )->pack( -fill => 'x' ); } sub run { MainLoop; } sub mw { $_[0]{'mw'} } sub nb { $_[0]{'nb'} } sub mb { $_[0]{'mb'} } sub active_viewer_name { $_[0]{'nb'}->raised } sub activate_viewer { my( $self, $name ) = @_; $self->{'nb'}->raise( $name ); $self } sub add_notebook_tab { my( $self, $name, $on_raise_cb, @args ) = @_; $self->nb->add( $name, -label => $name, -underline => 0, -raisecmd => $on_raise_cb, @args ); } sub delete_notebook_tab { my( $self, $name ) = @_; $self->nb->delete( $name ); } sub change_notebook_tab_label { my( $self, $name, $code ) = @_; local $_ = $self->nb->pagecget( $name, '-label' ); $code->(); $self->nb->pageconfigure( $name, -label => $_ ); } sub set_viewer_menus_state { my( $self, $state ) = @_; # boolean. true = enabled. $state = $state ? 'normal' : 'disabled'; $self->mb->entryconfigure( $_, -state => $state ) for keys %{ $self->{'viewer_menus'} }; } sub create_viewer # called in edit_dd_config callback when it's for a new dd { my( $this_appcontext, $config ) = @_; $config->{'name'} or warn("Tab name cannot be null!"), return; Adso->viewers( $config->{'name'} ) and warn("Error - tab name '$config->{'name'}' already in use!"), return; my $viewer = $this_appcontext->viewer_class->new( $config->{'name'} ); Adso->viewers( $config->{'name'}, $viewer ); $viewer->set_config($config); } sub destroy_viewer { my( $this_appcontext, $dd ) = @_; $dd->kill; Adso->forget_viewer($dd); } sub realize_viewer # called in TkTabbedText->new { my( $this_appcontext, $name, $on_raise_cb, @args ) = @_; $this_appcontext->add_notebook_tab( $name, sub { $this_appcontext->set_viewer_menus_state(1); $on_raise_cb->() if $on_raise_cb; }, -label => "$name ", @args ); } # this always sets the position of the new window at +200+50 relative # to the AppContext::StandaloneTkNotebookApp's MainWindow. sub create_dialog { my $this_appcontext = shift; my $mw = $this_appcontext->{'mw'}; my $tl = $mw->Toplevel; my $x = $mw->x + 200; my $y = $mw->y + 50; $tl->geometry("+$x+$y"); $tl } # this expects to be passed the current config as a data structure; # it passes back (calling set_config) the same data structure. sub edit_channel_config { my $this_appcontext = shift; my $config = shift; # hashref my $channel = shift; # undef if new? my $dlg = $this_appcontext->create_dialog; $dlg->title( "Edit $config->{'name'}" ); my $button_fr = $dlg->Frame->pack( -side => 'bottom' ); $button_fr->Button( -text => "OK", -command => sub { $dlg->destroy; $channel->set_config($config); } )->grid( -row => 0, -column => 0 ); $button_fr->Button( -text => "Cancel", -command => sub { $dlg->destroy; } )->grid( -row => 0, -column => 1 ); my $fr = $dlg->Frame( -borderwidth => 2, -relief => 'groove' )->pack; $fr->Label( -text => "'$config->{'name'}' configuration" )->pack; my $username_entry; for ( $fr->Frame->pack ) { $_->Label( -text => 'username:' )->pack( -side => 'left' ); $username_entry = $_->Entry( -textvariable => \( $config->{'username'} ) )->pack( -side => 'left' ); } for ( $fr->Frame->pack ) { $_->Label( -text => 'password:' )->pack( -side => 'left' ); $_->Entry( -textvariable => \( $config->{'password'} ), -show => '*' )->pack( -side => 'left' ); } for ( $fr->Frame->pack ) { $_->Label( -text => 'Interval:' )->pack( -side => 'left' ); $_->Entry( -textvariable => \( $config->{'interval'} ), -width => 4, )->pack( -side => 'left' ); } for ( $fr->Frame->pack ) { $_->Label( -text => 'Watcher.Regex:' )->pack( -side => 'left' ); $_->Entry( -textvariable => \( $config->{'watcher.regex'} ), -width => 40, )->pack( -side => 'left' ); } =pod for ( $fr->Frame->pack ) { $_->Label( -text => 'Datasource.Url:' )->pack( -side => 'left' ); $_->Entry( -textvariable => \( $config->{'url'} ), )->pack( -side => 'left' ); } =cut for ( $fr->Frame->pack ) { $_->Label( -text => 'Active:' )->pack( -side => 'left' ); $_->Checkbutton( -variable => \( $config->{'running'} ) )->pack; } $username_entry->focus; $dlg->grab; } =pod { name => (string|unset), links_visible => (0|1), channels => { foo => 1, bar => 1, } } Then we go over all the channels, adding in the un-set ones: { name => (string|unset), links_visible => (0|1), channels => { foo => 1, bar => 1, quux => 0, } } Final spec, as passed to set_config: { name => (string|unset), links_visible => (0|1), channels => { foo => (0|1), } } =cut # the 'name' element is editable only if it's null. # once it has a value, it can't be changed. sub edit_viewer_channels { my( $this_appcontext, $config, $viewer ) = @_; # $config: hashref # $viewer: the one whose config we're editing $viewer or die; #defined $viewer and $config->{'name'} = $viewer->name; my $dlg = $this_appcontext->create_dialog; $dlg->title( $viewer ? $config->{'name'} : "new" ); my $button_fr = $dlg->Frame->pack( -side => 'bottom' ); my $fr = $dlg->Frame( -borderwidth => 2, -relief => 'groove' )->pack; # show current name, read only: $fr->Label( -text => "Select Channels:" )->pack; my $OK_button = $button_fr->Button( -text => "OK", -command => sub { $dlg->destroy; $viewer->set_config($config); } )->grid( -row => 0, -column => 0 ); $button_fr->Button( -text => "Cancel", -command => sub { $dlg->destroy; } )->grid( -row => 0, -column => 1 ); for ( Adso->channel_names ) { $config->{'channels'}{$_} ||= 0; } for ( sort keys %{ $config->{'channels'} } ) { $fr->Frame->pack( -fill => 'x' )->Checkbutton( -text => $_, -variable => \( $config->{'channels'}{$_} ) )->pack( -side => 'left' ); } $OK_button->focus; $dlg->grab; } sub prompt_new_viewer { my( $this_appcontext, ) = @_; my $config = {}; my $dlg = $this_appcontext->create_dialog; $dlg->title( "new" ); my $button_fr = $dlg->Frame->pack( -side => 'bottom' ); my $fr = $dlg->Frame( -borderwidth => 2, -relief => 'groove' )->pack; # show edit field for entering new name: my $name_entry_fr = $fr->Frame->pack; $name_entry_fr->Label( -text => 'Tab name:' )->pack( -side => 'left' ); my $name_entry = $name_entry_fr->Entry( -textvariable => \( $config->{'name'} ) )->pack( -side => 'left' ); my $OK_button = $button_fr->Button( -text => "OK", -command => sub { $dlg->destroy; $this_appcontext->create_viewer($config); } )->grid( -row => 0, -column => 0 ); $button_fr->Button( -text => "Cancel", -command => sub { $dlg->destroy; } )->grid( -row => 0, -column => 1 ); $name_entry->bind( '' => sub { $OK_button->invoke } ); $name_entry->focus; $dlg->grab; } sub update { my $this_appcontext = shift; $this_appcontext->{'mw'}->update; } sub busy_up { my( $this_appcontext ) = @_; $this_appcontext->{'busy'}++; if ( $this_appcontext->{'busy'} == 1 ) { $this_appcontext->{'mw'}->Busy( -recurse => 1 ); $this_appcontext->{'mw'}->update; } } sub busy_down { my( $this_appcontext ) = @_; if ( $this_appcontext->{'busy'} > 0 ) { $this_appcontext->{'busy'}--; if ( $this_appcontext->{'busy'} == 0 ) { $this_appcontext->{'mw'}->Unbusy; $this_appcontext->{'mw'}->update; } } } } } ###################################### END of AppContext classes ########################################### ###################################### BEGIN main program ########################################### Adso->main; __END__ To Do: . Not reset the schlep interval from the datastructure if it's been explicitly set by the user. . Enhance channel_updated to handle a mixture of both styles. In fact, if there's anything more than a single add_and_remove, things are bad. (Any number of just add_only is fine.) . The Viewer should decide how to format ("render") each item, using meta data supplied by the channel. Currently it's the Channels that render each item. IDEALLY, we'd simply use stylesheets to control all this. . allow (at Viewer construction time) to specify a filter sub. For example, it should be possible to have two different windows open on the OtherUsers channel, with one showing only newly joined users, the other showing only "still here" users. . Every major class needs a method yeilding a config data structure. (The issue of accepting such a structure for the purpose of SETTING a config will be taken up later...) . make a class to store login creds ("IdentityCard"). have Adso maintain a db of these. each card needs a "name". This is distinct from its username, which is just a datum. These are created/configured independently. Then, when a set of login creds is needed, e.g. when configuring a channel, she simply selects a named IdentityCard. . Similar for Watchers. . on_connect_viewer needs to render the current contents of the channel into the new Viewer. That way, she doesn't have to create/configure a window BEFORE turning on the channel. . replace warn's with Viewer-specific alert messages. . Load/save config, automatically on startup/shutdown. . Re-schedule the cb fetch for "1 sec in the future" whenever a message gets sent. . Allow refresh (instant schlep) on demand (e.g. by buttonpress) . Re-schedule for an "immediate" reschlep if the channel is reconfigured for a new schlep interval. . Let the user configure (via the gui) how URLs get launched! . other "standard" text window features. . handle other shortcut schemes, e.g. node, pmdev... . Configuration properties per tab: - Font . Configuration properties per channel: - Alert pattern - Alert actions: . Pop up a message . Show a message in the status bar . Play a sound . Run an arbitrary perl snippet, module, or script . Channel-specific configuration items, e.g. - POP host, user, pass . A channel for monitoring specific nodes. . A channel for monitoring specific threads, similar to RAT.