[Bio] / Sprout / SproutSubsys.pm Repository:
ViewVC logotype

Annotation of /Sprout/SproutSubsys.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package SproutSubsys;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use PageBuilder;
8 :     use FIG;
9 :     use Sprout;
10 :    
11 :     =head1 Sprout Subsystem Object
12 :    
13 :     =head2 Introduction
14 :    
15 :     This object emulates the capabilities of the FIG-style C<Subsystem> object, but
16 :     uses Sprout methods to retrieve the data. This object can be dropped in place of
17 :     the UnvSubsys object to create subsystem displays for the Sprout rather than the
18 :     SEED.
19 :    
20 :     The structure created by the constructor contains the following data members.
21 :    
22 :     =over 4
23 :    
24 :     =item name
25 :    
26 :     Name of the subsystem. This is needed for any further database accesses required.
27 :    
28 :     =item curator
29 :    
30 :     Name of the subsystem's official curator.
31 :    
32 :     =item notes
33 :    
34 :     General notes about the subsystem.
35 :    
36 :     =item sprout
37 :    
38 :     Sprout object for accessing the database. This is a genuine Sprout object, not
39 :     an SFXlate object.
40 :    
41 :     =item genomeHash
42 :    
43 :     Map of genome IDs to row indices.
44 :    
45 :     =item genomes
46 :    
47 :     List of [genomeID, variantCode] tuples in row order.
48 :    
49 :     =item roleHash
50 :    
51 :     Map of role IDs and abbreviations to column indices. In other words, plugging
52 :     either a full-blown role ID or its abbreviation into this hash will return
53 :     the role's column index.
54 :    
55 :     =item roles
56 :    
57 :     List of [roleID, abbreviation] tuples in column order.
58 :    
59 : parrello 1.9 =item dir
60 :    
61 :     Directory root for the diagram and image files.
62 :    
63 : parrello 1.1 =item reactionHash
64 :    
65 :     Map of role IDs to a list of the reactions catalyzed by the role.
66 :    
67 :     =item colorHash
68 :    
69 :     Map of PEG IDs to cluster numbers. This is used to create color maps for
70 :     display of a subsystem's PEGs.
71 :    
72 :     =back
73 :    
74 :     =cut
75 :    
76 :     #: Constructor SproutSubsys->new();
77 :    
78 :     =head2 Public Methods
79 :    
80 :     =head3 new
81 :    
82 :     C<< my $sub = Subsystem->new($subName, $sprout); >>
83 :    
84 :     Load the subsystem.
85 :    
86 :     =over 4
87 :    
88 :     =item subName
89 :    
90 :     Name of the desired subsystem.
91 :    
92 :     =item sprout
93 :    
94 :     Sprout or SFXlate object for accessing the Sprout data store.
95 :    
96 :     =back
97 :    
98 :     =cut
99 :    
100 :     sub new {
101 :     # Get the parameters.
102 :     my ($class, $subName, $sprout) = @_;
103 :     # Insure we have a Sprout object.
104 :     if (ref $sprout eq 'SFXlate') {
105 :     $sprout = $sprout->{sprout};
106 :     }
107 :     # Declare the return value.
108 :     my $retVal;
109 :     # Get the subsystem's data fields.
110 :     my ($curator, $notes) = $sprout->GetEntityValues('Subsystem', $subName, ['Subsystem(curator)',
111 :     'Subsystem(notes)']);
112 :     # Only proceed if we found the subsystem.
113 :     if (defined $curator) {
114 :     # Get the genome IDs and variant codes for the rows. The list returned
115 :     # by GetAll will be a list of 2-tuples, each consisting of a genome ID
116 :     # and a subsystem variant code.
117 :     my @genomes = $sprout->GetAll(['ParticipatesIn'],
118 :     'ParticipatesIn(to-link) = ? ORDER BY ParticipatesIn(variant-code), ParticipatesIn(from-link)',
119 :     [$subName], ['ParticipatesIn(from-link)',
120 :     'ParticipatesIn(variant-code)']);
121 :     # Create the genome ID directory. This is a hash that maps a genome ID to its
122 :     # row index.
123 :     my $idx = 0;
124 :     my %genomeHash = map { $_->[0] => $idx++ } @genomes;
125 :     # Get the role IDs and abbreviations. The list returned by GetAll will be
126 :     # a list of 2-tuples, each consisting of a role ID and abbreviation. The
127 :     # 2-tuples will be ordered by the spreadsheet column number.
128 : parrello 1.11 my @roles = $sprout->GetAll(['OccursInSubsystem'],
129 : parrello 1.1 'OccursInSubsystem(to-link) = ? ORDER BY OccursInSubsystem(column-number)',
130 : parrello 1.11 [$subName], ['OccursInSubsystem(from-link)', 'OccursInSubsystem(abbr)']);
131 : parrello 1.1 # Now we need to create the role ID directory and the reaction hash.
132 :     # The role ID directory maps role IDs and their abbreviations to column numbers.
133 :     # The reaction hash maps a role ID to a list of the IDs for the reactions it
134 :     # catalyzes.
135 :     my %roleHash = ();
136 : parrello 1.11 my %abbrHash = ();
137 : parrello 1.1 my %reactionHash = ();
138 :     for ($idx = 0; $idx <= $#roles; $idx++) {
139 :     # Get the role ID and abbreviation for this column's role.
140 :     my ($roleID, $abbr) = @{$roles[$idx]};
141 :     # Put them both in the role directory.
142 :     $roleHash{$roleID} = $idx;
143 :     $roleHash{$abbr} = $idx;
144 : parrello 1.11 # Put the full name in the abbreviation directory.
145 :     $abbrHash{$abbr} = $roleID;
146 : parrello 1.1 # Get this role's reactions.
147 :     my @reactions = $sprout->GetFlat(['Catalyzes'], 'Catalyzes(from-link) = ?',
148 :     [$roleID], 'Catalyzes(to-link)');
149 :     # Put them in the reaction hash.
150 : parrello 1.3 if (@reactions > 0) {
151 :     $reactionHash{$roleID} = \@reactions;
152 :     }
153 : parrello 1.1 }
154 : parrello 1.9 # Find the subsystem directory.
155 :     my $subDir = Subsystem::get_dir_from_name($subName);
156 :     Trace("Subsystem directory is $subDir.") if T(3);
157 : parrello 1.1 # Create the subsystem object.
158 :     $retVal = {
159 :     # Name of the subsystem. This is needed for any further database
160 :     # accesses required.
161 :     name => $subName,
162 : parrello 1.9 # Directory root for diagram and image files.
163 :     dir => $subDir,
164 : parrello 1.1 # Name of the subsystem's official curator.
165 :     curator => $curator,
166 :     # General notes about the subsystem.
167 :     notes => $notes,
168 :     # Sprout object for accessing the database.
169 :     sprout => $sprout,
170 :     # Map of genome IDs to row indices.
171 :     genomeHash => \%genomeHash,
172 :     # List of [genomeID, variantCode] tuples in row order.
173 :     genomes => \@genomes,
174 :     # Map of role IDs and abbreviations to column indices.
175 :     roleHash => \%roleHash,
176 :     # List of [roleID, abbreviation] tuples in column order.
177 :     roles => \@roles,
178 :     # Map of PEG IDs to cluster numbers.
179 :     colorHash => {},
180 : parrello 1.11 # Map of abbreviations to role names.
181 :     abbrHash => \%abbrHash,
182 : parrello 1.2 # Map of role IDs to reactions.
183 :     reactionHash => \%reactionHash,
184 : parrello 1.1 };
185 :     # Bless and return it.
186 :     bless $retVal, $class;
187 :     }
188 :     return $retVal;
189 :     }
190 :    
191 :     =head3 get_genomes
192 :    
193 :     C<< my @genomeList = $sub->get_genomes(); >>
194 :    
195 :     Return a list of the genome IDs for this subsystem. Each genome corresponds to a row
196 :     in the subsystem spreadsheet. Indexing into this list returns the ID of the genome
197 :     in the specified row.
198 :    
199 :     =cut
200 :    
201 :     sub get_genomes {
202 :     # Get the parameters.
203 :     my ($self) = @_;
204 :     # Return a list of the genome IDs. The "genomes" member contains a 2-tuple
205 :     # with the genome ID followed by the variant code. We only return the
206 :     # genome IDs.
207 :     my @retVal = map { $_->[0] } @{$self->{genomes}};
208 :     return @retVal;
209 :     }
210 :    
211 :     =head3 get_variant_code
212 :    
213 :     C<< my $code = $sub->get_variant_code($gidx); >>
214 :    
215 :     Return the variant code for the specified genome. Each subsystem has multiple
216 :     variants which involve slightly different chemical reactions, and each variant
217 :     has an associated variant code. When a genome is connected to the spreadsheet,
218 :     the subsystem variant used by the genome must be specified.
219 :    
220 :     =over 4
221 :    
222 :     =item gidx
223 :    
224 :     Row index for the genome whose variant code is desired.
225 :    
226 :     =item RETURN
227 :    
228 :     Returns the variant code for the specified genome.
229 :    
230 :     =back
231 :    
232 :     =cut
233 :    
234 :     sub get_variant_code {
235 :     # Get the parameters.
236 :     my ($self, $gidx) = @_;
237 :     # Extract the variant code for the specified row index. It is the second
238 :     # element of the tuple from the "genomes" member.
239 : parrello 1.5 my $retVal = $self->{genomes}->[$gidx]->[1];
240 : parrello 1.1 return $retVal;
241 :     }
242 :    
243 :     =head3 get_curator
244 :    
245 :     C<< my $userName = $sub->get_curator(); >>
246 :    
247 :     Return the name of this subsystem's official curator.
248 :    
249 :     =cut
250 :    
251 :     sub get_curator {
252 :     # Get the parameters.
253 :     my ($self) = @_;
254 :     # Return the curator member.
255 :     return $self->{curator};
256 :     }
257 :    
258 :     =head3 get_notes
259 :    
260 :     C<< my $text = $sub->get_notes(); >>
261 :    
262 :     Return the descriptive notes for this subsystem.
263 :    
264 :     =cut
265 :    
266 :     sub get_notes {
267 :     # Get the parameters.
268 :     my ($self) = @_;
269 :     # Return the notes member.
270 :     return $self->{notes};
271 :     }
272 :    
273 :     =head3 get_roles
274 :    
275 :     C<< my @roles = $sub->get_roles(); >>
276 :    
277 :     Return a list of the subsystem's roles. Each role corresponds to a column
278 :     in the subsystem spreadsheet. The list entry at a specified position in
279 :     the list will contain the ID of that column's role.
280 :    
281 :     =cut
282 :    
283 :     sub get_roles {
284 :     # Get the parameters.
285 :     my ($self) = @_;
286 :     # Return the list of role IDs. The role IDs are stored as the first
287 :     # element of each 2-tuple in the "roles" member.
288 :     my @retVal = map { $_->[0] } @{$self->{roles}};
289 :     return @retVal;
290 :     }
291 :    
292 :     =head3 get_reactions
293 :    
294 :     C<< my $reactHash = $sub->get_reactions(); >>
295 :    
296 :     Return a reference to a hash that maps each role ID to a list of the reactions
297 :     catalyzed by the role.
298 :    
299 :     =cut
300 :    
301 :     sub get_reactions {
302 :     # Get the parameters.
303 :     my ($self) = @_;
304 :     # Return the reaction hash member.
305 :     return $self->{reactionHash};
306 :     }
307 :    
308 :     =head3 get_subset_namesC
309 :    
310 :     C<< my @subsetNames = $sub->get_subset_namesC(); >>
311 :    
312 :     Return a list of the names for all the column (role) subsets. Given a subset
313 :     name, you can use the L</get_subsetC_roles> method to get the roles in the
314 :     subset.
315 :    
316 :     =cut
317 :    
318 :     sub get_subset_namesC {
319 :     # Get the parameters.
320 :     my ($self) = @_;
321 :     # Get the sprout object and use it to retrieve the subset names.
322 :     my $sprout = $self->{sprout};
323 :     my @subsets = $sprout->GetFlat(['HasRoleSubset'], 'HasRoleSubset(from-link) = ?',
324 :     [$self->{name}], 'HasRoleSubset(to-link)');
325 :     # The sprout subset names are prefixed by the subsystem name. We need to pull the
326 :     # prefix off before we return the results. The prefixing character is a colon (:),
327 :     # so we search for the last colon to get ourselves the true subset name.
328 :     my @retVal = map { $_ =~ /:([^:]+)$/; $1 } @subsets;
329 :     return @retVal;
330 :     }
331 :    
332 :     =head3 get_role_abbr
333 :    
334 :     C<< my $abbr = $sub->get_role_abbr($ridx); >>
335 :    
336 :     Return the abbreviation for the role in the specified column. The abbreviation
337 :     is a shortened identifier that is not necessarily unique, but is more likely to
338 :     fit in a column heading.
339 :    
340 :     =over 4
341 :    
342 :     =item ridx
343 :    
344 :     Column index for the role whose abbreviation is desired.
345 :    
346 :     =item RETURN
347 :    
348 :     Returns an abbreviated name for the role corresponding to the indexed column.
349 :    
350 :     =back
351 :    
352 :     =cut
353 :    
354 :     sub get_role_abbr {
355 :     # Get the parameters.
356 :     my ($self, $ridx) = @_;
357 :     # Return the role abbreviation. The abbreviation is the second element
358 :     # in the 2-tuple for the specified column in the "roles" member.
359 :     my $retVal = $self->{roles}->[$ridx]->[1];
360 :     return $retVal;
361 :     }
362 :    
363 :     =head3 get_role_index
364 :    
365 :     C<< my $idx = $sub->get_role_index($role); >>
366 :    
367 :     Return the column index for the role with the specified ID.
368 :    
369 :     =over 4
370 :    
371 :     =item role
372 :    
373 :     ID (full name) or abbreviation of the role whose column index is desired.
374 :    
375 :     =item RETURN
376 :    
377 :     Returns the column index for the role with the specified name or abbreviation.
378 :    
379 :     =back
380 :    
381 :     =cut
382 :    
383 :     sub get_role_index {
384 :     # Get the parameters.
385 :     my ($self, $role) = @_;
386 :     # The role index is directly available from the "roleHash" member.
387 :     my $retVal = $self->{roleHash}->{$role};
388 :     return $retVal;
389 :     }
390 :    
391 :     =head3 get_subsetC_roles
392 :    
393 :     C<< my @roles = $sub->get_subsetC_roles($subname); >>
394 :    
395 :     Return the names of the roles contained in the specified role (column) subset.
396 :    
397 :     =over 4
398 :    
399 :     =item subname
400 :    
401 :     Name of the role subset whose roles are desired.
402 :    
403 :     =item RETURN
404 :    
405 :     Returns a list of the role names for the columns in the named subset.
406 :    
407 :     =back
408 :    
409 :     =cut
410 :    
411 :     sub get_subsetC_roles {
412 :     # Get the parameters.
413 :     my ($self, $subname) = @_;
414 :     # Get the sprout object. We need it to be able to get the subset data.
415 :     my $sprout = $self->{sprout};
416 :     # Convert the subset name to Sprout format. In Sprout, the subset name is
417 :     # prefixed by the subsystem name in order to get a unique subset ID.
418 :     my $subsetID = $self->{name} . ":$subname";
419 :     # Get a list of the role names for this subset.
420 :     my @roleNames = $sprout->GetFlat(['ConsistsOfRoles'], 'ConsistsOfRoles(from-link) = ?',
421 :     [$subsetID], 'ConsistsOfRoles(to-link)');
422 :     # Sort them by column number. We get the column number from the role hash.
423 :     my $roleHash = $self->{roleHash};
424 :     my @retVal = sort { $roleHash->{$a} <=> $roleHash->{$b} } @roleNames;
425 :     # Return the sorted list.
426 :     return @retVal;
427 :     }
428 :    
429 :     =head3 get_genome_index
430 :    
431 :     C<< my $idx = $sub->get_genome_index($genome); >>
432 :    
433 :     Return the row index for the genome with the specified ID.
434 :    
435 :     =over 4
436 :    
437 :     =item genome
438 :    
439 :     ID of the genome whose row index is desired.
440 :    
441 :     =item RETURN
442 :    
443 :     Returns the row index for the genome with the specified ID, or an undefined
444 :     value if the genome does not participate in the subsystem.
445 :    
446 :     =back
447 :    
448 :     =cut
449 :    
450 :     sub get_genome_index {
451 :     # Get the parameters.
452 :     my ($self, $genome) = @_;
453 :     # Get the genome row index from the "genomeHash" member.
454 :     my $retVal = $self->{genomeHash}->{$genome};
455 :     return $retVal;
456 :     }
457 :    
458 :     =head3 get_cluster_number
459 :    
460 :     C<< my $number = $sub->get_cluster_number($pegID); >>
461 :    
462 :     Return the cluster number for the specified PEG, or C<-1> if the
463 :     cluster number for the PEG is unknown or it is not clustered.
464 :    
465 :     The cluster number is read into the color hash by the
466 :     L</get_pegs_from_cell> method. If the incoming PEG IDs do not
467 :     come from the most recent cell retrievals, the information returned
468 :     will be invalid. This is a serious design flaw which needs to be
469 :     fixed soon.
470 :    
471 :     =over 4
472 :    
473 :     =item pegID
474 :    
475 :     ID of the PEG whose cluster number is desired.
476 : parrello 1.4
477 :     =item RETURN
478 :    
479 :     Returns the appropriate cluster number.
480 : parrello 1.1
481 :     =back
482 :    
483 :     =cut
484 :     #: Return Type $;
485 :     sub get_cluster_number {
486 :     # Get the parameters.
487 :     my ($self, $pegID) = @_;
488 :     # Declare the return variable.
489 :     my $retVal = -1;
490 :     # Check for a cluster number in the color hash.
491 :     if (exists $self->{colorHash}->{$pegID}) {
492 :     $retVal = $self->{colorHash}->{$pegID};
493 :     }
494 :     # Return the result.
495 :     return $retVal;
496 :     }
497 :    
498 :     =head3 get_pegs_from_cell
499 :    
500 :     C<< my @pegs = $sub->get_pegs_from_cell($rowstr, $colstr); >>
501 :    
502 :     Return a list of the peg IDs for the features in the specified spreadsheet cell.
503 :    
504 :     =over 4
505 :    
506 :     =item rowstr
507 :    
508 :     Genome row, specified either as a row index or a genome ID.
509 :    
510 :     =item colstr
511 :    
512 :     Role column, specified either as a column index, a role name, or a role
513 :     abbreviation.
514 :    
515 :     =item RETURN
516 :    
517 :     Returns a list of PEG IDs. The PEGs in the list belong to the genome in the
518 :     specified row and perform the role in the specified column. If the indicated
519 :     row and column does not exist, returns an empty list.
520 :    
521 :     =back
522 :    
523 :     =cut
524 :    
525 :     sub get_pegs_from_cell {
526 :     # Get the parameters.
527 :     my ($self, $rowstr, $colstr) = @_;
528 :     # Get the sprout object for accessing the database.
529 :     my $sprout = $self->{sprout};
530 :     # We need to convert the incoming row and column identifiers. We need a
531 :     # numeric column index and a character genome ID to create the ID for the
532 :     # subsystem spreadsheet cell. First, the column index: note that our version
533 :     # of "get_role_index" conveniently works for both abbreviations and full role IDs.
534 :     my $colIdx = ($colstr =~ /^(\d+)$/ ? $colstr : $self->get_role_index($colstr));
535 :     # Next the genome ID. In this case, we convert any number we find to a string.
536 :     # This requires a little care to avoid a run-time error if the row number is
537 :     # out of range.
538 :     my $genomeID = $rowstr;
539 :     if ($rowstr =~ /^(\d+)$/) {
540 :     # Here we need to convert the row number to an ID. Insure the number is in
541 :     # range. Note that if we do have a row number out of range, the genome ID
542 :     # will be invalid, and our attempt to read from the database will return an
543 :     # empty list.
544 :     my $genomeList = $self->{genomes};
545 :     if ($rowstr >= 0 && $rowstr < @{$genomeList}) {
546 :     $genomeID = $genomeList->[$rowstr]->[0];
547 :     }
548 :     }
549 :     # Construct the spreadsheet cell ID from the information we have.
550 : parrello 1.7 my $cellID = $sprout->DigestKey($self->{name} . ":$genomeID:$colIdx");
551 : parrello 1.1 # Get the list of PEG IDs and cluster numbers for the indicated cell.
552 :     my @pegList = $sprout->GetAll(['ContainsFeature'], 'ContainsFeature(from-link) = ?',
553 :     [$cellID], ['ContainsFeature(to-link)',
554 :     'ContainsFeature(cluster-number)']);
555 :     # Copy the pegs into the return list, and save the cluster numbers in the color hash.
556 :     my @retVal = ();
557 :     for my $pegEntry (@pegList) {
558 :     my ($peg, $cluster) = @{$pegEntry};
559 :     $self->{colorHash}->{$peg} = $cluster;
560 :     push @retVal, $peg;
561 :     }
562 :     # Return the list. If the spreadsheet cell was empty or non-existent, we'll end
563 :     # up returning an empty list.
564 :     return @retVal;
565 :     }
566 :    
567 : parrello 1.10 =head3 get_subsetR
568 : parrello 1.8
569 : parrello 1.10 C<< my @genomes = $sub->get_subsetR($subName); >>
570 :    
571 :     Return the genomes in the row subset indicated by the specified subset name.
572 :    
573 :     =over 4
574 :    
575 :     =item subName
576 :    
577 :     Name of the desired row subset, or C<All> to get all of the rows.
578 :    
579 :     =item RETURN
580 :    
581 :     Returns a list of genome IDs corresponding to the named subset.
582 :    
583 :     =back
584 :    
585 :     =cut
586 :    
587 :     sub get_subsetR {
588 :     # Get the parameters.
589 :     my ($self, $subName) = @_;
590 :     # Look for the specified row subset in the database. A row subset is identified using
591 :     # the subsystem name and the subset name. The special subset "All" is actually
592 :     # represented in the database, so we don't need to check for it.
593 :     my @rows = $self->{sprout}->GetFlat(['ConsistsOfGenomes'], "ConsistsOfGenomes(from-link) = ?",
594 :     ["$self->{name}:$subName"], 'ConsistsOfGenomes(to-link)');
595 :     return @rows;
596 :     }
597 : parrello 1.8
598 : parrello 1.4 =head3 get_diagrams
599 :    
600 :     C<< my @list = $sub->get_diagrams(); >>
601 :    
602 :     Return a list of the diagrams associated with this subsystem. Each diagram
603 :     is represented in the return list as a 4-tuple C<[diagram_id, diagram_name,
604 :     page_link, img_link]> where
605 :    
606 :     =over 4
607 :    
608 :     =item diagram_id
609 :    
610 :     ID code for this diagram.
611 :    
612 :     =item diagram_name
613 :    
614 :     Displayable name of the diagram.
615 :    
616 :     =item page_link
617 :    
618 :     URL of an HTML page containing information about the diagram.
619 :    
620 :     =item img_link
621 :    
622 :     URL of an HTML page containing an image for the diagram.
623 :    
624 :     =back
625 :    
626 :     Note that the URLs are in fact for CGI scripts with parameters that point them
627 :     to the correct place. Though Sprout has diagram information in it, it has
628 :     no relationship to the diagrams displayed in SEED, so the work is done entirely
629 :     on the SEED side.
630 :    
631 :     =cut
632 :    
633 :     sub get_diagrams {
634 :     # Get the parameters.
635 :     my ($self) = @_;
636 :     # Get the diagram IDs.
637 : parrello 1.9 my @diagramIDs = Subsystem::GetDiagramIDs($self->{dir});
638 : parrello 1.6 Trace("Diagram IDs are " . join(", ", @diagramIDs)) if T(3);
639 : parrello 1.4 # Create the return variable.
640 :     my @retVal = ();
641 :     # Loop through the diagram IDs.
642 :     for my $diagramID (@diagramIDs) {
643 : parrello 1.6 Trace("Processing diagram $diagramID.") if T(3);
644 : parrello 1.9 my ($name, $link, $imgLink) = $self->get_diagram($diagramID);
645 :     Trace("Diagram $name URLs are \"$link\" and \"$imgLink\".") if T(3);
646 : parrello 1.6 push @retVal, [$diagramID, $name, $link, $imgLink];
647 : parrello 1.4 }
648 : parrello 1.6 # Return the result.
649 :     return @retVal;
650 : parrello 1.4 }
651 :    
652 : parrello 1.9 =head3 get_diagram
653 :    
654 :     C<< my ($name, $pageURL, $imgURL) = $sub->get_diagram($id); >>
655 :    
656 :     Get the information (if any) for the specified diagram. The diagram corresponds
657 :     to a subdirectory of the subsystem's C<diagrams> directory. For example, if the
658 :     diagram ID is C<d03>, the diagram's subdirectory would be C<$dir/diagrams/d03>,
659 :     where I<$dir> is the subsystem directory. The diagram's name is extracted from
660 :     a tiny file containing the name, and then the links are computed using the
661 :     subsystem name and the diagram ID. The parameters are as follows.
662 :    
663 :     =over 4
664 :    
665 :     =item id
666 :    
667 :     ID code for the desired diagram.
668 :    
669 :     =item RETURN
670 :    
671 :     Returns a three-element list. The first element is the diagram name, the second
672 :     a URL for displaying information about the diagram, and the third a URL for
673 :     displaying the diagram image.
674 :    
675 :     =back
676 :    
677 :     =cut
678 :    
679 :     sub get_diagram {
680 :     my($self, $id) = @_;
681 :     my $name = Subsystem::GetDiagramName($self->{dir}, $id);
682 : parrello 1.11 my ($link, $img_link) = Subsystem::ComputeDiagramURLs($self, $self->{name}, $id, 1);
683 : parrello 1.9 return($name, $link, $img_link);
684 :     }
685 :    
686 :    
687 :     =head3 get_diagram_html_file
688 :    
689 :     C<< my $fileName = $sub->get_diagram_html_file($id); >>
690 :    
691 :     Get the HTML file (if any) for the specified diagram. The diagram corresponds
692 :     to a subdirectory of the subsystem's C<diagrams> directory. For example, if the
693 :     diagram ID is C<d03>, the diagram's subdirectory would be C<$dir/diagrams/d03>,
694 :     where I<$dir> is the subsystem directory. If an HTML file exists, it will be
695 :     named C<diagram.html> in the diagram directory. The parameters are as follows.
696 :    
697 :     =over 4
698 :    
699 :     =item id
700 :    
701 :     ID code for the desired diagram.
702 :    
703 :     =item RETURN
704 :    
705 :     Returns the name of an HTML diagram file, or C<undef> if no such file exists.
706 :    
707 :     =back
708 :    
709 :     =cut
710 :    
711 :     sub get_diagram_html_file {
712 :     my ($self, $id) = @_;
713 :     my $retVal;
714 :     my $ddir = "$self->{dir}/diagrams/$id";
715 :     if (-d $ddir) {
716 :     my $html = "$ddir/diagram.html";
717 :     if (-f $html) {
718 :     $retVal = $html;
719 :     }
720 :     }
721 :     return $retVal;
722 :     }
723 :    
724 : parrello 1.11 =head3 is_new_diagram
725 :    
726 :     C<< my $flag = $sub->is_new_diagram($id); >>
727 :    
728 :     Return TRUE if the specified diagram is in the new format, else FALSE.
729 :    
730 :     =over 4
731 :    
732 :     =item id
733 :    
734 :     ID code (e.g. C<d03>) of the relevant diagram.
735 :    
736 :     =item RETURN
737 :    
738 :     Returns TRUE if the diagram is in the new format, else FALSE.
739 :    
740 :     =back
741 :    
742 :     =cut
743 :    
744 :     sub is_new_diagram {
745 :     my ($self, $id) = @_;
746 :    
747 :     my $image_map = $self->get_diagram_html_file($id);
748 :     if ($image_map) {
749 :     Trace("Image map found for diagram $id at $image_map.") if T(3);
750 :     open(IN, "$image_map") or Confess("Unable to open file $image_map.");
751 :     my $header = <IN>;
752 :     close(IN);
753 :    
754 :     if ($header =~ /\<map name=\"GraffleExport\"\>/) {
755 :     return 1;
756 :     }
757 :     }
758 :    
759 :     return undef;
760 :     }
761 :    
762 :     =head3 get_role_from_abbr
763 :    
764 :     C<< my $roleName = $sub->get_role_from_abbr($abbr); >>
765 :    
766 :     Return the role name corresponding to an abbreviation.
767 :    
768 :     =over 4
769 :    
770 :     =item abbr
771 :    
772 :     Abbreviation name of the relevant role.
773 :    
774 :     =item RETURN
775 :    
776 :     Returns the full name of the specified role.
777 :    
778 :     =back
779 :    
780 :     =cut
781 :    
782 :     sub get_role_from_abbr {
783 :     # Get the parameters.
784 :     my($self, $abbr) = @_;
785 :     # Get the role name from the abbreviation hash.
786 :     my $retVal = $self->{abbrHash}->{$abbr};
787 :     # Check for a case incompatability.
788 :     if (! defined $retVal) {
789 :     $retVal = $self->{abbrHash}->{lcfirst $abbr};
790 :     }
791 :     # Return the result.
792 :     return $retVal;
793 :     }
794 :    
795 :    
796 : parrello 1.9 =head3 get_name
797 :    
798 :     C<< my $name = $sub->get_name(); >>
799 :    
800 :     Return the name of this subsystem.
801 :    
802 :     =cut
803 :    
804 :     sub get_name {
805 :     # Get the parameters.
806 :     my ($self) = @_;
807 :     # Return the result.
808 :     return $self->{name};
809 :     }
810 :    
811 :     =head3 open_diagram_image
812 :    
813 :     C<< my ($type, $fh) = $sub->open_diagram_image($id); >>
814 :    
815 :     Open a diagram's image file and return the type and file handle.
816 :    
817 :     =over 4
818 :    
819 :     =item id
820 :    
821 :     ID of the desired diagram
822 :    
823 :     =item RETURN
824 :    
825 :     Returns a 2-tuple containing the diagram's MIME type and an open filehandle
826 :     for the diagram's data. If the diagram does not exist, the type will be
827 :     returned as <undef>.
828 :    
829 :     =back
830 :    
831 :     =cut
832 :    
833 :     sub open_diagram_image {
834 :     # Get the parameters.
835 :     my ($self, $id) = @_;
836 :     # Declare the return variables.
837 :     my ($type, $fh);
838 :     # Get the diagram directory.
839 :     my $img_base = "$self->{dir}/diagrams/$id/diagram";
840 :     # Get a list of file extensions and types.
841 :     my %types = (png => "image/png",
842 :     gif => "image/gif",
843 :     jpg => "image/jpeg");
844 :     # This is my new syntax for the for-each-while loop.
845 :     # We loop until we run out of keys or come up with a type value.
846 :     for my $ext (keys %types) { last if (defined $type);
847 :     my $myType = $types{$ext};
848 :     # Compute a file name for this diagram.
849 :     my $file = "$img_base.$ext";
850 :     # If it exists, try to open it.
851 :     if (-f $file) {
852 :     $fh = Open(undef, "<$file");
853 :     $type = $myType;
854 :     }
855 :     }
856 :     # Return the result.
857 :     return ($type, $fh);
858 :     }
859 :    
860 : parrello 1.1
861 : parrello 1.4 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3