view release on metacpan or  search on metacpan

lib/App/Chart/EmacsMain.pm  view on Meta::CPAN

# Copyright 2008, 2009, 2010, 2011, 2014, 2015, 2016, 2017 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;  # for coding system "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 {