Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
289 lines (233 sloc) 7.74 KB
=head1 perlalias.pl - Perl-based command aliases for irssi
This script provides an /alias-like function that uses small pieces of perl code to carry out the commands.
=head2 Usage
Install into irssi script directory and /run perlalias and/or put into autorun.
=head2 Commands
=over
=item /perlalias
Syntax: /perlalias [[[-]<alias>] [<code>]]
Parameters: A name of the alias and the perl code to execute.
If you prepend the alias with -, it will remove the alias.
If you give no arguments, the list of defined aliases will be displayed.
Description:
Creates or updates an alias. Like any perl code, multiple statements must be separated using ; characters.
No replacement of parameter values is done: any $text is a perl variable.
The arguments given to the /alias when typed are put into $_ and are also split on whitespace and put into @_.
In addition, the variables $server and $witem will refer to the active server and window item respectively.
Examples:
/PERLALIAS UNACT foreach my $w (Irssi::windows) { $w->activity(0); }
=back
=over
=item /perlunalias
Syntax: /perlunalias <alias>
Parameters: The alias to remove.
Description:
Removes the given alias.
=back
Additionally, all aliases added are linked to perlalias.pl: if it is unloaded, the aliases will be removed.
Aliases can be saved and reloaded with the usual /save and /reload (including autosave). Saved aliases are loaded at script load.
=head2 ChangeLog
=over
=item 1.0
First version.
=back
=cut
use strict;
use warnings FATAL => qw(all);
use Irssi;
use Irssi::Irc;
use Carp ();
#use Cwd;
use POSIX qw(strftime);
{ package Irssi::Nick; } # Keeps trying to look for this package but for some reason it doesn't get loaded.
our $VERSION = '1.2';
our %IRSSI = (
authors => 'aquanight',
contact => 'aquanight@gmail.com',
name => 'perlalias',
description => 'Quickly create commands from short perl blocks',
license => 'public domain'
);
# Bound commands
my %cmds; # Contains command entries. The entry has three items:
# textcmd => Plaintext of the command to execute, which is used for loading/saving
# cmpcmd => Compiled command, for executing.
# tag => Our tag which we need to remove the command
# Package we execute all the commands within, to keep them away from our bits.
package Irssi::Script::perlalias::aliaspkg {
}
sub DESTROY {
Symbol::delete_package("Irssi::Script::perlalias::aliaspkg::");
}
# Alias executor
sub exec_perlalias {
my ($cmd, $data, $server, $witem) = @_;
exists $cmds{$cmd} or return;
defined $cmds{$cmd}->{cmpcmd} or return;
local $_ = $data;
$cmds{$cmd}->{cmpcmd}->($server, $witem, split / +/, $data);
}
# Bind a command
sub setup_command {
my ($cmd, $data) = @_;
# Compile the script.
my $code = qq{package Irssi::Scripts::perlalias::aliaspkg;\nno warnings;\nsub {my \$server = shift; my \$witem = shift;\n#line 1 "perlalias $cmd"\n$data}\n};
my $proc = eval $code;
if ($@) {
Irssi::printformat(MSGLEVEL_CLIENTERROR, perlalias_compile_error => $cmd);
Irssi::print(MSGLEVEL_CLIENTERROR, $@);
return "";
}
if (exists($cmds{$cmd})) {
my $entry = $cmds{$cmd};
$entry->{textcmd} = $data;
$entry->{cmpcmd} = $proc;
}
else {
my $entry = {};
my $tag = sub { exec_perlalias $cmd, @_; };
foreach my $existing_cmd (Irssi::commands()) {
if ($existing_cmd->{cmd} eq $cmd) {
Irssi::print_format(MSGLEVEL_CLIENTERROR, perlalias_cmd_in_use => $cmd);
return "";
}
}
$entry->{textcmd} = $data;
$entry->{cmpcmd} = $proc;
$entry->{tag} = sub { exec_perlalias $cmd, @_; };
Irssi::command_bind($cmd, $entry->{tag});
$cmds{$cmd} = $entry;
}
return 1;
}
sub remove_command {
my ($cmd) = @_;
if (exists($cmds{$cmd})) {
my $entry = $cmds{$cmd};
$entry->{tag}//die "Missing the tag we need to remove the alias!!!";
Irssi::command_unbind($cmd, $entry->{tag});
delete $cmds{$cmd};
return 1;
}
else {
Irssi::printformat(MSGLEVEL_CLIENTERROR, perlalias_not_found => $cmd);
return "";
}
}
sub list_commands {
my ($prefix) = @_;
my @whichones = sort grep /^\Q$prefix\E/, keys %cmds;
Irssi::printformat(MSGLEVEL_CLIENTCRAP, 'perlaliaslist_header');
for my $name (@whichones) {
my $entry = $cmds{$name};
Irssi::printformat(MSGLEVEL_CLIENTCRAP, perlaliaslist_line => $name, $entry->{textcmd});
}
}
sub cmd_perlalias {
my ($data, $server, $witem) = @_;
my ($command, $script) = split /\s+/, $data, 2;
if (($command//"") eq "") {
list_commands "";
}
elsif ($command =~ m/^-/) {
$command = substr($command, 1);
if (remove_command($command)) { Irssi::printformat(MSGLEVEL_CLIENTNOTICE, perlalias_removed => $command); }
}
elsif (($script//"") eq "") {
list_commands $command;
}
else {
if (setup_command($command, $script)) { Irssi::printformat(MSGLEVEL_CLIENTNOTICE, perlalias_added => $command); }
}
}
sub cmd_perlunalias {
my ($data, $server, $witem) = @_;
if (remove_command $data) { Irssi::printformat(MSGLEVEL_CLIENTNOTICE, perlalias_removed => $data); }
}
sub sig_setup_saved {
my ($main, $auto) = @_;
my $file = Irssi::get_irssi_dir() . "/perlalias";
open my $fd, '>', $file or return;
for my $cmd (keys %cmds) {
my $entry = $cmds{$cmd};
printf $fd "%s\t%s\n", $cmd, $entry->{textcmd};
}
close $fd;
}
sub sig_setup_reread {
my $file = Irssi::get_irssi_dir() . "/perlalias";
open my $fd, "<", $file or return;
my $ln;
my %newcmds;
while (defined($ln = <$fd>)) {
chomp $ln;
my ($cmd, $script) = split /\t/, $ln, 2;
if (exists $newcmds{$cmd}) {
Irssi::print(MSGLEVEL_CLIENTERROR, "There is a duplicate record in the PerlAlias save file.");
Irssi::print(MSGLEVEL_CLIENTERROR, "Offending alias: $cmd");
Irssi::print(MSGLEVEL_CLIENTERROR, "Previous definition: " . $newcmds{$cmd});
Irssi::print(MSGLEVEL_CLIENTERROR, "Duplicate definition: $script");
}
$newcmds{$cmd} = $script;
}
# Scrub the existing list. Update existings, remove any that aren't in the config, then we'll add any that's new.
my @currentcmds = keys %cmds;
for my $cmd (@currentcmds) {
if (exists $newcmds{$cmd}) {
setup_command($cmd, $newcmds{$cmd});
}
else {
remove_command($cmd);
}
delete $newcmds{$cmd};
}
# By this point all that should be in newcmds is any ... new commands.
for my $cmd (keys %newcmds) {
setup_command($cmd, $newcmds{$cmd});
}
close $fd;
}
sub sig_complete_perlalias {
my ($lst, $win, $word, $line, $want_space) = @_;
$word//return;
$line//return;
$lst//return;
if ($line ne '') {
my $def = $cmds{$line};
$def//return;
push @$lst, $def->{textcmd};
Irssi::signal_stop();
}
else {
push @$lst, (grep /^\Q$word\E/i, keys %cmds);
Irssi::signal_stop();
}
}
sub sig_complete_perlunalias {
my ($lst, $win, $word, $line, $want_space) = @_;
$lst//return;
$word//return;
push @$lst, (grep /^\Q$word\E/i, keys %cmds);
}
Irssi::signal_register({"complete command " => [qw(glistptr_char* Irssi::UI::Window string string intptr)]});
Irssi::signal_add("complete command perlalias" => \&sig_complete_perlalias);
Irssi::signal_add("complete command perlunalias" => \&sig_complete_perlunalias);
Irssi::signal_add("setup saved" => \&sig_setup_saved);
Irssi::signal_add("setup reread" => \&sig_setup_reread);
Irssi::command_bind(perlalias => \&cmd_perlalias);
Irssi::command_bind(perlunalias => \&cmd_perlunalias);
my %formats = (
# $0 Name of alias
'perlalias_compile_error' => '{error Error compiling alias {hilight $0}:}',
# $0 Name of alias
'perlalias_exec_error' => '{error Error executing alias {hilight $0}:}',
'perlalias_cmd_in_use' => 'Command {hilight $0} is already in use',
'perlalias_added' => 'PerlAlias {hilight $0} added',
'perlalias_removed' => 'PerlAlias {hilight $0} removed',
'perlalias_not_found' => 'PerlAlias {hilight $0} not found',
'perlaliaslist_header' => '%#PerlAliases:',
# $0 Name of alias, $1 alias text
'perlaliaslist_line' => '%#$[10]0 $1',
);
Irssi::theme_register([%formats]);
sig_setup_reread;