Source code is now on gitorious, not SF
[janus-irc:janus.git] / src / Commands / Core.pm
1 # Copyright (C) 2007-2009 Daniel De Graaf
2 # Released under the GNU Affero General Public License v3
3 package Commands::Core;
4 use strict;
5 use warnings;
6 use integer;
7
8 $perl::VERSION = sprintf '%vd', $^V;
9
10 my %help_section = (
11         Account => 'Account managment',
12         Admin => 'Administration',
13         Channel => 'Channel managment',
14         Info => 'Information',
15         Network => 'Network managment',
16         Other => 'Other',
17 );
18
19 Event::command_add({
20         cmd => 'about',
21         help => 'Provides information about janus',
22         section => 'Info',
23         code => sub {
24                 Janus::jmsg($_[1],
25                         'Janus is a server that allows IRC networks to share certain channels to other',
26                         'linked networks without needing to share all channels and make all users visible',
27                         'across both networks. If configured to allow it, users can also share their own',
28                         'channels across any linked network.',
29                         'The source code can be found at http://gitorious.com/janus-irc/janus',
30                 );
31         }
32 }, {
33         cmd => 'modules',
34         help => 'Version information on all modules loaded by janus',
35         section => 'Info',
36         syntax => '[all|janus|other|sha][columns]',
37         api => '=src =replyto ?$',
38         code => sub {
39                 my($src,$dst,$parm) = @_;
40                 $parm ||= 'a';
41                 my $w = $parm =~ /(\d+)/ ? $1 : 3;
42                 my @mods;
43                 if ($parm =~ /^j/) {
44                         @mods = sort('main', grep { $main::INC{$_} !~ /^\// } keys %main::INC);
45                 } elsif ($parm =~ /^o/) {
46                         @mods = sort('perl', grep { $main::INC{$_} =~ /^\// } keys %main::INC);
47                 } else {
48                         @mods = sort('main', 'perl', keys %main::INC);
49                 }
50                 my @mvs;
51                 for (@mods) {
52                         s/\.pmc?$//;
53                         s#/#::#g;
54                         my $v;
55                         if ($parm =~ /^s/i) {
56                                 $v = $Janus::modinfo{$_} ? substr $Janus::modinfo{$_}{sha}, 0, 10 : '';
57                         } elsif ($Janus::modinfo{$_}) {
58                                 $v = $Janus::modinfo{$_}{version};
59                         } else {
60                                 no strict 'refs';
61                                 $v = ${$_.'::VERSION'};
62                         }
63                         next unless $v;
64                         push @mvs, [ $_, $v ];
65                 }
66                 Interface::msgtable($dst, \@mvs, cols => $w, fmtfmt => [ '%%-%ds', '%%%ds' ]);
67         }
68 }, {
69         cmd => 'modinfo',
70         help => 'Provides information about a module',
71         section => 'Info',
72         syntax => '<module>',
73         api => '=src =replyto $',
74         code => sub {
75                 my($src,$dst,$mod) = @_;
76                 return Janus::jmsg($dst, 'Module not loaded (or not janus module)') unless $Janus::modinfo{$mod};
77                 my $ifo = $Janus::modinfo{$mod};
78                 my $active = $ifo->{active} ? 'active' : 'inactive';
79                 Janus::jmsg($dst, "Module $mod is at version $ifo->{version}; hooks are $active",
80                         "Source checksum is $ifo->{sha}");
81                 Janus::jmsg($dst, ' '.$ifo->{desc}) if $ifo->{desc};
82                 my(@hooks, @cmds, @sets);
83                 for my $cmd (sort keys %Event::commands) {
84                         next unless $Event::commands{$cmd}{class} eq $mod;
85                         push @cmds, $cmd;
86                 }
87                 for my $set (sort keys %Event::settings) {
88                         next unless $Event::settings{$set}{class} eq $mod;
89                         push @sets, $set;
90                 }
91                 for my $lvl (sort keys %Event::hook_mod) {
92                         next unless $Event::hook_mod{$lvl}{$mod};
93                         push @hooks, $lvl;
94                 }
95                 Janus::jmsg($dst, 'Provides commands: '. join ' ', @cmds) if @cmds;
96                 Janus::jmsg($dst, 'Provides settings: '. join ' ', @sets) if @sets;
97                 Janus::jmsg($dst, 'Hooks: '. join ' ', @hooks) if @hooks;
98         },
99 }, {
100         cmd => 'reload',
101         help => "Load or reload a module, live.",
102         section => 'Admin',
103         syntax => '<module>',
104         details => [
105                 "\002WARNING\002: Reloading core modules may introduce bugs because of persistance",
106                 "of old code by the perl interpreter."
107         ],
108         acl => 'reload',
109         api => '=src =replyto $',
110         code => sub {
111                 my($src,$dst,$name) = @_;
112                 return Janus::jmsg($dst, "Invalid module name") unless $name =~ /^([0-9_A-Za-z:]+)$/;
113                 my $n = $1;
114                 my $over = $Janus::modinfo{$n}{version} || 'none';
115                 if (Janus::reload($n)) {
116                         my $ver = $Janus::modinfo{$n}{version} || 'unknown';
117                         Log::audit("Module $n reloaded ($over => $ver) by " . $src->netnick);
118                         Janus::jmsg($dst, "Module $n reloaded ($over => $ver)");
119                 } else {
120                         Log::audit("Reload of module $n by ".$src->netnick.' failed');
121                         Janus::jmsg($dst, "Module load failed");
122                 }
123         },
124 }, {
125         cmd => 'unload',
126         help => "Unload the hooks registered by a module",
127         section => 'Admin',
128         syntax => '<module>',
129         acl => 'unload',
130         api => '=src =replyto $',
131         code => sub {
132                 my($src,$dst,$name) = @_;
133                 if ($name !~ /::/ || $name eq __PACKAGE__) {
134                         Janus::jmsg($dst, "You cannot unload the core module $name");
135                         return;
136                 }
137                 Janus::unload($name);
138                 Log::audit("Module $name unloaded by ".$src->netnick);
139                 Janus::jmsg($dst, "Module $name unloaded");
140         }
141 }, {
142         cmd => 'help',
143         help => 'Help on janus commands. See "help help" for use.',
144         section => 'Info',
145         api => '=src =replyto ?$',
146         syntax => "[<command>|\002ALL\002]",
147         code => sub {
148                 my($src,$dst,$item) = @_;
149                 $item = lc $item || '';
150                 if (exists $Event::commands{lc $item}) {
151                         my $det = $Event::commands{$item}{details};
152                         my $syn = $Event::commands{$item}{syntax};
153                         my $help = $Event::commands{$item}{help};
154                         Janus::jmsg($dst, "Syntax: \002".uc($item)."\002 $syn") if $syn;
155                         if (ref $det) {
156                                 Janus::jmsg($dst, @$det);
157                         } elsif ($syn || $help) {
158                                 Janus::jmsg($dst, $help) if $help;
159                         } else {
160                                 Janus::jmsg($dst, 'No help exists for that command');
161                         }
162                         my $acl = $Event::commands{$item}{acl};
163                         if ($acl) {
164                                 $acl = 'oper' if $acl eq '1';
165                                 my $allow = Account::acl_check($src, $acl) ? 'you' : 'you do not';
166                                 Janus::jmsg($dst, "Requires access to '$acl' ($allow currently have access)");
167                         }
168                         my $aclchk = $Event::commands{$item}{aclchk};
169                         if ($aclchk) {
170                                 my $allow = Account::acl_check($src, $aclchk) ? 'you' : 'you do not';
171                                 Janus::jmsg($dst, "Some options may require access to '$aclchk' ($allow currently have access)");
172                         }
173                 } elsif ($item eq '' || $item eq 'all') {
174                         my %cmds;
175                         my $synlen = 0;
176                         for my $cmd (sort keys %Event::commands) {
177                                 my $h = $Event::commands{$cmd}{help};
178                                 my $acl = $Event::commands{$cmd}{acl};
179                                 next unless $h;
180                                 if ($acl && $item ne 'all') {
181                                         $acl = 'oper' if $acl eq '1';
182                                         next unless Account::acl_check($src, $acl);
183                                 }
184                                 my $section = $Event::commands{$cmd}{section} || 'Other';
185                                 $cmds{$section} ||= [];
186                                 push @{$cmds{$section}}, $cmd;
187                                 $synlen = length $cmd if length $cmd > $synlen;
188                         }
189                         Janus::jmsg($dst, "Use '\002HELP\002 command' for details");
190                         for my $section (sort keys %cmds) {
191                                 my $sname = $help_section{$section} || $section;
192                                 Janus::jmsg($dst, $sname.':', map {
193                                         sprintf " \002\%-${synlen}s\002  \%s", uc $_, $Event::commands{$_}{help};
194                                 } @{$cmds{$section}});
195                         }
196                 } else {
197                         Janus::jmsg($dst, "Command not found. Use '\002HELP\002' to see the list of commands");
198                 }
199         }
200 });
201
202 1;