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

Annotation of /Sprout/SproutSubsys.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (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 :     my @roles = $sprout->GetAll(['OccursInSubsystem', 'Role'],
129 :     'OccursInSubsystem(to-link) = ? ORDER BY OccursInSubsystem(column-number)',
130 :     [$subName], ['OccursInSubsystem(from-link)', 'Role(abbr)']);
131 :     # 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 :     my %reactionHash = ();
137 :     for ($idx = 0; $idx <= $#roles; $idx++) {
138 :     # Get the role ID and abbreviation for this column's role.
139 :     my ($roleID, $abbr) = @{$roles[$idx]};
140 :     # Put them both in the role directory.
141 :     $roleHash{$roleID} = $idx;
142 :     $roleHash{$abbr} = $idx;
143 :     # Get this role's reactions.
144 :     my @reactions = $sprout->GetFlat(['Catalyzes'], 'Catalyzes(from-link) = ?',
145 :     [$roleID], 'Catalyzes(to-link)');
146 :     # Put them in the reaction hash.
147 : parrello 1.3 if (@reactions > 0) {
148 :     $reactionHash{$roleID} = \@reactions;
149 :     }
150 : parrello 1.1 }
151 : parrello 1.9 # Find the subsystem directory.
152 :     my $subDir = Subsystem::get_dir_from_name($subName);
153 :     Trace("Subsystem directory is $subDir.") if T(3);
154 : parrello 1.1 # Create the subsystem object.
155 :     $retVal = {
156 :     # Name of the subsystem. This is needed for any further database
157 :     # accesses required.
158 :     name => $subName,
159 : parrello 1.9 # Directory root for diagram and image files.
160 :     dir => $subDir,
161 : parrello 1.1 # Name of the subsystem's official curator.
162 :     curator => $curator,
163 :     # General notes about the subsystem.
164 :     notes => $notes,
165 :     # Sprout object for accessing the database.
166 :     sprout => $sprout,
167 :     # Map of genome IDs to row indices.
168 :     genomeHash => \%genomeHash,
169 :     # List of [genomeID, variantCode] tuples in row order.
170 :     genomes => \@genomes,
171 :     # Map of role IDs and abbreviations to column indices.
172 :     roleHash => \%roleHash,
173 :     # List of [roleID, abbreviation] tuples in column order.
174 :     roles => \@roles,
175 :     # Map of PEG IDs to cluster numbers.
176 :     colorHash => {},
177 : parrello 1.2 # Map of role IDs to reactions.
178 :     reactionHash => \%reactionHash,
179 : parrello 1.1 };
180 :     # Bless and return it.
181 :     bless $retVal, $class;
182 :     }
183 :     return $retVal;
184 :     }
185 :    
186 :     =head3 get_genomes
187 :    
188 :     C<< my @genomeList = $sub->get_genomes(); >>
189 :    
190 :     Return a list of the genome IDs for this subsystem. Each genome corresponds to a row
191 :     in the subsystem spreadsheet. Indexing into this list returns the ID of the genome
192 :     in the specified row.
193 :    
194 :     =cut
195 :    
196 :     sub get_genomes {
197 :     # Get the parameters.
198 :     my ($self) = @_;
199 :     # Return a list of the genome IDs. The "genomes" member contains a 2-tuple
200 :     # with the genome ID followed by the variant code. We only return the
201 :     # genome IDs.
202 :     my @retVal = map { $_->[0] } @{$self->{genomes}};
203 :     return @retVal;
204 :     }
205 :    
206 :     =head3 get_variant_code
207 :    
208 :     C<< my $code = $sub->get_variant_code($gidx); >>
209 :    
210 :     Return the variant code for the specified genome. Each subsystem has multiple
211 :     variants which involve slightly different chemical reactions, and each variant
212 :     has an associated variant code. When a genome is connected to the spreadsheet,
213 :     the subsystem variant used by the genome must be specified.
214 :    
215 :     =over 4
216 :    
217 :     =item gidx
218 :    
219 :     Row index for the genome whose variant code is desired.
220 :    
221 :     =item RETURN
222 :    
223 :     Returns the variant code for the specified genome.
224 :    
225 :     =back
226 :    
227 :     =cut
228 :    
229 :     sub get_variant_code {
230 :     # Get the parameters.
231 :     my ($self, $gidx) = @_;
232 :     # Extract the variant code for the specified row index. It is the second
233 :     # element of the tuple from the "genomes" member.
234 : parrello 1.5 my $retVal = $self->{genomes}->[$gidx]->[1];
235 : parrello 1.1 return $retVal;
236 :     }
237 :    
238 :     =head3 get_curator
239 :    
240 :     C<< my $userName = $sub->get_curator(); >>
241 :    
242 :     Return the name of this subsystem's official curator.
243 :    
244 :     =cut
245 :    
246 :     sub get_curator {
247 :     # Get the parameters.
248 :     my ($self) = @_;
249 :     # Return the curator member.
250 :     return $self->{curator};
251 :     }
252 :    
253 :     =head3 get_notes
254 :    
255 :     C<< my $text = $sub->get_notes(); >>
256 :    
257 :     Return the descriptive notes for this subsystem.
258 :    
259 :     =cut
260 :    
261 :     sub get_notes {
262 :     # Get the parameters.
263 :     my ($self) = @_;
264 :     # Return the notes member.
265 :     return $self->{notes};
266 :     }
267 :    
268 :     =head3 get_roles
269 :    
270 :     C<< my @roles = $sub->get_roles(); >>
271 :    
272 :     Return a list of the subsystem's roles. Each role corresponds to a column
273 :     in the subsystem spreadsheet. The list entry at a specified position in
274 :     the list will contain the ID of that column's role.
275 :    
276 :     =cut
277 :    
278 :     sub get_roles {
279 :     # Get the parameters.
280 :     my ($self) = @_;
281 :     # Return the list of role IDs. The role IDs are stored as the first
282 :     # element of each 2-tuple in the "roles" member.
283 :     my @retVal = map { $_->[0] } @{$self->{roles}};
284 :     return @retVal;
285 :     }
286 :    
287 :     =head3 get_reactions
288 :    
289 :     C<< my $reactHash = $sub->get_reactions(); >>
290 :    
291 :     Return a reference to a hash that maps each role ID to a list of the reactions
292 :     catalyzed by the role.
293 :    
294 :     =cut
295 :    
296 :     sub get_reactions {
297 :     # Get the parameters.
298 :     my ($self) = @_;
299 :     # Return the reaction hash member.
300 :     return $self->{reactionHash};
301 :     }
302 :    
303 :     =head3 get_subset_namesC
304 :    
305 :     C<< my @subsetNames = $sub->get_subset_namesC(); >>
306 :    
307 :     Return a list of the names for all the column (role) subsets. Given a subset
308 :     name, you can use the L</get_subsetC_roles> method to get the roles in the
309 :     subset.
310 :    
311 :     =cut
312 :    
313 :     sub get_subset_namesC {
314 :     # Get the parameters.
315 :     my ($self) = @_;
316 :     # Get the sprout object and use it to retrieve the subset names.
317 :     my $sprout = $self->{sprout};
318 :     my @subsets = $sprout->GetFlat(['HasRoleSubset'], 'HasRoleSubset(from-link) = ?',
319 :     [$self->{name}], 'HasRoleSubset(to-link)');
320 :     # The sprout subset names are prefixed by the subsystem name. We need to pull the
321 :     # prefix off before we return the results. The prefixing character is a colon (:),
322 :     # so we search for the last colon to get ourselves the true subset name.
323 :     my @retVal = map { $_ =~ /:([^:]+)$/; $1 } @subsets;
324 :     return @retVal;
325 :     }
326 :    
327 :     =head3 get_role_abbr
328 :    
329 :     C<< my $abbr = $sub->get_role_abbr($ridx); >>
330 :    
331 :     Return the abbreviation for the role in the specified column. The abbreviation
332 :     is a shortened identifier that is not necessarily unique, but is more likely to
333 :     fit in a column heading.
334 :    
335 :     =over 4
336 :    
337 :     =item ridx
338 :    
339 :     Column index for the role whose abbreviation is desired.
340 :    
341 :     =item RETURN
342 :    
343 :     Returns an abbreviated name for the role corresponding to the indexed column.
344 :    
345 :     =back
346 :    
347 :     =cut
348 :    
349 :     sub get_role_abbr {
350 :     # Get the parameters.
351 :     my ($self, $ridx) = @_;
352 :     # Return the role abbreviation. The abbreviation is the second element
353 :     # in the 2-tuple for the specified column in the "roles" member.
354 :     my $retVal = $self->{roles}->[$ridx]->[1];
355 :     return $retVal;
356 :     }
357 :    
358 :     =head3 get_role_index
359 :    
360 :     C<< my $idx = $sub->get_role_index($role); >>
361 :    
362 :     Return the column index for the role with the specified ID.
363 :    
364 :     =over 4
365 :    
366 :     =item role
367 :    
368 :     ID (full name) or abbreviation of the role whose column index is desired.
369 :    
370 :     =item RETURN
371 :    
372 :     Returns the column index for the role with the specified name or abbreviation.
373 :    
374 :     =back
375 :    
376 :     =cut
377 :    
378 :     sub get_role_index {
379 :     # Get the parameters.
380 :     my ($self, $role) = @_;
381 :     # The role index is directly available from the "roleHash" member.
382 :     my $retVal = $self->{roleHash}->{$role};
383 :     return $retVal;
384 :     }
385 :    
386 :     =head3 get_subsetC_roles
387 :    
388 :     C<< my @roles = $sub->get_subsetC_roles($subname); >>
389 :    
390 :     Return the names of the roles contained in the specified role (column) subset.
391 :    
392 :     =over 4
393 :    
394 :     =item subname
395 :    
396 :     Name of the role subset whose roles are desired.
397 :    
398 :     =item RETURN
399 :    
400 :     Returns a list of the role names for the columns in the named subset.
401 :    
402 :     =back
403 :    
404 :     =cut
405 :    
406 :     sub get_subsetC_roles {
407 :     # Get the parameters.
408 :     my ($self, $subname) = @_;
409 :     # Get the sprout object. We need it to be able to get the subset data.
410 :     my $sprout = $self->{sprout};
411 :     # Convert the subset name to Sprout format. In Sprout, the subset name is
412 :     # prefixed by the subsystem name in order to get a unique subset ID.
413 :     my $subsetID = $self->{name} . ":$subname";
414 :     # Get a list of the role names for this subset.
415 :     my @roleNames = $sprout->GetFlat(['ConsistsOfRoles'], 'ConsistsOfRoles(from-link) = ?',
416 :     [$subsetID], 'ConsistsOfRoles(to-link)');
417 :     # Sort them by column number. We get the column number from the role hash.
418 :     my $roleHash = $self->{roleHash};
419 :     my @retVal = sort { $roleHash->{$a} <=> $roleHash->{$b} } @roleNames;
420 :     # Return the sorted list.
421 :     return @retVal;
422 :     }
423 :    
424 :     =head3 get_genome_index
425 :    
426 :     C<< my $idx = $sub->get_genome_index($genome); >>
427 :    
428 :     Return the row index for the genome with the specified ID.
429 :    
430 :     =over 4
431 :    
432 :     =item genome
433 :    
434 :     ID of the genome whose row index is desired.
435 :    
436 :     =item RETURN
437 :    
438 :     Returns the row index for the genome with the specified ID, or an undefined
439 :     value if the genome does not participate in the subsystem.
440 :    
441 :     =back
442 :    
443 :     =cut
444 :    
445 :     sub get_genome_index {
446 :     # Get the parameters.
447 :     my ($self, $genome) = @_;
448 :     # Get the genome row index from the "genomeHash" member.
449 :     my $retVal = $self->{genomeHash}->{$genome};
450 :     return $retVal;
451 :     }
452 :    
453 :     =head3 get_cluster_number
454 :    
455 :     C<< my $number = $sub->get_cluster_number($pegID); >>
456 :    
457 :     Return the cluster number for the specified PEG, or C<-1> if the
458 :     cluster number for the PEG is unknown or it is not clustered.
459 :    
460 :     The cluster number is read into the color hash by the
461 :     L</get_pegs_from_cell> method. If the incoming PEG IDs do not
462 :     come from the most recent cell retrievals, the information returned
463 :     will be invalid. This is a serious design flaw which needs to be
464 :     fixed soon.
465 :    
466 :     =over 4
467 :    
468 :     =item pegID
469 :    
470 :     ID of the PEG whose cluster number is desired.
471 : parrello 1.4
472 :     =item RETURN
473 :    
474 :     Returns the appropriate cluster number.
475 : parrello 1.1
476 :     =back
477 :    
478 :     =cut
479 :     #: Return Type $;
480 :     sub get_cluster_number {
481 :     # Get the parameters.
482 :     my ($self, $pegID) = @_;
483 :     # Declare the return variable.
484 :     my $retVal = -1;
485 :     # Check for a cluster number in the color hash.
486 :     if (exists $self->{colorHash}->{$pegID}) {
487 :     $retVal = $self->{colorHash}->{$pegID};
488 :     }
489 :     # Return the result.
490 :     return $retVal;
491 :     }
492 :    
493 :     =head3 get_pegs_from_cell
494 :    
495 :     C<< my @pegs = $sub->get_pegs_from_cell($rowstr, $colstr); >>
496 :    
497 :     Return a list of the peg IDs for the features in the specified spreadsheet cell.
498 :    
499 :     =over 4
500 :    
501 :     =item rowstr
502 :    
503 :     Genome row, specified either as a row index or a genome ID.
504 :    
505 :     =item colstr
506 :    
507 :     Role column, specified either as a column index, a role name, or a role
508 :     abbreviation.
509 :    
510 :     =item RETURN
511 :    
512 :     Returns a list of PEG IDs. The PEGs in the list belong to the genome in the
513 :     specified row and perform the role in the specified column. If the indicated
514 :     row and column does not exist, returns an empty list.
515 :    
516 :     =back
517 :    
518 :     =cut
519 :    
520 :     sub get_pegs_from_cell {
521 :     # Get the parameters.
522 :     my ($self, $rowstr, $colstr) = @_;
523 :     # Get the sprout object for accessing the database.
524 :     my $sprout = $self->{sprout};
525 :     # We need to convert the incoming row and column identifiers. We need a
526 :     # numeric column index and a character genome ID to create the ID for the
527 :     # subsystem spreadsheet cell. First, the column index: note that our version
528 :     # of "get_role_index" conveniently works for both abbreviations and full role IDs.
529 :     my $colIdx = ($colstr =~ /^(\d+)$/ ? $colstr : $self->get_role_index($colstr));
530 :     # Next the genome ID. In this case, we convert any number we find to a string.
531 :     # This requires a little care to avoid a run-time error if the row number is
532 :     # out of range.
533 :     my $genomeID = $rowstr;
534 :     if ($rowstr =~ /^(\d+)$/) {
535 :     # Here we need to convert the row number to an ID. Insure the number is in
536 :     # range. Note that if we do have a row number out of range, the genome ID
537 :     # will be invalid, and our attempt to read from the database will return an
538 :     # empty list.
539 :     my $genomeList = $self->{genomes};
540 :     if ($rowstr >= 0 && $rowstr < @{$genomeList}) {
541 :     $genomeID = $genomeList->[$rowstr]->[0];
542 :     }
543 :     }
544 :     # Construct the spreadsheet cell ID from the information we have.
545 : parrello 1.7 my $cellID = $sprout->DigestKey($self->{name} . ":$genomeID:$colIdx");
546 : parrello 1.1 # Get the list of PEG IDs and cluster numbers for the indicated cell.
547 :     my @pegList = $sprout->GetAll(['ContainsFeature'], 'ContainsFeature(from-link) = ?',
548 :     [$cellID], ['ContainsFeature(to-link)',
549 :     'ContainsFeature(cluster-number)']);
550 :     # Copy the pegs into the return list, and save the cluster numbers in the color hash.
551 :     my @retVal = ();
552 :     for my $pegEntry (@pegList) {
553 :     my ($peg, $cluster) = @{$pegEntry};
554 :     $self->{colorHash}->{$peg} = $cluster;
555 :     push @retVal, $peg;
556 :     }
557 :     # Return the list. If the spreadsheet cell was empty or non-existent, we'll end
558 :     # up returning an empty list.
559 :     return @retVal;
560 :     }
561 :    
562 : parrello 1.8
563 :    
564 : parrello 1.4 =head3 get_diagrams
565 :    
566 :     C<< my @list = $sub->get_diagrams(); >>
567 :    
568 :     Return a list of the diagrams associated with this subsystem. Each diagram
569 :     is represented in the return list as a 4-tuple C<[diagram_id, diagram_name,
570 :     page_link, img_link]> where
571 :    
572 :     =over 4
573 :    
574 :     =item diagram_id
575 :    
576 :     ID code for this diagram.
577 :    
578 :     =item diagram_name
579 :    
580 :     Displayable name of the diagram.
581 :    
582 :     =item page_link
583 :    
584 :     URL of an HTML page containing information about the diagram.
585 :    
586 :     =item img_link
587 :    
588 :     URL of an HTML page containing an image for the diagram.
589 :    
590 :     =back
591 :    
592 :     Note that the URLs are in fact for CGI scripts with parameters that point them
593 :     to the correct place. Though Sprout has diagram information in it, it has
594 :     no relationship to the diagrams displayed in SEED, so the work is done entirely
595 :     on the SEED side.
596 :    
597 :     =cut
598 :    
599 :     sub get_diagrams {
600 :     # Get the parameters.
601 :     my ($self) = @_;
602 :     # Get the diagram IDs.
603 : parrello 1.9 my @diagramIDs = Subsystem::GetDiagramIDs($self->{dir});
604 : parrello 1.6 Trace("Diagram IDs are " . join(", ", @diagramIDs)) if T(3);
605 : parrello 1.4 # Create the return variable.
606 :     my @retVal = ();
607 :     # Loop through the diagram IDs.
608 :     for my $diagramID (@diagramIDs) {
609 : parrello 1.6 Trace("Processing diagram $diagramID.") if T(3);
610 : parrello 1.9 my ($name, $link, $imgLink) = $self->get_diagram($diagramID);
611 :     Trace("Diagram $name URLs are \"$link\" and \"$imgLink\".") if T(3);
612 : parrello 1.6 push @retVal, [$diagramID, $name, $link, $imgLink];
613 : parrello 1.4 }
614 : parrello 1.6 # Return the result.
615 :     return @retVal;
616 : parrello 1.4 }
617 :    
618 : parrello 1.9 =head3 get_diagram
619 :    
620 :     C<< my ($name, $pageURL, $imgURL) = $sub->get_diagram($id); >>
621 :    
622 :     Get the information (if any) for the specified diagram. The diagram corresponds
623 :     to a subdirectory of the subsystem's C<diagrams> directory. For example, if the
624 :     diagram ID is C<d03>, the diagram's subdirectory would be C<$dir/diagrams/d03>,
625 :     where I<$dir> is the subsystem directory. The diagram's name is extracted from
626 :     a tiny file containing the name, and then the links are computed using the
627 :     subsystem name and the diagram ID. The parameters are as follows.
628 :    
629 :     =over 4
630 :    
631 :     =item id
632 :    
633 :     ID code for the desired diagram.
634 :    
635 :     =item RETURN
636 :    
637 :     Returns a three-element list. The first element is the diagram name, the second
638 :     a URL for displaying information about the diagram, and the third a URL for
639 :     displaying the diagram image.
640 :    
641 :     =back
642 :    
643 :     =cut
644 :    
645 :     sub get_diagram {
646 :     my($self, $id) = @_;
647 :     my $name = Subsystem::GetDiagramName($self->{dir}, $id);
648 :     my ($link, $img_link) = Subsystem::ComputeDiagramURLs($self->{name}, $id, 1);
649 :     return($name, $link, $img_link);
650 :     }
651 :    
652 :    
653 :     =head3 get_diagram_html_file
654 :    
655 :     C<< my $fileName = $sub->get_diagram_html_file($id); >>
656 :    
657 :     Get the HTML file (if any) for the specified diagram. The diagram corresponds
658 :     to a subdirectory of the subsystem's C<diagrams> directory. For example, if the
659 :     diagram ID is C<d03>, the diagram's subdirectory would be C<$dir/diagrams/d03>,
660 :     where I<$dir> is the subsystem directory. If an HTML file exists, it will be
661 :     named C<diagram.html> in the diagram directory. 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 the name of an HTML diagram file, or C<undef> if no such file exists.
672 :    
673 :     =back
674 :    
675 :     =cut
676 :    
677 :     sub get_diagram_html_file {
678 :     my ($self, $id) = @_;
679 :     my $retVal;
680 :     my $ddir = "$self->{dir}/diagrams/$id";
681 :     if (-d $ddir) {
682 :     my $html = "$ddir/diagram.html";
683 :     if (-f $html) {
684 :     $retVal = $html;
685 :     }
686 :     }
687 :     return $retVal;
688 :     }
689 :    
690 :     =head3 get_name
691 :    
692 :     C<< my $name = $sub->get_name(); >>
693 :    
694 :     Return the name of this subsystem.
695 :    
696 :     =cut
697 :    
698 :     sub get_name {
699 :     # Get the parameters.
700 :     my ($self) = @_;
701 :     # Return the result.
702 :     return $self->{name};
703 :     }
704 :    
705 :     =head3 open_diagram_image
706 :    
707 :     C<< my ($type, $fh) = $sub->open_diagram_image($id); >>
708 :    
709 :     Open a diagram's image file and return the type and file handle.
710 :    
711 :     =over 4
712 :    
713 :     =item id
714 :    
715 :     ID of the desired diagram
716 :    
717 :     =item RETURN
718 :    
719 :     Returns a 2-tuple containing the diagram's MIME type and an open filehandle
720 :     for the diagram's data. If the diagram does not exist, the type will be
721 :     returned as <undef>.
722 :    
723 :     =back
724 :    
725 :     =cut
726 :    
727 :     sub open_diagram_image {
728 :     # Get the parameters.
729 :     my ($self, $id) = @_;
730 :     # Declare the return variables.
731 :     my ($type, $fh);
732 :     # Get the diagram directory.
733 :     my $img_base = "$self->{dir}/diagrams/$id/diagram";
734 :     # Get a list of file extensions and types.
735 :     my %types = (png => "image/png",
736 :     gif => "image/gif",
737 :     jpg => "image/jpeg");
738 :     # This is my new syntax for the for-each-while loop.
739 :     # We loop until we run out of keys or come up with a type value.
740 :     for my $ext (keys %types) { last if (defined $type);
741 :     my $myType = $types{$ext};
742 :     # Compute a file name for this diagram.
743 :     my $file = "$img_base.$ext";
744 :     # If it exists, try to open it.
745 :     if (-f $file) {
746 :     $fh = Open(undef, "<$file");
747 :     $type = $myType;
748 :     }
749 :     }
750 :     # Return the result.
751 :     return ($type, $fh);
752 :     }
753 :    
754 : parrello 1.1
755 : parrello 1.4 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3