source: trunk/lib/OpenGuides/Utils.pm

Last change on this file was 1441, checked in by bob, 9 years ago

merge of release changes for 0.70

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 20.8 KB
Line 
1package OpenGuides::Utils;
2
3use strict;
4use vars qw( $VERSION );
5$VERSION = '0.15';
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 Net::Netmask;
14use List::Util qw( first );
15use Data::Validate::URI qw( is_web_uri );
16
17=head1 NAME
18
19OpenGuides::Utils - General utility methods for OpenGuides scripts.
20
21=head1 DESCRIPTION
22
23Provides general utility methods for OpenGuides scripts.  Distributed
24and installed as part of the OpenGuides project, not intended for
25independent installation.  This documentation is probably only useful
26to OpenGuides developers.
27
28=head1 SYNOPSIS
29
30  use OpenGuide::Config;
31  use OpenGuides::Utils;
32
33  my $config = OpenGuides::Config->new( file => "wiki.conf" );
34  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
35
36=head1 METHODS
37
38=over 4
39
40=item B<make_wiki_object>
41
42  my $config = OpenGuides::Config->new( file => "wiki.conf" );
43  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
44
45Croaks unless an C<OpenGuides::Config> object is supplied.  Returns a
46C<Wiki::Toolkit> object made from the given config file on success,
47croaks if any other error occurs.
48
49The config file needs to define at least the following variables:
50
51=over
52
53=item *
54
55dbtype - one of C<postgres>, C<mysql> and C<sqlite>
56
57=item *
58
59dbname
60
61=item *
62
63indexing_directory - for the L<Search::InvertedIndex> or L<Plucene> files to go
64
65=back
66
67=cut
68
69sub make_wiki_object {
70    my ($class, %args) = @_;
71    my $config = $args{config} or croak "No config param supplied";
72    croak "config param isn't an OpenGuides::Config object"
73        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
74
75    # Require in the right database module.
76    my $dbtype = $config->dbtype;
77
78    my %wiki_toolkit_exts = (
79                          postgres => "Pg",
80                          mysql    => "MySQL",
81                          sqlite   => "SQLite",
82                        );
83
84    my $wiki_toolkit_module = "Wiki::Toolkit::Store::" . $wiki_toolkit_exts{$dbtype};
85    eval "require $wiki_toolkit_module";
86    croak "Can't 'require' $wiki_toolkit_module.\n" if $@;
87
88    # Make store.
89    my $store = $wiki_toolkit_module->new(
90        dbname  => $config->dbname,
91        dbuser  => $config->dbuser,
92        dbpass  => $config->dbpass,
93        dbhost  => $config->dbhost,
94        dbport  => $config->dbport,
95        charset => $config->dbencoding,
96    );
97
98    # Make search.
99    my $search;
100    if ( $config->use_plucene
101         && ( lc($config->use_plucene) eq "y"
102              || $config->use_plucene == 1 )
103       ) {
104        require Wiki::Toolkit::Search::Plucene;
105        $search = Wiki::Toolkit::Search::Plucene->new(
106                                       path => $config->indexing_directory,
107                                                 );
108    } else {
109        require Wiki::Toolkit::Search::SII;
110        require Search::InvertedIndex::DB::DB_File_SplitHash;
111        my $indexdb = Search::InvertedIndex::DB::DB_File_SplitHash->new(
112            -map_name  => $config->indexing_directory,
113            -lock_mode => "EX"
114        );
115        $search = Wiki::Toolkit::Search::SII->new( indexdb => $indexdb );
116    }
117
118    # Make formatter.
119    my $script_name = $config->script_name;
120    my $search_url = $config->script_url . "search.cgi";
121
122    my %macros = (
123        '@SEARCHBOX' =>
124            qq(<form action="$search_url" method="get"><input type="text" size="20" name="search"><input type="submit" name="Go" value="Search"></form>),
125        qr/\@INDEX_LINK\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\]/ =>
126            sub {
127                  # We may be being called by Wiki::Toolkit::Plugin::Diff,
128                  # which doesn't know it has to pass us $wiki - and
129                  # we don't use it anyway.
130                  if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
131                      shift; # just throw it away
132                  }
133                  my $type = ( lc( $_[0] ) eq "category" ) ? "cat" : "loc";
134                  my $link_title = $_[2] || "View all pages in $_[0] $_[1]";
135                  return qq(<a href="$script_name?action=index;$type=) . uri_escape( lc( $_[1] ) ) . qq(">$link_title</a>);
136                },
137        qr/\@INDEX_LIST\s+\[\[(Category|Locale)\s+([^\]]+)]]/ =>
138             sub {
139                   my ($wiki, $type, $value) = @_;
140                   return $class->do_index_list_macro(
141                       wiki => $wiki, type => $type, value => $value,
142                       include_prefix => 1 );
143                 },
144        qr/\@INDEX_LIST_NO_PREFIX\s+\[\[(Category|Locale)\s+([^\]]+)]]/ =>
145             sub {
146                   my ($wiki, $type, $value) = @_;
147                   return $class->do_index_list_macro(
148                       wiki => $wiki, type => $type, value => $value );
149                 },
150        qr/\@MAP_LINK\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\]/ =>
151                sub {
152                      if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
153                          shift; # don't need $wiki
154                      }
155
156                      my $type = ( lc( $_[0] ) eq "category" ) ? "cat" : "loc";
157                      my $link_title = $_[2]
158                                       || "View map of pages in $_[0] $_[1]";
159                      return qq(<a href="$script_name?action=index;format=map;$type=) . uri_escape( lc( $_[1] ) ) . qq(">$link_title</a>);
160                },
161        qr/\@RANDOM_PAGE_LINK(?:\s+\[\[(Category|Locale)\s+([^\]|]+)\|?([^\]]+)?\]\])?/ =>
162                sub {
163                      if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
164                          shift; # don't need $wiki
165                      }
166                      my ( $type, $value, $link_title ) = @_;
167                      my $link = "$script_name?action=random";
168
169                      if ( $type && $value ) {
170                          $link .= ";" . lc( uri_escape( $type ) ) . "="
171                                . lc( uri_escape( $value ) );
172                          $link_title ||= "View a random page in $type $value";
173                      } else {
174                          $link_title ||= "View a random page on this guide";
175                      }
176                      return qq(<a href="$link">$link_title</a>);
177                },
178        qr/\@INCLUDE_NODE\s+\[\[([^\]|]+)\]\]/ => 
179            sub {
180                  my ($wiki, $node) = @_;
181                  my %node_data = $wiki->retrieve_node( $node );
182                  return $node_data{content};
183                },
184        qr/\@RSS\s+(.+)/ => sub {
185                    # We may be being called by Wiki::Toolkit::Plugin::Diff,
186                    # which doesn't know it has to pass us $wiki - and
187                    # we don't use it anyway.
188                    if ( UNIVERSAL::isa( $_[0], "Wiki::Toolkit" ) ) {
189                        shift; # just throw it away
190                    }
191
192                    my $url = shift;
193
194                    # The URL will already have been processed as an inline
195                    # link, so transform it back again.
196                    if ( $url =~ m/href="([^"]+)/ ) {
197                        $url = $1;
198                    }
199
200                    # We can't do much about remote errors fetching
201                    # at this stage
202                    my $rss = eval { Wiki::Toolkit::Plugin::RSS::Reader->new(url => $url); };
203                    if ( $@ ) {
204                        warn $@;
205                        return '';
206                    }
207                    my @items = $rss->retrieve;
208
209                    # Ten items only at this till.
210                    $#items = 10 if $#items > 10;
211
212                    # Make a UseMod-formatted list with them - macros are
213                    # processed *before* UseMod formatting is applied but
214                    # *after* inline links like [http://foo/ bar]
215                    my $list = "\n";
216                    foreach (@items) {
217                        my $link        = $_->{link};
218                        my $title       = $_->{title};
219                        my $description = $_->{description};
220                        $list .= qq{* <a href="$link">$title</a>};
221                        $list .= " - $description" if $description;
222                        $list .= "\n";
223                    }
224                    $list .= "</ul>\n";
225        },
226    );
227
228    my $formatter = Wiki::Toolkit::Formatter::UseMod->new(
229        extended_links      => 1,
230        implicit_links      => 0,
231        allowed_tags        => [qw(a p b strong i em pre small img table td
232                                   tr th br hr ul li center blockquote kbd
233                                   div code span strike sub sup font dl dt dd
234                                  )],
235        macros              => \%macros,
236        pass_wiki_to_macros => 1,
237        node_prefix         => "$script_name?",
238        edit_prefix         => "$script_name?action=edit;id=",
239        munge_urls          => 1,
240        external_link_class => "external",
241    );
242
243    my %conf = ( store     => $store,
244                 search    => $search,
245                 formatter => $formatter );
246
247    my $wiki = Wiki::Toolkit->new( %conf );
248    return $wiki;
249}
250
251sub do_index_list_macro {
252    my ( $class, %args ) = @_;
253    my ( $wiki, $type, $value, $include_prefix )
254        = @args{ qw( wiki type value include_prefix ) };
255
256    # We may be being called by Wiki::Toolkit::Plugin::Diff,
257    # which doesn't know it has to pass us $wiki
258    if ( !UNIVERSAL::isa( $wiki, "Wiki::Toolkit" ) ) {
259        if ( $args{include_prefix} ) {
260            return "(unprocessed INDEX_LIST macro)";
261        } else {
262            return "(unprocessed INDEX_LIST_NO_PREFIX macro)";
263        }
264    }
265
266    my @nodes = sort $wiki->list_nodes_by_metadata(
267        metadata_type  => $type,
268        metadata_value => $value,
269        ignore_case    => 1,
270    );
271    unless ( scalar @nodes ) {
272        return "\n* No pages currently in " . lc($type) . " $value\n";
273    }
274    my $return = "\n";
275    foreach my $node ( @nodes ) {
276        my $title = $node;
277        $title =~ s/^(Category|Locale) // unless $args{include_prefix};
278        $return .= "* "
279                . $wiki->formatter->format_link( wiki => $wiki,
280                                                 link => "$node|$title" )
281                . "\n";
282    }
283    return $return;
284}
285
286=item B<get_wgs84_coords>
287
288Returns coordinate data suitable for use with Google Maps (and other GIS
289systems that assume WGS-84 data).
290
291    my ($wgs84_long, $wgs84_lat) = OpenGuides::Utils->get_wgs84_coords(
292                                        longitude => $longitude,
293                                        latitude => $latitude,
294                                        config => $config
295                                   );
296
297=cut
298
299sub get_wgs84_coords {
300    my ($self, %args) = @_;
301    my ($longitude, $latitude, $config) = ($args{longitude}, $args{latitude},
302                                           $args{config})
303       or croak "No longitude supplied to get_wgs84_coords";
304    croak "geo_handler not defined!" unless $config->geo_handler;
305
306    if ($config->force_wgs84) {
307        # Only as a rough approximation, good enough for large scale guides
308        return ($longitude, $latitude);
309    }
310
311    # If we don't have a lat and long, return undef right away
312    unless($args{longitude} || $args{latitude}) {
313        return undef;
314    }
315
316    # Try to load a provider of Helmert Transforms
317    my $helmert;
318    # First up, try the MySociety Geo::HelmertTransform
319    unless($helmert) {
320        eval {
321            require Geo::HelmertTransform;
322            $helmert = sub($$$) {
323                my ($datum,$oldlat,$oldlong) = @_;
324                if ($datum eq 'Airy') {
325                    $datum = 'Airy1830';
326                }
327                my $datum_helper = new Geo::HelmertTransform::Datum(Name=>$datum);
328                my $wgs84_helper = new Geo::HelmertTransform::Datum(Name=>'WGS84');
329                unless($datum_helper) {
330                    croak("No convertion helper for datum '$datum'");
331                    return undef;
332                }
333
334                my ($lat,$long,$h) = 
335                    Geo::HelmertTransform::convert_datum($datum_helper,$wgs84_helper,$oldlat,$oldlong,0);
336                return ($long,$lat);
337            };
338        };
339    }
340    # Give up, return undef
341    unless($helmert) {
342       return undef; 
343    }
344   
345
346    if ($config->geo_handler == 1) {
347        # Do conversion here
348        return &$helmert('Airy1830',$latitude,$longitude);
349    } elsif ($config->geo_handler == 2) {
350        # Do conversion here
351        return &$helmert('Airy1830Modified',$latitude,$longitude);
352    } elsif ($config->geo_handler == 3) {
353        if ($config->ellipsoid eq "WGS-84") {
354            return ($longitude, $latitude);
355        } else {
356            # Do conversion here
357            return &$helmert($config->ellipsoid,$latitude,$longitude);
358        }
359    } else {
360        croak "Invalid geo_handler config option $config->geo_handler";
361    }
362}
363
364=item B<get_wgs84_min_max>
365
366Given a set of WGS84 coordinate data, returns the minimum, maximum,
367and centre latitude and longitude.
368
369    %data = OpenGuides::Utils->get_wgs84_min_max(
370        nodes => [
371                   { wgs84_lat => 51.1, wgs84_long => 1.1 },
372                   { wgs84_lat => 51.2, wgs84_long => 1.2 },
373                 ]
374    );
375    print "Top right-hand corner is $data{max_lat}, $data{max_long}";
376    print "Centre point is $data{centre_lat}, $data{centre_long}";
377
378The hashes in the C<nodes> argument can include other key/value pairs;
379these will just be ignored.
380
381Returns false if it can't find any valid geodata in the nodes.
382
383=cut
384
385sub get_wgs84_min_max {
386    my ( $self, %args ) = @_;
387    my @nodes = @{$args{nodes}};
388
389    my @lats  = sort
390                grep { defined $_ && /^[-.\d]+$/ }
391                map { $_->{wgs84_lat} }
392                @nodes;
393    my @longs = sort
394                grep { defined $_ && /^[-.\d]+$/ }
395                map { $_->{wgs84_long} }
396                @nodes;
397
398    if ( !scalar @lats || !scalar @longs ) {
399        return;
400    }
401
402    my %data = ( min_lat  => $lats[0],  max_lat  => $lats[$#lats],
403                 min_long => $longs[0], max_long => $longs[$#longs] );
404    $data{centre_lat} = ( $data{min_lat} + $data{max_lat} ) / 2;
405    $data{centre_long} = ( $data{min_long} + $data{max_long} ) / 2;
406    return %data;
407}
408
409=item B<get_index_page_description>
410
411    $tt_vars{page_description} =
412        OpenGuides::Utils->get_index_page_description(
413            format => "map",
414            criteria => [ type => "locale", value => "croydon" ],
415    );
416
417Returns a sentence that can be used as a summary of what's shown on an
418index page.
419
420=cut
421
422sub get_index_page_description {
423    my ( $class, %args ) = @_;
424    my $desc = ( $args{format} eq "map" ) ? "Map" : "List";
425    $desc .= " of all our pages";
426
427    my ( @cats, @locs );
428    foreach my $criterion ( @{$args{criteria}} ) {
429        my ( $type, $name ) = ( $criterion->{type}, $criterion->{name} );
430        if ( $type eq "category" ) {
431            $name =~ s/Category //;
432            push @cats, $name;
433        } else {
434            $name =~ s/Locale //;
435            push @locs, $name;
436        }
437    }
438
439    if ( scalar @cats ) {
440        $desc .= " labelled with: " . join( ", ", @cats );
441        if ( scalar @locs ) {
442            $desc .= ", and";
443        }
444    }
445    if ( scalar @locs ) {
446        $desc .= " located in: " . join( ", ", @locs );
447    }
448    $desc .= ".";
449    return $desc;
450}
451
452=item B<detect_redirect>
453
454    $redir = OpenGuides::Utils->detect_redirect( content => "foo" );
455
456Checks the content of a node to see if the node is a redirect to another
457node.  If so, returns the name of the node that this one redirects to.  If
458not, returns false.
459
460(Also returns false if no content is provided.)
461
462=cut
463
464sub detect_redirect {
465    my ( $self, %args ) = @_;
466    return unless $args{content};
467
468    if ( $args{content} =~ /^#REDIRECT\s+(.+?)\s*$/ ) {
469        my $redirect = $1;
470
471        # Strip off enclosing [[ ]] in case this is an extended link.
472        $redirect =~ s/^\[\[//;
473        $redirect =~ s/\]\]\s*$//;
474
475        return $redirect;
476    }
477}
478
479=item B<validate_edit>
480
481    my $fails = OpenGuides::Utils->validate_edit(
482        id       => $node,
483        cgi_obj  => $q
484    );
485
486Checks supplied content for general validity. If anything is invalid,
487returns an array ref of errors to report to the user.
488
489=cut
490
491sub validate_edit {
492    my ( $self, %args ) = @_;
493    my $q = $args{cgi_obj};
494    my @fails;
495    push @fails, "Content missing" unless $q;
496    return \@fails if @fails;
497
498    # Now do our real validation
499    foreach my $var (qw(os_x os_y)) {
500        if ($q->param($var) and $q->param($var) !~ /^-?\d+$/) {
501            push @fails, "$var must be integer, was: " . $q->param($var);
502        }
503    }
504
505    foreach my $var (qw(latitude longitude)) {
506        if ($q->param($var) and $q->param($var) !~ /^-?\d+\.?(\d+)?$/) {
507            push @fails, "$var must be numeric, was: " . $q->param($var);
508        }
509    }
510
511    if ( $q->param('website') and $q->param('website') ne 'http://' ) {
512        unless ( is_web_uri( $q->param('website') ) ) {
513            push @fails, $q->param('website') . ' is not a valid web URI';
514        }
515    }
516
517    return \@fails;
518
519};
520
521=item B<parse_change_comment>
522
523    my $change_comment = parse_change_comment($string, $base_url);
524   
525Given a base URL (for example, C<http://example.com/wiki.cgi?>), takes a string,
526replaces C<[[page]]> and C<[[page|titled link]]> with
527
528    <a href="http://example.com/wiki.cgi?page">page</a>
529
530and
531
532    <a href="http://example.com/wiki.cgi?page">titled link</a>
533
534respectively, and returns it. This is a limited subset of wiki markup suitable for
535use in page change comments.
536
537=cut
538
539sub parse_change_comment {   
540    my ($comment, $base_url) = @_;
541
542    my @links = $comment =~ m{\[\[(.*?)\]\]}g;
543
544    # It's not all that great having to reinvent the wheel in this way, but
545    # Text::WikiFormat won't let you specify the subset of wiki notation that
546    # you're interested in. C'est la vie.
547    foreach (@links) {
548        if (/(.*?)\|(.*)/) {
549            my ($page, $title) = ($1, $2);
550            $comment =~ s{\[\[$page\|$title\]\]}
551                         {<a href="$base_url$page">$title</a>};
552        } else {
553            my $page = $_;
554            $comment =~ s{\[\[$page\]\]}
555                         {<a href="$base_url$page">$page</a>};
556        }
557    }
558
559    return $comment;
560}
561
562=item B<send_email>
563
564    eval { OpenGuides::Utils->send_email(
565            config        => $config,
566            subject       => "Subject",
567            body          => "Test body",
568            admin         => 1,
569            nobcc         => 1,
570            return_output => 1
571    ) };
572
573    if ($@) {
574        print "Error mailing admin: $@\n";
575    } else {
576        print "Mailed admin\n";
577    }
578
579Send out email. If C<admin> is true, the email will be sent to the site
580admin. If C<to> is defined, email will be sent to addresses in that
581arrayref. If C<nobcc> is true, there will be no Bcc to the admin.
582
583C<subject> and C<body> are mandatory arguments.
584
585Debugging: if C<return_output> is true, the message will be returned as
586a string instead of being sent by email.
587
588=cut
589
590
591sub send_email {
592    my ( $self, %args ) = @_;
593    my $config = $args{config} or die "config argument not supplied";
594    my @to;
595    @to = @{$args{to}} if $args{to};
596    my @bcc;
597    push @to, $config->contact_email if $args{admin};
598    die "No recipients specified" unless $to[0];
599    die "No subject specified" unless $args{subject};
600    die "No body specified" unless $args{body};
601    my $to_str = join ',', @to;
602    push @bcc, $config->contact_email unless $args{nobcc};
603    my $bcc_str = join ',', @bcc;
604    my $msg = MIME::Lite->new(
605        From    => $config->contact_email,
606        To      => $to_str,
607        Bcc     => $bcc_str,
608        Subject => $args{subject},
609        Data    => $args{body}
610    );
611
612    if ( $args{return_output} ) {
613        return $msg->as_string;
614    } else {
615        $msg->send or die "Couldn't send mail!";
616    }
617}
618
619=item B<in_moderate_whitelist>
620
621 if (OpenGuides::Utils->in_moderate_whitelist( '127.0.0.1' )) {
622     # skip moderation and apply new verson to published site
623 }
624
625Admins can supply a comma separated list of IP addresses or CIDR-notation
626subnets indicating the hosts which can bypass enforced moderation. Any
627values which cannot be parsed by C<NetAddr::IP> will be ignored.
628
629=cut
630
631sub in_moderate_whitelist {
632    my ($self, $config, $ip) = @_;
633    return undef if not defined $ip;
634
635    # create NetAddr::IP object of the test IP
636    my $addr = Net::Netmask->new2($ip) or return undef;
637
638    # load the configured whitelist
639    my @whitelist
640        = split ',', $config->moderate_whitelist;
641
642    # test each entry in the whitelist
643    return eval{
644        first { Net::Netmask->new2($_)->match($addr->base) } @whitelist
645    };
646}
647
648=back
649
650=head1 AUTHOR
651
652The OpenGuides Project (openguides-dev@lists.openguides.org)
653
654=head1 COPYRIGHT
655
656     Copyright (C) 2003-2012 The OpenGuides Project.  All Rights Reserved.
657
658This module is free software; you can redistribute it and/or modify it
659under the same terms as Perl itself.
660
661=cut
662
6631;
Note: See TracBrowser for help on using the repository browser.