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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1
2 :     package Subsystem;
3 :    
4 :     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 :     =head2 Thoughts on locking
29 :    
30 :     It is currently dangerous for multiple users to modify spreadsheets at once.
31 :     It will likely remain dangerous while the subsystem backend is fairly
32 :     stateless, as it is with the CGI mechanism.
33 :    
34 :     We'd like to make this a little safer. One mechanism might be to allow
35 :     a user to open a subsystem for modification, and others for readonly access.
36 :     For this to work we have to be able to tell which users is allowed; current
37 :     implementation uses the curator of the subsystem for this purpose.
38 :    
39 :     NB: This module does not currently attempt to handle locking or exclusion.
40 :     It is up to the caller (user application, CGI script, etc) to do so.
41 :     It does attempt to use locking internally where appropriate.
42 :    
43 :     =head2 Data structures
44 :    
45 :     We maintain the following data structures (all members of %$self).
46 :    
47 :     =over 4
48 :    
49 :     =item dir
50 :    
51 :     Directory in which the subsystem is stored.
52 :    
53 :     =item notes
54 :    
55 :     The current notes contents for the subsystem
56 :    
57 :     =item version
58 :    
59 :     Current subsystem version.
60 :    
61 :     =item exchangable
62 :    
63 :     1 if subsystem is exchangable, 0 otherwise.
64 :    
65 :    
66 :     =item roles
67 :    
68 :     list of role names
69 :    
70 :     =item role_index
71 :    
72 :     hash that maps from role name to index
73 :    
74 :     =item role_abbrs
75 :    
76 :     list of role abbreviations
77 :    
78 :     =item abbr
79 :    
80 :     hash mapping from role abbreviation to role name
81 :    
82 :     =item col_subsets
83 :    
84 :     list of column subset names
85 :    
86 :     =item col_subset_members
87 :    
88 :     hash that maps from column subset name to subset members
89 :    
90 :     =item col_active_subset
91 :    
92 :     currently-active column subset
93 :    
94 :     =item row_active_subset
95 :    
96 :     currently-active row subset
97 :    
98 :     =item genome
99 :    
100 :     List (1-indexed, so element 0 is undef) of genome IDs.
101 :    
102 :     =item variant_code
103 :    
104 :     List (1-indexed, so element 0 is undef) of variant codes.
105 :    
106 :     =item genome_index
107 :    
108 :     Hash mapping from genome ID to genome index.
109 :    
110 :     =item variant_code
111 :    
112 :     List (1-indexed, so element 0 is undef) of variant codes.
113 :    
114 :     =item spreadsheet
115 :    
116 :     Spreadsheet data. Structured as a list of rows, each of which
117 :     is a list of entries. An entry is a list of PEG numbers.
118 :    
119 :     =item spreadsheet_inv
120 :    
121 :     Inverted structure of spreadsheet - list of columns, each of which is a list
122 :     of rows.
123 :    
124 :     =back
125 :    
126 :     =cut
127 : olson 1.1
128 :     use FIG;
129 :    
130 :     =pod
131 :    
132 :     =head1 Subsystem constructor
133 :    
134 :     usage: $sub = Subsystem->new("subsystem name", $fig, $createFlag)
135 :    
136 :     Load the subsystem. If it does not exist, and $createFlag is true, create
137 :     a new empty subsystem.
138 :    
139 :     =cut
140 :    
141 :     sub new
142 :     {
143 :     my($class, $name, $fig, $create) = @_;
144 :    
145 :     my $ssa_dir = get_dir_from_name($name);
146 :    
147 :     #
148 :     # For loading, the subsystem directory must already exist.
149 :     #
150 :    
151 :     if (! -d $ssa_dir)
152 :     {
153 :     if ($create)
154 :     {
155 :     return create_subsystem($class, $name, $fig);
156 :     }
157 :     else
158 :     {
159 : olson 1.11 # warn "Subsystem $name does not exist\n";
160 : olson 1.1 return undef;
161 :     }
162 :     }
163 :    
164 :     my $self = {
165 :     dir => $ssa_dir,
166 :     name => $name,
167 :     fig => $fig,
168 :     };
169 :    
170 :     bless($self, $class);
171 :    
172 :     $self->load();
173 :    
174 :     return $self;
175 :     }
176 :    
177 : olson 1.19 sub new_from_dir
178 :     {
179 :     my($class, $dir, $fig) = @_;
180 :    
181 :     my $ssa_dir = $dir;
182 :     my $name;
183 :    
184 :     #
185 :     # For loading, the subsystem directory must already exist.
186 :     #
187 :    
188 :     my $self = {
189 :     dir => $ssa_dir,
190 :     name => $name,
191 :     fig => $fig,
192 :     };
193 :    
194 :     bless($self, $class);
195 :    
196 :     $self->load();
197 :    
198 :     return $self;
199 :     }
200 :    
201 : olson 1.1 sub create_subsystem
202 :     {
203 :     my($class, $name, $fig) = @_;
204 :    
205 :     return undef;
206 :     }
207 :    
208 : olson 1.5 #
209 : olson 1.7 # Retrieve the diagrams associated with this subsystem.
210 :     #
211 :     # This is done via a lookup into FIG/Data/SubsystemDiagrams/<ssaname>/<diagram-name>.
212 :     #
213 :     # Returned is a list of names.
214 :     #
215 :    
216 :     sub get_diagrams
217 :     {
218 :     my($self) = @_;
219 :    
220 :     my $b = $self->{name};
221 :     $b =~ s/ /_/g;
222 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b);
223 :    
224 :     my $dh = new DirHandle($dir);
225 :    
226 :     my @names = grep(/^[^.]/, $dh->read());
227 :    
228 :     return @names;
229 :     }
230 :    
231 :     #
232 :     # Return a Subsystem::Diagram object for this diagram.
233 :     #
234 :     sub get_diagram
235 :     {
236 :     my($self, $name) = @_;
237 :    
238 :     my $b = $self->{name};
239 :     $b =~ s/ /_/g;
240 :     my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b, $name);
241 :    
242 :     if (-d $dir)
243 :     {
244 :     return Subsystem::Diagram->new($self, $self->{fig}, $name, $dir);
245 :     }
246 :     else
247 :     {
248 :     return undef;
249 :     }
250 :     }
251 :    
252 :     #
253 : olson 1.5 # Synchronize the database index for this subsystem to the
254 :     # subsystem data.
255 :     #
256 :     # We assume the table already exists.
257 :     #
258 :    
259 :     sub db_sync
260 :     {
261 :     my($self, $skip_delete) = @_;
262 :    
263 :     my $rdbH = $self->{fig}->db_handle();
264 :    
265 :     if (!$skip_delete)
266 :     {
267 :     $rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")
268 :     }
269 :    
270 :     #
271 :     # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
272 :     #
273 :    
274 : olson 1.6 my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?)");
275 :    
276 : olson 1.5 for my $role ($self->get_roles())
277 :     {
278 :     my $ridx = $self->get_role_index($role);
279 :     my $col = $self->get_col($ridx);
280 :     for my $cell (@$col)
281 :     {
282 :     if ($cell)
283 :     {
284 :     for my $peg (@$cell)
285 :     {
286 : olson 1.6 $sth->execute($peg, $self->{name}, $role);
287 : olson 1.5 }
288 :     }
289 :     }
290 :     }
291 :     }
292 :    
293 : olson 1.1 sub load
294 :     {
295 :     my($self) = @_;
296 :    
297 :     #
298 :     # Load the subsystem.
299 :     #
300 :    
301 :     my $ssa;
302 :     if (!open($ssa,"<$self->{dir}/spreadsheet"))
303 :     {
304 :     warn "Spreadsheet does not exist in subsystem\n";
305 :     return;
306 :     }
307 :    
308 :     local $/ = "//\n";
309 :    
310 :     my $roles = <$ssa>;
311 :     if ($roles)
312 :     {
313 :     $roles =~ s,$/$,,;
314 :     #
315 :     # Split on newline, filter for non-empty lines.
316 :     #
317 :     my @roles = split("\n", $roles);
318 :    
319 :     @roles = grep { $_ ne "" } @roles;
320 :    
321 :     $self->load_roles(@roles);
322 :     }
323 :    
324 :     my $subsets = <$ssa>;
325 :     if ($subsets)
326 :     {
327 :     $subsets =~ s,$/$,,;
328 :     $self->load_subsets($subsets);
329 :     }
330 :    
331 :     $/ = "\n";
332 :    
333 :     $self->load_genomes($ssa);
334 :    
335 :     #
336 :     # Now load the rest of the info.
337 :     #
338 :    
339 :     $self->load_notes();
340 :     $self->load_version();
341 :     $self->load_exchangable();
342 : olson 1.17 $self->load_curation();
343 : olson 1.1 }
344 :    
345 :     sub load_notes
346 :     {
347 :     my($self) = @_;
348 :    
349 :     $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
350 :     }
351 :    
352 : olson 1.17 sub load_curation
353 :     {
354 :     my($self) = @_;
355 :    
356 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "curation.log"), 1);
357 :    
358 :     $_ = $l[0];
359 :     chomp;
360 :     if (/^\d+\t(\S+)\s+started/)
361 :     {
362 :     $self->{curator} = $1;
363 :     }
364 :     }
365 :    
366 : olson 1.1 sub load_version
367 :     {
368 :     my($self) = @_;
369 :    
370 :     my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
371 :     my $l = $l[0];
372 :     chomp $l;
373 :     $self->{version} = $l;
374 :     }
375 :    
376 :     sub load_exchangable
377 :     {
378 :     my($self) = @_;
379 :    
380 :     my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");
381 :    
382 :     if (-f $file)
383 :     {
384 :     my($l, @l);
385 :    
386 :     @l = &FIG::file_head($file, 1);
387 :     $l = $l[0];
388 :     chomp $l;
389 :     $self->{exchangable} = $l;
390 :     }
391 :     else
392 :     {
393 :     $self->{exchangable} = 0;
394 :     }
395 :     }
396 :    
397 :    
398 :     sub load_roles
399 :     {
400 :     my($self, @roles) = @_;
401 :    
402 : olson 1.5 $self->{abbr} = {};
403 :     $self->{role_index} = {};
404 :     $self->{roles} = [];
405 :     $self->{role_abbrs} = [];
406 :    
407 : olson 1.1 my $i = 1;
408 :     for my $role (@roles)
409 :     {
410 :     my($abbr, $name) = split(/\t/, $role);
411 : olson 1.2 # print "Role $i: abbr=$abbr name=$name\n";
412 : olson 1.1
413 :     $self->{abbr}->{$abbr} = $name;
414 :     $self->{role_index}->{$name} = $i;
415 :     $self->{roles}->[$i] = $name;
416 : olson 1.4 $self->{role_abbrs}->[$i] = $abbr;
417 : olson 1.1 $i++;
418 :     }
419 :     }
420 :    
421 :     sub load_subsets
422 :     {
423 :     my($self, $subsets) = @_;
424 :    
425 :     #
426 :     # Column and row subsets.
427 :     #
428 :     my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);
429 :    
430 :    
431 :     #
432 :     # Handle column subsets.
433 :     #
434 :    
435 :     my @subsetsC = split(/\n/, $subsetsC);
436 :    
437 :     #
438 :     # Determine active subset.
439 :     #
440 :    
441 :     my $active_subsetC;
442 :     if (@subsetsC > 0)
443 :     {
444 :     $active_subsetC = pop(@subsetsC);
445 :     }
446 :     else
447 :     {
448 :     $active_subsetC = 'All';
449 :     }
450 :    
451 :     $self->{col_active_subset} = $active_subsetC;
452 :    
453 :     $self->{col_subsets} = [];
454 : olson 1.5 $self->{col_subset_members} = {};
455 :    
456 : olson 1.1 for my $subset (@subsetsC)
457 :     {
458 :     my($name, @members) = split(/\s+/, $subset);
459 :    
460 :     push(@{$self->{col_subsets}}, $name);
461 :    
462 :     #
463 :     # Map role members from name to index if necessary.
464 :     #
465 :     # Is it really necessary? ssa2 code was looking up in %pos for this.
466 :     #
467 :     @members = map {
468 :     if (my $new = $self->{role_index}->{$_})
469 :     {
470 :     $new;
471 :     }
472 :     else
473 :     {
474 :     $_;
475 :     }
476 :     } @members;
477 :    
478 :     @{$self->{col_subset_members}->{$name}} = @members;
479 :     }
480 :    
481 :     #
482 :     # Now the row subsets.
483 :     #
484 :    
485 :     chomp($subsetsR);
486 :    
487 :     if ($subsetsR =~ /(\S+.*\S+)/)
488 :     {
489 :     $self->{row_subset_active} = $1;
490 :     }
491 :     else
492 :     {
493 :     $self->{row_subset_active} = 'All';
494 :     }
495 :     }
496 :    
497 :     sub load_genomes
498 :     {
499 :     my($self, $fh) = @_;
500 :     my(%seen);
501 :    
502 : olson 1.5 $self->{spreadsheet} = [];
503 :     $self->{spreadshhet_inv} = [];
504 :     $self->{genome} = [];
505 :     $self->{genome_index} = {};
506 :     $self->{variant_code} = [];
507 :    
508 : olson 1.1 my $i = 1;
509 :     while (<$fh>)
510 :     {
511 :     chomp;
512 :    
513 :     my($genome, $variant_code, @row) = split(/\t/);
514 :    
515 :     next if $seen{$genome};
516 :     $seen{$genome}++;
517 :    
518 :     my $j = 1;
519 :    
520 :     $self->{genome}->[$i] = $genome;
521 :     $self->{genome_index}->{$genome} = $i;
522 :     $self->{variant_code}->[$i] = $variant_code;
523 :    
524 :     for my $entry (@row)
525 :     {
526 :     my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
527 :     $self->{spreadsheet}->[$i]->[$j] = $e2;
528 :     $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
529 :     $j++;
530 :     }
531 :     $i++;
532 :    
533 :     }
534 :     }
535 :    
536 : olson 1.2 =pod
537 :    
538 :     =head1 get_genomes
539 :    
540 :     =cut
541 :    
542 :     sub get_genomes
543 :     {
544 :     my($self) = @_;
545 :    
546 :     my $glist = $self->{genome};
547 :    
548 :     return @$glist[1..$#$glist];
549 :     }
550 :    
551 :     =pod
552 :    
553 :     =head1 get_variant_codes
554 :    
555 :     =cut
556 :    
557 :     sub get_variant_codes
558 :     {
559 :     my($self) = @_;
560 :    
561 :     my $glist = $self->{variant_code};
562 :    
563 :     return @$glist[1..$#$glist];
564 :     }
565 :    
566 :     sub get_variant_code_for_genome
567 :     {
568 :     my($self, $genome) = @_;
569 :    
570 :     my $index = $self->{genome_index}->{$genome};
571 :     return $self->{variant_code}->[$index];
572 :     }
573 :    
574 :     sub get_roles
575 :     {
576 :     my($self) = @_;
577 :    
578 :     my $rlist = $self->{roles};
579 :    
580 :     return @$rlist[1..$#$rlist];
581 :     }
582 :    
583 : olson 1.10 sub get_row :scalar
584 : olson 1.1 {
585 :     my($self, $row) = @_;
586 :    
587 :     return $self->{spreadsheet}->[$row];
588 :     }
589 :    
590 : olson 1.21 sub get_col :scalar
591 : olson 1.1 {
592 :     my($self, $col) = @_;
593 :    
594 :     return $self->{spreadsheet_inv}->[$col];
595 :     }
596 :    
597 : olson 1.21 sub get_cell :scalar
598 : olson 1.1 {
599 :     my($self, $row, $col) = @_;
600 :    
601 : olson 1.5 my $cell = $self->{spreadsheet}->[$row]->[$col];
602 :     return $cell;
603 : olson 1.1 }
604 :    
605 : olson 1.21 sub get_genome_index :scalar
606 : olson 1.3 {
607 :     my($self, $genome) = @_;
608 :    
609 :     return $self->{genome_index}->{$genome};
610 :     }
611 :    
612 : olson 1.21 sub get_genome :scalar
613 : olson 1.3 {
614 :     my($self, $gidx) = @_;
615 :    
616 :     return $self->{genome}->[$gidx];
617 :     }
618 :    
619 : olson 1.21 sub get_role_index :scalar
620 : olson 1.5 {
621 :     my($self, $role) = @_;
622 :    
623 :     return $self->{role_index}->{$role};
624 :     }
625 :    
626 : olson 1.21 sub get_role :scalar
627 : olson 1.3 {
628 :     my($self, $ridx) = @_;
629 :    
630 :     return $self->{roles}->[$ridx];
631 :     }
632 :    
633 : olson 1.21 sub get_role_abbr :scalar
634 : olson 1.4 {
635 :     my($self, $ridx) = @_;
636 :    
637 :     return $self->{role_abbrs}->[$ridx];
638 :     }
639 :    
640 : olson 1.21 sub get_role_from_abbr :scalar
641 : olson 1.20 {
642 :     my($self, $abbr) = @_;
643 :    
644 :     return $self->{abbr}->{$abbr};
645 :     }
646 :    
647 : olson 1.1 sub get_pegs_from_cell
648 :     {
649 :     my($self, $rowstr, $colstr) = @_;
650 :     my($row, $col);
651 :    
652 :     #
653 :     # If row isn't numeric, look it up in the genomes list.
654 :     #
655 :    
656 :     if ($rowstr !~ /^\d+$/)
657 :     {
658 :     $row = $self->{genome_index}->{$rowstr};
659 :     }
660 :     else
661 :     {
662 :     $row = $rowstr;
663 :     }
664 :    
665 :     if (!$row)
666 :     {
667 :     warn "Cannot find row for $rowstr\n";
668 :     return undef;
669 :     }
670 :    
671 :     #
672 :     # If col isn't numeric, look it up in the roles and role abbreviations.
673 :     #
674 :    
675 :     if ($colstr !~ /^\d+$/)
676 :     {
677 :     #
678 :     # See if it's an abbr
679 :     #
680 :    
681 :     my $a = $self->{abbr}->{$colstr};
682 :     $colstr = $a if $a;
683 :    
684 :     $col = $self->{role_index}->{$colstr};
685 :     }
686 :     else
687 :     {
688 :     $col = $colstr;
689 :     }
690 :    
691 :     if (!$col)
692 :     {
693 :     warn "Cannot find col for $colstr\n";
694 :     return undef;
695 :     }
696 : olson 1.12 my $cell = $self->get_cell($row, $col);
697 : olson 1.1
698 :     if ($cell)
699 :     {
700 :     return @$cell;
701 :     }
702 :     else
703 :     {
704 :     return undef;
705 :     }
706 :     }
707 :    
708 : olson 1.17 sub get_name :scalar
709 :     {
710 :     my($self) = @_;
711 :     return $self->{name};
712 :     }
713 :    
714 :    
715 :     sub get_version :scalar
716 :     {
717 :     my($self) = @_;
718 :     return $self->{version};
719 :     }
720 :    
721 :     sub get_curator :scalar
722 :     {
723 :     my($self) = @_;
724 :     return $self->{curator};
725 :     }
726 :    
727 :    
728 : olson 1.1 sub dump
729 :     {
730 :     my($self) = @_;
731 :    
732 :     for my $k (keys(%$self))
733 :     {
734 :     next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
735 :     print "Key \"$k\": ", Dumper($self->{$k});
736 :     }
737 :     }
738 :    
739 : olson 1.14 #
740 :     # Increment the subsystem's version number.
741 :     #
742 :     sub incr_version {
743 :     my($self) = @_;
744 :    
745 :     my $dir = $self->{dir};
746 :     my $vfile = "$dir/VERSION";
747 :     my($ver);
748 :    
749 :     if (open(my $fh,"<$vfile"))
750 :     {
751 :     if (defined($ver = <$fh>) && ($ver =~ /^(\S+)/))
752 :     {
753 :     $ver = $1;
754 :     }
755 :     else
756 :     {
757 :     $ver = 0;
758 :     }
759 :     close($fh);
760 :     }
761 :     else
762 :     {
763 :     $ver = 0;
764 :     }
765 :    
766 :     $ver++;
767 :    
768 :     open(my $fh, ">$vfile") || die "could not open $vfile";
769 :     print $fh "$ver\n";
770 :     close($fh);
771 :    
772 :     chmod(0777, $vfile);
773 :    
774 :     $self->load_version();
775 :     }
776 : olson 1.1
777 :     sub get_dir_from_name
778 :     {
779 :     my($name) = @_;
780 :    
781 :     my $b = $name;
782 :     $b =~ s/ /_/g;
783 :     my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
784 :     return $dir;
785 :     }
786 :    
787 : olson 1.12 #
788 :     # Code for dealing with Bill McCune's prolog code for extending subsystems.
789 :     #
790 :     # The code here is a reconstruction of Bill's "go" script in perl with
791 :     # data pulled from the local SEED configuration.
792 :     #
793 :    
794 :     sub extend_with_billogix
795 :     {
796 :     my($self, $muser) = @_;
797 :     my($isMaster, $user);
798 :    
799 :     my $now = time();
800 :    
801 :     if ($muser =~ /master:(.*)/)
802 :     {
803 :     $isMaster = 1;
804 :     $user = $1;
805 :     }
806 :     else
807 :     {
808 :     $isMaster = 0;
809 :     $user = $muser;
810 :     }
811 :    
812 :     #
813 :     # Find the executable.
814 :     #
815 :    
816 :     my $exe = "$FIG_Config::bin/billogix";
817 :    
818 :     if (! -x $exe)
819 :     {
820 :     warn "Cannot find billogix exe at $exe\n";
821 :     return;
822 :     }
823 :    
824 :     my $ss_name = $self->{name};
825 : olson 1.18
826 :     $ss_name =~ s/\s+/_/g;
827 :    
828 : olson 1.14 my $ss_dir = "$self->{dir}/";
829 : olson 1.15 my $assign_dir = "$FIG_Config::data/Assignments/$user/";
830 : olson 1.12 &FIG::verify_dir($assign_dir);
831 :    
832 : olson 1.16 my $when= strftime("%m-%d-%y:%H:%M:%S", localtime($now));
833 :     my $job_id = "${when}:sss:$ss_name";
834 :    
835 : olson 1.12 my $seed = &FIG::cgi_url() . "/";
836 : olson 1.13 my $export_part = "ssa.cgi?user=$muser&request=delete_or_export_ssa&export=";
837 : olson 1.12
838 :     #
839 :     # Have the prereq stuff, now start up the app.
840 :     #
841 :    
842 :     $ENV{LOCALSZ} = "80000";
843 :     $ENV{GLOBALSZ} = "80000";
844 :     $ENV{TRAILSZ} = "30000";
845 : olson 1.13
846 :     my $arch = &FIG::get_current_arch();
847 :    
848 :     $ENV{BILLOGIX} = "$FIG_Config::fig_disk/dist/releases/current/$arch/lib/Billogix";
849 :    
850 :     #
851 :     # Need to ensure pl2wam is in our path
852 :     #
853 :    
854 :     $ENV{PATH} = "${FIG_Config::ext_bin}:$ENV{PATH}";
855 : olson 1.12
856 :     my $app_input = <<EOINP;
857 :     ['\$BILLOGIX/top'].
858 :     loadup.
859 :     asserta(url_default_seed('$seed')).
860 : olson 1.13 asserta(url_export_part('$export_part')).
861 : olson 1.12 asserta(ss_directory('$ss_dir')).
862 :     asserta(assign_directory('$assign_dir')).
863 :     asserta(job_id('$job_id')).
864 :     extend_test3('$ss_name').
865 :     EOINP
866 :    
867 :     print STDERR <<EOF;
868 :     Starting app
869 :    
870 :     ss_name = $ss_name
871 :     ss_dir = $ss_dir
872 :     user = $user
873 :     assign_dir = $assign_dir
874 :     exe = $exe
875 : olson 1.13 libdir = $ENV{BILLOGIX}
876 :     path = $ENV{PATH}
877 : olson 1.12
878 :     App input
879 :     $app_input
880 :     EOF
881 :     # feh, put in a block to reset perlmode indentation.
882 :     {
883 :     my($app_read, $app_write, $log);
884 :    
885 : olson 1.16 open($log, ">$ss_dir/$job_id.log");
886 : olson 1.12
887 : olson 1.14 #
888 :     # Start the actual application with stdin and stdout redirected
889 :     # to pipes.
890 :     #
891 :     # We write $app_input to the stdin pipe, and close it.
892 :     # Then loop reading stdout, logging that output.
893 :     #
894 : olson 1.12 my $pid = open2($app_read, $app_write, $exe);
895 :    
896 :     if (!$pid)
897 :     {
898 :     warn "open2 $exe failed: $!\n";
899 :     print $log "open2 $exe failed: $!\n";
900 :     return;
901 :     }
902 :    
903 :     print $app_write $app_input;
904 :     close($app_write);
905 :    
906 :     #
907 :     # Set autoflush on the logfile.
908 :     #
909 :    
910 :     my $old = select($log);
911 :     $| = 1;
912 :     select(STDERR);
913 :     $| = 1;
914 :     select($old);
915 :    
916 :     warn "Starting $exe with pid $pid\n";
917 :     print $log "Starting $exe with pid $pid\n";
918 :    
919 :     while (<$app_read>)
920 :     {
921 :     print STDERR $_;
922 :     print $log $_;
923 :     }
924 :    
925 :     print STDERR "App done\n";
926 :     print $log "App done\n";
927 :    
928 :     close($app_read);
929 :    
930 :     my $ret = waitpid($pid, 0);
931 :     my $stat = $?;
932 :     print STDERR "Return status is $?\n";
933 :     print $log "Return status is $?\n";
934 : olson 1.14
935 : olson 1.19
936 : olson 1.14 #
937 :     # At this point, the extension is finished.
938 : olson 1.19 # Make sure we have a rows file after the run.
939 :     #
940 :    
941 :     my $ssaD = $self->{dir};
942 :    
943 :     my $rows_file = "$ssaD/rows";
944 :     if (! -f $rows_file)
945 :     {
946 :     print STDERR "Missing rows file: $ssaD/rows\n";
947 :     print $log "Missing rows file: $ssaD/rows\n";
948 :     return;
949 :     }
950 :    
951 :     #
952 : olson 1.14 # Back up the spreadsheet, and append the rows file to it.
953 :     #
954 :    
955 :     &FIG::verify_dir("$ssaD/Backup");
956 :     my $ts = time;
957 :     rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
958 :     copy("$ssaD/spreadsheet","$ssaD/spreadsheet~");
959 :     rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
960 :    
961 :     #
962 :     # Append the new rows to the spreadsheet.
963 :     #
964 :    
965 :     my($ssafh, $rowsfh);
966 :     open($ssafh, ">>$ssaD/spreadsheet") or die "Cannot open $ssaD/spreadsheet for append: $!\n";
967 :     open($rowsfh, "<$ssaD/rows") or die "Cannot open $ssaD/rows for reading: $!\n";
968 :    
969 :     while (<$rowsfh>)
970 :     {
971 :     print $ssafh $_;
972 :     }
973 :     close($ssafh);
974 :     close($rowsfh);
975 :    
976 :     $self->incr_version();
977 : olson 1.12 }
978 : olson 1.14
979 : olson 1.12 }
980 : olson 1.13
981 : olson 1.14
982 : olson 1.13 sub set_current_extend_pid
983 :     {
984 :     my($self, $pid) = @_;
985 :    
986 :     if (open(my $fh, ">$self->{dir}/EXTEND_PID"))
987 :     {
988 :     print $fh "$pid\n";
989 :     }
990 :     else
991 :     {
992 :     warn "Cannot open $self->{dir}/EXTEND_PID: $!\n";
993 :     }
994 :     }
995 :    
996 :     sub get_current_extend_pid
997 :     {
998 :     my($self) = @_;
999 :    
1000 :     if (open(my $fh, "<$self->{dir}/EXTEND_PID"))
1001 :     {
1002 :     my $pid = <$fh>;
1003 :     close($fh);
1004 :     if ($pid)
1005 :     {
1006 :     chomp $pid;
1007 :    
1008 :     return $pid;
1009 :     }
1010 :     }
1011 :     return undef;
1012 :     }
1013 : olson 1.12
1014 : olson 1.7 package Subsystem::Diagram;
1015 :    
1016 :     sub new
1017 :     {
1018 :     my($class, $sub, $fig, $name, $dir) = @_;
1019 :    
1020 :     if (!-d $dir)
1021 :     {
1022 :     return undef;
1023 :     }
1024 :    
1025 :     my $self = {
1026 :     fig => $fig,
1027 :     subsystem => $sub,
1028 :     name => $name,
1029 :     dir =>$ dir,
1030 :     };
1031 :     bless $self, $class;
1032 :    
1033 :     $self->load();
1034 :    
1035 :     return $self;
1036 :     }
1037 :    
1038 :     #
1039 :     # Parse the diagram into internal data structure.
1040 :     #
1041 :    
1042 :     sub load
1043 :     {
1044 :     my($self) = @_;
1045 :    
1046 :     $self->load_area();
1047 :     }
1048 :    
1049 :     sub load_area
1050 :     {
1051 :     my($self) = @_;
1052 :     my $fh;
1053 :    
1054 : olson 1.8 if (!open($fh, "<$self->{dir}/area_table"))
1055 : olson 1.7 {
1056 : olson 1.8 warn "Could not load $self->{dir}/area_table: $!\n";
1057 : olson 1.7 return;
1058 :     }
1059 :    
1060 :     $self->{areas} = [];
1061 :    
1062 :     my $area_list = $self->{areas};
1063 :    
1064 :     while (<$fh>)
1065 :     {
1066 :     chomp;
1067 :     s/#.*$//;
1068 :     s/^\s+//;
1069 :     s/\s+$//;
1070 :     next if $_ eq '';
1071 :     my ($area, $tag, $value) = split(/\s+/, $_, 3);
1072 :     # print "area=$area tag=$tag value=$value\n";
1073 :    
1074 :     push(@$area_list, [$area, $tag, $value]);
1075 :    
1076 :     #
1077 :     # Do a little checking.
1078 :     #
1079 :    
1080 :     if ($tag eq "role")
1081 :     {
1082 :     my $idx = $self->{subsystem}->get_role_index($value);
1083 :     if (!defined($idx))
1084 :     {
1085 :     warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
1086 :     }
1087 :     }
1088 :     }
1089 :     close($fh);
1090 :     }
1091 :    
1092 :     sub get_areas
1093 :     {
1094 :     my($self) = @_;
1095 :    
1096 :     return @{$self->{areas}};
1097 :     }
1098 :    
1099 : olson 1.1 1;
1100 : olson 1.7
1101 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3