[Bio] / FigWebServices / HOPSS.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/HOPSS.cgi

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3