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::Start; |
8 |
use strict; |
9 |
|
10 |
use vars qw(@ISA @EXPORT); |
11 |
require Exporter; |
12 |
@ISA = qw(Exporter); |
13 |
@EXPORT = qw(Start); |
14 |
|
15 |
use CGI 2.00 qw(-compile :cgi); |
16 |
|
17 |
use Gedafe::Auth qw(AuthConnect); |
18 |
use Gedafe::Global qw(%g); |
19 |
use Gedafe::GUI qw( |
20 |
GUI_Entry |
21 |
GUI_List |
22 |
GUI_CheckFormID |
23 |
GUI_PostEdit |
24 |
GUI_Edit |
25 |
GUI_Delete |
26 |
GUI_Export |
27 |
GUI_DumpTable |
28 |
GUI_Pearl |
29 |
); |
30 |
use Gedafe::DB qw( |
31 |
DB_GetBlobType |
32 |
DB_GetBlobName |
33 |
DB_DumpBlob |
34 |
); |
35 |
|
36 |
use Gedafe::Util qw( |
37 |
Die |
38 |
MakeURL |
39 |
MyURL |
40 |
InitTemplate |
41 |
Template |
42 |
NextRefresh |
43 |
InitPearls); |
44 |
|
45 |
sub Start(%) |
46 |
{ |
47 |
my %conf = @_; |
48 |
|
49 |
my $q = new CGI; |
50 |
my $user = ''; |
51 |
my $cookie; |
52 |
|
53 |
# %s is the session global state, so that we don't have |
54 |
# to pass everything as single arguments to each sub |
55 |
my %s = ( cgi => $q); |
56 |
|
57 |
# store the session state in the global state for the Die handler |
58 |
# \%s should be passed normally as argument... |
59 |
$g{s}=\%s; |
60 |
|
61 |
# install Gedafe's die handler |
62 |
$SIG{__DIE__}=\&Die; #}} |
63 |
if(defined $q->url_param('reload')) { |
64 |
%g = (); |
65 |
} |
66 |
|
67 |
# configuration |
68 |
if(not exists $g{conf}) { |
69 |
# defaults |
70 |
$g{conf} = { |
71 |
list_rows => 10, |
72 |
tickets_socket => '/tmp/.gedafed.sock', |
73 |
gedafe_compat => '1.2', |
74 |
}; |
75 |
|
76 |
# init config |
77 |
while(my ($k, $v) = each %conf) { |
78 |
$g{conf}{$k}=$v; |
79 |
} |
80 |
|
81 |
# test mandatory arguments |
82 |
my @mandatory = ('templates', 'db_datasource'); |
83 |
for my $m (@mandatory) { |
84 |
defined $g{conf}{$m} or |
85 |
die "ERROR: '$m' named argument must be defined in Start.\n"; |
86 |
} |
87 |
} |
88 |
|
89 |
|
90 |
$s{url} = MyURL($q); |
91 |
$q->url(-absolute=>1) =~ /(.*)\/([^\/]*)/; |
92 |
$s{path} = $1; $s{script} = $2; |
93 |
$s{ticket_name} = "Ticket_$2"; $s{ticket_name} =~ s/\./_/g; |
94 |
|
95 |
my $expires = defined $q->url_param('refresh') ? '+5m' : '-1d'; |
96 |
|
97 |
InitTemplate("$g{conf}{templates}",".html"); |
98 |
|
99 |
InitPearls($g{conf}{pearl_dir}) if defined $g{conf}{pearl_dir}; |
100 |
|
101 |
if(defined $q->url_param('reload')) { |
102 |
my $next_refresh=NextRefresh(); |
103 |
print $q->header(-expires=>'-1d'); |
104 |
print Template({ |
105 |
PAGE => 'reload', |
106 |
ELEMENT => 'reload', |
107 |
THISURL => MyURL($q), |
108 |
NEXTURL => MakeURL(MyURL($q), { reload=>'', refresh=>$next_refresh }), |
109 |
}); |
110 |
exit; |
111 |
} |
112 |
|
113 |
GUI_CheckFormID(\%s, $user); |
114 |
|
115 |
my $ticket_value; |
116 |
my $dbh = AuthConnect(\%s, \$user, \$cookie,\$ticket_value) or do { |
117 |
die "Couldn't connect to database or database error"; |
118 |
}; |
119 |
|
120 |
$s{dbh}=$dbh; |
121 |
$s{user}=$user; |
122 |
$s{ticket_value}=$ticket_value; |
123 |
# print STDERR "TicketValue: $ticket_value\n"; |
124 |
|
125 |
my $action = $q->url_param('action') || ''; |
126 |
if($action eq 'edit' or $action eq 'add' or $action eq 'delete') { |
127 |
# cache forms... |
128 |
$expires = '+1d'; |
129 |
} |
130 |
if($q->request_method() eq 'POST') { |
131 |
# do not cache POST requests, so that for "Duplicate Form" is |
132 |
# shown if needed... |
133 |
$expires = '-1d'; |
134 |
} |
135 |
|
136 |
if($action eq 'export') { |
137 |
my $table = $q->url_param('table'); |
138 |
GUI_Export(\%s, $user, $dbh); |
139 |
exit; |
140 |
} |
141 |
|
142 |
my %headers =(-expires=>$expires); |
143 |
|
144 |
if($cookie) { |
145 |
$headers{-cookie} = $cookie; |
146 |
} |
147 |
|
148 |
if($action eq 'dumpblob'){ |
149 |
my $table = $q->param('table'); |
150 |
my $id = $q->param('id'); |
151 |
my $field = $q->param('field'); |
152 |
my $type = DB_GetBlobType($dbh,$table,$field,$id); |
153 |
my $name = DB_GetBlobName($dbh,$table,$field,$id); |
154 |
$headers{-type}=$type; |
155 |
$headers{-attachment}=$name; |
156 |
} |
157 |
if($action eq 'dumptable') { |
158 |
$headers{-type}='text/plain'; |
159 |
} |
160 |
|
161 |
if ($action eq 'runpearl') { |
162 |
my $pearl = $q->url_param('pearl'); |
163 |
Die "No Pearl named $pearl available" unless |
164 |
defined $g{pearls}{$pearl} and ref $g{pearls}{$pearl}; |
165 |
my($h,$b) =$g{pearls}{$pearl}->run(\%s); |
166 |
die "Sorry. The Pearl '$pearl' did not return any data.". |
167 |
"<br>You can use the BACK button!\n" |
168 |
if $b =~ /^\s*$/; |
169 |
$headers{-type}=$h; |
170 |
$headers{-length} = length $b; |
171 |
print $q->header(%headers); |
172 |
print $b; |
173 |
$dbh->disconnect; |
174 |
return; |
175 |
} |
176 |
|
177 |
|
178 |
print $q->header(%headers); |
179 |
$s{http_header_sent}=1; |
180 |
|
181 |
GUI_PostEdit(\%s, $user, $dbh); |
182 |
|
183 |
if($action eq 'list' or $action eq 'listrep') { |
184 |
GUI_List(\%s, $user, $dbh); |
185 |
} |
186 |
elsif($action eq 'edit' or $action eq 'add' or $action eq 'reedit') { |
187 |
GUI_Edit(\%s, $user, $dbh); |
188 |
} |
189 |
elsif($action eq 'configpearl') { |
190 |
GUI_Pearl(\%s); |
191 |
} |
192 |
elsif($action eq 'delete') { |
193 |
GUI_Delete(\%s, $user, $dbh); |
194 |
} |
195 |
elsif($action eq 'dumpblob'){ |
196 |
my $table = $q->param('table'); |
197 |
my $id = $q->param('id'); |
198 |
my $field = $q->param('field'); |
199 |
DB_DumpBlob($dbh,$table,$field,$id); |
200 |
} |
201 |
elsif($action eq 'dumptable'){ |
202 |
my $table = $q->url_param('table'); |
203 |
GUI_DumpTable(\%s, $user, $dbh); |
204 |
} |
205 |
else { |
206 |
GUI_Entry(\%s, $user, $dbh); |
207 |
} |
208 |
|
209 |
$dbh->disconnect; |
210 |
} |
211 |
|
212 |
|
213 |
1; |
214 |
|
215 |
# Emacs Configuration |
216 |
# |
217 |
# Local Variables: |
218 |
# mode: cperl |
219 |
# eval: (cperl-set-style "BSD") |
220 |
# cperl-indent-level: 8 |
221 |
# mode: flyspell |
222 |
# mode: flyspell-prog |
223 |
# End: |
224 |
# |
225 |
|