File Coverage

blib/lib/CGI/Application/NetNewsIface.pm
Criterion Covered Total %
statement 18 20 90.0
branch n/a
condition n/a
subroutine 7 7 100.0
pod n/a
total 25 27 92.5


line stmt bran cond sub pod time code
1             package CGI::Application::NetNewsIface;
2              
3 2     2   21159 use strict;
  2         4  
  2         48  
4 2     2   10 use warnings;
  2         3  
  2         46  
5              
6 2     2   36 use 5.008;
  2         10  
7              
8             =head1 NAME
9              
10             CGI::Application::NetNewsIface - a publicly-accessible read-only interface
11             for Usenet (NNTP) news.
12              
13             =head1 SYNOPSIS
14              
15             In a common module:
16              
17             use CGI::Application::NetNewsIface;
18              
19             sub get_app
20             {
21             return CGI::Application::NetNewsIface->new(
22             PARAMS => {
23             'nntp_server' => "nntp.perl.org",
24             'articles_per_page' => 10,
25             'dsn' => "dbi:SQLite:dbname=./data/mynntp.sqlite",
26             }
27             );
28             }
29              
30             To set up:
31              
32             get_app()->init_cache__sqlite();
33              
34             To run
35              
36             get_app()->run();
37              
38             =cut
39              
40 2     2   11 use base 'CGI::Application';
  2         2  
  2         2343  
41 2     2   15947 use base 'Class::Accessor';
  2         3  
  2         1605  
42              
43 2     2   5919 use CGI::Application::Plugin::TT;
  2         55415  
  2         27  
44              
45 2     2   2215 use XML::RSS;
  0            
  0            
46              
47             use Net::NNTP;
48              
49             use CGI::Application::NetNewsIface::ConfigData;
50              
51             use CGI::Application::NetNewsIface::Cache::DBI;
52              
53             use vars qw($VERSION);
54              
55             $VERSION = "0.0203";
56              
57             use CGI;
58              
59             my %modes =
60             (
61             'main' =>
62             {
63             'url' => "/",
64             'func' => "_main_page",
65             },
66             'groups_list' =>
67             {
68             'url' => "/group/",
69             'func' => "_groups_list_page",
70             },
71             'group_display' =>
72             {
73             'url' => "/group/foo.bar/",
74             'func' => "_group_display_page",
75             },
76             'article_display' =>
77             {
78             'url' => "/group/foo.bar/666",
79             'func' => "_article_display_page",
80             },
81             'css' =>
82             {
83             'url' => "/style.css",
84             'func' => "_css",
85             },
86             'about_app' =>
87             {
88             'url' => "/cgi-app-nni/",
89             'func' => "_about_app_page",
90             }
91             );
92              
93             my %urls_to_modes = (map { $modes{$_}->{'url'} => $_ } keys(%modes));
94              
95             __PACKAGE__->mk_accessors(qw(
96             config
97             record_tt
98             ));
99              
100             =head1 PARAMS
101              
102             =head2 nntp_server
103              
104             The Server to which to connect using NNTP.
105              
106             =head2 articles_per_page
107              
108             The number of articles to display per page of listing of a newsgroup.
109              
110             =head2 dsn
111              
112             The DBI 'dsn' for the cache.
113              
114             =head1 FUNCTIONS
115              
116             =head2 $cgiapp->setup()
117              
118             The setup subroutine as required by CGI::Application.
119              
120             =cut
121              
122             sub setup
123             {
124             my $self = shift;
125              
126             $self->_initialize($self->param('config'));
127              
128             $self->start_mode("main");
129             $self->mode_param(\&_determine_mode);
130              
131             $self->run_modes(
132             (map { $_ => $modes{$_}->{'func'}, } keys(%modes)),
133             # Remmed out:
134             # I think of deprecating it because there's not much difference
135             # between it and add.
136             # "add_form" => "add_form",
137             'redirect_to_main' => "_redirect_to_main",
138             'correct_path' => "_correct_path",
139             );
140             }
141              
142             sub cgiapp_prerun
143             {
144             my $self = shift;
145              
146             $self->tt_params(
147             'path_to_root' => $self->_get_path_to_root(),
148             'show_all_records_url' => "search/?all=1",
149             );
150              
151             # TODO : There may be a more efficient/faster way to do it, but I'm
152             # anxious to get it to work. -- Shlomi Fish
153             $self->tt_include_path(
154             [ './templates',
155             @{CGI::Application::NetNewsIface::ConfigData->config('templates_install_path')},
156             ],
157             );
158              
159             # This is so the CGI header won't print a character set.
160             $self->query()->charset('');
161             }
162              
163             =head2 cgiapp_prerun()
164              
165             This is the cgiapp_prerun() subroutine.
166              
167             =cut
168              
169             sub _redirect_to_main
170             {
171             my $self = shift;
172              
173             return "

URL Not Found

";
174             }
175              
176             sub _correct_path
177             {
178             my $self = shift;
179              
180             my $path = $self->_get_path();
181              
182             $path =~ m#([^/]+)/*$#;
183              
184             my $last_component = $1;
185              
186             # This is in case we were passed the script name without a trailing /
187             # in which case the last component would be undefined. So consult
188             # the request uri.
189             if (!defined($last_component))
190             {
191             # Extract the Request URI
192             my $request_uri = $ENV{REQUEST_URI} || "";
193             $request_uri =~ m#([^/]+)/*$#;
194             $last_component = $1;
195             if (!defined($last_component))
196             {
197             $last_component = "";
198             }
199             }
200              
201             $self->header_type('redirect');
202             $self->header_props(-url => "./$last_component/");
203             }
204              
205             sub _get_path
206             {
207             my $self = shift;
208              
209             my $q = $self->query();
210              
211             my $path = $q->path_info();
212              
213             return $path;
214             }
215              
216             sub _determine_mode
217             {
218             my $self = shift;
219              
220             my $path = $self->_get_path();
221              
222             if ($path =~ /\/\/$/)
223             {
224             return "correct_path";
225             }
226              
227             if ($path eq "/")
228             {
229             return "main";
230             }
231             if ($path eq "/style.css")
232             {
233             return "css";
234             }
235             elsif ($path eq "/cgi-app-nni/")
236             {
237             return "about_app";
238             }
239             elsif ($path =~ s{^/group/}{})
240             {
241             if ($path eq "")
242             {
243             return "groups_list";
244             }
245             elsif ($path =~ s{^([[:lower:][:digit:]\.]+)/}{})
246             {
247             my $group = $1;
248             $self->param('group' => $group);
249             if ($path eq "")
250             {
251             return "group_display";
252             }
253             else
254             {
255             if ($path =~ s{^(\d+)$}{})
256             {
257             $self->param('article' => $1);
258             return "article_display";
259             }
260             else
261             {
262             return "correct_path";
263             }
264             }
265             }
266             }
267             else
268             {
269             return "redirect_to_main";
270             }
271             }
272              
273             sub _initialize
274             {
275             my $self = shift;
276              
277             my $config = shift;
278             $self->config($config);
279              
280             my $tt = Template->new(
281             {
282             'BLOCKS' =>
283             {
284             'main' => $config->{'record_template'},
285             },
286             },
287             );
288              
289             $self->record_tt($tt);
290              
291             return 0;
292             }
293              
294             sub _remove_leading_slash
295             {
296             my ($self, $string) = @_;
297             $string =~ s{^/}{};
298             return $string;
299             }
300              
301             sub _get_path_wo_leading_slash
302             {
303             my $self = shift;
304             return $self->_remove_leading_slash($self->_get_path());
305             }
306              
307             sub _get_rel_url_to_root
308             {
309             my ($self, $string) = @_;
310             return join("", (map { "../" } split(/\//, $string)));
311             }
312              
313             sub _get_path_to_root
314             {
315             my $self = shift;
316              
317             return $self->_get_rel_url_to_root($self->_get_path_wo_leading_slash());
318             }
319              
320             sub _main_page
321             {
322             my $self = shift;
323              
324             return $self->tt_process(
325             'main_page.tt',
326             {
327             'path_to_root' => $self->_get_path_to_root(),
328             'title' => "Web Interface to the News Server",
329             'nntp_server' => $self->param('nntp_server'),
330             },
331             );
332             }
333              
334             sub _about_app_page
335             {
336             my $self = shift;
337              
338             return $self->tt_process(
339             'about_app_page.tt',
340             {
341             'title' => "About CGI-Application-NetNewsIface",
342             'path_to_root' => $self->_get_path_to_root(),
343             },
344             );
345             }
346              
347             sub _get_nntp
348             {
349             my $self = shift;
350             return Net::NNTP->new($self->param('nntp_server'));
351             }
352              
353             sub _groups_list_page
354             {
355             my $self = shift;
356              
357             my $nntp = $self->_get_nntp();
358              
359             my $groups = $nntp->list();
360              
361             $nntp->quit();
362              
363             return $self->tt_process(
364             'groups_list_page.tt',
365             {
366             'groups' => [ sort { $a cmp $b } keys(%$groups) ],
367             'title' => "Groups' List",
368             }
369             );
370             }
371              
372             sub _get_group_display_article_data
373             {
374             my ($self, $nntp, $index) = @_;
375              
376             my $head = $nntp->head($index);
377             my $body = $nntp->body($index);
378             my $subject;
379             my $author;
380             my $date;
381             foreach my $line (@$head)
382             {
383             if ($line =~ m{^Subject: (.*)\n$})
384             {
385             $subject = $1;
386             }
387             elsif ($line =~ m{^From: (.*)\n$})
388             {
389             $author = $1;
390             }
391             elsif ($line =~ m{^Date: (.*)\n$})
392             {
393             $date = $1;
394             }
395             }
396             return
397             {
398             'idx' => $index,
399             'subject' => $subject,
400             'author' => $author,
401             'date' => $date,
402             'lines' => scalar(@$body),
403             };
404             }
405              
406             sub _group_display_page
407             {
408             my $self = shift;
409              
410             my $group = $self->param('group');
411              
412             my $nntp = $self->_get_nntp();
413              
414             my @info = $nntp->group($group);
415              
416             if (! @info)
417             {
418             $nntp->quit();
419             return "

Error! Unknown Group.

";
420             }
421              
422             my ($num_articles, $first_article, $last_article, $group_name) = @info;
423              
424             my $max_article = $self->query()->param('max') || $last_article;
425              
426             if ($max_article < $first_article)
427             {
428             $max_article = $first_article;
429             }
430             elsif ($max_article > $last_article)
431             {
432             $max_article = $last_article;
433             }
434              
435             my $min_article = $max_article - $self->param('articles_per_page') + 1;
436              
437             if ($min_article < $first_article)
438             {
439             $min_article = $first_article;
440             }
441              
442             # TODO
443             # Is it possible that article numbers won't be consecutive? How should
444             # we deal with it?
445             my @articles =
446             (map
447             { $self->_get_group_display_article_data($nntp, $_) }
448             ($min_article .. $max_article)
449             );
450             $nntp->quit();
451              
452             return $self->tt_process(
453             'group_display_page.tt',
454             {
455             'group' => $group,
456             'title' => "Articles for Group $group",
457             'articles' => [reverse(@articles)],
458             'nntp_server' => $self->param('nntp_server'),
459             'max_art' => $max_article,
460             'min_art' => $min_article,
461             'num_arts' => $num_articles,
462             'last_art' => $last_article,
463             'arts_per_page' => $self->param('articles_per_page'),
464             }
465             );
466             }
467              
468             sub _get_show_headers
469             {
470             my $self = shift;
471             return scalar($self->query()->param("show_headers"));
472             }
473              
474             sub _get_headers
475             {
476             my ($self, $head) = @_;
477             if ($self->_get_show_headers())
478             {
479             return $head;
480             }
481             else
482             {
483             return
484             [ grep /^(?:Newsgroups|Date|Subject|To|From|Message-ID): /, @$head]
485             ;
486             }
487             }
488              
489             sub _article_display_page
490             {
491             my $self = shift;
492              
493             my $group = $self->param('group');
494             my $article = $self->param('article');
495              
496             my $nntp = $self->_get_nntp();
497              
498             my @info = $nntp->group($group);
499              
500             if (! @info)
501             {
502             $nntp->quit();
503             return "

Error! Unknown Group.

";
504             }
505              
506             my ($num_articles, $first_article, $last_article, $group_name) = @info;
507              
508             # TODO : Error handling.
509             my $head = $nntp->head($article);
510             my $body = $nntp->body($article);
511              
512             my $article_text =
513             join("",
514             map
515             {
516             my $s = $_;
517             chomp($s);
518             my $s_esc = CGI::escapeHTML($s);
519             ($s =~ /^(Subject|From):/ ? "$s_esc" : $s_esc) . "\n";
520             }
521             @{$self->_get_headers($head)},
522             ) .
523             "
\n" .
524             join("",
525             map {
526             my $s = $_;
527             chomp($s);
528             CGI::escapeHTML($s). "\n";
529             }
530             @$body
531             );
532              
533             return
534             $self->tt_process(
535             'article_display_page.tt',
536             {
537             'group' => $group,
538             'article' => $article,
539             'title' => "$group ($article)",
540             'text' => $article_text,
541             'show_headers' => $self->_get_show_headers(),
542             'first_art' => $first_article,
543             'last_art' => $last_article,
544             'thread' => $self->_get_thread($nntp),
545             },
546             );
547             }
548              
549             sub _thread_render_node
550             {
551             my ($self, $node, $current) = @_;
552             my $subj = CGI::escapeHTML($node->{subject});
553             my $node_text =
554             ($node->{idx} == $current) ?
555             "$subj" :
556             qq|$subj|
557             ;
558              
559             return "
  • $node_text " .
  • 560             CGI::escapeHTML($node->{from}) .
    561             (exists($node->{subs}) ?
    562             ("
      " .
    563             join("",
    564             map
    565             {$self->_thread_render_node($_, $current) }
    566             @{$node->{subs}}
    567             ) .
    568             "") :
    569             ""
    570             ) .
    571             "";
    572             }
    573              
    574             # TODO :
    575             # 2. Make the current article non-linked and bold.
    576             # 3. Add the date (?).
    577             sub _get_thread
    578             {
    579             my ($self, $nntp) = @_;
    580             my $article = $self->param('article');
    581              
    582             my $cache = CGI::Application::NetNewsIface::Cache::DBI->new(
    583             {
    584             'nntp' => $nntp,
    585             'dsn' => $self->param('dsn'),
    586             },
    587             );
    588             $cache->select($self->param('group'));
    589              
    590             my ($thread, $coords) = $cache->get_thread($article);
    591              
    592             return "
      " . $self->_thread_render_node($thread, $article) . "
    ";
    593             }
    594              
    595             sub _css
    596             {
    597             my $self = shift;
    598             $self->header_props(-type => 'text/css');
    599             return <<"EOF";
    600             .articles th, .articles td
    601             {
    602             vertical-align:top;
    603             text-align: left;
    604             }
    605             .articles
    606             {
    607             border-collapse: collapse;
    608             }
    609             .articles td, .articles th
    610             {
    611             border: 1.5pt black solid;
    612             padding: 2pt;
    613             }
    614             EOF
    615             }
    616              
    617             =head2 $cgiapp->update_group($group)
    618              
    619             Updates the cache records for the NNTP group C<$group>. This method is used
    620             for maintenance, to make sure a script loads promptly.
    621              
    622             =cut
    623              
    624             sub update_group
    625             {
    626             my $self = shift;
    627             my $group = shift;
    628              
    629             my $cache = CGI::Application::NetNewsIface::Cache::DBI->new(
    630             {
    631             'nntp' => $self->_get_nntp(),
    632             'dsn' => $self->param('dsn'),
    633             },
    634             );
    635             $cache->select($group);
    636             }
    637              
    638             =head2 $cgiapp->init_cache__sqlite()
    639              
    640             Initializes the SQLite cache that is pointed by the DBI DSN given as
    641             a parameter to the CGI script. This should be called before any use of the
    642             CGI Application itself, because otherwise there will be no tables to operate
    643             on.
    644              
    645             =cut
    646              
    647             sub init_cache__sqlite
    648             {
    649             my $self = shift;
    650             return $self->_init_cache({'auto_inc' => "PRIMARY KEY AUTOINCREMENT"});
    651             }
    652              
    653             =head2 $cgiapp->init_cache__mysql()
    654              
    655             Initializes the MySQL cache that is pointed by the DBI DSN given as
    656             a parameter to the CGI script. This should be called before any use of the
    657             CGI Application itself, because otherwise there will be no tables to operate
    658             on.
    659              
    660             =cut
    661              
    662             sub init_cache__mysql
    663             {
    664             my $self = shift;
    665             return $self->_init_cache({'auto_inc' => "PRIMARY KEY NOT NULL AUTO_INCREMENT"});
    666             }
    667              
    668             sub _init_cache
    669             {
    670             my $self = shift;
    671             my $args = shift;
    672              
    673             my $auto_inc = $args->{'auto_inc'};
    674              
    675             require DBI;
    676              
    677             my $dbh = DBI->connect($self->param('dsn'), "", "");
    678             $dbh->do("CREATE TABLE groups (name varchar(255), idx INTEGER $auto_inc, last_art INTEGER)");
    679             $dbh->do("CREATE TABLE articles (group_idx INTEGER, article_idx INTEGER, msg_id varchar(255), parent INTEGER, subject varchar(255), frm varchar(255), date varchar(255))");
    680             $dbh->do("CREATE UNIQUE INDEX idx_groups_name ON groups (name)");
    681             $dbh->do("CREATE UNIQUE INDEX idx_articles_primary ON articles (group_idx, article_idx)");
    682             $dbh->do("CREATE INDEX idx_articles_msg_id ON articles (group_idx, msg_id)");
    683             $dbh->do("CREATE INDEX idx_articles_parent ON articles (group_idx, parent)");
    684             }
    685              
    686             1;
    687              
    688             =head1 AUTHOR
    689              
    690             Shlomi Fish, L .
    691              
    692             =head1 BUGS
    693              
    694             Please report any bugs or feature requests to
    695             C, or through the web interface at
    696             L.
    697             I will be notified, and then you'll automatically be notified of progress on
    698             your bug as I make changes.
    699              
    700             =head2 Known Bugs
    701              
    702             None, but it doesn't mean there aren't any bugs.
    703              
    704             =head1 ACKNOWLEDGEMENTS
    705              
    706             =head1 COPYRIGHT & LICENSE
    707              
    708             Copyright 2006 Shlomi Fish, all rights reserved.
    709              
    710             This program is released under the following license: MIT X11.
    711              
    712             =cut
    713              
    714             1; # End of CGI::Application::NetNewsIface