Skip to content
This repository
Newer
Older
100755 1158 lines (976 sloc) 32.632 kb
021602ab »
2002-05-05 Removed -w to save filling up error logs
1 #! /usr/bin/perl -T
1a96077d »
2002-03-05 Interfaces now working, with detection for IE and mozilla, work still…
2 # CGI:IRC - http://cgiirc.sourceforge.net/
3 # Copyright (C) 2000-2002 David Leadbeater <cgiirc@dgl.cx>
1824c08d »
2002-04-14 New User list, *lots* of other stuff, cleanups and so on..
4 # vim:set ts=3 expandtab shiftwidth=3 cindent:
1a96077d »
2002-03-05 Interfaces now working, with detection for IE and mozilla, work still…
5
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
10
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
15
16 # You should have received a copy of the GNU General Public License
17 # along with this program; if not, write to the Free Software
18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
20 # Uncomment this if the server doesn't chdir (Boa).
21 # BEGIN { (my $dir = $0) =~ s|[^/]+$||; chdir($dir) }
22
da0a3a00 »
2002-03-05 Initial revision
23 require 5.004;
24 use strict;
a3ea3074 »
2002-05-01 runs under -T now :)
25 use lib qw{./modules ./interfaces};
da0a3a00 »
2002-03-05 Initial revision
26 use vars qw(
8c31c1ca »
2002-07-01 Client pingy stuff
27 $VERSION @handles %inbuffer $select_bits @output
3e2cf322 »
2002-11-02 ping fix
28 $unixfh $ircfh $cookie $ctcptime $intime $pingtime
8c31c1ca »
2002-07-01 Client pingy stuff
29 $timer $event $config $cgi $irc $format $interface $ioptions
30 $regexpicon %regexpicon
da0a3a00 »
2002-03-05 Initial revision
31 );
32
c024623e »
2002-03-05 Reorganised headers to make more sense
33 ($VERSION =
ce67c540 »
2003-04-16 add max_users
34 '$Name: $ 0_5_CVS $Id: nph-irc.cgi,v 1.84 2003/04/16 12:10:27 dgl Exp $'
75181b5d »
2002-11-24 New version code to show date of cvs versions
35 ) =~ s/^.*?(\d\S+) .*?(\d{4}\/\S+) .*$/$1/;
36 $VERSION .= " ($2)" if index($VERSION, "CVS") > 0;
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
37 $VERSION =~ s/_/./g;
da0a3a00 »
2002-03-05 Initial revision
38
c024623e »
2002-03-05 Reorganised headers to make more sense
39 use Socket;
40 use Symbol; # gensym
41 $|++;
da0a3a00 »
2002-03-05 Initial revision
42 # Check for IPV6. Bit yucky but avoids errors when module isn't present
43 BEGIN {
44 eval('use Socket6; $::IPV6++ if defined $Socket6::VERSION');
45 unless(defined $::IPV6) {
46 $::IPV6 = 0;
8c31c1ca »
2002-07-01 Client pingy stuff
47 eval('sub AF_INET6 {0};sub NI_NUMERICHOST {0};sub NI_NUMERICSERV {}');
da0a3a00 »
2002-03-05 Initial revision
48 }
49 }
50
51 # My own Modules
52 use Timer;
53 use Event;
54 use IRC;
55 use Command;
56 require 'parse.pl';
57
c024623e »
2002-03-05 Reorganised headers to make more sense
58 my $needtodie = 0;
c78e6e07 »
2002-10-20 oops
59 $SIG{HUP} = $SIG{INT} = $SIG{TERM} = sub { $needtodie = 1 };
c332be9f »
2002-10-17 form_redirect works..
60 # Pipe isn't bad..
61 $SIG{PIPE} = 'IGNORE';
84b81ebc »
2002-03-15 Non-js interface nearly working, tab completion fixed in mozilla and …
62
63 $SIG{__DIE__} = sub {
64 error("Program ending: @_");
65 };
66
67 # DEBUG
68 #use Carp;
69 #$SIG{__DIE__} = \&confess;
c024623e »
2002-03-05 Reorganised headers to make more sense
70
da0a3a00 »
2002-03-05 Initial revision
71 #### Network Functions
72
73 ## Returns the address of a host (handles both IPv4 and IPv6)
74 ## Return value: (ipv4,ipv6)
75 sub net_hostlookup {
76 my($host) = @_;
77
78 if($::IPV6) {
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
79 my($family,$socktype, $proto, $saddr, $canonname, @res) =
a910162f »
2002-05-10 DCC reject works.
80 getaddrinfo($host, undef, AF_UNSPEC, SOCK_STREAM);
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
81 return undef unless $family;
2f32521a »
2002-05-06 ipv6 stuff
82 my($addr, $port) = getnameinfo($saddr, NI_NUMERICHOST | NI_NUMERICSERV);
aeac62ef »
2002-10-02 big commit
83 =pod
84 my $ip = config_set('prefer_v6')
85 ? ($ipv6 ? $ipv6 : $ipv4)
86 : ($ipv4 ? $ipv4 : $ipv6);
87 =cut
88 return $addr;
da0a3a00 »
2002-03-05 Initial revision
89 }else{ # IPv4
0307205c »
2002-05-09 IPv6 finally working :)
90 my $ip = (gethostbyname($host))[4];
91 return $ip ? inet_ntoa($ip) : undef;
da0a3a00 »
2002-03-05 Initial revision
92 }
93 }
94
95 ## Connects a tcp socket and returns the file handle
2f32521a »
2002-05-06 ipv6 stuff
96 ## inet_addr should be the output of net_gethostbyname
da0a3a00 »
2002-03-05 Initial revision
97 sub net_tcpconnect {
2f32521a »
2002-05-06 ipv6 stuff
98 my($inet_addr, $port) = @_;
da0a3a00 »
2002-03-05 Initial revision
99 my $fh = Symbol::gensym;
0307205c »
2002-05-09 IPv6 finally working :)
100 my $family = ($inet_addr !~ /:/ ? AF_INET : AF_INET6);
da0a3a00 »
2002-03-05 Initial revision
101
0307205c »
2002-05-09 IPv6 finally working :)
102 socket($fh, $family, SOCK_STREAM,
2f32521a »
2002-05-06 ipv6 stuff
103 getprotobyname('tcp')) or return(0, $!);
ff5d3062 »
2002-04-05 *** empty log message ***
104 setsockopt($fh, SOL_SOCKET, SO_KEEPALIVE, pack("l", 1)) or return(0, $!);
105
da0a3a00 »
2002-03-05 Initial revision
106 my $saddr;
2f32521a »
2002-05-06 ipv6 stuff
107 if($inet_addr !~ /:/) {
8c31c1ca »
2002-07-01 Client pingy stuff
108 $saddr = sockaddr_in($port, inet_aton($inet_addr));
109 if(config_set('vhost')) {
110 (my $vhost) = $config->{vhost} =~ /([^ ]+)/;
111 bind($fh, pack_sockaddr_in(0, inet_aton($vhost)));
112 }else{
113 bind($fh, pack_sockaddr_in(0, inet_aton('0.0.0.0')));
114 }
2f32521a »
2002-05-06 ipv6 stuff
115 }else{
8c31c1ca »
2002-07-01 Client pingy stuff
116 $saddr = sockaddr_in6($port, inet_pton(AF_INET6, $inet_addr));
117 if(config_set('vhost6')) {
118 # this needs testing...
119 (my $vhost) = $config->{vhost6} =~ /([^ ]+)/;
120 bind($fh, pack_sockaddr_in6(0, inet_pton(AF_INET6, $vhost)));
121 }
da0a3a00 »
2002-03-05 Initial revision
122 }
123
0307205c »
2002-05-09 IPv6 finally working :)
124 if($family == AF_INET) {
125 my($localport,$localip) = sockaddr_in(getsockname $fh);
126 irc_write_server(inet_ntoa($localip), $localport, $inet_addr, $port);
127 }else{
128 my($localport,$localip) = sockaddr_in6(getsockname $fh);
129 irc_write_server(inet_pton(AF_INET6, $localip), $localport, $inet_addr, $port);
130 }
57feb2b8 »
2002-04-24 removed race condition on writing server file - identd should *always…
131
aeac62ef »
2002-10-02 big commit
132 $SIG{ALRM} = sub { die "timeout" };
133 eval {
134 local $SIG{__DIE__} = undef;
135 alarm 60;
136 connect($fh, $saddr) or return (0,$!);
137 };
138 alarm 0;
139
140 if($@ =~ /timeout/) {
141 return(0, "Connection timed out (60 seconds)");
142 }
da0a3a00 »
2002-03-05 Initial revision
143
79b1a797 »
2002-05-01 realised the stupid bug causing errors in select
144 net_autoflush($fh);
da0a3a00 »
2002-03-05 Initial revision
145
57feb2b8 »
2002-04-24 removed race condition on writing server file - identd should *always…
146 return($fh);
da0a3a00 »
2002-03-05 Initial revision
147 }
148
149 ## Opens a UNIX Domain Listening socket
150 ## Passed just the filename, returns 1 on success, 0 on failure
151 sub net_unixconnect {
152 my($local) = @_;
153 my $fh = Symbol::gensym;
154
155 if(-e $local) {
8c31c1ca »
2002-07-01 Client pingy stuff
156 return 0 unless unlink $local;
da0a3a00 »
2002-03-05 Initial revision
157 }
158
159 socket($fh, PF_UNIX, SOCK_STREAM, 0) or return (0, $!);
160 bind($fh, sockaddr_un($local)) or return (0, $!);
161 listen($fh, SOMAXCONN) or return (0, $!);
162
79b1a797 »
2002-05-01 realised the stupid bug causing errors in select
163 net_autoflush($fh);
164
da0a3a00 »
2002-03-05 Initial revision
165 return $fh;
166 }
167
79b1a797 »
2002-05-01 realised the stupid bug causing errors in select
168 sub net_autoflush {
169 my $fh = shift;
170 select $fh;
171 $| = 1;
172 select STDOUT;
173 }
174
da0a3a00 »
2002-03-05 Initial revision
175 ## Send data to specific filehandle
176 sub net_send {
177 my($fh,$data) = @_;
178 syswrite($fh, $data, length $data);
179 }
180
181 #### Select Helper Functions
182 ## Code adapted from IO::Select.pm by Graham Barr
183
184 ## Adds file handle into @handles and fileno into the bit vector
185 sub select_add {
186 my($fh) = @_;
187 my $fileno = select_fileno($fh);
79b1a797 »
2002-05-01 realised the stupid bug causing errors in select
188 $handles[$fileno] = $fh;
189 select_makebits();
da0a3a00 »
2002-03-05 Initial revision
190 }
191
192 ## Deletes the filehandle and fileno
193 sub select_del {
194 my($fh) = @_;
195 my $fileno = select_fileno($fh);
196 if(!$fileno) {
8c31c1ca »
2002-07-01 Client pingy stuff
197 for(0 .. $#handles) {
198 $fileno = $_, last if $handles[$_] == $fh;
199 }
da0a3a00 »
2002-03-05 Initial revision
200 }
201 return unless defined $handles[$fileno];
8c31c1ca »
2002-07-01 Client pingy stuff
202
79b1a797 »
2002-05-01 realised the stupid bug causing errors in select
203 $handles[$fileno] = undef;
204 select_makebits();
da0a3a00 »
2002-03-05 Initial revision
205 }
206
207 ## Returns a fileno
208 sub select_fileno {
209 fileno(shift);
210 }
211
79b1a797 »
2002-05-01 realised the stupid bug causing errors in select
212 sub select_makebits {
213 $select_bits = '';
214 for(2 .. $#handles) {
215 next unless defined $handles[$_] && ref $handles[$_];
216 vec($select_bits, select_fileno($handles[$_]), 1) = 1;
217 }
218 }
219
da0a3a00 »
2002-03-05 Initial revision
220 ## Returns list of handles with input waiting
221 sub select_canread {
222 my($timeout) = @_;
223 my $read = $select_bits;
8c31c1ca »
2002-07-01 Client pingy stuff
224
da0a3a00 »
2002-03-05 Initial revision
225 if(select($read, undef, undef, $timeout) > 0) {
8c31c1ca »
2002-07-01 Client pingy stuff
226 my @out;
227 for(0 .. $#handles) {
228 push(@out, $handles[$_]) if vec($read, $_, 1);
229 }
230 return @out;
da0a3a00 »
2002-03-05 Initial revision
231 }
232 return ();
233 }
234
235 ## Closes and deletes a filehandle
236 sub select_close {
237 my($fh) = @_;
238 return irc_close() if $ircfh == $fh;
239 select_del($fh);
240 close($fh);
241 }
242
243 #### Format Functions
244
245 ## Loads the format given to it, or the default
246 sub load_format {
247 my $formatname = $config->{format};
248 if($cgi->{format} && $cgi->{format} !~ /[^A-Za-z0-9]/) {
8c31c1ca »
2002-07-01 Client pingy stuff
249 $formatname = $cgi->{format};
da0a3a00 »
2002-03-05 Initial revision
250 }
84b81ebc »
2002-03-15 Non-js interface nearly working, tab completion fixed in mozilla and …
251 return parse_config('formats/' . $formatname);
da0a3a00 »
2002-03-05 Initial revision
252 }
253
254 ## Prints a nicely formatted line
255 ## the format is the format name to use, taken from the %format hash
256 ## the params are passed to the format
257 sub format_out {
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
258 my($formatname, $info, $params) = @_;
da0a3a00 »
2002-03-05 Initial revision
259 return unless exists $format->{$formatname};
26a2d223 »
2002-04-27 Fixes for smilies and quits (hopefully).
260 return unless $format->{$formatname};
da0a3a00 »
2002-03-05 Initial revision
261
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
262 my $line = format_parse($format->{$formatname}, $info, $params);
da0a3a00 »
2002-03-05 Initial revision
263 $line = format_colourhtml($line);
264 interface_lineout($info, $line);
265 }
266
267 sub message {
268 my($formatname, @params) = @_;
269 my $info = { target => 'Status', activity => 1 };
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
270 format_out($formatname, $info, \@params);
da0a3a00 »
2002-03-05 Initial revision
271 }
272
273 ## Formats IRC Colours and Styles into HTML and makes URLs clickable
274 sub format_colourhtml {
275 my($line) = @_;
276
4cf672f6 »
2002-10-02 little hack to make smilies work
277 # Used as a token for replaces
278 my $tok = "\004";
279
280 $line =~ s/$tok//g;
281
282 $line =~ s/\&/$tok\&amp;$tok/g;
283 $line =~ s/</$tok\&lt;$tok/g;
284 $line =~ s/>/$tok\&gt;$tok/g;
285 $line =~ s/"/$tok\&quot;$tok/g;
f65718d9 »
2002-04-14 Various fixes
286
dd4f510f »
2003-02-19 updated dates on the main cgi files
287 $line =~ s{((https?|ftp):\/\/[^$ ]+)(?![^<]*>)}{$interface->link(format_remove($1), format_linkshorten($1))}gie;
288 $line =~ s{(?:^|\s)(www\..*?)([\.,]?($|\s)|\)|\002)(?![^<]*>)}{$interface->link(format_remove("http://$1"), $1) . $2}gie;
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
289
84d99eae »
2002-04-24 Options very nearly fully working
290 if(exists $ioptions->{smilies} && $ioptions->{smilies}) {
4cf672f6 »
2002-10-02 little hack to make smilies work
291 $line =~ s{(?<![^\.a-zA-Z_ ])$regexpicon(?![^<]*>)}{
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
292 my($sm, $tmp) = ($1, $1);
293 for(keys %regexpicon) {
294 next unless $sm =~ /^$_$/;
aeac62ef »
2002-10-02 big commit
295 $tmp = $interface->smilie("$config->{image_path}/$regexpicon{$_}.gif", $regexpicon{$_}, $sm);
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
296 last;
297 }
298 $tmp
9be85319 »
2002-08-06 Fixes for keys in mozilla, needs IE testing.
299 }ge;
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
300 }
301
4cf672f6 »
2002-10-02 little hack to make smilies work
302 $line =~ s/$tok//g;
aeac62ef »
2002-10-02 big commit
303 $line =~ s/( {2,})/'&nbsp;' x (length $1)/eg;
304
da0a3a00 »
2002-03-05 Initial revision
305 return format_remove($line) if $config->{removecolour};
306
83f7d953 »
2002-04-25 Made colour parsing marginally faster when there is no colour
307 if($line =~ /[\002\003\017\022\037]/) {
308 $line=~ s/\003(\d{1,2})(\,(\d{1,2})|)([^\003\017]*|.*?$)/
309 my $me = "<font ";
310 my $fg = sprintf("%0.2d",$1);
311 my $bg = length $3 ? sprintf("%0.2d",$3) : '';
312
313 if(length $bg) {
314 $me .= "style=\"background: ".$format->{$bg}."\" "
315 }
8c31c1ca »
2002-07-01 Client pingy stuff
316
317 $me .= "color=\"$format->{$fg}\">$4<\/font>";
318 $me
83f7d953 »
2002-04-25 Made colour parsing marginally faster when there is no colour
319 /eg;
320 $line =~ s/\002(.*?)(\002|\017|$)/<b>$1<\/b>/g;
321 $line =~ s/\022(.*?)(\022|\017|$)/<u>$1<\/u>/g;
322 $line =~ s/\037(.*?)(\037|\017|$)/<u>$1<\/u>/g;
323 }
da0a3a00 »
2002-03-05 Initial revision
324
325 return format_remove($line);
326 }
327
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
328 sub format_init_smilies {
329 %regexpicon = (
aeac62ef »
2002-10-02 big commit
330 '\;-?\)' => 'wink',
331 '\;-?D' => 'grin',
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
332 ':\'\(?' => 'cry',
333 ':-?/(?!\S)' => 'notsure',
334 ':-?[xX]' => 'confused',
335 ':-?\[' => 'embarassed',
336 ':-?\*' => 'love',
af4f64a0 »
2002-11-21 nasty hack to make angry smilie work..
337 "\004\&gt;\004:-?\\(" => 'angry', #XXX
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
338 ':-?[pP]' => 'tongue',
339 ':-?\)' => 'happy',
55f4e238 »
2002-05-05 Output queuing - results in better performance in mozilla (and probab…
340 '\:-?D' => 'cheesy',
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
341 ':-?\(' => 'unhappy',
6b1e41bb »
2002-04-27 :-o needed rather than :o (too hard to stop appearing on ends of word…
342 ':-[oO]' => 'surprised',
26a2d223 »
2002-04-27 Fixes for smilies and quits (hopefully).
343 '8-?\)' => 'cool',
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
344 ':-?\|' => 'flat',
345 );
346 $regexpicon = '(' . join('|', keys %regexpicon) . ')';
347 }
348
68852015 »
2002-04-15 begining of options code
349 sub format_linkshorten {
350 my $link = shift;
351 if(config_set('linkshorten')) {
352 return substr($link, 0, $config->{linkshorten})
353 . (length $link > $config->{linkshorten} ? '...' : '');
354 }else{
355 return substr($link, 0, 120)
356 . (length $link > 120 ? '...' : '');
357 }
358 }
359
da0a3a00 »
2002-03-05 Initial revision
360 ## Removes all IRC formating characters
361 sub format_remove {
362 my($line) = @_;
363 $line =~ s/\003(\d{1,2})(\,(\d{1,2})|)//g;
364 $line =~ s/[\x00-\x1f]//g;
365 return $line;
366 }
367
368 ## Lowlevel code that deals with the format parsing
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
369 ## No longer supports nested
da0a3a00 »
2002-03-05 Initial revision
370 sub format_parse {
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
371 my($line, $info, $params) = @_;
da0a3a00 »
2002-03-05 Initial revision
372 return unless defined $line;
373
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
374 my($match, $name, $param);
375
376 $line =~ s{
377 ( # format
378 \{
379 ([^\}\s]+)
380 \s?([^\}]+)?
381 \}
382 # variables
383 | (\$[A-Za-z0-9-]+)
384 | (\%(?:\d{1,2}|n|_|%))
385 )
386 }{
387 ($match, $name, $param) = ($1, $2, $3);
388 if($match =~ /^[\$%]/) {
389 format_varexpand($match, $info, $params);
390 }elsif(!exists $format->{$name}) {
391 error("Invalid format ($name) called: $line");
392 }else{
393 format_parse($format->{$name}, $info,
394 [map {format_varexpand($_, $info, $params)} split / /,
395 defined $param ? $param : '']);
396 }
397 }egx;
398
399 return $line;
da0a3a00 »
2002-03-05 Initial revision
400 }
401
402 sub format_varexpand {
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
403 $_ = shift;
404 my($info, $params) = @_;
405 return '' unless defined;
406
407 if(s/^\$//) {
408 if(ref $params && /^(\d+)\-$/) {
409 return join(' ', @$params[$1 .. @$params - 1]);
58cab368 »
2002-08-07 pop-out working on mozilla not tested on IE.
410 }elsif(!/\D/) {
411 return $params->[$_] if ref $params && defined $params->[$_];
412 return '';
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
413 }elsif(/^VERSION$/) {
414 return $VERSION;
415 }elsif(/^T$/ && exists $info->{target}) {
416 return $info->{target};
417 }elsif(/^N$/) {
418 return $irc->{nick}
419 }elsif(/^S$/) {
420 return $irc->{server};
421 }
422 }elsif(s/^%//) {
8c31c1ca »
2002-07-01 Client pingy stuff
423 if(/^_$/) {
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
424 return "\002";
8c31c1ca »
2002-07-01 Client pingy stuff
425 }elsif(/^n$/) {
426 return "\003$format->{fg},$format->{bg}";
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
427 }elsif(/^%$/) {
428 return "%";
8c31c1ca »
2002-07-01 Client pingy stuff
429 }elsif(/^\d+$/) {
430 return "\003$_";
431 }
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
432 return "\%$_";
433 }
434 return $_;
da0a3a00 »
2002-03-05 Initial revision
435 }
436
437 #### Interface Functions
438
439 ## Loads the default interface.
440 sub load_interface {
1a96077d »
2002-03-05 Interfaces now working, with detection for IE and mozilla, work still…
441 my $name = defined $cgi->{interface} ? $cgi->{interface} : 'default';
a3ea3074 »
2002-05-01 runs under -T now :)
442 ($name) = $name =~ /([a-z]+)/i;
443 require("./interfaces/$name.pm");
68852015 »
2002-04-15 begining of options code
444
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
445 $ioptions = parse_interface_cookie();
68852015 »
2002-04-15 begining of options code
446 for(keys %$config) {
447 next unless s/^interface //;
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
448 next if exists $ioptions->{$_};
449 $ioptions->{$_} = $config->{"interface $_"};
68852015 »
2002-04-15 begining of options code
450 }
451
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
452 $interface = $name->new($event,$timer, $config, $ioptions);
664e052a »
2002-05-04 untaint vhost
453 my $bg = $format->{$format->{bg}};
454 my $fg = $format->{$format->{fg}};
455 $interface->header($config, $cgi, $bg, $fg);
84b81ebc »
2002-03-15 Non-js interface nearly working, tab completion fixed in mozilla and …
456
457 return $interface;
da0a3a00 »
2002-03-05 Initial revision
458 }
459
460 sub interface_show {
461 my($show, $input) = @_;
19dd46b1 »
2002-03-08 Typical mass-commit :)
462 return '' unless $interface->exists($show);
da0a3a00 »
2002-03-05 Initial revision
463
1a96077d »
2002-03-05 Interfaces now working, with detection for IE and mozilla, work still…
464 return $interface->$show($input, $irc, $config);
da0a3a00 »
2002-03-05 Initial revision
465 }
466
467 sub interface_keepalive {
468 $interface->keepalive($irc, $config);
469 }
470
471 sub interface_lineout {
472 my($type, $target, $html) = @_;
55f4e238 »
2002-05-05 Output queuing - results in better performance in mozilla (and probab…
473 push(@output, $interface->makeline($type, $target, $html));
da0a3a00 »
2002-03-05 Initial revision
474 }
475
476 #### Unix Domain Socket Functions
477
478 ## Opens the listening socket
479 sub load_socket {
480 error('Communication socket name is invalid')
481 if !$cgi->{R} or $cgi->{R} =~ /[^A-Za-z0-9]/;
a3ea3074 »
2002-05-01 runs under -T now :)
482 ($cgi->{R}) = $cgi->{R} =~ /([A-Za-z0-9]+)/;
da0a3a00 »
2002-03-05 Initial revision
483 error('Communication socket already exists')
484 if -e $config->{socket_prefix}.$cgi->{R};
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
485
84b81ebc »
2002-03-15 Non-js interface nearly working, tab completion fixed in mozilla and …
486 mkdir($config->{socket_prefix}.$cgi->{R}, 0700) or error("Mkdir error: $!");
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
487
84b81ebc »
2002-03-15 Non-js interface nearly working, tab completion fixed in mozilla and …
488 open(IP, ">$config->{socket_prefix}$cgi->{R}/ip") or error("Open error: $!");
489 print IP "$ENV{REMOTE_ADDR}\n";
490 print IP "$ENV{HTTP_X_FORWARDED_FOR}\n" if exists $ENV{HTTP_X_FORWARDED_FOR};
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
491 close(IP);
492
493 my($socket,$error) =
8c31c1ca »
2002-07-01 Client pingy stuff
494 net_unixconnect($config->{socket_prefix}.$cgi->{R}.'/sock');
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
495
da0a3a00 »
2002-03-05 Initial revision
496 error("Error opening socket: $error") unless ref $socket;
497
498 select_add($socket);
499
500 return $socket;
501 }
502
503 sub unix_in {
504 my($fh, $line) = @_;
0113ac4a »
2002-04-03 session_timeout
505
da0a3a00 »
2002-03-05 Initial revision
506 my $input = parse_query($line);
507
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
508 if($cookie && (!defined $input->{COOKIE} || $input->{COOKIE} ne $cookie)) {
b5f8ee38 »
2002-04-16 Changes for option code:
509 net_send($fh, "Content-type: text/html\r\n\r\nInvalid cookie\r\n");
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
510 select_close($fh);
511 return;
512 }
513
3e2cf322 »
2002-11-02 ping fix
514 $pingtime = time;
fc92da86 »
2002-11-02 client_hostname fixes
515 $intime = $pingtime if $input->{cmd} eq 'say'
516 && $input->{say} ne '/noop';
3e2cf322 »
2002-11-02 ping fix
517
da0a3a00 »
2002-03-05 Initial revision
518 if($input->{cmd}) {
8c31c1ca »
2002-07-01 Client pingy stuff
519 my $now = time;
520 utime($now, $now, "$config->{socket_prefix}$cgi->{R}/sock");
5c85155b »
2002-11-23 New code to handle pastes much better..
521 input_command($input->{cmd}, $input, $fh, $line);
da0a3a00 »
2002-03-05 Initial revision
522 }
523
b5f8ee38 »
2002-04-16 Changes for option code:
524 net_send($fh, "Content-type: text/html\r\n\r\n");
525
0113ac4a »
2002-04-03 session_timeout
526 if(defined $input->{item} && $input->{item} =~ /^\w+$/) {
8c31c1ca »
2002-07-01 Client pingy stuff
527 net_send($fh, interface_show($input->{item}, $input));
da0a3a00 »
2002-03-05 Initial revision
528 }
529
530 select_close($fh);
531 }
532
533 sub input_command {
5c85155b »
2002-11-23 New code to handle pastes much better..
534 my($command, $params, $fh, $line) = @_;
da0a3a00 »
2002-03-05 Initial revision
535 if($command eq 'say') {
b5f8ee38 »
2002-04-16 Changes for option code:
536 say_command($params->{say}, $params->{target});
5c85155b »
2002-11-23 New code to handle pastes much better..
537 }elsif($command eq 'paste') {
538 $params = parse_query($line, 1);
539 for(split /\n/, $params->{say}) {
540 irc_send_message($params->{target}, $_);
541 }
da0a3a00 »
2002-03-05 Initial revision
542 }elsif($command eq 'quit') {
a4683161 »
2002-05-02 Fixed two long standing bugs (typo in interface and internal server e…
543 net_send($fh, "Content-type: text/html\r\n\r\nquit\r\n"); # avoid errors
9dd72c39 »
2002-05-02 kill formats missed out
544 irc_close("");
b50f332a »
2002-04-24 options making more sense, and lots of other stuff
545 }elsif($command eq 'options' && length $params->{name} && length $params->{value}) {
546 $ioptions->{$params->{name}} = $params->{value};
547 $interface->setoption($params->{name}, $params->{value});
548 # write proper cookie code one day.
84d99eae »
2002-04-24 Options very nearly fully working
549 net_send($fh, "Set-Cookie: cgiirc$params->{name}=$params->{value}; path=/; expires=Sun, 01-Jan-2011 00:00:00 GMT\r\n");
da0a3a00 »
2002-03-05 Initial revision
550 }
551 }
552
553 sub say_command {
554 my($say, $target) = @_;
95581e7d »
2002-03-10 blank lines
555 return unless length $say;
8c31c1ca »
2002-07-01 Client pingy stuff
556 $say =~ s/(\n|\r|\0|\001)//sg;
557 $target =~ s/(\n|\r|\0|\001)//sg;
06775838 »
2002-03-19 Interface stuff working a bit nicer
558 $say =~ s/\%C/\003/g;
559 $say =~ s/\%B/\002/g;
f2bd4bb2 »
2002-03-28 Timestamps
560 $say =~ s/\%U/\037/g;
da0a3a00 »
2002-03-05 Initial revision
561 if($say =~ m!^/!) {
8c31c1ca »
2002-07-01 Client pingy stuff
562 if($say =~ s!^/ /!/!) {
563 irc_send_message($target, $say);
564 }else{
565 (my $command, my $params) = $say =~ m|^/([^ ]+)(?: (.+))?$|;
566 unless(defined $command && length $command) {
567 return;
568 }
569
570 $command = Command->expand($command);
571 unless(access_command($command)) {
572 message('command denied', $command);
573 return;
574 }
575
576 my $error = Command->run($event, $irc, $command, $target, defined $params ? $params : '', $config, $interface);
577 return 1 if $error == 100;
578
579 if($error == 2) {
580 message('command notparams', $error);
581 }else{
582 message('command error', $error);
583 }
584 return 0;
585 }
da0a3a00 »
2002-03-05 Initial revision
586 }else{
8c31c1ca »
2002-07-01 Client pingy stuff
587 irc_send_message($target, $say);
da0a3a00 »
2002-03-05 Initial revision
588 }
589 }
590
591 #### Access Checking Functions
592
cc6d21ff »
2002-03-12 ip access
593 sub config_set {
594 my($option) = @_;
595 return 1 if defined $config->{$option} && $config->{$option};
596 0;
597 }
598
da0a3a00 »
2002-03-05 Initial revision
599 sub access_ipcheck {
cc6d21ff »
2002-03-12 ip access
600 return 1 unless config_set('ip_access_file');
8515c699 »
2002-06-30 CIDR notation patch for ipaccess
601 my($ip) = $ENV{REMOTE_ADDR};
602 my($ipn) = inet_aton($ip);
603 my($ipaccess_match) = 0;
cc6d21ff »
2002-03-12 ip access
604
605 my %ips = list_connected_ips();
ce67c540 »
2003-04-16 add max_users
606 my $total = 0;
607 $total += $ips{$_} for keys %ips;
608 if(config_set("max_users") && $total > $config->{max_users}) {
609 message('access denied', 'Too many connections (global)');
610 }
611
612 open(IP, "<$config->{ip_access_file}") or return 1;
da0a3a00 »
2002-03-05 Initial revision
613 while(<IP>) {
8515c699 »
2002-06-30 CIDR notation patch for ipaccess
614 chomp;
615 next if /^(#|\s*$)/;
616 s/\s+#.*$//g;
617 my($check,$limit) = split(' ', $_, 2);
618 if ($check =~ /\//) {
619 my($addr,$mask) = split('/', $check, 2);
620 $mask = "1" x $mask . "0" x (32-$mask);
621 $mask = pack ("B32", $mask);
622 $mask = inet_ntoa($mask & $ipn);
623 if($addr eq $mask) {
624 $ipaccess_match = 1;
625 }
626 }else{
627 $check =~ s/\./\\./g;
628 $check =~ s/\*/\\d+/g;
629 if($ip =~ /^$check$/) {
630 $ipaccess_match = 1;
631 }
632 }
633 if($ipaccess_match == 1) {
634 return 1 unless defined $limit;
635 if($limit == 0) {
636 message('access denied', 'No connections allowed');
637 irc_close();
638 }elsif($ips{$ip} >= $limit) {
639 message('access denied', 'Too many connections');
640 irc_close();
641 }
642 return 1;
643 }
da0a3a00 »
2002-03-05 Initial revision
644 }
645 close(IP);
411689fd »
2002-03-12 ipaccess
646
647 message('access denied', 'No connections allowed');
e6bc01de »
2002-04-26 # Heavy-handed fix for some weird bug (NS4 only?!)
648 irc_close();
da0a3a00 »
2002-03-05 Initial revision
649 }
650
aeac62ef »
2002-10-02 big commit
651 sub access_dnsbl {
652 return unless config_set('dnsbl');
653 my $arpa = join '.', reverse split /\./, shift;
654
655 for my $zone(split ' ', $config->{dnsbl}) {
656 if(defined net_hostlookup("$arpa.$zone")) {
657 message('access denied', "Found in DNS black list $zone");
658 irc_close();
659 }
660 }
661 }
662
cc6d21ff »
2002-03-12 ip access
663 sub list_connected_ips {
664 my %ips = ();
665 (my $dir, my $prefix) = $config->{socket_prefix} =~ /^(.*\/)([^\/]+)$/;
666 opendir(TMPDIR, "$dir") or return ();
667 for(readdir TMPDIR) {
8c31c1ca »
2002-07-01 Client pingy stuff
668 next unless /^\Q$prefix\E/;
669 next unless -o $dir . $_ && -d $dir . $_;
670 open(TMP, "<$dir$_/ip") or next;
671 chomp(my $tmp = <TMP>);
672 $ips{$tmp}++;
673 close(TMP);
cc6d21ff »
2002-03-12 ip access
674 }
675 closedir(TMPDIR);
676 return %ips;
677 }
678
da0a3a00 »
2002-03-05 Initial revision
679 sub access_configcheck {
680 my($type, $check) = @_;
cc6d21ff »
2002-03-12 ip access
681 if(config_set("default_$type")) {
8c31c1ca »
2002-07-01 Client pingy stuff
682 my %tmp;
683 @tmp{split /,\s*/, lc $config->{"default_$type"}} = 1;
684 return 1 if exists $tmp{lc $check};
da0a3a00 »
2002-03-05 Initial revision
685 }
68852015 »
2002-04-15 begining of options code
686 return 0 unless config_set('allow_non_default') && config_set("access_$type");
da0a3a00 »
2002-03-05 Initial revision
687
688 return 1 if $check =~ /^$config->{"access_$type"}$/i;
689
690 0;
691 }
692
693 sub access_command {
ae1f1ca3 »
2002-03-10 working ctcp supprt
694 my($command) = @_;
cc6d21ff »
2002-03-12 ip access
695 return 1 unless config_set('access_command');
ae1f1ca3 »
2002-03-10 working ctcp supprt
696 for(split / /, $config->{access_command}) {
8c31c1ca »
2002-07-01 Client pingy stuff
697 if(/^!(.*)/) {
698 return 0 if $command =~ /^$1/i;
699 }else{
700 return 1 if $command =~ /^$_/i;
701 }
ae1f1ca3 »
2002-03-10 working ctcp supprt
702 }
633d2064 »
2002-03-06 Commands, interfaces, lots of other stuff :)
703 return 1;
da0a3a00 »
2002-03-05 Initial revision
704 }
705
706 sub encode_ip {
707 return join('',map(sprintf("%0.2x", $_), split(/\./,shift)));
708 }
709
501cfd7c »
2002-05-22 format selection
710 sub client_hostname {
c332be9f »
2002-10-17 form_redirect works..
711 my $ip = defined $_[0] ? $_[0] : $ENV{REMOTE_ADDR};
501cfd7c »
2002-05-22 format selection
712
713 my($hostname) = gethostbyaddr(inet_aton($ip), AF_INET);
714 unless(defined $hostname && $hostname) {
dee94dae »
2002-11-03 oops.
715 return($ip, $ip);
501cfd7c »
2002-05-22 format selection
716 }
717
718 my $ip_check = scalar gethostbyname($hostname);
719
720 if(inet_aton($ip) ne $ip_check) {
dee94dae »
2002-11-03 oops.
721 return($ip, $ip);
501cfd7c »
2002-05-22 format selection
722 }
723
aeac62ef »
2002-10-02 big commit
724 if(exists $ENV{HTTP_X_FORWARDED_FOR}
c332be9f »
2002-10-17 form_redirect works..
725 && $ENV{HTTP_X_FORWARDED_FOR} =~ /((\d{1,3}\.){3}\d{1,3})$/
726 && !defined $_[1]) { # check proxy but only once
aeac62ef »
2002-10-02 big commit
727 my $proxyip = $1;
fc92da86 »
2002-11-02 client_hostname fixes
728 return($hostname, $ip) if $proxyip =~ /^(192\.168|127|10|172\.(1[6789]|2\d|3[01]))\./;
c332be9f »
2002-10-17 form_redirect works..
729
aeac62ef »
2002-10-02 big commit
730 access_dnsbl($proxyip);
dee94dae »
2002-11-03 oops.
731 open(TRUST, "<trusted-proxy") or return($hostname, $ip);
aeac62ef »
2002-10-02 big commit
732 while(<TRUST>) {
733 chomp;
734 s/\*/.*/g;
735 s/\?/./g;
736 return client_hostname($proxyip, 1) if $hostname =~ /^$_$/i;
737 }
738 close TRUST;
739 }
740
fc92da86 »
2002-11-02 client_hostname fixes
741 return($hostname, $ip);
501cfd7c »
2002-05-22 format selection
742 }
743
0113ac4a »
2002-04-03 session_timeout
744 sub session_timeout {
745 return unless defined $intime;
8c31c1ca »
2002-07-01 Client pingy stuff
746 if(config_set('session_timeout') &&
747 (time - $config->{session_timeout}) > $intime) {
68852015 »
2002-04-15 begining of options code
748 message('session timeout');
9dd72c39 »
2002-05-02 kill formats missed out
749 irc_close('Session timeout');
3e2cf322 »
2002-11-02 ping fix
750 }elsif($interface->ping && $pingtime < time - 900) {
8c31c1ca »
2002-07-01 Client pingy stuff
751 irc_close('Ping timeout');
3e2cf322 »
2002-11-02 ping fix
752 }elsif($interface->ping && $pingtime < time - 600) {
8c31c1ca »
2002-07-01 Client pingy stuff
753 $interface->sendping;
0113ac4a »
2002-04-03 session_timeout
754 }
755 }
756
da0a3a00 »
2002-03-05 Initial revision
757 #### IRC Functions
758
759 ## Opens the connection to IRC
760 sub irc_connect {
761 my($server, $port) = @_;
afd388c8 »
2002-07-03 empty server..
762 error("No server specified") unless $server;
763
633d2064 »
2002-03-06 Commands, interfaces, lots of other stuff :)
764 message('looking up', $server);
c0798157 »
2002-08-07 flushoutput
765 flushoutput(); # this stuff can block - keep the user informed
da0a3a00 »
2002-03-05 Initial revision
766
aeac62ef »
2002-10-02 big commit
767 my $ip = net_hostlookup($server);
768 unless(defined $ip) {
8c31c1ca »
2002-07-01 Client pingy stuff
769 error("Looking up address: $!");
da0a3a00 »
2002-03-05 Initial revision
770 }
771
2f32521a »
2002-05-06 ipv6 stuff
772 message('connecting', $server, $ip, $port);
c0798157 »
2002-08-07 flushoutput
773 flushoutput();
774
2f32521a »
2002-05-06 ipv6 stuff
775 my($fh,$error) = net_tcpconnect($ip, $port);
da0a3a00 »
2002-03-05 Initial revision
776
777 error("Connecting to IRC: $error") unless ref $fh;
1824c08d »
2002-04-14 New User list, *lots* of other stuff, cleanups and so on..
778
57feb2b8 »
2002-04-24 removed race condition on writing server file - identd should *always…
779 select_add($fh);
780 return $fh;
781 }
782
783 sub irc_write_server {
784 my($lip, $lport, $rip, $rport) = @_;
1824c08d »
2002-04-14 New User list, *lots* of other stuff, cleanups and so on..
785 open(S, ">$config->{socket_prefix}$cgi->{R}/server")
786 or error("Opening server file: $!");
57feb2b8 »
2002-04-24 removed race condition on writing server file - identd should *always…
787 print S "$rip:$rport\n$lip:$lport\n";
1824c08d »
2002-04-14 New User list, *lots* of other stuff, cleanups and so on..
788 close(S);
da0a3a00 »
2002-03-05 Initial revision
789 }
790
791 ## Sends data to the irc connection
792 sub irc_out {
793 my($event,$fh,$data) = @_;
794 $data = $fh, $fh = $event if !$data;
ae1f1ca3 »
2002-03-10 working ctcp supprt
795 #message('default', "-> Server: $data");
da0a3a00 »
2002-03-05 Initial revision
796 net_send($fh, $data . "\r\n");
797 }
798
cc6d21ff »
2002-03-12 ip access
799 sub irc_close {
9dd72c39 »
2002-05-02 kill formats missed out
800 my $message = shift;
801 $message = 'EOF' unless defined $message;
75181b5d »
2002-11-24 New version code to show date of cvs versions
802 $message = (config_set('quit_prefix') ? $config->{quit_prefix} : "CGI:IRC") .
9dd72c39 »
2002-05-02 kill formats missed out
803 ($message ? " ($message)" : '');
804
c0798157 »
2002-08-07 flushoutput
805 flushoutput();
e372e676 »
2002-05-27 /op type mode command fixes
806
cc6d21ff »
2002-03-12 ip access
807 exit unless ref $unixfh;
808 close($unixfh);
9dd72c39 »
2002-05-02 kill formats missed out
809
cc6d21ff »
2002-03-12 ip access
810 my $t = $config->{socket_prefix} . $cgi->{R};
50051655 »
2002-08-07 oops, left some debugging code
811 unlink("$t/sock", "$t/ip", "$t/server", "$t/ident");
cc6d21ff »
2002-03-12 ip access
812 exit unless rmdir($t);
9dd72c39 »
2002-05-02 kill formats missed out
813
cc6d21ff »
2002-03-12 ip access
814 exit unless ref $ircfh;
9dd72c39 »
2002-05-02 kill formats missed out
815 net_send($ircfh, "QUIT :$message\r\n");
cc6d21ff »
2002-03-12 ip access
816 format_out('irc close', { target => '-all', activity => 1 });
e372e676 »
2002-05-27 /op type mode command fixes
817
c0798157 »
2002-08-07 flushoutput
818 flushoutput();
e372e676 »
2002-05-27 /op type mode command fixes
819
06775838 »
2002-03-19 Interface stuff working a bit nicer
820 $interface->end if ref $interface;
9dd72c39 »
2002-05-02 kill formats missed out
821
cc6d21ff »
2002-03-12 ip access
822 sleep 1;
823 close($ircfh);
824 exit;
825 }
826
827 sub irc_connected {
828 my($event, $self, $server, $nick) = @_;
9dd72c39 »
2002-05-02 kill formats missed out
829 open(SERVER, ">>$config->{socket_prefix}$cgi->{R}/server")
830 or error("Writing to server file; $!");
b1bd2229 »
2002-05-03 Add the initial nickname to the server file
831 print SERVER "$server\n$nick\n";
e180e5e9 »
2002-04-14 fixed identd, and various things
832 close(SERVER);
833
cc6d21ff »
2002-03-12 ip access
834 my $key;
835 $key = $1 if $cgi->{chan} =~ s/ (.+)$//;
836 unless(access_configcheck('channel', $cgi->{chan})) {
8c31c1ca »
2002-07-01 Client pingy stuff
837 message('access channel denied', $cgi->{chan});
838 $cgi->{chan} = (split /,/, $config->{default_channel})[0];
cc6d21ff »
2002-03-12 ip access
839 }
840 $irc->join($cgi->{chan} . (defined $key ? ' ' . $key : ''));
841 }
842
da0a3a00 »
2002-03-05 Initial revision
843 sub irc_send_message {
844 my($target, $text) = @_;
845 $event->handle('message ' .
8c31c1ca »
2002-07-01 Client pingy stuff
846 (
33862339 »
2002-07-02 oops (and thanks darix)
847 $irc->is_channel($target) ? 'public'
848 : 'private' .
849 ($interface->query ? ' window' : '')
8c31c1ca »
2002-07-01 Client pingy stuff
850 ) . ' own',
851 { target => $target, create => 1 },
852 $irc->{nick}, $irc->{myhost}, $text);
da0a3a00 »
2002-03-05 Initial revision
853 $irc->msg($target,$text);
854 }
855
856 sub irc_event {
857 my($event, $name, $info, @params) = @_;
84b81ebc »
2002-03-15 Non-js interface nearly working, tab completion fixed in mozilla and …
858 return if $name =~ /^user /;
da0a3a00 »
2002-03-05 Initial revision
859 $info->{type} = $name;
860
861 if($name =~ /^raw/) {
ae1f1ca3 »
2002-03-10 working ctcp supprt
862 #message('default', "Unhandled numeric: $name");
8c31c1ca »
2002-07-01 Client pingy stuff
863 my $params = $params[0];
864 $info->{activity} = 1;
865 $info->{target} = defined $params->{params}->[2] ? $params->{params}->[2] : 'Status';
866
867 @params = (join(' ', defined $params->{params}->[2]
868 ? @{$params->{params}}[2 .. @{$params->{params}} - 1]
869 : ''),
870 defined $params->{text}
871 ? $params->{text}
872 : '');
873
ae1f1ca3 »
2002-03-10 working ctcp supprt
874 }elsif($name =~ /^ctcp/) {
8c31c1ca »
2002-07-01 Client pingy stuff
875 return irc_ctcp($name, $info, @params);
1966ae31 »
2002-03-16 more interface stuff
876 }elsif($name eq 'message public' && $params[2] =~ /^\Q$irc->{nick}\E\W/i) {
8c31c1ca »
2002-07-01 Client pingy stuff
877 $info->{activity} = 3;
878 $name = 'message public hilight';
1966ae31 »
2002-03-16 more interface stuff
879 }elsif($name eq 'message private' && $interface->query) {
8c31c1ca »
2002-07-01 Client pingy stuff
880 $name = 'message private window';
da0a3a00 »
2002-03-05 Initial revision
881 }
8c31c1ca »
2002-07-01 Client pingy stuff
882
da0a3a00 »
2002-03-05 Initial revision
883 if(exists $format->{$name}) {
8c31c1ca »
2002-07-01 Client pingy stuff
884 format_out($name, $info, \@params);
da0a3a00 »
2002-03-05 Initial revision
885 }else{
51cef102 »
2002-06-15 New format code (regexp not silly C like parsing)
886 format_out('default', $info, \@params);
da0a3a00 »
2002-03-05 Initial revision
887 }
888 }
889
ae1f1ca3 »
2002-03-10 working ctcp supprt
890 sub irc_ctcp {
9a9197f9 »
2002-05-05 ctcp fixes
891 my($name, $info, $to, $nick, $host, $command, $params) = @_;
ae1f1ca3 »
2002-03-10 working ctcp supprt
892 if($name eq 'ctcp own msg') {
8c31c1ca »
2002-07-01 Client pingy stuff
893 format_out('ctcp own msg', $info, [$nick, $host, $command, $params]);
ae1f1ca3 »
2002-03-10 working ctcp supprt
894 }elsif($name =~ /^ctcp msg /) {
1824c08d »
2002-04-14 New User list, *lots* of other stuff, cleanups and so on..
895 if(uc($command) eq 'KILL') {
8c31c1ca »
2002-07-01 Client pingy stuff
896 return unless config_set('admin password');
897 my $crypt = $config->{'admin password'};
898 my($password, $reason) = split ' ', $params, 2;
899 return unless length $password and length $crypt;
900
901 if(crypt($password, substr($crypt, 0, 2)) eq $crypt) {
902 message('kill ok', $nick, $reason);
903 net_send($ircfh, "QUIT :Killed ($nick ($reason))\r\n");
904 irc_close();
905 }else{
906 message('kill wrong', $nick, $reason);
907 }
908 }elsif(uc($command) eq 'ACTION' && $irc->is_channel($info->{target})) {
909 format_out('action public', $info, [$nick, $host, $params]);
910 return;
911 }elsif(uc($command) eq 'ACTION') {
912 format_out('action private', $info, [$nick, $host, $params]);
913 return;
914 }elsif(uc($command) eq 'DCC' && lc $to eq lc $irc->{nick}) {
915 format_out('not supported', $info, [$nick, $host, $params, "DCC"]);
916 }else{
917 format_out('ctcp msg', $info, [$to, $nick, $host, $command, $params]);
918 }
919
920 if($ctcptime > time-4) {
921 $ctcptime = time;
922 return;
923 }
924 $ctcptime = time;
925
926 if(uc($command) eq 'VERSION') {
75181b5d »
2002-11-24 New version code to show date of cvs versions
927 $irc->ctcpreply($nick, $command,
8c31c1ca »
2002-07-01 Client pingy stuff
928 "CGI:IRC $VERSION - http://cgiirc.sf.net/");
929 }elsif(uc($command) eq 'PING') {
930 return if $params =~ /[^0-9 ]/ || length $params > 50;
931 unless($interface->ctcpping($nick, $params)) {
932 $irc->ctcpreply($nick, $command, $params);
933 }
934 }elsif(uc($command) eq 'USERINFO') {
935 $irc->ctcpreply($nick, $command,
936 config_set('extra_userinfo') ?
937 "IP: $ENV{REMOTE_ADDR} - Proxy: $ENV{HTTP_VIA} - " .
938 "Forward IP: $ENV{HTTP_X_FORWARDED_FOR} - User Agent: " .
939 "$ENV{HTTP_USER_AGENT} - Host: $ENV{SERVER_NAME}"
c332be9f »
2002-10-17 form_redirect works..
940 : "$ENV{REMOTE_ADDR} - $ENV{HTTP_USER_AGENT}"
8c31c1ca »
2002-07-01 Client pingy stuff
941 );
942 }elsif(uc($command) eq 'TIME') {
943 $irc->ctcpreply($nick, $command,
944 scalar localtime());
945 }elsif(uc($command) eq 'DCC' && lc $to eq lc $irc->{nick}) {
946 my($type, $subtype) = split ' ', $params;
947 $type .= " $subtype";
948 $type = substr($type, 0, 20);
949 $irc->ctcpreply($nick, $command, "REJECT $type Not Supported");
950 }
ae1f1ca3 »
2002-03-10 working ctcp supprt
951 }else{
8c31c1ca »
2002-07-01 Client pingy stuff
952 if(uc($command) eq 'PING') {
953 $params = time - $params . " seconds";
954 }
955 format_out('ctcp reply', $info, [$nick, $host, $command, $params]);
ae1f1ca3 »
2002-03-10 working ctcp supprt
956 }
957 }
958
da0a3a00 »
2002-03-05 Initial revision
959
960 #### prints a very simple header
961 sub header {
b51de2c1 »
2002-11-03 Added charset and first user of it, russian format file from 'iluXa'
962 my $charset = shift;
c2c10549 »
2002-07-01 non-nph fix
963 print "HTTP/1.0 200 OK\r\n" if $0 =~ /nph-/;
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
964 print join("\r\n",
b51de2c1 »
2002-11-03 Added charset and first user of it, russian format file from 'iluXa'
965 'Content-type: text/html' . (defined $charset ? "; charset=$charset" :
966 ''),
8c31c1ca »
2002-07-01 Client pingy stuff
967 'Pragma: no-cache',
968 'Cache-control: must-revalidate, no-cache, no-store',
969 'Expires: -1',
970 "\r\n");
da0a3a00 »
2002-03-05 Initial revision
971 }
972
c0798157 »
2002-08-07 flushoutput
973 sub flushoutput {
974 if(@output) {
975 $interface->lines(@output);
976 @output = ( );
977 }
978 }
979
da0a3a00 »
2002-03-05 Initial revision
980
981 #### Error Reporting
982 sub error {
c0798157 »
2002-08-07 flushoutput
983 my $message = "@_";
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
984 header() unless $config;
1a96077d »
2002-03-05 Interfaces now working, with detection for IE and mozilla, work still…
985 if(defined $interface && ref $interface) {
aeac62ef »
2002-10-02 big commit
986 flushoutput();
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
987 if(ref $format) {
8c31c1ca »
2002-07-01 Client pingy stuff
988 my $format = format_parse($format->{error}, {}, [$message]);
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
989 $format = format_colourhtml($format);
990 $interface->error($format);
991 }else{
8c31c1ca »
2002-07-01 Client pingy stuff
992 $interface->error("Error: $message");
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
993 }
1a96077d »
2002-03-05 Interfaces now working, with detection for IE and mozilla, work still…
994 }else{
995 print "An error occured: $message\n";
996 }
aeac62ef »
2002-10-02 big commit
997 print STDERR "[" . scalar localtime() . "] CGI:IRC Error: $message (" . join(' ',(caller(1))[3,2]) . ")";
9dd72c39 »
2002-05-02 kill formats missed out
998 irc_close("Error");
da0a3a00 »
2002-03-05 Initial revision
999 }
1000
1001 #### Init
1002
1003 sub init {
1004 $timer = new Timer;
1005 $event = new Event;
1006 $timer->addforever(interval => 15, code => \&interface_keepalive);
1007 $event->add('irc out', code => \&irc_out);
1008 $event->add('unhandled', code => \&irc_event);
1009 $event->add('server connected', code => \&irc_connected);
1010
1011 $config = parse_config('cgiirc.config');
15844e9b »
2002-03-14 Made configuration file set-up nicer
1012 $config->{socket_prefix} ||= '/tmp/cgiirc-';
f0dc2e80 »
2002-05-02 fixed taint error
1013 ($config->{socket_prefix}) = $config->{socket_prefix} =~ /(.*)/;
15844e9b »
2002-03-14 Made configuration file set-up nicer
1014 $config->{encoded_ip} = 2 unless exists $config->{encoded_ip};
1015 $config->{access_command} = '!quote' unless exists $config->{access_command};
1016 $config->{format} ||= 'default';
da0a3a00 »
2002-03-05 Initial revision
1017
8c31c1ca »
2002-07-01 Client pingy stuff
1018 $timer->addforever(interval => 30, code => \&session_timeout);
0113ac4a »
2002-04-03 session_timeout
1019
da0a3a00 »
2002-03-05 Initial revision
1020
1021 $cgi = parse_query($ENV{QUERY_STRING});
84d99eae »
2002-04-24 Options very nearly fully working
1022 format_init_smilies();
b51de2c1 »
2002-11-03 Added charset and first user of it, russian format file from 'iluXa'
1023 $format = load_format($cgi->{format});
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
1024 $cookie = parse_cookie();
da0a3a00 »
2002-03-05 Initial revision
1025
b51de2c1 »
2002-11-03 Added charset and first user of it, russian format file from 'iluXa'
1026 header($format->{charset} ? $format->{charset} : undef);
1027
da0a3a00 »
2002-03-05 Initial revision
1028 error('No CGI Input') unless keys %$cgi;
1029 $cgi->{serv} ||= (split /,/, $config->{default_server})[0];
1030 $cgi->{chan} ||= (split /,/, $config->{default_channel})[0];
1031 $cgi->{port} ||= $config->{default_port};
1032 $cgi->{nick} ||= $config->{default_nick};
1033 $cgi->{name} ||= $config->{default_name};
1034
a3ea3074 »
2002-05-01 runs under -T now :)
1035 ($cgi->{port}) = $cgi->{port} =~ /(\d+)/;
1036
aeac62ef »
2002-10-02 big commit
1037 if($cgi->{serv} =~ s/:(\d+)$//) {
1038 $cgi->{port} = $1;
1039 }
1040
da0a3a00 »
2002-03-05 Initial revision
1041 $cgi->{nick} =~ s/\?/int rand 10/eg;
0113ac4a »
2002-04-03 session_timeout
1042 # Only valid nickname characters
1043 $cgi->{nick} =~ s/[^A-Za-z0-9\[\]\{\}^\\\|\_\-\`]//g;
da0a3a00 »
2002-03-05 Initial revision
1044
664e052a »
2002-05-04 untaint vhost
1045 $interface = load_interface();
cc6d21ff »
2002-03-12 ip access
1046
1047 access_ipcheck();
aeac62ef »
2002-10-02 big commit
1048 access_dnsbl($ENV{REMOTE_ADDR});
da0a3a00 »
2002-03-05 Initial revision
1049
1050 unless(access_configcheck('server', $cgi->{serv})) {
8c31c1ca »
2002-07-01 Client pingy stuff
1051 message('access server denied', $cgi->{serv});
1052 $cgi->{serv} = (split /,/, $config->{default_server})[0];
da0a3a00 »
2002-03-05 Initial revision
1053 }
aeac62ef »
2002-10-02 big commit
1054 ($cgi->{serv}) = $cgi->{serv} =~ /([^ ]+)/; # untaint hack.
8c31c1ca »
2002-07-01 Client pingy stuff
1055
501cfd7c »
2002-05-22 format selection
1056 my $resolved = '';
fc92da86 »
2002-11-02 client_hostname fixes
1057 my $resolvedip = '';
92a51fb3 »
2002-11-23 Bug which means encoded ip isn't sent (oops!)
1058 ($resolved, $resolvedip) = client_hostname();
501cfd7c »
2002-05-22 format selection
1059
cc6d21ff »
2002-03-12 ip access
1060 if(config_set('encoded_ip')) {
8c31c1ca »
2002-07-01 Client pingy stuff
1061 $cgi->{name} = '[' .
1062 ($config->{encoded_ip} <= 2
fc92da86 »
2002-11-02 client_hostname fixes
1063 ? encode_ip($resolvedip)
8c31c1ca »
2002-07-01 Client pingy stuff
1064 # The resolved hostname in realname if set to 3.
1065 : $resolved
1066 )
cba97bde »
2002-03-27 Cookie checking working, commands added to userlist, various other fixes
1067 . '] ' . $cgi->{name};
da0a3a00 »
2002-03-05 Initial revision
1068 }
0d5173ed »
2002-03-10 New socket code, (dir/sock, dir/ip).
1069
501cfd7c »
2002-05-22 format selection
1070 if(config_set('realhost_as_password')) {
fc92da86 »
2002-11-02 client_hostname fixes
1071 $cgi->{pass} = "CGIIRC_${resolvedip}_${resolved}";
501cfd7c »
2002-05-22 format selection
1072 }
1073
da0a3a00 »
2002-03-05 Initial revision
1074 $unixfh = load_socket();
1075
e372e676 »
2002-05-27 /op type mode command fixes
1076 if(exists $ENV{REMOTE_USER}) {
1077 open(IDENT, ">$config->{socket_prefix}$cgi->{R}/ident")
1078 or error("Ident file: $!");
1079 print IDENT "$ENV{REMOTE_USER}\n";
1080 close(IDENT);
1081 }
1082
75181b5d »
2002-11-24 New version code to show date of cvs versions
1083 message('cgiirc welcome') if exists $format->{'cgiirc welcome'};
da0a3a00 »
2002-03-05 Initial revision
1084 $ircfh = irc_connect($cgi->{serv}, $cgi->{port});
1085 $irc = IRC->new(
8c31c1ca »
2002-07-01 Client pingy stuff
1086 event => $event,
1087 timer => $timer,
1088 fh => $ircfh,
1089 nick => $cgi->{nick},
1090 server => $cgi->{serv},
1091 password => defined $cgi->{pass}
1092 ? $cgi->{pass}
1093 : (config_set('server_password')
1094 ? $config->{server_password}
1095 : ''
1096 ),
1097 realname => $cgi->{name},
1098 user => config_set('encoded_ip') && $config->{encoded_ip} > 1
1099 ? encode_ip($ENV{REMOTE_ADDR})
1100 : (config_set('default_user')
1101 ? $config->{default_user}
f3261aa7 »
2002-11-24 Now send the user's nickname as ident rather than cgiirc if none is
1102 : $cgi->{nick}
8c31c1ca »
2002-07-01 Client pingy stuff
1103 ),
1104 );
5c85155b »
2002-11-23 New code to handle pastes much better..
1105
1106 # Generally use server connected.
1107 $event->handle("user connected", $irc);
1108
1109 $interface->sendping if $interface->ping;
1110 $intime = $pingtime = time;
da0a3a00 »
2002-03-05 Initial revision
1111 }
1112
1113
1114 #### Main loop
1115
1116 sub main_loop {
1117 error("Required objects not loaded")
8c31c1ca »
2002-07-01 Client pingy stuff
1118 unless ref $timer
1119 and ref $event
1120 and ref $config;
da0a3a00 »
2002-03-05 Initial revision
1121
1122 while(1) {
8c31c1ca »
2002-07-01 Client pingy stuff
1123 my @ready = select_canread(2);
1124 for my $fh(@ready) {
1125 if($fh == $unixfh) {
1126 my $newfh = Symbol::gensym;
1127 if(accept($newfh, $fh)) {
1128 net_autoflush($newfh);
1129 select_add($newfh);
1130 }
1131 }else{
1132 my($tmp,$char);
1133 $tmp = sysread( $fh, $char, 4096 );
1134
1135 select_close($fh) unless defined $tmp && length $char;
1136
1137 $inbuffer{$fh} .= $char;
1138
1139 while (my($theline,$therest)=$inbuffer{$fh} =~ /([^\n]*)\n(.*)/s ) {
1140 $inbuffer{$fh} = $therest;
1141 $theline =~ s/\r$//;
1142
1143 if($fh == $ircfh) {
1144 $irc->in($theline);
1145 }else{
1146 unix_in($fh,$theline);
1147 }
1148 }
c0798157 »
2002-08-07 flushoutput
1149 flushoutput();
55f4e238 »
2002-05-05 Output queuing - results in better performance in mozilla (and probab…
1150 }
8c31c1ca »
2002-07-01 Client pingy stuff
1151 }
1152 irc_close() if $needtodie;
1153 $timer->run;
da0a3a00 »
2002-03-05 Initial revision
1154 }
1155 }
1156
1157 init();
1158 main_loop();
1159
Something went wrong with that request. Please try again.