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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3