mirror of
https://git.code.sf.net/p/fldigi/flrig
synced 2026-08-13 17:28:24 -04:00
382 lines
9.3 KiB
Perl
Executable file
382 lines
9.3 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# flrig-shell version 0.10
|
|
# A Perl script to control flrig over HTTP/XML-RPC.
|
|
#
|
|
# flrig must have been built with xml-rpc support; see INSTALL.
|
|
#
|
|
# Copyright (C) 2015
|
|
# Dave Freese, W1HKJ
|
|
#
|
|
# flrig-shell 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 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# flrig-shell 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
|
# ----------------------------------------------------------------------------
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use RPC::XML qw(:types);
|
|
use RPC::XML::Client;
|
|
use Term::ReadLine;
|
|
use POSIX qw(:termios_h);
|
|
use IO::Handle;
|
|
use Getopt::Std;
|
|
use Data::Dumper;
|
|
use Time::HiRes qw(gettimeofday tv_interval usleep);
|
|
use LWP;
|
|
|
|
################################################################################
|
|
|
|
our $VERSION = "0.10";
|
|
our $progname = (split(/\//, $0))[-1];
|
|
our $histfile = $ENV{'HOME'} . "/.flrig/shell-history";
|
|
|
|
our $client;
|
|
our $ua;
|
|
|
|
our $term;
|
|
our $OUT = \*STDOUT;
|
|
our $debug = 1;
|
|
|
|
our %methods;
|
|
our %commands;
|
|
our %encoders;
|
|
|
|
our %opts;
|
|
|
|
################################################################################
|
|
# terminal routines from perlfaq8
|
|
|
|
our ($termios, $oterm, $echo, $noecho, $fd_stdin);
|
|
|
|
sub term_get_attr
|
|
{
|
|
$fd_stdin = fileno(STDIN);
|
|
|
|
$termios = POSIX::Termios->new();
|
|
$termios->getattr($fd_stdin);
|
|
$oterm = $termios->getlflag();
|
|
|
|
$echo = ECHO | ECHOK | ICANON;
|
|
$noecho = $oterm & ~$echo;
|
|
}
|
|
|
|
sub term_cbreak
|
|
{
|
|
$termios->setlflag($noecho);
|
|
$termios->setcc(VTIME, 1);
|
|
$termios->setattr($fd_stdin, TCSANOW);
|
|
}
|
|
|
|
sub term_cooked
|
|
{
|
|
$termios->setlflag($oterm);
|
|
$termios->setcc(VTIME, 0);
|
|
$termios->setattr($fd_stdin, TCSANOW);
|
|
}
|
|
|
|
sub term_getc
|
|
{
|
|
my $key = '';
|
|
term_cbreak();
|
|
sysread(STDIN, $key, 1);
|
|
term_cooked();
|
|
return $key;
|
|
}
|
|
|
|
################################################################################
|
|
# xml-rpc helper routines
|
|
|
|
sub encode
|
|
{
|
|
my $aref = $_[0];
|
|
return unless (exists( $methods{$aref->[0]} ));
|
|
|
|
my $sig = $methods{$aref->[0]}->[0]; $sig =~ s/.+://;
|
|
my @args = split(//, $sig);
|
|
|
|
# Try to find an encoder for each format string char.
|
|
# Use it to encode the corresponding method argument.
|
|
for (my $i = 0; $i <= $#args; $i++) {
|
|
if (exists($encoders{$args[$i]}) && exists($aref->[$i])) {
|
|
print "Encoding arg " . ($i+1) . " as $args[$i]\n" if ($debug);
|
|
$aref->[$i+1] = &{ $encoders{$args[$i]} }($aref->[$i+1]);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub req
|
|
{
|
|
encode(\@_);
|
|
my $r = $client->send_request(@_);
|
|
if (!ref($r)) {
|
|
print $OUT "Error: " . $r . "\n" unless ($r =~ /Unknown tag.+nil$/);
|
|
$r = undef;
|
|
}
|
|
elsif ($r->is_fault()) {
|
|
print $OUT "Error " . $r->value->{"faultCode"} . ": " .
|
|
$r->value->{"faultString"} . "\n";
|
|
$r = undef;
|
|
}
|
|
|
|
return $r;
|
|
}
|
|
|
|
sub decode
|
|
{
|
|
my $r;
|
|
return "" unless defined($r = req(@_));
|
|
return ref($r->value) ? Dumper($r->value) : $r->value;
|
|
}
|
|
|
|
sub execute($)
|
|
{
|
|
my @line = split(/\s+/, $_[0]);
|
|
my $ret;
|
|
|
|
if (exists( $commands{$line[0]} )) {
|
|
my $cmd = shift(@line);
|
|
&{ $commands{$cmd}->[2] }(@line);
|
|
}
|
|
elsif (exists( $methods{$line[0]} )) {
|
|
# should we resplit the line?
|
|
my $sig = $methods{$line[0]}->[0]; $sig =~ s/.+://; $sig =~ s/n//;
|
|
print "Method " . $line[0] . " takes " . length($sig) . " args\n" if ($debug);
|
|
if (length($sig) != $#line) {
|
|
@line = split(/ +/, $_[0], length($sig) + 1);
|
|
}
|
|
print Dumper(\@line) if ($debug);
|
|
my $r = decode(@line);
|
|
if (defined $r) { print $OUT $r, "\n"};
|
|
}
|
|
else {
|
|
print $OUT $line[0] . ": command not found. Do you need ``help''?\n";
|
|
}
|
|
}
|
|
|
|
################################################################################
|
|
# command routines
|
|
|
|
sub help
|
|
{
|
|
my @k = (@_ ? @_ : (sort keys %methods, sort keys %commands));
|
|
|
|
if (%methods) {
|
|
print $OUT "Server methods:", "\n" if (!@_);
|
|
foreach (@k) {
|
|
next unless (exists($methods{$_}));
|
|
printf($OUT " %-32s%-8s%s\n", $_, $methods{$_}->[0], $methods{$_}->[1]);
|
|
}
|
|
print $OUT "\n" if (!@_);
|
|
}
|
|
print $OUT "Shell commands:", "\n" if (!@_);
|
|
foreach (@k) {
|
|
next unless (exists($commands{$_}));
|
|
printf(" %-32s%-8s%s\n", $_, $commands{$_}->[0], $commands{$_}->[1]);
|
|
}
|
|
}
|
|
|
|
sub print_history
|
|
{
|
|
my $out = $_[0];
|
|
|
|
my @h = $term->GetHistory();
|
|
splice(@h, 0, $_[1]) if ($_[1] > 0);
|
|
print $out join("\n", @h), "\n" if (@h);
|
|
}
|
|
|
|
sub time_cmd
|
|
{
|
|
my $t0 = [gettimeofday()];
|
|
execute("@_");
|
|
print tv_interval($t0), " seconds\n";
|
|
}
|
|
|
|
sub evaluate(@)
|
|
{
|
|
warn "$@" unless (defined(eval "@_"));
|
|
}
|
|
|
|
sub source
|
|
{
|
|
open(IN, '<', $_[0]) or warn "Could not read input file: $!\n" and return;
|
|
evaluate(<IN>);
|
|
close(IN);
|
|
}
|
|
|
|
|
|
################################################################################
|
|
|
|
%opts = ( "c" => "", "d" => 0, "u" => "http://localhost:12345/RPC2" );
|
|
|
|
%commands = (
|
|
"debug" => [ "n:n", "Toggle debugging output", sub { $debug = (@_ ? $_[0] : !$debug); } ],
|
|
"eval" => [ "s:s", "Evaluate Perl code", sub { evaluate "@_"; } ],
|
|
"exit" => [ "n:n", "Exit the shell", sub { exit(0) } ],
|
|
"help" => [ "n:n", "Print this command help", \&help ],
|
|
"history" => [ "s:n", "Print command history", sub { print_history($OUT, 0); } ],
|
|
"reinit" => [ "n:n", "Rebuild command list", sub { build_cmds(); setup_compl(); } ],
|
|
);
|
|
|
|
%encoders = ( "b" => \&RPC_BOOLEAN, "6" => \&RPC_BASE64,
|
|
"d" => \&RPC_DOUBLE, "s" => \&RPC_STRING );
|
|
|
|
################################################################################
|
|
|
|
|
|
sub HELP_MESSAGE
|
|
{
|
|
print <<EOF
|
|
|
|
Usage: $progname [-OPTIONS [-MORE_OPTIONS]] [--] [FILE ...]
|
|
|
|
The following single-character options are accepted:
|
|
|
|
-c CMD Execute command CMD and exit.
|
|
|
|
-d Enable debugging output.
|
|
|
|
-u URL Use URL to access the server.
|
|
The default is $opts{"u"}
|
|
|
|
Files are evaluated as Perl code and may contain
|
|
execute("COMMAND [ARG ...]") statements, where COMMAND
|
|
is an flrig-shell command.
|
|
|
|
Options may be merged together. -- stops processing of options.
|
|
Space is not required between options and their arguments.
|
|
EOF
|
|
;
|
|
}
|
|
|
|
sub handle_cmdline
|
|
{
|
|
$Getopt::Std::STANDARD_HELP_VERSION = 1;
|
|
|
|
my $optstr = 'c:du:';
|
|
my $old_warn_handler = $SIG{__WARN__};
|
|
$SIG{__WARN__} = sub { die $_[0]; };
|
|
getopts($optstr, \%opts);
|
|
$SIG{__WARN__} = $old_warn_handler;
|
|
|
|
my @argopts;
|
|
my $last = 0;
|
|
foreach (split(//, $optstr)) {
|
|
push(@argopts, $last) if ($_ eq ":");
|
|
$last = $_;
|
|
}
|
|
foreach (@argopts) {
|
|
if (exists($opts{$_}) && !defined($opts{$_})) {
|
|
die "$0: option `-$_' requires an argument\n";
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
$debug = $opts{"d"};
|
|
}
|
|
|
|
################################################################################
|
|
|
|
sub build_cmds
|
|
{
|
|
%methods = ();
|
|
|
|
# this uses system.listMethods to get all methods with a single request
|
|
if (defined(my $r = req("rig.list_methods"))) {
|
|
foreach (@{$r->value}) {
|
|
$methods{ $_->{"name"} } = [ $_->{"signature"}, $_->{"help"} ];
|
|
# $methods{ $_->{"name"} } = [ "i:s", "return a string" ];
|
|
# $methods{ $_ } = [ "i:s", "return a string" ];
|
|
}
|
|
|
|
$methods{"system.listMethods"} = [ "i:n", "XML-RPC methods on this server." ];
|
|
# $methods{"system.methodHelp"} = [ "i:s", "Given the name of a method, return a help string." ];
|
|
# $methods{"system.methodSignature"} = [ "A:s", "Given the name of a method, return an array of legal signatures." ];
|
|
# $methods{"system.multicall"} = [ "i:n", "Process an array of calls, and return an array of results." ];
|
|
# $methods{"system.shutdown"} = [ "i:i", "Shut down the server. Return code is always zero." ];
|
|
}
|
|
}
|
|
|
|
sub setup_compl
|
|
{
|
|
# Use the hashes to set up simple completion for rpc methods and shell commands
|
|
if ($term->ReadLine eq "Term::ReadLine::Gnu") {
|
|
my $attribs = $term->Attribs();
|
|
$attribs->{"completion_entry_function"} = $attribs->{"list_completion_function"};
|
|
$attribs->{"completion_word"} = [keys %methods, keys %commands];
|
|
} elsif ($term->ReadLine eq "Term::ReadLine::Perl") {
|
|
readline::rl_basic_commands(keys %methods, keys %commands);
|
|
}
|
|
}
|
|
|
|
sub load_history
|
|
{
|
|
open(HIST, '<', $histfile) or return 0;
|
|
while (<HIST>) {
|
|
chomp;
|
|
$term->addhistory($_);
|
|
}
|
|
my $r = $.;
|
|
close(HIST);
|
|
return $r;
|
|
}
|
|
|
|
sub save_history
|
|
{
|
|
open(HIST, '>>', $histfile) or return;
|
|
print_history(\*HIST, $_[0]);
|
|
close(HIST);
|
|
}
|
|
|
|
################################################################################
|
|
################################################################################
|
|
|
|
# parse cmd line
|
|
handle_cmdline();
|
|
|
|
# create client
|
|
$client = RPC::XML::Client->new($opts{"u"});
|
|
|
|
# save terminal attributes; used by getc routine
|
|
term_get_attr();
|
|
|
|
# initialise termline
|
|
$term = new Term::ReadLine "flrig-shell";
|
|
#$OUT = $term->OUT || \*STDOUT;
|
|
STDOUT->autoflush(1);
|
|
my $histskip = load_history();
|
|
|
|
# build commands hashes
|
|
build_cmds();
|
|
help();
|
|
|
|
if ($opts{'c'} ne "") { # execute argument and exit
|
|
execute($opts{'c'});
|
|
exit(0);
|
|
}
|
|
elsif (@ARGV) {
|
|
source($_) foreach(@ARGV);
|
|
exit(0);
|
|
}
|
|
|
|
setup_compl();
|
|
|
|
# ignore interrupts
|
|
$SIG{INT} = 'IGNORE';
|
|
|
|
# execute commands
|
|
while (defined($_ = $term->readline("flrig % "))) {
|
|
execute($_) if (/\w/);
|
|
}
|
|
save_history($histskip);
|