File Coverage

blib/lib/Bot/Pastebot/Data.pm
Criterion Covered Total %
statement 27 153 17.6
branch 0 44 0.0
condition 0 12 0.0
subroutine 9 31 29.0
pod 0 19 0.0
total 36 259 13.9


line stmt bran cond sub pod time code
1             # Data management.
2              
3             package Bot::Pastebot::Data;
4              
5 1     1   946 use warnings;
  1         2  
  1         25  
6 1     1   7 use strict;
  1         2  
  1         26  
7              
8 1     1   4 use Carp qw(croak);
  1         2  
  1         36  
9 1     1   5 use POE;
  1         1  
  1         8  
10 1     1   2150 use Storable;
  1         3534  
  1         71  
11 1     1   7 use Bot::Pastebot::Conf qw( get_names_by_type get_items_by_name );
  1         3  
  1         48  
12              
13 1     1   4 use base qw(Exporter);
  1         2  
  1         178  
14              
15             our @EXPORT_OK = qw(
16             store_paste fetch_paste delete_paste list_paste_ids
17             delete_paste_by_id fetch_paste_channel clear_channel_ignores
18             set_ignore clear_ignore get_ignores is_ignored channels add_channel
19             remove_channel clear_channels
20             );
21              
22             # Paste data members.
23              
24             sub PASTE_TIME () { 0 }
25             sub PASTE_SUMMARY () { 1 }
26             sub PASTE_ID () { 2 }
27             sub PASTE_NETWORK () { 3 }
28             sub PASTE_CHANNEL () { 4 }
29             sub PASTE_HOST () { 5 }
30              
31             my $id_sequence = 0;
32             my %paste_cache;
33             my %ignores; # $ignores{$ircnet}{lc $channel} = [ mask, mask, ... ];
34             my %channels;
35              
36             # Return this module's configuration.
37              
38 1     1   6 use Bot::Pastebot::Conf qw(SCALAR REQUIRED);
  1         1  
  1         1540  
39              
40             my %conf = (
41             pastes => {
42             name => SCALAR | REQUIRED,
43             check => SCALAR,
44             expire => SCALAR,
45             count => SCALAR,
46             throttle => SCALAR,
47             store => SCALAR | REQUIRED,
48             },
49             );
50              
51 0     0 0   sub get_conf { return %conf }
52              
53             # Return a list of all paste IDs.
54              
55             sub list_paste_ids {
56 0     0 0   return keys %paste_cache;
57             }
58              
59              
60             {
61             my $store = ''; # Static variable in pastestore()
62              
63             sub pastestore {
64              
65             # already set, return value
66              
67 0 0   0 0   $store and return $store;
68              
69 0           my @names = get_names_by_type('pastes');
70 0 0         return unless @names;
71 0           my %conf = get_items_by_name($names[0]);
72 0           $store = $conf{store};
73             }
74             }
75              
76             # Remove pastes that are too old (if applicable).
77              
78             sub check_paste_count {
79 0     0 0   my @names = get_names_by_type('pastes');
80 0 0         return unless @names;
81 0           my %conf = get_items_by_name($names[0]);
82 0 0 0       return unless %conf && $conf{'count'};
83 0 0         return if (scalar keys %paste_cache < $conf{'count'});
84 0           my $oldest = (
85             sort {
86 0           $paste_cache{$a}->[PASTE_TIME] > $paste_cache{$b}->[PASTE_TIME]
87             } keys %paste_cache
88             )[0];
89 0           delete_paste_by_id($oldest);
90             }
91              
92             # Save paste, returning an ID.
93              
94             sub store_paste {
95 0     0 0   my ($id, $summary, $paste, $ircnet, $channel, $ipaddress) = @_;
96 0           check_paste_count();
97              
98 0           my $new_id = ++$id_sequence;
99 0           $paste_cache{$new_id} = [
100             time(), # PASTE_TIME
101             $summary, # PASTE_SUMMARY
102             $id, # PASTE_ID
103             $ircnet, # PASTE_NETWORK
104             lc($channel), # PASTE_CHANNEL
105             $ipaddress, # PASTE_HOST
106             ];
107              
108 0           my $dir = pastestore();
109              
110 0           store \%paste_cache, "$dir/Index";
111              
112 0 0         open BODY, ">", "$dir/$new_id" or warn "I cannot store paste $new_id: $!";
113 0           binmode(BODY);
114 0           print BODY $paste;
115 0           close BODY;
116              
117 0           return $new_id;
118             }
119              
120             # Fetch paste by ID.
121              
122             sub fetch_paste {
123 0     0 0   my $id = shift;
124 0           my $paste = $paste_cache{$id};
125 0 0         return(undef, undef, undef) unless defined $paste;
126              
127 0           my $dir = pastestore();
128              
129 0 0         unless(open BODY, "<", "$dir/$id") {
130 0           warn "Error opening paste $id: $!";
131 0           return(undef, undef, undef);
132             }
133 0           local $/ = undef;
134              
135             return(
136 0           $paste->[PASTE_ID],
137             $paste->[PASTE_SUMMARY],
138             <BODY>
139             );
140             }
141              
142             # Fetch the channel a paste was meant for.
143              
144             sub fetch_paste_channel {
145 0     0 0   my $id = shift;
146 0           return $paste_cache{$id}->[PASTE_CHANNEL];
147             }
148              
149             sub delete_paste_by_id {
150 0     0 0   my $id = shift;
151 0           delete $paste_cache{$id};
152              
153 0           my $dir = pastestore;
154              
155 0 0         unlink "$dir/$id" or warn "Problem removing paste $id: $!";
156              
157 0           store \%paste_cache, "$dir/Index";
158             }
159              
160             # Delete a possibly sensitive or offensive paste.
161              
162             sub delete_paste {
163 0     0 0   my ($ircnet, $channel, $id, $bywho) = @_;
164              
165 0           my $dir = pastestore();
166              
167 0 0 0       if (
168             $paste_cache{$id}[PASTE_NETWORK] eq $ircnet &&
169             $paste_cache{$id}[PASTE_CHANNEL] eq lc $channel
170             ) {
171             # place the blame where it belongs
172 0 0         unless (open BODY, ">", "$dir/$id") {
173 0           warn "Error deleting body for paste $id: $!";
174 0           return;
175             }
176 0           print BODY "Deleted by $bywho";
177             }
178             else {
179 0           return;
180             }
181             }
182              
183             # Manage channel/IRC network based ignores of http requestors.
184              
185             sub _convert_mask {
186 0     0     my $mask = shift;
187              
188 0           $mask =~ s/\./\\./g;
189 0           $mask =~ s/\*/\\d+/g;
190              
191 0           $mask;
192             }
193              
194             sub is_ignored {
195 0     0 0   my ($ircnet, $channel, $host) = @_;
196              
197 0 0 0       $ignores{$ircnet}{lc $channel} && @{$ignores{$ircnet}{lc $channel}}
  0            
198             or return;
199              
200 0           for my $mask (@{$ignores{$ircnet}{lc $channel}}) {
  0            
201 0 0         $host =~ /^$mask$/ and return 1;
202             }
203              
204 0           return;
205             }
206              
207             sub set_ignore {
208 0     0 0   my ($ircnet, $channel, $mask) = @_;
209              
210 0           $mask = _convert_mask($mask);
211              
212             # remove any existing mask - so it's not fast
213 0           @{$ignores{$ircnet}{lc $channel}} =
  0            
214 0           grep $_ ne $mask, @{$ignores{$ircnet}{lc $channel}};
215 0           push @{$ignores{$ircnet}{lc $channel}}, $mask;
  0            
216 0           store \%ignores, "ignorelist";
217             }
218              
219             sub clear_ignore {
220 0     0 0   my ($ircnet, $channel, $mask) = @_;
221              
222 0           $mask = _convert_mask($mask);
223              
224 0           @{$ignores{$ircnet}{lc $channel}} =
  0            
225 0           grep $_ ne $mask, @{$ignores{$ircnet}{lc $channel}};
226 0           store \%ignores, "ignorelist";
227             }
228              
229             sub get_ignores {
230 0     0 0   my ($ircnet, $channel) = @_;
231              
232 0 0         $ignores{$ircnet}{lc $channel} or return;
233              
234 0           my @masks = @{$ignores{$ircnet}{lc $channel}};
  0            
235              
236 0           for (@masks) {
237 0           s/\\d\+/*/g;
238 0           s/\\././g;
239             }
240              
241 0           @masks;
242             }
243              
244             sub clear_channel_ignores {
245 0     0 0   my ($ircnet, $channel) = @_;
246              
247 0           $ignores{$ircnet}{lc $channel} = [];
248 0           store \%ignores, "ignorelist";
249             }
250              
251             # Channels we're on
252              
253             sub channels {
254 0     0 0   my $network = lc(shift);
255 0           return sort keys %{$channels{$network}};
  0            
256             }
257              
258             sub clear_channels {
259 0     0 0   my $network = lc(shift);
260 0           %{$channels{$network}} = ();
  0            
261 0 0         return if keys %{$channels{$network}}; # Should never happen
  0            
262 0           return 1;
263             }
264              
265             sub add_channel {
266 0     0 0   my ($network, $channel) = @_;
267 0           $network = lc($network);
268 0           $channel = lc($channel);
269 0           $channels{$network}{$channel} = 1;
270             }
271              
272             sub remove_channel {
273 0     0 0   my ($network, $channel) = @_;
274 0           $network = lc($network);
275 0           $channel = lc($channel);
276 0           delete $channels{$network}{$channel}; # returns automatically
277             }
278              
279             # Init stuff
280              
281             sub initialize {
282 0     0 0   my $dir = pastestore();
283              
284 0 0         unless (-d $dir) {
285 1     1   6 use File::Path;
  1         2  
  1         419  
286 0           eval { mkpath $dir };
  0            
287 0 0         if ($@) {
288 0           die "Couldn't create directory $dir: $@";
289             }
290             }
291              
292 0 0         if (-e "$dir/Index") {
293 0           %paste_cache = %{retrieve "$dir/Index"};
  0            
294 0           $id_sequence = (sort keys %paste_cache)[-1];
295             }
296 0 0         if (-e "ignorelist") {
297 0           %ignores = %{retrieve 'ignorelist'};
  0            
298             }
299              
300 0           my @pastes = get_names_by_type('pastes');
301 0 0         if (@pastes) {
302 0           my %conf = get_items_by_name($pastes[0]);
303 0 0 0       if ($conf{'check'} && $conf{'expire'}) {
304             POE::Session->create(
305             inline_states => {
306 0     0     _start => sub { $_[KERNEL]->delay( ticks => $conf{'check'} ); },
307             ticks => sub {
308 0     0     for (keys %paste_cache) {
309             next unless (
310 0 0         (time - $paste_cache{$_}->[PASTE_TIME]) > $conf{'expire'}
311             );
312 0           delete_paste_by_id($_);
313             }
314 0           $_[KERNEL]->delay( ticks => $conf{'check'} );
315             },
316             },
317 0           );
318             }
319             }
320             }
321              
322             1;