├── lib └── PM │ └── CB │ ├── Common.pm │ ├── Control.pm │ ├── Communication.pm │ └── GUI.pm ├── cpanfile ├── README.md ├── pm-cb └── pm-cb-g /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/?node_id=', 15 | FREQ => 7, 16 | # Node ids: 17 | LOGIN => 109, 18 | CB => 207304, 19 | }; 20 | 21 | 22 | print "User? "; 23 | chomp( my $user = ); 24 | ReadMode('noecho'); 25 | print "Pass? "; 26 | chomp( my $pass = ); 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 | 122 | $gui->gui; 123 | 124 | 125 | # MCE::Channel can only enqueue, it has no insert method. 126 | sub MCE::Channel::insert { 127 | my ($self, undef, $messages) = @_; 128 | $self->enqueue($messages); 129 | } 130 | 131 | 132 | =head1 NAME 133 | 134 | pm-cb-g - A GUI client to PerlMonks' Chatter Box 135 | 136 | =head1 SYNOPSIS 137 | 138 | pm-cb-g -a blue -b white -c 12 -f black -F Helvetica 139 | -p magenta -s 15 -S darkgray -t darkcyan -g darkgreen 140 | -u www.perlmonks.org -U www.perlmonks.org 141 | -C Control-Button-1 -l "" -B firefox 142 | [ -h -m/-M -n ] 143 | 144 | =head1 OPTIONS 145 | 146 | The default values are shown in the Synopsis above. 147 | 148 | For colors, use a color name or C<#RRGGBB> code. 149 | 150 | =over 151 | 152 | =item B I 153 | 154 | The color to display the names of authors of public messages. 155 | 156 | =item B I 157 | 158 | The background color of the application. 159 | 160 | =item B I 161 | 162 | The command ran to open urls. By default uses the system's default 163 | browser. 164 | 165 | =item B I 166 | 167 | The size of all the characters (integer). 168 | 169 | =item B I 170 | 171 | The event(s) that copies the link under mouse cursor to the clipboard. 172 | 173 | =item B I 174 | 175 | The foreground colour of the new messages. 176 | 177 | =item B I 178 | 179 | The font for all the characters. 180 | 181 | =item B I 182 | 183 | The foreground colour to display the names of gesture authors (C). 184 | 185 | =item B IxI[+I+I] 186 | 187 | Geometry of the main window. Use the optimal geometry if none given. 188 | 189 | =item B 190 | 191 | Prints options and arguments. 192 | 193 | =item B I 194 | 195 | Save all messages to the given log file. Don't save any messages if 196 | the filename is empty. 197 | 198 | =item B 199 | 200 | Use L and L instead of L and 201 | L. 202 | 203 | =item B 204 | 205 | Use L and L instead of L and 206 | L. 207 | 208 | =item B 209 | 210 | Don't show time stamps. 211 | 212 | =item B I 213 | 214 | The color for the authors of private messages. 215 | 216 | =item B I 217 | 218 | The event(s) that paste text from the clipboard. 219 | 220 | =item B 221 | 222 | Change the PM URL randomly time to time (should prevent lag). 223 | 224 | =item B I 225 | 226 | Needed for L. Use a higher number if the program doesn't work 227 | with the default value. 228 | 229 | =item B I 230 | 231 | The color for already read messages. 232 | 233 | =item B I 234 | 235 | The color for time stamps. 236 | 237 | =item B I<[www.]perlmonks.(com|net|org)> 238 | 239 | The address to use to communicate with PerlMonks. 240 | 241 | =item B I<[www.]perlmonks.(com|net|org)> 242 | 243 | The address to use to open PerlMonks links in the browser. Same as 244 | B if not specified. 245 | 246 | =item B I 247 | 248 | The color that indicates a too long message. 249 | 250 | =back 251 | 252 | =head1 AUTHOR 253 | 254 | E. Choroba 255 | 256 | =head2 Contributors 257 | 258 | H.Merijn Brand, LorenzoTa, Mario Roy, Nick Tonkin, Steve Rogerson 259 | 260 | =cut 261 | -------------------------------------------------------------------------------- /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/?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/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}/$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 | 55 | my $read_f = $mw->Frame->pack(-expand => 1, -fill => 'both'); 56 | $self->{read} = my $read 57 | = $read_f->ROText(-background => $self->{bg_color}, 58 | -foreground => $self->{fg_color}, 59 | -wrap => 'word') 60 | ->pack(-expand => 1, -fill => 'both'); 61 | $read->tagConfigure(author => -foreground => $self->{author_color}); 62 | $read->tagConfigure(private => -foreground => $self->{private_color}); 63 | $read->tagConfigure(gesture => -foreground => $self->{gesture_color}); 64 | $read->tagConfigure(seen => -foreground => $self->{seen_color}); 65 | $read->tagConfigure(time => -foreground => $self->{time_color}); 66 | 67 | my $balloon = $self->{balloon} = $mw->Balloon; 68 | 69 | my $last_update_f = $mw->Frame->pack; 70 | $self->{last_update} = my $last_update 71 | = $last_update_f->Label(-text => 'No update yet', 72 | -foreground => 'black') 73 | ->pack(-side => 'left'); 74 | 75 | my $write_f = $mw->Frame->pack(-fill => 'x'); 76 | $self->{write} = my $write = $write_f->Text( 77 | -height => 3, 78 | -background => $self->{bg_color}, 79 | -foreground => $self->{fg_color}, 80 | -insertbackground => $self->{fg_color}, 81 | -wrap => 'word', 82 | )->pack(-fill => 'x'); 83 | $self->{write}->bind('<<Modified>>', sub { 84 | return unless $self->{write}->editModified; 85 | 86 | $self->{write}->editModified(0); 87 | 88 | # We can't check the length immediately, because when deleting 89 | # characters, the old length is returned. 90 | $mw->after(10, sub { 91 | if (CHAR_LIMIT < length to_entities($self->{write}->Contents)) { 92 | $self->{write}->configure(-foreground => $self->{warn_color}) 93 | unless $self->{write}->cget('-foreground') 94 | eq $self->{warn_color}; 95 | } else { 96 | $self->{write}->configure(-foreground => $self->{fg_color}) 97 | if $self->{write}->cget('-foreground') 98 | eq $self->{warn_color}; 99 | } 100 | }); 101 | }); 102 | 103 | my $cb_paste = sub { 104 | my $paste = eval { $write->SelectionGet } 105 | // eval { $write->SelectionGet(-selection => 'CLIPBOARD') }; 106 | $write->insert('insert', $paste) if length $paste; 107 | }; 108 | $write->bind("<$_>", $cb_paste) for split ' ', $self->{paste_keys}; 109 | 110 | my $button_f = $mw->Frame->pack; 111 | my $send_b = $button_f->Button(-text => 'Send', 112 | -command => sub { $self->send }, 113 | )->pack(-side => 'left'); 114 | $mw->bind("<$_>", sub { $write->delete('insert - 1 char'); 115 | $send_b->invoke } 116 | ) for qw( Return KP_Enter ); 117 | 118 | my $seen_b = $button_f->Button(-text => 'Seen', 119 | -command => sub { $self->seen }, 120 | -underline => 0, 121 | )->pack(-side => 'left'); 122 | $mw->bind('<Alt-s>', sub { $seen_b->invoke }); 123 | 124 | my $save_b = $button_f->Button( 125 | -text => 'Save', 126 | -command => sub { $self->save }, 127 | -underline => 1 128 | )->pack(-side => 'left'); 129 | $mw->bind('<Alt-a>', sub { $save_b->invoke }); 130 | 131 | $self->{opt_b} = my $opt_b = $button_f->Button( 132 | -text => 'Options', 133 | -command => sub { 134 | $self->show_options; 135 | }, 136 | -underline => 0, 137 | )->pack(-side => 'left'); 138 | $mw->bind('<Alt-o>', sub { $opt_b->invoke }); 139 | 140 | my $list_b = $button_f->Button( 141 | -text => 'List Monks', 142 | -command => sub { $self->list_monks }, 143 | -underline => 0, 144 | )->pack(-side => 'left'); 145 | $mw->bind('<Alt-l>', sub { $list_b->invoke }); 146 | 147 | my $help_b = $self->{opt_h} = $button_f->Button( 148 | -text => 'Help', 149 | -command => sub { $self->help }, 150 | -underline => 0, 151 | )->pack(-side => 'left'); 152 | $mw->bind('<Alt-h>', sub { $help_b->invoke }); 153 | 154 | my $quit_b = $button_f->Button(-text => 'Quit', 155 | -command => sub { $self->quit }, 156 | -underline => 0, 157 | )->pack(-side => 'left'); 158 | $mw->bind('<Alt-q>', sub { $quit_b->invoke }); 159 | 160 | $mw->bind('<Prior>', 161 | sub { $self->{read}->yviewScroll(-1, 'pages')}); 162 | $mw->bind('<Next>', 163 | sub { $self->{read}->yviewScroll( 1, 'pages')}); 164 | 165 | $self->{history} = [""]; 166 | $self->{history_index} = -1; 167 | $mw->bind('<Alt-comma>', 168 | sub { 169 | $self->{history_index}-- 170 | unless $self->{history_index} <= -@{ $self->{history} }; 171 | $write->Contents( 172 | $self->{history}[ $self->{history_index} ] 173 | ); 174 | }); 175 | $mw->bind('<Alt-period>', 176 | sub { 177 | $self->{history_index}++ 178 | unless $self->{history_index} == -1; 179 | $write->Contents( 180 | $self->{history}[ $self->{history_index} ] 181 | ); 182 | }); 183 | 184 | my ($username, $password); 185 | 186 | $mw->repeat(1000, sub { 187 | my $msg; 188 | my %dispatch = ( 189 | time => sub { $self->update_time($msg->[0], $tzoffset, 190 | $msg->[1]) }, 191 | login => sub { $self->login_dialog }, 192 | chat => sub { $self->show_message($tzoffset, @$msg); 193 | $self->increment_unread; }, 194 | private => sub { $self->show_private(@$msg, $tzoffset); 195 | $self->increment_unread; }, 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 | }); 210 | 211 | $mw->repeat(10_000, sub { 212 | # Ask just one not to overload the server. 213 | if (my $id = (shuffle(keys %{ $self->{ids} }))[0]) { 214 | warn "PMCB: Reasking id $id"; 215 | $self->ask_title($id, $self->{ids}{$id}{name}); 216 | if (++$self->{ids}{$id}{count} > REASK_THRESHOLD) { 217 | warn "PMCB: Asked 10 times for $id ($self->{ids}{$id}{name})"; 218 | $self->show_title( 219 | $id, $self->{ids}{$id}{name}, $self->{ids}{$id}{name}); 220 | } 221 | } 222 | 223 | if (my $shortcut = (shuffle(keys %{ $self->{shortcuts} }))[0]) { 224 | warn "PMCB: Reasking shortcut $shortcut"; 225 | $self->ask_shortcut($shortcut, 226 | $self->{shortcuts}{$shortcut}{title}); 227 | if (++$self->{shortcuts}{$shortcut}{count} > REASK_THRESHOLD) { 228 | warn "PMCB: Asked 10 times for $shortcut " 229 | . "($self->{shortcuts}{$shortcut}{title})"; 230 | $self->show_shortcut( 231 | $shortcut, $self->{shortcuts}{$shortcut}{title}, 232 | $self->{shortcuts}{$shortcut}{title}); 233 | } 234 | } 235 | }); 236 | 237 | if (length $self->{log}) { 238 | if (open my $from, '<:encoding(UTF-8)', $self->{log}) { 239 | my $pos = 0; 240 | while (<$from>) { 241 | $pos = tell $from if /\N{LINE SEPARATOR}/; 242 | } 243 | seek $from, $pos, 0; 244 | $self->{read}->insert('end', $_, ['seen']) while <$from>; 245 | $self->{read}->see('end'); 246 | } 247 | 248 | open $self->{log_fh}, '>>:encoding(UTF-8)', $self->{log} 249 | or die "$self->{log}: $!"; 250 | print { $self->{log_fh} } "\N{LINE SEPARATOR}"; 251 | } 252 | 253 | $mw->after(1, sub { $self->login_dialog; $self->{write}->focus; }); 254 | 255 | Tk::MainLoop(); 256 | } 257 | 258 | 259 | sub send { 260 | my ($self) = @_; 261 | my $write = $self->{write}; 262 | $self->{to_comm}->enqueue([ send => $write->Contents ]); 263 | splice @{ $self->{history} }, -1, 0, $write->Contents; 264 | shift @{ $self->{history} } if HISTORY_SIZE < @{ $self->{history} }; 265 | $self->{history_index} = -1; 266 | $write->Contents(q()); 267 | } 268 | 269 | 270 | sub list_monks { 271 | my ($self) = @_; 272 | $self->{to_comm}->enqueue(['list']); 273 | } 274 | 275 | 276 | sub show_options { 277 | my ($self) = @_; 278 | $self->{opt_b}->configure(-state => 'disabled'); 279 | my $opt_w = $self->{mw}->Toplevel(-title => TITLE . ' Options'); 280 | 281 | $self->{to_comm}->enqueue(['url']) 282 | if $self->{random_url} || ! exists $self->{pm_url}; 283 | 284 | my $opt_f = $opt_w->Frame(-relief => 'groove', -borderwidth => 2) 285 | ->pack(-padx => 5, -pady => 5); 286 | 287 | my @opts = ( 288 | [ 'Font Size' => 'char_size' ], 289 | [ 'Font Family' => 'font_name' ], 290 | [ 'Background Color' => 'bg_color' ], 291 | [ 'Foreground Color' => 'fg_color' ], 292 | [ 'Author Color' => 'author_color' ], 293 | [ 'Private Color' => 'private_color' ], 294 | [ 'Gesture Color' => 'gesture_color' ], 295 | [ 'Timestamp Color' => 'time_color' ], 296 | [ 'Seen Color' => 'seen_color' ], 297 | [ 'Warn Color' => 'warn_color' ], 298 | [ 'Browser URL' => 'browse_url' ], 299 | [ 'Copy Link' => 'copy_link' ], 300 | [ 'Paste keys' => 'paste_keys' ], 301 | ); 302 | 303 | my $new; 304 | for my $opt (@opts) { 305 | my $f = $opt_f->Frame->pack(-fill => 'x'); 306 | $f->Label(-text => $opt->[0])->pack(-side => 'left'); 307 | $f->Entry( 308 | -textvariable => \($new->{ $opt->[1] } = $self->{ $opt->[1] }) 309 | )->pack(-side => 'right'); 310 | } 311 | 312 | my $old_pm_url = $self->{pm_url} // q(); 313 | my $old_random = $self->{random_url}; 314 | my $new_random = $old_random; 315 | my $f = $opt_f->Frame->pack(-fill => 'x'); 316 | $f->Label(-text => 'PerlMonks URL')->pack(-side => 'left'); 317 | my $e; 318 | $f->Checkbutton( 319 | -variable => \$new_random, 320 | -text => 'Random', 321 | -command => sub { 322 | $e->configure(-state => $new_random 323 | ? 'disabled' : 'normal' ) 324 | } 325 | )->pack(-side => 'left'); 326 | $e = $f->Entry(-textvariable => \ my $new_pm_url, 327 | -state => $new_random ? 'disabled' : 'normal') 328 | ->pack(-side => 'right'); 329 | my $wait_for_url; 330 | $wait_for_url = $self->{mw}->repeat(250, sub { 331 | if (defined $self->{pm_url}) { 332 | $wait_for_url->cancel; 333 | $old_pm_url = $self->{pm_url} 334 | if "" eq ($old_pm_url // 'closed too quickly'); 335 | $new_pm_url = $old_pm_url 336 | if "" eq ($new_pm_url // ""); 337 | } 338 | }); 339 | 340 | my $time_f = $opt_f->Frame->pack(-fill => 'x'); 341 | $opt_f->Label(-text => 'Show Timestamps')->pack(-side => 'left'); 342 | $opt_f->Checkbutton(-variable => \(my $show_time = ! $self->{no_time})) 343 | ->pack(-side => 'right'); 344 | 345 | my $info_f = $opt_w->Frame(-relief => 'groove', -borderwidth => 2) 346 | ->pack(-padx => 5, -pady => 5); 347 | $info_f->Label( 348 | -justify => 'left', 349 | -text => join "\n", 350 | 'Threading model:', 351 | ($self->{mce} && $self->{mce}{hobo} 352 | ? ('MCE::Hobo ' . $MCE::Hobo::VERSION, 353 | 'MCE::Shared ' . $MCE::Shared::VERSION) 354 | : $self->{mce} && $self->{mce}{child} 355 | ? ('MCE::Child ' . $MCE::Child::VERSION, 356 | 'MCE::Channel ' . $MCE::Channel::VERSION) 357 | : ('threads ' . $threads::VERSION, 358 | 'Thread::Queue ' . $Thread::Queue::VERSION) 359 | ), 360 | ('Stack size: ' . 2 ** $self->{stack_size}) x ! $self->{mce}, 361 | 'Geometry: ' . $self->{mw}->geometry, 362 | $self->{log_fh} ? 'Log file: ' . $self->{log} : (), 363 | )->pack(-side => 'left', -padx => 5); 364 | 365 | my $button_f = $opt_w->Frame->pack(-padx => 5, -pady => 5); 366 | my $apply_b = $button_f->Button( 367 | -text => 'Apply', 368 | -underline => 0, 369 | -command => sub{ 370 | $new->{random_url} = $new_random if $new_random != $old_random; 371 | $new->{pm_url} = $new_pm_url 372 | if length $new_pm_url && $old_pm_url ne $new_pm_url; 373 | $self->update_options($show_time, $new); 374 | $opt_w->destroy; 375 | $self->{opt_b}->configure(-state => 'normal'); 376 | }, 377 | )->pack(-side => 'left'); 378 | $opt_w->bind('<Alt-a>', sub { $apply_b->invoke }); 379 | 380 | my $cancel_b = $button_f->Button( 381 | -text => 'Cancel', 382 | -command => my $cancel_s = sub { 383 | $opt_w->destroy; 384 | $self->{opt_b}->configure(-state => 'normal'); 385 | }, 386 | )->pack(-side => 'left'); 387 | $opt_w->bind('<Escape>', $cancel_s); 388 | $opt_w->protocol(WM_DELETE_WINDOW => $cancel_s); 389 | } 390 | 391 | 392 | sub update_options { 393 | my ($self, $show_time, $new) = @_; 394 | 395 | my %old = (pm_url => $self->{pm_url}, 396 | random_url => $self->{random_url}, 397 | fg_color => $self->{fg_color}, 398 | warn_color => $self->{warn_color}, 399 | map +($_ => [ split ' ', $self->{$_} ]), 400 | qw( copy_link paste_keys )); 401 | 402 | for my $opt (keys %$new) { 403 | $self->{$opt} = $new->{$opt} if ! exists $self->{$opt} 404 | || $self->{$opt} ne $new->{$opt}; 405 | } 406 | 407 | for my $tag (grep /^browse:/, $self->{read}->tagNames) { 408 | for my $old_event (@{ $old{copy_link} }) { 409 | my $binding = $self->{read}->tagBind($tag, "<$old_event>"); 410 | $self->{read}->tagBind($tag, "<$old_event>", ""); 411 | $self->{read}->tagBind($tag, "<$_>", $binding) 412 | for split ' ', $self->{copy_link}; 413 | } 414 | } 415 | for my $old_event (@{ $old{paste_keys} }) { 416 | my $binding = $self->{write}->bind("<$old_event>"); 417 | $self->{write}->bind("<$old_event>", ""); 418 | $self->{write}->bind("<$_>", $binding) 419 | for split ' ', $self->{paste_keys}; 420 | } 421 | 422 | $self->{mw}->optionAdd('*font', "$self->{font_name} $self->{char_size}"); 423 | for my $part (qw( read write last_update )) { 424 | $self->{$part}->configure( 425 | -font => $self->{mw}->fontCreate( 426 | -family => $self->{font_name}, 427 | -size => $self->{char_size}, 428 | ), 429 | (-bg => $self->{bg_color}, 430 | -fg => $self->{fg_color}) x ('last_update' ne $part), 431 | ); 432 | } 433 | $self->{read}->tagConfigure(author => -foreground => $self->{author_color}); 434 | $self->{read}->tagConfigure(seen => -foreground => $self->{seen_color}); 435 | $self->{read}->tagConfigure(time => -foreground => $self->{time_color}); 436 | $self->{read}->tagConfigure( 437 | private => -foreground => $self->{private_color}); 438 | $self->{no_time} = ! $show_time; 439 | 440 | $self->{to_control}->enqueue(['random_url', $self->{random_url}]); 441 | if (($old{pm_url} // "") ne ($self->{pm_url} // "")) { 442 | $self->{to_comm}->enqueue(['url', $self->{pm_url}]); 443 | $self->send_login; 444 | } 445 | 446 | if ($self->{warn_color} eq $self->{fg_color}) { 447 | $self->{warn_color} 448 | = ($old{warn_color} eq $self->{warn_color}) 449 | ? $old{fg_color} : $old{warn_color}; 450 | } 451 | 452 | if ($self->{warn_color} ne $old{warn_color}) { 453 | $self->{write}->editModified(1); 454 | } 455 | } 456 | 457 | 458 | sub show_title { 459 | my ($self, $id, $name, $title) = @_; 460 | delete $self->{ids}{$id}; 461 | my $tag = "browse:$id|$name"; 462 | my ($from, $to) = ('1.0'); 463 | while (($from, $to) = $self->{read}->tagNextrange($tag, $from)) { 464 | $self->{read}->delete($from, $to); 465 | $self->{read}->insert($from, "[$title]", [$tag]); 466 | $from = $to; 467 | } 468 | } 469 | 470 | 471 | sub show_shortcut { 472 | my ($self, $shortcut, $url, $title) = @_; 473 | $url = "https://www.perlmonks.org/?node=$shortcut" if 0 == length $url; 474 | delete $self->{shortcuts}{$shortcut}; 475 | my $old_tag = "shortcut:$shortcut|$title"; 476 | my $new_tag = "browse:$url|$title"; 477 | my ($from, $to) = ('1.0'); 478 | while (($from, $to) = $self->{read}->tagNextrange($old_tag, $from)) { 479 | $self->{read}->tagRemove("[$old_tag]", $from, $to); 480 | $self->{read}->delete($from, $to); 481 | 482 | $self->add_clickable($title, $new_tag, $from, $url); 483 | $from = $to; 484 | } 485 | } 486 | 487 | 488 | sub save { 489 | my ($self) = @_; 490 | my $file = $self->{mw}->getSaveFile(-title => 'Save the history to a file'); 491 | return unless defined $file; 492 | 493 | if (open my $OUT, '>', $file) { 494 | print {$OUT} $self->{read}->Contents; 495 | } else { 496 | $self->{mw}->messageBox( 497 | -title => "Can't save", 498 | -icon => 'error', 499 | -message => "'$file' can't be opened for writing", 500 | -type => 'Ok' 501 | ); 502 | } 503 | } 504 | 505 | 506 | sub increment_unread { 507 | my ($self) = @_; 508 | my $title = $self->{mw}->cget('-title'); 509 | if ($title =~ s/([0-9]+)/$1 + 1/e) { 510 | $self->{mw}->configure(-title => $title); 511 | } else { 512 | $self->{mw}->configure(-title => '[1] ' . TITLE); 513 | } 514 | } 515 | 516 | 517 | sub seen { 518 | my ($self) = @_; 519 | while (my ($from, $to) = $self->{read}->tagNextrange('unseen', '1.0')) { 520 | $self->{read}->tagRemove('unseen', $from, $to); 521 | $self->{read}->tagAdd('seen', $from, $to); 522 | } 523 | $self->{last_update}->configure(-foreground => $self->{seen_color}); 524 | $self->{mw}->configure(-title => TITLE); 525 | } 526 | 527 | 528 | sub decode { 529 | my ($msg) = @_; 530 | 531 | $msg =~ s/&#(x?)([0-9a-f]+);/$1 ? chr hex $2 : chr $2/gei; 532 | $msg =~ s{([^\0-\x{FFFF}])}{ 533 | "\x{2997}" 534 | . (charnames::viacode(ord $1) 535 | // sprintf 'U+%X', ord $1) 536 | . "\x{2998}"}ge 537 | if grep $_ eq $^O, qw( MSWin32 darwin ); 538 | return $msg 539 | } 540 | 541 | 542 | sub show { 543 | my ($self, $timestamp, $author, $message, $type, $id) = @_; 544 | 545 | my $text = $self->{read}; 546 | $text->insert(end => "<$timestamp> ", ['time']) unless $self->{no_time}; 547 | my $author_separator = $type == GESTURE ? "" : ': '; 548 | $text->insert(end => "[$author]$author_separator", 549 | { (PRIVATE) => ['private', "deletemsg_$id" x !! $id], 550 | (PUBLIC) => 'author', 551 | (GESTURE) => 'gesture' }->{$type}); 552 | $self->{read}->tagBind("deletemsg_$id", '<Button-1>', 553 | sub { $self->{to_comm}->enqueue(['deletemsg', $id]) }); 554 | my ($line, $column) = split /\./, $text->index('end'); 555 | --$line; 556 | $column += (3 + length($timestamp)) * ! $self->{no_time} + 2 557 | + length($author_separator) + length $author; 558 | $text->insert(end => "$message\n", ['unseen']); 559 | 560 | $self->{log_fh}->printflush( 561 | "<$timestamp> [$author]$author_separator$message\n" 562 | ) if $self->{log_fh}; 563 | 564 | my $fix_length = 0; 565 | my $start_pos = 0; 566 | while ($message =~ m{ 567 | (.*?(?=($|<c(ode)?>))) # Non-greedy up to <code> or end of line 568 | ( 569 | ($ | # followed by end of line 570 | <(c|code)> # or <c> or <code> 571 | .*? # some stuff 572 | </ \g{-1} > # and </c> or </code> as per above 573 | ) 574 | )? 575 | }gx) { 576 | my $not_code = $1; 577 | while ($not_code =~ m{\[(\s*(?: 578 | https? 579 | | (?:meta)?mod | doc 580 | | id | node | href 581 | | pad 582 | )://.+?\s*|[^\]]+)\]}gix 583 | ) { 584 | my $orig = $1; 585 | my ($url, $name) = split /\|/, $orig; 586 | my $pos = $start_pos + pos $not_code; 587 | my $from = $line . '.' 588 | . ($column + $pos 589 | - length(length $name ? "[$url|$name]" : "[$url]") 590 | - $fix_length); 591 | my $to = $line . '.' . ($column - $fix_length + $pos); 592 | $text->delete($from, $to); 593 | 594 | $name = $url unless length $name; 595 | s/^\s+//, s/\s+$// for $name, $url; 596 | $url =~ s{^(?:(?:meta)?mod|doc)://}{http://p3rl.org/}i; 597 | $url =~ s{^pad://([^|\]]*)} 598 | {length $1 599 | ? $self->url("__PM_CB_URL__$1's+scratchpad") 600 | : $self->url("__PM_CB_URL__$author\'s+scratchpad")}ie; 601 | $url =~ s{^href://}{ $self->url("__PM_CB_URL__", "") }ie; 602 | $url =~ s{^node://}{ $self->url("__PM_CB_URL__") }ie; 603 | 604 | my $tag = "browse:$url|$name"; 605 | 606 | if ($url =~ m{^id://([0-9]+)}i) { 607 | my $id = $1; 608 | $self->ask_title($id, $url) if $name eq $url; 609 | $url =~ s{^id://[0-9]+}{ $self->url("__PM_CB_URL__$id", '?node_id=') }ie; 610 | $tag = "browse:$id|$name"; 611 | 612 | } elsif ($url =~ m{://} && $url !~ m{^https?://}i 613 | && $orig =~ /^\Q$url\E\|?/ 614 | ) { 615 | $name =~ s{^.+?://}{} if $name eq $url; 616 | $self->ask_shortcut($url, $name); 617 | $tag = "shortcut:$url|$name"; 618 | 619 | } else { 620 | substr $url, 0, 0, '__PM_CB_URL__' unless $url =~ m{^https?://}i; 621 | $tag = "browse:$url|$name"; 622 | } 623 | 624 | $fix_length += length($orig) - length($name); 625 | 626 | $self->add_clickable($name, $tag, $from, $url); 627 | } 628 | $start_pos = pos $message; 629 | } 630 | $text->see('end'); 631 | } 632 | 633 | 634 | sub add_clickable { 635 | my ($self, $name, $tag, $from, $url) = @_; 636 | my $text = $self->{read}; 637 | $text->tagConfigure($tag => -underline => 1); 638 | $text->insert($from, "[$name]", [$tag]); 639 | $text->tagBind($tag, '<Enter>', 640 | sub { $self->{balloon}->attach( 641 | $text, 642 | -balloonmsg => $self->url($url), 643 | -state => 'balloon', 644 | -balloonposition => 'mouse') }); 645 | $text->tagBind($tag, '<Leave>', 646 | sub { $self->{balloon}->detach($text) }); 647 | $text->tagBind($tag, '<Button-1>', 648 | sub { $self->browse($url) }); 649 | $text->tagBind($tag, "<$_>", 650 | sub { $text->clipboardClear; 651 | $text->clipboardAppend($self->url($url)) } 652 | ) for split ' ', $self->{copy_link}; 653 | } 654 | 655 | 656 | sub deleted { 657 | my ($self, $id) = @_; 658 | $self->{read}->tagConfigure("deletemsg_$id" => -overstrike => 1); 659 | } 660 | 661 | 662 | sub show_list { 663 | my ($self, @monks) = @_; 664 | $self->{read}->insert('end', '[Active Monks]', ['private']); 665 | for my $monk (@monks) { 666 | $self->{read}->insert('end', ' '); 667 | $self->add_clickable("$monk", "browse:$monk", 'end', 668 | $self->url("__PM_CB_URL__$monk")); 669 | } 670 | $self->{read}->insert('end', "\n"); 671 | $self->{read}->see('end'); 672 | } 673 | 674 | 675 | sub ask_title { 676 | my ($self, $id, $name) = @_; 677 | $self->{ids}{$id}{name} = $name; 678 | $self->{to_comm}->enqueue(['title', $id, $name]); 679 | } 680 | 681 | 682 | sub ask_shortcut { 683 | my ($self, $shortcut, $title) = @_; 684 | $self->{shortcuts}{$shortcut}{title} = $title; 685 | $self->{to_comm}->enqueue(['shortcut', $shortcut, $title]); 686 | } 687 | 688 | 689 | sub browse { 690 | my ($self, $url) = @_; 691 | $url = $self->url($url); 692 | my $action = $self->{browser} 693 | ? sub { system qq{$self->{browser} "$url" &} } 694 | : {MSWin32 => sub { system 1, qq{start "$url" /b "$url"} }, 695 | darwin => sub { system qq{open "$url" &} }, 696 | }->{$^O} || sub { system qq{xdg-open "$url" &} }; 697 | $action->(); 698 | } 699 | 700 | 701 | sub show_message { 702 | my ($self, $tzoffset, $timestamp, $author, $message) = @_; 703 | 704 | my $type = $message =~ s{^/me(?=\s|')}{} ? GESTURE : PUBLIC; 705 | $message = decode($message); 706 | $timestamp = convert_time($timestamp, $tzoffset) 707 | ->strftime('%Y-%m-%d %H:%M:%S'); 708 | 709 | substr $timestamp, 0, 11, q() if 0 == index $timestamp, $self->{last_date}; 710 | $self->show($timestamp, $author, $message, $type); 711 | } 712 | 713 | 714 | sub show_private { 715 | my ($self, $author, $time, $msg, $id, $tzoffset) = @_; 716 | $msg = decode($msg); 717 | $msg =~ s/[\n\r]//g; 718 | 719 | if (defined $time) { 720 | local $ENV{TZ} = 'America/New_York'; 721 | my $est = Time::Piece::localtime()->tzoffset; 722 | $time = 'Time::Piece'->strptime($time, '%Y-%m-%d %H:%M:%S') 723 | - $est + $tzoffset; 724 | } else { 725 | $time = Time::Piece::localtime(); 726 | } 727 | $time = $time->strftime('%Y-%m-%d %H:%M:%S'); 728 | 729 | $self->show($time, $author, $msg, PRIVATE, $id); 730 | } 731 | 732 | 733 | sub convert_time { 734 | my ($server_time, $tzoffset) = @_; 735 | my $local_time = 'Time::Piece'->strptime( 736 | $server_time, '%Y-%m-%d %H:%M:%S' 737 | ) + $tzoffset; # Assumption: Server time is in UTC. 738 | return $local_time 739 | } 740 | 741 | 742 | sub update_time { 743 | my ($self, $server_time, $tzoffset, $should_update) = @_; 744 | my $local_time = convert_time($server_time, $tzoffset); 745 | $self->{last_update}->configure( 746 | -text => 'Last update: ' 747 | . $local_time->strftime('%Y-%m-%d %H:%M:%S'), 748 | -foreground => 'black'); 749 | $self->{last_date} = $local_time->strftime('%Y-%m-%d') if $should_update; 750 | } 751 | 752 | 753 | { my ($login, $password); 754 | sub send_login { 755 | my ($self) = @_; 756 | $self->{to_comm}->enqueue([ 'login', $login, $password ]); 757 | } 758 | 759 | 760 | sub login_dialog { 761 | my ($self) = @_; 762 | 763 | my $dialog = $self->{mw}->Dialog( 764 | -title => 'Login', 765 | -default_button => 'Login', 766 | -buttons => [qw[ Login Cancel ]]); 767 | 768 | my $username_f = $dialog->Frame->pack(-fill => 'both'); 769 | $username_f->Label(-text => 'Username: ') 770 | ->pack(-side => 'left', -fill => 'x'); 771 | my $username_e = $username_f->Entry->pack(-side => 'left'); 772 | $username_e->focus; 773 | 774 | my $password_f = $dialog->Frame->pack(-fill => 'both'); 775 | $password_f->Label(-text => 'Password: ') 776 | ->pack(-side => 'left', -fill => 'x'); 777 | my $password_e = $password_f->Entry(-show => '*') 778 | ->pack(-side => 'right'); 779 | 780 | my $reply = $dialog->Show; 781 | if ('Cancel' eq $reply) { 782 | $self->quit; 783 | return 784 | } 785 | 786 | ($login, $password) = ($username_e->get, $password_e->get); 787 | $self->send_login; 788 | } 789 | } 790 | 791 | 792 | sub quit { 793 | my ($self) = @_; 794 | print STDERR "Quitting...\n"; 795 | $self->{to_control}->insert(0, ['quit']); 796 | if ('MSWin32' ne $^O && $self->{mce}) { 797 | $self->{control_t}->kill('QUIT'); 798 | Tk::exit() 799 | } 800 | } 801 | 802 | 803 | sub help { 804 | my ($self) = @_; 805 | 806 | my @help = ( 807 | '<Alt+,> previous history item', 808 | '<Alt+.> next history item', 809 | '<{paste_keys}> paste clipboard', 810 | '<{copy_link}> copy link', 811 | '<Esc> to exit help', 812 | ); 813 | $self->{opt_h}->configure(-state => 'disabled'); 814 | my $top = $self->{mw}->Toplevel(-title => TITLE . ' Help'); 815 | my $text = $top->ROText(height => 1 + @help)->pack; 816 | s/\{(.+?)\}/$self->{$1}/g for @help; 817 | $text->insert('end', "$_\n") for @help[ 0 .. $#help - 1 ]; 818 | $text->insert('end', "\n$help[-1]"); 819 | 820 | $top->bind('<Escape>', my $end = sub { 821 | $top->DESTROY; 822 | $self->{opt_h}->configure(-state => 'normal'); 823 | }); 824 | $top->protocol(WM_DELETE_WINDOW => $end); 825 | } 826 | 827 | __PACKAGE__ 828 | --------------------------------------------------------------------------------