/[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 1 - (hide 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 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     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