moved qdb here because matt is lazy
[public/www-new.git] / pub / qdb / src / modules / Chirpy / UpdateChecker.pm
1 ###############################################################################\r
2 # Chirpy! 0.3, a quote management system                                      #\r
3 # Copyright (C) 2005-2007 Tim De Pauw <ceetee@users.sourceforge.net>          #\r
4 ###############################################################################\r
5 # This program is free software; you can redistribute it and/or modify it     #\r
6 # under the terms of the GNU General Public License as published by the Free  #\r
7 # Software Foundation; either version 2 of the License, or (at your option)   #\r
8 # any later version.                                                          #\r
9 #                                                                             #\r
10 # This program is distributed in the hope that it will be useful, but WITHOUT #\r
11 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or       #\r
12 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for   #\r
13 # more details.                                                               #\r
14 #                                                                             #\r
15 # You should have received a copy of the GNU General Public License along     #\r
16 # with this program; if not, write to the Free Software Foundation, Inc., 51  #\r
17 # Franklin St, Fifth Floor, Boston, MA  02110-1301  USA                       #\r
18 ###############################################################################\r
19 \r
20 ###############################################################################\r
21 # $Id:: UpdateChecker.pm 291 2007-02-05 21:24:46Z ceetee                    $ #\r
22 ###############################################################################\r
23 \r
24 =head1 NAME\r
25 \r
26 Chirpy::UpdateChecker - Update checker\r
27 \r
28 =head1 AUTHOR\r
29 \r
30 Tim De Pauw E<lt>ceetee@users.sourceforge.netE<gt>\r
31 \r
32 =head1 SEE ALSO\r
33 \r
34 L<Chirpy>, L<http://chirpy.sourceforge.net/>\r
35 \r
36 =head1 COPYRIGHT\r
37 \r
38 Copyright 2005-2007 Tim De Pauw. All rights reserved.\r
39 \r
40 This program is free software; you can redistribute it and/or modify it under\r
41 the terms of the GNU General Public License as published by the Free Software\r
42 Foundation; either version 2 of the License, or (at your option) any later\r
43 version.\r
44 \r
45 This program is distributed in the hope that it will be useful, but WITHOUT ANY\r
46 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A\r
47 PARTICULAR PURPOSE.  See the GNU General Public License for more details.\r
48 \r
49 =cut\r
50 \r
51 package Chirpy::UpdateChecker;\r
52 \r
53 use strict;\r
54 use warnings;\r
55 \r
56 use vars qw($VERSION);\r
57 \r
58 $VERSION = '0.3';\r
59 \r
60 use Chirpy 0.3;\r
61 \r
62 use constant UPDATE_URL => Chirpy::URL . 'update/';\r
63 use constant TIMEOUT => 5;\r
64 use constant KEY_VERSION_NUMBER => 'VersionNumber';\r
65 use constant KEY_RELEASE_DATE => 'ReleaseDate';\r
66 use constant KEY_DETAIL_URL => 'DetailURL';\r
67 \r
68 sub new {\r
69         my ($class, $parent) = @_;\r
70         eval 'use LWP::UserAgent';\r
71         my ($ua, $error);\r
72         if ($@) {\r
73                 $error = 'LWP::UserAgent not available';\r
74         }\r
75         else {\r
76                 $ua = new LWP::UserAgent();\r
77                 $ua->timeout(TIMEOUT);\r
78                 $ua->env_proxy();\r
79         }\r
80         my $self = {\r
81                 'parent' => $parent,\r
82                 'ua' => $ua,\r
83                 'error' => $error\r
84         };\r
85         return bless $self, $class;\r
86 }\r
87 \r
88 sub check_for_updates {\r
89         my $self = shift;\r
90         return 1 unless ($self->{'ua'});\r
91         my $info = $self->get_version_information();\r
92         if (ref $info ne 'ARRAY') {\r
93                 $self->{'error'} = $info;\r
94                 return 1;\r
95         }\r
96         if (shift(@$info)) {\r
97                 return $info;\r
98         }\r
99         return 0;\r
100 }\r
101 \r
102 sub get_error_message {\r
103         my $self = shift;\r
104         return $self->{'error'};\r
105 }\r
106 \r
107 sub get_version_information {\r
108         my $self = shift;\r
109         my $ua = $self->{'ua'};\r
110         my $url = $self->{'parent'}->configuration()->get('ui', 'webapp.site_url');\r
111         if (defined $url) {\r
112                 eval 'use URI::Escape';\r
113                 $url = ($@ ? undef : URI::Escape::uri_escape($url));\r
114         }\r
115         $url = UPDATE_URL . '?version=' . $Chirpy::VERSION\r
116                 . (defined $url ? '&url=' . $url : '');\r
117         my $response = $ua->get($url);\r
118         if ($response->is_success) {\r
119                 my $xml = $response->content;\r
120                 my %info = ();\r
121                 if ($xml =~ m{\r
122                         <CurrentVersion(?:\s+newer="(.*?))?">\s*(.*?)\s*</CurrentVersion>\r
123                 }sx) {\r
124                         my ($newer, $node) = ($1, $2);\r
125                         $newer = (defined $newer && lc $newer eq 'true');\r
126                         my $pattern = join('|', map { quotemeta }\r
127                                 (KEY_VERSION_NUMBER, KEY_RELEASE_DATE, KEY_DETAIL_URL));\r
128                         while ($node =~ m!<($pattern)>\s*(.*?)\s*</\1>!sg) {\r
129                                 $info{$1} = $2;\r
130                         }\r
131                         $info{KEY_DETAIL_URL} =~ s/&amp;/&/g;\r
132                         return [\r
133                                 $newer,\r
134                                 $info{KEY_VERSION_NUMBER()},\r
135                                 $info{KEY_RELEASE_DATE()},\r
136                                 $info{KEY_DETAIL_URL()}\r
137                         ];\r
138                 }\r
139                 return 'Unknown response from update server';\r
140         }\r
141         return $response->status_line;\r
142 }\r
143 \r
144 1;\r
145 \r
146 ###############################################################################