/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (hide annotations)
Sun May 8 15:01:05 2005 UTC (18 years, 10 months 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 dpavlin 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 dpavlin 14 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 dpavlin 1 }
165     }
166    
167     sub DropUnique($$)
168     {
169     my $s = shift;
170     my $unique_id = shift;
171 dpavlin 14 return 1 unless ($s->{'ticket_value'});
172 dpavlin 1 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