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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1 package Subsystem;
2 :    
3 : olson 1.25 use Carp;
4 : olson 1.1 use FIG;
5 :    
6 : olson 1.10 use FIGAttributes;
7 :     use base 'FIGAttributes';
8 :    
9 : olson 1.12 use POSIX;
10 : olson 1.7 use DirHandle;
11 : olson 1.1 use Data::Dumper;
12 : olson 1.14 use File::Copy;
13 : olson 1.1 use File::Spec;
14 : olson 1.12 use IPC::Open2;
15 : olson 1.1
16 :     use strict;
17 :    
18 : olson 1.2 =pod
19 :    
20 :     =head1 Subsystem manipulation.
21 :    
22 :     Any manipulation of subsystem data should happen through this interface.
23 :     This allows us to assure ourselves that the relational tables that
24 :     mirror and index the subsystem data are kept up to date with the
25 :     canonical version of the subsystem information in the flat-files
26 :     kept in $FIG_Config::data/Subsystems.
27 :    
28 : olson 1.25 =head2 Objects.
29 :    
30 :     We define the following perl objects:
31 :    
32 :     Subsystem: represents a subsystem. It can be read from disk and
33 :     written to disk, and manipulated via its methods when in memory.
34 :    
35 :     If we were completely on the OO side of the world, we would also
36 :     define the following set of objects. However, we are not, so they are
37 :     only objects in a conceptual sense. They are implemented using the
38 :     basic perl datatypes.
39 :    
40 :     Role: represents a single role. A role has a name and an abbreviation.
41 :    
42 :     RoleSubset: represents a subset of available roles. A subset has a
43 :     name and a list of role names that comprise the subset.
44 :    
45 : olson 1.2 =head2 Thoughts on locking
46 :    
47 :     It is currently dangerous for multiple users to modify spreadsheets at once.
48 :     It will likely remain dangerous while the subsystem backend is fairly
49 :     stateless, as it is with the CGI mechanism.
50 :    
51 :     We'd like to make this a little safer. One mechanism might be to allow
52 :     a user to open a subsystem for modification, and others for readonly access.
53 :     For this to work we have to be able to tell which users is allowed; current
54 :     implementation uses the curator of the subsystem for this purpose.
55 :    
56 :     NB: This module does not currently attempt to handle locking or exclusion.
57 :     It is up to the caller (user application, CGI script, etc) to do so.
58 :     It does attempt to use locking internally where appropriate.
59 :    
60 :     =head2 Data structures
61 :    
62 :     We maintain the following data structures (all members of %$self).
63 :    
64 :     =over 4
65 :    
66 :     =item dir
67 :    
68 :     Directory in which the subsystem is stored.
69 :    
70 :     =item notes
71 :    
72 :     The current notes contents for the subsystem
73 :    
74 :     =item version
75 :    
76 :     Current subsystem version.
77 :    
78 :     =item exchangable
79 :    
80 :     1 if subsystem is exchangable, 0 otherwise.
81 :    
82 :     =item roles
83 :    
84 : olson 1.25 List of role names.
85 : olson 1.2
86 :     =item role_index
87 :    
88 :     hash that maps from role name to index
89 :    
90 :     =item role_abbrs
91 :    
92 :     list of role abbreviations
93 :    
94 :     =item abbr
95 :    
96 :     hash mapping from role abbreviation to role name
97 :    
98 :     =item col_subsets
99 :    
100 :     list of column subset names
101 :    
102 :     =item col_subset_members
103 :    
104 :     hash that maps from column subset name to subset members
105 :    
106 :     =item col_active_subset
107 :    
108 :     currently-active column subset
109 :    
110 :     =item row_active_subset
111 :    
112 :     currently-active row subset
113 :    
114 :     =item genome
115 :    
116 : olson 1.25 List of genome IDs.
117 : olson 1.2
118 :     =item variant_code
119 :    
120 : olson 1.25 List of variant codes.
121 : olson 1.2
122 :     =item genome_index
123 :    
124 :     Hash mapping from genome ID to genome index.
125 :    
126 :     =item spreadsheet
127 :    
128 :     Spreadsheet data. Structured as a list of rows, each of which
129 :     is a list of entries. An entry is a list of PEG numbers.
130 :    
131 :     =item spreadsheet_inv
132 :    
133 :     Inverted structure of spreadsheet - list of columns, each of which is a list
134 :     of rows.
135 :    
136 :     =back
137 :    
138 : olson 1.25 =head2 Methods
139 :    
140 :     =over 4
141 :    
142 :     =item index_cell
143 :    
144 :     Create the subsystem_index entries for the given cell.
145 :     (NEW).
146 :    
147 :     =item delete_role(name)
148 :    
149 :     Delete the given role.
150 :    
151 :     =item add_role(name, abbr)
152 :    
153 :     Add a new role.
154 :    
155 :     =item get_subset(name)
156 :    
157 : overbeek 1.31 A deprecated form of get_subsetC
158 :    
159 :     =item get_subsetC(name)
160 :    
161 : olson 1.25 Returns a given subset. A subset is an object, implemented as a blessed array
162 :     of roles.
163 :    
164 :     =item add_genome(genome_id, variant_code)
165 :    
166 :     =item remove_genome(genome_id)
167 :    
168 :     =back
169 :    
170 : olson 1.2 =cut
171 : olson 1.1
172 :     =pod
173 :    
174 :     =head1 Subsystem constructor
175 :    
176 :     usage: $sub = Subsystem->new("subsystem name", $fig, $createFlag)
177 :    
178 :     Load the subsystem. If it does not exist, and $createFlag is true, create
179 :     a new empty subsystem.
180 :    
181 :     =cut
182 :    
183 :     sub new
184 :     {
185 :     my($class, $name, $fig, $create) = @_;
186 :    
187 :     my $ssa_dir = get_dir_from_name($name);
188 :     #
189 :     # For loading, the subsystem directory must already exist.
190 :     #
191 :    
192 : olson 1.25 if (! -d $ssa_dir and not $create)
193 : olson 1.1 {
194 : olson 1.25 # warn "Subsystem $name does not exist\n";
195 :     return undef;
196 : olson 1.1 }
197 :     my $self = {
198 :     dir => $ssa_dir,
199 :     name => $name,
200 :     fig => $fig,
201 :     };
202 :    
203 :     bless($self, $class);
204 :    
205 : olson 1.25 if ($create)
206 :     {
207 :     $self->create_subsystem();
208 :     }
209 :     else
210 :     {
211 :     $self->load();
212 :     }
213 : olson 1.1
214 :     return $self;
215 :     }
216 :    
217 : olson 1.19 sub new_from_dir
218 :     {
219 :     my($class, $dir, $fig) = @_;
220 :    
221 :     my $ssa_dir = $dir;
222 : olson 1.29 my $name = $dir;
223 :     $name =~ s,.*/,,;
224 : olson 1.19
225 :     #
226 :     # For loading, the subsystem directory must already exist.
227 :     #
228 :    
229 :     my $self = {
230 :     dir => $ssa_dir,
231 :     name => $name,
232 :     fig => $fig,
233 :     };
234 :    
235 :     bless($self, $class);
236 :    
237 :     $self->load();
238 :    
239 :     return $self;
240 :     }
241 :    
242 : olson 1.25 =pod
243 :    
244 :     =head2 create_subsystem()
245 :    
246 :     Create a new subsystem. This creates the subsystem directory in the
247 :     correct place ($FIG_Config::data/Subsystems), and populates it with
248 :     the correct initial data.
249 :    
250 :     =cut
251 :    
252 : olson 1.1 sub create_subsystem
253 :     {
254 : olson 1.25 my($self) = @_;
255 :    
256 :     my $dir = $self->{dir};
257 :     my $fig = $self->{fig};
258 :    
259 :     if (-d $dir)
260 :     {
261 :     warn "Not creating: Subsystem directory $dir already exists";
262 :     return;
263 :     }
264 :    
265 :     $fig->verify_dir($dir);
266 :    
267 :     #
268 :     # Initialize empty data structures.
269 :     #
270 :    
271 :     $self->{genome} = [];
272 :     $self->{genome_index} = {};
273 :     $self->{variant_code} = [];
274 :    
275 :     $self->{abbr} = {};
276 :     $self->{role_index} = {};
277 :     $self->{roles} = [];
278 :     $self->{role_abbrs} = [];
279 : olson 1.1
280 : olson 1.25 $self->{spreadsheet} = [];
281 :     $self->{spreadsheet_inv} = [];
282 :    
283 :     $self->{col_subsets} = [];
284 :     $self->{col_subset_members} = {};
285 :    
286 : overbeek 1.31 $self->{row_subsets} = [];
287 :     $self->{row_subset_members} = {};
288 : overbeek 1.35 $self->load_row_subsets();
289 : overbeek 1.31
290 : olson 1.25 $self->{row_active_subset} = "All";
291 :     $self->{col_active_subset} = "All";
292 :    
293 :     $self->{version} = 0;
294 :     $self->{exchangable} = 0;
295 : overbeek 1.45 $self->{classification} = [];
296 : olson 1.25
297 :     $self->write_subsystem();
298 : olson 1.1 }
299 :    
300 : olson 1.5 #
301 : olson 1.7 # Retrieve the diagrams associated with this subsystem.
302 :     #
303 :     # This is done via a lookup into FIG/Data/SubsystemDiagrams/<ssaname>/<diagram-name>.
304 :     #
305 :     # Returned is a list of names.
306 :     #
307 :    
308 :     sub get_diagrams
309 :     {
310 :     my($self) = @_;
311 :    
312 :     my $b = $self->{name};
313 :     $b =~ s/ /_/g;
314 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b);
315 :    
316 :     my $dh = new DirHandle($dir);
317 :    
318 :     my @names = grep(/^[^.]/, $dh->read());
319 :    
320 :     return @names;
321 :     }
322 :    
323 :     #
324 :     # Return a Subsystem::Diagram object for this diagram.
325 :     #
326 :     sub get_diagram
327 :     {
328 :     my($self, $name) = @_;
329 :    
330 :     my $b = $self->{name};
331 :     $b =~ s/ /_/g;
332 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b, $name);
333 :    
334 :     if (-d $dir)
335 :     {
336 :     return Subsystem::Diagram->new($self, $self->{fig}, $name, $dir);
337 :     }
338 :     else
339 :     {
340 :     return undef;
341 :     }
342 :     }
343 :    
344 :     #
345 : olson 1.5 # Synchronize the database index for this subsystem to the
346 :     # subsystem data.
347 :     #
348 :     # We assume the table already exists.
349 :     #
350 :    
351 :     sub db_sync
352 :     {
353 :     my($self, $skip_delete) = @_;
354 :    
355 :     my $rdbH = $self->{fig}->db_handle();
356 :    
357 :     if (!$skip_delete)
358 :     {
359 : olson 1.25 $self->delete_indices();
360 : olson 1.5 }
361 :    
362 :     #
363 :     # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
364 :     #
365 :    
366 : olson 1.6 my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?)");
367 :    
368 : olson 1.5 for my $role ($self->get_roles())
369 :     {
370 :     my $ridx = $self->get_role_index($role);
371 :     my $col = $self->get_col($ridx);
372 :     for my $cell (@$col)
373 :     {
374 :     if ($cell)
375 :     {
376 :     for my $peg (@$cell)
377 :     {
378 : olson 1.6 $sth->execute($peg, $self->{name}, $role);
379 : olson 1.5 }
380 :     }
381 :     }
382 :     }
383 :     }
384 :    
385 : olson 1.22 #
386 :     # Delete this subsystem's entries from the database index.
387 :     #
388 :     sub delete_indices
389 :     {
390 :     my($self) = @_;
391 :    
392 :     my $rdbH = $self->{fig}->db_handle();
393 :    
394 :     $rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")
395 :     }
396 :    
397 : olson 1.1 sub load
398 :     {
399 :     my($self) = @_;
400 :    
401 :     #
402 :     # Load the subsystem.
403 :     #
404 :    
405 :     my $ssa;
406 :     if (!open($ssa,"<$self->{dir}/spreadsheet"))
407 :     {
408 :     warn "Spreadsheet does not exist in subsystem\n";
409 :     return;
410 :     }
411 :    
412 :     local $/ = "//\n";
413 :    
414 :     my $roles = <$ssa>;
415 :     if ($roles)
416 :     {
417 :     $roles =~ s,$/$,,;
418 :     #
419 :     # Split on newline, filter for non-empty lines.
420 :     #
421 :     my @roles = split("\n", $roles);
422 :    
423 :     @roles = grep { $_ ne "" } @roles;
424 :    
425 :     $self->load_roles(@roles);
426 :     }
427 :    
428 :     my $subsets = <$ssa>;
429 :     if ($subsets)
430 :     {
431 :     $subsets =~ s,$/$,,;
432 :     $self->load_subsets($subsets);
433 :     }
434 :    
435 :     $/ = "\n";
436 :    
437 : overbeek 1.35 $self->load_row_subsets();
438 : olson 1.1 $self->load_genomes($ssa);
439 :    
440 :     #
441 :     # Now load the rest of the info.
442 :     #
443 :    
444 :     $self->load_notes();
445 : redwards 1.44 $self->load_classification();
446 : olson 1.1 $self->load_version();
447 :     $self->load_exchangable();
448 : olson 1.17 $self->load_curation();
449 : olson 1.1 }
450 :    
451 :     sub load_notes
452 :     {
453 :     my($self) = @_;
454 :    
455 :     $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
456 :     }
457 :    
458 : redwards 1.44 sub load_classification
459 :     {
460 :     my($self) = @_;
461 :    
462 :     my $class = &FIG::file_read(File::Spec->catfile($self->{dir}, "CLASSIFICATION"));
463 :     if ($class) {$self->{classification} = [split /\t/, $class]} else {$self->{classification} = ['', '', '']}
464 :     }
465 :    
466 : olson 1.17 sub load_curation
467 :     {
468 :     my($self) = @_;
469 :    
470 : overbeek 1.47 # my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "curation.log"), 1);
471 :     #
472 :     # $_ = $l[0];
473 :     # chomp;
474 : olson 1.17
475 : overbeek 1.47 if (open(LOG,"<$self->{dir}/curation.log"))
476 : olson 1.17 {
477 : overbeek 1.47 while (defined($_ = <LOG>))
478 :     {
479 :     if (/^\d+\t(\S+)\s+started/)
480 :     {
481 :     $self->{curator} = $1;
482 :     }
483 :     }
484 :     close(LOG);
485 : olson 1.17 }
486 :     }
487 :    
488 : olson 1.1 sub load_version
489 :     {
490 :     my($self) = @_;
491 :    
492 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
493 :     my $l = $l[0];
494 :     chomp $l;
495 :     $self->{version} = $l;
496 :     }
497 :    
498 :     sub load_exchangable
499 :     {
500 :     my($self) = @_;
501 :    
502 :     my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");
503 :    
504 :     if (-f $file)
505 :     {
506 :     my($l, @l);
507 :    
508 :     @l = &FIG::file_head($file, 1);
509 :     $l = $l[0];
510 :     chomp $l;
511 :     $self->{exchangable} = $l;
512 :     }
513 :     else
514 :     {
515 :     $self->{exchangable} = 0;
516 :     }
517 :     }
518 :    
519 :    
520 :     sub load_roles
521 :     {
522 :     my($self, @roles) = @_;
523 :    
524 : olson 1.5 $self->{abbr} = {};
525 :     $self->{role_index} = {};
526 :     $self->{roles} = [];
527 :     $self->{role_abbrs} = [];
528 :    
529 : olson 1.25 my $i = 0;
530 : olson 1.1 for my $role (@roles)
531 :     {
532 :     my($abbr, $name) = split(/\t/, $role);
533 : olson 1.2 # print "Role $i: abbr=$abbr name=$name\n";
534 : olson 1.1
535 :     $self->{abbr}->{$abbr} = $name;
536 :     $self->{role_index}->{$name} = $i;
537 :     $self->{roles}->[$i] = $name;
538 : olson 1.4 $self->{role_abbrs}->[$i] = $abbr;
539 : olson 1.1 $i++;
540 :     }
541 :     }
542 :    
543 :     sub load_subsets
544 :     {
545 :     my($self, $subsets) = @_;
546 :    
547 :     #
548 :     # Column and row subsets.
549 :     #
550 :     my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
551 :    
552 :     #
553 :     # Handle column subsets.
554 :     #
555 :    
556 :     my @subsetsC = split(/\n/, $subsetsC);
557 :    
558 :     #
559 :     # Determine active subset.
560 :     #
561 :    
562 :     my $active_subsetC;
563 :     if (@subsetsC > 0)
564 :     {
565 :     $active_subsetC = pop(@subsetsC);
566 :     }
567 :     else
568 :     {
569 :     $active_subsetC = 'All';
570 :     }
571 :    
572 :     $self->{col_active_subset} = $active_subsetC;
573 :    
574 :     $self->{col_subsets} = [];
575 : olson 1.5 $self->{col_subset_members} = {};
576 :    
577 : olson 1.1 for my $subset (@subsetsC)
578 :     {
579 :     my($name, @members) = split(/\s+/, $subset);
580 :    
581 : olson 1.25 #
582 :     # File format has members 1-based.
583 :     #
584 :    
585 :     @members = map { $_ - 1 } @members;
586 :    
587 : olson 1.1 push(@{$self->{col_subsets}}, $name);
588 :    
589 :     #
590 :     # Map role members from name to index if necessary.
591 :     #
592 :     # Is it really necessary? ssa2 code was looking up in %pos for this.
593 :     #
594 :     @members = map {
595 :     if (my $new = $self->{role_index}->{$_})
596 :     {
597 :     $new;
598 :     }
599 :     else
600 :     {
601 :     $_;
602 :     }
603 :     } @members;
604 :    
605 :     @{$self->{col_subset_members}->{$name}} = @members;
606 :     }
607 :    
608 :     #
609 :     # Now the row subsets.
610 :     #
611 :    
612 :     chomp($subsetsR);
613 :    
614 :     if ($subsetsR =~ /(\S+.*\S+)/)
615 :     {
616 : olson 1.25 $self->{row_active_subset} = $1;
617 : olson 1.1 }
618 :     else
619 :     {
620 : olson 1.25 $self->{row_active_subset} = 'All';
621 : olson 1.1 }
622 : overbeek 1.35 $self->{row_subsets} = [];
623 : olson 1.1 }
624 :    
625 :     sub load_genomes
626 :     {
627 :     my($self, $fh) = @_;
628 :     my(%seen);
629 :    
630 : olson 1.5 $self->{spreadsheet} = [];
631 : olson 1.29 $self->{spreadsheet_inv} = [];
632 : olson 1.5 $self->{genome} = [];
633 :     $self->{genome_index} = {};
634 :     $self->{variant_code} = [];
635 :    
636 : olson 1.25 my $nr = @{$self->{roles}};
637 :    
638 :     my $i = 0;
639 : olson 1.1 while (<$fh>)
640 :     {
641 :     chomp;
642 :    
643 : olson 1.25 my($genome, $variant_code, @row) = split(/\t/, $_, $nr + 2);
644 : overbeek 1.46 $variant_code =~ s/ //g;
645 : olson 1.1 next if $seen{$genome};
646 :     $seen{$genome}++;
647 :    
648 : olson 1.25 my $j = 0;
649 : olson 1.1
650 :     $self->{genome}->[$i] = $genome;
651 :     $self->{genome_index}->{$genome} = $i;
652 :     $self->{variant_code}->[$i] = $variant_code;
653 :    
654 : olson 1.25 my $thislen = @row;
655 :    
656 :     # if ($thislen != $nr)
657 :     # {
658 :     # warn "Genome $genome has wrong column count ($thislen != $nr)\n";
659 :     # warn "<$_> $genome $variant_code '", join(":", @row), "'\n";
660 :     # }
661 :    
662 :     for my $j (0..$nr - 1)
663 : olson 1.1 {
664 : olson 1.25 my $entry = $row[$j];
665 : olson 1.1 my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
666 :     $self->{spreadsheet}->[$i]->[$j] = $e2;
667 :     $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
668 :     $j++;
669 :     }
670 :     $i++;
671 :    
672 :     }
673 :     }
674 :    
675 : olson 1.2 =pod
676 :    
677 : olson 1.25 =head2 write_subsystem()
678 :    
679 :     Write the subsystem to the disk. Updates on-disk data with notes,
680 :     etc. Perform backups when necessary.
681 :    
682 :     =cut
683 :    
684 :     sub write_subsystem
685 :     {
686 :     my($self) = @_;
687 :    
688 :     my $dir = $self->{dir};
689 :     my $fig = $self->{fig};
690 :    
691 :     #
692 :     # We first move the existing spreadsheet and notes files (if present)
693 :     # to spreadsheet~ and notes~, and current state.
694 :     #
695 :    
696 :     my $ss_file = "$dir/spreadsheet";
697 :     my $ss_bak = "$dir/spreadsheet~";
698 :     my $notes_file = "$dir/notes";
699 :     my $notes_bak = "$dir/notes~";
700 : redwards 1.44 my $classification_file = "$dir/CLASSIFICATION";
701 : olson 1.25
702 :     if (-f $ss_file)
703 :     {
704 :     rename($ss_file, $ss_bak);
705 :     }
706 :    
707 :     if (-f $notes_file)
708 :     {
709 :     rename($notes_file, $notes_bak);
710 :     }
711 :    
712 :     #
713 :     # Eval this whole chunk, so that if we get any fatal errors, we can
714 :     # roll back to the old saved data.
715 :     #
716 :    
717 :     eval {
718 :     my $fh;
719 :     open($fh, ">$ss_file") or die "Cannot open $ss_file for writing: $!\n";
720 :     $self->write_spreadsheet($fh);
721 :     close($fh);
722 : overbeek 1.31 chmod(0777,$ss_file);
723 : olson 1.25
724 :     open($fh, ">$notes_file") or die "Cannot open $notes_file for writing: $!\n";
725 :     print $fh "$self->{notes}\n";
726 :     close($fh);
727 : overbeek 1.31 chmod(0777,$notes_file);
728 : olson 1.25
729 : redwards 1.44 open($fh, ">$classification_file") or die "Can not open $classification_file for writing: $!\n";
730 :     print $fh join "\t", (@{$self->{classification}}), "\n";
731 :     close($fh);
732 :     chmod(0777,$classification_file);
733 :    
734 : olson 1.25 $self->update_curation_log();
735 :    
736 :     #
737 :     # Write out the piddly stuff.
738 :     #
739 :    
740 :     open($fh, ">$dir/EXCHANGABLE") or die "Cannot write $dir/EXCHANGABLE: $!\n";
741 :     print $fh "$self->{exchangable}\n";
742 :     close($fh);
743 : overbeek 1.31 chmod(0777,"EXCHANGABLE");
744 : olson 1.25
745 :     #
746 :     # Process backup files. This is the smae process that determines when the
747 :     # version number should be bumped, so write the version file afterward.
748 :     #
749 :    
750 :     $self->update_backups();
751 :    
752 : overbeek 1.37 if ($self->{version} < 100) { $self->{version} += 100 }
753 :     open($fh, ">$dir/VERSION") or die "Cannot write $dir/VERSION: $!\n";
754 :     print $fh "$self->{version}\n";
755 : olson 1.25 close($fh);
756 : overbeek 1.31 chmod(0777,"VERSION");
757 : olson 1.25 };
758 :    
759 :     if ($@ ne "")
760 :     {
761 :     warn "Spreadsheet write failed, reverting to backup. Error was\n$@\n";
762 :     }
763 :    
764 :     }
765 :    
766 :     sub update_curation_log
767 :     {
768 :     my($self) = @_;
769 :    
770 :     my $fh;
771 :     my $file = "$self->{dir}/curation.log";
772 :    
773 :     my $now = time;
774 :     my $user = $self->{fig}->get_user();
775 :    
776 :     if (-f $file)
777 :     {
778 :     open($fh, ">>$file") or die "Cannot open $file for writing: $!\n";
779 :     }
780 :     else
781 :     {
782 :     open($fh, ">$file") or die "Cannot open $file for writing: $!\n";
783 :     print $fh "$now\t$user\tstarted\n";
784 :     }
785 :     print $fh "$now\t$user\tupdated\n";
786 :     close($fh);
787 :     }
788 :    
789 :     sub update_backups
790 :     {
791 :     my($self) = @_;
792 :    
793 :     my $dir = $self->{dir};
794 :     my $fig = $self->{fig};
795 :    
796 :     my $ss_file = "$dir/spreadsheet";
797 :     my $ss_bak = "$dir/spreadsheet~";
798 :     my $notes_file = "$dir/notes";
799 :     my $notes_bak = "$dir/notes~";
800 :    
801 :     my $ss_diff = abs((-s $ss_file) - (-s $ss_bak));
802 :     my $notes_diff = abs((-s $notes_file) - (-s $notes_bak));
803 :    
804 : overbeek 1.37 if (($ss_diff > 10) or ($notes_diff > 10))
805 : olson 1.25 {
806 :     $self->make_backup();
807 :     }
808 :     }
809 :    
810 :     sub make_backup
811 :     {
812 :     my($self) = @_;
813 :    
814 :     my $dir = $self->{dir};
815 :     my $bak = "$dir/Backup";
816 :    
817 :     $self->{fig}->verify_dir($bak);
818 :    
819 :     my $ts = time;
820 :    
821 :     rename("$dir/spreadsheet~", "$bak/spreadsheet.$ts");
822 :     rename("$dir/notes~", "$bak/notes.$ts");
823 :     $self->{version}++;
824 :     }
825 :    
826 :    
827 :    
828 :     =pod
829 :    
830 :     =head1 write_spreadsheet($fh)
831 :    
832 :     Write the spreadsheet for this subsystem to filehandle $fh.
833 :    
834 :     =cut
835 :    
836 :     sub write_spreadsheet
837 :     {
838 :     my($self, $fh) = @_;
839 :    
840 :     $self->_write_roles($fh);
841 :     print $fh "//\n";
842 :    
843 :     $self->_write_subsets($fh);
844 :     print $fh "//\n";
845 :    
846 :     $self->_write_spreadsheet($fh);
847 :     }
848 :    
849 :     sub _write_roles
850 :     {
851 :     my($self, $fh) = @_;
852 :    
853 :     my(@roles, @abbrs);
854 :    
855 :     @roles = $self->get_roles();
856 :     @abbrs = $self->get_abbrs();
857 :    
858 :     while (@roles)
859 :     {
860 :     my $role = shift(@roles);
861 :     my $abbr = shift(@abbrs);
862 :    
863 :     print $fh "$abbr\t$role\n";
864 :     }
865 :     }
866 :    
867 :     sub _write_subsets
868 :     {
869 :     my($self, $fh) = @_;
870 :    
871 : overbeek 1.31 for my $sub ($self->get_subset_namesC())
872 : olson 1.25 {
873 : overbeek 1.35 next if ($sub eq "All");
874 : overbeek 1.31 my @members= $self->get_subsetC($sub);
875 : olson 1.25
876 :     #
877 :     # member list on disk is 1-based
878 :     #
879 :    
880 :     @members = map { $_ + 1 } @members;
881 :     print $fh join("\t", $sub, @members), "\n";
882 :     }
883 : overbeek 1.39 my $active_row_subset = $self->{row_active_subset};
884 :     my $active_col_subset = $self->{col_active_subset};
885 :    
886 :     print $fh "$active_col_subset\n";
887 : olson 1.25
888 :     #
889 :     # separator
890 :     #
891 :    
892 :     print $fh "\n";
893 :    
894 :     #
895 :     # genome subsets.
896 :     #
897 :    
898 : overbeek 1.39 print $fh "$active_row_subset\n";
899 : olson 1.25 }
900 :    
901 :     sub _write_spreadsheet
902 :     {
903 :     my($self, $fh) = @_;
904 :    
905 :     my(@genomes);
906 :    
907 :     @genomes= $self->get_genomes();
908 :    
909 :     for (my $i = 0; $i < @genomes; $i++)
910 :     {
911 :     my $genome = $genomes[$i];
912 :     my $vc = $self->get_variant_code($i);
913 :    
914 :     my $row = $self->get_row($i);
915 :    
916 :     if ($vc eq "")
917 :     {
918 :     $vc = "0";
919 :     }
920 :     print $fh "$genome\t$vc";
921 :    
922 :     for my $entry (@$row)
923 :     {
924 :     my(@p);
925 :    
926 :     for my $peg (@$entry)
927 :     {
928 :     if ($peg =~ /fig\|$genome\.peg\.(\d+)$/)
929 :     {
930 :     push(@p, $1);
931 :     }
932 :     else
933 :     {
934 :     warn "Bad peg $peg in cell for $genome";
935 :     }
936 :     }
937 :     print $fh "\t", join(",", @p);
938 :     }
939 :     print $fh "\n";
940 :     }
941 :     }
942 :    
943 :    
944 :     =pod
945 :    
946 : olson 1.2 =head1 get_genomes
947 :    
948 :     =cut
949 : olson 1.25
950 : olson 1.2 sub get_genomes
951 :     {
952 :     my($self) = @_;
953 :    
954 :     my $glist = $self->{genome};
955 :    
956 : olson 1.25 return @$glist;
957 : olson 1.2 }
958 :    
959 :     =pod
960 :    
961 :     =head1 get_variant_codes
962 :    
963 :     =cut
964 : olson 1.25
965 : olson 1.2 sub get_variant_codes
966 :     {
967 :     my($self) = @_;
968 :    
969 :     my $glist = $self->{variant_code};
970 :    
971 : olson 1.25 return @$glist;
972 :     }
973 :    
974 :     sub get_variant_code
975 :     {
976 :     my($self, $gidx) = @_;
977 : overbeek 1.46 my $c = $self->{variant_code}->[$gidx];
978 :     $c =~ s/ //g;
979 :     return $c;
980 : olson 1.2 }
981 :    
982 : overbeek 1.34 sub set_variant_code
983 :     {
984 :     my($self, $gidx, $val) = @_;
985 :     $self->{variant_code}->[$gidx] = $val;
986 :     return;
987 :     }
988 :    
989 : olson 1.25
990 : olson 1.2 sub get_variant_code_for_genome
991 :     {
992 :     my($self, $genome) = @_;
993 :    
994 :     my $index = $self->{genome_index}->{$genome};
995 :     return $self->{variant_code}->[$index];
996 :     }
997 :    
998 :     sub get_roles
999 :     {
1000 :     my($self) = @_;
1001 :    
1002 :     my $rlist = $self->{roles};
1003 :    
1004 : olson 1.25 return @$rlist;
1005 :     }
1006 :    
1007 :     sub get_abbrs
1008 :     {
1009 :     my($self) = @_;
1010 :    
1011 :     my $rlist = $self->{role_abbrs};
1012 :    
1013 :     return @$rlist;
1014 : olson 1.2 }
1015 :    
1016 : olson 1.29 sub roles_with_abbreviations
1017 :     {
1018 :     my($self) = @_;
1019 :    
1020 :     my @ret;
1021 :    
1022 :     for my $i (0..@{$self->{roles}} - 1)
1023 :     {
1024 :     push(@ret, [$self->{role_abbrs}->[$i], $self->{roles}->[$i]]);
1025 :     }
1026 :     return @ret;
1027 :     }
1028 :    
1029 :    
1030 : olson 1.10 sub get_row :scalar
1031 : olson 1.1 {
1032 :     my($self, $row) = @_;
1033 :    
1034 :     return $self->{spreadsheet}->[$row];
1035 :     }
1036 :    
1037 : olson 1.21 sub get_col :scalar
1038 : olson 1.1 {
1039 :     my($self, $col) = @_;
1040 :    
1041 :     return $self->{spreadsheet_inv}->[$col];
1042 :     }
1043 :    
1044 : olson 1.21 sub get_cell :scalar
1045 : olson 1.1 {
1046 :     my($self, $row, $col) = @_;
1047 :    
1048 : olson 1.5 my $cell = $self->{spreadsheet}->[$row]->[$col];
1049 : overbeek 1.37 if (! defined($cell))
1050 :     {
1051 :     $cell = $self->{spreadsheet}->[$row]->[$col] = [];
1052 :     }
1053 : olson 1.5 return $cell;
1054 : olson 1.1 }
1055 :    
1056 : olson 1.21 sub get_genome_index :scalar
1057 : olson 1.3 {
1058 :     my($self, $genome) = @_;
1059 :    
1060 :     return $self->{genome_index}->{$genome};
1061 :     }
1062 :    
1063 : olson 1.21 sub get_genome :scalar
1064 : olson 1.3 {
1065 :     my($self, $gidx) = @_;
1066 :    
1067 :     return $self->{genome}->[$gidx];
1068 :     }
1069 :    
1070 : olson 1.21 sub get_role_index :scalar
1071 : olson 1.5 {
1072 :     my($self, $role) = @_;
1073 :    
1074 :     return $self->{role_index}->{$role};
1075 :     }
1076 :    
1077 : olson 1.21 sub get_role :scalar
1078 : olson 1.3 {
1079 :     my($self, $ridx) = @_;
1080 :    
1081 :     return $self->{roles}->[$ridx];
1082 :     }
1083 :    
1084 : olson 1.21 sub get_role_abbr :scalar
1085 : olson 1.4 {
1086 :     my($self, $ridx) = @_;
1087 :    
1088 :     return $self->{role_abbrs}->[$ridx];
1089 :     }
1090 :    
1091 : olson 1.21 sub get_role_from_abbr :scalar
1092 : olson 1.20 {
1093 :     my($self, $abbr) = @_;
1094 :    
1095 :     return $self->{abbr}->{$abbr};
1096 :     }
1097 :    
1098 : olson 1.26 =pod
1099 :    
1100 :     =head1 set_pegs_in_cell($genome, $role, $peg_list)
1101 :    
1102 :     Set the cell for the given genome and role to $peg_list.
1103 :    
1104 :     =cut
1105 :    
1106 :     sub set_pegs_in_cell
1107 :     {
1108 :     my($self, $genome, $role, $peg_list) = @_;
1109 :     my($row, $col);
1110 :    
1111 :     #
1112 :     # If row isn't numeric, look it up in the genomes list.
1113 :     #
1114 :    
1115 :     if ($genome !~ /^\d+$/)
1116 :     {
1117 :     $row = $self->{genome_index}->{$genome};
1118 :     }
1119 :     else
1120 :     {
1121 :     $row = $genome
1122 :     }
1123 :    
1124 : overbeek 1.37 if (! defined($row))
1125 : olson 1.26 {
1126 : overbeek 1.37 print &Dumper($self->{genome_index});
1127 :     confess "Cannot find row for $genome\n";
1128 : olson 1.26 return undef;
1129 :     }
1130 :    
1131 :     #
1132 :     # If col isn't numeric, look it up in the roles and role abbreviations.
1133 :     #
1134 :    
1135 :     if ($role !~ /^\d+$/)
1136 :     {
1137 :     #
1138 :     # See if it's an abbr
1139 :     #
1140 :    
1141 :     my $a = $self->{abbr}->{$role};
1142 : olson 1.27 $role = $a if $a;
1143 : olson 1.26
1144 :     $col = $self->{role_index}->{$role};
1145 :     }
1146 :     else
1147 :     {
1148 :     $col = $role;
1149 :     }
1150 :    
1151 : overbeek 1.37 if (! defined($col))
1152 : olson 1.26 {
1153 : overbeek 1.38 print &Dumper($self->{role_index});
1154 :     confess "Cannot find col for $role\n";
1155 : olson 1.26 return undef;
1156 :     }
1157 :     my $cell = $self->get_cell($row, $col);
1158 :    
1159 : overbeek 1.37 if (defined($cell))
1160 : olson 1.26 {
1161 : overbeek 1.37 my $peg;
1162 :     my $rdbH = $self->{fig}->db_handle();
1163 : overbeek 1.40 my $roleQ = quotemeta $role;
1164 :    
1165 : overbeek 1.37 if (@$cell > 0)
1166 :     {
1167 :     foreach $peg (@$cell)
1168 :     {
1169 :     $rdbH->SQL("DELETE FROM subsystem_index where ( subsystem = '$self->{name}' ) AND
1170 : overbeek 1.40 ( role = '$roleQ' ) AND
1171 : overbeek 1.37 ( protein = '$peg' )" );
1172 :     }
1173 :     }
1174 : olson 1.26 @$cell = @$peg_list;
1175 : overbeek 1.37 foreach $peg (@$cell)
1176 :     {
1177 : overbeek 1.40 $rdbH->SQL("INSERT INTO subsystem_index (protein,subsystem,role) VALUES ('$peg','$self->{name}','$roleQ' )");
1178 : overbeek 1.37 }
1179 : olson 1.26 }
1180 :     else
1181 :     {
1182 :     warn "set_pegs_in_cell: Could not find cell!";
1183 :     }
1184 :     }
1185 :    
1186 : olson 1.1 sub get_pegs_from_cell
1187 :     {
1188 :     my($self, $rowstr, $colstr) = @_;
1189 :     my($row, $col);
1190 :    
1191 :     #
1192 :     # If row isn't numeric, look it up in the genomes list.
1193 :     #
1194 :    
1195 :     if ($rowstr !~ /^\d+$/)
1196 :     {
1197 :     $row = $self->{genome_index}->{$rowstr};
1198 :     }
1199 :     else
1200 :     {
1201 :     $row = $rowstr;
1202 :     }
1203 :    
1204 : overbeek 1.31 if (! defined($row))
1205 : olson 1.1 {
1206 : overbeek 1.38 print &Dumper($self->{genome_index});
1207 :     confess "Cannot find row for $rowstr\n";
1208 : olson 1.1 return undef;
1209 :     }
1210 :    
1211 :     #
1212 :     # If col isn't numeric, look it up in the roles and role abbreviations.
1213 :     #
1214 :    
1215 :     if ($colstr !~ /^\d+$/)
1216 :     {
1217 :     #
1218 :     # See if it's an abbr
1219 :     #
1220 :    
1221 :     my $a = $self->{abbr}->{$colstr};
1222 :     $colstr = $a if $a;
1223 :    
1224 :     $col = $self->{role_index}->{$colstr};
1225 :     }
1226 :     else
1227 :     {
1228 :     $col = $colstr;
1229 :     }
1230 : overbeek 1.32
1231 : overbeek 1.31 if (! defined($col))
1232 : olson 1.1 {
1233 :     warn "Cannot find col for $colstr\n";
1234 :     return undef;
1235 :     }
1236 : olson 1.12 my $cell = $self->get_cell($row, $col);
1237 : olson 1.1
1238 :     if ($cell)
1239 :     {
1240 :     return @$cell;
1241 :     }
1242 :     else
1243 :     {
1244 :     return undef;
1245 :     }
1246 :     }
1247 :    
1248 : olson 1.25 #
1249 :     # Subset support
1250 :     #
1251 :    
1252 : olson 1.30 sub get_active_subsetC
1253 :     {
1254 :     my($self) = @_;
1255 :    
1256 :     return $self->{col_active_subset};
1257 :     }
1258 :    
1259 :     sub get_active_subsetR
1260 :     {
1261 :     my($self) = @_;
1262 :    
1263 :     return $self->{row_active_subset};
1264 :     }
1265 :    
1266 :     sub set_active_subsetC
1267 :     {
1268 :     my($self, $subset) = @_;
1269 :    
1270 :     $self->{col_active_subset} = $subset;
1271 :     }
1272 :    
1273 :    
1274 :     sub set_active_subsetR
1275 :     {
1276 :     my($self, $subset) = @_;
1277 :    
1278 :     $self->{row_active_subset} = $subset;
1279 :     }
1280 :    
1281 :    
1282 : olson 1.25 sub get_subset_names
1283 : olson 1.17 {
1284 :     my($self) = @_;
1285 : olson 1.25
1286 : overbeek 1.31 return $self->get_subset_namesC;
1287 :     }
1288 :    
1289 :     sub get_subset_namesC
1290 :     {
1291 :     my($self) = @_;
1292 :    
1293 : overbeek 1.35 return ("All",@{$self->{col_subsets}});
1294 : overbeek 1.31 }
1295 :    
1296 :     sub get_subset_namesR
1297 :     {
1298 :     my($self) = @_;
1299 :    
1300 : overbeek 1.35 return ("All",@{$self->{row_subsets}});
1301 : olson 1.17 }
1302 :    
1303 : overbeek 1.33 sub get_subsetC_roles
1304 :     {
1305 :     my($self, $subname) = @_;
1306 :     return map { $self->get_role($_) } $self->get_subsetC($subname);
1307 :     }
1308 :    
1309 : overbeek 1.31 sub get_subsetC
1310 :     {
1311 :     my($self, $subname) = @_;
1312 : overbeek 1.33 if ($subname eq "All") { return map { $self->get_role_index($_) } $self->get_roles }
1313 : overbeek 1.31
1314 : overbeek 1.37 defined($self->{col_subset_members}->{$subname}) || confess "BAD";
1315 : overbeek 1.31 return @{$self->{col_subset_members}->{$subname}};
1316 :     }
1317 :    
1318 : olson 1.25 sub get_subset
1319 : olson 1.17 {
1320 : olson 1.25 my($self, $subname) = @_;
1321 : overbeek 1.33 return $self->get_subsetC($subname);
1322 : overbeek 1.31 }
1323 :    
1324 :     sub get_subsetR
1325 :     {
1326 :     my($self, $subname) = @_;
1327 :     my($pair,$id,$members,$genome);
1328 :    
1329 :     if ($subname eq "All") { return $self->get_genomes }
1330 : overbeek 1.38 my %genomes = map { $_ => 1 } $self->get_genomes;
1331 :    
1332 :     return grep { $genomes{$_} } @{$self->{row_subset_members}->{$subname}};
1333 : overbeek 1.35 }
1334 :    
1335 :     sub load_row_subsets {
1336 :     my($self) = @_;
1337 :     my($id,$members,$pair);
1338 : overbeek 1.31
1339 : overbeek 1.35 my $taxonomic_groups = $self->{fig}->taxonomic_groups_of_complete(10);
1340 :     foreach $pair (@$taxonomic_groups)
1341 : overbeek 1.31 {
1342 : overbeek 1.35 ($id,$members) = @$pair;
1343 :     if ($id ne "All")
1344 : overbeek 1.31 {
1345 :     push(@{$self->{row_subsets}},$id);
1346 :     }
1347 : overbeek 1.35 $self->{row_subset_members}->{$id} = $members;
1348 : overbeek 1.31 }
1349 : olson 1.25 }
1350 :    
1351 : overbeek 1.35
1352 : olson 1.25 =pod
1353 :    
1354 : overbeek 1.31 =head2 set_subsetC($name, $members)
1355 : olson 1.25
1356 :     Create a subset with the given name and members.
1357 :    
1358 :     $members is a list of role names.
1359 :    
1360 :     =cut
1361 :    
1362 : overbeek 1.31 sub set_subsetC
1363 : olson 1.25 {
1364 :     my($self, $subname, $list) = @_;
1365 :    
1366 :     my $nl = [map { $self->get_role_index($_) } @$list];
1367 :    
1368 :     $self->_set_subset($subname, $nl);
1369 :     }
1370 :    
1371 : overbeek 1.31 sub set_subset
1372 :     {
1373 :     my($self, $subname, $list) = @_;
1374 :    
1375 :     $self->set_subsetsC($subname,$list);
1376 :     }
1377 :    
1378 : olson 1.25 =pod
1379 :    
1380 :     =head2 _set_subset($name, $members)
1381 :    
1382 :     Create a subset with the given name and members.
1383 :    
1384 :     Internal version - here, members is a list of role indices.
1385 :    
1386 :     =cut
1387 :    
1388 :     sub _set_subset
1389 :     {
1390 :     my($self, $subname, $list) = @_;
1391 :     $self->{col_subset_members}->{$subname} = $list;
1392 : overbeek 1.37 my($i,$x);
1393 :     $x = $self->{col_subsets};
1394 :     for ($i=0; ($i < @$x) && ($x->[$i] ne $subname); $i++) {}
1395 :     if ($i == @$x)
1396 :     {
1397 :     push(@$x,$subname);
1398 :     }
1399 :     }
1400 :    
1401 :     sub delete_subsetC
1402 :     {
1403 :     my($self, $subname) = @_;
1404 :     my($i,$x);
1405 :    
1406 :     $x = $self->{col_subsets};
1407 :     for ($i=0; ($i < @$x) && ($x->[$i] ne $subname); $i++) {}
1408 :     if ($i < @$x)
1409 :     {
1410 :     splice(@$x,$i,1);
1411 :     }
1412 :     delete $self->{col_subset_members}->{$subname};
1413 : olson 1.25 }
1414 :    
1415 :     #
1416 :     # Role manipulation.
1417 :     #
1418 :    
1419 :    
1420 :     =pod
1421 :    
1422 :     =head1 set_roles($role_list)
1423 :    
1424 :     Set the list of roles. C<$role_list> is a list of tuples C<[$role_name, $abbreviation]>.
1425 :    
1426 :     If a role already exists, it is used. If it does not exist, it is created empty.
1427 :    
1428 :     =cut
1429 :    
1430 :     sub set_roles
1431 :     {
1432 :     my($self, $roles) = @_;
1433 :    
1434 :     #
1435 :     # We do this by first creating a new spreadsheet.
1436 :     #
1437 :     # It is easiest to do this by manipulating the inverted spreadsheet
1438 :     # (role-major), and then creating the non-inverted spreadsheet from it.
1439 :     #
1440 :    
1441 :     my $oldss = $self->{spreadsheet};
1442 :     my $oldssinv = $self->{spreadsheet_inv};
1443 :    
1444 :     my $ss = [];
1445 :     my $ssinv = [];
1446 :    
1447 :     my $g = $self->{genome};
1448 :     my $ng = @$g;
1449 :    
1450 :     my $old_roles = $self->{role_index};
1451 :    
1452 :     my @role_index_conversion;
1453 :    
1454 :    
1455 :     $self->{abbr} = {};
1456 :     $self->{role_index} = {};
1457 :     $self->{roles} = [];
1458 :     $self->{role_abbrs} = [];
1459 :    
1460 :    
1461 :     for (my $idx = 0; $idx < @$roles; $idx++)
1462 :     {
1463 :     my $role = $roles->[$idx]->[0];
1464 :     my $abbr = $roles->[$idx]->[1];
1465 :    
1466 :     my $old_idx = $old_roles->{$role};
1467 :    
1468 :     if (defined($old_idx))
1469 :     {
1470 : overbeek 1.31 # print "Found old idx $old_idx for $role $idx\n";
1471 :     # print $oldssinv->[$old_idx];
1472 : olson 1.25 $ssinv->[$idx] = $oldssinv->[$old_idx];
1473 :    
1474 :     $role_index_conversion[$old_idx] = $idx;
1475 :     }
1476 :     else
1477 :     {
1478 : overbeek 1.37 # print "Did not find old role for $role $idx\n";
1479 :     # print Dumper($old_roles);
1480 : olson 1.25 my $l = [];
1481 :     for (my $j = 0; $j < $ng; $j++)
1482 :     {
1483 :     $l->[$j] = [];
1484 :     }
1485 :    
1486 :     $ssinv->[$idx] = $l;
1487 :     }
1488 :    
1489 :     #
1490 :     # While we're here, update the new role and abbrev indexes
1491 :     #
1492 :     $self->{role_index}->{$role} = $idx;
1493 :     $self->{abbr}->{$abbr} = $role;
1494 :     $self->{roles}->[$idx] = $role;
1495 :     $self->{role_abbrs}->[$idx] = $abbr;
1496 :     }
1497 :    
1498 :     #
1499 :     # Now create the uninverted spreadsheet.
1500 :     #
1501 :    
1502 :     for (my $gidx = 0; $gidx < $ng; $gidx++)
1503 :     {
1504 :     my $row = [];
1505 :     $ss->[$gidx] = $row;
1506 :     for (my $ridx = 0; $ridx < @$roles; $ridx++)
1507 :     {
1508 :     $row->[$ridx] = $ssinv->[$ridx]->[$gidx];
1509 :     }
1510 :     }
1511 :    
1512 :     $self->{spreadsheet} = $ss;
1513 :     $self->{spreadsheet_inv} = $ssinv;
1514 :    
1515 :     #
1516 :     # Fix up the subsets.
1517 :     #
1518 :    
1519 :    
1520 : overbeek 1.37 for my $subset (grep { $_ ne "All" } $self->get_subset_names())
1521 : olson 1.25 {
1522 :     my $n = [];
1523 :     for my $idx ($self->get_subset($subset))
1524 :     {
1525 :     my $new = $role_index_conversion[$idx];
1526 :     if (defined($new))
1527 :     {
1528 :     push(@$n, $new);
1529 :     }
1530 :     }
1531 :     $self->_set_subset($subset, $n);
1532 :     }
1533 :    
1534 :     }
1535 :    
1536 :     =pod
1537 :    
1538 :     =head1 C<add_role($role, $abbr)>
1539 :    
1540 :     Add the given role to the spreadsheet.
1541 :    
1542 :     This causes a new column to be added, with empty values in each cell.
1543 :    
1544 :     We do nothing if the role is already present.
1545 :    
1546 :     Return the index of the new role.
1547 :    
1548 :     =cut
1549 :    
1550 :     sub add_role
1551 :     {
1552 :     my($self, $role, $abbr) = @_;
1553 :    
1554 :     if (defined($self->get_role_index($role)))
1555 :     {
1556 :     warn "Role $role already present\n";
1557 :     return undef;
1558 :     }
1559 :    
1560 :     #
1561 :     # Add to the roles list. It goes at the end.
1562 :     #
1563 :    
1564 :     my $idx = @{$self->{roles}};
1565 :     $self->{roles}->[$idx] = $role;
1566 :     $self->{role_abbrs}->[$idx] = $abbr;
1567 :     $self->{role_index}->{$role} = $idx;
1568 :     $self->{abbr}->{$abbr} = $role;
1569 :    
1570 :     #
1571 :     # Update the spreadsheet.
1572 :     # On the standard one, we have to go through all the rows adding
1573 :     # a columnt to each.
1574 :     #
1575 :     # On the inverted one, we add a column with [] in each entry.
1576 :     #
1577 :    
1578 :     my $ng = @{$self->{genome}};
1579 :     my $newcol = [];
1580 :    
1581 :     for (my $i = 0; $i < $ng; $i++)
1582 :     {
1583 :     my $cell = [];
1584 :     # print "nr: Adding cell $cell for gidx=$i ridx=$idx\n";
1585 :     $self->{spreadsheet}->[$i]->[$idx] = $cell;
1586 :     $newcol->[$i] = $cell;
1587 :     }
1588 :    
1589 :     $self->{spreadsheet_inv}->[$idx] = $newcol;
1590 :    
1591 :     return $idx;
1592 :     }
1593 :    
1594 :     =pod
1595 :    
1596 :     =head1 remove_role($role)
1597 :    
1598 :     Remove the role from the spreadsheet.
1599 :    
1600 :     We do nothing if the role is not present.
1601 :    
1602 :     =cut
1603 :    
1604 :     sub remove_role
1605 :     {
1606 :     my($self, $role) = @_;
1607 :    
1608 :     my $idx = $self->get_role_index($role);
1609 :     if (!defined($idx))
1610 :     {
1611 :     warn "Role $role not present\n";
1612 :     return undef;
1613 :     }
1614 :    
1615 :     #
1616 :     # Remove from the roles list.
1617 :     #
1618 :    
1619 :     my $abbr = $self->{role_abbrs}->[$idx];
1620 :    
1621 :     splice(@{$self->{roles}}, $idx, 1);
1622 :     splice(@{$self->{role_abbrs}}, $idx, 1);
1623 :     delete $self->{role_index}->{$role};
1624 :     delete $self->{abbr}->{$abbr};
1625 :    
1626 :     #
1627 :     # Update the spreadsheet.
1628 :     # On the standard one, we have to go through all the rows removing
1629 :     # the column from each.
1630 :     #
1631 :     # On the inverted one, we just remove the column.
1632 :     #
1633 :    
1634 :     my $ng = @{$self->{genome}};
1635 :     my $newcol = [];
1636 :    
1637 :     for (my $i = 0; $i < $ng; $i++)
1638 :     {
1639 :     splice(@{$self->{spreadsheet}->[$i]}, $idx, 1);
1640 :     }
1641 :    
1642 :     splice(@{$self->{spreadsheet_inv}}, $idx, 1);
1643 :    
1644 :     #
1645 :     # We need to rewrite the subsets. if $idx was present in one, it is
1646 :     # removed. Any index >$idx is decremented.
1647 :     #
1648 :    
1649 :     for my $subset ($self->get_subset_names())
1650 :     {
1651 :     my @n;
1652 :    
1653 :     for my $sidx ($self->get_subset($subset))
1654 :     {
1655 :     if ($sidx < $idx)
1656 :     {
1657 :     push(@n, $sidx);
1658 :     }
1659 :     elsif ($sidx > $idx)
1660 :     {
1661 :     push(@n, $sidx - 1);
1662 :     }
1663 :     }
1664 :    
1665 :     $self->_set_subset($subset, [@n]);
1666 :     }
1667 :     }
1668 :    
1669 :     =pod
1670 :    
1671 :     =head1 C<add_genome($genome, $abbr)>
1672 :    
1673 :     Add the given genome to the spreadsheet.
1674 :    
1675 :     This causes a new row to be added, with empty values in each cell.
1676 :    
1677 :     We do nothing if the genome is already present.
1678 :    
1679 :     Return the index of the new genome.
1680 :    
1681 :     =cut
1682 :    
1683 :     sub add_genome
1684 :     {
1685 :     my($self, $genome) = @_;
1686 :    
1687 :     my $idx = $self->get_genome_index($genome);
1688 :     if (defined($idx))
1689 :     {
1690 :     warn "Genome $genome already present\n";
1691 :     return $idx;
1692 :     }
1693 :    
1694 :     #
1695 :     # Add to the genomes list. It goes at the end.
1696 :     #
1697 :    
1698 :     my $idx = @{$self->{genome}};
1699 : olson 1.26 $self->{variant_code}->[$idx] = 0;
1700 : olson 1.25 $self->{genome}->[$idx] = $genome;
1701 :     $self->{genome_index}->{$genome} = $idx;
1702 :    
1703 :     #
1704 :     # Update the spreadsheet.
1705 :     # On the inverted one, we have to go through all the columns adding
1706 :     # a row to each.
1707 :     #
1708 :     # On the regular one, we add a row with [] in each entry.
1709 :     #
1710 :    
1711 :     my $nr = @{$self->{roles}};
1712 :     my $newrow = [];
1713 :    
1714 :     for my $i (0.. $nr - 1)
1715 :     {
1716 :     my $cell = [];
1717 :     # print "ng: Adding cell $cell for gidx=$idx ridx=$i\n";
1718 :     $self->{spreadsheet_inv}->[$i]->[$idx] = $cell;
1719 :     $newrow->[$i] = $cell;
1720 :     }
1721 :    
1722 :     $self->{spreadsheet}->[$idx] = $newrow;
1723 :    
1724 :     return $idx;
1725 :     }
1726 :    
1727 :     =pod
1728 :    
1729 :     =head1 remove_genome($genome)
1730 :    
1731 :     Remove the genome from the spreadsheet.
1732 :    
1733 :     We do nothing if the genome is not present.
1734 :    
1735 :     =cut
1736 :    
1737 :     sub remove_genome
1738 :     {
1739 :     my($self, $genome) = @_;
1740 :    
1741 :     my $idx = $self->get_genome_index($genome);
1742 :     if (!defined($idx))
1743 :     {
1744 :     warn "Genome $genome not present\n";
1745 :     return undef;
1746 :     }
1747 :    
1748 :     #
1749 :     # Remove from the genomes list.
1750 :     #
1751 :    
1752 :     splice(@{$self->{genome}}, $idx, 1);
1753 : overbeek 1.43
1754 :     my $genome1;
1755 :     foreach $genome1 (@{$self->{genome}})
1756 :     {
1757 :     if ($self->{genome_index}->{$genome1} > $idx)
1758 :     {
1759 :     $self->{genome_index}->{$genome1}--;
1760 :     }
1761 :     }
1762 : olson 1.25 splice(@{$self->{variant_code}}, $idx, 1);
1763 :    
1764 :     delete $self->{genome_index}->{$genome};
1765 :    
1766 :     #
1767 :     # Update the spreadsheet.
1768 :     # On the inverted one, we have to go through all the columns removing
1769 :     # the row from each.
1770 :     #
1771 :     # On the standard one, we just remove the row.
1772 :     #
1773 :    
1774 :     my $nr = @{$self->{roles}};
1775 :    
1776 :     for my $i (0 .. $nr - 1)
1777 :     {
1778 :     splice(@{$self->{spreadsheet_inv}->[$i]}, $idx, 1);
1779 :     }
1780 :    
1781 :     splice(@{$self->{spreadsheet}}, $idx, 1);
1782 :    
1783 :     }
1784 :    
1785 :     sub get_name :scalar
1786 :     {
1787 :     my($self) = @_;
1788 :     return $self->{name};
1789 :     }
1790 :    
1791 : overbeek 1.41 sub get_dir :scalar
1792 :     {
1793 :     my($self) = @_;
1794 :     return $self->{dir};
1795 :     }
1796 :    
1797 : olson 1.25
1798 :     sub get_version :scalar
1799 :     {
1800 :     my($self) = @_;
1801 :     return $self->{version};
1802 : olson 1.17 }
1803 :    
1804 : olson 1.26 sub get_notes :scalar
1805 :     {
1806 :     my($self) = @_;
1807 :    
1808 :     return $self->{notes};
1809 :     }
1810 :    
1811 :     sub set_notes
1812 :     {
1813 :     my($self, $notes) = @_;
1814 :    
1815 : olson 1.28 $self->{notes} = $notes;
1816 : olson 1.26 }
1817 :    
1818 : redwards 1.44 sub get_classification
1819 :     {
1820 :     my($self) = @_;
1821 :    
1822 :     return $self->{classification};
1823 :     }
1824 :    
1825 :     sub set_classification
1826 :     {
1827 :     my($self, $classification) = @_;
1828 :    
1829 :     $self->{classification}=$classification;
1830 :     }
1831 :    
1832 :    
1833 :    
1834 : olson 1.17 sub get_curator :scalar
1835 :     {
1836 :     my($self) = @_;
1837 :     return $self->{curator};
1838 :     }
1839 : overbeek 1.47
1840 : olson 1.25 #
1841 :     # Subsystem copying logic
1842 :     #
1843 :    
1844 :     =pod
1845 :    
1846 :     =head2 add_to_subsystem($subsystem_name, $columns, $notes_flag)
1847 :    
1848 :     Merge the given columns from $subsystem_name into this subsystem. Append the
1849 :     notes from the subsystem if $notes_flag is true.
1850 :    
1851 :     =cut
1852 :    
1853 :     sub add_to_subsystem
1854 :     {
1855 :     my($self, $subsystem_name, $cols, $add_notes) = @_;
1856 :    
1857 :     my $ss = $self->{fig}->get_subsystem($subsystem_name);
1858 :    
1859 :     if (!$ss)
1860 :     {
1861 :     warn "Cannot open subsystem '$subsystem_name' to copy from";
1862 :     return;
1863 :     }
1864 :    
1865 :     #
1866 :     # Merge the data from the other subsystem.
1867 :     #
1868 :     # First we assure ourselves that we have the appropriate roles. While
1869 :     # we do this, build the list of row indices (in this subsystem) that
1870 :     # map to the roles we are adding.
1871 :     #
1872 :    
1873 :     #
1874 :     # local_roles[$his_role] = $my_role (map from other role idx to local role idx)
1875 :     #
1876 :    
1877 :     my @local_roles;
1878 :    
1879 :     #
1880 :     # his_roles = list of role indices corresponding to the remote roles.
1881 :     #
1882 : overbeek 1.36 if ($cols->[0] eq "all")
1883 :     {
1884 :     $cols = [$ss->get_roles];
1885 :     }
1886 :    
1887 : olson 1.25 my @his_roles;
1888 :    
1889 :     for my $his_role (@$cols)
1890 :     {
1891 :     my $idx = $self->get_role_index($his_role);
1892 :     my $his_idx = $ss->get_role_index($his_role);
1893 :    
1894 :     if (!defined($his_idx))
1895 :     {
1896 :     confess "Cannot map his role $his_role\n";
1897 :     }
1898 :     push(@his_roles, $his_idx);
1899 :    
1900 :     if (!defined($idx))
1901 :     {
1902 :     my $his_abbr = $ss->get_role_abbr($his_idx);
1903 :    
1904 :     $idx = $self->add_role($his_role, $his_abbr);
1905 : overbeek 1.37 # print "Adding missing role $his_role idx=$idx\n";
1906 : olson 1.25 }
1907 :     else
1908 :     {
1909 : overbeek 1.37 # print "Found existing role $his_role idx=$idx\n";
1910 : olson 1.25 }
1911 :    
1912 :    
1913 :     $local_roles[$his_idx] = $idx;
1914 :     }
1915 :    
1916 :     #
1917 :     # Similar scan to ensure that we have rows for the genomes
1918 :     # that are in the other subsystem.
1919 :     #
1920 :    
1921 :     my @local_genomes;
1922 :    
1923 :     my @his_genomes = $ss->get_genomes();
1924 :    
1925 :     for my $his_idx (0..@his_genomes - 1)
1926 :     {
1927 :     my $genome = $his_genomes[$his_idx];
1928 : overbeek 1.37
1929 : olson 1.25
1930 :     my $my_idx = $self->get_genome_index($genome);
1931 :    
1932 :     if (!defined($my_idx))
1933 :     {
1934 :     #
1935 :     # Not there, need to add.
1936 :     #
1937 :    
1938 :     $my_idx = $self->add_genome($genome);
1939 : overbeek 1.37 # print "Adding missing genome $genome idx=$my_idx\n";
1940 : olson 1.25 }
1941 :     else
1942 :     {
1943 : overbeek 1.37 # print "Found existing genome $genome idx=$my_idx\n";
1944 : olson 1.25 }
1945 :    
1946 :     $local_genomes[$his_idx] = $my_idx;
1947 :     }
1948 :    
1949 :    
1950 :     #
1951 :     # Now that we have our local roles set up to receive the data,
1952 :     # process the incoming roles one at a time.
1953 :     #
1954 :    
1955 :    
1956 :     for my $his_role (@his_roles)
1957 :     {
1958 :     my $my_col = $self->get_col($local_roles[$his_role]);
1959 :     my $his_col = $ss->get_col($his_role);
1960 :    
1961 :     #
1962 :     # $his_col is the information for $his_role, indexed by
1963 :     # genome in @his_genomes.
1964 :     #
1965 :     # $my_col is hte information for my copy of $his_role,
1966 :     # indexed by genome in MY genome list.
1967 :     #
1968 :    
1969 :     my $my_role = $local_roles[$his_role];
1970 :    
1971 : overbeek 1.37 # print "merging: $self->{roles}->[$my_role] $ss->{roles}->[$his_role] his_role=$his_role my_role=$my_role\n";
1972 : olson 1.25
1973 :     for my $his_gidx (0 .. @his_genomes - 1)
1974 :     {
1975 :     my $hisent = $his_col->[$his_gidx];
1976 :    
1977 :     my $my_gidx = $local_genomes[$his_gidx];
1978 :    
1979 : overbeek 1.37
1980 : olson 1.25 my $myent = $my_col->[$my_gidx];
1981 :    
1982 : overbeek 1.37 # print " his_gidx=$his_gidx my_gidx=$my_gidx hisent=@$hisent myent=@$myent\n";
1983 : olson 1.25
1984 :     my %new;
1985 :     map { $new{$_}++ } @$hisent;
1986 :     map { $new{$_}++ } @$myent;
1987 :    
1988 :     @$myent = keys(%new);
1989 :    
1990 : overbeek 1.37 # print " new entry: @$myent\n";
1991 : olson 1.25 }
1992 :     }
1993 : olson 1.26
1994 :     #
1995 :     # Fix up the variant codes.
1996 :     #
1997 :    
1998 :     for my $his_gidx (0 .. @his_genomes - 1)
1999 :     {
2000 :     my $his_code = $ss->get_variant_code($his_gidx);
2001 :     my $my_gidx = $local_genomes[$his_gidx];
2002 :    
2003 :     if (!$self->get_variant_code($my_gidx))
2004 :     {
2005 :     $self->{variant_code}->[$my_gidx] = $his_code;
2006 :     }
2007 :     }
2008 :    
2009 :     #
2010 :     # If we are to add notes, append the other subsystem's notes text.
2011 :     #
2012 :    
2013 :     if ($add_notes)
2014 :     {
2015 :     my $his_notes = $ss->get_notes();
2016 :    
2017 :     $self->{notes} .= "\nNotes copied from $ss->{name}:\n$his_notes\n";
2018 :     }
2019 : olson 1.25 }
2020 : olson 1.17
2021 : olson 1.1 sub dump
2022 :     {
2023 :     my($self) = @_;
2024 :    
2025 :     for my $k (keys(%$self))
2026 :     {
2027 :     next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
2028 :     print "Key \"$k\": ", Dumper($self->{$k});
2029 :     }
2030 :     }
2031 :    
2032 : olson 1.14 #
2033 :     # Increment the subsystem's version number.
2034 :     #
2035 :     sub incr_version {
2036 :     my($self) = @_;
2037 :    
2038 :     my $dir = $self->{dir};
2039 :     my $vfile = "$dir/VERSION";
2040 :     my($ver);
2041 :    
2042 :     if (open(my $fh,"<$vfile"))
2043 :     {
2044 :     if (defined($ver = <$fh>) && ($ver =~ /^(\S+)/))
2045 :     {
2046 :     $ver = $1;
2047 :     }
2048 :     else
2049 :     {
2050 :     $ver = 0;
2051 :     }
2052 :     close($fh);
2053 :     }
2054 :     else
2055 :     {
2056 :     $ver = 0;
2057 :     }
2058 :    
2059 :     $ver++;
2060 :    
2061 :     open(my $fh, ">$vfile") || die "could not open $vfile";
2062 :     print $fh "$ver\n";
2063 :     close($fh);
2064 :    
2065 :     chmod(0777, $vfile);
2066 :    
2067 :     $self->load_version();
2068 :     }
2069 : olson 1.1
2070 :     sub get_dir_from_name
2071 :     {
2072 :     my($name) = @_;
2073 :    
2074 :     my $b = $name;
2075 :     $b =~ s/ /_/g;
2076 :     my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
2077 :     return $dir;
2078 :     }
2079 :    
2080 : olson 1.12 #
2081 :     # Code for dealing with Bill McCune's prolog code for extending subsystems.
2082 :     #
2083 :     # The code here is a reconstruction of Bill's "go" script in perl with
2084 :     # data pulled from the local SEED configuration.
2085 :     #
2086 :    
2087 :     sub extend_with_billogix
2088 :     {
2089 : olson 1.42 my($self, $muser, $genomes) = @_;
2090 : olson 1.12 my($isMaster, $user);
2091 :    
2092 :     my $now = time();
2093 :    
2094 :     if ($muser =~ /master:(.*)/)
2095 :     {
2096 :     $isMaster = 1;
2097 :     $user = $1;
2098 :     }
2099 :     else
2100 :     {
2101 :     $isMaster = 0;
2102 :     $user = $muser;
2103 :     }
2104 :    
2105 :     #
2106 : olson 1.42 # initialize the genome list to all complete genomes, if none was passed in.
2107 :     #
2108 :    
2109 :     if (!$genomes)
2110 :     {
2111 :     $genomes = [$self->{fig}->genomes("complete")];
2112 :     warn "getting genome list from fig $self->{fig}";
2113 :     }
2114 :    
2115 :     #
2116 :     # Ensure genome list is of the right form.
2117 :     #
2118 :    
2119 :     if (ref($genomes) ne "ARRAY")
2120 :     {
2121 :     warn "billogix: genome list is not a list reference";
2122 :     return;
2123 :     }
2124 :    
2125 :     for my $g (@$genomes)
2126 :     {
2127 :     if ($g !~ /^\d+\.\d+/)
2128 :     {
2129 :     warn "billogix: genome '$g' is not of the proper form, aborting billogix run.";
2130 :     return;
2131 :     }
2132 :     }
2133 :    
2134 :     my $genome_list = "[" . join(", ", map { "'$_'" } @$genomes) . "]";
2135 :    
2136 :     warn "Genomes: $genome_list\n";
2137 :     warn Dumper($genomes);
2138 :    
2139 :     #
2140 : olson 1.12 # Find the executable.
2141 :     #
2142 :    
2143 :     my $exe = "$FIG_Config::bin/billogix";
2144 :    
2145 :     if (! -x $exe)
2146 :     {
2147 :     warn "Cannot find billogix exe at $exe\n";
2148 :     return;
2149 :     }
2150 :    
2151 :     my $ss_name = $self->{name};
2152 : olson 1.18
2153 :     $ss_name =~ s/\s+/_/g;
2154 :    
2155 : olson 1.14 my $ss_dir = "$self->{dir}/";
2156 : olson 1.15 my $assign_dir = "$FIG_Config::data/Assignments/$user/";
2157 : olson 1.12 &FIG::verify_dir($assign_dir);
2158 :    
2159 : olson 1.16 my $when= strftime("%m-%d-%y:%H:%M:%S", localtime($now));
2160 :     my $job_id = "${when}:sss:$ss_name";
2161 :    
2162 : olson 1.12 my $seed = &FIG::cgi_url() . "/";
2163 : olson 1.13 my $export_part = "ssa.cgi?user=$muser&request=delete_or_export_ssa&export=";
2164 : olson 1.12
2165 :     #
2166 :     # Have the prereq stuff, now start up the app.
2167 :     #
2168 :    
2169 :     $ENV{LOCALSZ} = "80000";
2170 :     $ENV{GLOBALSZ} = "80000";
2171 :     $ENV{TRAILSZ} = "30000";
2172 : olson 1.13
2173 :     my $arch = &FIG::get_current_arch();
2174 :    
2175 :     $ENV{BILLOGIX} = "$FIG_Config::fig_disk/dist/releases/current/$arch/lib/Billogix";
2176 :    
2177 :     #
2178 :     # Need to ensure pl2wam is in our path
2179 :     #
2180 :    
2181 :     $ENV{PATH} = "${FIG_Config::ext_bin}:$ENV{PATH}";
2182 : olson 1.12
2183 : olson 1.23 #
2184 :     # We're going to divide the run into $n_chunks chunks.
2185 :     #
2186 :    
2187 :     my $n_chunks = 10;
2188 :    
2189 :     my($log);
2190 :     open($log, ">$ss_dir/$job_id.log");
2191 :    
2192 :     for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2193 :     {
2194 :     my $app_input = <<EOINP;
2195 : olson 1.12 ['\$BILLOGIX/top'].
2196 :     loadup.
2197 : olson 1.42 asserta(job_genome_list($genome_list)).
2198 : olson 1.23 asserta(part($this_chunk, $n_chunks)).
2199 : olson 1.12 asserta(url_default_seed('$seed')).
2200 : olson 1.13 asserta(url_export_part('$export_part')).
2201 : olson 1.12 asserta(ss_directory('$ss_dir')).
2202 :     asserta(assign_directory('$assign_dir')).
2203 :     asserta(job_id('$job_id')).
2204 :     extend_test3('$ss_name').
2205 :     EOINP
2206 :    
2207 : olson 1.23 print STDERR <<EOF;
2208 : olson 1.12 Starting app
2209 :    
2210 : olson 1.23 chunk $this_chunk of $n_chunks
2211 : olson 1.12 ss_name = $ss_name
2212 :     ss_dir = $ss_dir
2213 :     user = $user
2214 :     assign_dir = $assign_dir
2215 :     exe = $exe
2216 : olson 1.13 libdir = $ENV{BILLOGIX}
2217 :     path = $ENV{PATH}
2218 : olson 1.12
2219 :     App input
2220 :     $app_input
2221 :     EOF
2222 :     # feh, put in a block to reset perlmode indentation.
2223 : olson 1.23 {
2224 :     my($app_read, $app_write);
2225 :    
2226 :     #
2227 :     # Start the actual application with stdin and stdout redirected
2228 :     # to pipes.
2229 :     #
2230 :     # We write $app_input to the stdin pipe, and close it.
2231 :     # Then loop reading stdout, logging that output.
2232 :     #
2233 :     my $pid = open2($app_read, $app_write, $exe);
2234 :    
2235 :     if (!$pid)
2236 :     {
2237 :     warn "open2 $exe failed: $!\n";
2238 :     print $log "open2 $exe failed: $!\n";
2239 :     return;
2240 :     }
2241 :    
2242 :     print $app_write $app_input;
2243 :     close($app_write);
2244 :    
2245 :     #
2246 :     # Set autoflush on the logfile.
2247 :     #
2248 :    
2249 :     my $old = select($log);
2250 :     $| = 1;
2251 :     select(STDERR);
2252 :     $| = 1;
2253 :     select($old);
2254 :    
2255 :     warn "Starting $exe with pid $pid\n";
2256 :     print $log "Starting $exe with pid $pid\n";
2257 :    
2258 :     while (<$app_read>)
2259 :     {
2260 :     print STDERR $_;
2261 :     print $log $_;
2262 :     }
2263 :    
2264 :     print STDERR "App done\n";
2265 :     print $log "App done\n";
2266 :    
2267 :     close($app_read);
2268 :    
2269 :     my $ret = waitpid($pid, 0);
2270 :     my $stat = $?;
2271 :     print STDERR "Return status is $?\n";
2272 :     print $log "Return status is $?\n";
2273 :    
2274 :     #
2275 :     # This chunk has finished. We should see a file
2276 :     # rows.$this_chunk.$n_chunks.
2277 :     #
2278 :     }
2279 :     }
2280 :     #
2281 :     # At this point, the extension is finished (we've run the
2282 :     # $n_chunks parts of the extension job).
2283 :     #
2284 : olson 1.12
2285 : olson 1.14 #
2286 : olson 1.23 # We read in all the individual rows files, writing the single
2287 :     # concatenation of rows.
2288 : olson 1.14 #
2289 : olson 1.12
2290 : olson 1.23 my $ssaD = $self->{dir};
2291 :    
2292 :     my $rows_file = "$ssaD/rows";
2293 :    
2294 :     my $rowFH;
2295 :     if (!open($rowFH, ">$rows_file"))
2296 : olson 1.12 {
2297 : olson 1.23 my $err = "Cannot open rows file $ssaD/rows for writing: $!\n";
2298 :     print STDERR $err;
2299 :     print $log $err;
2300 : olson 1.12 return;
2301 :     }
2302 :    
2303 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2304 :     {
2305 :     my $chunkFH;
2306 :     my $cfile = "$ssaD/rows.$this_chunk.$n_chunks";
2307 :     if (!open($chunkFH, "<$cfile"))
2308 :     {
2309 :     my $err = "Cannot open rows file $cfile for reading: $!\n";
2310 :     print STDERR $err;
2311 :     print $log $err;
2312 :     return;
2313 :     }
2314 :     while (<$chunkFH>)
2315 :     {
2316 :     print $rowFH $_;
2317 :     }
2318 :     close($chunkFH);
2319 :     }
2320 :     close($rowFH);
2321 : olson 1.12
2322 :     #
2323 : olson 1.23 # Concatenate the assignments into the assignment directory.
2324 : olson 1.12 #
2325 :    
2326 : olson 1.23 my $assignments_file = "$assign_dir$job_id";
2327 :     my $assignFH;
2328 : olson 1.12
2329 : olson 1.23 if (!open($assignFH, ">$assignments_file"))
2330 : olson 1.12 {
2331 : olson 1.23 my $err = "Cannot open assignments file $assignments_file for writing: $!\n";
2332 :     print STDERR $err;
2333 :     print $log $err;
2334 :     return;
2335 : olson 1.12 }
2336 :    
2337 : olson 1.23 for (my $this_chunk = 1; $this_chunk <= $n_chunks; $this_chunk++)
2338 : olson 1.19 {
2339 : olson 1.23 my $aFH;
2340 :     my $afile = "$ssaD/assignments.$this_chunk.$n_chunks";
2341 :     if (!open($aFH, "<$afile"))
2342 :     {
2343 :     my $err = "Cannot open assignments file $afile for reading: $!\n";
2344 :     print STDERR $err;
2345 :     print $log $err;
2346 :     return;
2347 :     }
2348 :     while (<$aFH>)
2349 :     {
2350 :     print $assignFH $_;
2351 :     }
2352 :     close($aFH);
2353 : olson 1.19 }
2354 : olson 1.23 close($assignFH);
2355 : olson 1.19
2356 : olson 1.23
2357 :    
2358 : olson 1.19 #
2359 : olson 1.14 # Back up the spreadsheet, and append the rows file to it.
2360 :     #
2361 :    
2362 :     &FIG::verify_dir("$ssaD/Backup");
2363 :     my $ts = time;
2364 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
2365 :     copy("$ssaD/spreadsheet","$ssaD/spreadsheet~");
2366 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
2367 :    
2368 :     #
2369 :     # Append the new rows to the spreadsheet.
2370 :     #
2371 :    
2372 :     my($ssafh, $rowsfh);
2373 :     open($ssafh, ">>$ssaD/spreadsheet") or die "Cannot open $ssaD/spreadsheet for append: $!\n";
2374 :     open($rowsfh, "<$ssaD/rows") or die "Cannot open $ssaD/rows for reading: $!\n";
2375 :    
2376 :     while (<$rowsfh>)
2377 :     {
2378 :     print $ssafh $_;
2379 :     }
2380 :     close($ssafh);
2381 :     close($rowsfh);
2382 :    
2383 :     $self->incr_version();
2384 : olson 1.12 }
2385 : olson 1.13
2386 : olson 1.14
2387 : olson 1.13 sub set_current_extend_pid
2388 :     {
2389 :     my($self, $pid) = @_;
2390 :    
2391 :     if (open(my $fh, ">$self->{dir}/EXTEND_PID"))
2392 :     {
2393 :     print $fh "$pid\n";
2394 :     }
2395 :     else
2396 :     {
2397 :     warn "Cannot open $self->{dir}/EXTEND_PID: $!\n";
2398 :     }
2399 :     }
2400 :    
2401 :     sub get_current_extend_pid
2402 :     {
2403 :     my($self) = @_;
2404 :    
2405 :     if (open(my $fh, "<$self->{dir}/EXTEND_PID"))
2406 :     {
2407 :     my $pid = <$fh>;
2408 :     close($fh);
2409 :     if ($pid)
2410 :     {
2411 :     chomp $pid;
2412 :    
2413 :     return $pid;
2414 :     }
2415 :     }
2416 :     return undef;
2417 :     }
2418 : olson 1.12
2419 : olson 1.7 package Subsystem::Diagram;
2420 :    
2421 :     sub new
2422 :     {
2423 :     my($class, $sub, $fig, $name, $dir) = @_;
2424 :    
2425 :     if (!-d $dir)
2426 :     {
2427 :     return undef;
2428 :     }
2429 :    
2430 :     my $self = {
2431 :     fig => $fig,
2432 :     subsystem => $sub,
2433 :     name => $name,
2434 :     dir =>$ dir,
2435 :     };
2436 :     bless $self, $class;
2437 :    
2438 :     $self->load();
2439 :    
2440 :     return $self;
2441 :     }
2442 :    
2443 :     #
2444 :     # Parse the diagram into internal data structure.
2445 :     #
2446 :    
2447 :     sub load
2448 :     {
2449 :     my($self) = @_;
2450 :    
2451 :     $self->load_area();
2452 :     }
2453 :    
2454 :     sub load_area
2455 :     {
2456 :     my($self) = @_;
2457 :     my $fh;
2458 :    
2459 : olson 1.8 if (!open($fh, "<$self->{dir}/area_table"))
2460 : olson 1.7 {
2461 : olson 1.8 warn "Could not load $self->{dir}/area_table: $!\n";
2462 : olson 1.7 return;
2463 :     }
2464 :    
2465 :     $self->{areas} = [];
2466 :    
2467 :     my $area_list = $self->{areas};
2468 :    
2469 :     while (<$fh>)
2470 :     {
2471 :     chomp;
2472 :     s/#.*$//;
2473 :     s/^\s+//;
2474 :     s/\s+$//;
2475 :     next if $_ eq '';
2476 :     my ($area, $tag, $value) = split(/\s+/, $_, 3);
2477 :     # print "area=$area tag=$tag value=$value\n";
2478 :    
2479 :     push(@$area_list, [$area, $tag, $value]);
2480 :    
2481 :     #
2482 :     # Do a little checking.
2483 :     #
2484 :    
2485 :     if ($tag eq "role")
2486 :     {
2487 :     my $idx = $self->{subsystem}->get_role_index($value);
2488 :     if (!defined($idx))
2489 :     {
2490 :     warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
2491 :     }
2492 :     }
2493 :     }
2494 :     close($fh);
2495 :     }
2496 :    
2497 :     sub get_areas
2498 :     {
2499 :     my($self) = @_;
2500 :    
2501 :     return @{$self->{areas}};
2502 :     }
2503 :    
2504 : olson 1.1 1;
2505 : olson 1.7
2506 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3