/[gedafe]/trunk/lib/perl/Gedafe/Start.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/Start.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (show annotations)
Sun May 8 15:01:05 2005 UTC (18 years, 10 months ago) by dpavlin
File size: 5005 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::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;
117
118 if ($g{conf}{preauth_user}) {
119 use Gedafe::DB qw(DB_Connect);
120 $dbh = DB_Connect($g{conf}{preauth_user},($g{conf}{preauth_passwd} || ''));
121 $user = $g{conf}{preauth_user};
122 } else {
123 $dbh = AuthConnect(\%s, \$user, \$cookie,\$ticket_value) or do {
124 die "Couldn't connect to database or database error";
125 };
126 }
127
128 $s{dbh}=$dbh;
129 $s{user}=$user;
130 $s{ticket_value}=$ticket_value;
131 # print STDERR "TicketValue: $ticket_value\n";
132
133 my $action = $q->url_param('action') || '';
134 if($action eq 'edit' or $action eq 'add' or $action eq 'delete') {
135 # cache forms...
136 $expires = '+1d';
137 }
138 if($q->request_method() eq 'POST') {
139 # do not cache POST requests, so that for "Duplicate Form" is
140 # shown if needed...
141 $expires = '-1d';
142 }
143
144 if($action eq 'export') {
145 my $table = $q->url_param('table');
146 GUI_Export(\%s, $user, $dbh);
147 exit;
148 }
149
150 my %headers =(-expires=>$expires);
151
152 if($cookie) {
153 $headers{-cookie} = $cookie;
154 }
155
156 if($action eq 'dumpblob'){
157 my $table = $q->param('table');
158 my $id = $q->param('id');
159 my $field = $q->param('field');
160 my $type = DB_GetBlobType($dbh,$table,$field,$id);
161 my $name = DB_GetBlobName($dbh,$table,$field,$id);
162 $headers{-type}=$type;
163 $headers{-attachment}=$name;
164 }
165 if($action eq 'dumptable') {
166 $headers{-type}='text/plain';
167 }
168
169 if ($action eq 'runpearl') {
170 my $pearl = $q->url_param('pearl');
171 Die "No Pearl named $pearl available" unless
172 defined $g{pearls}{$pearl} and ref $g{pearls}{$pearl};
173 my($h,$b) =$g{pearls}{$pearl}->run(\%s);
174 die "Sorry. The Pearl '$pearl' did not return any data.".
175 "<br>You can use the BACK button!\n"
176 if $b =~ /^\s*$/;
177 $headers{-type}=$h;
178 $headers{-length} = length $b;
179 print $q->header(%headers);
180 print $b;
181 $dbh->disconnect;
182 return;
183 }
184
185
186 print $q->header(%headers);
187 $s{http_header_sent}=1;
188
189 GUI_PostEdit(\%s, $user, $dbh);
190
191 if($action eq 'list' or $action eq 'listrep') {
192 GUI_List(\%s, $user, $dbh);
193 }
194 elsif($action eq 'edit' or $action eq 'add' or $action eq 'reedit') {
195 GUI_Edit(\%s, $user, $dbh);
196 }
197 elsif($action eq 'configpearl') {
198 GUI_Pearl(\%s);
199 }
200 elsif($action eq 'delete') {
201 GUI_Delete(\%s, $user, $dbh);
202 }
203 elsif($action eq 'dumpblob'){
204 my $table = $q->param('table');
205 my $id = $q->param('id');
206 my $field = $q->param('field');
207 DB_DumpBlob($dbh,$table,$field,$id);
208 }
209 elsif($action eq 'dumptable'){
210 my $table = $q->url_param('table');
211 GUI_DumpTable(\%s, $user, $dbh);
212 }
213 else {
214 GUI_Entry(\%s, $user, $dbh);
215 }
216
217 $dbh->disconnect;
218 }
219
220
221 1;
222
223 # Emacs Configuration
224 #
225 # Local Variables:
226 # mode: cperl
227 # eval: (cperl-set-style "BSD")
228 # cperl-indent-level: 8
229 # mode: flyspell
230 # mode: flyspell-prog
231 # End:
232 #
233

  ViewVC Help
Powered by ViewVC 1.1.26