line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Author Chris "BinGOs" Williams |
2
|
|
|
|
|
|
|
# Cribbed the regexps from Net::Ident by Jan-Pieter Cornet |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# This module may be used, modified, and distributed under the same |
5
|
|
|
|
|
|
|
# terms as Perl itself. Please see the license that came with your Perl |
6
|
|
|
|
|
|
|
# distribution for details. |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
package POE::Filter::Ident; |
10
|
|
|
|
|
|
|
|
11
|
2
|
|
|
2
|
|
26363
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
55
|
|
12
|
2
|
|
|
2
|
|
9
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
49
|
|
13
|
2
|
|
|
2
|
|
9
|
use Carp; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
164
|
|
14
|
2
|
|
|
2
|
|
10
|
use vars qw($VERSION); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
1351
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
$VERSION = '1.16'; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub new { |
19
|
1
|
|
|
1
|
1
|
2
|
my $class = shift; |
20
|
1
|
|
|
|
|
3
|
my %args = @_; |
21
|
1
|
|
|
|
|
4
|
$args{lc $_} = delete $args{$_} for keys %args; |
22
|
1
|
|
|
|
|
6
|
bless \%args, $class; |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# Set/clear the 'debug' flag. |
27
|
|
|
|
|
|
|
sub debug { |
28
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
29
|
0
|
0
|
|
|
|
0
|
$self->{'debug'} = $_[0] if @_; |
30
|
0
|
|
|
|
|
0
|
return $self->{'debug'}; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub get { |
35
|
1
|
|
|
1
|
1
|
9
|
my ($self, $raw) = @_; |
36
|
1
|
|
|
|
|
2
|
my $events = []; |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
|
|
|
4
|
foreach my $line (@$raw) { |
39
|
1
|
50
|
|
|
|
12
|
warn "<<< $line\n" if $self->{'debug'}; |
40
|
1
|
50
|
|
|
|
8
|
next unless $line =~ /\S/; |
41
|
|
|
|
|
|
|
|
42
|
1
|
|
|
|
|
10
|
my ($port1, $port2, $replytype, $reply) = |
43
|
|
|
|
|
|
|
$line =~ |
44
|
|
|
|
|
|
|
/^\s*(\d+)\s*,\s*(\d+)\s*:\s*(ERROR|USERID)\s*:\s*(.*)$/; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
SWITCH: { |
47
|
1
|
50
|
|
|
|
3
|
unless ( defined $reply ) { |
|
1
|
|
|
|
|
3
|
|
48
|
0
|
|
|
|
|
0
|
push @$events, { name => 'barf', args => [ 'UKNOWN-ERROR' ] }; |
49
|
0
|
|
|
|
|
0
|
last SWITCH; |
50
|
|
|
|
|
|
|
} |
51
|
1
|
50
|
|
|
|
5
|
if ( $replytype eq 'ERROR' ) { |
52
|
0
|
|
|
|
|
0
|
my ($error); |
53
|
0
|
|
|
|
|
0
|
( $error = $reply ) =~ s/\s+$//; |
54
|
0
|
|
|
|
|
0
|
push @$events, { name => 'error', args => [ $port1, $port2, $error ] }; |
55
|
0
|
|
|
|
|
0
|
last SWITCH; |
56
|
|
|
|
|
|
|
} |
57
|
1
|
50
|
|
|
|
5
|
if ( $replytype eq 'USERID' ) { |
58
|
1
|
|
|
|
|
2
|
my ($opsys, $userid); |
59
|
1
|
50
|
|
|
|
10
|
unless ( ($opsys, $userid) = |
60
|
|
|
|
|
|
|
($reply =~ /\s*((?:[^\\:]+|\\.)*):(.*)$/) ) { |
61
|
|
|
|
|
|
|
# didn't parse properly, abort. |
62
|
0
|
|
|
|
|
0
|
push @$events, { name => 'barf', args => [ 'UKNOWN-ERROR' ] }; |
63
|
0
|
|
|
|
|
0
|
last SWITCH; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
# remove trailing whitespace, except backwhacked whitespaces from opsys |
66
|
1
|
|
|
|
|
8
|
$opsys =~ s/([^\\])\s+$/$1/; |
67
|
|
|
|
|
|
|
# un-backwhack opsys. |
68
|
1
|
|
|
|
|
3
|
$opsys =~ s/\\(.)/$1/g; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# in all cases is leading whitespace removed from the username, even |
71
|
|
|
|
|
|
|
# though rfc1413 mentions that it shouldn't be done, current |
72
|
|
|
|
|
|
|
# implementation practice dictates otherwise. What insane OS would |
73
|
|
|
|
|
|
|
# use leading whitespace in usernames anyway... |
74
|
1
|
|
|
|
|
5
|
$userid =~ s/^\s+//; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# Test if opsys is "special": if it contains a charset definition, |
77
|
|
|
|
|
|
|
# or if it is "OTHER". This means that it is rfc1413-like, instead |
78
|
|
|
|
|
|
|
# of rfc931-like. (Why can't they make these RFCs non-conflicting??? ;) |
79
|
|
|
|
|
|
|
# Note that while rfc1413 (the one that superseded rfc931) indicates |
80
|
|
|
|
|
|
|
# that _any_ characters following the final colon are part of the |
81
|
|
|
|
|
|
|
# username, current implementation practice inserts a space there, |
82
|
|
|
|
|
|
|
# even "modern" identd daemons. |
83
|
|
|
|
|
|
|
# Also, rfc931 specifically mentions escaping characters, while |
84
|
|
|
|
|
|
|
# rfc1413 does not mention it (it isn't really necessary). Anyway, |
85
|
|
|
|
|
|
|
# I'm going to remove trailing whitespace from userids, and I'm |
86
|
|
|
|
|
|
|
# going to un-backwhack them, unless the opsys is "special". |
87
|
1
|
50
|
33
|
|
|
12
|
unless ( $opsys =~ /,/ || $opsys eq 'OTHER' ) { |
88
|
|
|
|
|
|
|
# remove trailing whitespace, except backwhacked whitespaces. |
89
|
1
|
|
|
|
|
4
|
$userid =~ s/([^\\])\s+$/$1/; |
90
|
|
|
|
|
|
|
# un-backwhack |
91
|
1
|
|
|
|
|
3
|
$userid =~ s/\\(.)/$1/g; |
92
|
|
|
|
|
|
|
} |
93
|
1
|
|
|
|
|
6
|
push @$events, { name => 'reply', args => [ $port1, $port2, $opsys, $userid ] }; |
94
|
1
|
|
|
|
|
5
|
last SWITCH; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
# If we fell out here then it is probably an error |
97
|
0
|
|
|
|
|
0
|
push @$events, { name => 'barf', args => [ 'UKNOWN-ERROR' ] }; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
1
|
|
|
|
|
5
|
return $events; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
# This sub is so useless to implement that I won't even bother. |
106
|
|
|
|
|
|
|
sub put { |
107
|
0
|
|
|
0
|
1
|
|
croak "Call to unimplemented subroutine POE::Filter::Ident->put()"; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
1; |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
__END__ |