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

Diff of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.48, Fri Jul 22 21:39:19 2005 UTC revision 1.64, Sat Oct 8 14:14:47 2005 UTC
# Line 1  Line 1 
1  package HTML;  package HTML;
2    
3    use Tracer;
4  use FIG;  use FIG;
5  use Carp;  use Carp;
6  use Data::Dumper;  use Data::Dumper;
# Line 10  Line 11 
11  use HTTP::Request::Common;  use HTTP::Request::Common;
12  use POSIX;  use POSIX;
13    
14    
15  sub new  sub new
16  {  {
17      my($class) = @_;      my($class) = @_;
# Line 63  Line 65 
65          for $_ (@html_hdr)          for $_ (@html_hdr)
66          {          {
67              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;              s,(href|img\s+src)="/FIG/,\1="$FIG_Config::cgi_base,g;
68                s,(\?user\=)\",$1$user",;
69              if ($_ eq "<!-- HEADER_INSERT -->\n")              if ($_ eq "<!-- HEADER_INSERT -->\n")
70              {              {
71                  $_ = $insert_stuff;                  $_ = $insert_stuff;
# Line 76  Line 79 
79  sub show_page {  sub show_page {
80      #warn "SHOWPAGE: cgi=", Dumper(@_);      #warn "SHOWPAGE: cgi=", Dumper(@_);
81      shift if UNIVERSAL::isa($_[0],__PACKAGE__);      shift if UNIVERSAL::isa($_[0],__PACKAGE__);
82      my($cgi,$html,$no_home, $alt_header, $css, $javasrc) = @_;      my($cgi,$html,$no_home, $alt_header, $css, $javasrc, $cookie) = @_;
83      my $i;      my $i;
84    
85      # ARGUMENTS:      # ARGUMENTS:
# Line 88  Line 91 
91      #               the sheet named "Default" is considered to be the default style sheet, and if this is not set it points at $FIG_Config::HTML/css/default.css      #               the sheet named "Default" is considered to be the default style sheet, and if this is not set it points at $FIG_Config::HTML/css/default.css
92      #               the sheet named "Sans Serif" is considered to the the first alternate, and if this is not set it points at $FIG_Config::HTML/css/sanserif.css      #               the sheet named "Sans Serif" is considered to the the first alternate, and if this is not set it points at $FIG_Config::HTML/css/sanserif.css
93      #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")      #     $javasrc is a reference to an array of URLs to javascripts to be included (e.g. "/FIG/Html/css/styleswitcher.js")
94        #     $cookie is the name and value of the cookie to set. Note that you should probably use raelib->cookie to get/set your cookies
95      #      #
96      # Find the HTML header      # Find the HTML header
97      #      #
# Line 109  Line 113 
113          @html_hdr = compute_html_header(undef,$user);          @html_hdr = compute_html_header(undef,$user);
114      }      }
115    
116        # RAE: I am offloading the handling of cookies to CGI.pm since I don't know how they are set up.
117        # This modification adds the cookies if necessary
118    
119        # Note: 3/10/05 commented this line out pending the discussion of adding cookies into the seed that we are waiting to see about
120        # to add cookies back in replace these two header lines with each other
121    
122      print $cgi->header;      #print $cgi->header(-cookie=>$cookie);
123        print $cgi->header();
124    
125      #      #
126      #  The SEED header file goes immediately after <BODY>.  Figure out      #  The SEED header file goes immediately after <BODY>.  Figure out
# Line 128  Line 138 
138                       meta     => 1,                       meta     => 1,
139                       nextid   => 1,                       nextid   => 1,
140                       style    => 1,                       style    => 1,
141                       title    => 1                       title    => 1,
142                     );                     );
143    
144      #      #
# Line 270  Line 280 
280    
281      if (!$css || !$css->{'Default'})      if (!$css || !$css->{'Default'})
282      {      {
283         $css->{'Default'}=$FIG_Config::cgi_url."/Html/css/default.css";         $css->{'Default'} = &FIG::cgi_url() . "/Html/css/default.css";
284      }      }
285      if (!$css->{"Sans Serif"})      if (!$css->{"Sans Serif"})
286      {      {
287         $css->{'Sans Serif'}=$FIG_Config::cgi_url."/Html/css/sanserif.css";         $css->{'Sans Serif'} = &FIG::cgi_url() . "/Html/css/sanserif.css";
288      }      }
289    
290      my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";      my $csstext = "<link rel='stylesheet' title='default' href='".$css->{'Default'}."' type='text/css'>\n";
291      $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";      $csstext   .= "<link rel='alternate stylesheet' title='Sans Serif' href='".$css->{'Sans Serif'}."' type='text/css'>\n";
292    
# Line 285  Line 296 
296         $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";         $csstext .= "<link rel='alternate stylesheet' title='$k' href='".$css->{$k}."' type='text/css'>\n";
297      }      }
298    
299        $csstext   .= "<link rel='alternate'  title='SEED RSS feeds' href='".&FIG::cgi_url()."/Html/rss/SEED.rss' type='application/rss+xml'>\n";
300    
301      # RAE: also added support for external javascripts here.      # RAE: also added support for external javascripts here.
302      # we are cluttering the HTML code with all the javascripts when they could easily be in external files      # we are cluttering the HTML code with all the javascripts when they could easily be in external files
# Line 294  Line 306 
306      # it will reduce our overhead.      # it will reduce our overhead.
307    
308      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts      # $javasrc must be a ref to an array with urls (absolute or relative) to the javascripts
309      push @$javasrc, $FIG_Config::cgi_url."/Html/css/FIG.js";      push @$javasrc, &FIG::cgi_url() . "/Html/css/FIG.js";
310      foreach my $script (@$javasrc) {      foreach my $script (@$javasrc) {
311       $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";       $csstext .= "<script src=\"$script\" type=\"text/javascript\"></script>\n";
312      }      }
# Line 328  Line 340 
340  #       }  #       }
341    
342          $base_line = $head_end_line;          $base_line = $head_end_line;
343          splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );          #
344            # RDO 2005-1006. Remove this so proxying works better.
345            #
346    #        splice( @$html, $base_line, 0, "<BASE href=\"$base_url/\">\n" );
347      }      }
348    
349      #      #
# Line 378  Line 393 
393      #  Figure out where to insert The SEED tail.  Before </body>,      #  Figure out where to insert The SEED tail.  Before </body>,
394      #  or before </html>, or at end of page.      #  or before </html>, or at end of page.
395      #      #
   
396      my @tags = ();      my @tags = ();
397        # Check for a tracing queue.
398        my $traceString = QTrace("HTML");
399        if ($traceString) {
400            push @tags, $traceString;
401        }
402      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}      for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
403      if ($i >= @$html)        # </body> not found; look for </html>      if ($i >= @$html)        # </body> not found; look for </html>
404      {      {
# Line 415  Line 433 
433      {      {
434          print $_;          print $_;
435      }      }
436    
437  }  }
438    
439  sub make_table {  sub make_table {
# Line 422  Line 441 
441      my(@tab);      my(@tab);
442    
443      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";      my $border = defined $options{border} ? "border=\"$options{border}\"" : "border";
444      push( @tab, "\n<table $border>\n",      my $width = defined $options{width} ? "width=\"$options{width}\"" : undef;
445        push( @tab, "\n<table $border $width>\n",
446                  "\t<caption><b>$title</b></caption>\n",                  "\t<caption><b>$title</b></caption>\n",
447                  "\t<tr>\n\t\t"                  "\t<tr>\n\t\t"
448                . join( "\n", map { &expand($_, "th") } @$col_hdrs )                . join( "\n", map { &expand($_, "th") } @$col_hdrs )
# Line 468  Line 488 
488  }  }
489    
490    
491    =head2 merge_table_rows()
492    
493    Merge table rows together. This will merge a table so that adjacent cells with the same content will only be shown once.
494    
495    Something like this:
496    
497        -----------------------
498        |    1     |    a     |
499        -----------------------
500        |    1     |    b     |
501        -----------------------
502        |    2     |    c     |
503        -----------------------
504        |    3     |    d     |
505        -----------------------
506        |    4     |    d     |
507        -----------------------
508        |    5     |    d     |
509        -----------------------
510    
511    Will become:
512    
513        -----------------------
514        |          |    a     |
515        |    1     |-----------
516        |          |    b     |
517        -----------------------
518        |    2     |    c     |
519        -----------------------
520        |    3     |          |
521        ------------          |
522        |    4     |    5     |
523        ------------          |
524        |    5     |          |
525        -----------------------
526    
527    
528    The method takes two arguments. The reference to the array that is the table ($tab). This is the standard table that is created for HTML.pm to draw, and a reference to a hash of columns that you don't want to merge together. The reference to the hash is optional, and if not included, everything will be merged.
529    
530     $tab=&HTML::merge_table_rows($tab);
531    
532     or
533    
534     $skip=(1=>1, 3=>1, 5=>1);
535     $tab=&HTML::merge_table_rows($tab, $skip);  # will merge all columns except 1, 3 and 5. Note the first column in the table is #0
536    
537    
538    =cut
539    
540    
541    
542    
543  sub merge_table_rows {  sub merge_table_rows {
544   # RAE:   # RAE:
545   # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer   # Experimental piece of code. We often want to have rows or columns were cells are merged. It just looks so much nicer
# Line 477  Line 549 
549   # before you do a make_table call   # before you do a make_table call
550    
551   my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);   my $self=shift if UNIVERSAL::isa($_[0],__PACKAGE__);
552   my ($tab)=@_;   my ($tab, $skip)=@_;
553    
554   my $newtable;   my $newtable;
555   my $lastrow;   my $lastrow;
# Line 487  Line 559 
559   for (my $y=0; $y <= $#$tab; $y++) {   for (my $y=0; $y <= $#$tab; $y++) {
560   #$y is the row in the table;   #$y is the row in the table;
561    for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {    for (my $x=0; $x <= $#{$tab->[$y]}; $x++) {
562       # this is the user definable columns not to merge
563       if ($skip->{$x})
564       {
565        $newtable->[$y]->[$x] = $tab->[$y]->[$x];
566        next;
567       }
568    
569     #$x is the column in the table     #$x is the column in the table
570     # if the column in the row we are looking at is the same as the column in the previous row, we don't add     # if the column in the row we are looking at is the same as the column in the previous row, we don't add
571     # this cell to $newtable. Instead we increment the rowspan of the previous row by one     # this cell to $newtable. Instead we increment the rowspan of the previous row by one
# Line 496  Line 575 
575    
576     # now we go back through the table looking where to draw the merge line:     # now we go back through the table looking where to draw the merge line:
577     my $lasty=$y;     my $lasty=$y;
578     while ($tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}     while ($lasty >= 0 && $tab->[$y]->[$x] eq $tab->[$lasty]->[$x]) {$lasty--}
579     $lasty++; # this is the last identical cell. If lasty==y it is the current cell, so we just save the data. Otherwise we increment the rowspan     $lasty++; # this is the last identical cell. If lasty==y it is the current cell, so we just save the data. Otherwise we increment the rowspan
580     if ($lasty == $y) {     if ($lasty == $y) {
581      # we always want to have something in rows that may otherwise be empty but should be there (see below)      # we always want to have something in rows that may otherwise be empty but should be there (see below)
# Line 608  Line 687 
687          {          {
688              $n = $fid;              $n = $fid;
689          }          }
690          if ($1 ne "peg") { return $n }  
691            my $link;
692            #added to format prophage and path island links to feature.cgi
693            if ($1 ne "peg")
694            {
695               my $user = $cgi->param('user');
696               if (! $user) { $user = "" }
697               my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
698               $link = &FIG::cgi_url . "/feature.cgi?feature=$fid&user=$user$trans$sprout";
699               $link =~ s/[a-z_A-Z0-9]+\.cgi\?/feature.cgi?/;
700            }
701            else
702            {
703          my $user = $cgi->param('user');          my $user = $cgi->param('user');
704          if (! $user) { $user = "" }          if (! $user) { $user = "" }
705          my $trans = $cgi->param('translate') ? "&translate=1" : "";          my $trans = $cgi->param('translate') ? "&translate=1" : "";
706          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";          my $sprout = $cgi->param('SPROUT') ? "&SPROUT=1" : "";
707          my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";  ###a
708    
709    ### This used to be
710    ###     my $link = &FIG::cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
711    ###
712    ### The cost became prohibitive in the subsystem spreadsheets.  Hence, we cache the value
713    ###
714    ### RAO
715    
716                #if (! $cgi_url) { $cgi_url = &FIG::cgi_url }
717                #$link = $cgi_url . "/protein.cgi?prot=$fid&user=$user$trans$sprout";
718                $link = "protein.cgi?prot=$fid&user=$user$trans$sprout";
719          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;          $link =~ s/[a-z_A-Z0-9]+\.cgi\?/protein.cgi?/;
720          #          #
721          # Elimin the p2p part if we're in that subdir. Ugh.          # Elimin the p2p part if we're in that subdir. Ugh.
722          #          #
723          $link =~ s,p2p/protein.cgi,protein.cgi,;          $link =~ s,p2p/protein.cgi,protein.cgi,;
724            }
725          if ($just_url)          if ($just_url)
726          {          {
727              return $link;              return $link;
# Line 907  Line 1009 
1009      $user = $cgi->param('user');      $user = $cgi->param('user');
1010      $user = $user ? $user : "";      $user = $user ? $user : "";
1011      $org = $org ? $org : "";      $org = $org ? $org : "";
1012      my $url = "$FIG_Config::cgi_url/show_kegg_map.cgi?user=$user&map=$map&org=$org";  
1013        my $url = "show_kegg_map.cgi?user=$user&map=$map&org=$org";
1014    #rel    my $url = &FIG::cgi_url() . "/show_kegg_map.cgi?user=$user&map=$map&org=$org";
1015      my $link = "<a href=\"$url\">$map</a>";      my $link = "<a href=\"$url\">$map</a>";
1016      return $link;      return $link;
1017  }  }
# Line 946  Line 1050 
1050      return $sub_link;      return $sub_link;
1051  }  }
1052    
1053  1  sub reaction_link {
1054        my($reaction) = @_;
1055    
1056        if ($reaction =~ /^R\d+/)
1057        {
1058            return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?rn+$reaction\" target=reaction$$>$reaction</a>";
1059        }
1060        return $reaction;
1061    }
1062    
1063    sub html_for_assignments {
1064        my($fig,$user,$peg_sets) = @_;
1065        my $i;
1066    
1067        my @vals = ();
1068        my $set = 1;
1069        foreach $peg_set (@$peg_sets)
1070        {
1071            for ($i=0; ($i < @$peg_set); $i++)
1072            {
1073                $peg = $peg_set->[$i];
1074                push(@vals,'show=' . join("@",($set,$i+1,$peg,&FIG::abbrev($fig->org_of($peg)),"")));
1075            }
1076            $set++;
1077        }
1078    
1079        $ENV{'REQUEST_METHOD'} = 'GET';
1080        $ENV{'QUERY_STRING'} = join('&',('request=show_commentary',"uni=1","user=$user",@vals));
1081        my $out = join("",`$FIG_Config::fig/CGI/chromosomal_clusters.cgi`);
1082        $out =~ s/^.*?<form/<form/si;
1083        $out =~ s/^(.*)<table.*/$1/si;
1084        return $out;
1085    }
1086    
1087    =head1 rss_feed
1088    
1089    Add something to the RSS feed. The rss feeds are stored in the Html directory, and there are several RSS feeds:
1090            SEED.rss                - everything gets written here
1091            SEEDgenomes.rss                 - whenever a genome is added to the SEED
1092            SEEDsubsystems.rss      - whenever a subsystem is edited (or should this be added?)
1093    
1094    
1095    RSS feeds must contain a title, description, and link. The title is what is seen e.g. from the firefox or safari pull down menu. The description is seen from within an rss aggregator, and may be displayed on web pages and so on.
1096    
1097    The method takes a reference to an array containing the file names for the RSS feeds to add your item to, and a hash of items for the xml. Only title, description, and link are required tags in the XML.
1098    
1099    The file names are the full name of the file, eg SEEDsubsystems.rss, SEEDgenomes.rss. Be aware that this is a file name, though, so don't uses special characters. The path will be added.
1100    
1101    The has can have these keys:
1102    
1103    REQUIRED:
1104    title       : the title. This is usually what is seen by the user in the pull down menu
1105    description : a more complete description that is often seen is rss viewers but not always
1106    link        : link to the item that was added/edited
1107    All other keys are treated as optional RSS arguments and written to the file. At most, 10 recent entries are stored in the rss file.
1108    
1109    RSS files are quite simple, and contain some standard header information, and then individual items surrounded by an <item> </item> tag. Note that there is also an initial title/description/link set that describes the file.
1110    
1111    
1112    =cut
1113    
1114    sub rss_feed {
1115     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
1116     my ($files, $args)=@_;
1117     foreach my $a (keys %$args) {if ($a =~ /^-(.*)/) {my $b=$1; $args->{$b}=$args->{$a}; delete $args->{$a}}}
1118    
1119     my $filepath=$FIG_Config::fig."/CGI/Html/rss";
1120     # check for the directory and if not, make it
1121     mkdir $filepath unless (-d $filepath);
1122    
1123     # note that $info is a hash of references to hashes that are written out as headers in the file
1124     my $info=
1125     {
1126      "SEED.rss" =>
1127       {
1128            title           => "The SEED",
1129            description     => "Latest news from the SEED",
1130            link            => &FIG::cgi_url()."/Html/rss/SEED.rss",
1131       },
1132    
1133      "SEEDsubsystems.rss" =>
1134      {
1135            title           => "SEED Subsystems",
1136            description     => "Recently updated SEED subsystems",
1137            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1138      },
1139    
1140      "SEEDsubsystems.rss" =>
1141      {
1142            title           => "SEED Genomes",
1143            description     => "Genomes recently added to the SEED",
1144            link            => &FIG::cgi_url()."/Html/rss/SEEDsubsystems.rss",
1145      },
1146    
1147     };
1148    
1149    
1150     # build the new xml
1151     my $xml = "\t<item>\n";
1152     foreach my $qw ("title", "description", "link") {
1153      unless ($args->{$qw}) {
1154       print STDERR "You need to include a $qw tag in your RSS description\n";
1155       return(0);
1156      }
1157      # we need to do something a bit funky with the link. We can't have ampersands in the <link> </link> in valid html
1158      # so we are going to pull out the links and uri_escape just the part after the .cgi
1159      if ($qw eq "link")
1160      {
1161       $args->{$qw} =~ /^(.*?\.cgi.)(.*)$/;
1162       print STDERR "Got ->>$1<<- and ->>$2<<-\n";
1163       $args->{$qw} = $1.uri_escape($2) if ($1 && $2);
1164      }
1165    
1166      $xml .= "\t\t<$qw>".$args->{$qw}."</$qw>\n";
1167      delete $args->{$qw};
1168     }
1169    
1170     foreach my $tag (grep {!/type/i} keys %$args)
1171     {
1172      $xml .= "\t\t<$tag>".$args->{$tag}."</$tag>\n";
1173     }
1174    
1175     $xml .= "\t</item>\n";
1176    
1177    
1178     my @files=("SEED.rss");
1179     if ($args->{"type"}) {push @files, "SEED.$type.rss"}
1180    
1181     foreach my $file ("SEED.rss", @$files)
1182     {
1183      if (-e "$filepath/$file")
1184      {
1185       my @out; # the new content of the file
1186       my $itemcount=0; # how many <item> </item>'s are we keeping
1187       my $initem; # are we in an item?
1188       open(IN, "$filepath/$file") || die "Can't open $filepath/$file";
1189       while (<IN>)
1190       {
1191        if (/\<item\>/) {
1192         push @out, $xml, unless ($itemcount);
1193         $itemcount++;
1194         $initem=1;
1195        }
1196        if (/\<\/item\>/) {$initem=0; next if ($itemcount > 9)}
1197        next if ($initem && $itemcount > 9);
1198        push @out, $_;
1199       }
1200       close IN;
1201       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1202       print OUT @out;
1203      }
1204      else
1205      {
1206       open(OUT, ">$filepath/$file") || die "Can't open $filepath/$file for writing";
1207       print OUT "<?xml version=\"1.0\"?>\n<rss version=\"2.0\">\n<channel>\n";
1208       if ($info->{$file})
1209       {
1210         # we're going to sanity check each of the three options we output, just to be sure
1211         foreach my $qw ("title", "description", "link")
1212         {
1213           if ($info->{$file}->{$qw})
1214           {
1215              print OUT "<$qw>", $info->{$file}->{$qw}, "</$qw>\n";
1216           } else {
1217              print STDERR "Please add a $qw for $file\n"; print OUT "<$qw>$file</$qw>\n";
1218           }
1219         }
1220       }
1221       else {
1222        print STDERR "Please define title, link, and description information for $file\n";
1223        print OUT "<title>$file</title>\n<description>An RSS feed</description>\n<link>", &FIG::cgi_url, "</link>\n";
1224       }
1225       print OUT "\n", $xml;
1226       print OUT "\n", "</channel>\n</rss>\n"
1227      }
1228     }
1229    }
1230    
1231    
1232    
1233    1;
1234    

Legend:
Removed from v.1.48  
changed lines
  Added in v.1.64

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3