File Coverage

blib/lib/IRC/Toolkit/Modes.pm
Criterion Covered Total %
statement 70 70 100.0
branch 29 34 85.2
condition 18 30 60.0
subroutine 7 7 100.0
pod 3 3 100.0
total 127 144 88.1


line stmt bran cond sub pod time code
1             package IRC::Toolkit::Modes;
2             $IRC::Toolkit::Modes::VERSION = '0.092002';
3 5     5   16021 use strictures 2;
  5         2229  
  5         150  
4 5     5   679 use Carp;
  5         6  
  5         234  
5              
6 5     5   17 use Scalar::Util 'blessed', 'reftype';
  5         5  
  5         217  
7              
8 5     5   741 use parent 'Exporter::Tiny';
  5         430  
  5         18  
9             our @EXPORT = qw/
10             array_to_mode
11             mode_to_array
12             mode_to_hash
13             /;
14              
15              
16             sub array_to_mode {
17 8     8 1 1265 my ($array) = @_;
18 8 100 66     33 if (blessed $array && $array->isa('IRC::Mode::Set')) {
19 1         31 $array = $array->mode_array
20             }
21 8 50 33     51 confess "Expected an ARRAY but got $array"
22             unless ref $array and reftype $array eq 'ARRAY';
23              
24 8         6 my $mstr;
25 8         10 my $curflag = my $pstr = '';
26 8         11 for my $cset (@$array) {
27 23         46 my ($flag, $mode, $param) = @$cset;
28 23 50 33     67 confess "Appear to have been given an invalid mode array"
29             unless defined $flag and defined $mode;
30 23 100       33 $mstr .= $flag eq $curflag ? $mode : ($curflag = $flag) . $mode ;
31 23 100       40 $pstr .= " $param" if defined $param;
32             }
33              
34 8 100       15 $mstr .= $pstr if length $pstr;
35 8         28 $mstr
36             }
37              
38             sub mode_to_array {
39             ## mode_to_array( $string,
40             ## param_always => [ split //, 'bkov' ],
41             ## param_set => [ 'l' ],
42             ## params => [ @params ],
43             ##
44             ## Returns ARRAY-of-ARRAY like:
45             ## [ [ '+', 'o', 'some_nick' ], [ '-', 't' ] ]
46              
47 9     9 1 852 my $modestr = shift;
48 9 50       25 confess "mode_to_array() called without mode string"
49             unless defined $modestr;
50              
51 9         20 my %args = @_;
52 9 100       18 if (my $isup = $args{isupport_chanmodes}) {
53 1 50 33     17 confess
      33        
54             "isupport_chanmodes specified but not an ISupport chanmodes() obj: $isup"
55             unless blessed $isup and $isup->can('always') and $isup->can('whenset');
56 1         3 $args{param_always} = $isup->always->unbless;
57 1         7 $args{param_set} = $isup->whenset->unbless;
58             }
59 9   100     32 $args{param_always} ||= [ split //, 'bkohv' ];
60 9   50     30 $args{param_set} ||= ( $args{param_on_set} || [ 'l' ] );
      66        
61 9   100     22 $args{params} ||= [ ];
62              
63 9 100       21 if ( index($modestr, ' ') > -1 ) {
64 4         4 my @params;
65 4         14 ($modestr, @params) = split ' ', $modestr;
66 4         7 unshift @{ $args{params} }, @params;
  4         12  
67             }
68              
69 9         15 for (qw/ param_always param_set params /) {
70             confess "$_ should be an ARRAY"
71 27 50       74 unless reftype $args{$_} eq 'ARRAY';
72             }
73              
74 9         10 my @parsed;
75 9         8 my %param_always = map {; $_ => 1 } @{ $args{param_always} };
  33         53  
  9         14  
76 9         11 my %param_set = map {; $_ => 1 } @{ $args{param_set} };
  10         16  
  9         12  
77 9         24 my @chunks = split //, $modestr;
78 9         11 my $in = '+';
79 9         16 CHUNK: while (my $chunk = shift @chunks) {
80 57 100 100     139 if ($chunk eq '-' || $chunk eq '+') {
81 25         18 $in = $chunk;
82             next CHUNK
83 25         43 }
84              
85 32         35 my @current = ( $in, $chunk );
86 32 100       35 if ($in eq '+') {
87 19         23 push @current, shift @{ $args{params} }
88             if exists $param_always{$chunk}
89 22 100 66     57 or exists $param_set{$chunk};
90             } else {
91 6         8 push @current, shift @{ $args{params} }
92 10 100       16 if exists $param_always{$chunk};
93             }
94              
95 32         78 push @parsed, [ @current ]
96             }
97              
98 9         55 [ @parsed ]
99             }
100              
101             sub mode_to_hash {
102             ## Returns HASH like:
103             ## add => {
104             ## 'o' => [ 'some_nick' ],
105             ## 't' => 1,
106             ## },
107             ## del => {
108             ## 'k' => [ 'some_key' ],
109             ## },
110              
111             ## This is a 'lossy' approach.
112             ## It won't accomodate batched modes well.
113             ## Use mode_to_array instead.
114 2     2 1 4 my $array = mode_to_array(@_);
115 2         4 my $modes = { add => {}, del => {} };
116 2         5 while (my $this_mode = shift @$array) {
117 5         6 my ($flag, $mode, $param) = @$this_mode;
118 5 100       6 my $key = $flag eq '+' ? 'add' : 'del' ;
119 5 100       15 $modes->{$key}->{$mode} = $param ? [ $param ] : 1
120             }
121              
122             $modes
123 2         7 }
124              
125             1;
126              
127              
128             =pod
129              
130             =head1 NAME
131              
132             IRC::Toolkit::Modes - IRC mode parsing utilities
133              
134             =head1 SYNOPSIS
135              
136             use IRC::Toolkit::Modes;
137             my $mode_string = '+o-o avenj Joah';
138             my $array = mode_to_array( $mode_string );
139             my $hash = mode_to_hash( $mode_string );
140              
141             =head1 DESCRIPTION
142              
143             Utility functions for parsing IRC mode strings.
144              
145             Also see L for an object-oriented approach to modes.
146              
147             =head2 mode_to_array
148              
149             my $array = mode_to_array(
150             ## Mode change string with or without params, e.g. '+kl-t'
151             $mode_string,
152              
153             ## Modes that always have a param:
154             param_always => ARRAY,
155              
156             ## Modes that only have a param when set:
157             param_set => ARRAY,
158              
159             ## Respective params for modes specified above
160             ## (or can be specified as part of mode string)
161             params => ARRAY,
162             );
163              
164             Given a mode string and some options, return an ARRAY of ARRAYs containing
165             parsed mode changes.
166              
167             The structure looks like:
168              
169             [
170             [ FLAG, MODE, MAYBE_PARAM ],
171             [ . . . ],
172             ]
173              
174             For example:
175              
176             mode_to_array( '+kl-t',
177             params => [ 'key', 10 ],
178             param_always => [ split //, 'bkov' ],
179             param_set => [ 'l' ],
180             );
181              
182             ## Result:
183             [
184             [ '+', 'k', 'key' ],
185             [ '+', 'l', 10 ],
186             [ '-', 't' ],
187             ],
188              
189             If the mode string contains (space-delimited) parameters, they are given
190             precedence ahead of the optional 'params' ARRAY.
191              
192             Instead of manually specifying C and C, you can pass
193             in the B object provided by L:
194              
195             my $isupport = parse_isupport(@isupport_lines);
196             my $array = mode_to_array( '+kl-t',
197             params => [ 'key', 10 ],
198             isupport_chanmodes => $isupport->chanmodes,
199             );
200              
201             C will override C / C -- if
202             that's not acceptable, you can select individual sets:
203              
204             my $array = mode_to_array( '+klX-t',
205             params => [ 'key', 10, 'foo' ],
206             param_always => $isupport->chanmodes->always,
207             param_set => [ 'lX' ],
208              
209             =head2 array_to_mode
210              
211             Takes an ARRAY such as that produced by L and returns an IRC
212             mode string.
213              
214             =head2 mode_to_hash
215              
216             Takes the same parameters as L -- this is just a way to
217             inflate the ARRAY to a hash.
218              
219             Given a mode string and some options, return a HASH with
220             the keys B and B.
221              
222             B and B are HASHes mapping mode characters to either a simple
223             boolean true value or an ARRAY whose only element is the mode's
224             parameters, e.g.:
225              
226             mode_to_hash( '+kl-t',
227             params => [ 'key', 10 ],
228             param_always => [ split //, 'bkov' ],
229             param_set => [ 'l' ],
230             );
231              
232             ## Result:
233             {
234             add => {
235             'l' => [ 10 ],
236             'k' => [ 'key' ],
237             },
238              
239             del => {
240             't' => 1,
241             },
242             }
243              
244             This is a 'lossy' approach that won't deal well with multiple conflicting mode
245             changes in a single line; L should generally be preferred.
246              
247             =head1 AUTHOR
248              
249             Jon Portnoy
250              
251             =cut
252