source: trunk/lib/OpenGuides/Utils.pm @ 1231

Last change on this file since 1231 was 1231, checked in by Dominic Hargreaves, 13 years ago

Correctly validate web site URLs during edit and display,
and truncate URLs that are too long (fixes #21)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.8 KB
Line 
1package OpenGuides::Utils;
2
3use strict;
4use vars qw( $VERSION );
5$VERSION = '0.11';
6
7use Carp qw( croak );
8use Wiki::Toolkit;
9use Wiki::Toolkit::Formatter::UseMod;
10use Wiki::Toolkit::Plugin::RSS::Reader;
11use URI::Escape;
12use MIME::Lite;
13use Data::Validate::URI qw( is_web_uri );
14
15=head1 NAME
16
17OpenGuides::Utils - General utility methods for OpenGuides scripts.
18
19=head1 DESCRIPTION
20
21Provides general utility methods for OpenGuides scripts.  Distributed
22and installed as part of the OpenGuides project, not intended for
23independent installation.  This documentation is probably only useful
24to OpenGuides developers.
25
26=head1 SYNOPSIS
27
28  use OpenGuide::Config;
29  use OpenGuides::Utils;
30
31  my $config = OpenGuides::Config->new( file => "wiki.conf" );
32  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
33
34=head1 METHODS
35
36=over 4
37
38=item B<make_wiki_object>
39
40  my $config = OpenGuides::Config->new( file => "wiki.conf" );
41  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
42
43Croaks unless an C<OpenGuides::Config> object is supplied.  Returns a
44C<Wiki::Toolkit> object made from the given config file on success,
45croaks if any other error occurs.
46
47The config file needs to define at least the following variables:
48
49=over
50
51=item *
52
53dbtype - one of C<postgres>, C<mysql> and C<sqlite>
54
55=item *
56
57dbname
58
59=item *
60
61indexing_directory - for the L<Search::InvertedIndex> or L<Plucene> files to go
62
63=back
64
65=cut
66
67sub make_wiki_object {
68    my ($class, %args) = @_;
69    my $config = $args{config} or croak "No config param supplied";
70    croak "config param isn't an OpenGuides::Config object"
71        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
72
73    # Require in the right database module.
74    my $dbtype = $config->dbtype;
75
76    my %wiki_toolkit_exts = (
77                          postgres => "Pg",
78                          mysql    => "MySQL",
79                          sqlite   => "SQLite",
80                        );
81
82    my $wiki_toolkit_module = "Wiki::Toolkit::Store::" . $wiki_toolkit_exts{$dbtype};
83    eval "require $wiki_toolkit_module";
84    croak "Can't 'require' $wiki_toolkit_module.\n" if $@;
85
86    # Make store.
87    my $store = $wiki_toolkit_module->new(
88        dbname  => $config->dbname,
89        dbuser  => $config->dbuser,
90        dbpass  => $config->dbpass,
91        dbhost  => $config->dbhost,
92        dbport  => $config->dbport,
93        charset => $config->dbencoding,
94    );
95
96    # Make search.
97    my $search;
98    if ( $config->use_plucene
99         && ( lc($config->use_plucene) eq "y"
100              || $config->use_plucene == 1 )
101       ) {
102        require Wiki::Toolkit::Search::Plucene;
103        $search = Wiki::Toolkit::Search::Plucene->new(
104                                       path => $config->indexing_directory,
105                                                 );
106    } else {
107        require Wiki::Toolkit::Search::SII;
108        require Search::InvertedIndex::DB::DB_File_SplitHash;
109        my $indexdb = Search::InvertedIndex::DB::DB_File_SplitHash->new(
110            -map_name  => $config->indexing_directory,
111            -lock_mode => "EX"
112        );
113        $search = Wiki::Toolkit::Search::SII->new( indexdb => $indexdb );
114    }
115
116    # Make formatter.
117    my $script_name = $config->script_name;
118    my $search_url = $config->script_url . "search.cgi";
119
120    my %macros = (
121        '@SEARCHBOX' =>
122            qq(<form action="$search_url" method="get"><input type="text" size="20" name="search"><input type="submit" name="Go" value="Search"></form>),
123        qr/\@INDEX_LINK\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\]/ =>
124            sub {
125                  # We may be being called by Wiki::Toolkit::Plugin::Diff,
126                  # which doesn't know it has to pass us $wiki - and
127                  # we don't use it anyway.
128                  if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
129                      shift; # just throw it away
130                  }
131                  my $link_title = $_[2] || "View all pages in $_[0] $_[1]";
132                  return qq(<a href="$script_name?action=index;index_type=) . uri_escape(lc($_[0])) . qq(;index_value=) . uri_escape($_[1]) . qq(">$link_title</a>);
133                },
134        qr/\@INDEX_LIST\s+\[\[(Category|Locale)\s+([^\]]+)]]/ =>
135             sub {
136                   my ($wiki, $type, $value) = @_;
137
138                   # We may be being called by Wiki::Toolkit::Plugin::Diff,
139                   # which doesn't know it has to pass us $wiki
140                   unless ( UNIVERSAL::isa( $wiki, "Wiki::Toolkit" ) ) {
141                       return "(unprocessed INDEX_LIST macro)";
142                   }
143
144                   my @nodes = sort $wiki->list_nodes_by_metadata(
145                       metadata_type  => $type,
146                       metadata_value => $value,
147                       ignore_case    => 1,
148                   );
149                   unless ( scalar @nodes ) {
150                       return "\n* No pages currently in "
151                              . lc($type) . " $value\n";
152                   }
153                   my $return = "\n";
154                   foreach my $node ( @nodes ) {
155                       $return .= "* "
156                               . $wiki->formatter->format_link(
157                                                                wiki => $wiki,
158                                                                link => $node,
159                                                              )
160                                . "\n";
161                   }
162                   return $return;
163                 },
164        qr/\@MAP_LINK\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\]/ =>
165                sub {
166                      if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
167                          shift; # don't need $wiki
168                      }
169                      my $link_title = $_[2]
170                                       || "View map of pages in $_[0] $_[1]";
171                      return qq(<a href="$script_name?action=index;format=map;index_type=) . uri_escape(lc($_[0])) . qq(;index_value=) . uri_escape($_[1]) . qq(">$link_title</a>);
172                },
173        qr/\@RANDOM_PAGE_LINK(?:\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\])?/ =>
174                sub {
175                      if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
176                          shift; # don't need $wiki
177                      }
178                      my ( $type, $value, $link_title ) = @_;
179                      my $link = "$script_name?action=random";
180
181                      if ( $type && $value ) {
182                          $link .= ";" . lc( uri_escape( $type ) ) . "="
183                                . lc( uri_escape( $value ) );
184                          $link_title ||= "View a random page in $type $value";
185                      } else {
186                          $link_title ||= "View a random page on this guide";
187                      }
188                      return qq(<a href="$link">$link_title</a>);
189                },
190        qr/\@INCLUDE_NODE\s+\[\[([^\]|]+)\]\]/ => 
191            sub {
192                  my ($wiki, $node) = @_;
193                  my %node_data = $wiki->retrieve_node( $node );
194                  return $node_data{content};
195                },
196        qr/\@RSS\s+(.+)/ => sub {
197                    # We may be being called by Wiki::Toolkit::Plugin::Diff,
198                    # which doesn't know it has to pass us $wiki - and
199                    # we don't use it anyway.
200                    if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
201                        shift; # just throw it away
202                    }
203
204                    my $url = shift;
205
206                    # The URL will already have been processed as an inline
207                    # link, so transform it back again.
208                    if ( $url =~ m/href="([^"]+)/ ) {
209                        $url = $1;
210                    }
211
212                    my $rss = Wiki::Toolkit::Plugin::RSS::Reader->new(url => $url);
213                    my @items = $rss->retrieve;
214
215                    # Ten items only at this till.
216                    $#items = 10 if $#items > 10;
217
218                    # Make a UseMod-formatted list with them - macros are
219                    # processed *before* UseMod formatting is applied but
220                    # *after* inline links like [http://foo/ bar]
221                    my $list = "\n";
222                    foreach (@items) {
223                        my $link        = $_->{link};
224                        my $title       = $_->{title};
225                        my $description = $_->{description};
226                        $list .= qq{* <a href="$link">$title</a>};
227                        $list .= " - $description" if $description;
228                        $list .= "\n";
229                    }
230                    $list .= "</ul>\n";
231        },
232    );
233
234    my $formatter = Wiki::Toolkit::Formatter::UseMod->new(
235        extended_links      => 1,
236        implicit_links      => 0,
237        allowed_tags        => [qw(a p b strong i em pre small img table td
238                                   tr th br hr ul li center blockquote kbd
239                                   div code strike sub sup font)],
240        macros              => \%macros,
241        pass_wiki_to_macros => 1,
242        node_prefix         => "$script_name?",
243        edit_prefix         => "$script_name?action=edit;id=",
244        munge_urls          => 1,
245    );
246
247    my %conf = ( store     => $store,
248                 search    => $search,
249                 formatter => $formatter );
250
251    my $wiki = Wiki::Toolkit->new( %conf );
252    return $wiki;
253}
254
255=item B<get_wgs84_coords>
256
257Returns coordinate data suitable for use with Google Maps (and other GIS
258systems that assume WGS-84 data).
259
260    my ($wgs84_long, $wgs84_lat) = OpenGuides::Utils->get_wgs84_coords(
261                                        longitude => $longitude,
262                                        latitude => $latitude,
263                                        config => $config
264                                   );
265
266=cut
267
268sub get_wgs84_coords {
269    my ($self, %args) = @_;
270    my ($longitude, $latitude, $config) = ($args{longitude}, $args{latitude},
271                                           $args{config})
272       or croak "No longitude supplied to get_wgs84_coords";
273    croak "geo_handler not defined!" unless $config->geo_handler;
274
275    if ($config->force_wgs84) {
276        # Only as a rough approximation, good enough for large scale guides
277        return ($longitude, $latitude);
278    }
279
280    # If we don't have a lat and long, return undef right away
281    unless($args{longitude} || $args{latitude}) {
282        return undef;
283    }
284
285    # Try to load a provider of Helmert Transforms
286    my $helmert;
287    # First up, try the MySociety Geo::HelmertTransform
288    unless($helmert) {
289        eval {
290            require Geo::HelmertTransform;
291            $helmert = sub($$$) {
292                my ($datum,$oldlat,$oldlong) = @_;
293                if ($datum eq 'Airy') {
294                    $datum = 'Airy1830';
295                }
296                my $datum_helper = new Geo::HelmertTransform::Datum(Name=>$datum);
297                my $wgs84_helper = new Geo::HelmertTransform::Datum(Name=>'WGS84');
298                unless($datum_helper) {
299                    croak("No convertion helper for datum '$datum'");
300                    return undef;
301                }
302
303                my ($lat,$long,$h) = 
304                    Geo::HelmertTransform::convert_datum($datum_helper,$wgs84_helper,$oldlat,$oldlong,0);
305                return ($long,$lat);
306            };
307        };
308    }
309    # Give up, return undef
310    unless($helmert) {
311       return undef; 
312    }
313   
314
315    if ($config->geo_handler == 1) {
316        # Do conversion here
317        return &$helmert('Airy1830',$latitude,$longitude);
318    } elsif ($config->geo_handler == 2) {
319        # Do conversion here
320        return &$helmert('Airy1830Modified',$latitude,$longitude);
321    } elsif ($config->geo_handler == 3) {
322        if ($config->ellipsoid eq "WGS-84") {
323            return ($longitude, $latitude);
324        } else {
325            # Do conversion here
326            return &$helmert($config->ellipsoid,$latitude,$longitude);
327        }
328    } else {
329        croak "Invalid geo_handler config option $config->geo_handler";
330    }
331}
332
333=item B<detect_redirect>
334
335    $redir = OpenGuides::Utils->detect_redirect( content => "foo" );
336
337Checks the content of a node to see if the node is a redirect to another
338node.  If so, returns the name of the node that this one redirects to.  If
339not, returns false.
340
341(Also returns false if no content is provided.)
342
343=cut
344
345sub detect_redirect {
346    my ( $self, %args ) = @_;
347    return unless $args{content};
348
349    if ( $args{content} =~ /^#REDIRECT\s+(.+?)\s*$/ ) {
350        my $redirect = $1;
351
352        # Strip off enclosing [[ ]] in case this is an extended link.
353        $redirect =~ s/^\[\[//;
354        $redirect =~ s/\]\]\s*$//;
355
356        return $redirect;
357    }
358}
359
360=item B<validate_edit>
361
362    my $fails = OpenGuides::Utils->validate_edit(
363        id       => $node,
364        cgi_obj  => $q
365    );
366
367Checks supplied content for general validity. If anything is invalid,
368returns an array ref of errors to report to the user.
369
370=cut
371
372sub validate_edit {
373    my ( $self, %args ) = @_;
374    my $q = $args{cgi_obj};
375    my @fails;
376    push @fails, "Content missing" unless $q;
377    return \@fails if @fails;
378
379    # Now do our real validation
380    foreach my $var (qw(os_x os_y)) {
381        if ($q->param($var) and $q->param($var) !~ /^-?\d+$/) {
382            push @fails, "$var must be integer, was: " . $q->param($var);
383        }
384    }
385
386    foreach my $var (qw(latitude longitude)) {
387        if ($q->param($var) and $q->param($var) !~ /^-?\d+\.?(\d+)?$/) {
388            push @fails, "$var must be numeric, was: " . $q->param($var);
389        }
390    }
391
392    if ( $q->param('website') and $q->param('website') ne 'http://' ) {
393        unless ( is_web_uri( $q->param('website') ) ) {
394            push @fails, $q->param('website') . ' is not a valid web URI';
395        }
396    }
397
398    return \@fails;
399
400};
401
402=item B<parse_change_comment>
403
404    my $change_comment = parse_change_comment($string, $base_url);
405   
406Given a base URL (for example, C<http://example.com/wiki.cgi?>), takes a string,
407replaces C<[[page]]> and C<[[page|titled link]]> with
408
409    <a href="http://example.com/wiki.cgi?page">page</a>
410
411and
412
413    <a href="http://example.com/wiki.cgi?page">titled link</a>
414
415respectively, and returns it. This is a limited subset of wiki markup suitable for
416use in page change comments.
417
418=cut
419
420sub parse_change_comment {   
421    my ($comment, $base_url) = @_;
422
423    my @links = $comment =~ m{\[\[(.*?)\]\]}g;
424
425    # It's not all that great having to reinvent the wheel in this way, but
426    # Text::WikiFormat won't let you specify the subset of wiki notation that
427    # you're interested in. C'est la vie.
428    foreach (@links) {
429        if (/(.*?)\|(.*)/) {
430            my ($page, $title) = ($1, $2);
431            $comment =~ s{\[\[$page\|$title\]\]}
432                         {<a href="$base_url$page">$title</a>};
433        } else {
434            my $page = $_;
435            $comment =~ s{\[\[$page\]\]}
436                         {<a href="$base_url$page">$page</a>};
437        }
438    }
439
440    return $comment;
441}
442
443=item B<send_email>
444
445    eval { OpenGuides::Utils->send_email(
446            config        => $config,
447            subject       => "Subject",
448            body          => "Test body",
449            admin         => 1,
450            nobcc         => 1,
451            return_output => 1
452    ) };
453
454    if ($@) {
455        print "Error mailing admin: $@\n";
456    } else {
457        print "Mailed admin\n";
458    }
459
460Send out email. If C<admin> is true, the email will be sent to the site
461admin. If C<to> is defined, email will be sent to addresses in that
462arrayref. If C<nobcc> is true, there will be no Bcc to the admin.
463
464C<subject> and C<body> are mandatory arguments.
465
466Debugging: if C<return_output> is true, the message will be returned as
467a string instead of being sent by email.
468
469=cut
470
471
472sub send_email {
473    my ( $self, %args ) = @_;
474    my $config = $args{config} or die "config argument not supplied";
475    my @to;
476    @to = @{$args{to}} if $args{to};
477    my @bcc;
478    push @to, $config->contact_email if $args{admin};
479    die "No recipients specified" unless $to[0];
480    die "No subject specified" unless $args{subject};
481    die "No body specified" unless $args{body};
482    my $to_str = join ',', @to;
483    push @bcc, $config->contact_email unless $args{nobcc};
484    my $bcc_str = join ',', @bcc;
485    my $msg = MIME::Lite->new(
486        From    => $config->contact_email,
487        To      => $to_str,
488        Bcc     => $bcc_str,
489        Subject => $args{subject},
490        Data    => $args{body}
491    );
492
493    if ( $args{return_output} ) {
494        return $msg->as_string;
495    } else {
496        $msg->send or die "Couldn't send mail!";
497    }
498}
499
500=back
501
502=head1 AUTHOR
503
504The OpenGuides Project (openguides-dev@lists.openguides.org)
505
506=head1 COPYRIGHT
507
508     Copyright (C) 2003-2008 The OpenGuides Project.  All Rights Reserved.
509
510This module is free software; you can redistribute it and/or modify it
511under the same terms as Perl itself.
512
513=cut
514
5151;
Note: See TracBrowser for help on using the repository browser.