File Coverage

blib/lib/IRC/Toolkit/CTCP.pm
Criterion Covered Total %
statement 51 59 86.4
branch 20 38 52.6
condition 3 6 50.0
subroutine 8 8 100.0
pod 3 3 100.0
total 85 114 74.5


line stmt bran cond sub pod time code
1             package IRC::Toolkit::CTCP;
2             $IRC::Toolkit::CTCP::VERSION = '0.091001';
3 2     2   993 use strictures 2;
  2         1146  
  2         66  
4 2     2   312 use Carp 'confess';
  2         2  
  2         129  
5              
6 2     2   773 use parent 'Exporter::Tiny';
  2         215  
  2         7  
7             our @EXPORT = qw/
8             ctcp_quote
9             ctcp_unquote
10             ctcp_extract
11             /;
12              
13 2     2   3453 use IRC::Message::Object 'ircmsg';
  2         7  
  2         23  
14              
15 2     2   536 use Scalar::Util 'blessed';
  2         4  
  2         2131  
16              
17             my %quote = (
18             "\012" => 'n',
19             "\015" => 'r',
20             "\0" => '0',
21             "\cP" => "\cP",
22             );
23             my %dequote = reverse %quote;
24              
25             ## CTCP handling logic borrowed from POE::Filter::IRC::Compat / Net::IRC
26             ## (by BinGOs, fimm, Abigail et al)
27              
28             sub ctcp_quote {
29 1     1 1 2670 my ($line) = @_;
30 1 50       5 confess "Expected a line" unless defined $line;
31              
32 1 50       6 if ($line =~ tr/[\012\015\0\cP]//) {
33 0         0 $line =~ s/([\012\015\0\cP])/\cP$quote{$1}/g;
34             }
35              
36 1         3 $line =~ s/\001/\\a/g;
37 1         8 "\001$line\001";
38             }
39              
40             sub ctcp_unquote {
41 5     5 1 875 my ($line) = @_;
42 5 50       14 confess "Expected a line" unless defined $line;
43              
44 5 50       17 if ($line =~ tr/\cP//) {
45 0         0 $line =~ s/\cP([nr0\cP])/$dequote{$1}/g;
46             }
47              
48 5 50       16 substr $line, rindex($line, "\001"), 1, '\\a'
49             if ($line =~ tr/\001//) % 2 != 0;
50 5 100       17 return unless $line =~ tr/\001//;
51              
52 2         8 my @chunks = split /\001/, $line;
53 2 50       8 shift @chunks unless length $chunks[0];
54 2         4 for (@chunks) {
55             ## De-quote / convert escapes
56 2         5 s/\\([^\\a])/$1/g;
57 2         3 s/\\\\/\\/g;
58 2         5 s/\\a/\001/g;
59             }
60              
61 2         2 my (@ctcp, @text);
62              
63             ## If we start with a ctrl+A, the first chunk is CTCP:
64 2 50       8 if (index($line, "\001") == 0) {
65 2         3 push @ctcp, shift @chunks;
66             }
67             ## Otherwise we start with text and alternate CTCP:
68 2         4 while (@chunks) {
69 0         0 push @text, shift @chunks;
70 0 0       0 push @ctcp, shift @chunks if @chunks;
71             }
72              
73 2         7 +{ ctcp => \@ctcp, text => \@text }
74             }
75              
76             sub ctcp_extract {
77 4     4 1 10 my ($input) = @_;
78              
79 4 50 33     18 unless (blessed $input && $input->isa('IRC::Message::Object')) {
80 4 100       23 $input = ref $input ?
81             ircmsg(%$input) : ircmsg(raw_line => $input)
82             }
83              
84 4 100       1619 my $type = uc($input->command) eq 'PRIVMSG' ? 'ctcp' : 'ctcpreply' ;
85 4         63 my $line = $input->params->[1];
86 4         952 my $unquoted = ctcp_unquote($line);
87 4 100 66     33 return unless $unquoted and @{ $unquoted->{ctcp} };
  2         9  
88              
89 2         4 my ($name, $params);
90 2         5 CTCP: for my $str ($unquoted->{ctcp}->[0]) {
91 2         11 ($name, $params) = $str =~ /^(\w+)(?: +(.*))?/;
92 2 50       5 last CTCP unless $name;
93 2         3 $name = lc $name;
94 2 50       6 if ($name eq 'dcc') {
95             ## Does no extra work to parse DCC
96             ## ... but see POE::Filter::IRC::Compat for that
97 0         0 my ($dcc_type, $dcc_params) = $params =~ /^(\w+) +(.+)/;
98 0 0       0 last CTCP unless $dcc_type;
99 0 0       0 return ircmsg(
100             ( $input->prefix ? (prefix => $input->prefix) : () ),
101             command => 'dcc_request_'.lc($dcc_type),
102             params => [
103             $input->prefix,
104             $dcc_params
105             ],
106             raw_line => $input->raw_line,
107             )
108             } else {
109 2 50       20 return ircmsg(
    50          
110             ( $input->prefix ? (prefix => $input->prefix) : () ),
111             command => $type .'_'. $name,
112             params => [
113             $input->params->[0],
114             ( defined $params ? $params : '' ),
115             ],
116             raw_line => $input->raw_line,
117             )
118             }
119             }
120             return
121 0           }
122              
123              
124             1;
125              
126             =pod
127              
128             =head1 NAME
129              
130             IRC::Toolkit::CTCP - CTCP parsing utilities
131              
132             =head1 SYNOPSIS
133              
134             ## Extract first CTCP request/reply from a message:
135             if (my $ctcp_ev = ctcp_extract( $orig_msg ) ) {
136             ## CTCP was found; $ctcp_ev is an IRC::Message::Object
137             ...
138             }
139              
140             ## Properly CTCP-quote a string:
141             my $quoted_ctcp = ctcp_quote("PING 1234");
142              
143             ## Deparse CTCP messages (including multipart):
144             if (my $ref = ctcp_unquote($raw_line)) {
145             my @ctcp = @{ $ref->{ctcp} };
146             my @txt = @{ $ref->{text} };
147             ...
148             }
149              
150             =head1 DESCRIPTION
151              
152             Utility functions useful for quoting/unquoting/extracting CTCP.
153              
154             =head2 ctcp_extract
155              
156             Takes input (in the form of an L instance,
157             a hash such as that produced by L, or a
158             raw line) and attempts to extract a valid CTCP request or reply.
159              
160             Returns an L whose C carries an
161             appropriate prefix (one of B, B, or B) prepended
162             to the CTCP command:
163              
164             ## '$ev' is your incoming or outgoing IRC::Message::Object
165             ## CTCP VERSION request:
166             $ev->command eq 'ctcp_version'
167              
168             ## Reply to CTCP VERSION:
169             $ev->command eq 'ctcpreply_version'
170              
171             ## DCC SEND:
172             $ev->command eq 'dcc_request_send'
173              
174             Returns empty list if no valid CTCP was found.
175              
176             =head2 ctcp_quote
177              
178             CTCP quote a raw line.
179              
180             =head2 ctcp_unquote
181              
182             Deparses a raw line possibly containing CTCP.
183              
184             Returns a hash with two keys, B and B, whose values are
185             ARRAYs containing the CTCP and text portions of a CTCP-quoted message.
186              
187             Returns an empty list if no valid CTCP was found.
188              
189             =head1 AUTHOR
190              
191             Jon Portnoy
192              
193             Code derived from L and L,
194             copyright BinGOs, HINRIK, fimm, Abigail et al
195              
196             Licensed under the same terms as Perl.
197              
198             =cut
199