2020-07-09 08:21:54 +02:00
|
|
|
# File: Plang.pm
|
|
|
|
# Author: pragma-
|
|
|
|
#
|
|
|
|
# Purpose: Simplified scripting language for creating advanced PBot factoids
|
|
|
|
# and interacting with various internal PBot APIs.
|
|
|
|
|
|
|
|
# This Source Code Form is subject to the terms of the Mozilla Public
|
|
|
|
# License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
|
|
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
|
|
|
|
|
|
|
package Plugins::Plang;
|
|
|
|
use parent 'Plugins::Plugin';
|
|
|
|
|
|
|
|
use warnings; use strict;
|
|
|
|
use feature 'unicode_strings';
|
|
|
|
|
|
|
|
use Getopt::Long qw(GetOptionsFromArray);
|
|
|
|
|
|
|
|
sub initialize {
|
|
|
|
my ($self, %conf) = @_;
|
|
|
|
|
2020-07-19 04:48:05 +02:00
|
|
|
# load Plang module
|
2020-07-09 08:21:54 +02:00
|
|
|
my $path = $self->{pbot}->{registry}->get_value('general', 'plang_dir') // 'Plang';
|
|
|
|
unshift @INC, $path if not grep { $_ eq $path } @INC;
|
|
|
|
require "$path/Interpreter.pm";
|
|
|
|
|
2020-07-19 04:48:05 +02:00
|
|
|
# allow !refresh to reload these modules
|
|
|
|
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/Interpreter.pm");
|
|
|
|
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/AstInterpreter.pm");
|
|
|
|
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/Grammar.pm");
|
|
|
|
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/Lexer.pm");
|
|
|
|
$self->{pbot}->{refresher}->{refresher}->update_cache("$path/Parser.pm");
|
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
# regset plang.debug 0-10 -- Plugin must be reloaded for this value to take effect.
|
2020-07-09 08:21:54 +02:00
|
|
|
my $debug = $self->{pbot}->{registry}->get_value('plang', 'debug') // 0;
|
2020-07-12 06:15:54 +02:00
|
|
|
|
|
|
|
# create our Plang interpreter object
|
2020-07-09 08:21:54 +02:00
|
|
|
$self->{plang} = Plang::Interpreter->new(embedded => 1, debug => $debug);
|
|
|
|
|
2020-07-19 04:48:05 +02:00
|
|
|
# register some PBot-specific built-in functions
|
2020-07-13 02:36:32 +02:00
|
|
|
$self->{plang}->{interpreter}->add_function_builtin('factset',
|
|
|
|
# parameters are [['param1 name', default arg], ['param2 name', default arg], ...]
|
2020-07-13 07:09:59 +02:00
|
|
|
[['namespace', undef], ['keyword', undef], ['text', undef]],
|
2020-07-13 06:18:17 +02:00
|
|
|
sub { $self->set_factoid(@_) });
|
2020-07-13 02:36:32 +02:00
|
|
|
|
|
|
|
$self->{plang}->{interpreter}->add_function_builtin('factget',
|
2020-07-13 07:09:59 +02:00
|
|
|
[['namespace', undef], ['keyword', undef], ['meta', ['STRING', 'action']]],
|
2020-07-13 06:18:17 +02:00
|
|
|
sub { $self->get_factoid(@_) });
|
2020-07-13 02:36:32 +02:00
|
|
|
|
|
|
|
$self->{plang}->{interpreter}->add_function_builtin('factappend',
|
2020-07-13 07:09:59 +02:00
|
|
|
[['namespace', undef], ['keyword', undef], ['text', undef]],
|
2020-07-13 06:18:17 +02:00
|
|
|
sub { $self->append_factoid(@_) });
|
2020-07-12 06:15:54 +02:00
|
|
|
|
2020-07-19 04:48:05 +02:00
|
|
|
# override the built-in `print` function to send to our output buffer instead
|
|
|
|
$self->{plang}->{interpreter}->add_function_builtin('print',
|
|
|
|
[['stmt', undef], ['end', ['STRING', "\n"]]],
|
|
|
|
sub { $self->print_override(@_) });
|
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
# register the `plang` command
|
2020-07-09 08:21:54 +02:00
|
|
|
$self->{pbot}->{commands}->register(sub { $self->cmd_plang(@_) }, "plang", 0);
|
|
|
|
}
|
|
|
|
|
|
|
|
sub unload {
|
|
|
|
my $self = shift;
|
|
|
|
$self->{pbot}->{commands}->unregister("plang");
|
|
|
|
}
|
|
|
|
|
|
|
|
sub cmd_plang {
|
|
|
|
my ($self, $context) = @_;
|
|
|
|
|
2020-07-13 03:53:57 +02:00
|
|
|
my $usage = "Usage: plang <code>; see https://github.com/pragma-/Plang";
|
2020-07-09 08:21:54 +02:00
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
return $usage if not length $context->{arguments};
|
|
|
|
|
|
|
|
# run() returns result of the final statement
|
|
|
|
my $result = $self->run($context->{arguments});
|
|
|
|
|
|
|
|
# check to see if we need to append final result to output
|
2020-07-16 06:47:03 +02:00
|
|
|
$self->{output} .= $self->{plang}->{interpreter}->output_value($result) if defined $result->[1];
|
2020-07-12 06:15:54 +02:00
|
|
|
|
2020-07-13 02:36:32 +02:00
|
|
|
# return the output
|
2020-07-12 06:15:54 +02:00
|
|
|
return length $self->{output} ? $self->{output} : "No output.";
|
|
|
|
}
|
|
|
|
|
|
|
|
# run an embedded plang program
|
2020-07-13 03:33:13 +02:00
|
|
|
# TODO this is just a proof-of-concept at this stage; 90% of this stuff will be moved into Plang::Interpreter
|
2020-07-12 06:15:54 +02:00
|
|
|
sub run {
|
|
|
|
my ($self, $code) = @_;
|
2020-07-09 08:21:54 +02:00
|
|
|
|
2020-07-13 03:33:13 +02:00
|
|
|
# reset output buffer
|
|
|
|
$self->{output} = ""; # collect output of the embedded Plang program
|
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
# parse the code into an ast
|
|
|
|
my $ast = $self->{plang}->parse_string($code);
|
2020-07-13 03:33:13 +02:00
|
|
|
|
|
|
|
# check for parse errors
|
|
|
|
my $errors = $self->{plang}->handle_parse_errors;
|
|
|
|
return ['ERROR', $errors] if defined $errors;
|
|
|
|
|
|
|
|
# return if no program
|
2020-07-12 06:15:54 +02:00
|
|
|
return if not defined $ast;
|
2020-07-09 08:21:54 +02:00
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
# create a new environment for a Plang program
|
2020-07-19 04:48:05 +02:00
|
|
|
my $context = $self->{plang}->{interpreter}->new_context;
|
2020-07-09 08:21:54 +02:00
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
# grab our program's statements
|
|
|
|
my $program = $ast->[0];
|
|
|
|
my $statements = $program->[1];
|
|
|
|
|
2020-07-16 06:47:03 +02:00
|
|
|
my $result; # result of the final statement
|
2020-07-12 06:15:54 +02:00
|
|
|
|
2020-07-13 02:36:32 +02:00
|
|
|
eval {
|
|
|
|
# interpret the statements
|
|
|
|
foreach my $node (@$statements) {
|
|
|
|
my $ins = $node->[0];
|
2020-07-12 06:15:54 +02:00
|
|
|
|
2020-07-13 02:36:32 +02:00
|
|
|
if ($ins eq 'STMT') {
|
|
|
|
$result = $self->{plang}->{interpreter}->statement($context, $node->[1]);
|
2020-07-13 06:18:17 +02:00
|
|
|
|
2020-07-14 04:32:00 +02:00
|
|
|
if ($result->[0] eq 'STDOUT') {
|
|
|
|
$self->{output} .= $result->[1];
|
|
|
|
$result = undef;
|
|
|
|
next;
|
|
|
|
}
|
2020-07-13 06:18:17 +02:00
|
|
|
|
|
|
|
if ($result->[0] eq 'ERROR') {
|
|
|
|
$self->{output} .= "Error: $result->[1]";
|
|
|
|
$result = undef;
|
|
|
|
last;
|
|
|
|
}
|
2020-07-13 02:36:32 +02:00
|
|
|
}
|
2020-07-12 06:15:54 +02:00
|
|
|
}
|
2020-07-13 02:36:32 +02:00
|
|
|
};
|
2020-07-12 06:15:54 +02:00
|
|
|
|
2020-07-13 02:36:32 +02:00
|
|
|
if ($@) {
|
|
|
|
$self->{output} .= $@;
|
2020-07-12 06:15:54 +02:00
|
|
|
return;
|
|
|
|
}
|
|
|
|
|
2020-07-13 02:36:32 +02:00
|
|
|
return $result; # return result of the final statement
|
2020-07-12 06:15:54 +02:00
|
|
|
}
|
|
|
|
|
2020-07-19 04:48:05 +02:00
|
|
|
# overridden `print` built-in
|
|
|
|
sub print_override {
|
|
|
|
my ($self, $plang, $name, $arguments) = @_;
|
|
|
|
my ($stmt, $end) = ($plang->output_value($arguments->[0]), $arguments->[1]->[1]);
|
|
|
|
$self->{output} .= "$stmt$end";
|
2020-07-19 08:27:44 +02:00
|
|
|
return ['STRING', "$stmt$end"];
|
2020-07-19 04:48:05 +02:00
|
|
|
}
|
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
# our custom PBot built-in functions for Plang
|
|
|
|
|
2020-07-13 06:18:17 +02:00
|
|
|
sub is_locked {
|
|
|
|
my ($self, $channel, $keyword) = @_;
|
|
|
|
return $self->{pbot}->{factoids}->get_meta($channel, $keyword, 'locked');
|
|
|
|
}
|
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
sub get_factoid {
|
2020-07-13 06:18:17 +02:00
|
|
|
my ($self, $plang, $name, $arguments) = @_;
|
2020-07-13 07:09:59 +02:00
|
|
|
my ($namespace, $keyword, $meta) = ($arguments->[0]->[1], $arguments->[1]->[1], $arguments->[2]->[1]);
|
|
|
|
my $result = $self->{pbot}->{factoids}->get_meta($namespace, $keyword, $meta);
|
2020-07-13 06:18:17 +02:00
|
|
|
return ['STRING', $result];
|
2020-07-12 06:15:54 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
sub set_factoid {
|
2020-07-13 06:18:17 +02:00
|
|
|
my ($self, $plang, $name, $arguments) = @_;
|
2020-07-13 07:09:59 +02:00
|
|
|
my ($namespace, $keyword, $text) = ($arguments->[0]->[1], $arguments->[1]->[1], $arguments->[2]->[1]);
|
|
|
|
return ['ERROR', "Factoid $namespace.$keyword is locked. Cannot set."] if $self->is_locked($namespace, $keyword);
|
|
|
|
$self->{pbot}->{factoids}->add_factoid('text', $namespace, 'Plang', $keyword, $text);
|
2020-07-13 06:18:17 +02:00
|
|
|
return ['STRING', $text];
|
2020-07-12 06:15:54 +02:00
|
|
|
}
|
2020-07-09 08:21:54 +02:00
|
|
|
|
2020-07-12 06:15:54 +02:00
|
|
|
sub append_factoid {
|
2020-07-13 06:18:17 +02:00
|
|
|
my ($self, $plang, $name, $arguments) = @_;
|
2020-07-13 07:09:59 +02:00
|
|
|
my ($namespace, $keyword, $text) = ($arguments->[0]->[1], $arguments->[1]->[1], $arguments->[2]->[1]);
|
|
|
|
return ['ERROR', "Factoid $namespace.$keyword is locked. Cannot append."] if $self->is_locked($namespace, $keyword);
|
|
|
|
my $action = $self->{pbot}->{factoids}->get_meta($namespace, $keyword, 'action');
|
2020-07-13 06:18:17 +02:00
|
|
|
$action = "" if not defined $action;
|
|
|
|
$action .= $text;
|
2020-07-13 07:09:59 +02:00
|
|
|
$self->{pbot}->{factoids}->add_factoid('text', $namespace, 'Plang', $keyword, $action);
|
2020-07-13 06:18:17 +02:00
|
|
|
return ['STRING', $action];
|
2020-07-09 08:21:54 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
1;
|