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

Annotation of /Sprout/SearchHelper.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package SearchHelper;
4 :    
5 :     use strict;
6 :     use Tracer;
7 :     use PageBuilder;
8 :     use Digest::MD5;
9 :     use File::Basename;
10 :     use File::Path;
11 :     use File::stat;
12 :     use LWP::UserAgent;
13 :     use Time::HiRes 'gettimeofday';
14 :     use Sprout;
15 :     use SFXlate;
16 :     use FIGRules;
17 :     use HTML;
18 :     use BasicLocation;
19 :    
20 :     =head1 Search Helper Base Class
21 :    
22 :     =head2 Introduction
23 :    
24 :     The search helper is a base class for all search objects. It has methods for performing
25 :     all the common tasks required to build and manage a search cache. The subclass must
26 :     provide methods for generating and processing search forms. The base class has the
27 :     following object fields.
28 :    
29 :     =over 4
30 :    
31 :     =item cols
32 :    
33 :     Reference to a list of column header descriptions. If undefined, then the session cache
34 :     file has been opened but nothing has been written to it.
35 :    
36 :     =item fileHandle
37 :    
38 :     File handle for the session cache file.
39 :    
40 :     =item query
41 :    
42 :     CGI query object, which includes the search parameters and the various
43 :     session status variables kept between requests from the user.
44 :    
45 :     =item type
46 :    
47 :     Session type: C<old> if there is an existing cache file from which we are
48 :     displaying search results, or C<new> if the cache file needs to be built.
49 :    
50 :     =item class
51 :    
52 :     Name of the search helper class as it would appear in the CGI query object
53 :     (i.e. without the C<SH> prefix.
54 :    
55 :     =item sprout
56 :    
57 :     Sprout object for accessing the database.
58 :    
59 :     =item message
60 :    
61 :     Message to display if an error has been detected.
62 :    
63 :     =item orgs
64 :    
65 :     Reference to a hash mapping genome IDs to organism names.
66 :    
67 :     =item name
68 :    
69 :     Name to use for this object's form.
70 :    
71 :     =item scriptQueue
72 :    
73 :     List of JavaScript statements to be executed after the form is closed.
74 :    
75 :     =back
76 :    
77 :     =cut
78 :    
79 :     # This counter is used to insure every form on the page has a unique name.
80 :     my $formCount = 0;
81 :    
82 :     =head2 Public Methods
83 :    
84 :     =head3 new
85 :    
86 :     C<< my $shelp = SearchHelper->new($query); >>
87 :    
88 :     Construct a new SearchHelper object.
89 :    
90 :     =over 4
91 :    
92 :     =item query
93 :    
94 :     The CGI query object for the current script.
95 :    
96 :     =back
97 :    
98 :     =cut
99 :    
100 :     sub new {
101 :     # Get the parameters.
102 :     my ($class, $query) = @_;
103 :     # Check for a session ID.
104 :     my $session_id = $query->param("SessionID");
105 :     my $type = "old";
106 :     if (! $session_id) {
107 :     # Here we're starting a new session. We create the session ID and
108 :     # store it in the query object.
109 :     $session_id = NewSessionID();
110 :     $type = "new";
111 :     $query->param(-name => 'SessionID', -value => $session_id);
112 :     }
113 :     # Compute the subclass name.
114 :     $class =~ /SH(.+)$/;
115 :     my $subClass = $1;
116 :     # Create the Sprout object.
117 :     my $sprout = SFXlate->new_sprout_only();
118 :     # Insure everybody knows we're in Sprout mode.
119 :     $query->param(-name => 'SPROUT', -value => 1);
120 :     # Generate the form name.
121 :     my $formName = "$class$formCount";
122 :     $formCount++;
123 :     # Create the shelp object. It contains the query object (with the session ID)
124 :     # as well as an indicator as to whether or not the session is new, plus the
125 :     # class name and the Sprout object.
126 :     my $retVal = {
127 :     query => $query,
128 :     type => $type,
129 :     class => $subClass,
130 :     sprout => $sprout,
131 :     orgs => {},
132 :     name => $formName,
133 :     scriptQueue => [],
134 :     };
135 :     # Bless and return it.
136 :     bless $retVal, $class;
137 :     return $retVal;
138 :     }
139 :    
140 :     =head3 Q
141 :    
142 :     C<< my $query = $shelp->Q(); >>
143 :    
144 :     Return the CGI query object.
145 :    
146 :     =cut
147 :    
148 :     sub Q {
149 :     # Get the parameters.
150 :     my ($self) = @_;
151 :     # Return the result.
152 :     return $self->{query};
153 :     }
154 :    
155 :     =head3 DB
156 :    
157 :     C<< my $sprout = $shelp->DB(); >>
158 :    
159 :     Return the Sprout database object.
160 :    
161 :     =cut
162 :    
163 :     sub DB {
164 :     # Get the parameters.
165 :     my ($self) = @_;
166 :     # Return the result.
167 :     return $self->{sprout};
168 :     }
169 :    
170 :     =head3 IsNew
171 :    
172 :     C<< my $flag = $shelp->IsNew(); >>
173 :    
174 :     Return TRUE if this is a new session, FALSE if this is an old session. An old
175 :     session already has search results ready to process.
176 :    
177 :     =cut
178 :    
179 :     sub IsNew {
180 :     # Get the parameters.
181 :     my ($self) = @_;
182 :     # Return the result.
183 :     return ($self->{type} eq 'new');
184 :     }
185 :    
186 :     =head3 ID
187 :    
188 :     C<< my $sessionID = $shelp->ID(); >>
189 :    
190 :     Return the current session ID.
191 :    
192 :     =cut
193 :    
194 :     sub ID {
195 :     # Get the parameters.
196 :     my ($self) = @_;
197 :     # Return the result.
198 :     return $self->Q()->param("SessionID");
199 :     }
200 :    
201 :     =head3 FormName
202 :    
203 :     C<< my $name = $shelp->FormName(); >>
204 :    
205 :     Return the name of the form this helper object will generate.
206 :    
207 :     =cut
208 :    
209 :     sub FormName {
210 :     # Get the parameters.
211 :     my ($self) = @_;
212 :     # Return the result.
213 :     return $self->{name};
214 :     }
215 :    
216 :     =head3 QueueFormScript
217 :    
218 :     C<< $shelp->QueueFormScript($statement); >>
219 :    
220 :     Add the specified statement to the queue of JavaScript statements that are to be
221 :     executed when the form has been fully defined. This is necessary because until
222 :     the closing </FORM> tag is emitted, the form elements cannot be referenced by
223 :     name. When generating the statement, you can refer to the variable C<thisForm>
224 :     in order to reference the form in progress. Thus,
225 :    
226 :     thisForm.simLimit.value = 1e-10;
227 :    
228 :     would set the value of the form element C<simLimit> in the current form to
229 :     C<1e-10>.
230 :    
231 :     =over 4
232 :    
233 :     =item statement
234 :    
235 :     JavaScript statement to be queued for execution after the form is built.
236 :     The trailing semi-colon is required. Theoretically, you could include
237 :     multiple statements separated by semi-colons, but one at a time works
238 :     just as well.
239 :    
240 :     =back
241 :    
242 :     =cut
243 :    
244 :     sub QueueFormScript {
245 :     # Get the parameters.
246 :     my ($self, $statement) = @_;
247 :     # Push the statement onto the script queue.
248 :     push @{$self->{scriptQueue}}, $statement;
249 :     }
250 :    
251 :     =head3 FormStart
252 :    
253 :     C<< my $html = $shelp->FormStart($title); >>
254 :    
255 :     Return the initial section of a form designed to perform another search of the
256 :     same type. The form header is included along with hidden fields to persist the
257 :     tracing, sprout status, and search class.
258 :    
259 :     A call to L</FormEnd> is required to close the form.
260 :    
261 :     =over 4
262 :    
263 :     =item title
264 :    
265 :     Title to be used for the form.
266 :    
267 :     =item RETURN
268 :    
269 :     Returns the initial HTML for the search form.
270 :    
271 :     =back
272 :    
273 :     =cut
274 :    
275 :     sub FormStart {
276 :     # Get the parameters.
277 :     my ($self, $title) = @_;
278 :     # Get the CGI object.
279 :     my $cgi = $self->Q();
280 :     # Start the form.
281 :     my $retVal = "<div class=\"search\">\n" .
282 :     $cgi->start_form(-method => 'POST',
283 :     -action => $cgi->url(-relative => 1),
284 :     -name => $self->FormName()) .
285 :     $cgi->hidden(-name => 'Class',
286 :     -value => $self->{class}) .
287 :     $cgi->hidden(-name => 'SPROUT',
288 :     -value => 1) .
289 :     $cgi->h3($title);
290 :     # If tracing is on, add it to the form.
291 :     if ($cgi->param('Trace')) {
292 :     $retVal .= $cgi->hidden(-name => 'Trace',
293 :     -value => $cgi->param('Trace')) .
294 :     $cgi->hidden(-name => 'TF',
295 :     -value => ($cgi->param('TF') ? 1 : 0));
296 :     }
297 :     # Put in an anchor tag in case there's a table of contents.
298 :     my $anchorName = $self->FormName();
299 :     $retVal .= "<a name=\"$anchorName\"></a>\n";
300 :     # Return the result.
301 :     return $retVal;
302 :     }
303 :    
304 :     =head3 FormEnd
305 :    
306 :     C<< my $htmlText = $shelp->FormEnd(); >>
307 :    
308 :     Return the HTML text for closing a search form. This closes both the C<form> and
309 :     C<div> tags.
310 :    
311 :     =cut
312 :    
313 :     sub FormEnd {
314 :     # Get the parameters.
315 :     my ($self) = @_;
316 :     # Declare the return variable, closing the form and the DIV block.
317 :     my $retVal = "</form></div>\n";
318 :     # Now we flush out the statement queue.
319 :     my @statements = @{$self->{scriptQueue}};
320 :     if (@statements > 0) {
321 :     # Switch to JavaScript and set the "thisForm" variable.
322 :     $retVal .= "<SCRIPT language=\"JavaScript\">\n" .
323 :     " thisForm = document.$self->{name};\n";
324 :     # Unroll the statements.
325 :     while (@statements > 0) {
326 :     my $statement = shift @statements;
327 :     $retVal .= " $statement\n";
328 :     }
329 :     # Close the JavaScript.
330 :     $retVal .= "</SCRIPT>\n";
331 :     }
332 :     # Return the result.
333 :     return $retVal;
334 :     }
335 :    
336 :     =head3 SetMessage
337 :    
338 :     C<< $shelp->SetMessage($msg); >>
339 :    
340 :     Store the specified text as the result message. The result message is displayed
341 :     if an invalid parameter value is specified.
342 :    
343 :     =over 4
344 :    
345 :     =item msg
346 :    
347 :     Text of the result message to be displayed.
348 :    
349 :     =back
350 :    
351 :     =cut
352 :    
353 :     sub SetMessage {
354 :     # Get the parameters.
355 :     my ($self, $msg) = @_;
356 :     # Store the message.
357 :     $self->{message} = $msg;
358 :     }
359 :    
360 :     =head3 Message
361 :    
362 :     C<< my $text = $shelp->Message(); >>
363 :    
364 :     Return the result message. The result message is displayed if an invalid parameter
365 :     value is specified.
366 :    
367 :     =cut
368 :    
369 :     sub Message {
370 :     # Get the parameters.
371 :     my ($self) = @_;
372 :     # Return the result.
373 :     return $self->{message};
374 :     }
375 :    
376 :     =head3 OpenSession
377 :    
378 :     C<< $shelp->OpenSession(); >>
379 :    
380 :     Set up to open the session cache file for writing. Note we don't actually
381 :     open the file until after we know the column headers.
382 :    
383 :     =cut
384 :    
385 :     sub OpenSession {
386 :     # Get the parameters.
387 :     my ($self) = @_;
388 :     # Denote we have not yet written out the column headers.
389 :     $self->{cols} = undef;
390 :     }
391 :    
392 :     =head3 GetCacheFileName
393 :    
394 :     C<< my $fileName = $shelp->GetCacheFileName(); >>
395 :    
396 :     Return the name to be used for this session's cache file.
397 :    
398 :     =cut
399 :    
400 :     sub GetCacheFileName {
401 :     # Get the parameters.
402 :     my ($self) = @_;
403 :     # Return the result.
404 :     return $self->GetTempFileName('cache');
405 :     }
406 :    
407 :     =head3 GetTempFileName
408 :    
409 :     C<< my $fileName = $shelp->GetTempFileName($type); >>
410 :    
411 :     Return the name to be used for a temporary file of the specified type. The
412 :     name is computed from the session name with the type as a suffix.
413 :    
414 :     =over 4
415 :    
416 :     =item type
417 :    
418 :     Type of temporary file to be generated.
419 :    
420 :     =item RETURN
421 :    
422 :     Returns a file name generated from the session name and the specified type.
423 :    
424 :     =back
425 :    
426 :     =cut
427 :    
428 :     sub GetTempFileName {
429 :     # Get the parameters.
430 :     my ($self, $type) = @_;
431 :     # Compute the file name. Note it gets stuffed in the FIG temporary
432 :     # directory.
433 :     my $retVal = "$FIG_Config::temp/tmp_" . $self->ID() . ".$type";
434 :     # Return the result.
435 :     return $retVal;
436 :     }
437 :    
438 :     =head3 PutFeature
439 :    
440 :     C<< $shelp->PutFeature($record, %extraCols); >>
441 :    
442 :     Store a feature in the result cache. This is the workhorse method for most
443 :     searches, since the primary data item in the database is features.
444 :    
445 :     For each feature, there are certain columns that are standard: the feature name, the
446 :     GBrowse and protein page links, the functional assignment, and so forth. If additional
447 :     columns are required by a particular search subclass, they should be included in the
448 :     parameters, in key-value form. For example, the following call adds columns for
449 :     essentiality and virulence.
450 :    
451 :     $shelp->PutFeature($record, essential => $essentialFlag, virulence => $vfactor);
452 :    
453 :     For correct results, all values should be specified for all extra columns in all calls to
454 :     B<PutFeature>. (In particular, the column header names are computed on the first
455 :     call.) If a column is to be blank for the current feature, its value can be given
456 :     as C<undef>.
457 :    
458 :     if (! $essentialFlag) {
459 :     $essentialFlag = undef;
460 :     }
461 :     $shelp->PutFeature($record, essential => $essentialFlag, virulence = $vfactor);
462 :    
463 :     =over 4
464 :    
465 :     =item record
466 :    
467 :     DBObject record for the feature.
468 :    
469 :     =item extraCols
470 :    
471 :     =back
472 :    
473 :     =cut
474 :    
475 :     sub PutFeature {
476 :     # Get the parameters. Note that the extra columns are read in as a list
477 :     # instead of a hash so that the column order is preserved.
478 :     my ($self, $record, @extraColList) = @_;
479 :     # Check for a first-call situation.
480 :     if (! defined $self->{cols}) {
481 :     # Here we need to set up the column information. Start with the defaults.
482 :     $self->{cols} = $self->DefaultFeatureColumns();
483 :     # Append the extras. Note we proceed by twos because the columns are
484 :     # specified in the form name => value.
485 :     for (my $i = 0; $i <= $#extraColList; $i += 2) {
486 :     push @{$self->{cols}}, "X=$extraColList[$i]";
487 :     }
488 :     # Write out the column headers. This also prepares the cache file to receive
489 :     # output.
490 :     $self->WriteColumnHeaders(map { $self->FeatureColumnTitle($_) } @{$self->{cols}});
491 :     }
492 :     # Get the feature ID.
493 :     my ($fid) = $record->Value('Feature(id)');
494 :     # Now we process the columns themselves. First, convert the extra column list
495 :     # to a hash.
496 :     my %extraCols = @extraColList;
497 :     # Loop through the column headers, producing the desired data.
498 :     my @output = ();
499 :     for my $colName (@{$self->{cols}}) {
500 :     push @output, $self->FeatureColumnValue($colName, $record, \%extraCols);
501 :     }
502 :     # Compute the sort key. The sort key floats NMPDR organism features to the
503 :     # top of the return list.
504 :     my $group = $self->FeatureGroup($fid);
505 :     my $key = ($group ? "A$group" : "ZZ");
506 :     # Write the feature data.
507 :     $self->WriteColumnData($key, @output);
508 :     }
509 :    
510 :     =head3 WriteColumnHeaders
511 :    
512 :     C<< $shelp->WriteColumnHeaders(@colNames); >>
513 :    
514 :     Write out the column headers for the current search session. The column headers
515 :     are sent to the cache file, and then the cache is re-opened as a sort pipe and
516 :     the handle saved.
517 :    
518 :     =over 4
519 :    
520 :     =item colNames
521 :    
522 :     A list of column names in the desired presentation order.
523 :    
524 :     =back
525 :    
526 :     =cut
527 :    
528 :     sub WriteColumnHeaders {
529 :     # Get the parameters.
530 :     my ($self, @colNames) = @_;
531 :     # Get the cache file name and open it for output.
532 :     my $fileName = $self->GetCacheFileName();
533 :     my $handle1 = Open(undef, ">$fileName");
534 :     # Write the column headers and close the file.
535 :     Tracer::PutLine($handle1, \@colNames);
536 :     close $handle1;
537 :     # Now open the sort pipe and save the file handle. Note how we append the
538 :     # sorted data to the column header row already in place. The output will
539 :     # contain a sort key followed by the real columns. The sort key is
540 :     # hacked off before going to the output file.
541 :     $self->{fileHandle} = Open(undef, "| sort | cut --fields=2- >>$fileName");
542 :     }
543 :    
544 :     =head3 WriteColumnData
545 :    
546 :     C<< $shelp->WriteColumnData($key, @colValues); >>
547 :    
548 :     Write a row of column values to the current search session. It is assumed that
549 :     the session file is already open for output.
550 :    
551 :     =over 4
552 :    
553 :     =item key
554 :    
555 :     Sort key.
556 :    
557 :     =item colValues
558 :    
559 :     List of column values to write to the search result cache file for this session.
560 :    
561 :     =back
562 :    
563 :     =cut
564 :    
565 :     sub WriteColumnData {
566 :     # Get the parameters.
567 :     my ($self, $key, @colValues) = @_;
568 :     # Write them to the cache file.
569 :     Tracer::PutLine($self->{fileHandle}, [$key, @colValues]);
570 :     }
571 :    
572 :     =head3 CloseSession
573 :    
574 :     C<< $shelp->CloseSession(); >>
575 :    
576 :     Close the session file.
577 :    
578 :     =cut
579 :    
580 :     sub CloseSession {
581 :     # Get the parameters.
582 :     my ($self) = @_;
583 :     # Check for an open session file.
584 :     if (defined $self->{fileHandle}) {
585 :     # We found one, so close it.
586 :     close $self->{fileHandle};
587 :     }
588 :     }
589 :    
590 :     =head3 NewSessionID
591 :    
592 :     C<< my $id = SearchHelpers::NewSessionID(); >>
593 :    
594 :     Generate a new session ID for the current user.
595 :    
596 :     =cut
597 :    
598 :     sub NewSessionID {
599 :     # Declare the return variable.
600 :     my $retVal;
601 :     # Get a digest encoder.
602 :     my $md5 = Digest::MD5->new();
603 :     # If we have a randomization file, use it to seed the digester.
604 :     if (open(R, "/dev/urandom")) {
605 :     my $b;
606 :     read(R, $b, 1024);
607 :     $md5->add($b);
608 :     }
609 :     # Add the PID and the time stamp.
610 :     $md5->add($$, gettimeofday);
611 :     # Hash it up and clean the result so that it works as a file name.
612 :     $retVal = $md5->b64digest();
613 :     $retVal =~ s,/,\$,g;
614 :     $retVal =~ s,\+,@,g;
615 :     # Return it.
616 :     return $retVal;
617 :     }
618 :    
619 :     =head3 OrganismData
620 :    
621 :     C<< my ($orgName, $group) = $shelp->Organism($genomeID); >>
622 :    
623 :     Return the name and status of the organism corresponding to the specified genome ID.
624 :     For performance reasons, this information is cached in a special hash table, so we
625 :     only compute it once per run.
626 :    
627 :     =over 4
628 :    
629 :     =item genomeID
630 :    
631 :     ID of the genome whose name is desired.
632 :    
633 :     =item RETURN
634 :    
635 :     Returns a list of two items. The first item in the list is the organism name,
636 :     and the second is the name of the NMPDR group, or an empty string if the
637 :     organism is not in an NMPDR group.
638 :    
639 :     =back
640 :    
641 :     =cut
642 :    
643 :     sub OrganismData {
644 :     # Get the parameters.
645 :     my ($self, $genomeID) = @_;
646 :     # Declare the return variables.
647 :     my ($orgName, $group);
648 :     # Check the cache.
649 :     my $cache = $self->{orgs};
650 :     if (exists $cache->{$genomeID}) {
651 :     ($orgName, $group) = @{$cache->{$genomeID}};
652 :     } else {
653 :     # Here we have to use the database.
654 :     my $sprout = $self->DB();
655 :     my ($genus, $species, $strain, $group) = $sprout->GetEntityValues('Genome', $genomeID,
656 :     ['Genome(genus)', 'Genome(species)',
657 :     'Genome(unique-characterization)',
658 :     'Genome(primary-group)']);
659 :     # Null out the supporting group.
660 :     $group = "" if ($group eq $FIG_Config::otherGroup);
661 :     # If the organism does not exist, format an unknown name.
662 :     if (! defined($genus)) {
663 :     $orgName = "Unknown Genome $genomeID";
664 :     } else {
665 :     # It does exist, so format the organism name.
666 :     $orgName = "$genus $species";
667 :     if ($strain) {
668 :     $orgName .= " $strain";
669 :     }
670 :     }
671 :     # Save this organism in the cache.
672 :     $cache->{$genomeID} = [$orgName, $group];
673 :     }
674 :     # Return the result.
675 :     return ($orgName, $group);
676 :     }
677 :    
678 :     =head3 Organism
679 :    
680 :     C<< my $orgName = $shelp->Organism($genomeID); >>
681 :    
682 :     Return the name of the relevant organism. The name is computed from the genus,
683 :     species, and unique characterization. A cache is used to improve performance.
684 :    
685 :     =over 4
686 :    
687 :     =item genomeID
688 :    
689 :     ID of the genome whose name is desired.
690 :    
691 :     =item RETURN
692 :    
693 :     Returns the display name of the specified organism.
694 :    
695 :     =back
696 :    
697 :     =cut
698 :    
699 :     sub Organism {
700 :     # Get the parameters.
701 :     my ($self, $genomeID) = @_;
702 :     # Get the organism data.
703 :     my ($retVal, $group) = $self->OrganismData($genomeID);
704 :     # Return the result.
705 :     return $retVal;
706 :     }
707 :    
708 :     =head3 FeatureGroup
709 :    
710 :     C<< my $groupName = $shelp->FeatureGroup($fid); >>
711 :    
712 :     Return the group name for the specified feature.
713 :    
714 :     =over 4
715 :    
716 :     =item fid
717 :    
718 :     ID of the relevant feature.
719 :    
720 :     =item RETURN
721 :    
722 :     Returns the name of the NMPDR group to which the feature belongs, or an empty
723 :     string if it is not part of an NMPDR group.
724 :    
725 :     =back
726 :    
727 :     =cut
728 :    
729 :     sub FeatureGroup {
730 :     # Get the parameters.
731 :     my ($self, $fid) = @_;
732 :     # Parse the feature ID to get the genome ID.
733 :     my ($genomeID) = FIGRules::ParseFeatureID($fid);
734 :     # Get the organism data.
735 :     my (undef, $retVal) = $self->OrganismData($genomeID);
736 :     # Return the result.
737 :     return $retVal;
738 :     }
739 :    
740 :     =head3 FeatureName
741 :    
742 :     C<< my $fidName = $shelp->FeatureName($fid); >>
743 :    
744 :     Return the display name of the specified feature.
745 :    
746 :     =over 4
747 :    
748 :     =item fid
749 :    
750 :     ID of the feature whose name is desired.
751 :    
752 :     =item RETURN
753 :    
754 :     A displayable feature name, consisting of the organism name plus some feature
755 :     type and location information.
756 :    
757 :     =back
758 :    
759 :     =cut
760 :    
761 :     sub FeatureName {
762 :     # Get the parameters.
763 :     my ($self, $fid) = @_;
764 :     # Declare the return variable
765 :     my $retVal;
766 :     # Parse the feature ID.
767 :     my ($genomeID, $type, $num) = FIGRules::ParseFeatureID($fid);
768 :     if (! defined $genomeID) {
769 :     # Here the feature ID has an invalid format.
770 :     $retVal = "External: $fid";
771 :     } else {
772 :     # Here we can get its genome data.
773 :     $retVal = $self->Organism($genomeID);
774 :     # Append the type and number.
775 :     $retVal .= " [$type $num]";
776 :     }
777 :     # Return the result.
778 :     return $retVal;
779 :     }
780 :    
781 :     =head3 ComputeFASTA
782 :    
783 :     C<< my $fasta = $shelp->ComputeFASTA($incomingType, $desiredType, $sequence); >>
784 :    
785 :     Parse a sequence input and convert it into a FASTA string of the desired type. Note
786 :     that it is possible to convert a DNA sequence into a protein sequence, but the reverse
787 :     is not possible.
788 :    
789 :     =over 4
790 :    
791 :     =item incomingType
792 :    
793 :     C<dna> if this is a DNA sequence, C<prot> if this is a protein sequence.
794 :    
795 :     =item desiredType
796 :    
797 :     C<dna> to return a DNA sequence, C<prot> to return a protein sequence. If the
798 :     I<$incomingType> is C<prot> and this value is C<dna>, an error will be thrown.
799 :    
800 :     =item sequence
801 :    
802 :     Sequence to return. It may be a DNA or protein sequence in FASTA form or a feature ID.
803 :     If a feature ID is specified, the feature's DNA or translation will be returned. The
804 :     feature ID is recognized by the presence of a vertical bar in the input. Otherwise,
805 :     if the input does not begin with a greater-than sign (FASTA label line), a default label
806 :     line will be provided.
807 :    
808 :     =item RETURN
809 :    
810 :     Returns a string in FASTA format representing the content of the desired sequence with
811 :     an appropriate label. If the input is invalid, a message will be stored and we will
812 :     return C<undef>. Note that the output will include a trailing new-line.
813 :    
814 :     =back
815 :    
816 :     =cut
817 :    
818 :     sub ComputeFASTA {
819 :     # Get the parameters.
820 :     my ($self, $incomingType, $desiredType, $sequence) = @_;
821 :     # Declare the return variable. If an error occurs, it will remain undefined.
822 :     my $retVal;
823 :     # Create variables to hold the FASTA label and data.
824 :     my ($fastaLabel, $fastaData);
825 :     # Check for a feature specification.
826 :     if ($sequence =~ /^\s*(\w+\|\S+)\s*$/) {
827 :     # Here we have a feature ID in $1. We'll need the Sprout object to process
828 :     # it.
829 :     my $fid = $1;
830 :     my $sprout = $self->DB();
831 :     # Get the FIG ID. Note that we only use the first feature found. We are not
832 :     # supposed to have redundant aliases, though we may have an ID that doesn't
833 :     # exist.
834 :     my ($figID) = $sprout->FeaturesByAlias($fid);
835 :     if (! $figID) {
836 :     $self->SetMessage("No feature found with the ID \"$fid\".");
837 :     } else {
838 :     # Set the FASTA label.
839 :     my $fastaLabel = $fid;
840 :     # Now proceed according to the sequence type.
841 :     if ($desiredType =~ /prot/i) {
842 :     # We want protein, so get the translation.
843 :     $fastaData = $sprout->FeatureTranslation($figID);
844 :     } else {
845 :     # We want DNA, so get the DNA sequence. This is a two-step process.
846 :     my @locList = $sprout->FeatureLocation($figID);
847 :     $fastaData = $sprout->DNASeq(\@locList);
848 :     }
849 :     }
850 :     } elsif ($incomingType =~ /prot/ && $desiredType =~ /dna/) {
851 :     # Here we're being asked to do an impossible conversion.
852 :     $self->SetMessage("Cannot convert a protein sequence to DNA.");
853 :     } else {
854 :     # Here we are expecting a FASTA. We need to see if there's a label.
855 :     if ($sequence =~ /^>\s*(\S.*)\s*\n(.+)$/) {
856 :     # Here we have a label, so we split it from the data.
857 :     $fastaLabel = $1;
858 :     $fastaData = $2;
859 :     } else {
860 :     # Here we have no label, so we create one and use the entire sequence
861 :     # as data.
862 :     $fastaLabel = "User-specified $incomingType sequence";
863 :     $fastaData = $sequence;
864 :     }
865 :     # The next step is to clean the junk out of the sequence.
866 :     $fastaData =~ s/\n//g;
867 :     $fastaData =~ s/\s+//g;
868 :     # Finally, if the user wants to convert to protein, we do it here. Note that
869 :     # we've already prevented a conversion from protein to DNA.
870 :     if ($incomingType ne $desiredType) {
871 :     $fastaData = Sprout::Protein($fastaData);
872 :     }
873 :     }
874 :     # At this point, either "$fastaLabel" and "$fastaData" have values or an error is
875 :     # in progress.
876 :     if (defined $fastaLabel) {
877 :     # We need to format the sequence into 60-byte chunks. We use the infamous
878 :     # grep-split trick. The split, because of the presence of the parentheses,
879 :     # includes the matched delimiters in the output list. The grep strips out
880 :     # the empty list items that appear between the so-called delimiters, since
881 :     # the delimiters are what we want.
882 :     my @chunks = grep { $_ } split /(.{1,60})/, $fastaData;
883 :     my $retVal = join("\n", ">$fastaLabel", @chunks, "");
884 :     }
885 :     # Return the result.
886 :     return $retVal;
887 :     }
888 :    
889 :     =head3 NmpdrGenomeMenu
890 :    
891 :     C<< my $htmlText = $shelp->NmpdrGenomeMenu($menuName, \%options, \@selected); >>
892 :    
893 :     This method creates a hierarchical HTML menu for NMPDR genomes organized by category. The
894 :     category indicates the low-level NMPDR group. Organizing the genomes in this way makes it
895 :     easier to select all genomes from a particular category.
896 :    
897 :     =over 4
898 :    
899 :     =item menuName
900 :    
901 :     Name to give to the menu.
902 :    
903 :     =item options
904 :    
905 :     Reference to a hash containing the options to be applied to the C<SELECT> tag form the menu.
906 :     Typical options would include C<multiple> to specify
907 :     that multiple selections are allowed and C<size> to set the number of rows to display
908 :     in the menu.
909 :    
910 :     =item selected
911 :    
912 :     Reference to a list containing the IDs of the genomes to be pre-selected. If the menu
913 :     is not intended to allow multiple selections, the list should be a singleton. If the
914 :     list is empty, nothing will be pre-selected.
915 :    
916 :     =item RETURN
917 :    
918 :     Returns the HTML text to generate a C<SELECT> menu inside a form.
919 :    
920 :     =back
921 :    
922 :     =cut
923 :    
924 :     sub NmpdrGenomeMenu {
925 :     # Get the parameters.
926 :     my ($self, $menuName, $options, $selected) = @_;
927 :     # Get the Sprout and CGI objects.
928 :     my $sprout = $self->DB();
929 :     my $cgi = $self->Q();
930 :     # Get the form name.
931 :     my $formName = $self->FormName();
932 :     # Get a list of all the genomes in group order. In fact, we only need them ordered
933 :     # by name (genus,species,strain), but putting primary-group in front enables us to
934 :     # take advantage of an existing index.
935 :     my @genomeList = $sprout->GetAll(['Genome'],
936 :     "ORDER BY Genome(primary-group), Genome(genus), Genome(species), Genome(unique-characterization)",
937 :     [], ['Genome(primary-group)', 'Genome(id)',
938 :     'Genome(genus)', 'Genome(species)',
939 :     'Genome(unique-characterization)']);
940 :     # Create a hash to organize the genomes by group. Each group will contain a list of
941 :     # 2-tuples, the first element being the genome ID and the second being the genome
942 :     # name.
943 :     my %groupHash = ();
944 :     for my $genome (@genomeList) {
945 :     # Get the genome data.
946 :     my ($group, $genomeID, $genus, $species, $strain) = @{$genome};
947 :     # Form the genome name.
948 :     my $name = "$genus $species";
949 :     if ($strain) {
950 :     $name .= " $strain";
951 :     }
952 :     # Push the genome into the group's list.
953 :     push @{$groupHash{$group}}, [$genomeID, $name];
954 :     }
955 :     # Now we are ready to unroll the menu out of the group hash. First, we sort the groups, putting
956 :     # the supporting-genome group last.
957 :     my @groups = sort grep { $_ ne $FIG_Config::otherGroup } keys %groupHash;
958 :     push @groups, $FIG_Config::otherGroup;
959 :     # Next, create a hash that specifies the pre-selected entries.
960 :     my %selectedHash = map { $_ => 1 } @{$selected};
961 :     # Now it gets complicated. We need a way to mark all the NMPDR genomes.
962 :     # Create the type counters.
963 :     my $groupCount = 1;
964 :     # Compute the ID for the status display.
965 :     my $divID = "${formName}_${menuName}_status";
966 :     # Compute the JavaScript call for updating the status.
967 :     my $showSelect = "showSelected($menuName, '$divID', 1000);";
968 :     # If multiple selection is supported, create an onChange event.
969 :     my $onChange = "";
970 :     if ($options->{multiple}) {
971 :     $onChange = " onChange=\"$showSelect\"";
972 :     }
973 :     # Create the SELECT tag and stuff it into the output array.
974 :     my $select = "<" . join(" ", "SELECT name=\"$menuName\"$onChange", map { " $_=\"$options->{$_}\"" } keys %{$options}) . ">";
975 :     my @lines = ($select);
976 :     # Loop through the groups.
977 :     for my $group (@groups) {
978 :     # Create the option group tag.
979 :     my $tag = "<OPTGROUP label=\"$group\">";
980 :     push @lines, " $tag";
981 :     # Compute the label for this group's options. This is seriously dirty stuff, as the
982 :     # label option may have functionality in future browsers. If that happens, we'll need
983 :     # to modify the genome text so that the "selectSome" method can tell which are NMPDR
984 :     # organisms and which aren't. Sadly, the OPTGROUP tag is invisible in the DOM Javascript
985 :     # hierarchy.
986 :     my $label = ($group eq $FIG_Config::otherGroup ? "other" : "nmpdr");
987 :     # Get the genomes in the group.
988 :     for my $genome (@{$groupHash{$group}}) {
989 :     my ($genomeID, $name) = @{$genome};
990 :     # See if it's selected.
991 :     my $select = ($selectedHash{$genomeID} ? " selected" : "");
992 :     # Generate the option tag.
993 :     my $optionTag = "<OPTION value=\"$genomeID\" label=\"$label\"$select>$name <em>($genomeID)</em></OPTION>";
994 :     push @lines, " $optionTag";
995 :     }
996 :     # Close the option group.
997 :     push @lines, " </OPTGROUP>";
998 :     }
999 :     # Close the SELECT tag.
1000 :     push @lines, "</SELECT>";
1001 :     # Check for multiple selection.
1002 :     if ($options->{multiple}) {
1003 :     # Since multi-select is on, we can set up some buttons to set and clear selections.
1004 :     push @lines, "<br />";
1005 :     push @lines, "<INPUT type=\"button\" name=\"SelectAll\" class=\"bigButton\" value=\"Select All\" onClick=\"selectAll($menuName); $showSelect\" />";
1006 :     push @lines, "<INPUT type=\"button\" name=\"ClearAll\" class=\"bigButton\" value=\"Clear All\" onClick=\"clearAll($menuName); $showSelect\" />";
1007 :     push @lines, "<INPUT type=\"button\" name=\"NMPDROnly\" class=\"bigButton\" value=\"Select NMPDR\" onClick=\"selectSome($menuName, 'nmpdr'); $showSelect\" />";
1008 :     push @lines, "<INPUT type=\"button\" name=\"OtherOnly\" class=\"bigButton\" value=\"Select Supporting\" onClick=\"selectSome($menuName, 'other'); $showSelect\" />";
1009 :     # Add the status display, too.
1010 :     push @lines, "<DIV id=\"$divID\" class=\"selectStatus\"></DIV>";
1011 :     # Queue to update the status display when the form loads. We need to modify the show statement
1012 :     # slightly because the queued statements are executed outside the form. This may seem like a lot of
1013 :     # trouble, but we want all of the show statement calls to be generated from a single line of code,
1014 :     # in case we decide to twiddle the parameters.
1015 :     $showSelect =~ s/showSelected\(/showSelected\(thisForm\./;
1016 :     $self->QueueFormScript($showSelect);
1017 :     }
1018 :     # Assemble all the lines into a string.
1019 :     my $retVal = join("\n", @lines, "");
1020 :     # Return the result.
1021 :     return $retVal;
1022 :     }
1023 :    
1024 :     =head3 MakeTable
1025 :    
1026 :     C<< my $htmlText = $shelp->MakeTable(\@rows); >>
1027 :    
1028 :     Create a table from a group of table rows. The table rows must be fully pre-formatted: in
1029 :     other words, each must have the TR and TD tags included.
1030 :    
1031 :     The purpose of this method is to provide a uniform look for search form tables. It is
1032 :     almost impossible to control a table using styles, so rather than have a table style,
1033 :     we create the TABLE tag in this method. Note also that the first TD or TH in each row will
1034 :     be updated with an explicit width so the forms look pretty when they are all on one
1035 :     page.
1036 :    
1037 :     =over 4
1038 :    
1039 :     =item rows
1040 :    
1041 :     Reference to a list of table rows. Each table row must be in HTML form with all
1042 :     the TR and TD tags set up. The first TD or TH tag in each row will be modified to
1043 :     set the width. Everything else will be left as is.
1044 :    
1045 :     =item RETURN
1046 :    
1047 :     Returns the full HTML for a table in the approved NMPDR Search Form style.
1048 :    
1049 :     =back
1050 :    
1051 :     =cut
1052 :    
1053 :     sub MakeTable {
1054 :     # Get the parameters.
1055 :     my ($self, $rows) = @_;
1056 :     # Get the CGI object.
1057 :     my $cgi = $self->Q();
1058 :     # Fix the widths on the first column. Note that we eschew the use of the "g"
1059 :     # modifier becase we only want to change the first tag. Also, if a width
1060 :     # is already specified on the first column bad things will happen.
1061 :     for my $row (@{$rows}) {
1062 :     $row =~ s/(<td|th)/$1 width="150"/i;
1063 :     }
1064 :     # Create the table.
1065 :     my $retVal = $cgi->table({border => 2, cellspacing => 2,
1066 :     width => 700, class => 'search'},
1067 :     @{$rows});
1068 :     # Return the result.
1069 :     return $retVal;
1070 :     }
1071 :    
1072 :     =head3 SubmitRow
1073 :    
1074 :     C<< my $htmlText = $shelp->SubmitRow(); >>
1075 :    
1076 :     Returns the HTML text for the row containing the page size control
1077 :     and the submit button. All searches should have this row somewhere
1078 :     near the top of the form.
1079 :    
1080 :     =cut
1081 :    
1082 :     sub SubmitRow {
1083 :     # Get the parameters.
1084 :     my ($self) = @_;
1085 :     my $cgi = $self->Q();
1086 :     # Declare the return variable.
1087 :     my $retVal = $cgi->Tr($cgi->td("Results/Page"),
1088 :     $cgi->td($cgi->popup_menu(-name => 'PageSize',
1089 :     -values => [10, 25, 45, 100, 1000],
1090 :     -default => $cgi->param('PageSize'))),
1091 :     $cgi->td($cgi->submit(-class => 'goButton',
1092 :     -name => 'Search',
1093 :     -value => 'Go')));
1094 :     # Return the result.
1095 :     return $retVal;
1096 :     }
1097 :     =head3 GBrowseFeatureURL
1098 :    
1099 :     C<< my $url = SearchHelper::GBrowseFeatureURL($sprout, $feat); >>
1100 :    
1101 :     Compute the URL required to pull up a Gbrowse page for the the specified feature.
1102 :     In order to do this, we need to pull out the ID of the feature's Genome, its
1103 :     contig ID, and some rough starting and stopping offsets.
1104 :    
1105 :     =over 4
1106 :    
1107 :     =item sprout
1108 :    
1109 :     Sprout object for accessing the database.
1110 :    
1111 :     =item feat
1112 :    
1113 :     ID of the feature whose Gbrowse URL is desired.
1114 :    
1115 :     =item RETURN
1116 :    
1117 :     Returns a GET-style URL for the Gbrowse CGI, with parameters specifying the genome
1118 :     ID, contig ID, starting offset, and stopping offset.
1119 :    
1120 :     =back
1121 :    
1122 :     =cut
1123 :    
1124 :     sub GBrowseFeatureURL {
1125 :     # Get the parameters.
1126 :     my ($sprout, $feat) = @_;
1127 :     # Declare the return variable.
1128 :     my $retVal;
1129 :     # Compute the genome ID.
1130 :     my ($genomeID) = FIGRules::ParseFeatureID($feat);
1131 :     # Only proceed if the feature ID produces a valid genome.
1132 :     if ($genomeID) {
1133 :     # Get the feature location string.
1134 :     my $loc = $sprout->FeatureLocation($feat);
1135 :     # Compute the contig, start, and stop points.
1136 :     my($start, $stop, $contig) = BasicLocation::Parse($loc);
1137 :     # Now we need to do some goofiness to insure that the location is not too
1138 :     # big and that we get some surrounding stuff.
1139 :     my $mid = int(($start + $stop) / 2);
1140 :     my $chunk_len = 20000;
1141 :     my $max_feature = 40000;
1142 :     my $feat_len = abs($stop - $start);
1143 :     if ($feat_len > $chunk_len) {
1144 :     if ($feat_len > $max_feature) {
1145 :     $chunk_len = $max_feature;
1146 :     } else {
1147 :     $chunk_len = $feat_len + 100;
1148 :     }
1149 :     }
1150 :     my($show_start, $show_stop);
1151 :     if ($chunk_len == $max_feature) {
1152 :     $show_start = $start - 300;
1153 :     } else {
1154 :     $show_start = $mid - int($chunk_len / 2);
1155 :     }
1156 :     if ($show_start < 1) {
1157 :     $show_start = 1;
1158 :     }
1159 :     $show_stop = $show_start + $chunk_len - 1;
1160 :     my $clen = $sprout->ContigLength($contig);
1161 :     if ($show_stop > $clen) {
1162 :     $show_stop = $clen;
1163 :     }
1164 :     my $seg_id = $contig;
1165 :     $seg_id =~ s/:/--/g;
1166 :     # Assemble all the pieces.
1167 :     $retVal = "gbrowse.cgi/GB_$genomeID?ref=$seg_id&start=$show_start&stop=$show_stop";
1168 :     }
1169 :     # Return the result.
1170 :     return $retVal;
1171 :     }
1172 :    
1173 :     =head2 Feature Column Methods
1174 :    
1175 :     The methods in this column manage feature column data. If you want to provide the
1176 :     capability to include new types of data in feature columns, then all the changes
1177 :     are made to this section of the source file. Technically, this should be implemented
1178 :     using object-oriented methods, but this is simpler for non-programmers to maintain.
1179 :     To add a new column of feature data, you must first give it a name. For example,
1180 :     the name for the protein page link column is C<protlink>. If the column is to appear
1181 :     in the default list of feature columns, add it to the list returned by
1182 :     L</DefaultFeatureColumns>. Then add code to produce the column title to
1183 :     L</FeatureColumnTitle> and code to produce its value to L</FeatureColumnValue>, and
1184 :     everything else will happen automatically.
1185 :    
1186 :     There is one special column name syntax for extra columns (that is, nonstandard
1187 :     feature columns). If the column name begins with C<X=>, then it is presumed to be
1188 :     an extra column. The column title is the text after the C<X=>, and its value is
1189 :     pulled from the extra column hash.
1190 :    
1191 :     =head3 DefaultFeatureColumns
1192 :    
1193 :     C<< my $colNames = $shelp->DefaultFeatureColumns(); >>
1194 :    
1195 :     Return a reference to a list of the default feature column identifiers. These
1196 :     identifiers can be passed to L</FeatureColumnTitle> and L</FeatureColumnValue> in
1197 :     order to produce the column titles and row values.
1198 :    
1199 :     =cut
1200 :    
1201 :     sub DefaultFeatureColumns {
1202 :     # Get the parameters.
1203 :     my ($self) = @_;
1204 :     # Return the result.
1205 :     return ['orgName', 'function', 'gblink', 'protlink'];
1206 :     }
1207 :    
1208 :     =head3 FeatureColumnTitle
1209 :    
1210 :     C<< my $title = $shelp->FeatureColumnTitle($colName); >>
1211 :    
1212 :     Return the column heading title to be used for the specified feature column.
1213 :    
1214 :     =over 4
1215 :    
1216 :     =item name
1217 :    
1218 :     Name of the desired feature column.
1219 :    
1220 :     =item RETURN
1221 :    
1222 :     Returns the title to be used as the column header for the named feature column.
1223 :    
1224 :     =back
1225 :    
1226 :     =cut
1227 :    
1228 :     sub FeatureColumnTitle {
1229 :     # Get the parameters.
1230 :     my ($self, $colName) = @_;
1231 :     # Declare the return variable. We default to a blank column name.
1232 :     my $retVal = "&nbsp;";
1233 :     # Process the column name.
1234 :     if ($colName =~ /^X=(.+)$/) {
1235 :     # Here we have an extra column.
1236 :     $retVal = $1;
1237 :     } elsif ($colName eq 'orgName') {
1238 :     $retVal = "Name";
1239 :     } elsif ($colName eq 'fid') {
1240 :     $retVal = "FIG ID";
1241 :     } elsif ($colName eq 'alias') {
1242 :     $retVal = "External Aliases";
1243 :     } elsif ($colName eq 'function') {
1244 :     $retVal = "Functional Assignment";
1245 :     } elsif ($colName eq 'gblink') {
1246 :     $retVal = "GBrowse";
1247 :     } elsif ($colName eq 'protlink') {
1248 :     $retVal = "NMPDR Protein Page";
1249 :     } elsif ($colName eq 'group') {
1250 :     $retVal = "NMDPR Group";
1251 :     }
1252 :     # Return the result.
1253 :     return $retVal;
1254 :     }
1255 :    
1256 :     =head3 FeatureColumnValue
1257 :    
1258 :     C<< my $value = $shelp->FeatureColumnValue($colName, $fid, \%extraCols); >>
1259 :    
1260 :     Return the value to be displayed in the specified feature column.
1261 :    
1262 :     =over 4
1263 :    
1264 :     =item colName
1265 :    
1266 :     Name of the column to be displayed.
1267 :    
1268 :     =item record
1269 :    
1270 :     DBObject record for the feature being displayed in the current row.
1271 :    
1272 :     =item extraCols
1273 :    
1274 :     Reference to a hash of extra column names to values. If the incoming column name
1275 :     begins with C<X=>, its value will be taken from this hash.
1276 :    
1277 :     =item RETURN
1278 :    
1279 :     Returns the HTML to be displayed in the named column for the specified feature.
1280 :    
1281 :     =back
1282 :    
1283 :     =cut
1284 :    
1285 :     sub FeatureColumnValue {
1286 :     # Get the parameters.
1287 :     my ($self, $colName, $record, $extraCols) = @_;
1288 :     # Get the sprout and CGI objects.
1289 :     my $cgi = $self->Q();
1290 :     my $sprout = $self->DB();
1291 :     # Get the feature ID.
1292 :     my ($fid) = $record->Value('Feature(id)');
1293 :     # Declare the return variable. Denote that we default to a non-breaking space,
1294 :     # which will translate to an empty table cell (rather than a table cell with no
1295 :     # interior, which is what you get for a null string).
1296 :     my $retVal = "&nbsp;";
1297 :     # Process according to the column name.
1298 :     if ($colName =~ /^X=(.+)$/) {
1299 :     # Here we have an extra column. Only update if the value exists. Note that
1300 :     # a value of C<undef> is treated as a non-existent value, because the
1301 :     # caller may have put "colName => undef" in the "PutFeature" call in order
1302 :     # to insure we know the extra column exists.
1303 :     if (defined $extraCols->{$1}) {
1304 :     $retVal = $extraCols->{$1};
1305 :     }
1306 :     } elsif ($colName eq 'orgName') {
1307 :     # Here we want the formatted organism name and feature number.
1308 :     $retVal = $self->FeatureName($fid);
1309 :     } elsif ($colName eq 'fid') {
1310 :     # Here we have the raw feature ID. We hyperlink it to the protein page.
1311 :     $retVal = HTML::set_prot_links($fid);
1312 :     } elsif ($colName eq 'alias') {
1313 :     # In this case, the user wants a list of external aliases for the feature.
1314 :     # The complicated part is we have to hyperlink them. First, get the
1315 :     # aliases.
1316 :     my @aliases = $sprout->FeatureAliases($fid);
1317 :     # Only proceed if we found some.
1318 :     if (@aliases) {
1319 :     # Join the aliases into a comma-delimited list.
1320 :     my $aliasList = join(", ", @aliases);
1321 :     # Ask the HTML processor to hyperlink them.
1322 :     $retVal = HTML::set_prot_links($aliasList);
1323 :     }
1324 :     } elsif ($colName eq 'function') {
1325 :     # The functional assignment is just a matter of getting some text.
1326 :     ($retVal) = $record->Value('Feature(assignment)');
1327 :     } elsif ($colName eq 'gblink') {
1328 :     # Here we want a link to the GBrowse page using the official GBrowse button.
1329 :     my $gurl = "GetGBrowse.cgi?fid=$fid";
1330 :     $retVal = $cgi->a({ href => $gurl, title => "GBrowse for $fid" },
1331 :     $cgi->img({ src => "../images/button-gbrowse.png",
1332 :     border => 0 })
1333 :     );
1334 :     } elsif ($colName eq 'protlink') {
1335 :     # Here we want a link to the protein page using the official NMPDR button.
1336 :     my $hurl = HTML::fid_link($cgi, $fid, 0, 1);
1337 :     $retVal = $cgi->a({ href => $hurl, title => "Protein page for $fid" },
1338 :     $cgi->img({ src => "../images/button-nmpdr.png",
1339 :     border => 0 })
1340 :     );
1341 :     } elsif ($colName eq 'group') {
1342 :     # Get the NMPDR group name.
1343 :     my (undef, $group) = $self->OrganismData($fid);
1344 :     # Dress it with a URL to the group's main page.
1345 :     my $nurl = $sprout->GroupPageName($group);
1346 :     $retVal = $cgi->a({ href => $nurl, title => "$group summary" },
1347 :     $group);
1348 :     }
1349 :     # Return the result.
1350 :     return $retVal;
1351 :     }
1352 :    
1353 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3