This file is indexed.

/usr/share/perl5/OpenGuides/CGI.pm is in openguides 0.76-2.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
package OpenGuides::CGI;
use strict;
use vars qw( $VERSION );
$VERSION = '0.12';

use Carp qw( croak );
use CGI;
use CGI::Cookie;

=head1 NAME

OpenGuides::CGI - An OpenGuides helper for CGI-related things.

=head1 DESCRIPTION

Does CGI stuff for OpenGuides.  Distributed and installed as part of
the OpenGuides project, not intended for independent installation.
This documentation is probably only useful to OpenGuides developers.

=head1 SYNOPSIS

Saving preferences in a cookie:

  use OpenGuides::CGI;
  use OpenGuides::Config;
  use OpenGuides::Template;
  use OpenGuides::Utils;

  my $config = OpenGuides::Config->new( file => "wiki.conf" );

  my $cookie = OpenGuides::CGI->make_prefs_cookie(
      config                     => $config,
      username                   => "Kake",
      include_geocache_link      => 1,
      preview_above_edit_box     => 1,
      latlong_traditional        => 1,
      omit_help_links            => 1,
      show_minor_edits_in_rc     => 1,
      default_edit_type          => "tidying",
      cookie_expires             => "never",
      track_recent_changes_views => 1,
      display_google_maps        => 1,
      is_admin                   => 1
  );

  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
  print OpenGuides::Template->output( wiki     => $wiki,
                                      config   => $config,
                                      template => "preferences.tt",
                                      cookies  => $cookie
  );

  # and to retrive prefs later:
  my %prefs = OpenGuides::CGI->get_prefs_from_cookie(
      config => $config
  );

Tracking visits to Recent Changes:

  use OpenGuides::CGI;
  use OpenGuides::Config;
  use OpenGuides::Template;
  use OpenGuides::Utils;

  my $config = OpenGuides::Config->new( file => "wiki.conf" );

  my $cookie = OpenGuides::CGI->make_recent_changes_cookie(
      config => $config,
  );

=head1 METHODS

=over 4

=item B<extract_node_param>

    my $config_file = $ENV{OPENGUIDES_CONFIG_FILE} || "wiki.conf";
    my $config = OpenGuides::Config->new( file => $config_file );
    my $guide = OpenGuides->new( config => $config );
    my $wiki = $guide->wiki;

    my $q = CGI->new;

    my $node_param = OpenGuides::CGI->extract_node_param(
                        wiki => $wiki, cgi_obj => $q );

Returns the title, id, or keywords parameter from the URL.  Normally
this will be something like "British_Museum", i.e. with underscores
instead of spaces.  However if the URL does contain spaces (encoded as
%20 or +), the return value will be e.g. "British Museum" instead.

Croaks unless a L<Wiki::Toolkit> object is supplied as C<wiki> and a
L<CGI> object is supplied as C<cgi_obj>.

=cut

sub extract_node_param {
    my ($class, %args) = @_;
    my $wiki = $args{wiki} or croak "No wiki supplied";
    croak "wiki not a Wiki::Toolkit object"
        unless UNIVERSAL::isa( $wiki, "Wiki::Toolkit" );
    my $q = $args{cgi_obj} or croak "No cgi_obj supplied";
    croak "cgi_obj not a CGI object"
        unless UNIVERSAL::isa( $q, "CGI" );

    # Note $q->param( "keywords" ) gives you the entire param string.
    # We need this to do URLs like foo.com/wiki.cgi?This_Page
    my $param = $q->param( "id" )
                || $q->param( "title" )
                || join( " ", $q->param( "keywords" ) )
                || "";
    $param =~ s/%20/ /g;
    $param =~ s/\+/ /g;
    return $param;
}

=item B<extract_node_name>

    my $config_file = $ENV{OPENGUIDES_CONFIG_FILE} || "wiki.conf";
    my $config = OpenGuides::Config->new( file => $config_file );
    my $guide = OpenGuides->new( config => $config );
    my $wiki = $guide->wiki;

    my $q = CGI->new;

    my $node_name = OpenGuides::CGI->extract_node_name(
                        wiki => $wiki, cgi_obj => $q );

Returns the name of the node the user wishes to display/manipulate, as
we expect it to be stored in the database.  Normally this will be
something like "British Museum", i.e. with spaces in.  Croaks unless a
L<Wiki::Toolkit> object is supplied as C<wiki> and a L<CGI> object is
supplied as C<cgi_obj>.

=cut

sub extract_node_name {
    my ($class, %args) = @_;
    # The next call will validate our args for us and croak if necessary.
    my $param = $class->extract_node_param( %args );

    # Sometimes people type spaces instead of underscores.
    $param =~ s/ /_/g;
    $param =~ s/%20/_/g;
    $param =~ s/\+/_/g;

    my $formatter = $args{wiki}->formatter;
    return $formatter->node_param_to_node_name( $param );
}

=item B<check_spaces_redirect>

    my $config_file = $ENV{OPENGUIDES_CONFIG_FILE} || "wiki.conf";
    my $config = OpenGuides::Config->new( file => $config_file );
    my $guide = OpenGuides->new( config => $config );

    my $q = CGI->new;

    my $url = OpenGuides::CGI->check_spaces_redirect(
                                 wiki => $wiki, cgi_obj => $q );

If the user seems to have typed a URL with spaces in the node param
instead of underscores, this method will return the URL with the
underscores put in.  Otherwise, it returns false.

=cut

sub check_spaces_redirect {
    my ($class, %args) = @_;
    my $wiki = $args{wiki};
    my $q = $args{cgi_obj};

    my $name = $class->extract_node_name( wiki => $wiki, cgi_obj => $q );
    my $param = $class->extract_node_param( wiki => $wiki, cgi_obj => $q );

    # If we can't figure out the name or param, it's safest to do nothing.
    if ( !$name || !$param ) {
        return 0;
    }

    # If the name has no spaces in, or the name and param differ, we're
    # probably OK.
    if ( ( $name !~ / / ) || ( $name ne $param ) ) {
        return 0;
    }

    # Make a new CGI object to manipulate, to avoid action-at-a-distance.
    my $new_q = CGI->new( $q );
    my $formatter = $wiki->formatter;
    my $real_param = $formatter->node_name_to_node_param( $name );

    if ( $q->param( "id" ) ) {
        $new_q->param( -name => "id", -value => $real_param );
    } elsif ( $q->param( "title" ) ) {
        $new_q->param( -name => "title", -value => $real_param );
    } else {
        # OK, we have the keywords case; the entire param string is the
        # node param.  So just delete all existing parameters and stick
        # the node param back in.
        $new_q->delete_all();
        $new_q->param( -name => "id", -value => $real_param );
    }

    my $url = $new_q->self_url;

    # Escaped commas are ugly.
    $url =~ s/%2C/,/g;
    return $url;
}

=item B<make_prefs_cookie>

  my $cookie = OpenGuides::CGI->make_prefs_cookie(
      config                     => $config,
      username                   => "Kake",
      include_geocache_link      => 1,
      preview_above_edit_box     => 1,
      latlong_traditional        => 1,
      omit_help_links            => 1,
      show_minor_edits_in_rc     => 1,
      default_edit_type          => "tidying",
      cookie_expires             => "never",
      track_recent_changes_views => 1,
      display_google_maps        => 1,
      is_admin                   => 1
  );

Croaks unless an L<OpenGuides::Config> object is supplied as C<config>.
Acceptable values for C<cookie_expires> are C<never>, C<month>,
C<year>; anything else will default to C<month>.

=cut

sub make_prefs_cookie {
    my ($class, %args) = @_;
    my $config = $args{config} or croak "No config object supplied";
    croak "Config object not an OpenGuides::Config"
        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
    my $cookie_name = $class->_get_cookie_name( config => $config );
    my $expires;
    if ( $args{cookie_expires} and $args{cookie_expires} eq "never" ) {
        # Gosh, a hack.  YES I AM ASHAMED OF MYSELF.
        # Putting no expiry date means cookie expires when browser closes.
        # Putting a date later than 2037 makes it wrap round, at least on Linux
        # I will only be 62 by the time I need to redo this hack, so I should
        # still be alive to fix it.
        $expires = "Thu, 31-Dec-2037 22:22:22 GMT";
    } elsif ( $args{cookie_expires} and $args{cookie_expires} eq "year" ) {
        $expires = "+1y";
    } else {
        $args{cookie_expires} = "month";
        $expires = "+1M";
    }
    # Supply 'default' values to stop CGI::Cookie complaining about
    # uninitialised values.  *Real* default should be applied before
    # calling this method.
    my $cookie = CGI::Cookie->new(
        -name  => $cookie_name,
	-value => { user       => $args{username} || "",
		    gclink     => $args{include_geocache_link} || 0,
                    prevab     => $args{preview_above_edit_box} || 0,
                    lltrad     => $args{latlong_traditional} || 0,
                    omithlplks => $args{omit_help_links} || 0,
                    rcmined    => $args{show_minor_edits_in_rc} || 0,
                    defedit    => $args{default_edit_type} || "normal",
                    exp        => $args{cookie_expires},
                    trackrc    => $args{track_recent_changes_views} || 0,
                    gmaps      => $args{display_google_maps} || 0,
                    admin      => $args{is_admin} || 0
                  },
        -expires => $expires,
    );
    return $cookie;
}

=item B<get_prefs_from_cookie>

  my %prefs = OpenGuides::CGI->get_prefs_from_cookie(
      config => $config,
      cookies => \@cookies
  );

Croaks unless an L<OpenGuides::Config> object is supplied as C<config>.
Returns default values for any parameter not specified in cookie.

If C<cookies> is provided, and includes a preferences cookie, this overrides
any preferences cookie submitted by the browser.

=cut

sub get_prefs_from_cookie {
    my ($class, %args) = @_;
    my $config = $args{config} or croak "No config object supplied";
    croak "Config object not an OpenGuides::Config"
        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
    my $cookie_name = $class->_get_cookie_name( config => $config );
    my %cookies;
    if ( my $cookies = $args{cookies} ) {
        if (ref $cookies ne 'ARRAY') {
            $cookies = [ $cookies ];
        }
        %cookies = map { $_->name => $_ } @{ $cookies };
    }
    if ( !$cookies{$cookie_name} ) {
        my %stored_cookies = CGI::Cookie->fetch;
        $cookies{$cookie_name} = $stored_cookies{$cookie_name};
    }
    my %data;
    if ( $cookies{$cookie_name} ) {
        %data = $cookies{$cookie_name}->value; # call ->value in list context
    }

    my %long_forms = (
                       user       => "username",
                       gclink     => "include_geocache_link",
                       prevab     => "preview_above_edit_box",
                       lltrad     => "latlong_traditional",
                       omithlplks => "omit_help_links",
                       rcmined    => "show_minor_edits_in_rc",
                       defedit    => "default_edit_type",
                       exp        => "cookie_expires",
                       trackrc    => "track_recent_changes_views",
                       gmaps      => "display_google_maps",
                       admin      => "is_admin",
                     );
    my %long_data = map { $long_forms{$_} => $data{$_} } keys %long_forms;

    return $class->get_prefs_from_hash( %long_data );
}

sub get_prefs_from_hash {
    my ($class, %data) = @_;
    my %defaults = (
                     username                   => "Anonymous",
                     include_geocache_link      => 0,
                     preview_above_edit_box     => 0,
                     latlong_traditional        => 0,
                     omit_help_links            => 0,
                     # This has been set to 1 to work around
                     # Wiki::Toolkit bug #41 - consider reverting this
                     # when that bug gets fixed
                     show_minor_edits_in_rc     => 1,
                     default_edit_type          => "normal",
                     cookie_expires             => "never",
                     track_recent_changes_views => 0,
                     display_google_maps        => 1,
                     is_admin                   => 0,
                   );
    my %return;
    foreach my $key ( keys %data ) {
        $return{$key} = defined $data{$key} ? $data{$key} : $defaults{$key};
    }

    return %return;
}


=item B<make_recent_changes_cookie>

  my $cookie = OpenGuides::CGI->make_recent_changes_cookie(
      config => $config,
  );

Makes a cookie that stores the time now as the time of the latest
visit to Recent Changes.  Or, if C<clear_cookie> is specified and
true, makes a cookie with an expiration date in the past:

  my $cookie = OpenGuides::CGI->make_recent_changes_cookie(
      config       => $config,
      clear_cookie => 1,
  );

=cut

sub make_recent_changes_cookie {
    my ($class, %args) = @_;
    my $config = $args{config} or croak "No config object supplied";
    croak "Config object not an OpenGuides::Config"
        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
    my $cookie_name = $class->_get_rc_cookie_name( config => $config );
    # See explanation of expiry date hack above in make_prefs_cookie.
    my $expires;
    if ( $args{clear_cookie} ) {
        $expires = "-1M";
    } else {
        $expires = "Thu, 31-Dec-2037 22:22:22 GMT";
    }
    my $cookie = CGI::Cookie->new(
        -name  => $cookie_name,
	-value => {
                    time => time,
                  },
        -expires => $expires,
    );
    return $cookie;
}


=item B<get_last_recent_changes_visit_from_cookie>

  my %prefs = OpenGuides::CGI->get_last_recent_changes_visit_from_cookie(
      config => $config
  );

Croaks unless an L<OpenGuides::Config> object is supplied as C<config>.
Returns the time (as seconds since epoch) of the user's last visit to
Recent Changes.

=cut

sub get_last_recent_changes_visit_from_cookie {
    my ($class, %args) = @_;
    my $config = $args{config} or croak "No config object supplied";
    croak "Config object not an OpenGuides::Config"
        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
    my %cookies = CGI::Cookie->fetch;
    my $cookie_name = $class->_get_rc_cookie_name( config => $config );
    my %data;
    if ( $cookies{$cookie_name} ) {
        %data = $cookies{$cookie_name}->value; # call ->value in list context
    }
    return $data{time};
}


sub _get_cookie_name {
    my ($class, %args) = @_;
    my $site_name = $args{config}->site_name
        or croak "No site name in config";
    return $site_name . "_userprefs";
}

sub _get_rc_cookie_name {
    my ($class, %args) = @_;
    my $site_name = $args{config}->site_name
        or croak "No site name in config";
    return $site_name . "_last_rc_visit";
}

=item B<make_index_form_dropdowns>

    my @dropdowns = OpenGuides::CGI->make_index_form_dropdowns (
        guide    => $guide,
        selected => [
                      { type => "category", value => "pubs" },
                      { type => "locale", value => "holborn" },
                    ],
    );
    %tt_vars = ( %tt_vars, dropdowns => \@dropdowns );

    # In the template
    [% FOREACH dropdown = dropdowns %]
      [% dropdown.type.ucfirst | html %]:
      [% dropdown.html %]
      <br />
    [% END %]

Makes HTML dropdown selects suitable for passing to an indexing template.

The C<selected> argument is optional; if supplied, it gives default values
for the dropdowns.  At least one category and one locale dropdown will be
returned; if no defaults are given for either then they'll default to
everything/everywhere.

=cut

sub make_index_form_dropdowns {
    my ( $class, %args ) = @_;
    my @selected = @{$args{selected} || [] };
    my $guide = $args{guide};
    my @dropdowns;
    my ( $got_cat, $got_loc );
    foreach my $criterion ( @selected ) {
        my $type = $criterion->{type} || "";
        my $value = $criterion->{value} || "";
        my $html;
        if ( $type eq "category" ) {
            $html = $class->_make_dropdown_html(
                        %$criterion, guide => $guide );
            $got_cat = 1;
        } elsif ( $type eq "locale" ) {
            $html = $class->_make_dropdown_html(
                        %$criterion, guide => $guide );
            $got_loc = 1;
        } else {
            warn "Unknown or missing criterion type: $type";
        }
        if ( $html ) {
            push @dropdowns, { type => $type, html => $html };
        }
    }
    if ( !$got_cat ) {
        push @dropdowns, { type => "category", html =>
            $class->_make_dropdown_html( type => "category", guide => $guide )
        };
    }
    if ( !$got_loc ) {
        push @dropdowns, { type => "locale", html =>
            $class->_make_dropdown_html( type => "locale", guide => $guide )
        };
    }
    # List the category dropdowns before the locale dropdowns, for consistency.
    @dropdowns = sort { $a->{type} cmp $b->{type} } @dropdowns;
    return @dropdowns;
}

sub _make_dropdown_html {
    my ( $class, %args ) = @_;
    my ( $field_name, $any_label );

    if ( $args{type} eq "locale" ) {
        $args{type} = "locales"; # hysterical raisins
        $any_label = " -- anywhere -- ";
        $field_name = "loc";
    } else {
        $any_label = " -- anything -- ";
        $field_name = "cat";
    }

    my @options = $args{guide}->wiki->list_nodes_by_metadata(
        metadata_type => "category",
        metadata_value => $args{type},
        ignore_case => 1,
    );
    @options = map { s/^Category //; s/^Locale //; $_ } @options;
    my %labels = map { lc( $_ ) => $_ } @options;
    my @values = sort keys %labels;
    my $default = lc( $args{value} || "");

    my $q = CGI->new( "" );
    return $q->popup_menu( -name => $field_name,
                           -values => [ "", @values ],
                           -labels => { "" => $any_label, %labels },
                           -default => $default );
}

=back

=head1 AUTHOR

The OpenGuides Project (openguides-dev@lists.openguides.org)

=head1 COPYRIGHT

     Copyright (C) 2003-2013 The OpenGuides Project.  All Rights Reserved.

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;