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

Annotation of /FigKernelPackages/HTML.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : efrank 1.1 package HTML;
2 :    
3 :     use Carp;
4 :     use Data::Dumper;
5 :     use LWP::UserAgent;
6 :     use LWP::Simple;
7 :     use URI::URL;
8 :     use HTTP::Request::Common;
9 :    
10 :     sub show_page {
11 :     my($cgi,$html,$no_home) = @_;
12 :     my $i;
13 :    
14 : olson 1.2 #
15 :     # Find the HTML header
16 :     #
17 :    
18 :     my $html_hdr_file = "./Html/html.hdr";
19 :     if (! -f $html_hdr_file)
20 :     {
21 :     $html_hdr_file = "$FIG_Config::fig/CGI/Html/html.hdr";
22 :     }
23 :    
24 :     my $html_tail_file = "./Html/html.tail";
25 :     if (! -f $html_tail_file)
26 :     {
27 :     $html_tail_file = "$FIG_Config::fig/CGI/Html/html.tail";
28 :     }
29 :    
30 :    
31 : efrank 1.1 print $cgi->header;
32 :     print "<base href=\"" . &FIG::cgi_url . "/\">\n";
33 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<body\>/i); $i++) {}
34 :     if ($i < @$html)
35 :     {
36 : olson 1.2 splice(@$html,$i+1,0,`cat $html_hdr_file`);
37 : efrank 1.1 }
38 :     else
39 :     {
40 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<html\>/i); $i++) {}
41 :     if ($i < @$html)
42 :     {
43 : olson 1.2 splice(@$html,$i+1,0,`cat $html_hdr_file`);
44 : efrank 1.1 }
45 :     else
46 :     {
47 : olson 1.2 splice(@$html,0,0,`cat $html_hdr_file`);
48 : efrank 1.1 }
49 :     }
50 :    
51 : olson 1.2 @tail = `cat $html_tail_file`;
52 : efrank 1.1 if (! $no_home)
53 :     {
54 :     my $user = $cgi->param('user');
55 :     $user = $user ? $user : "";
56 :     my $link = $cgi->url();
57 :     $link =~ s/[a-zA-Z_]+\.cgi$/index.cgi/;
58 :     push(@tail,"<hr><a href=\"$link?user=$user\">FIG search</a>\n");
59 :     }
60 :    
61 :     if (@tail > 0)
62 :     {
63 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/body\>/i); $i++) {}
64 :     if ($i < @$html)
65 :     {
66 :     splice(@$html,$i,0,@tail);
67 :     }
68 :     else
69 :     {
70 :     for ($i=0; ($i < @$html) && ($html->[$i] !~ /\<\/html\>/i); $i++) {}
71 :     if ($i < @$html)
72 :     {
73 :     splice(@$html,$i,0,@tail);
74 :     }
75 :     else
76 :     {
77 :     push(@$html,@tail);
78 :     }
79 :     }
80 :     }
81 :     print @$html;
82 :     }
83 :    
84 :     sub make_table {
85 :     my($col_hdrs,$tab,$title,$instr) = @_;
86 :     my(@tab);
87 :    
88 :     push(@tab,"<table border><caption><b>$title</b></caption>\n");
89 :     push(@tab,"<tr><th>" . join("</th><th>",@$col_hdrs) . "</th></tr>\n");
90 :     my($i,$nowrap);
91 :    
92 :     for ($i=0; ($i < @$instr) && ($instr->[$i] !~ /nowrap/); $i++) {}
93 :     $nowrap = ($i == @$instr) ? "" : " nowrap";
94 :    
95 : overbeek 1.3 my $row;
96 :     foreach $row (@$tab)
97 : efrank 1.1 {
98 : overbeek 1.3 push(@tab,"<tr><td$nowrap>" . join("</td>",map { &expand($_) } @$row) . "</td></tr>\n");
99 : efrank 1.1 }
100 :     push(@tab,"</table>\n");
101 :     return join("",@tab);
102 :     }
103 :    
104 : overbeek 1.3 sub expand {
105 :     my($x) = @_;
106 :    
107 :     if ($x =~ /^\@([^:]+)\:([^:]+)\:(.*)$/)
108 :     {
109 :     return "<td$nowrap $1=\"$2\">$3";
110 :     }
111 :     else
112 :     {
113 :     return "<td$nowrap>$x";
114 :     }
115 :     }
116 :    
117 : efrank 1.1 sub ec_link {
118 :     my($role) = @_;
119 :    
120 :     if ($role =~ /(\d+\.\d+\.\d+\.\d+)/)
121 :     {
122 :     return "<a href=\"http://www.genome.ad.jp/dbget-bin/www_bget?ec:$1\">$role</a>";
123 :     }
124 :     else
125 :     {
126 :     return $role;
127 :     }
128 :     }
129 :    
130 :     sub role_link {
131 :     my($cgi,$role) = @_;
132 :    
133 :     my $roleR = ($role =~ /^(\d+\.\d+\.\d+\.\d+)\s+-\s+/) ? $1 : $role;
134 :     my $user = $cgi->param('user');
135 :     if (! $user) { $user = "" }
136 :     my $link = $cgi->url() . "?role=$roleR&user=$user";
137 :     $link =~ s/[a-z]+\.cgi\?/pom.cgi?/;
138 :     return "<a href=$link>$role</a>";
139 :     }
140 :    
141 :     sub fid_link {
142 :     my($cgi,$fid,$local,$just_url) = @_;
143 :     my($n);
144 :    
145 :     if ($fid =~ /^fig\|\d+\.\d+\.([a-z]+)\.(\d+)/)
146 :     {
147 :     if ($local)
148 :     {
149 :     if ($1 eq "peg")
150 :     {
151 :     $n = $2;
152 :     }
153 :     else
154 :     {
155 :     $n = "$1.$2";
156 :     }
157 :     }
158 :     else
159 :     {
160 :     $n = $fid;
161 :     }
162 :     if ($1 ne "peg") { return $n }
163 :     my $user = $cgi->param('user');
164 :     if (! $user) { $user = "" }
165 :     my $trans = $cgi->param('translate') ? "&translate=1" : "";
166 :     my $link = $cgi->url() . "?prot=$fid&user=$user$trans";
167 :     $link =~ s/[a-z_A-Z]+\.cgi\?/protein.cgi?/;
168 :     if ($just_url)
169 :     {
170 :     return $link;
171 :     }
172 :     else
173 :     {
174 :     return "<a href=$link>$n</a>";
175 :     }
176 :     }
177 :     return $fid;
178 :     }
179 :    
180 :     sub family_link {
181 :     my($family,$user) = @_;
182 :    
183 :     return $family;
184 :     }
185 :    
186 :     use URI::Escape;
187 :    
188 :     sub get_html {
189 :     my( $url, $type, $kv_pairs) = @_;
190 :     my( $encoded, $ua, $args, @args, $out, @output, $x );
191 :    
192 :     $ua = new LWP::UserAgent;
193 :     $ua->timeout( 900 );
194 :    
195 :     if ($type =~/post/i)
196 :     {
197 :     $args = [];
198 :     foreach $x (@$kv_pairs)
199 :     {
200 :     push(@$args, ( $x->[0], $x->[1]) );
201 :     }
202 :     my $request = POST $url, $args;
203 :     my $response = $ua->request($request);
204 :     $out = $response->content;
205 :     }
206 :     else
207 :     {
208 :     @args = ();
209 :     foreach $x (@$kv_pairs)
210 :     {
211 :     push( @args, "$x->[0]=" . uri_escape($x->[1]) );
212 :     }
213 :    
214 :     if (@args > 0)
215 :     {
216 :     $url .= "?" . join("&",@args);
217 :     }
218 :     $request = new HTTP::Request('GET', $url);
219 :     my $response = $ua->request($request);
220 :    
221 :     if ($response->is_success)
222 :     {
223 :     $out = $response->content;
224 :     }
225 :     else
226 :     {
227 :     $out = "<H1>Error: " . $response->code . "</H1>" . $response->message;
228 :     }
229 :     }
230 :     # set up a document with proper eol characters
231 :     @output = split(/[\012\015]+/,$out);
232 :     foreach $out (@output) { $out .= "\n"; }
233 :    
234 :     # Now splice in a line of the form <base href=URL> to cause all relative links to work
235 :     # properly. Remove the header.
236 :    
237 :     for ($i=0; ($i < @output) && ($output[$i] !~ /^\s*\</); $i++) {}
238 :     if ($i < @output)
239 :     {
240 :    
241 :     splice(@output,0,$i);
242 :     }
243 :    
244 :     for ($i=0; ($i < @output) && ($output[$i] !~ /\<body\>/i); $i++) {}
245 :     if ($i == @output)
246 :     {
247 :     $i = -1;
248 :     }
249 :     splice(@output,$i+1,0,"<base href=\"$url\">\n");
250 :     return @output;
251 :     }
252 :    
253 :     sub trim_output {
254 :     my($out) = @_;
255 :     my $i;
256 :    
257 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /^\</); $i++) {}
258 :     splice(@$out,0,$i);
259 :    
260 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<body\>/i); $i++) {}
261 :     if ($i == @$out)
262 :     {
263 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<html\>/i); $i++) {}
264 :     if ($i == @$out)
265 :     {
266 :     $i = -1;
267 :     }
268 :     }
269 :     for ($j=$i+1; ($j < @$out) && ($out->[$j] !~ /^\<hr\>$/); $j++) {}
270 :     if ($j < @$out)
271 :     {
272 :     splice(@$out,$i+1,($j-$i));
273 :     }
274 :    
275 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/body\>/i); $i++) {}
276 :     if ($i == @$out)
277 :     {
278 :     for ($i=0; ($i < @$out) && ($out->[$i] !~ /\<\/html\>/i); $i++) {}
279 :     }
280 :    
281 :     for ($j=$i-1; ($j > 0) && ($out->[$j] !~ /FIG search/); $j--) {}
282 :     if ($j > 0)
283 :     {
284 : olson 1.2 my @tmp = `cat $html_tail_file`;
285 : efrank 1.1 my $n = @tmp;
286 :     splice(@$out,$j-$n,$n+1);
287 :     }
288 :     }
289 :    
290 :     sub set_prot_links {
291 :     my($cgi,$x) = @_;
292 :     my($before,$match,$after);
293 :    
294 :     if ($x =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
295 :     {
296 :     $before = $1;
297 :     $match = $2;
298 :     $after = $3;
299 :     return &set_prot_links($cgi,$before) . &HTML::fid_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
300 :     }
301 :     elsif ($x =~ /^(.*)(gi\|\d+)(.*)$/)
302 :     {
303 :     $before = $1;
304 :     $match = $2;
305 :     $after = $3;
306 :     return &set_prot_links($cgi,$before) . &HTML::gi_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
307 :     }
308 :     elsif ($x =~ /^(.*)(sp\|[A-Z0-9]{6})(.*)$/)
309 :     {
310 :     $before = $1;
311 :     $match = $2;
312 :     $after = $3;
313 :     return &set_prot_links($cgi,$before) . &HTML::sp_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
314 :     }
315 :     elsif ($x =~ /^(.*)(pirnr\|NF\d+)(.*)$/)
316 :     {
317 :     $before = $1;
318 :     $match = $2;
319 :     $after = $3;
320 :     return &set_prot_links($cgi,$before) . &HTML::pir_link($cgi,$match) . &set_prot_links($cgi,$after) . "\n";
321 :     }
322 :     return $x;
323 :     }
324 :    
325 :     sub gi_link {
326 :     my($cgi,$gi) = @_;
327 :    
328 :     if ($gi =~ /^gi\|(\d+)$/)
329 :     {
330 :     return "<a href=http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Retrieve&db=Protein&list_uids=$1&dopt=GenPept>$gi</a>";
331 :     }
332 :     return $gi;
333 :     }
334 :    
335 :     sub sp_link {
336 :     my($cgi,$sp) = @_;
337 :    
338 :     if ($sp =~ /^sp\|(\S+)$/)
339 :     {
340 :     return "<a href=http://us.expasy.org/cgi-bin/get-sprot-entry?$1>$sp</a>";
341 :     }
342 :     return $sp;
343 :     }
344 :    
345 :     sub pir_link {
346 :     my($cgi,$pir) = @_;
347 :    
348 :     if ($pir =~ /^pirnr\|(NF\d+)$/)
349 :     {
350 :     return "<a href=http://pir.georgetown.edu/cgi-bin/nfEntry.pl?id=$1>$pir</a>";
351 :     }
352 :     return $pir;
353 :     }
354 :    
355 :    
356 :     1

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3