view release on metacpan or  search on metacpan

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

  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) = @_;