/[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 1 - (show annotations)
Mon Feb 14 18:52:26 2005 UTC (19 years, 1 month ago) by dpavlin
File size: 4919 byte(s)
import of Gedafe 1.2.2

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 my $socket = ConnectToTicketsDaemon($s);
152 print $socket "SITE $s->{path}/$s->{script}\n";
153 <$socket>;
154 print $socket "GETUNIQUE\n";
155 $_ = <$socket>;
156 close($socket);
157 if(! /^([\w-]+)$/) {
158 Die("Couldn't understand ticket daemon reply: $_");
159 }
160 return $1;
161 }
162
163 sub DropUnique($$)
164 {
165 my $s = shift;
166 my $unique_id = shift;
167 if(defined $unique_id) {
168 my $socket = ConnectToTicketsDaemon($s);
169 print $socket "SITE $s->{path}/$s->{script}\n";
170 <$socket>;
171 print $socket "DROPUNIQUE $unique_id\n";
172 $_ = <$socket>;
173 close($socket);
174 if(!/^OK$/) {
175 return 0;
176 }
177 }
178 return 1;
179 }
180
181 sub UniqueFormStart($$)
182 {
183 my $s = shift;
184 my $action = shift;
185 print qq{<FORM ACTION="$action" METHOD="POST" ENCTYPE="multipart/form-data" NAME="editform">\n};
186
187 $s->{in_form}=1;
188 }
189 sub FormStart($$)
190 {
191 my $s = shift;
192 my $action = shift;
193 print qq{<FORM ACTION="$action" METHOD="GET" ENCTYPE="multipart/form-data" NAME="editform">\n};
194 $s->{in_form}=1;
195 }
196
197 # end form without double form protection
198 sub FormEnd($)
199 {
200 my $s = shift;
201
202 print "</FORM>\n";
203
204 delete $s->{in_form};
205 }
206
207 sub UniqueFormEnd($$;$)
208 {
209 my $s = shift;
210 my $form_url = shift;
211 my $next_url = shift || $form_url;
212
213 my $form_id = GetUnique($s);
214 print "\n<INPUT TYPE=\"hidden\" NAME=\"form_url\" VALUE=\"$form_url\">\n";
215 print "<INPUT TYPE=\"hidden\" NAME=\"next_url\" VALUE=\"$next_url\">\n";
216 print "<INPUT TYPE=\"hidden\" NAME=\"form_id\" VALUE=\"$form_id\">\n";
217 FormEnd $s;
218 }
219
220
221 sub rand_ascii_32
222 {
223 return sprintf "%04x%04x", rand()*(1<<16), rand()*(1<<16);
224 }
225
226 sub NextRefresh()
227 {
228 return rand_ascii_32;
229 }
230
231 sub InitTemplate($$)
232 {
233 return if defined $g{tmpl};
234 $g{tmpl} = new Text::CPPTemplate(shift,shift);
235 }
236
237 sub Template($)
238 {
239 return $g{tmpl}->template(shift);
240 }
241
242 sub InitPearls($){
243 return if defined $g{pearls};
244 my $path = shift;
245 my %pearls;
246 chdir $path || Die "switching to 'pearl_dir ($path)': $!\n";
247 my @modules = <*.pm>;
248 foreach my $module (@modules) {
249 $module =~ s/\.pm$//;
250 $pearls{$module} = eval "local \$SIG{__DIE__} = 'IGNORE';
251 require $module;
252 $module->new()";
253 if ($@) {
254 $pearls{$module} =
255 "<pre>Unable to load Pearl $module.pm from $path<br><br>$@</pre>"
256 }
257 }
258 $g{pearls} = \%pearls;
259 }
260
261 1;
262
263 # Emacs Configuration
264 #
265 # Local Variables:
266 # mode: cperl
267 # eval: (cperl-set-style "BSD")
268 # cperl-indent-level: 8
269 # mode: flyspell
270 # mode: flyspell-prog
271 # End:
272 #

  ViewVC Help
Powered by ViewVC 1.1.26