/[gedafe]/trunk/lib/perl/Gedafe/Util.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/perl/Gedafe/Util.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (show annotations)
Sun May 8 15:01:05 2005 UTC (14 years, 1 month ago) by dpavlin
File size: 5055 byte(s)
added preauth_user and preauth_passwd options, changed gedafe to work
without gedafed if thouse options are specifed.

1 # Gedafe, the Generic Database Frontend
2 # copyright (c) 2000-2003 ETH Zurich
3 # see http://isg.ee.ethz.ch/tools/gedafe/
4
5 # released under the GNU General Public License
6
7 package Gedafe::Util;
8 use strict;
9
10 use Gedafe::Global qw(%g);
11 use Text::CPPTemplate;
12
13 use IO::Socket;
14
15 use vars qw(@ISA @EXPORT_OK);
16 require Exporter;
17 @ISA = qw(Exporter);
18 @EXPORT_OK = qw(
19 ConnectToTicketsDaemon
20 MakeURL
21 MyURL
22 InitTemplate
23 InitPearls
24 Template
25 Die
26 DropUnique
27 FormStart
28 UniqueFormStart
29 FormEnd
30 UniqueFormEnd
31 NextRefresh
32 );
33
34 # Gedafe's die handler
35 sub Die($) {
36 my $error_text = shift;
37 my $s = $g{s};
38
39 # no recursion here please
40 $SIG{__DIE__} = 'DEFAULT';
41
42 my %t = (
43 PAGE => 'error',
44 TITLE => 'Internal Error',
45 );
46
47 die "GEDAFE INTERNAL ERROR: $error_text\n" unless (defined $s and defined $s->{cgi});
48
49 if(not $s->{http_header_sent}) {
50 print $s->{cgi}->header(-expires=>'-1d');
51 }
52
53 if(not $s->{header_sent}) {
54 $t{ELEMENT}='header';
55 print Template(\%t);
56
57 $t{ELEMENT}='header2';
58 print Template(\%t);
59 }
60
61 if($s->{in_form}) {
62 print "\n</FORM>\n";
63 }
64
65 if($s->{in_table}) {
66 print Template({ ELEMENT => 'xtable' });
67 }
68
69 $t{ELEMENT} ='error';
70 $t{ERROR} = $error_text ? $error_text : '(unknown)';
71 print Template(\%t);
72 delete $t{ERROR};
73
74 $t{ELEMENT}='footer';
75 print Template(\%t);
76
77 # die "GEDAFE ERROR: $error_text";
78 exit 1;
79 }
80
81 sub ConnectToTicketsDaemon($) {
82 my $s = shift;
83 my $file = $g{conf}{tickets_socket};
84 my $socket = IO::Socket::UNIX->new(Peer => $file)
85 or Die("Couldn't connect to gedafed daemon: $!");
86 return $socket;
87 }
88
89 sub MakeURL($$)
90 {
91 my $prev = shift;
92 my $new_params = shift;
93 my %params = ();
94 my $url;
95
96 # parse old url ($prev)
97 if($prev =~ /^(.*?)\?(.*)$/) {
98 $url = $1;
99 foreach(split(/[;&]/,$2)) {
100 if(/^(.*?)=(.*)$/) {
101 $params{$1} = $2;
102 }
103 }
104 }
105 else {
106 $url = $prev;
107 }
108
109 # merge
110 foreach(keys %$new_params) {
111 $params{$_} = $new_params->{$_};
112 }
113
114 # delete empty values
115 foreach(keys %params) {
116 delete $params{$_} unless defined $params{$_} and $params{$_} ne '';
117 }
118
119 # prepare key=value pairs
120 my @params_list = ();
121 foreach(sort keys %params) {
122 push @params_list, "$_=$params{$_}";
123 }
124
125 # make url
126 if(scalar @params_list != 0) {
127 $url .= '?';
128 # make url
129 $url .= join('&', @params_list);
130 }
131
132 return $url;
133 }
134
135 # get full URL, including parameters
136 sub MyURL($)
137 {
138 my $q = shift;
139 my $qs = $ENV{QUERY_STRING} || '';
140 if($qs =~ /^\s*$/) {
141 return $q->url();
142 }
143 else {
144 return $q->url().'?'.$qs;
145 }
146 }
147
148 sub GetUnique($)
149 {
150 my $s = shift;
151 if ($s->{'ticket_value'}) {
152 my $socket = ConnectToTicketsDaemon($s);
153 print $socket "SITE $s->{path}/$s->{script}\n";
154 <$socket>;
155 print $socket "GETUNIQUE\n";
156 $_ = <$socket>;
157 close($socket);
158 if(! /^([\w-]+)$/) {
159 Die("Couldn't understand ticket daemon reply: $_");
160 }
161 return $1;
162 } else {
163 return $s->{'user'}.'-'.rand_ascii_32();
164 }
165 }
166
167 sub DropUnique($$)
168 {
169 my $s = shift;
170 my $unique_id = shift;
171 return 1 unless ($s->{'ticket_value'});
172 if(defined $unique_id) {
173 my $socket = ConnectToTicketsDaemon($s);
174 print $socket "SITE $s->{path}/$s->{script}\n";
175 <$socket>;
176 print $socket "DROPUNIQUE $unique_id\n";
177 $_ = <$socket>;
178 close($socket);
179 if(!/^OK$/) {
180 return 0;
181 }
182 }
183 return 1;
184 }
185
186 sub UniqueFormStart($$)
187 {
188 my $s = shift;
189 my $action = shift;
190 print qq{<FORM ACTION="$action" METHOD="POST" ENCTYPE="multipart/form-data" NAME="editform">\n};
191
192 $s->{in_form}=1;
193 }
194 sub FormStart($$)
195 {
196 my $s = shift;
197 my $action = shift;
198 print qq{<FORM ACTION="$action" METHOD="GET" ENCTYPE="multipart/form-data" NAME="editform">\n};
199 $s->{in_form}=1;
200 }
201
202 # end form without double form protection
203 sub FormEnd($)
204 {
205 my $s = shift;
206
207 print "</FORM>\n";
208
209 delete $s->{in_form};
210 }
211
212 sub UniqueFormEnd($$;$)
213 {
214 my $s = shift;
215 my $form_url = shift;
216 my $next_url = shift || $form_url;
217
218 my $form_id = GetUnique($s);
219 print "\n<INPUT TYPE=\"hidden\" NAME=\"form_url\" VALUE=\"$form_url\">\n";
220 print "<INPUT TYPE=\"hidden\" NAME=\"next_url\" VALUE=\"$next_url\">\n";
221 print "<INPUT TYPE=\"hidden\" NAME=\"form_id\" VALUE=\"$form_id\">\n";
222 FormEnd $s;
223 }
224
225
226 sub rand_ascii_32
227 {
228 return sprintf "%04x%04x", rand()*(1<<16), rand()*(1<<16);
229 }
230
231 sub NextRefresh()
232 {
233 return rand_ascii_32;
234 }
235
236 sub InitTemplate($$)
237 {
238 return if defined $g{tmpl};
239 $g{tmpl} = new Text::CPPTemplate(shift,shift);
240 }
241
242 sub Template($)
243 {
244 return $g{tmpl}->template(shift);
245 }
246
247 sub InitPearls($){
248 return if defined $g{pearls};
249 my $path = shift;
250 my %pearls;
251 chdir $path || Die "switching to 'pearl_dir ($path)': $!\n";
252 my @modules = <*.pm>;
253 foreach my $module (@modules) {
254 $module =~ s/\.pm$//;
255 $pearls{$module} = eval "local \$SIG{__DIE__} = 'IGNORE';
256 require $module;
257 $module->new()";
258 if ($@) {
259 $pearls{$module} =
260 "<pre>Unable to load Pearl $module.pm from $path<br><br>$@</pre>"
261 }
262 }
263 $g{pearls} = \%pearls;
264 }
265
266 1;
267
268 # Emacs Configuration
269 #
270 # Local Variables:
271 # mode: cperl
272 # eval: (cperl-set-style "BSD")
273 # cperl-indent-level: 8
274 # mode: flyspell
275 # mode: flyspell-prog
276 # End:
277 #

  ViewVC Help
Powered by ViewVC 1.1.26