[Bio] / FigKernelPackages / Construct.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/Construct.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (view) (download) (as text)

1 : olson 1.1 #
2 : olson 1.2 # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 :     #
7 :     # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 :     # Public License.
10 :     #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 :     #
19 : olson 1.1 # Subsystem construct utilities.
20 :     #
21 :    
22 :     package Construct;
23 :     use strict;
24 :    
25 :     use Exporter;
26 :     use base qw(Exporter);
27 :    
28 :     use vars qw(@EXPORT_OK);
29 :    
30 :     @EXPORT_OK = qw(validate_constructs get_constructs_from_form
31 :     make_html write_constructs_file parse_constructs_file);
32 :    
33 :     #
34 :     # Walk a constructs list.
35 :     #
36 :     # For each require element check to see
37 :     # if it is a role reference (if it is a number) or if it
38 :     # is a construct name, in which case it should not overlap with
39 :     # an active role in the subsystem or any of its aliases.
40 :     #
41 :     sub validate_constructs
42 :     {
43 :     my($cons, $sub, $errs) = @_;
44 :    
45 :     my %construct_names;
46 :    
47 :     #
48 :     # Scan once and fill in the list of construct names.
49 :     #
50 :    
51 :     for my $con_ent (@$cons)
52 :     {
53 :     my($name, $req_list) = @$con_ent;
54 :    
55 :     #
56 :     # Ensure construct names aren't role names.
57 :     #
58 :    
59 :     if (defined($sub->get_role_index($name)))
60 :     {
61 :     push(@$errs, "Construct name <i>$name</i> is also a role name.");
62 :     }
63 :     elsif (defined(my $r = $sub->get_role_from_abbr($name)))
64 :     {
65 :     push(@$errs, "Construct name <i>$name</i> is a role abbreviation for <i>$r</i>.");
66 :     }
67 :     else
68 :     {
69 :     $construct_names{$name}++;
70 :     }
71 :     }
72 :    
73 :     #
74 :     # Scan again and walk the requires lists and validate them.
75 :     #
76 :    
77 :     for my $con_ent (@$cons)
78 :     {
79 :     my($name, $req_list) = @$con_ent;
80 :    
81 :     for my $req (@$req_list)
82 :     {
83 :     my ($type, $req_name) = @$req;
84 :    
85 :     #
86 :     # See if $req_name is numeric and matches a role.
87 :     #
88 :    
89 :     if ($req_name =~ /^\d+$/)
90 :     {
91 :     my $role = $sub->get_role($req_name - 1);
92 :    
93 :     if ($role)
94 :     {
95 :     $req->[0] = 'R';
96 :     $req->[1] = $sub->get_role_abbr($req_name - 1);
97 :     $req->[2] = $role;
98 :     }
99 :     else
100 :     {
101 :     $req->[0] = 'R';
102 :     $req->[1] = '*' . $req_name;
103 :     $req->[2] = undef;
104 :     }
105 :     }
106 :     else
107 :     {
108 :     #
109 :     # otherwise, it can be a construct, role, or role alias
110 :     #
111 :    
112 :     my $role = $sub->get_role_from_abbr($req_name);
113 :    
114 :     if (defined($role))
115 :     {
116 :     my $idx;
117 :     $idx = $sub->get_role_index($role);
118 :     if (defined($idx))
119 :     {
120 :     $req->[0] = 'R';
121 :     $req->[2] = $role;
122 :     }
123 :     else
124 :     {
125 :     #
126 :     # This shouldn't happen.
127 :     #
128 :    
129 :     warn "construct.cgi: heap big error in subsystem data\n";
130 :     $req->[0] = 'X';
131 :     $req->[2] = undef;
132 :     push(@$errs, "Spreadsheet data may be corrupted: Role $role found from abbr $req_name did not have an index");
133 :     }
134 :     }
135 :     else
136 :     {
137 :     #
138 :     # Not a role or abbreviation. See if it's a construct name.
139 :     #
140 :     if (defined($construct_names{$req_name}))
141 :     {
142 :     $req->[0] = 'C';
143 :     }
144 :     else
145 :     {
146 :     $req->[0] = 'X';
147 :     push(@$errs, "Requirement element <i>$req_name</i> in construct <i>$name</i> is not a role abbreviation or construct name");
148 :     }
149 :     }
150 :     }
151 :     }
152 :     }
153 :    
154 :     return (@$errs == 0);
155 :     }
156 :    
157 :     sub get_constructs_from_form
158 :     {
159 :     my($cgi) = @_;
160 :    
161 :     my $row_idx = 0;
162 :    
163 :     my(@ret);
164 :    
165 :     while (1)
166 :     {
167 :     my $name = $cgi->param("construct_name_$row_idx");
168 :     my $req_str = $cgi->param("construct_req_$row_idx");
169 :    
170 :     last unless defined($name);
171 :    
172 :     $name =~ s/^\s+//;
173 :     $name =~ s/\s+$//;
174 :    
175 :     if ($name ne '')
176 :     {
177 :    
178 :     my $reqs = [];
179 :     for my $req (split(/,/, $req_str))
180 :     {
181 :     $req =~ s/^\s+//;
182 :     $req =~ s/\s+$//;
183 :     push(@$reqs, [undef, $req]);
184 :     }
185 :     push(@ret, [$name, $reqs]);
186 :     }
187 :     $row_idx++;
188 :     }
189 :     return @ret;
190 :     }
191 :    
192 :     sub make_html
193 :     {
194 :     my($cons, $cgi) = @_;
195 :    
196 :     my(@table, @ext_cons);
197 :    
198 :     my $row_idx = 0;
199 :    
200 :     @ext_cons = @$cons;
201 :     my $n_blanks = 5;
202 :     for (1..$n_blanks)
203 :     {
204 :     push(@ext_cons, ['', []]);
205 :     }
206 :    
207 :     for my $con_ent (@ext_cons)
208 :     {
209 :     my($name, $req_list) = @$con_ent;
210 :    
211 :     my $row = [];
212 :    
213 :     push(@$row, $cgi->textfield(-name => "construct_name_$row_idx",
214 :     -override => 1,
215 :     -value => $name));
216 :    
217 :     my(@name_strings);
218 :     for my $req (@$req_list)
219 :     {
220 :     my ($type, $req_name) = @$req;
221 :    
222 :     #
223 :     # For now, just use the name from the file.
224 :     # Eventually, we'll do lookups from role # -> name,
225 :     # etc. (though no row #s in saved files).
226 :     #
227 :     push(@name_strings, $req_name);
228 :     }
229 :    
230 :     push(@$row, $cgi->textfield(-name => "construct_req_$row_idx",
231 :     -override => 1,
232 :     -value => join(", ", @name_strings),
233 :     -size => 80));
234 :     push(@table, $row);
235 :     $row_idx++;
236 :     }
237 :    
238 :     return HTML::make_table(["Construct Name", "Requires"],
239 :     \@table,
240 :     "Constructs");
241 :     }
242 :    
243 :     sub write_constructs_file
244 :     {
245 :     my($cons, $file) = @_;
246 :    
247 :     my($fh);
248 :    
249 :     open($fh, ">$file") or die "Cannot write $file: $!\n";
250 :    
251 :     for my $con_ent (@$cons)
252 :     {
253 :     my($name, $req_list) = @$con_ent;
254 :    
255 :     print $fh "$name\n";
256 :     for my $req (@$req_list)
257 :     {
258 :     my ($type, $req_name, $role_name) = @$req;
259 :    
260 :     if ($type eq "R")
261 :     {
262 :     print $fh "$type $role_name\n";
263 :     }
264 :     elsif ($type eq "C")
265 :     {
266 :     print $fh "$type $req_name\n";
267 :     }
268 :     }
269 :    
270 :     print $fh "//\n";
271 :     }
272 :     close($fh);
273 :     }
274 :    
275 :    
276 :     sub parse_constructs_file
277 :     {
278 :     my($file, $sub) = @_;
279 :    
280 :     my($fh);
281 :    
282 :     if (!open($fh, "<$file"))
283 :     {
284 :     die "Cannot open $file: $!\n";
285 :     }
286 :    
287 :     local($/);
288 :    
289 :     $/ = "//\n";
290 :    
291 :     my(@ret);
292 :    
293 :     while (<$fh>)
294 :     {
295 :     chomp $_;
296 :     next if $_ eq '';
297 :     my($name, @reqs) = split(/\n/, $_);
298 :    
299 :     my $reqlist = [];
300 :    
301 :     foreach my $req (@reqs)
302 :     {
303 :     my($type, $rname) = split(/\s+/, $req, 2);
304 :     my $abbr;
305 :    
306 :     $rname =~ s/\s+$//;
307 :    
308 :     if ($type eq "R")
309 :     {
310 :     my $idx = $sub->get_role_index($rname);
311 :     if (defined($idx))
312 :     {
313 :     $abbr = $sub->get_role_abbr($idx);
314 :     }
315 :     else
316 :     {
317 :     $abbr = $rname;
318 :     $abbr =~ s/,/_/g;
319 :     }
320 :     push(@$reqlist, [$type, $abbr, $rname]);
321 :     }
322 :     else
323 :     {
324 :     push(@$reqlist, [$type, $rname]);
325 :     }
326 :     }
327 :     push(@ret, [$name, $reqlist]);
328 :     }
329 :     return @ret;
330 :     }
331 :    
332 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3