source: trunk/lib/OpenGuides/CGI.pm @ 1105

Last change on this file since 1105 was 1105, checked in by Dominic Hargreaves, 15 years ago

Bump version numbers for release

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.7 KB
Line 
1package OpenGuides::CGI;
2use strict;
3use vars qw( $VERSION );
4$VERSION = '0.08';
5
6use Carp qw( croak );
7use CGI::Cookie;
8
9=head1 NAME
10
11OpenGuides::CGI - An OpenGuides helper for CGI-related things.
12
13=head1 DESCRIPTION
14
15Does CGI stuff for OpenGuides.  Distributed and installed as part of
16the OpenGuides project, not intended for independent installation.
17This documentation is probably only useful to OpenGuides developers.
18
19=head1 SYNOPSIS
20
21Saving preferences in a cookie:
22
23  use OpenGuides::CGI;
24  use OpenGuides::Config;
25  use OpenGuides::Template;
26  use OpenGuides::Utils;
27
28  my $config = OpenGuides::Config->new( file => "wiki.conf" );
29
30  my $cookie = OpenGuides::CGI->make_prefs_cookie(
31      config                     => $config,
32      username                   => "Kake",
33      include_geocache_link      => 1,
34      preview_above_edit_box     => 1,
35      latlong_traditional        => 1,
36      omit_help_links            => 1,
37      show_minor_edits_in_rc     => 1,
38      default_edit_type          => "tidying",
39      cookie_expires             => "never",
40      track_recent_changes_views => 1,
41      display_google_maps        => 1
42  );
43
44  my $wiki = OpenGuides::Utils->make_wiki_object( config => $config );
45  print OpenGuides::Template->output( wiki     => $wiki,
46                                      config   => $config,
47                                      template => "preferences.tt",
48                                      cookies  => $cookie
49  );
50
51  # and to retrive prefs later:
52  my %prefs = OpenGuides::CGI->get_prefs_from_cookie(
53      config => $config
54  );
55
56Tracking visits to Recent Changes:
57
58  use OpenGuides::CGI;
59  use OpenGuides::Config;
60  use OpenGuides::Template;
61  use OpenGuides::Utils;
62
63  my $config = OpenGuides::Config->new( file => "wiki.conf" );
64
65  my $cookie = OpenGuides::CGI->make_recent_changes_cookie(
66      config => $config,
67  );
68
69=head1 METHODS
70
71=over 4
72
73=item B<make_prefs_cookie>
74
75  my $cookie = OpenGuides::CGI->make_prefs_cookie(
76      config                     => $config,
77      username                   => "Kake",
78      include_geocache_link      => 1,
79      preview_above_edit_box     => 1,
80      latlong_traditional        => 1,
81      omit_help_links            => 1,
82      show_minor_edits_in_rc     => 1,
83      default_edit_type          => "tidying",
84      cookie_expires             => "never",
85      track_recent_changes_views => 1,
86      display_google_maps        => 1
87  );
88
89Croaks unless an L<OpenGuides::Config> object is supplied as C<config>.
90Acceptable values for C<cookie_expires> are C<never>, C<month>,
91C<year>; anything else will default to C<month>.
92
93=cut
94
95sub make_prefs_cookie {
96    my ($class, %args) = @_;
97    my $config = $args{config} or croak "No config object supplied";
98    croak "Config object not an OpenGuides::Config"
99        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
100    my $cookie_name = $class->_get_cookie_name( config => $config );
101    my $expires;
102    if ( $args{cookie_expires} and $args{cookie_expires} eq "never" ) {
103        # Gosh, a hack.  YES I AM ASHAMED OF MYSELF.
104        # Putting no expiry date means cookie expires when browser closes.
105        # Putting a date later than 2037 makes it wrap round, at least on Linux
106        # I will only be 62 by the time I need to redo this hack, so I should
107        # still be alive to fix it.
108        $expires = "Thu, 31-Dec-2037 22:22:22 GMT";
109    } elsif ( $args{cookie_expires} and $args{cookie_expires} eq "year" ) {
110        $expires = "+1y";
111    } else {
112        $args{cookie_expires} = "month";
113        $expires = "+1M";
114    }
115    # Supply 'default' values to stop CGI::Cookie complaining about
116    # uninitialised values.  *Real* default should be applied before
117    # calling this method.
118    my $cookie = CGI::Cookie->new(
119        -name  => $cookie_name,
120        -value => { user       => $args{username} || "",
121                    gclink     => $args{include_geocache_link} || 0,
122                    prevab     => $args{preview_above_edit_box} || 0,
123                    lltrad     => $args{latlong_traditional} || 0,
124                    omithlplks => $args{omit_help_links} || 0,
125                    rcmined    => $args{show_minor_edits_in_rc} || 0,
126                    defedit    => $args{default_edit_type} || "normal",
127                    exp        => $args{cookie_expires},
128                    trackrc    => $args{track_recent_changes_views} || 0,
129                    gmaps      => $args{display_google_maps} || 0
130                  },
131        -expires => $expires,
132    );
133    return $cookie;
134}
135
136=item B<get_prefs_from_cookie>
137
138  my %prefs = OpenGuides::CGI->get_prefs_from_cookie(
139      config => $config,
140      cookies => \@cookies
141  );
142
143Croaks unless an L<OpenGuides::Config> object is supplied as C<config>.
144Returns default values for any parameter not specified in cookie.
145
146If C<cookies> is provided, this overrides any cookies submitted by the
147browser.
148
149=cut
150
151sub get_prefs_from_cookie {
152    my ($class, %args) = @_;
153    my $config = $args{config} or croak "No config object supplied";
154    croak "Config object not an OpenGuides::Config"
155        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
156    my $cookie_name = $class->_get_cookie_name( config => $config );
157    my %cookies;
158    if ( my $cookies = $args{cookies} ) {
159        if (ref $cookies ne 'ARRAY') {
160            $cookies = [ $cookies ];
161        }
162        %cookies = map { $_->name => $_ } @{ $cookies };
163    }
164    else {
165        %cookies = CGI::Cookie->fetch;
166    }
167    my %data;
168    if ( $cookies{$cookie_name} ) {
169        %data = $cookies{$cookie_name}->value; # call ->value in list context
170    }
171
172    my %long_forms = (
173                       user       => "username",
174                       gclink     => "include_geocache_link",
175                       prevab     => "preview_above_edit_box",
176                       lltrad     => "latlong_traditional",
177                       omithlplks => "omit_help_links",
178                       rcmined    => "show_minor_edits_in_rc",
179                       defedit    => "default_edit_type",
180                       exp        => "cookie_expires",
181                       trackrc    => "track_recent_changes_views",
182                       gmaps      => "display_google_maps",
183                     );
184    my %long_data = map { $long_forms{$_} => $data{$_} } keys %long_forms;
185
186    return $class->get_prefs_from_hash( %long_data );
187}
188
189sub get_prefs_from_hash {
190    my ($class, %data) = @_;
191    my %defaults = (
192                     username                   => "Anonymous",
193                     include_geocache_link      => 0,
194                     preview_above_edit_box     => 0,
195                     latlong_traditional        => 0,
196                     omit_help_links            => 0,
197                     show_minor_edits_in_rc     => 0,
198                     default_edit_type          => "normal",
199                     cookie_expires             => "month",
200                     track_recent_changes_views => 0,
201                     display_google_maps        => 1,
202                   );
203    my %return;
204    foreach my $key ( keys %data ) {
205        $return{$key} = defined $data{$key} ? $data{$key} : $defaults{$key};
206    }
207
208    return %return;
209}
210
211
212=item B<make_recent_changes_cookie>
213
214  my $cookie = OpenGuides::CGI->make_recent_changes_cookie(
215      config => $config,
216  );
217
218Makes a cookie that stores the time now as the time of the latest
219visit to Recent Changes.  Or, if C<clear_cookie> is specified and
220true, makes a cookie with an expiration date in the past:
221
222  my $cookie = OpenGuides::CGI->make_recent_changes_cookie(
223      config       => $config,
224      clear_cookie => 1,
225  );
226
227=cut
228
229sub make_recent_changes_cookie {
230    my ($class, %args) = @_;
231    my $config = $args{config} or croak "No config object supplied";
232    croak "Config object not an OpenGuides::Config"
233        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
234    my $cookie_name = $class->_get_rc_cookie_name( config => $config );
235    # See explanation of expiry date hack above in make_prefs_cookie.
236    my $expires;
237    if ( $args{clear_cookie} ) {
238        $expires = "-1M";
239    } else {
240        $expires = "Thu, 31-Dec-2037 22:22:22 GMT";
241    }
242    my $cookie = CGI::Cookie->new(
243        -name  => $cookie_name,
244        -value => {
245                    time => time,
246                  },
247        -expires => $expires,
248    );
249    return $cookie;
250}
251
252
253=item B<get_last_recent_changes_visit_from_cookie>
254
255  my %prefs = OpenGuides::CGI->get_last_recent_changes_visit_from_cookie(
256      config => $config
257  );
258
259Croaks unless an L<OpenGuides::Config> object is supplied as C<config>.
260Returns the time (as seconds since epoch) of the user's last visit to
261Recent Changes.
262
263=cut
264
265sub get_last_recent_changes_visit_from_cookie {
266    my ($class, %args) = @_;
267    my $config = $args{config} or croak "No config object supplied";
268    croak "Config object not an OpenGuides::Config"
269        unless UNIVERSAL::isa( $config, "OpenGuides::Config" );
270    my %cookies = CGI::Cookie->fetch;
271    my $cookie_name = $class->_get_rc_cookie_name( config => $config );
272    my %data;
273    if ( $cookies{$cookie_name} ) {
274        %data = $cookies{$cookie_name}->value; # call ->value in list context
275    }
276    return $data{time};
277}
278
279
280sub _get_cookie_name {
281    my ($class, %args) = @_;
282    my $site_name = $args{config}->site_name
283        or croak "No site name in config";
284    return $site_name . "_userprefs";
285}
286
287sub _get_rc_cookie_name {
288    my ($class, %args) = @_;
289    my $site_name = $args{config}->site_name
290        or croak "No site name in config";
291    return $site_name . "_last_rc_visit";
292}
293
294=back
295
296=head1 AUTHOR
297
298The OpenGuides Project (openguides-dev@lists.openguides.org)
299
300=head1 COPYRIGHT
301
302     Copyright (C) 2003-2007 The OpenGuides Project.  All Rights Reserved.
303
304This module is free software; you can redistribute it and/or modify it
305under the same terms as Perl itself.
306
307=cut
308
3091;
310
Note: See TracBrowser for help on using the repository browser.