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

Annotation of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3