Annotation of /FigWebServices/HOPSS.cgi

Revision 1.2 - (view) (download)

1 :	overbeek	1.1	# -- perl --
2 :
3 :			use FIG;
4 :			my $fig = new FIG;
5 :
6 :			use URI::Escape; # uri_escape()
7 :			use HTML;
8 :			use CGI;
9 :
10 :			my $cgi = new CGI;
11 :			if (0)
12 :			{
13 :			my $VAR1;
14 :			eval(join("",`cat /tmp/hopss_parms`));
15 :			$cgi = $VAR1;
16 :			# print STDERR &Dumper($cgi);
17 :			}
18 :
19 :			if (0)
20 :			{
21 :			print $cgi->header;
22 :			my @params = $cgi->param;
23 :			print "<pre>\n";
24 :			foreach $_ (@params)
25 :			{
26 :			print "$_\t:",join(",",$cgi->param($_)),":\n";
27 :			}
28 :
29 :			if (0)
30 :			{
31 :			if (open(TMP,">/tmp/hopss_parms"))
32 :			{
33 :			print TMP &Dumper($cgi);
34 :			close(TMP);
35 :			}
36 :			}
37 :			exit;
38 :			}
39 :
40 :			my $html = [];
41 :			push @$html, "<TITLE>HOPSS</TITLE>\n";
42 :
43 :			my $request = $cgi->param('request');
44 :
45 :			if (! $request)
46 :			{
47 :			push(@$html,$cgi->br,
48 :			$cgi->h1("Welcome to <a href=Html/about_HOPSS.html target=help>HOPSS</a> database"),$cgi->br,
49 :			$cgi->h2("A Public Depository of Open Problems and Conjectures Identified by SubSystem analysis"),
50 :	overbeek	1.2	"<br><br>"
51 :	overbeek	1.1	);
52 :
53 :			push(@$html,&summary($fig,$cgi));
54 :			push(@$html, $cgi->hr,
55 :	overbeek	1.2	"<a href=HOPSS.cgi?request=new_problem>New Problem</a>\n<br><br><br><hr>",
56 :			"This site was inspired by the events surrounding the <a href=http://www-groups.dcs.st-and.ac.uk/~history/HistTopics/Scottish_Book.html>Scottish book</a> and the impact that it made upon mathematics. If you wish
57 :			to know more about that topic, ask Rick or Ross over beers.\n"
58 :	overbeek	1.1	);
59 :			}
60 :			else
61 :			{
62 :			if ($request eq "new_problem")
63 :			{
64 :			&add_problem_form($fig,$cgi,$html),
65 :			}
66 :			elsif ($request eq "add_problem")
67 :			{
68 :			&add_problem($fig,$cgi,$html);
69 :			push(@$html,$cgi->h1('added'));
70 :			push(@$html,&summary($fig,$cgi));
71 :			push(@$html, $cgi->hr,
72 :			"<a href=HOPSS.cgi?request=new_problem>New Problem</a>\n"
73 :			);
74 :			}
75 :			elsif (($request eq "show_problem") && ($problem = $cgi->param('problem')))
76 :			{
77 :			&show_problem($fig,$cgi,$html,$problem);
78 :			}
79 :			elsif (($request eq "update_problem") && ($problem = $cgi->param('problem')))
80 :			{
81 :			&update_problem($fig,$cgi,$html,$problem);
82 :			}
83 :			}
84 :			&HTML::show_page($cgi,$html);
85 :
86 :			sub show_problem {
87 :			my($fig,$cgi,$html,$problem) = @_;
88 :
89 :			&load_form($fig,$cgi,$problem);
90 :			&update_form($fig,$cgi,$html,$problem);
91 :			}
92 :
93 :			sub load_form {
94 :			my($fig,$cgi,$problem) = @_;
95 :
96 :			my $kv = &read_problem($problem);
97 :			foreach $name (keys(%$kv))
98 :			{
99 :			my $val = $kv->{$name};
100 :			$cgi->param(-name => $name, -value => $val);
101 :			}
102 :			}
103 :
104 :			sub update_problem {
105 :			my($fig,$cgi,$html,$problem) = @_;
106 :
107 :			&write_problem($cgi,$problem);
108 :			&update_form($fig,$cgi,$html,$problem);
109 :			}
110 :
111 :			sub update_form {
112 :			my($fig,$cgi,$html,$problem) = @_;
113 :
114 :
115 :			my(@types) = ('Missing gene for a role',
116 :			'Gene in subsystem without clear role',
117 :			'Role out of context',
118 :			'Missing input/output',
119 :			'Functionally coupled hypothetical',
120 :			'Orphan chromosomal cluster',
121 :			'Unresolved paralogs',
122 :			'other');
123 :
124 :			my $type = &parameter($cgi,"type");
125 :			my $title = &parameter($cgi,'title');
126 :			my $subsystem = &parameter($cgi,'subsystem');
127 :			my $who = &parameter($cgi,'who');
128 :			my $description = &parameter($cgi,'description');
129 :
130 :			my @conjectures = grep { $_ } &parameter($cgi,'conjecture');
131 :			my @comments = grep { $_ } &parameter($cgi,'comment');
132 :
133 :			push(@$html,$cgi->start_form(-action => "HOPSS.cgi", -method => 'post'),
134 :			$cgi->hidden(-name => 'request', -value => 'update_problem', -override => 1),
135 :			$cgi->hidden(-name => 'subsystem', -value => $subsystem, -override => 1),
136 :			$cgi->hidden(-name => 'problem', -value => $problem, -override => 1),
137 :			$cgi->br,
138 :			$cgi->br,
139 :			$cgi->br,
140 :			"<a href=Html/HOPSS_type.html target=help><b>Help on How to Pick Types</b></a>\n",
141 :			$cgi->br,
142 :			$cgi->scrolling_list(-name => 'type', -values => \@types, -default => $type, -size => 5),
143 :			$cgi->br,
144 :			$cgi->br,
145 :			$cgi->br,
146 :			'Title: ',$cgi->textfield(-name => 'title', -default => $title, -size=>60),
147 :			$cgi->br,
148 :			$cgi->br,
149 :			"Subsystem: $subsystem <br><br>\n",
150 :			$cgi->br,
151 :			$cgi->br,
152 :			'Your Name: ',$cgi->textfield(-name => 'who', -default => $who, -size=>60),
153 :			$cgi->br,
154 :			$cgi->br,
155 :			# 'Approximate number of genomes: ',$cgi->textfield(-name => 'num_genomes', -default => '', -size=>60),
156 :			# $cgi->br,
157 :			# $cgi->br,
158 :			'Description of the Problem',
159 :			$cgi->br,
160 :			$cgi->br,
161 :			$cgi->textarea(-name => 'description', -rows => 20, -cols => 100, -value => $description),
162 :			$cgi->br,
163 :			$cgi->br
164 :			);
165 :			foreach $_ (@conjectures,'')
166 :			{
167 :			push(@$html,"Conjecture: ",$cgi->br,
168 :			$cgi->textarea(-name => 'conjecture', -rows => 20, -cols => 100, -value => $_, -override => 1),
169 :			$cgi->br,
170 :			$cgi->br
171 :			);
172 :			}
173 :
174 :			foreach $_ (@comments,'')
175 :			{
176 :			push(@$html,"Comment: ",$cgi->br,
177 :			$cgi->textarea(-name => 'comment', -rows => 20, -cols => 100, -value => $_, -override => 1),
178 :			$cgi->br,
179 :			$cgi->br
180 :			);
181 :			}
182 :
183 :			push(@$html,
184 :			$cgi->submit('Update the Problem'),
185 :			$cgi->end_form
186 :			);
187 :			}
188 :
189 :
190 :
191 :			sub summary {
192 :			my($fig,$cgi) = @_;
193 :
194 :			my @existing = &problems;
195 :			if (@existing > 0)
196 :			{
197 :			my $col_hdrs = ['title','subsystem','type','timestamp','who','conjectures','comments'];
198 :			my $tab = [];
199 :
200 :			my $problem;
201 :			foreach $problem (@existing)
202 :			{
203 :			$kv = &read_problem($problem );
204 :
205 :			push(@$tab,[
206 :			&problem_link($cgi,&title($kv),$problem),
207 :			&subsystem($kv),
208 :			&type($kv),
209 :			&time_of_creation($kv),
210 :			&who($kv),
211 :			&num_conjectures($kv),
212 :			&num_comments($kv)
213 :			]);
214 :			}
215 :			return &HTML::make_table($col_hdrs,[sort { ($a->[1] cmp $b->[1]) } @$tab],"Summary of Existing Problems and Conjectures");
216 :			}
217 :			else
218 :			{
219 :			return $cgi->br;
220 :			}
221 :			}
222 :
223 :			sub problem_link {
224 :			my($cgi,$title,$problem) = @_;
225 :
226 :			return "<a href=HOPSS.cgi?request=show_problem&problem=$problem>$title</a>\n";
227 :			}
228 :
229 :			sub type {
230 :			my($kv) = @_;
231 :
232 :			return $kv->{'type'}->[0];
233 :			}
234 :
235 :			sub time_of_creation {
236 :			my($kv) = @_;
237 :
238 :			return $fig->epoch_to_readable($kv->{'time_of_creation'}->[0]);
239 :			}
240 :
241 :			sub title {
242 :			my($kv) = @_;
243 :
244 :			return $kv->{'title'}->[0];
245 :			}
246 :
247 :			sub subsystem {
248 :			my($kv) = @_;
249 :
250 :			return $kv->{'subsystem'}->[0];
251 :			}
252 :
253 :			sub who {
254 :			my($kv) = @_;
255 :
256 :			return $kv->{'who'}->[0];
257 :			}
258 :
259 :			sub num_conjectures {
260 :			my($kv) = @_;
261 :
262 :			my $x = @{$kv->{'conjecture'}};
263 :			return $x ? scalar @$x : 0;
264 :			}
265 :
266 :			sub num_comments {
267 :			my($kv) = @_;
268 :
269 :			my $x = @{$kv->{'comment'}};
270 :			return $x ? scalar @$x : 0;
271 :			}
272 :
273 :			sub read_problem {
274 :			my($problem) = @_;
275 :
276 :			my $kv = undef;
277 :			if (open(PROB,"<$FIG_Config::data/HOPSS/$problem/problem"))
278 :			{
279 :			$/ = "\n//\n";
280 :			while ($_ = <PROB>)
281 :			{
282 :			chomp;
283 :			if ($_ =~ /^(\S+)\n(.*)/s)
284 :			{
285 :			push(@{$kv->{$1}},$2);
286 :			}
287 :			}
288 :			$/ = "\n";
289 :			close(PROB);
290 :			}
291 :			return $kv;
292 :			}
293 :
294 :			sub add_problem {
295 :			my($fig,$cgi,$html) = @_;
296 :
297 :			&FIG::verify_dir("$FIG_Config::data/HOPSS");
298 :
299 :			my @existing = &problems;
300 :			my $new_prob = &next_id(\@existing);
301 :			&write_problem($cgi,$new_prob);
302 :			}
303 :
304 :			sub write_problem {
305 :			my($cgi,$new_prob) = @_;
306 :
307 :			&FIG::verify_dir("$FIG_Config::data/HOPSS/$new_prob");
308 :			if (-s "$FIG_Config::data/HOPSS/$new_prob/problem")
309 :			{
310 :			my $timestamp = time;
311 :			rename("$FIG_Config::data/HOPSS/$new_prob/problem",
312 :			"$FIG_Config::data/HOPSS/$new_prob/Backup/problem.$timestamp");
313 :			}
314 :			&FIG::verify_dir("$FIG_Config::data/HOPSS/$new_prob/Backup");
315 :			open(NEW,">$FIG_Config::data/HOPSS/$new_prob/problem")
316 :			\|\| die "could not open $FIG_Config::data/HOPSS/$new_prob/problem";
317 :
318 :			my $type = &parameter($cgi,'type');
319 :			my $title = &parameter($cgi,'title');
320 :			my $subsystem = &parameter($cgi,'subsystem');
321 :			my $who = &parameter($cgi,'who');
322 :			# my $num_genomes = &parameter($cgi,'num_genomes');
323 :			my $description = &parameter($cgi,'description');
324 :			my @conjectures = grep { $_ } &parameter($cgi,'conjecture');
325 :			my @comments = grep { $_ } &parameter($cgi,'comment');
326 :
327 :			print NEW "ID\n$new_prob\n//\n";
328 :
329 :			print NEW "time_of_creation\n",time,"\n//\n";
330 :			print NEW "type\n$type\n//\n";
331 :			print NEW "title\n$title\n//\n";
332 :			print NEW "subsystem\n$subsystem\n//\n";
333 :			print NEW "who\n$who\n//\n";
334 :			# print NEW "num_genomes\n$num_genomes\n//\n";
335 :			print NEW "description\n$description\n//\n";
336 :			foreach $_ (@conjectures)
337 :			{
338 :			print NEW "conjecture\n$_\n//\n";
339 :			}
340 :
341 :			foreach $_ (@comments)
342 :			{
343 :			print NEW "comment\n$_\n//\n";
344 :			}
345 :			close(NEW);
346 :			}
347 :
348 :			sub problems {
349 :
350 :			my @existing = ();
351 :			if (opendir(HOPSS,"$FIG_Config::data/HOPSS"))
352 :			{
353 :			@existing = grep { $_ !~ /^\./ } readdir(HOPSS);
354 :			closedir(HOPSSS);
355 :			}
356 :			return @existing;
357 :			}
358 :
359 :			sub next_id {
360 :			my($existing) = @_;
361 :
362 :			my $max = 0;
363 :			foreach $_ (@$existing)
364 :			{
365 :			$max = &FIG::max($max,$_);
366 :			}
367 :			return $max+1;
368 :			}
369 :
370 :			sub parameter {
371 :			my($cgi,$name) = @_;
372 :
373 :			if (wantarray)
374 :			{
375 :			my @val = $cgi->param($name);
376 :			if (@val > 0)
377 :			{
378 :			foreach $_ (@val)
379 :			{
380 :			$_ =~ s/ /\n/g;
381 :			}
382 :			}
383 :			else
384 :			{
385 :			@val = ();
386 :			}
387 :			return @val;
388 :			}
389 :			else
390 :			{
391 :			my $val = $cgi->param($name);
392 :			$val = $val ? $val : "";
393 :			$val =~ s/ /\n/g;
394 :			return $val;
395 :			}
396 :			}
397 :
398 :			sub add_problem_form {
399 :			my($fig,$cgi,$html) = @_;
400 :
401 :			my(@types) = ('Missing gene for a role',
402 :			'Gene in subsystem without clear role',
403 :			'Role out of context',
404 :			'Missing input/output',
405 :			'Functionally coupled hypothetical',
406 :			'Orphan chromosomal cluster',
407 :			'Unresolved paralogs',
408 :			'other');
409 :
410 :			my @subsystems = sort { uc $a cmp uc $b } $fig->all_subsystems;
411 :
412 :			push(@$html,$cgi->h1("Please fill in the relevant fileds"),
413 :			$cgi->start_form(-action => "HOPSS.cgi", -method => 'post'),
414 :			$cgi->hidden(-name => 'request', -value => 'add_problem', -override => 1),
415 :			$cgi->scrolling_list(-name => 'type', -values => \@types, -size => 5),
416 :			$cgi->br,
417 :			$cgi->br,
418 :			$cgi->br,
419 :			'Title: ',$cgi->textfield(-name => 'title', -default => '', -size=>60),
420 :			$cgi->br,
421 :			$cgi->br,
422 :			$cgi->scrolling_list(-name => 'subsystem', -values => \@subsystems, -size => 5),
423 :			$cgi->br,
424 :			$cgi->br,
425 :			'Your Name: ',$cgi->textfield(-name => 'who', -default => '', -size=>60),
426 :			$cgi->br,
427 :			$cgi->br,
428 :			# 'Approximate number of genomes: ',$cgi->textfield(-name => 'num_genomes', -default => '', -size=>60),
429 :			# $cgi->br,
430 :			# $cgi->br,
431 :			'Description of the Problem',
432 :			$cgi->br,
433 :			$cgi->br,
434 :			$cgi->textarea(-name => 'description', -rows => 20, -cols => 100, -value => ''),
435 :			$cgi->br,
436 :			$cgi->br,
437 :			$cgi->submit('Add the Problem'),
438 :			$cgi->end_form
439 :			);
440 :			}
441 :

MCS Webmaster	ViewVC Help
Powered by ViewVC 1.0.3