File Coverage

blib/lib/CGI/Application/NetNewsIface/Cache/DBI.pm
Criterion Covered Total %
statement 9 115 7.8
branch 0 28 0.0
condition n/a
subroutine 3 12 25.0
pod 4 4 100.0
total 16 159 10.0


line stmt bran cond sub pod time code
1             package CGI::Application::NetNewsIface::Cache::DBI;
2              
3 1     1   52608 use strict;
  1         2  
  1         23  
4 1     1   6 use warnings;
  1         1  
  1         28  
5              
6 1     1   8 use DBI;
  1         2  
  1         1458  
7              
8             =head1 NAME
9              
10             CGI::Application::NetNewsIface::Cache::DBI - an internally used class to
11             form a fast cache of the NNTP data.
12              
13             =head1 SYNOPSIS
14              
15             use CGI::Application::NetNewsIface::Cache::DBI;
16              
17             my $cache = CGI::Application::NetNewsIface::Cache::DBI->new(
18             {
19             'nntp' => $nntp,
20             'dsn' => "dbi:SQLite:dbname=foo.sqlite",
21             },
22             );
23              
24             =head1 FUNCTIONS
25              
26             =head2 new({ %params })
27              
28             Constructs a new cache object. Accepts a single argument - a hash ref with
29             named parameters. Required parameters are:
30              
31             =over 4
32              
33             =item 'nntp'
34              
35             A handle to the Net::NNTP object that will be used for querying the NNTP
36             server.
37              
38             =item 'dsn'
39              
40             The DBI 'dsn' for the DBI initialization.
41              
42             =back
43              
44             =cut
45              
46             sub new
47             {
48 0     0 1   my $class = shift;
49 0           my $self = {};
50 0           bless $self, $class;
51              
52 0           $self->_initialize(@_);
53              
54 0           return $self;
55             }
56              
57             sub _initialize
58             {
59 0     0     my $self = shift;
60 0           my $args = shift;
61              
62 0           $self->{'nntp'} = $args->{'nntp'};
63              
64 0           my $dbh = $self->{'dbh'} = DBI->connect($args->{'dsn'}, "", "");
65              
66 0           $self->{'sths'}->{'select_group'} =
67             $dbh->prepare_cached(
68             "SELECT idx, last_art FROM groups WHERE name = ?"
69             );
70              
71 0           $self->{'sths'}->{'insert_group'} =
72             $dbh->prepare_cached(
73             "INSERT INTO groups (name, idx, last_art) VALUES (?, null, 0)"
74             );
75              
76 0           $self->{'sths'}->{'insert_art'} =
77             $dbh->prepare_cached(
78             "INSERT INTO articles (group_idx, article_idx, msg_id, parent, subject, frm, date)
79             VALUES (?, ?, ?, ?, ?, ?, ?)"
80             );
81              
82 0           $self->{'sths'}->{'update_last_art'} =
83             $dbh->prepare_cached(
84             "UPDATE groups SET last_art = ? WHERE idx = ?"
85             );
86              
87 0           $self->{'sths'}->{'get_index_of_id'} =
88             $dbh->prepare_cached(
89             "SELECT article_idx FROM articles WHERE (group_idx = ?) AND (msg_id = ?)"
90             );
91              
92 0           $self->{'sths'}->{'get_parent'} =
93             $dbh->prepare_cached(
94             "SELECT parent FROM articles WHERE (group_idx = ?) AND (article_idx = ?)"
95             );
96              
97 0           $self->{'sths'}->{'get_sub_thread'} =
98             $dbh->prepare_cached(
99             "SELECT article_idx, subject, date, frm" .
100             " FROM articles" .
101             " WHERE (group_idx = ?) AND (parent = ?)" .
102             # We're ordering on (group_idx, article_idx) because that's what
103             # the relevant index on the table is wired to.
104             " ORDER BY group_idx, article_idx"
105             );
106              
107 0           $self->{'sths'}->{'get_art_info'} =
108             $dbh->prepare_cached(
109             "SELECT subject, date, frm FROM articles WHERE (group_idx = ?) AND (article_idx = ?)"
110             );
111              
112 0           return 0;
113             }
114              
115             # This is a non-working workaround for the following DBD-SQLite bug:
116             # http://rt.cpan.org/Public/Bug/Display.html?id=9643
117             # It can probably be removed afterwards.
118             sub DESTROY
119             {
120 0     0     my $self = shift;
121 0           my @stmts = keys(%{$self->{'sths'}});
  0            
122 0           foreach my $s (@stmts)
123             {
124 0           my $sth = delete($self->{'sths'}->{$s});
125 0           $sth->finish();
126             }
127             }
128              
129             =head2 $cache->select( $group )
130              
131             Selects the newsgroup $group.
132              
133             =cut
134              
135             sub select
136             {
137 0     0 1   my ($self, $group) = @_;
138 0           $self->{'group'} = $group;
139 0           return $self->_update_group();
140             }
141              
142             sub _update_group
143             {
144 0     0     my $self = shift;
145              
146 0           my $group = $self->{'group'};
147 0           my $nntp = $self->{'nntp'};
148 0           my @info = $nntp->group($group);
149 0 0         if (! @info)
150             {
151 0           die "Unknown group \"$group\".";
152             }
153              
154 0           my ($num_articles, $first_article, $last_article) = @info;
155              
156             # TODO: Add a transaction here
157 0           my $sth = $self->{sths}->{select_group};
158 0           $sth->execute($group);
159 0           my $group_record = $sth->fetchrow_arrayref();
160 0 0         if (!defined($group_record))
161             {
162 0           $self->{sths}->{insert_group}->execute($group);
163 0           $sth = $self->{sths}->{select_group};
164 0           $sth->execute($group);
165 0           $group_record = $sth->fetchrow_arrayref();
166             }
167 0           my $last_updated_art;
168             my $group_idx;
169 0           my $start_art;
170 0           ($group_idx, $last_updated_art) = @$group_record;
171 0           $self->{group_idx} = $group_idx;
172 0 0         if ($last_updated_art == 0)
173             {
174 0           $start_art = $first_article;
175             }
176             else
177             {
178 0           $start_art = $last_updated_art+1;
179             }
180              
181 0           my $ins_sth = $self->{sths}->{insert_art};
182 0           for (my $art_idx=$start_art; $art_idx <= $last_article;$art_idx++)
183             {
184 0           my $head = $nntp->head($art_idx);
185 0 0         if (!defined($head))
186             {
187 0           next;
188             }
189              
190 0           my ($msg_id,$subject, $from, $date);
191 0           my $parent = 0;
192 0           foreach my $header (@$head)
193             {
194 0           chomp($header);
195 0 0         if ($header =~ m{^Subject: (.*)})
    0          
    0          
    0          
    0          
196             {
197 0           $subject = $1;
198             }
199             elsif ($header =~ m{^Message-ID: <(.*?)>$})
200             {
201 0           $msg_id = $1;
202             }
203             elsif ($header =~ m{In-reply-to: <(.*?)>$}i)
204             {
205 0           $parent = $self->get_index_of_id($1);
206             }
207             elsif ($header =~ m{^From: (.*)$})
208             {
209 0           $from = $1;
210             }
211             elsif ($header =~ m{^Date: (.*)$})
212             {
213 0           $date = $1;
214             }
215             }
216             $ins_sth->execute(
217 0           $group_idx, $art_idx, $msg_id, $parent,
218             $subject, $from, $date,
219             );
220             }
221              
222 0 0         if ($start_art <= $last_article)
223             {
224             $self->{sths}->{update_last_art}
225 0           ->execute($last_article, $group_idx);
226             }
227              
228 0           return 0;
229             }
230              
231             =head2 $cache->get_index_of_id($id)
232              
233             Retrieves the index of the message with the id C<$id>.
234              
235             =cut
236              
237             sub get_index_of_id
238             {
239 0     0 1   my ($self, $msg_id) = @_;
240 0           my $sth = $self->{sths}->{get_index_of_id};
241 0           $sth->execute($self->{'group_idx'}, $msg_id);
242 0           my $ret = $sth->fetchrow_arrayref();
243 0 0         return (defined($ret) ? $ret->[0] : 0);
244             }
245              
246             sub _get_parent
247             {
248 0     0     my ($self, $index) = @_;
249 0           my $sth = $self->{sths}->{get_parent};
250 0           $sth->execute($self->{'group_idx'}, $index);
251 0           my $ret = $sth->fetchrow_arrayref();
252 0 0         return (defined($ret) ? $ret->[0] : undef);
253             }
254              
255             =head2 ($thread, $coords) = $cache->get_thread($index);
256              
257             Gets the thread for the message indexed C<$index>. Thread is:
258              
259             C<$thread> looks like this:
260              
261             {
262             'idx' => $index,
263             'subject' => "Problem with Test::More",
264             'date' => $date,
265             'from' => "Shlomi Fish ",
266             'subs' =>
267             [
268             {
269             'idx' => $index,
270             .
271             'subs' =>
272             [
273             .
274             .
275             .
276             ],
277             }
278             .
279             .
280             .
281             ],
282             }
283              
284             C<$coords> is the coordinates leading to the current article within the
285             thread. To access the current article from the coords use:
286              
287             $thread->{'subs'}->[$coords[0]]->{'subs'}->[$coords[1]]->...
288              
289             =cut
290              
291             sub get_thread
292             {
293 0     0 1   my ($self, $index) = @_;
294              
295             # Get the first ancestor of the thread.
296 0           my $thread_head;
297             {
298 0           my ($parent, $grandparent);
  0            
299 0           $parent = $index;
300 0           while (($grandparent = $self->_get_parent($parent)) != 0)
301             {
302 0           $parent = $grandparent;
303             }
304 0           $thread_head = $parent;
305             }
306              
307             # Make sure we retrieve information for the top-most node.
308 0           my $sth = $self->{sths}->{get_art_info};
309 0           $sth->execute($self->{group_idx}, $thread_head);
310 0           my $info = $sth->fetchrow_arrayref();
311 0           my $thread_struct =
312             {
313             'idx' => $thread_head,
314             'subject' => $info->[0],
315             'date' => $info->[1],
316             'from' => $info->[2],
317             };
318              
319 0           my $coords;
320 0           $self->_get_sub_thread($thread_struct, $index, \$coords, []);
321 0           return ($thread_struct, $coords);
322             }
323              
324             sub _get_sub_thread
325             {
326 0     0     my ($self, $struct_ptr, $requested, $coords_ptr, $coords) = @_;
327 0           my $index = $struct_ptr->{idx};
328 0 0         if ($index == $requested)
329             {
330 0           $$coords_ptr = $coords;
331             }
332 0           my $sth = $self->{sths}->{get_sub_thread};
333 0           $sth->execute($self->{group_idx}, $index);
334 0           my @subs;
335 0           while (my $row = $sth->fetchrow_arrayref())
336             {
337 0           push @subs,
338             {
339             'idx' => $row->[0],
340             'subject' => $row->[1],
341             'date' => $row->[2],
342             'from' => $row->[3],
343             };
344             }
345 0 0         if (@subs)
346             {
347 0           $struct_ptr->{subs} = \@subs;
348 0           foreach my $child_idx (0 .. $#subs)
349             {
350 0           $self->_get_sub_thread(
351             $subs[$child_idx],
352             $requested,
353             $coords_ptr,
354             [@$coords, $child_idx],
355             );
356             }
357             }
358             }
359              
360             =head1 AUTHOR
361              
362             Shlomi Fish, L .
363              
364             =head1 BUGS
365              
366             Please report any bugs or feature requests to
367             C, or through the web interface at
368             L.
369             I will be notified, and then you'll automatically be notified of progress on
370             your bug as I make changes.
371              
372             =head1 ACKNOWLEDGEMENTS
373              
374             =head1 COPYRIGHT & LICENSE
375              
376             Copyright 2006 Shlomi Fish, all rights reserved.
377              
378             This program is released under the following license: MIT X11.
379              
380             =cut
381              
382             1;
383