# Copyright 2008, 2009, 2010, 2011, 2014 Kevin Ryde
# This file is part of Chart.
#
# Chart is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3, or (at your option) any later version.
#
# Chart is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along
# with Chart. If not, see <http://www.gnu.org/licenses/>.
# ENHANCE-ME:
# remember which latests sent, only give 'update' for them
package App::Chart::EmacsMain;
use 5.010;
use strict;
use warnings;
use Encode;
use Encode::Locale;
use IO::Handle;
use Lisp::Reader;
use Lisp::Printer ('lisp_print');
use Lisp::Symbol ('symbol');
use POSIX ();
use Regexp::Common 'whitespace';
use Locale::TextDomain 'App-Chart';
use App::Chart;
# set this to 1 for development debugging prints
use constant { DEBUG => 0,
DEBUG_TTY_FILENAME => '/dev/tty7' };
use constant PROTOCOL_VERSION => 102;
my $emacs_fh;
# reopen $fd on $filename with $omode a POSIX::O_WRONLY() etc value
# return $fd on success, or undef with $! set on error
sub fdreopen {
my ($fd, $filename, $omode) = @_;
my $file_fd = POSIX::open ($filename, $omode);
if (! defined $fd) { return undef; }
# print "fdreopen $fd $filename, via $file_fd\n";
if (! defined POSIX::dup2 ($file_fd, $fd)) {
{
local $!;
POSIX::close ($file_fd);
}
return undef;
}
if (! defined POSIX::close ($file_fd)) { return undef; }
return $fd;
}
sub main {
my ($class) = @_;
# subprocess unbuffered and utf8
binmode (STDIN, ':utf8') or die;
# dup-ed to a new descriptor to talk to emacs
open $emacs_fh, '>&STDOUT' or die;
$emacs_fh->autoflush(1); # emacs_write() does single-string prints
# ENHANCE-ME: use one of the IO::Capture or via layer or whatnot to get
# perl prints to STDOUT/STDERR and send them up to an emacs buffer, or
# message area
#
# stdout/stderr fds 1 and 2 put to /dev/null to discard other prints
my $devnull = File::Spec->devnull;
fdreopen (1, $devnull, POSIX::O_WRONLY())
// die "Cannot send STDOUT to $devnull: ", Glib::strerror($!);
POSIX::dup2 (1, 2) // die;
if (DEBUG) {
# fds 1 and 2 changed (again) to DEBUG_TTY_FILENAME, if it's possible to
# open that
if (fdreopen (1, DEBUG_TTY_FILENAME, POSIX::O_WRONLY())) {
POSIX::dup2 (1, 2) // die "Cannot dup fd 1 to fd 2: $!";
print "EmacsMain started, emacs_fh fd=",fileno($emacs_fh),
", diagnostics on ",DEBUG_TTY_FILENAME,"\n";
print " STDOUT fd ",fileno(STDOUT),", STDERR fd ",fileno(STDERR),"\n";
STDOUT->autoflush(1);
STDERR->autoflush(1); # probably true already
}
}
# initial message
emacs_write (symbol('init'), 'UTF-8', PROTOCOL_VERSION);
my $mainloop = Glib::MainLoop->new;
STDIN->blocking(0);
Glib::IO->add_watch (fileno(STDIN), ['in', 'hup', 'err'], \&_do_read,
$mainloop);
$Lisp::Reader::SYMBOLS_AS_STRINGS = 1;
my $dirb = App::Chart::chart_dirbroadcast();
$dirb->listen;
$dirb->connect ('delete-symbol', \&completions_update);
$dirb->connect ('symlist-content-changed', \&_do_symlist_content_changed);
$dirb->connect ('symlist-content-inserted', \&_do_symlist_content_inserted);
$dirb->connect ('symlist-content-deleted', \&_do_symlist_content_deleted);
$dirb->connect ('symlist-content-reordered',\&_do_symlist_content_reordered);
$dirb->connect ('symlist-list-changed', \&_do_symlist_list_changed);
$dirb->connect ('latest-changed', \&send_update);
$dirb->connect ('data-changed', \&send_update);
Glib->install_exception_handler (\&exception_handler);
## no critic (RequireLocalizedPunctuationVars)
$SIG{'__WARN__'} = \&exception_handler;
$mainloop->run;
}
# 'data-changed' and 'latest-changed'
sub send_update {
my ($changed) = @_;
if (DEBUG) { print "Changed: ",join(' ',keys %$changed),"\n"; }
emacs_write (symbol('update'), [ keys %$changed ]);
# this is a bit excessive, only really want to know if new symbols have
# been added to the latest quotes
completions_update();
}
sub exception_handler {
my ($msg) = @_;
# perhaps some modules like LWP will put through a locale $! or similar
unless (utf8::is_utf8($msg)) { $msg = Encode::decode('locale',$msg); }
if (DEBUG) { print "Error ", $msg; }
$msg =~ s/$RE{ws}{crop}//g; # leading and trailing whitespace
# $trace->as_string has non-ascii de-fanged to something printable, so it
# can go straight out
#
my $backtrace;
if (eval { require Devel::StackTrace; }) {
$backtrace = Devel::StackTrace->new->as_string;
$msg .= __('See *chart-process-backtrace* buffer');
}
emacs_write (symbol('error'), $msg, $backtrace);
return 1; # stay installed
}
sub emacs_write {
if (DEBUG >= 2) { require Data::Dumper;
print Data::Dumper::Dumper(\@_); }
if (DEBUG) { print "To emacs: ",lisp_print([@_]),"\n"; }
print $emacs_fh lisp_print([@_]),"\n";
}
my $buf = '';
sub _do_read {
my ($fd, $conditions, $mainloop) = @_;
for (;;) {
if (DEBUG >= 2) { print " read more at ",length($buf),"\n"; }
my $got = read STDIN, $buf, 8192, length($buf);
if (DEBUG >= 2) { print " got ",$got//'undef'," $!\n"; }
if (! defined $got) {
if ($! == POSIX::EWOULDBLOCK()) { last; } # no more data for now
if ($!) {
print STDERR "Read error: ",Glib::strerror($!),"\n";
}
$mainloop->quit;
return 0;
}
if ($got == 0) {
## no critic (ProhibitExit, ProhibitExitInSubroutines)
exit 0;
}
}
my ($aref, $endpos) = Lisp::Reader::lisp_read ($buf);
$buf = substr ($buf, $endpos);
if (DEBUG) { require Data::Dumper;
print "Receive: ",Data::Dumper::Dumper($aref);
print "leaving buf ",length($buf),"\n"; }
foreach my $list (@$aref) {
call_command ($list);
}
return 1; # stay connected
}
sub call_command {
my ($list) = @_;
my $lisp_command = shift @$list;
my $command = $lisp_command;
$command =~ tr/-/_/;
$command = "emacs_command_$command";
if (DEBUG) { print "Call $command\n"; }
if (defined &$command) {
no strict;
&$command (@$list);
} else {
emacs_write (symbol('error'), "Unknown $command ($lisp_command)", undef);
}
}
#-----------------------------------------------------------------------------
# broadcast handlers
# 'symlist-list-changed' handler
sub _do_symlist_list_changed {
my ($key, $pos) = @_;
if ($key eq 'all' || $key eq 'favourites') {
completions_update();
}
emacs_write (symbol('symlist-list-changed'), [ $key ]);
}
# 'symlist-content-changed' handler
sub _do_symlist_content_changed {
my ($key, $pos) = @_;
if ($key eq 'all' || $key eq 'favourites') {
completions_update();
}
emacs_write (symbol('symlist-update'), [ $key ]);
}
# 'symlist-content-deleted' handler
sub _do_symlist_content_deleted {
my ($key, $pos) = @_;
if ($key eq 'all' || $key eq 'favourites') {
completions_update();
}
emacs_write (symbol('symlist-update'), [ $key ]);
}
# 'symlist-content-inserted' handler
sub _do_symlist_content_inserted {
my ($key, $pos) = @_;
if ($key eq 'all' || $key eq 'favourites') {
completions_update();
}
emacs_write (symbol('symlist-update'), [ $key ]);
}
# 'symlist-content-reordered' handler
sub _do_symlist_content_reordered {
my ($key, $pos) = @_;
if ($key eq 'all' || $key eq 'favourites') {
completions_update();
}
emacs_write (symbol('symlist-update'), [ $key ]);
}
#-----------------------------------------------------------------------------
# return string for $latest
sub latest_line {
my ($latest) = @_;
my $excess = 0;
my $ret = '';
my $add = sub {
my ($width, $str) = @_;
my $this = sprintf ('%*s', $width, $str//'');
$excess += length($this) - abs($width);
while ($excess > 0 && $ret =~ / $/) {
$ret = substr ($ret, 0, -1);
$excess--;
}
while ($excess > 0 && length($this) > 1 && $this =~ /^ /) {
$this = substr ($this, 1);
$excess--;
}
$ret .= $this;
};
$add->(-9, $latest->{'symbol'});
my $bid = $latest->{'bid'};
my $offer = $latest->{'offer'};
$add->(7, format_price($bid));
my $slash = (defined $bid && defined $offer && $bid > $offer ? 'x' : '/');
$add->(1, $slash);
$add->(-7, format_price($offer));
$add->(1, ' ');
$add->(7, format_price($latest->{'last'}));
$add->(1, ' ');
$add->(6, format_price($latest->{'change'}));
$add->(1, ' ');
$add->(7, format_price($latest->{'low'}));
$add->(1, ' ');
$add->(7, format_price($latest->{'high'}));
$add->(1, ' ');
$add->(7, $latest->formatted_volume);
$add->(1, ' ');
$add->(7, $latest->short_datetime);
$add->(1, ' ');
my $note = $latest->{'note'} // '';
$add->(length($note), $note);
return $ret;
}
sub format_price {
my ($str) = @_;
if (! defined $str) { return ''; }
my $nf = App::Chart::number_formatter();
return $nf->format_number ($str, App::Chart::count_decimals($str), 1);
}
sub latest_to_face {
my ($latest) = @_;
if ($App::Chart::Gtk2::Job::Latest::inprogress{$latest->{'symbol'}}) {
return symbol('chartprog-in-progress');
}
my $change = $latest->{'change'} || 0;
if ($change > 0) {
return symbol('chartprog-up');
} elsif ($change < 0) {
return symbol('chartprog-down');
}
return undef;
}
# return element list [$symbol, $string, $face, $help]
sub latest_elem {
my ($symbol) = @_;
require App::Chart::Latest;
my $latest = App::Chart::Latest->get ($symbol);
my $face = latest_to_face($latest);
my $help = join (' - ', $symbol, $latest->{'name'}//'') . "\n";
if (my $quote_date = $latest->{'quote_date'}) {
my $quote_time = $latest->{'quote_time'} || '';
$help .= __x("Quote: {quote_date} {quote_time}",
quote_date => $quote_date,
quote_time => $quote_time)
. "\n";
}
if (my $last_date = $latest->{'last_date'}) {
my $last_time = $latest->{'last_time'} || '';
$help .= __x("Last: {last_date} {last_time}",
last_date => $last_date,
last_time => $last_time);
$help .= "\n";
}
$help .= __x("{location} time; source {source}",
location => App::Chart::TZ->for_symbol($symbol)->name,
source => $latest->{'source'});
return [$symbol, latest_line($latest), $face, $help];
}
#-----------------------------------------------------------------------------
# commands
# send latest lines for SYMBOL-LIST
sub emacs_command_latest_get_list {
my ($symbol_list) = @_;
# write in chunks of 20 symbols
while (@$symbol_list) {
my @part = splice @$symbol_list, 0, 20;
emacs_write (symbol('latest-line-list'),
[ map { latest_elem($_) } @part ]);
}
}
sub emacs_command_request_symbols {
my ($symbol_list) = @_;
require App::Chart::Gtk2::Job::Latest;
App::Chart::Gtk2::Job::Latest->start ($symbol_list);
}
sub emacs_command_request_explicit {
goto &emacs_command_request_symbols;
}
# send the symbols in symlist $key
sub emacs_command_get_symlist {
my ($key) = @_;
require App::Chart::Gtk2::Symlist;
my $symlist = App::Chart::Gtk2::Symlist->new_from_key ($key);
emacs_write (symbol('symlist-list'), symbol($key), $symlist->symbol_listref);
}
sub emacs_command_synchronize {
my ($n) = @_;
emacs_write (symbol('synchronize', $n));
}
sub emacs_command_synchronous {
my ($seq, $func, @args) = @_;
if (DEBUG) { print " synchronous to $func\n"; }
emacs_write (symbol('synchronous'), $seq,
call_command ([$func, @args]));
}
sub emacs_command_noop {
}
#-----------------------------------------------------------------------------
# symlist manipulations
# (request-symlist KEY)
# Begin a download of latest prices for all symbols in symlist KEY.
#
sub emacs_command_request_symlist {
my ($key) = @_;
require App::Chart::Gtk2::Symlist;
my $symlist = App::Chart::Gtk2::Symlist->new_from_key ($key);
require App::Chart::Gtk2::Job::Latest;
App::Chart::Gtk2::Job::Latest->start_symlist ($symlist);
}
sub emacs_command_request_explicit_symlist {
goto &emacs_command_request_symlist;
}
# (symlist-delete KEY POS COUNT)
#
sub emacs_command_symlist_delete {
my ($key, $pos, $count) = @_;
my $symlist = App::Chart::Gtk2::Symlist->new_from_key ($key);
foreach (1 .. $count) {
my $iter = $symlist->iter_nth_child (undef, $pos);
$symlist->remove ($iter);
}
}
sub emacs_command_symlist_insert {
my ($key, $pos, $symbol_list) = @_;
my $symlist = App::Chart::Gtk2::Symlist->new_from_key ($key);
foreach my $symbol (@$symbol_list) {
$symlist->insert_symbol_at_pos ($symbol, $pos++);
}
}
#-----------------------------------------------------------------------------
# completion - symbols
sub emacs_command_get_completion_symbols {
my %symbols;
# # favourites list symbols
# {
# require App::Chart::Gtk2::Symlist::Favourites;
# if (my $favourites = App::Chart::Gtk2::Symlist::Favourites->instance) {
# my $href = $favourites->hash;
# %symbols = %$href; # copy
# }
# }
# all database data symbols
require App::Chart::Database;
@symbols{App::Chart::Database->symbols_list()} = (); # hash slice
require App::Chart::DBI;
my $dbh = App::Chart::DBI->instance;
foreach my $statement (# all latest record symbols
'SELECT symbol FROM latest',
# all symbols in all lists
'SELECT symbol FROM symlist_content') {
my $sth = $dbh->prepare_cached($statement);
my $a = $dbh->selectcol_arrayref ($sth);
@symbols{@$a} = (); # hash slice
}
return [ map {[$_]} sort keys %symbols ];
}
sub completions_update {
emacs_write (symbol('completion-symbols-update'));
}
#-----------------------------------------------------------------------------
# symlist alist
# the `chart-symlist-alist' data, being a list of elements (NAME KEY
# EDITABLE), is sent up as an asynch, and with a dummy return value
#
# this suits chart-watchlist startup which doesn't want to wait, and
# chart-symlist-alist forced initialization, which does want to wait
#
sub emacs_command_get_symlist_alist {
# my $model = App::Chart::Gtk2::SymlistListModel->instance;
# my @list;
# $model->foreach (sub {
# my ($model, $path, $iter) = @_;
# $model->get_value ($iter, $model->COL_NAME))
# $model->get_value ($iter, $model->COL_KEY))
# column_contents$model
require App::Chart::Gtk2::Symlist;
emacs_write (symbol('symlist-alist'),
[ map { my $symlist = $_;
[ $symlist->name,
symbol($symlist->key),
$symlist->can_edit ? symbol('t') : undef ]
}
App::Chart::Gtk2::Symlist->all_lists ]);
return undef;
}
#-----------------------------------------------------------------------------
# individual `chart-quote'
# Return [$symbol, $string, $face, $help] intended for display in the
# message area of an `M-x chart-quote' single-symbol quote.
#
# The return is the current latest quote. Nothing is downloaded. (That's
# done by a separate `request-explicit'.)
#
# The symbol name and timezone are appended to the $string returned so as to
# show that as a second line in the message area (in GNU emacs which has
# multi-line messages, but not XEmacs circa its 21.4).
#
sub emacs_command_quote_one {
my ($symbol) = @_;
if (DEBUG) { print " quote-one $symbol\n"; }
my $elem = latest_elem ($symbol);
my $extra = '';
if (length($symbol) > 9) {
$extra = $symbol;
}
# " - name", when the name is available
my $latest = App::Chart::Latest->get ($symbol);
if (my $name = $latest->{'name'}) {
if ($extra) {
$extra = join (' - ', $extra, $name);
} else {
$extra = $name;
}
}
my $timezone = App::Chart::TZ->for_symbol($symbol);
if ($timezone != App::Chart::TZ->loco) {
$extra = join (' ', $extra, '[' . $timezone->name . ']');
}
$elem->[1] = join ("\n", $elem->[1], $extra);
return $elem;
}
#-----------------------------------------------------------------------------
# latest records
sub emacs_command_get_latest_record {
my ($symbol) = @_;
require App::Chart::Latest;
my $latest = App::Chart::Latest->get ($symbol);
return [ symbol('symbol'), $latest->{'symbol'},
symbol('name'), $latest->{'name'},
symbol('bid'), $latest->{'bid'},
symbol('offer'), $latest->{'offer'},
symbol('open'), $latest->{'open'},
symbol('high'), $latest->{'high'},
symbol('low'), $latest->{'low'},
symbol('last'), $latest->{'last'},
symbol('change'), $latest->{'change'},
symbol('volume'), $latest->{'volume'},
symbol('decimals'), 0,
symbol('note'), $latest->{'note'},
symbol('source'), $latest->{'source'},
symbol('face'), latest_to_face($latest),
];
}
#-----------------------------------------------------------------------------
# spreadsheet support
# return when SYMBOL-LIST has been downloaded
# (define-public (emacs-command-request-symbols-synchronous symbol-list)
# (call-with-current-continuation
# (lambda (cont)
# (define (callback this-symbol-list)
# (set! this-symbol-list (remove latest-in-progress? this-symbol-list))
# (set! symbol-list (lset-difference string=?
# symbol-list this-symbol-list))
# (if (null? symbol-list)
# (begin
# (notify-disconnect 'latest-update callback)
# (cont #f))))
# (notify-connect 'latest-update callback)
# (c-main-enq! latest-request-symbols symbol-list)
# (c-main-goto-top)))
# 'nil)
1;
__END__
=head1 NAME
App::Chart::EmacsMain -- main loop for Emacs interaction
=head1 SYNOPSIS
use App::Chart::EmacsMain;
App::Chart::EmacsMain->main ();
=head1 HOME PAGE
L<http://user42.tuxfamily.org/chart/index.html>
=head1 LICENCE
Copyright 2008, 2009, 2010, 2011, 2014 Kevin Ryde
Chart is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation; either version 3, or (at your option) any later version.
Chart is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
You should have received a copy of the GNU General Public License along with
Chart; see the file F<COPYING>. Failing that, see
L<http://www.gnu.org/licenses/>.
=cut