source: trunk/lib/OpenGuides.pm @ 375

Last change on this file since 375 was 375, checked in by kake, 18 years ago

Minor bugfixes.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.3 KB
Line 
1package OpenGuides;
2use strict;
3
4use Carp "croak";
5use CGI;
6use CGI::Wiki::Plugin::Diff;
7use CGI::Wiki::Plugin::Locator::UK;
8use OpenGuides::Template;
9use OpenGuides::Utils;
10
11use vars qw( $VERSION );
12
13$VERSION = '0.33_02';
14
15=head1 NAME
16
17OpenGuides - A complete web application for managing a collaboratively-written guide to a city or town.
18
19=head1 DESCRIPTION
20
21The OpenGuides software provides the framework for a collaboratively-written
22city guide.  It is similar to a wiki but provides somewhat more structured
23data storage allowing you to annotate wiki pages with information such as
24category, location, and much more.  It provides searching facilities
25including "find me everything within a certain distance of this place".
26Every page includes a link to a machine-readable (RDF) version of the page.
27
28=head1 METHODS
29
30=over
31
32=item B<new>
33
34  my $guide = OpenGuides->new( config => $config );
35
36=cut
37
38sub new {
39    my ($class, %args) = @_;
40    my $self = {};
41    bless $self, $class;
42    my $wiki = OpenGuides::Utils->make_wiki_object( config => $args{config} );
43    $self->{wiki} = $wiki;
44    $self->{config} = $args{config};
45    my $locator = CGI::Wiki::Plugin::Locator::UK->new;
46    $wiki->register_plugin( plugin => $locator );
47    $self->{locator} = $locator;
48    my $differ = CGI::Wiki::Plugin::Diff->new;
49    $wiki->register_plugin( plugin => $differ );
50    $self->{differ} = $differ;
51    return $self;
52}
53
54=item B<wiki>
55
56An accessor, returns the underlying L<CGI::Wiki> object.
57
58=cut
59
60sub wiki {
61    my $self = shift;
62    return $self->{wiki};
63}
64
65=item B<config>
66
67An accessor, returns the underlying L<Config::Tiny> object.
68
69=cut
70
71sub config {
72    my $self = shift;
73    return $self->{config};
74}
75
76=item B<locator>
77
78An accessor, returns the underlying L<CGI::Wiki::Plugin::Locator::UK> object.
79
80=cut
81
82sub locator {
83    my $self = shift;
84    return $self->{locator};
85}
86
87=item B<differ>
88
89An accessor, returns the underlying L<CGI::Wiki::Plugin::Diff> object.
90
91=cut
92
93sub differ {
94    my $self = shift;
95    return $self->{differ};
96}
97
98=item B<display_node>
99
100  # Print node to STDOUT.
101  $guide->display_node(
102                        id      => "Calthorpe Arms",
103                        version => 2,
104                      );
105
106  # Or return output as a string (useful for writing tests).
107  $guide->display_node(
108                        id            => "Calthorpe Arms",
109                        return_output => 1,
110                      );
111
112If C<version> is omitted then the latest version will be displayed.
113
114=cut
115
116sub display_node {
117    my ($self, %args) = @_;
118    my $return_output = $args{return_output} || 0;
119    my $version = $args{version};
120    my $id = $args{id} || "Home";
121    my $wiki = $self->wiki;
122    my $config = $self->config;
123
124    my %tt_vars;
125
126    if ( $id =~ /^(Category|Locale) (.*)$/ ) {
127        my $type = $1;
128        $tt_vars{is_indexable_node} = 1;
129        $tt_vars{index_type} = lc($type);
130        $tt_vars{index_value} = $2;
131    }
132
133    my %current_data = $wiki->retrieve_node( $id );
134    my $current_version = $current_data{version};
135    undef $version if ($version && $version == $current_version);
136    my %criteria = ( name => $id );
137    $criteria{version} = $version if $version;#retrieve_node default is current
138
139    my %node_data = $wiki->retrieve_node( %criteria );
140    my $raw = $node_data{content};
141    if ( $raw =~ /^#REDIRECT\s+(.+?)\s*$/ ) {
142        my $redirect = $1;
143        # Strip off enclosing [[ ]] in case this is an extended link.
144        $redirect =~ s/^\[\[//;
145        $redirect =~ s/\]\]\s*$//;
146        # See if this is a valid node, if not then just show the page as-is.
147        if ( $wiki->node_exists($redirect) ) {
148            redirect_to_node($redirect);
149        }
150    }
151    my $content    = $wiki->format($raw);
152    my $modified   = $node_data{last_modified};
153    my %metadata   = %{$node_data{metadata}};
154
155    my %metadata_vars = OpenGuides::Template->extract_metadata_vars(
156                            wiki     => $wiki,
157                            config   => $config,
158                            metadata => $node_data{metadata} );
159
160    %tt_vars = (
161                 %tt_vars,
162                 %metadata_vars,
163                 content       => $content,
164                 geocache_link => $self->make_geocache_link($id),
165                 last_modified => $modified,
166                 version       => $node_data{version},
167                 node_name     => CGI->escapeHTML($id),
168                 node_param    => CGI->escape($id),
169                 language      => $config->{_}->{default_language},
170               );
171
172
173    # We've undef'ed $version above if this is the current version.
174    $tt_vars{current} = 1 unless $version;
175
176    if ($id eq "RecentChanges") {
177        my $minor_edits = $self->get_cookie( "show_minor_edits_in_rc" );
178        my %criteria = ( days => 7 );
179        $criteria{metadata_was} = { edit_type => "Normal edit" }
180          unless $minor_edits;
181        my @recent = $wiki->list_recent_changes( %criteria );
182        @recent = map { {name          => CGI->escapeHTML($_->{name}),
183                         last_modified => CGI->escapeHTML($_->{last_modified}),
184                         comment       => CGI->escapeHTML($_->{metadata}{comment}[0]),
185                         username      => CGI->escapeHTML($_->{metadata}{username}[0]),
186                         host          => CGI->escapeHTML($_->{metadata}{host}[0]),
187                         username_param => CGI->escape($_->{metadata}{username}[0]),
188                         edit_type     => CGI->escapeHTML($_->{metadata}{edit_type}[0]),
189                         url           => "$config->{_}->{script_name}?"
190          . CGI->escape($wiki->formatter->node_name_to_node_param($_->{name})) }
191                       } @recent;
192        $tt_vars{recent_changes} = \@recent;
193        $tt_vars{days} = 7;
194        my $output = $self->process_template(
195                                          id            => $id,
196                                          template      => "recent_changes.tt",
197                                          tt_vars       => \%tt_vars,
198                                            );
199        return $output if $return_output;
200        print $output;
201    } elsif ($id eq "Home") {
202        my @recent = $wiki->list_recent_changes(
203            last_n_changes => 10,
204            metadata_was   => { edit_type => "Normal edit" },
205        );
206        @recent = map { {name          => CGI->escapeHTML($_->{name}),
207                         last_modified => CGI->escapeHTML($_->{last_modified}),
208                         comment       => CGI->escapeHTML($_->{metadata}{comment}[0]),
209                         username      => CGI->escapeHTML($_->{metadata}{username}[0]),
210                         url           => "$config->{_}->{script_name}?"
211          . CGI->escape($wiki->formatter->node_name_to_node_param($_->{name})) }
212                       } @recent;
213        $tt_vars{recent_changes} = \@recent;
214        my $output = $self->process_template(
215                                              id            => $id,
216                                              template      => "home_node.tt",
217                                              tt_vars       => \%tt_vars,
218                                            );
219        return $output if $return_output;
220        print $output;
221    } else {
222        my $output = $self->process_template(
223                                              id            => $id,
224                                              template      => "node.tt",
225                                              tt_vars       => \%tt_vars,
226                                            );
227        return $output if $return_output;
228        print $output;
229    }
230}
231
232=item B<display_diffs>
233
234  $guide->display_diffs(
235                         id            => "Home Page",
236                         version       => 6,
237                         other_version => 5,
238                       );
239
240=cut
241
242sub display_diffs {
243    my ($self, %args) = @_;
244    my %diff_vars = $self->differ->differences(
245                                        node          => $args{id},
246                                        left_version  => $args{version},
247                                        right_version => $args{other_version},
248                                              );
249    print $self->process_template(
250                                   id       => $args{id},
251                                   template => "differences.tt",
252                                   vars     => \%diff_vars
253                                 );
254}
255
256=item B<find_within_distance>
257
258  $guide->find_within_distance(
259                                id => $node,
260                                metres => $q->param("distance_in_metres")
261                              );
262
263=cut
264
265sub find_within_distance {
266    my ($self, %args) = @_;
267    my $node = $args{node};
268    my $metres = $args{metres};
269    my $formatter = $self->wiki->formatter;
270
271    my @finds = $self->locator->find_within_distance(
272                                                      node   => $node,
273                                                      metres => $metres,
274                                                    );
275    my @nodes;
276    foreach my $find ( @finds ) {
277        my $distance = $self->locator->distance(
278                                                 from_node => $node,
279                                                 to_node   => $find,
280                                                 unit      => "metres"
281                                               );
282        push @nodes, {
283                       name     => $find,
284                       param    => $formatter->node_name_to_node_param($find),
285                       distance => $distance,
286                     };
287    }
288    @nodes = sort { $a->{distance} <=> $b->{distance} } @nodes;
289
290    my %tt_vars = (
291                    nodes        => \@nodes,
292                    origin       => $node,
293                    origin_param => $formatter->node_name_to_node_param($node),
294                    limit        => "$metres metres",
295                  );
296
297    print $self->process_template(
298                                   id       => "index", # KLUDGE
299                                   template => "site_index.tt",
300                                   vars     => \%tt_vars,
301                                 );
302}
303
304=item B<show_index>
305
306  $guide->show_index(
307                      type   => "category",
308                      value  => "pubs",
309                    );
310
311  # RDF version.
312  $guide->show_index(
313                      type   => "locale",
314                      value  => "Holborn",
315                      format => "rdf",
316                    );
317
318=cut
319
320sub show_index {
321    my ($self, %args) = @_;
322    my $wiki = $self->wiki;
323    my $formatter = $wiki->formatter;
324    my %tt_vars;
325    my @selnodes;
326
327    if ( $args{type} and $args{value} ) {
328        if ( $args{type} eq "fuzzy_title_match" ) {
329            my %finds = $wiki->fuzzy_title_match( $args{value} );
330            @selnodes = sort { $finds{$a} <=> $finds{$b} } keys %finds;
331            $tt_vars{criterion} = {
332                type  => $args{type},  # for RDF version
333                value => $args{value}, # for RDF version
334                name  => CGI->escapeHTML("Fuzzy Title Match on '$args{value}'")
335            };
336        } else {
337            @selnodes = $wiki->list_nodes_by_metadata(
338                metadata_type  => $args{type},
339                metadata_value => $args{value},
340                ignore_case    => 1,
341            );
342            my $name = ucfirst($args{type}) . " $args{value}" ;
343            my $url = $self->config->{_}->{script_name}
344                      . ucfirst( $args{type} )
345                      . "_"
346                      . uri_escape(
347                              $formatter->node_name_to_node_param($args{value})
348                                  );
349            $tt_vars{criterion} = {
350                type  => $args{type},
351                value => $args{value}, # for RDF version
352                name  => CGI->escapeHTML( $name ),
353                url   => $url,
354            };
355        }
356    } else {
357        @selnodes = $wiki->list_all_nodes();
358    }
359
360    my @nodes = map { { name      => $_,
361                        node_data => { $wiki->retrieve_node( name => $_ ) },
362                        param     => $formatter->node_name_to_node_param($_) }
363                    } sort @selnodes;
364
365    $tt_vars{nodes} = \@nodes;
366
367    my ($template, %conf);
368
369    if ( $args{format} eq "rdf" ) {
370        $template = "rdf_index.tt";
371        $conf{content_type} = "text/plain";
372    } else {
373        $template = "site_index.tt";
374    }
375
376    %conf = (
377              %conf,
378              node        => "$args{type} index", # KLUDGE
379              template    => $template,
380              tt_vars     => \%tt_vars,
381    );
382
383    print $self->process_template( %conf );
384}
385
386=item B<list_all_versions>
387
388  $guide->list_all_versions ( id => "Home Page" );
389
390=cut
391
392sub list_all_versions {
393    my ($self, %args) = @_;
394    my $node = $args{id};
395    my %curr_data = $self->wiki->retrieve_node($node);
396    my $curr_version = $curr_data{version};
397    croak "This is the first version" unless $curr_version > 1;
398    my @history;
399    for my $version ( 1 .. $curr_version ) {
400        my %node_data = $self->wiki->retrieve_node( name    => $node,
401                                                    version => $version );
402        push @history, { version  => $version,
403                         modified => $node_data{last_modified},
404                         username => $node_data{metadata}{username}[0],
405                         comment  => $node_data{metadata}{comment}[0]   };
406    }
407    @history = reverse @history;
408    my %tt_vars = ( node    => $node,
409                    version => $curr_version,
410                    history => \@history );
411    print $self->process_template(
412                                   id       => $node,
413                                   template => "node_history.tt",
414                                   tt_vars  => \%tt_vars,
415                                 );
416}
417
418sub process_template {
419    my ($self, %args) = @_;
420    my %output_conf = ( wiki     => $self->wiki,
421                        config   => $self->config,
422                        node     => $args{id},
423                        template => $args{template},
424                        vars     => $args{tt_vars},
425    );
426    $output_conf{content_type} = $args{content_type} if $args{content_type};
427    return OpenGuides::Template->output( %output_conf );
428}
429
430sub get_cookie {
431    my $self = shift;
432    my $config = $self->config;
433    my $pref_name = shift or return "";
434    my %cookie_data = OpenGuides::CGI->get_prefs_from_cookie(config=>$config);
435    return $cookie_data{$pref_name};
436}
437
438sub make_geocache_link {
439    my $self = shift;
440    my $wiki = $self->wiki;
441    my $config = $self->config;
442    return "" unless $self->get_cookie( "include_geocache_link" );
443    my $node = shift || $config->{_}->{home_name};
444    my %current_data = $wiki->retrieve_node( $node );
445    my %criteria     = ( name => $node );
446    my %node_data    = $wiki->retrieve_node( %criteria );
447    my %metadata     = %{$node_data{metadata}};
448    my $latitude     = $metadata{latitude}[0];
449    my $longitude    = $metadata{longitude}[0];
450    my $geocache     = CGI::Wiki::Plugin::GeoCache->new();
451    my $link_text    = "Look for nearby geocaches";
452
453    if ($latitude && $longitude) {
454        my $cache_url    = $geocache->make_link(
455                                        latitude  => $latitude,
456                                        longitude => $longitude,
457                                        link_text => $link_text
458                                );
459        return $cache_url;
460    }
461    else {
462        return "";
463    }
464}
465
466=back
467
468=head1 BUGS AND CAVEATS
469
470At the moment, the location data uses a United-Kingdom-specific module,
471so the location features might not work so well outside the UK.
472
473=head1 SEE ALSO
474
475=over 4
476
477=item * L<http://london.openguides.org/|The Open Guide to London>, the first and biggest OpenGuides site.
478
479=item * L<http://openguides.org/|The OpenGuides website>, with a list of all live OpenGuides installs.
480
481=item * L<CGI::Wiki>, the Wiki toolkit which does the heavy lifting for OpenGuides
482
483=back
484
485=head1 FEEDBACK
486
487If you have a question, a bug report, or a patch, or you're interested
488in joining the development team, please contact openguides-dev@openguides.org
489(moderated mailing list, will reach all current developers but you'll have
490to wait for your post to be approved) or kake@earth.li (a real person who
491may take a little while to reply to your mail if she's busy).
492
493=head1 AUTHOR
494
495The OpenGuides Project (openguides-dev@openguides.org)
496
497=head1 COPYRIGHT
498
499     Copyright (C) 2003-4 The OpenGuides Project.  All Rights Reserved.
500
501The OpenGuides distribution is free software; you can redistribute it
502and/or modify it under the same terms as Perl itself.
503
504=head1 CREDITS
505
506Programming by Earle Martin, Kake Pugh, Ivor Williams.  Testing and
507bug reporting by Cal Henderson, Bob Walker, Kerry Bosworth, Dominic
508Hargreaves, Simon Cozens, among others.  Much of the Module::Build
509stuff copied from the Siesta project L<http://siesta.unixbeard.net/>
510
511=cut
512
5131;
Note: See TracBrowser for help on using the repository browser.