├── README.md ├── alert.xpm ├── cpanfile ├── lib └── PM │ └── CB │ ├── Common.pm │ ├── Communication.pm │ ├── Control.pm │ └── GUI.pm ├── pm-cb ├── pm-cb-g └── pm.xpm /README.md: -------------------------------------------------------------------------------- 1 | pm-cb is Copyright (C) 2017-2020, E. Choroba 2 | 3 | PerlMonks ChatterBox Client 4 | == 5 | 6 | DESCRIPTION 7 | -- 8 | 9 | There are two executable programs, `pm-cb` and `pm-cb-g`. The former 10 | doesn't implement a full chat client (you can't use it to post to the 11 | ChatterBox) and is no longer supported. The latter is a graphical 12 | client to PerlMonks' ChatterBox written in Perl and Tk. 13 | 14 | Pull requests welcome! 15 | 16 | PREQUISITES 17 | -- 18 | Install required modules using 19 | ``` 20 | cpanm --installdeps . 21 | ``` 22 | 23 | If your `perl` has been compiled with thread support: 24 | 25 | ``` 26 | perl -MConfig -E 'say "Threads supported" if $Config{useithreads}' 27 | ``` 28 | you can simply start the program with 29 | 30 | ``` 31 | perl pm-cb-g 32 | 33 | ``` 34 | If threads are not supported, either compile a new perl with threads enabled, 35 | e.g. 36 | 37 | ``` 38 | perlbrew install perl-5.30.0 --as=5.30.0-threads -Dusethreads 39 | perlbrew use 5.30.0-threads 40 | ``` 41 | or run the program using `MCE::Hobo` with 42 | ``` 43 | perl pm-cb-g --mce_hobo 44 | ``` 45 | or with `MCE::Child` 46 | ``` 47 | perl pm-cb-g --mce_child 48 | ``` 49 | 50 | 51 | LICENSE INFORMATION 52 | -- 53 | 54 | This code is free software; you can redistribute it and/or modify it 55 | under the same terms as Perl 5.30 (see [the Perl Artistic 56 | License](https://perldoc.pl/perlartistic) and [the GNU General Public 57 | License, version 1](https://perldoc.pl/perlgpl)). 58 | 59 | -------------------------------------------------------------------------------- /alert.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char * pm_xpm[] = { 3 | "32 32 4 1", 4 | " c black", 5 | ". c red", 6 | "X c yellow", 7 | "o c brown", 8 | " ", 9 | " .............................. ", 10 | " .............................. ", 11 | " .............................. ", 12 | " XXXXX......................XXX ", 13 | " XXXXXX....................XXXX ", 14 | " ....XXX..................XX... ", 15 | " ......X..................X.... ", 16 | " ......XX................XX.... ", 17 | " ......XX................X..... ", 18 | " ...X...XX..............XX..... ", 19 | " ..XXX..XX............XXX...X.. ", 20 | " ...X...XX...........XX....XoX. ", 21 | " ........XX.........XX......XX. ", 22 | " ........XX.........XXXX....... ", 23 | " .........XX...........X....... ", 24 | " .........XX...........XX...... ", 25 | " ......XXXX............XXXX.... ", 26 | " .....XX..................XX... ", 27 | " ..XXXX....................XX.. ", 28 | " .XX.......................XX.. ", 29 | " ..XXXX...................XX... ", 30 | " .....XXX.............XXXXX.... ", 31 | " ......XX.............XX....... ", 32 | " ..X..XX...............XXX..... ", 33 | " XXXX.XX.................XXX... ", 34 | " XX..XX....................XXX. ", 35 | " X...........................XX ", 36 | " .............................X ", 37 | " .............................X ", 38 | " .............................. ", 39 | " "}; 40 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | use Config; 2 | 3 | on build => sub { 4 | if ($Config{usethreads}) { 5 | suggests 'MCE::Hobo'; 6 | suggests 'MCE::Shared'; 7 | } else { 8 | requires 'MCE::Hobo'; 9 | requires 'MCE::Shared'; 10 | } 11 | suggests 'MCE::Child'; 12 | suggests 'MCE::Channel'; 13 | }; 14 | 15 | requires 'FindBin'; 16 | requires 'Getopt::Long'; 17 | requires 'Pod::Usage'; 18 | requires 'Time::HiRes'; 19 | requires 'Time::Piece'; 20 | requires 'charnames'; 21 | 22 | requires 'List::Util'; 23 | requires 'LWP::Protocol::https'; 24 | requires 'Syntax::Construct'; 25 | requires 'Tk'; 26 | requires 'WWW::Mechanize'; 27 | requires 'XML::LibXML'; 28 | -------------------------------------------------------------------------------- /lib/PM/CB/Common.pm: -------------------------------------------------------------------------------- 1 | package PM::CB::Common; 2 | 3 | use warnings; 4 | use strict; 5 | 6 | use Exporter qw{ import }; 7 | our @EXPORT_OK = qw{ to_entities }; 8 | 9 | sub to_entities { 10 | my ($message) = @_; 11 | $message =~ s/(.)/ord $1 > 127 ? '&#' . ord($1) . ';' : $1/ge; 12 | return $message 13 | } 14 | 15 | 16 | __PACKAGE__ 17 | -------------------------------------------------------------------------------- /lib/PM/CB/Communication.pm: -------------------------------------------------------------------------------- 1 | package PM::CB::Communication; 2 | 3 | use warnings; 4 | use strict; 5 | use Syntax::Construct qw{ // }; 6 | 7 | use Encode; 8 | use Time::HiRes; 9 | use WWW::Mechanize; 10 | use XML::LibXML; 11 | use PM::CB::Common qw{ to_entities }; 12 | 13 | use constant { 14 | FREQ => 10, 15 | REPEAT_THRESHOLD => 5, 16 | NOT_DELETABLE => 0, 17 | # Node ids: 18 | LOGIN => 109, 19 | CB => 207304, 20 | DELETE => 50772, 21 | SEND => 227820, 22 | PRIVATE => 15848, 23 | MONKLIST => 15851, 24 | SHORTCUT => 11136513, 25 | RANDOM_SHORT => 3193, 26 | }; 27 | 28 | 29 | sub new { 30 | my ($class, $struct) = @_; 31 | bless $struct, $class 32 | } 33 | 34 | 35 | sub url { "https://$_[0]{pm_url}/bare/index.pl?node_id=" } 36 | 37 | 38 | sub communicate { 39 | my ($self) = @_; 40 | 41 | my $mech = $self->{mech} 42 | = 'WWW::Mechanize'->new( 43 | timeout => 120, 44 | autocheck => 0, 45 | ssl_opts => $self->ssl_opts); 46 | 47 | my ($from_id, $previous, %seen); 48 | 49 | my $last_update = -1; 50 | my ($message, $command); 51 | my %dispatch = ( 52 | login => sub { $self->login(@$message) 53 | or $self->{to_gui}->enqueue(['login']) }, 54 | send => sub { $message->[0] =~ tr/\x00-\x20/ /s; 55 | $self->send_message($message->[0]) }, 56 | title => sub { $self->get_title(@$message) }, 57 | shortcut => sub { $self->get_shortcut(@$message) }, 58 | deletemsg => sub { $self->delete_msg(@$message) }, 59 | url => sub { $self->handle_url(@$message) }, 60 | list => sub { $self->get_monklist }, 61 | quit => sub { no warnings 'exiting'; last }, 62 | ); 63 | 64 | while (1) { 65 | if ($message = $self->{from_gui}->dequeue_nb) { 66 | $command = shift @$message; 67 | $dispatch{$command}->(); 68 | } 69 | 70 | Time::HiRes::usleep(250_000); 71 | next if time - $last_update < FREQ; 72 | 73 | $last_update = time; 74 | 75 | my $url = $self->url . CB; 76 | $url .= ";fromid=$from_id" if defined $from_id; 77 | $mech->get($url); 78 | if ( my $content = $self->mech_content ) { 79 | my $xml; 80 | if (eval { 81 | $xml = 'XML::LibXML'->load_xml(string => $content); 82 | }) { 83 | 84 | my @messages = $xml->findnodes('/chatter/message'); 85 | 86 | my $time = $xml->findvalue('/chatter/info/@gentimeGMT'); 87 | 88 | for my $message (@messages) { 89 | my $id = $message->findvalue('message_id'); 90 | if (! exists $seen{$id}) { 91 | $self->{to_gui}->enqueue([ 92 | chat => $time, 93 | $message->findvalue('author'), 94 | $message->findvalue('text') ]); 95 | undef $seen{$id}; 96 | } 97 | } 98 | $self->{to_gui}->enqueue([ time => $time, !! @messages ]); 99 | 100 | my $new_from_id = $xml->findvalue( 101 | '/chatter/message[last()]/message_id'); 102 | $from_id = $new_from_id if length $new_from_id; 103 | 104 | $previous = $xml; 105 | } else { 106 | warn "PMCB: $@"; 107 | } 108 | } 109 | 110 | my @private = $self->get_all_private(\%seen); 111 | for my $msg (@private) { 112 | $self->{to_gui}->enqueue([ 113 | private => @$msg{qw{ author time text id }} 114 | ]) unless exists $seen{"p$msg->{id}"}; 115 | undef $seen{"p$msg->{id}"}; 116 | } 117 | } 118 | } 119 | 120 | 121 | sub get_monklist { 122 | my ($self, $repeat) = @_; 123 | my $response; 124 | eval { $response = $self->{mech}->get($self->url . MONKLIST) }; 125 | if (! $response || $response->is_error) { 126 | $repeat //= 0; 127 | if ($repeat <= REPEAT_THRESHOLD) { 128 | $self->get_monklist($repeat + 1); 129 | 130 | } else { 131 | warn "PMCB: Can't get monklist.\n"; 132 | } 133 | return 134 | } 135 | my $dom; 136 | eval { 137 | $dom = 'XML::LibXML'->load_xml(string => $self->mech_content); 138 | } or return; 139 | my $names = $dom->findnodes('/CHATTER/user'); 140 | $self->{to_gui}->enqueue(['list', map $_->{username}, @$names]); 141 | } 142 | 143 | 144 | sub handle_url { 145 | my ($self, @message) = @_; 146 | if (@message && $message[0] ne $self->{pm_url}) { 147 | $self->{pm_url} = $message[0]; 148 | $self->{mech}->ssl_opts(%{ $self->ssl_opts }); 149 | $self->{to_gui}->enqueue(['send_login']); 150 | } else { 151 | $self->{to_gui}->enqueue(['url', $self->{pm_url}]); 152 | } 153 | } 154 | 155 | 156 | { my %titles; 157 | sub get_title { 158 | my ($self, $id, $name, $repeat) = @_; 159 | my $title = $titles{$id}; 160 | unless (defined $title) { 161 | my $url = $self->url . $id; 162 | my $response; 163 | eval { 164 | $response = $self->{mech}->get($url . ';displaytype=xml'); 165 | }; 166 | if (! $response || $response->is_error) { 167 | $repeat //= 0; 168 | $self->get_title($id, $name, $repeat + 1) 169 | unless $repeat > REPEAT_THRESHOLD; 170 | return 171 | } 172 | 173 | # Only use the surrogate title when the page works but has no 174 | # title. Locked users, for example, don't return anything, so 175 | # surrogate title isn't used. 176 | my $dom; 177 | eval { 178 | $dom = 'XML::LibXML'->load_xml(string => $self->mech_content); 179 | } or return; 180 | 181 | $title = $dom->findvalue('/node/@title'); 182 | $title = "untitled node, ID $id" unless length $title; 183 | $titles{$id} = $title; 184 | } 185 | 186 | $self->{to_gui}->enqueue(['title', $id, $name, $title]); 187 | } 188 | } 189 | 190 | 191 | { my %link; 192 | sub get_shortcut { 193 | my ($self, $shortcut, $title, $repeat) = @_; 194 | my $url = $link{$shortcut}; 195 | unless (defined $url) { 196 | my $response; 197 | eval { 198 | $response = $self->{mech}->get($self->url . SHORTCUT 199 | . ";link=$shortcut"); 200 | }; 201 | if (! $response || $response->is_error) { 202 | $repeat //= 0; 203 | $self->get_shortcut($shortcut, $repeat + 1) 204 | unless $repeat > REPEAT_THRESHOLD; 205 | return 206 | } 207 | 208 | my $dom; 209 | eval { 210 | $dom = 'XML::LibXML'->load_xml(string => $self->mech_content) 211 | } or return; 212 | 213 | $link{$shortcut} = $url 214 | = $dom->findvalue('/links/link/url') =~ s/\n//r; 215 | } 216 | $self->{to_gui}->enqueue(['shortcut', $shortcut, $url, $title]); 217 | } 218 | } 219 | 220 | 221 | sub login { 222 | my ($self, $username, $password) = @_; 223 | my $response = $self->{mech}->get($self->url . LOGIN); 224 | if ($response->is_success) { 225 | $self->{mech}->submit_form( 226 | form_number => 1, 227 | fields => { user => $username, 228 | passwd => $password, 229 | }); 230 | return $self->mech_content 231 | !~ /^Oops\. You must have the wrong login/m 232 | } 233 | return 234 | } 235 | 236 | 237 | sub send_message { 238 | my ($self, $message, $repeat) = @_; 239 | return unless length $message; 240 | 241 | my $msg = to_entities($message); 242 | my $response; 243 | eval { $response = $self->{mech}->post( 244 | $self->url . SEND, 245 | Content => { op => 'message', 246 | node => SEND, 247 | message => $msg } 248 | ) }; 249 | if (! $response 250 | || $response->is_error 251 | || $response->content =~ m{500\ Internal\ Server\ Error 252 | |Server\ Error\ \(Error\ ID\ \w+\)</span>}x 253 | ) { 254 | $repeat //= 0; 255 | $self->send_message($message, $repeat + 1) 256 | unless $repeat > REPEAT_THRESHOLD; 257 | return 258 | } 259 | my $content = $response->content; 260 | if ($content =~ /^Chatter accepted/) { 261 | if ($message =~ m{^/msg\s+(\S+)\s+(.*)}) { 262 | $self->{to_gui}->enqueue( 263 | [private => "-> $1", undef, $2, NOT_DELETABLE]); 264 | } 265 | return 266 | } 267 | 268 | $self->{to_gui}->enqueue( 269 | [private => '<pm-cb-g>', undef, $content, NOT_DELETABLE]); 270 | } 271 | 272 | 273 | sub delete_msg { 274 | my ($self, $id) = @_; 275 | my $response; 276 | eval { $response = $self->{mech}->post( 277 | $self->url . DELETE, 278 | Content => { op => 'message', 279 | node => RANDOM_SHORT, 280 | "deletemsg_$id" => 'yup', 281 | perlisgood => 'delete'})}; 282 | $self->{to_gui}->enqueue(['delete', $id]) 283 | if $response && $response->is_success; 284 | } 285 | 286 | 287 | sub get_all_private { 288 | my ($self, $seen) = @_; 289 | 290 | my $url = $self->url . PRIVATE; 291 | 292 | my ($max, @private); 293 | ALL: 294 | while (1) { 295 | my $response; 296 | eval { $response = $self->{mech}->get($url) }; 297 | last unless $response && $response->is_success; 298 | 299 | my $content = $self->mech_content; 300 | last unless $content =~ /</; 301 | 302 | my $xml; 303 | eval { $xml = 'XML::LibXML'->load_xml(string => $content) } 304 | or last; 305 | 306 | my @messages; 307 | last unless @messages = $xml->findnodes('/CHATTER/message'); 308 | 309 | for my $msg (@messages) { 310 | my $id = $msg->findvalue('@message_id'); 311 | last ALL if $seen->{"p$id"}; 312 | 313 | push @private, { 314 | author => $msg->findvalue('@author'), 315 | time => $msg->findvalue('@time'), 316 | text => $msg->findvalue('text()'), 317 | id => $id, 318 | }; 319 | } 320 | 321 | my $first = $messages[0]->findvalue('@message_id'); 322 | $url = $self->url . PRIVATE . "&prior_to=$first"; 323 | } 324 | 325 | @private = sort { $a->{time} cmp $b->{time} } @private; 326 | return @private 327 | } 328 | 329 | 330 | sub mech_content { 331 | my ($self) = @_; 332 | # libxml respects encoding, but mech returns the page in unicode, 333 | # not windows-1252. 334 | my $content = Encode::encode('UTF-8', $self->{mech}->content); 335 | $content =~ s/windows-1252/utf-8/i; 336 | return $content 337 | } 338 | 339 | 340 | sub ssl_opts { 341 | {verify_hostname => $_[0]->is_url_verifiable ? 1 : 0} 342 | } 343 | 344 | 345 | sub is_url_verifiable { 346 | $_[0]{pm_url} =~ /^(?:www\.)?perlmonks\.(?:com|net|org)$/ 347 | } 348 | 349 | 350 | __PACKAGE__ 351 | -------------------------------------------------------------------------------- /lib/PM/CB/Control.pm: -------------------------------------------------------------------------------- 1 | package PM::CB::Control; 2 | 3 | use warnings; 4 | use strict; 5 | 6 | use PM::CB::Communication; 7 | 8 | 9 | sub new { 10 | my ($class, $struct) = @_; 11 | bless $struct, $class 12 | } 13 | 14 | 15 | sub start_comm { 16 | my ($self) = @_; 17 | $self->{communicate_t} = $self->{worker_class}->create(sub { 18 | my $communication = 'PM::CB::Communication'->new({ 19 | to_gui => $self->{to_gui}, 20 | from_gui => $self->{to_comm}, 21 | pm_url => $self->{pm_url}, 22 | }); 23 | $communication->communicate; 24 | }); 25 | 26 | my $counter = 10; 27 | while (1) { 28 | my $msg = $self->{from_gui}->dequeue_nb; 29 | last if $msg && 'quit' eq $msg->[0]; 30 | 31 | 32 | if ($msg) { 33 | { random_url => sub { $self->{random_url} = $msg->[1] } 34 | }->{$msg->[0]}->(); 35 | } 36 | 37 | sleep 1; 38 | $self->heartbeat; 39 | if ($self->{random_url} && ! $counter--) { 40 | $counter = 10; 41 | $self->{to_comm}->enqueue(['url', random_url()]); 42 | $self->{to_comm}->enqueue(['url']); 43 | }; 44 | } 45 | $self->{to_comm}->insert(0, ['quit']); 46 | $self->{communicate_t}->join; 47 | $self->{to_gui}->insert(0, ['quit']); 48 | } 49 | 50 | 51 | sub random_url { 52 | (map +( $_, "www.$_" ), map "perlmonks.$_", qw( org net com ))[rand 6] 53 | } 54 | 55 | 56 | sub heartbeat { 57 | my ($self) = @_; 58 | 59 | unless ($self->{communicate_t}->is_running) { 60 | warn "PMCB: Restarting worker...\n"; 61 | eval { $self->{communicate_t}->join }; 62 | $self->start_comm; 63 | $self->{to_gui}->enqueue(['send_login']); 64 | } 65 | } 66 | 67 | 68 | __PACKAGE__ 69 | -------------------------------------------------------------------------------- /lib/PM/CB/GUI.pm: -------------------------------------------------------------------------------- 1 | package PM::CB::GUI; 2 | 3 | use warnings; 4 | use strict; 5 | use Syntax::Construct qw{ // }; 6 | 7 | use charnames (); 8 | use Time::Piece; 9 | use List::Util qw{ shuffle }; 10 | use PM::CB::Common qw{ to_entities }; 11 | 12 | use constant { 13 | TITLE => 'PM::CB::G', 14 | PUBLIC => 0, 15 | PRIVATE => 1, 16 | GESTURE => 2, 17 | REASK_THRESHOLD => 10, 18 | HISTORY_SIZE => 100, 19 | CHAR_LIMIT => 255, 20 | }; 21 | 22 | 23 | sub new { 24 | my ($class, $struct) = @_; 25 | bless $struct, $class 26 | } 27 | 28 | 29 | sub url { 30 | my ($self, $url, $part) = @_; 31 | $url //= '__PM_CB_URL__'; 32 | $part //= "?node="; 33 | $url =~ s{__PM_CB_URL__}{https://$self->{browse_url}/index.pl$part}; 34 | return $url 35 | } 36 | 37 | 38 | sub gui { 39 | my ($self) = @_; 40 | 41 | my $tzoffset = Time::Piece::localtime()->tzoffset; 42 | $self->{last_date} = q(); 43 | 44 | require Tk; 45 | 46 | require Tk::Dialog; 47 | require Tk::ROText; 48 | require Tk::Balloon; 49 | 50 | $self->{mw} = my $mw = 'MainWindow'->new(-title => TITLE); 51 | $mw->protocol(WM_DELETE_WINDOW => sub { $self->quit }); 52 | $mw->geometry($self->{geometry}) if $self->{geometry}; 53 | $mw->optionAdd('*font', "$self->{font_name} $self->{char_size}"); 54 | $self->{icon} = $mw->Pixmap(-file => "$self->{icon_path}/pm.xpm"); 55 | $self->{icon_alert} = $mw->Pixmap(-file => "$self->{icon_path}/alert.xpm"); 56 | $mw->iconimage($self->{icon}); 57 | $mw->iconname('normal'); 58 | 59 | my $read_f = $mw->Frame->pack(-expand => 1, -fill => 'both'); 60 | $self->{read} = my $read 61 | = $read_f->ROText(-background => $self->{bg_color}, 62 | -foreground => $self->{fg_color}, 63 | -wrap => 'word') 64 | ->pack(-expand => 1, -fill => 'both'); 65 | $read->tagConfigure(author => -foreground => $self->{author_color}); 66 | $read->tagConfigure(private => -foreground => $self->{private_color}); 67 | $read->tagConfigure(gesture => -foreground => $self->{gesture_color}); 68 | $read->tagConfigure(seen => -foreground => $self->{seen_color}); 69 | $read->tagConfigure(time => -foreground => $self->{time_color}); 70 | 71 | my $balloon = $self->{balloon} = $mw->Balloon; 72 | 73 | my $last_update_f = $mw->Frame->pack; 74 | $self->{last_update} = my $last_update 75 | = $last_update_f->Label(-text => 'No update yet', 76 | -foreground => 'black') 77 | ->pack(-side => 'left'); 78 | 79 | my $write_f = $mw->Frame->pack(-fill => 'x'); 80 | $self->{write} = my $write = $write_f->Text( 81 | -height => 3, 82 | -background => $self->{bg_color}, 83 | -foreground => $self->{fg_color}, 84 | -insertbackground => $self->{fg_color}, 85 | -wrap => 'word', 86 | )->pack(-fill => 'x'); 87 | $self->{write}->bind('<<Modified>>', sub { 88 | return unless $self->{write}->editModified; 89 | 90 | $self->{write}->editModified(0); 91 | 92 | # We can't check the length immediately, because when deleting 93 | # characters, the old length is returned. 94 | $mw->after(10, sub { 95 | if (CHAR_LIMIT < length to_entities($self->{write}->Contents)) { 96 | $self->{write}->configure(-foreground => $self->{warn_color}) 97 | unless $self->{write}->cget('-foreground') 98 | eq $self->{warn_color}; 99 | } else { 100 | $self->{write}->configure(-foreground => $self->{fg_color}) 101 | if $self->{write}->cget('-foreground') 102 | eq $self->{warn_color}; 103 | } 104 | }); 105 | }); 106 | 107 | my $cb_paste = sub { 108 | my $paste = eval { $write->SelectionGet } 109 | // eval { $write->SelectionGet(-selection => 'CLIPBOARD') }; 110 | $write->insert('insert', $paste) if length $paste; 111 | }; 112 | $write->bind("<$_>", $cb_paste) for split ' ', $self->{paste_keys}; 113 | 114 | my $button_f = $mw->Frame->pack; 115 | my $send_b = $button_f->Button(-text => 'Send', 116 | -command => sub { $self->send }, 117 | )->pack(-side => 'left'); 118 | $mw->bind("<$_>", sub { $write->delete('insert - 1 char'); 119 | $send_b->invoke } 120 | ) for qw( Return KP_Enter ); 121 | 122 | my $seen_b = $button_f->Button(-text => 'Seen', 123 | -command => sub { $self->seen }, 124 | -underline => 0, 125 | )->pack(-side => 'left'); 126 | $mw->bind('<Alt-s>', sub { $seen_b->invoke }); 127 | 128 | my $save_b = $button_f->Button( 129 | -text => 'Save', 130 | -command => sub { $self->save }, 131 | -underline => 1 132 | )->pack(-side => 'left'); 133 | $mw->bind('<Alt-a>', sub { $save_b->invoke }); 134 | 135 | $self->{opt_b} = my $opt_b = $button_f->Button( 136 | -text => 'Options', 137 | -command => sub { 138 | $self->show_options; 139 | }, 140 | -underline => 0, 141 | )->pack(-side => 'left'); 142 | $mw->bind('<Alt-o>', sub { $opt_b->invoke }); 143 | 144 | my $list_b = $button_f->Button( 145 | -text => 'List Monks', 146 | -command => sub { $self->list_monks }, 147 | -underline => 0, 148 | )->pack(-side => 'left'); 149 | $mw->bind('<Alt-l>', sub { $list_b->invoke }); 150 | 151 | my $help_b = $self->{opt_h} = $button_f->Button( 152 | -text => 'Help', 153 | -command => sub { $self->help }, 154 | -underline => 0, 155 | )->pack(-side => 'left'); 156 | $mw->bind('<Alt-h>', sub { $help_b->invoke }); 157 | 158 | my $quit_b = $button_f->Button(-text => 'Quit', 159 | -command => sub { $self->quit }, 160 | -underline => 0, 161 | )->pack(-side => 'left'); 162 | $mw->bind('<Alt-q>', sub { $quit_b->invoke }); 163 | 164 | $mw->bind('<Prior>', 165 | sub { $self->{read}->yviewScroll(-1, 'pages')}); 166 | $mw->bind('<Next>', 167 | sub { $self->{read}->yviewScroll( 1, 'pages')}); 168 | 169 | $self->{history} = [""]; 170 | $self->{history_index} = -1; 171 | $mw->bind('<Alt-comma>', 172 | sub { 173 | $self->{history_index}-- 174 | unless $self->{history_index} <= -@{ $self->{history} }; 175 | $write->Contents( 176 | $self->{history}[ $self->{history_index} ] 177 | ); 178 | }); 179 | $mw->bind('<Alt-period>', 180 | sub { 181 | $self->{history_index}++ 182 | unless $self->{history_index} == -1; 183 | $write->Contents( 184 | $self->{history}[ $self->{history_index} ] 185 | ); 186 | }); 187 | 188 | $mw->repeat(1000, sub { 189 | my $msg; 190 | my %dispatch = ( 191 | time => sub { $self->update_time($msg->[0], $tzoffset, 192 | $msg->[1]) }, 193 | login => sub { $self->login_dialog }, 194 | chat => sub { $self->show_message($tzoffset, @$msg) }, 195 | private => sub { $self->show_private(@$msg, $tzoffset) }, 196 | delete => sub { $self->deleted(@$msg) }, 197 | title => sub { $self->show_title(@$msg) }, 198 | shortcut => sub { $self->show_shortcut(@$msg) }, 199 | send_login => sub { $self->send_login }, 200 | url => sub { $self->{pm_url} = $msg->[0] }, 201 | list => sub { $self->show_list(@$msg) }, 202 | quit => sub { $self->{control_t}->join; Tk::exit() }, 203 | 204 | ); 205 | while ($msg = $self->{from_comm}->dequeue_nb) { 206 | my $type = shift @$msg; 207 | $dispatch{$type}->(); 208 | } 209 | if ($self->{alert} && defined $self->{mw}->focusCurrent) { 210 | delete $self->{alert}; 211 | $self->blink_icon(1); 212 | } 213 | $self->blink_icon if $self->{alert}; 214 | }); 215 | 216 | $mw->repeat(10_000, sub { 217 | # Ask just one not to overload the server. 218 | if (my $id = (shuffle(keys %{ $self->{ids} }))[0]) { 219 | warn "PMCB: Reasking id $id"; 220 | $self->ask_title($id, $self->{ids}{$id}{name}); 221 | if (++$self->{ids}{$id}{count} > REASK_THRESHOLD) { 222 | warn "PMCB: Asked 10 times for $id ($self->{ids}{$id}{name})"; 223 | $self->show_title( 224 | $id, $self->{ids}{$id}{name}, $self->{ids}{$id}{name}); 225 | } 226 | } 227 | 228 | if (my $shortcut = (shuffle(keys %{ $self->{shortcuts} }))[0]) { 229 | warn "PMCB: Reasking shortcut $shortcut"; 230 | $self->ask_shortcut($shortcut, 231 | $self->{shortcuts}{$shortcut}{title}); 232 | if (++$self->{shortcuts}{$shortcut}{count} > REASK_THRESHOLD) { 233 | warn "PMCB: Asked 10 times for $shortcut " 234 | . "($self->{shortcuts}{$shortcut}{title})"; 235 | $self->show_shortcut( 236 | $shortcut, $self->{shortcuts}{$shortcut}{title}, 237 | $self->{shortcuts}{$shortcut}{title}); 238 | } 239 | } 240 | }); 241 | 242 | if (length $self->{log}) { 243 | if (open my $from, '<:encoding(UTF-8)', $self->{log}) { 244 | my $pos = 0; 245 | while (<$from>) { 246 | $pos = tell $from if /\N{LINE SEPARATOR}/; 247 | } 248 | seek $from, $pos, 0; 249 | $self->{read}->insert('end', $_, ['seen']) while <$from>; 250 | $self->{read}->see('end'); 251 | } 252 | 253 | open $self->{log_fh}, '>>:encoding(UTF-8)', $self->{log} 254 | or die "$self->{log}: $!"; 255 | print { $self->{log_fh} } "\N{LINE SEPARATOR}"; 256 | } 257 | 258 | $mw->after(1, sub { $self->login_dialog; $self->{write}->focus; }); 259 | 260 | Tk::MainLoop(); 261 | } 262 | 263 | 264 | sub send { 265 | my ($self) = @_; 266 | my $write = $self->{write}; 267 | $self->{to_comm}->enqueue([ send => $write->Contents ]); 268 | splice @{ $self->{history} }, -1, 0, $write->Contents; 269 | shift @{ $self->{history} } if HISTORY_SIZE < @{ $self->{history} }; 270 | $self->{history_index} = -1; 271 | $write->Contents(q()); 272 | } 273 | 274 | 275 | sub list_monks { 276 | my ($self) = @_; 277 | $self->{to_comm}->enqueue(['list']); 278 | } 279 | 280 | 281 | sub show_options { 282 | my ($self) = @_; 283 | $self->{opt_b}->configure(-state => 'disabled'); 284 | my $opt_w = $self->{mw}->Toplevel(-title => TITLE . ' Options'); 285 | 286 | $self->{to_comm}->enqueue(['url']) 287 | if $self->{random_url} || ! exists $self->{pm_url}; 288 | 289 | my $opt_f = $opt_w->Frame(-relief => 'groove', -borderwidth => 2) 290 | ->pack(-padx => 5, -pady => 5); 291 | 292 | my @opts = ( 293 | [ 'Font Size' => 'char_size' ], 294 | [ 'Font Family' => 'font_name' ], 295 | [ 'Background Color' => 'bg_color' ], 296 | [ 'Foreground Color' => 'fg_color' ], 297 | [ 'Author Color' => 'author_color' ], 298 | [ 'Private Color' => 'private_color' ], 299 | [ 'Gesture Color' => 'gesture_color' ], 300 | [ 'Timestamp Color' => 'time_color' ], 301 | [ 'Seen Color' => 'seen_color' ], 302 | [ 'Warn Color' => 'warn_color' ], 303 | [ 'Browser URL' => 'browse_url' ], 304 | [ 'Copy Link' => 'copy_link' ], 305 | [ 'Paste keys' => 'paste_keys' ], 306 | ); 307 | 308 | my $new; 309 | for my $opt (@opts) { 310 | my $f = $opt_f->Frame->pack(-fill => 'x'); 311 | $f->Label(-text => $opt->[0])->pack(-side => 'left'); 312 | $f->Entry( 313 | -textvariable => \($new->{ $opt->[1] } = $self->{ $opt->[1] }) 314 | )->pack(-side => 'right'); 315 | } 316 | 317 | my $old_pm_url = $self->{pm_url} // q(); 318 | my $old_random = $self->{random_url}; 319 | my $new_random = $old_random; 320 | my $f = $opt_f->Frame->pack(-fill => 'x'); 321 | $f->Label(-text => 'PerlMonks URL')->pack(-side => 'left'); 322 | my $e; 323 | $f->Checkbutton( 324 | -variable => \$new_random, 325 | -text => 'Random', 326 | -command => sub { 327 | $e->configure(-state => $new_random 328 | ? 'disabled' : 'normal' ) 329 | } 330 | )->pack(-side => 'left'); 331 | $e = $f->Entry(-textvariable => \ my $new_pm_url, 332 | -state => $new_random ? 'disabled' : 'normal') 333 | ->pack(-side => 'right'); 334 | my $wait_for_url; 335 | $wait_for_url = $self->{mw}->repeat(250, sub { 336 | if (defined $self->{pm_url}) { 337 | $wait_for_url->cancel; 338 | $old_pm_url = $self->{pm_url} 339 | if "" eq ($old_pm_url // 'closed too quickly'); 340 | $new_pm_url = $old_pm_url 341 | if "" eq ($new_pm_url // ""); 342 | } 343 | }); 344 | 345 | my $time_f = $opt_f->Frame->pack(-fill => 'x'); 346 | $opt_f->Label(-text => 'Show Timestamps')->pack(-side => 'left'); 347 | $opt_f->Checkbutton(-variable => \(my $show_time = ! $self->{no_time})) 348 | ->pack(-side => 'right'); 349 | 350 | my $info_f = $opt_w->Frame(-relief => 'groove', -borderwidth => 2) 351 | ->pack(-padx => 5, -pady => 5); 352 | $info_f->Label( 353 | -justify => 'left', 354 | -text => join "\n", 355 | 'Threading model:', 356 | ($self->{mce} && $self->{mce}{hobo} 357 | ? ('MCE::Hobo ' . $MCE::Hobo::VERSION, 358 | 'MCE::Shared ' . $MCE::Shared::VERSION) 359 | : $self->{mce} && $self->{mce}{child} 360 | ? ('MCE::Child ' . $MCE::Child::VERSION, 361 | 'MCE::Channel ' . $MCE::Channel::VERSION) 362 | : ('threads ' . $threads::VERSION, 363 | 'Thread::Queue ' . $Thread::Queue::VERSION) 364 | ), 365 | ('Stack size: ' . 2 ** $self->{stack_size}) x ! $self->{mce}, 366 | 'Geometry: ' . $self->{mw}->geometry, 367 | $self->{log_fh} ? 'Log file: ' . $self->{log} : (), 368 | )->pack(-side => 'left', -padx => 5); 369 | 370 | my $button_f = $opt_w->Frame->pack(-padx => 5, -pady => 5); 371 | my $apply_b = $button_f->Button( 372 | -text => 'Apply', 373 | -underline => 0, 374 | -command => sub{ 375 | $new->{random_url} = $new_random if $new_random != $old_random; 376 | $new->{pm_url} = $new_pm_url 377 | if length $new_pm_url && $old_pm_url ne $new_pm_url; 378 | $self->update_options($show_time, $new); 379 | $opt_w->destroy; 380 | $self->{opt_b}->configure(-state => 'normal'); 381 | }, 382 | )->pack(-side => 'left'); 383 | $opt_w->bind('<Alt-a>', sub { $apply_b->invoke }); 384 | 385 | my $cancel_b = $button_f->Button( 386 | -text => 'Cancel', 387 | -command => my $cancel_s = sub { 388 | $opt_w->destroy; 389 | $self->{opt_b}->configure(-state => 'normal'); 390 | }, 391 | )->pack(-side => 'left'); 392 | $opt_w->bind('<Escape>', $cancel_s); 393 | $opt_w->protocol(WM_DELETE_WINDOW => $cancel_s); 394 | } 395 | 396 | 397 | sub update_options { 398 | my ($self, $show_time, $new) = @_; 399 | 400 | my %old = (pm_url => $self->{pm_url}, 401 | random_url => $self->{random_url}, 402 | fg_color => $self->{fg_color}, 403 | warn_color => $self->{warn_color}, 404 | map +($_ => [ split ' ', $self->{$_} ]), 405 | qw( copy_link paste_keys )); 406 | 407 | for my $opt (keys %$new) { 408 | $self->{$opt} = $new->{$opt} if ! exists $self->{$opt} 409 | || $self->{$opt} ne $new->{$opt}; 410 | } 411 | 412 | for my $tag (grep /^browse:/, $self->{read}->tagNames) { 413 | for my $old_event (@{ $old{copy_link} }) { 414 | my $binding = $self->{read}->tagBind($tag, "<$old_event>"); 415 | $self->{read}->tagBind($tag, "<$old_event>", ""); 416 | $self->{read}->tagBind($tag, "<$_>", $binding) 417 | for split ' ', $self->{copy_link}; 418 | } 419 | } 420 | for my $old_event (@{ $old{paste_keys} }) { 421 | my $binding = $self->{write}->bind("<$old_event>"); 422 | $self->{write}->bind("<$old_event>", ""); 423 | $self->{write}->bind("<$_>", $binding) 424 | for split ' ', $self->{paste_keys}; 425 | } 426 | 427 | $self->{mw}->optionAdd('*font', "$self->{font_name} $self->{char_size}"); 428 | for my $part (qw( read write last_update )) { 429 | $self->{$part}->configure( 430 | -font => $self->{mw}->fontCreate( 431 | -family => $self->{font_name}, 432 | -size => $self->{char_size}, 433 | ), 434 | (-bg => $self->{bg_color}, 435 | -fg => $self->{fg_color}) x ('last_update' ne $part), 436 | ); 437 | } 438 | $self->{read}->tagConfigure(author => -foreground => $self->{author_color}); 439 | $self->{read}->tagConfigure(seen => -foreground => $self->{seen_color}); 440 | $self->{read}->tagConfigure(time => -foreground => $self->{time_color}); 441 | $self->{read}->tagConfigure( 442 | private => -foreground => $self->{private_color}); 443 | $self->{no_time} = ! $show_time; 444 | 445 | $self->{to_control}->enqueue(['random_url', $self->{random_url}]); 446 | if (($old{pm_url} // "") ne ($self->{pm_url} // "")) { 447 | $self->{to_comm}->enqueue(['url', $self->{pm_url}]); 448 | $self->send_login; 449 | } 450 | 451 | if ($self->{warn_color} eq $self->{fg_color}) { 452 | $self->{warn_color} 453 | = ($old{warn_color} eq $self->{warn_color}) 454 | ? $old{fg_color} : $old{warn_color}; 455 | } 456 | 457 | if ($self->{warn_color} ne $old{warn_color}) { 458 | $self->{write}->editModified(1); 459 | } 460 | } 461 | 462 | 463 | sub show_title { 464 | my ($self, $id, $name, $title) = @_; 465 | delete $self->{ids}{$id}; 466 | my $tag = "browse:$id|$name"; 467 | my ($from, $to) = ('1.0'); 468 | while (($from, $to) = $self->{read}->tagNextrange($tag, $from)) { 469 | $self->{read}->delete($from, $to); 470 | $self->{read}->insert($from, "[$title]", [$tag]); 471 | $from = $to; 472 | } 473 | } 474 | 475 | 476 | sub show_shortcut { 477 | my ($self, $shortcut, $url, $title) = @_; 478 | $url = "https://$self->{browse_url}/index.pl?node=$shortcut" 479 | if 0 == length $url; 480 | delete $self->{shortcuts}{$shortcut}; 481 | my $old_tag = "shortcut:$shortcut|$title"; 482 | my $new_tag = "browse:$url|$title"; 483 | my ($from, $to) = ('1.0'); 484 | while (($from, $to) = $self->{read}->tagNextrange($old_tag, $from)) { 485 | $self->{read}->tagRemove("[$old_tag]", $from, $to); 486 | $self->{read}->delete($from, $to); 487 | 488 | $self->add_clickable($title, $new_tag, $from, $url); 489 | $from = $to; 490 | } 491 | } 492 | 493 | 494 | sub save { 495 | my ($self) = @_; 496 | my $file = $self->{mw}->getSaveFile(-title => 'Save the history to a file'); 497 | return unless defined $file; 498 | 499 | if (open my $OUT, '>', $file) { 500 | print {$OUT} $self->{read}->Contents; 501 | } else { 502 | $self->{mw}->messageBox( 503 | -title => "Can't save", 504 | -icon => 'error', 505 | -message => "'$file' can't be opened for writing", 506 | -type => 'Ok' 507 | ); 508 | } 509 | } 510 | 511 | 512 | sub increment_unread { 513 | my ($self) = @_; 514 | my $title = $self->{mw}->cget('-title'); 515 | if ($title =~ s/([0-9]+)/$1 + 1/e) { 516 | $self->{mw}->configure(-title => $title); 517 | } else { 518 | $self->{mw}->configure(-title => '[1] ' . TITLE); 519 | } 520 | } 521 | 522 | 523 | sub seen { 524 | my ($self) = @_; 525 | while (my ($from, $to) = $self->{read}->tagNextrange('unseen', '1.0')) { 526 | $self->{read}->tagRemove('unseen', $from, $to); 527 | $self->{read}->tagAdd('seen', $from, $to); 528 | } 529 | $self->{last_update}->configure(-foreground => $self->{seen_color}); 530 | $self->{mw}->configure(-title => TITLE); 531 | } 532 | 533 | 534 | sub decode { 535 | my ($msg) = @_; 536 | 537 | $msg =~ s/&#(x?)([0-9a-f]+);/$1 ? chr hex $2 : chr $2/gei; 538 | $msg =~ s{([^\0-\x{FFFF}])}{ 539 | "\x{2997}" 540 | . (charnames::viacode(ord $1) 541 | // sprintf 'U+%X', ord $1) 542 | . "\x{2998}"}ge 543 | if grep $_ eq $^O, qw( MSWin32 darwin ); 544 | return $msg 545 | } 546 | 547 | 548 | sub show { 549 | my ($self, $timestamp, $author, $message, $type, $id) = @_; 550 | 551 | my $text = $self->{read}; 552 | $text->insert(end => "<$timestamp> ", ['time']) unless $self->{no_time}; 553 | my $author_separator = $type == GESTURE ? "" : ': '; 554 | $text->insert(end => "[$author]$author_separator", 555 | { (PRIVATE) => ['private', 556 | $id ? ("msg_$author", "deletemsg_$id") : ()], 557 | (PUBLIC) => ['author', "mention_$author"], 558 | (GESTURE) => ['gesture', "mention_$author"] }->{$type}); 559 | if ($id) { 560 | $self->{read}->tagBind("deletemsg_$id", '<Button-1>', 561 | sub { $self->{to_comm}->enqueue(['deletemsg', $id]) }); 562 | $self->{read}->tagBind("msg_$author", '<Button-2>', 563 | sub { $self->{write}->insert('1.0' => "/msg $author ") }) 564 | unless $self->{read}->tagBind("msg_$author"); 565 | } else { 566 | $self->{read}->tagBind("mention_$author", '<Button-2>', 567 | sub { $self->{write}->insert('1.0' => "[$author]: ") }) 568 | unless $self->{read}->tagBind("mention_$author"); 569 | } 570 | my ($line, $column) = split /\./, $text->index('end'); 571 | --$line; 572 | $column += (3 + length($timestamp)) * ! $self->{no_time} + 2 573 | + length($author_separator) + length $author; 574 | $text->insert(end => "$message\n", ['unseen']); 575 | 576 | $self->{log_fh}->printflush( 577 | "<$timestamp> [$author]$author_separator$message\n" 578 | ) if $self->{log_fh}; 579 | 580 | $self->{alert} = 1 if $id || $message =~ /$self->{username}/i; 581 | 582 | my $fix_length = 0; 583 | my $start_pos = 0; 584 | while ($message =~ m{ 585 | (.*?(?=($|<c(ode)?>))) # Non-greedy up to <code> or end of line 586 | ( 587 | ($ | # followed by end of line 588 | <(c|code)> # or <c> or <code> 589 | .*? # some stuff 590 | </ \g{-1} > # and </c> or </code> as per above 591 | ) 592 | )? 593 | }gx) { 594 | my $not_code = $1; 595 | while ($not_code =~ m{\[(\s*(?: 596 | https? 597 | | (?:meta)?mod | doc 598 | | id | node | href 599 | | pad 600 | )://.+?\s*|[^\]]+)\]}gix 601 | ) { 602 | my $orig = $1; 603 | my ($url, $name) = split /\|/, $orig; 604 | my $pos = $start_pos + pos $not_code; 605 | my $from = $line . '.' 606 | . ($column + $pos 607 | - length(length $name ? "[$url|$name]" : "[$url]") 608 | - $fix_length); 609 | my $to = $line . '.' . ($column - $fix_length + $pos); 610 | $text->delete($from, $to); 611 | 612 | $name = $url unless length $name; 613 | s/^\s+//, s/\s+$// for $name, $url; 614 | $url =~ s{^(?:(?:meta)?mod|doc)://}{http://p3rl.org/}i; 615 | $url =~ s{^pad://([^|\]]*)} 616 | {length $1 617 | ? $self->url("__PM_CB_URL__$1's+scratchpad") 618 | : $self->url("__PM_CB_URL__$author\'s+scratchpad")}ie; 619 | $url =~ s{^href://}{ $self->url("__PM_CB_URL__", "") }ie; 620 | $url =~ s{^node://}{ $self->url("__PM_CB_URL__") }ie; 621 | 622 | my $tag = "browse:$url|$name"; 623 | 624 | if ($url =~ m{^id://([0-9]+)}i) { 625 | my $id = $1; 626 | $self->ask_title($id, $url) if $name eq $url; 627 | $url =~ s{^id://[0-9]+}{ $self->url("__PM_CB_URL__$id", '?node_id=') }ie; 628 | $tag = "browse:$id|$name"; 629 | 630 | } elsif ($url =~ m{://} && $url !~ m{^https?://}i 631 | && $orig =~ /^\Q$url\E\|?/ 632 | ) { 633 | $name =~ s{^.+?://}{} if $name eq $url; 634 | $self->ask_shortcut($url, $name); 635 | $tag = "shortcut:$url|$name"; 636 | 637 | } else { 638 | substr $url, 0, 0, '__PM_CB_URL__' unless $url =~ m{^https?://}i; 639 | $tag = "browse:$url|$name"; 640 | } 641 | 642 | $fix_length += length($orig) - length($name); 643 | 644 | $self->add_clickable($name, $tag, $from, $url); 645 | } 646 | $start_pos = pos $message; 647 | } 648 | $text->see('end'); 649 | } 650 | 651 | 652 | sub add_clickable { 653 | my ($self, $name, $tag, $from, $url) = @_; 654 | my $text = $self->{read}; 655 | $text->tagConfigure($tag => -underline => 1); 656 | $text->insert($from, "[$name]", [$tag]); 657 | $text->tagBind($tag, '<Enter>', 658 | sub { $self->{balloon}->attach( 659 | $text, 660 | -balloonmsg => $self->url($url), 661 | -state => 'balloon', 662 | -balloonposition => 'mouse') }); 663 | $text->tagBind($tag, '<Leave>', 664 | sub { $self->{balloon}->detach($text) }); 665 | $text->tagBind($tag, '<Button-1>', 666 | sub { $self->browse($url) }); 667 | $text->tagBind($tag, "<$_>", 668 | sub { $text->clipboardClear; 669 | $text->clipboardAppend($self->url($url)) } 670 | ) for split ' ', $self->{copy_link}; 671 | } 672 | 673 | 674 | sub deleted { 675 | my ($self, $id) = @_; 676 | $self->{read}->tagConfigure("deletemsg_$id" => -overstrike => 1); 677 | $self->{read}->tagBind("deletemsg_$id", '<Button-1>', undef); 678 | } 679 | 680 | 681 | sub show_list { 682 | my ($self, @monks) = @_; 683 | $self->{read}->insert('end', '[Active Monks]', ['private']); 684 | for my $monk (@monks) { 685 | $self->{read}->insert('end', ' '); 686 | $self->add_clickable("$monk", "browse:$monk", 'end', 687 | $self->url("__PM_CB_URL__$monk")); 688 | } 689 | $self->{read}->insert('end', "\n"); 690 | $self->{read}->see('end'); 691 | } 692 | 693 | 694 | sub ask_title { 695 | my ($self, $id, $name) = @_; 696 | $self->{ids}{$id}{name} = $name; 697 | $self->{to_comm}->enqueue(['title', $id, $name]); 698 | } 699 | 700 | 701 | sub ask_shortcut { 702 | my ($self, $shortcut, $title) = @_; 703 | $self->{shortcuts}{$shortcut}{title} = $title; 704 | $self->{to_comm}->enqueue(['shortcut', $shortcut, $title]); 705 | } 706 | 707 | 708 | sub browse { 709 | my ($self, $url) = @_; 710 | $url = $self->url($url); 711 | my $action = $self->{browser} 712 | ? sub { system qq{$self->{browser} "$url" &} } 713 | : {MSWin32 => sub { system 1, qq{start "$url" /b "$url"} }, 714 | darwin => sub { system qq{open "$url" &} }, 715 | }->{$^O} || sub { system qq{xdg-open "$url" &} }; 716 | $action->(); 717 | } 718 | 719 | 720 | sub show_message { 721 | my ($self, $tzoffset, $timestamp, $author, $message) = @_; 722 | 723 | my $type = $message =~ s{^/me(?=\s|')}{} ? GESTURE : PUBLIC; 724 | $message = decode($message); 725 | $timestamp = convert_time($timestamp, $tzoffset) 726 | ->strftime('%Y-%m-%d %H:%M:%S'); 727 | 728 | substr $timestamp, 0, 11, q() if 0 == index $timestamp, $self->{last_date}; 729 | $self->show($timestamp, $author, $message, $type); 730 | $self->increment_unread; 731 | } 732 | 733 | 734 | sub show_private { 735 | my ($self, $author, $time, $msg, $id, $tzoffset) = @_; 736 | $msg = decode($msg); 737 | $msg =~ s/[\n\r]//g; 738 | 739 | if (defined $time) { 740 | local $ENV{TZ} = 'America/New_York'; 741 | my $est = Time::Piece::localtime()->tzoffset; 742 | $time = 'Time::Piece'->strptime($time, '%Y-%m-%d %H:%M:%S') 743 | - $est + $tzoffset; 744 | } else { 745 | $time = Time::Piece::localtime(); 746 | } 747 | $time = $time->strftime('%Y-%m-%d %H:%M:%S'); 748 | 749 | $self->show($time, $author, $msg, PRIVATE, $id); 750 | $self->increment_unread if $id; 751 | } 752 | 753 | 754 | sub convert_time { 755 | my ($server_time, $tzoffset) = @_; 756 | my $local_time = 'Time::Piece'->strptime( 757 | $server_time, '%Y-%m-%d %H:%M:%S' 758 | ) + $tzoffset; # Assumption: Server time is in UTC. 759 | return $local_time 760 | } 761 | 762 | 763 | sub update_time { 764 | my ($self, $server_time, $tzoffset, $should_update) = @_; 765 | my $local_time = convert_time($server_time, $tzoffset); 766 | $self->{last_update}->configure( 767 | -text => 'Last update: ' 768 | . $local_time->strftime('%Y-%m-%d %H:%M:%S'), 769 | -foreground => 'black'); 770 | $self->{last_date} = $local_time->strftime('%Y-%m-%d') if $should_update; 771 | } 772 | 773 | 774 | { my ($login, $password); 775 | sub send_login { 776 | my ($self) = @_; 777 | $self->{username} = $login; 778 | $self->{to_comm}->enqueue([ 'login', $login, $password ]); 779 | } 780 | 781 | 782 | sub login_dialog { 783 | my ($self) = @_; 784 | 785 | my $dialog = $self->{mw}->Dialog( 786 | -title => 'Login', 787 | -default_button => 'Login', 788 | -buttons => [qw[ Login Cancel ]]); 789 | 790 | my $username_f = $dialog->Frame->pack(-fill => 'both'); 791 | $username_f->Label(-text => 'Username: ') 792 | ->pack(-side => 'left', -fill => 'x'); 793 | my $username_e = $username_f->Entry->pack(-side => 'left'); 794 | $username_e->focus; 795 | 796 | my $password_f = $dialog->Frame->pack(-fill => 'both'); 797 | $password_f->Label(-text => 'Password: ') 798 | ->pack(-side => 'left', -fill => 'x'); 799 | my $password_e = $password_f->Entry(-show => '*') 800 | ->pack(-side => 'right'); 801 | 802 | my $reply = $dialog->Show; 803 | if ('Cancel' eq $reply) { 804 | $self->quit; 805 | return 806 | } 807 | 808 | ($login, $password) = ($username_e->get, $password_e->get); 809 | $self->send_login; 810 | } 811 | } 812 | 813 | 814 | sub blink_icon { 815 | my ($self, $to_normal) = @_; 816 | $self->{mw}->idletasks; 817 | my $current_icon = $self->{mw}->iconname; 818 | return if $to_normal && 'normal' eq $current_icon; 819 | 820 | my $new_icon = qw( alert normal )[ $current_icon eq 'alert' ]; 821 | $self->{mw}->idletasks; 822 | $self->{mw}->iconimage($self->{ 823 | qw( icon icon_alert )[ $new_icon eq 'alert'] }); 824 | $self->{mw}->idletasks; 825 | $self->{mw}->iconname($new_icon); 826 | } 827 | 828 | 829 | sub quit { 830 | my ($self) = @_; 831 | print STDERR "Quitting...\n"; 832 | $self->{to_control}->insert(0, ['quit']); 833 | if ('MSWin32' ne $^O && $self->{mce}) { 834 | $self->{control_t}->kill('QUIT'); 835 | Tk::exit() 836 | } 837 | } 838 | 839 | 840 | sub help { 841 | my ($self) = @_; 842 | 843 | my @help = ( 844 | '<Alt+,> previous history item', 845 | '<Alt+.> next history item', 846 | '<{paste_keys}> paste clipboard', 847 | '<{copy_link}> copy link', 848 | '<Button-1> to delete a private message', 849 | '<Button-2> to reply to a message (both private and public', 850 | '<Esc> to exit help', 851 | ); 852 | $self->{opt_h}->configure(-state => 'disabled'); 853 | my $top = $self->{mw}->Toplevel(-title => TITLE . ' Help'); 854 | my $text = $top->ROText(height => 1 + @help)->pack; 855 | s/\{(.+?)\}/$self->{$1}/g for @help; 856 | $text->insert('end', "$_\n") for @help[ 0 .. $#help - 1 ]; 857 | $text->insert('end', "\n$help[-1]"); 858 | 859 | $top->bind('<Escape>', my $end = sub { 860 | $top->DESTROY; 861 | $self->{opt_h}->configure(-state => 'normal'); 862 | }); 863 | $top->protocol(WM_DELETE_WINDOW => $end); 864 | } 865 | 866 | __PACKAGE__ 867 | -------------------------------------------------------------------------------- /pm-cb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use warnings; 3 | use strict; 4 | use feature qw{ say }; 5 | 6 | use Term::ANSIColor; 7 | use Term::ReadKey; 8 | use XML::LibXML; 9 | use WWW::Mechanize; 10 | 11 | my $debug = @ARGV && '-d' eq shift; 12 | 13 | use constant { 14 | PM_URL => 'http://www.perlmonks.org/bare/index.pl?node_id=', 15 | FREQ => 7, 16 | # Node ids: 17 | LOGIN => 109, 18 | CB => 207304, 19 | }; 20 | 21 | 22 | print "User? "; 23 | chomp( my $user = <STDIN> ); 24 | ReadMode('noecho'); 25 | print "Pass? "; 26 | chomp( my $pass = <STDIN> ); 27 | ReadMode('normal'); 28 | say STDERR '*' x length $pass; 29 | 30 | my $mech = 'WWW::Mechanize'->new; 31 | $mech->get(PM_URL . LOGIN); 32 | 33 | $mech->submit_form( 34 | form_number => 1, 35 | fields => { user => $user, 36 | passwd => $pass, 37 | }); 38 | 39 | my %seen; 40 | my $from_id; 41 | my $previous; 42 | 43 | while (1) { 44 | my $url = PM_URL . CB; 45 | $url .= ";fromid=$from_id" if defined $from_id; 46 | $mech->get($url); 47 | 48 | my $xml = 'XML::LibXML'->load_xml(string => $mech->content); 49 | 50 | my $time = $xml->findvalue('/chatter/info/@gentimeGMT'); 51 | print STDERR colored(['bright_black'], $time), "\r"; 52 | 53 | my @messages = $xml->findnodes('/chatter/message'); 54 | 55 | my $first = 1; 56 | for my $message (@messages) { 57 | print "\n" and undef $first if $first; 58 | 59 | my $id = $message->findvalue('message_id'); 60 | if (exists $seen{$id}) { 61 | if ($debug) { 62 | say STDERR colored(['cyan'], "Duplicate msg $id (from $from_id"); 63 | say STDERR colored(['cyan'], $previous, "---\n", $xml); 64 | } 65 | 66 | } else { 67 | say colored(['bold blue'], 68 | '[', $message->findvalue('author'), '] '), 69 | $message->findvalue('text'); 70 | undef $seen{$id}; 71 | } 72 | } 73 | 74 | my $new_from_id = $xml->findvalue('/chatter/message[last()]/message_id'); 75 | $from_id = $new_from_id if length $new_from_id; 76 | 77 | $previous = $xml; 78 | sleep FREQ; 79 | } 80 | -------------------------------------------------------------------------------- /pm-cb-g: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use warnings; 3 | use strict; 4 | use Syntax::Construct qw{ // }; 5 | 6 | use FindBin; 7 | use lib "$FindBin::Bin/lib"; 8 | 9 | use Getopt::Long qw( :config no_ignore_case ); 10 | use Pod::Usage; 11 | 12 | use PM::CB::GUI; 13 | use PM::CB::Control; 14 | 15 | my ($bg_color, $fg_color, $author_color, $private_color, $gesture_color, 16 | $time_color, $font_name, $char_size, $stack_size, $seen_color, $warn_color, 17 | $no_time, $help, $pm_url, $browse_url, $random_url, $copy_link, 18 | $mce, $geometry, $log, $paste_keys, $browser); 19 | 20 | BEGIN { 21 | ($bg_color, $fg_color, $author_color, $private_color, $gesture_color, 22 | $time_color, $seen_color, $warn_color, $font_name, $char_size, $stack_size, 23 | $no_time, $help, $pm_url, $random_url, $copy_link) 24 | = qw( white black blue magenta darkgreen darkcyan darkgray red Helvetica 25 | 12 15 0 0 www.perlmonks.org 0 Control-Button-1 red); 26 | 27 | $paste_keys = 'Shift-Insert'; 28 | $paste_keys .= ' XF86Paste' if $^O ne 'MSWin32'; 29 | 30 | GetOptions( 31 | 'a|author_color=s' => \$author_color, 32 | 'b|bg_color=s' => \$bg_color, 33 | 'B|browser=s' => \$browser, 34 | 'c|char_size=i' => \$char_size, 35 | 'C|copy_link=s' => \$copy_link, 36 | 'f|fg_color=s' => \$fg_color, 37 | 'F|font_name=s' => \$font_name, 38 | 'g|gesture_color=s' => \$gesture_color, 39 | 'G|geometry=s' => \$geometry, 40 | 'h|help' => \$help, 41 | 'l|log=s' => \$log, 42 | 'm|mce_hobo' => \$mce->{hobo}, 43 | 'M|mce_child' => \$mce->{child}, 44 | 'n|no_time' => \$no_time, 45 | 'p|private_color=s' => \$private_color, 46 | 'P|paste_keys=s' => \$paste_keys, 47 | 'r|random_url' => \$random_url, 48 | 's|stack_size=i' => \$stack_size, 49 | 'S|seen_color=s' => \$seen_color, 50 | 't|time_color=s' => \$time_color, 51 | 'u|url=s' => \$pm_url, 52 | 'U|browse_url=s' => \$browse_url, 53 | 'w|warn_color=s' => \$warn_color, 54 | ) or pod2usage(-verbose => 0, -exitval => 1); 55 | $browse_url //= $pm_url; 56 | die "Can't combine mce_hobo and mce_child.\n" 57 | if $mce->{hobo} && $mce->{child}; 58 | $mce = {} unless $mce->{hobo} || $mce->{child}; 59 | 60 | $warn_color = 'red' if $warn_color eq $fg_color; 61 | $warn_color = 'orange' if $warn_color eq $fg_color; 62 | 63 | pod2usage(-verbose => 1, -exitval => 0) if $help; 64 | } 65 | 66 | 67 | use if $mce->{hobo} => 'MCE::Hobo'; 68 | use if $mce->{hobo} => 'MCE::Shared'; 69 | 70 | use if $mce->{child} => 'MCE::Child'; 71 | use if $mce->{child} => 'MCE::Channel'; 72 | 73 | use if ! %$mce => threads => (stack_size => 2 ** $stack_size); 74 | use if ! %$mce => 'Thread::Queue'; 75 | 76 | my ($queue_class, $queue_constructor, $worker_class) 77 | = @{ 78 | { 0 => [qw[ Thread::Queue new threads ]], 79 | 1 => [qw[ MCE::Shared queue MCE::Hobo ]], 80 | 2 => [qw[ MCE::Channel new MCE::Child ]], 81 | }->{ ($mce->{hobo} || 0) + 2 * ($mce->{child} || 0) } 82 | }; 83 | 84 | my ($to_gui, $to_comm, $to_control) 85 | = map $queue_class->$queue_constructor, 1, 2, 3; 86 | my $control_t = $worker_class->create(sub { 87 | my $control = 'PM::CB::Control'->new({to_gui => $to_gui, 88 | to_comm => $to_comm, 89 | from_gui => $to_control, 90 | worker_class => $worker_class, 91 | pm_url => $pm_url, 92 | random_url => $random_url}); 93 | $control->start_comm; 94 | }); 95 | 96 | my $gui = 'PM::CB::GUI'->new({ 97 | bg_color => $bg_color, 98 | fg_color => $fg_color, 99 | author_color => $author_color, 100 | private_color => $private_color, 101 | gesture_color => $gesture_color, 102 | time_color => $time_color, 103 | font_name => $font_name, 104 | char_size => $char_size, 105 | stack_size => $stack_size, 106 | seen_color => $seen_color, 107 | warn_color => $warn_color, 108 | mce => keys %$mce ? $mce : undef, 109 | no_time => $no_time, 110 | from_comm => $to_gui, 111 | to_comm => $to_comm, 112 | to_control => $to_control, 113 | control_t => $control_t, 114 | browse_url => $browse_url, 115 | browser => $browser, 116 | random_url => $random_url, 117 | geometry => $geometry, 118 | log => $log, 119 | copy_link => $copy_link, 120 | paste_keys => $paste_keys, 121 | icon_path => $FindBin::Bin}); 122 | 123 | $gui->gui; 124 | 125 | 126 | # MCE::Channel can only enqueue, it has no insert method. 127 | sub MCE::Channel::insert { 128 | my ($self, undef, $messages) = @_; 129 | $self->enqueue($messages); 130 | } 131 | 132 | 133 | =head1 NAME 134 | 135 | pm-cb-g - A GUI client to PerlMonks' Chatter Box 136 | 137 | =head1 SYNOPSIS 138 | 139 | pm-cb-g -a blue -b white -c 12 -f black -F Helvetica 140 | -p magenta -s 15 -S darkgray -t darkcyan -g darkgreen 141 | -u www.perlmonks.org -U www.perlmonks.org 142 | -C Control-Button-1 -l "" -B firefox 143 | [ -h -m/-M -n ] 144 | 145 | =head1 OPTIONS 146 | 147 | The default values are shown in the Synopsis above. 148 | 149 | For colors, use a color name or C<#RRGGBB> code. 150 | 151 | =over 152 | 153 | =item B<a|author_color> I<color> 154 | 155 | The color to display the names of authors of public messages. 156 | 157 | =item B<b|bg_color> I<color> 158 | 159 | The background color of the application. 160 | 161 | =item B<B|browser> I<command> 162 | 163 | The command ran to open urls. By default uses the system's default 164 | browser. 165 | 166 | =item B<c|char_size> I<size> 167 | 168 | The size of all the characters (integer). 169 | 170 | =item B<C|copy_link> I<event(s)> 171 | 172 | The event(s) that copies the link under mouse cursor to the clipboard. 173 | 174 | =item B<f|fg_color> I<color> 175 | 176 | The foreground colour of the new messages. 177 | 178 | =item B<F|font_name> I<font> 179 | 180 | The font for all the characters. 181 | 182 | =item B<g|gesture_color> I<color> 183 | 184 | The foreground colour to display the names of gesture authors (C</me>). 185 | 186 | =item B<G|geometry> I<width>xI<height>[+I<xpos>+I<ypos>] 187 | 188 | Geometry of the main window. Use the optimal geometry if none given. 189 | 190 | =item B<h|help> 191 | 192 | Prints options and arguments. 193 | 194 | =item B<l|log> I<filename> 195 | 196 | Save all messages to the given log file. Don't save any messages if 197 | the filename is empty. 198 | 199 | =item B<m|mce_hobo> 200 | 201 | Use L<MCE::Shared> and L<MCE::Hobo> instead of L<threads> and 202 | L<Thread::Queue>. 203 | 204 | =item B<M|mce_child> 205 | 206 | Use L<MCE::Child> and L<MCE::Channel> instead of L<threads> and 207 | L<Thread::Queue>. 208 | 209 | =item B<n|no_time> 210 | 211 | Don't show time stamps. 212 | 213 | =item B<p|private_color> I<color> 214 | 215 | The color for the authors of private messages. 216 | 217 | =item B<P|paste_keys> I<event(s)> 218 | 219 | The event(s) that paste text from the clipboard. 220 | 221 | =item B<r|random_url> 222 | 223 | Change the PM URL randomly time to time (should prevent lag). 224 | 225 | =item B<s|stack_size> I<size> 226 | 227 | Needed for L<threads>. Use a higher number if the program doesn't work 228 | with the default value. 229 | 230 | =item B<S|seen_color> I<color> 231 | 232 | The color for already read messages. 233 | 234 | =item B<t|time_color> I<color> 235 | 236 | The color for time stamps. 237 | 238 | =item B<u|url> I<[www.]perlmonks.(com|net|org)> 239 | 240 | The address to use to communicate with PerlMonks. 241 | 242 | =item B<U|browse_url> I<[www.]perlmonks.(com|net|org)> 243 | 244 | The address to use to open PerlMonks links in the browser. Same as 245 | B<url> if not specified. 246 | 247 | =item B<w|warn_color> I<color> 248 | 249 | The color that indicates a too long message. 250 | 251 | =back 252 | 253 | =head1 AUTHOR 254 | 255 | E. Choroba 256 | 257 | =head2 Contributors 258 | 259 | H.Merijn Brand, LorenzoTa, Mario Roy, Nick Tonkin, Steve Rogerson 260 | 261 | =cut 262 | -------------------------------------------------------------------------------- /pm.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char * pm_xpm[] = { 3 | "32 32 4 1", 4 | " c black", 5 | ". c #000080", 6 | "X c yellow", 7 | "o c brown", 8 | " ", 9 | " .............................. ", 10 | " .............................. ", 11 | " .............................. ", 12 | " XXXXX......................XXX ", 13 | " XXXXXX....................XXXX ", 14 | " ....XXX..................XX... ", 15 | " ......X..................X.... ", 16 | " ......XX................XX.... ", 17 | " ......XX................X..... ", 18 | " ...X...XX..............XX..... ", 19 | " ..XXX..XX............XXX...X.. ", 20 | " ...X...XX...........XX....XoX. ", 21 | " ........XX.........XX......XX. ", 22 | " ........XX.........XXXX....... ", 23 | " .........XX...........X....... ", 24 | " .........XX...........XX...... ", 25 | " ......XXXX............XXXX.... ", 26 | " .....XX..................XX... ", 27 | " ..XXXX....................XX.. ", 28 | " .XX.......................XX.. ", 29 | " ..XXXX...................XX... ", 30 | " .....XXX.............XXXXX.... ", 31 | " ......XX.............XX....... ", 32 | " ..X..XX...............XXX..... ", 33 | " XXXX.XX.................XXX... ", 34 | " XX..XX....................XXX. ", 35 | " X...........................XX ", 36 | " .............................X ", 37 | " .............................X ", 38 | " .............................. ", 39 | " "}; 40 | --------------------------------------------------------------------------------