manage

Revision 194, 13.7 kB (checked in by athomas, 4 years ago)
Added on_change() trigger for %CONF variables.
Property svn:executable set to

Line
1	#!/usr/bin/perl
2
3	use warnings;
4	use strict;
5
6	package manage;
7
8	BEGIN { $ENV{COLUMNS} = 80; $ENV{LINES} = 25; }
9
10	use Config;
11	use CLI;
12	use CLI::Plugin;
13	use Term::ReadKey;
14	use Term::ReadLine;
15	use Term::ReadLine::Gnu;
16	use POSIX qw(ctermid floor);
17	use Fcntl qw(SEEK_SET SEEK_END SEEK_CUR O_RDONLY);
18	use IO::File;
19	use IO::Select;
20	use Text::Table;
21	use POSIX qw(ctermid);
22
23	use constant CMD_ARG => 1;
24	use constant CMD_STDIN => 2;
25	use constant CMD_INTERACTIVE => 3;
26
27
28	my $SELF = $0; $SELF =~ s/.*\///;
29	our $DEBUG = 0;
30	my $BREAK = 0; $SIG{INT} = sub { $BREAK = 1; };
31	my $FATAL = 0; $SIG{__DIE__} = sub { $FATAL = 1; };
32	our %C = (
33	bold => "\e[1m",
34	nobold => "\e[22m",
35	underline => "\e[4m",
36	nounderline => "\e[24m",
37	reset => "\e[0m",
38	normal => "\e[22m",
39	black => "\e[30m",
40	red => "\e[31m",
41	green => "\e[32m",
42	brown => "\e[33m",
43	blue => "\e[34m",
44	magenta => "\e[35m",
45	cyan => "\e[36m",
46	white => "\e[37m",
47	);
48	%C = ( bold => "", nobold => "", nounderline => "", underline => "",
49	reset => "", normal => "", black => "",
50	red => "", green => "", brown => "", blue => "", magenta => "",
51	cyan => "", white => "" ) unless (-t STDOUT);
52
53	our @ALTCOLOURS = ("$C{cyan}$C{bold}", "$C{cyan}$C{nobold}");
54	# Global variables
55	our $PROMPT = "$SELF> ";
56	our $BANNER = '';
57	# Plugin path
58	my $PLUGINBASE = "$Config{prefix}/libexec";
59	my $PLUGINS = "$PLUGINBASE/$SELF";
60	#$PLUGINS = "./plugins";
61	our %CONF = (
62	prompt => {
63	value => \$PROMPT,
64	help => 'CLI prompt.'
65	},
66	debug => {
67	value => \$DEBUG,
68	pattern => '\d',
69	help => 'Set debug level (0-9).',
70	},
71	);
72	my %ORIGINAL_CONF = ();
73	my $CLI;
74
75
76	# Helper functions
77	sub logger {
78	#print(LOG "@_");
79	}
80
81	sub read_line($) {
82	fatal("Can only edit lines interactively.") unless -t STDOUT and -t STDIN;
83	my $prompt = shift;
84	my $term = new Term::ReadLine($prompt); $term->ornaments(0);
85
86	return $term->readline($prompt);
87	}
88
89	sub read_key($$) {
90	fatal("Can only read keys interactively.") unless -t STDOUT and -t STDIN;
91	my $prompt = shift;
92	my $valid = '[' . shift() . ']';
93	my $mode = $\|;
94	my $response;
95
96	$\| = 1;
97	ReadMode 4;
98	READ_KEY: while (1) {
99	print($prompt);
100	$response = ReadKey(0);
101	if (not defined($response) or $response !~ /$valid/) {
102	print("\nInvalid response.\n");
103	} else {
104	print("$response\n");
105	last READ_KEY;
106	}
107	}
108	ReadMode 0;
109	$\| = $mode;
110	return $response;
111	}
112
113	sub debug($;$) {
114	my ($msg, $level) = @_;
115
116	if (defined($level)) {
117	if ($DEBUG >= $msg) {
118	print("$C{magenta}$C{bold}DB$msg $level$C{reset}\n");
119	}
120	} elsif ($DEBUG > 0) {
121	print("$C{magenta}$C{bold}DB1 $msg$C{reset}\n");
122	}
123	}
124
125	sub fatal {
126	my $str = "$C{red}$C{bold}FTL @_$C{reset}\n";
127	print(STDERR $str);
128	logger($str);
129	exit 1;
130	}
131
132	sub error {
133	my $str = "$C{red}$C{bold}ERR @_$C{reset}\n";
134
135	print(STDERR $str);
136	logger($str);
137	return undef;
138	}
139
140	sub warning {
141	my $str = "$C{brown}$C{bold}WRN @_$C{reset}\n";
142
143	print(STDERR $str);
144	logger($str);
145	return undef;
146	}
147
148	sub info {
149	my $str;
150
151	if (@_ and $_[0] eq '-n') {
152	shift(@_);
153	$str = "$C{green}$C{bold}OK$C{normal} @_$C{reset}";
154	} else {
155	$str = "$C{green}$C{bold}OK$C{normal} @_$C{reset}\n";
156	}
157	print($str);
158	}
159
160	sub read_password($) {
161	my $prompt = shift;
162	my $tty = ctermid();
163
164	open(TTY, "+>$tty");
165	TTY->autoflush();
166	print(TTY $prompt);
167	ReadMode(2, *TTY);
168	my $secret = ReadLine(0, *TTY);
169	chomp($secret) if $secret;
170	ReadMode(0, *TTY);
171	print("\n");
172	close(TTY);
173	return $secret;
174	}
175
176	sub get_password($) {
177	warning("get_password() is deprecated and will be removed, use read_password()");
178	return read_password(@_);
179	}
180
181	# Format columnar text with fine control over row/title colours
182	sub format_columns_extended($$) {
183	my @header = @{shift()};
184	my @body = @{shift()};
185	my $hc = shift(@header);
186	my @bc;
187	my $text;
188	my $table = new Text::Table(@header);
189	my $row = 0;
190
191	# Extract colour column
192	for my $r (@body) {
193	my $colour = shift(@$r);
194
195	$colour = $ALTCOLOURS[++$row % 2] unless defined($colour);
196	push(@bc, $colour);
197	}
198
199	$table->load(@body);
200	$text = $table->title();
201	chomp($text);
202	$hc = "$C{bold}$C{underline}" unless defined($hc);
203	print("$hc$text$C{reset}\n");
204	for (my $line = 0; $line < $table->body_height(); ++$line) {
205	$text = $table->body($line);
206	chomp($text);
207	print($bc[$line] . $text . "$C{reset}\n");
208	}
209	}
210
211	# Format columns with default colours
212	sub format_columns($$) {
213	my ($title, $rows) = @_;
214
215	unshift(@$title, undef);
216	for my $row (@$rows) {
217	unshift(@$row, undef);
218	}
219	return format_columns_extended($title, $rows);
220	}
221
222	sub exec_line {
223	my $mode = shift;
224	my ($type, $action, $ctx) = $CLI->parse("@_");
225
226	if ($type eq 'HELP') {
227	print($action);
228	} elsif ($type eq 'ACTION') {
229	$action->($ctx, @{$ctx->args()});
230	} elsif ($type eq 'ERROR') {
231	if (defined($ctx)) {
232	my @gh = @{$ctx->grammar_history()};
233	my @th = @{$ctx->token_history()};
234	my @ath = @{$ctx->all_tokens()};
235	my $grammar = $gh[$#gh];
236	my @candidates;
237	push(@th, "") if $action =~ /More input expected/;
238	my $prefix = ' ' x length("@th[0 .. $#th - 1]") . (@th <= @ath ? ' ' : '');
239
240	$action = "$C{underline}@ath$C{nounderline}\n $prefix^ $action";
241	for my $key (keys(%{$gh[$#gh]})) {
242	my $cmd = $key;
243	my $type = ref($grammar->{$key});
244
245	next if $cmd =~ /^[A-Z]+$/;
246	$cmd =~ s/^(\d+\))?({.+?})?(\$(\*)?)?//;
247	if ($type eq 'HASH' and $grammar->{$key}->{HELP}) {
248	$type = ref($grammar->{$key}->{HELP});
249	if ($type eq 'ARRAY') {
250	$cmd = $grammar->{$key}->{HELP}->[0];
251	} elsif ($type eq 'CODE') {
252	my %s = $grammar->{$key}->{HELP}->($ctx, @{$ctx->args()});
253	push(@candidates, keys(%s));
254	$cmd = undef;
255	}
256	}
257	if (defined($cmd)) {
258	push(@candidates, $cmd);
259	}
260	}
261	if (@candidates and $grammar->{ACTION}) {
262	push(@candidates, "<eol>");
263	}
264	@candidates = sort(@candidates);
265	if (@candidates > 1) {
266	$action .= "\n ${prefix}Candidates are " . join(", ", @candidates[0 .. $#candidates - 1]) . " and " . $candidates[-1] . ".";
267	} elsif (@candidates == 1) {
268	$action .= "\n ${prefix}Expecting @candidates.";
269	} else {
270	if ($grammar->{ACTION}) {
271	$action .= "\n ${prefix}Expected end of command.";
272	}
273	}
274	}
275	error($action);
276	}
277	}
278
279	sub load_config($) {
280	my $file = shift;
281
282	if (open(CONF, "<$file")) {
283	while (<CONF>) {
284	next if /^\s$/ or /^#./;
285	$_ =~ /^([.\w-]+)\s=\s(.*)/;
286	if (defined($CONF{$1})) {
287	if ($CONF{$1}->{on_change}) {
288	${$CONF{$1}->{value}} = $CONF{$1}->{on_change}->(${$CONF{$1}->{value}}, $2);
289	} else {
290	${$CONF{$1}->{value}} = $2;
291	}
292	$CONF{$1}->{loaded} = 1;
293	}
294	}
295	close(CONF);
296	}
297	}
298
299
300	# Initialisation
301	my $GRAMMAR = {
302	HELPHEADER => "Help can be obtained at any stage by pressing $C{bold}?$C{normal} after any command.
303
304	eg. $C{bold}log ?$C{reset}
305
306	Words, optionally separated by a $C{bold}\|$C{normal}, indicate commands that can be
307	entered exactly as shown. Words enclosed in $C{bold}< >$C{normal} are user defined.
308	",
309	'{9999}set' => {
310	HELP => 'Query/modify settings.',
311	'$[\w.-]+' => {
312	'$.+' => {
313	ACTION => sub {
314	my $ctx = shift;
315	my ($key, $value) = @_;
316
317	if ($CONF{$key}) {
318	my $pattern = $CONF{$key}->{pattern};
319
320	$pattern = '.+' unless defined($pattern);
321	if ($value =~ /^$pattern$/) {
322	if ($CONF{$key}->{on_change}) {
323	${$CONF{$key}->{value}} = $CONF{$key}->{on_change}->(${$CONF{$key}->{value}}, $value);
324	} else {
325	${$CONF{$key}->{value}} = $value;
326	}
327	} else {
328	error("Value for '$key' is invalid.");
329	}
330	} else {
331	error("No such setting '$key'.");
332	}
333	},
334	VALIDATE => sub {
335	my ($ctx, $value, $pattern) = (shift, shift, $CONF{shift()}->{pattern});
336
337	$pattern = '.+' unless defined($pattern);
338	return $value =~ /^$pattern$/;
339	},
340	HELP => [ '<value>', 'Set value.' ],
341	},
342	VALIDATE => 1,
343	HELP => sub {
344	my $ctx = shift;
345	my %help;
346
347	for my $key (keys(%CONF)) {
348	$help{$key} = $CONF{$key}->{help} unless $CONF{$key}->{hidden};
349	}
350	return %help;
351	},
352	ACTION => {
353	ACTION => sub {
354	my $ctx = shift;
355	my $key = shift;
356
357	if ($CONF{$key} and !$CONF{$key}->{hidden}) {
358	print("$C{bold}$C{green}$key='$C{normal}${$CONF{$key}->{value}}$C{bold}'$C{reset}\n");
359	} else {
360	error("No such setting '$key'.");
361	}
362	},
363	HELP => 'List value of setting.',
364	},
365
366	},
367	ACTION => {
368	HELP => 'Display full list of settings.',
369	ACTION => sub {
370	my $ctx = shift;
371	my @rows = ();
372
373	for my $key (sort keys %CONF) {
374	my $value = ${$CONF{$key}->{value}};
375
376	# Strip ANSI codes
377	$value =~ s/\e\[.*?m//g;
378	push(@rows, [$key, $value, $CONF{$key}->{help}]) unless $CONF{$key}->{hidden};
379	}
380	format_columns(["Setting", "Value", "Description"], \@rows);
381	},
382	},
383	},
384	'{9999}history' => {
385	clear => {
386	ACTION => sub {
387	my $ctx = shift;
388
389	print(join(" ", @{$ctx->{token_history}}) . "\n");
390	Term::ReadLine::Gnu->clear_history();
391	info("History cleared");
392	},
393	HELP => "Clear the command line history."
394	},
395	ACTION => sub {
396	my $ctx = shift;
397	print(join("\n", Term::ReadLine::Gnu->GetHistory) . "\n");
398	},
399	HELP => "Display command line history.",
400	},
401	'{9999}quit\|exit' => {
402	HELP => [ 'exit', 'Exit.' ],
403	ACTION => sub { exit; },
404	},
405	};
406
407	# Add administrative functions if allowed
408	if (-w $PLUGINBASE and $SELF eq 'manage') {
409	$GRAMMAR = {
410	%$GRAMMAR,
411	init => {
412	HELP => "Initialise basic skeleton for a new CLI.",
413	'$\w+' => {
414	HELP => [ "<name>", "Name of CLI." ],
415	'$*.+' => {
416	HELP => [ "<module>", "Add a skeleton module to new CLI." ],
417	ACTION => {
418	HELP => "Initialise skeleton.",
419	ACTION => sub {
420	my ($ctx, $cli) = (shift, shift);
421	my @modules = @_;
422
423	print(<<EOF);
424	About to create CLI skeleton with the following attributes:
425
426	Binary symlink:
427	$Config{bin}/$cli -> $Config{bin}/$SELF
428	Modules:
429	EOF
430	for my $module (@modules) {
431	print(" $Config{prefix}/libexec/$cli/$module.pm\n");
432	}
433	print("\n");
434	my $response = read_key("Continue (y/n)? ", "yn");
435	if ($response eq 'y') {
436	info("Creating skeleton directories.");
437	mkdir("$Config{prefix}/libexec");
438	mkdir("$Config{prefix}/libexec/$cli");
439	for my $module (@modules) {
440	if (open(F, ">$Config{prefix}/libexec/$cli/$module.pm")) {
441	info("Creating module $cli\::$module");
442	print(F <<EOF);
443	# Put us in the manage namespace
444	package manage;
445
446	use warnings;
447	use strict;
448
449	# Some useful functions from manage itself
450	#sub format_columns(\$\$);
451	#sub read_key(\$\$);
452	#sub read_line(\$);
453	#sub get_password(\$);
454
455
456	{
457	# Place commands for CLI module $module here
458	};
459	EOF
460	close(F);
461	} else {
462	warning("Failed to create skeleton for $cli::$module.");
463	}
464	}
465	info("Creating symlink $Config{bin}/$cli");
466	symlink(${SELF}, "$Config{bin}/$cli");
467	info("Finished creating skeleton CLI.");
468	} elsif ($response eq 'n') {
469	warning("Initialisation aborted.");
470	}
471	},
472	},
473	},
474	},
475	},
476	};
477	}
478	$CLI = new CLI(
479	grammar => $GRAMMAR,
480	plugins => $PLUGINS,
481	);
482
483	# Merge config
484	for my $plugin (values(%{$CLI->{plugins}})) {
485	%CONF = (%CONF, %{$plugin->{conf}}) if $plugin->{conf};
486	}
487
488	# Initialise terminal and readline
489	my $term = new Term::ReadLine($SELF); $term->ornaments(0);
490	my $termattribs = $term->Attribs;
491	# Do command completion
492	$termattribs->{completion_function} = sub {
493	my ($text, $line, $start, $end) = @_;
494	my ($type, $action, $args) = $CLI->parse(substr($line, 0, $start) . ' ?');
495	my @matches;
496
497	if ($type eq 'HELP') {
498	my @line = grep(/^ \e/, split(/\n/, $action));
499
500	for my $line (@line) {
501	$line =~ s/^ \e\[1m([^\s\e]+).*/$1/;
502	next if $line =~ /^</;
503	if ($line =~ /^$text/) {
504	push(@matches,