[Bio] / FigKernelScripts / to_org_specific.pl Repository:
ViewVC logotype

Annotation of /FigKernelScripts/to_org_specific.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : hwang 1.1 #!/usr/bin/perl -w
2 :     use lib "/home/khwang/MODULES/FramesReady/lib";
3 :    
4 :     use strict;
5 :     use Data::Dumper;
6 :     use LWP;
7 :     use LWP::UserAgent;
8 :     use HTTP::Request::Common;
9 :     use FIG;
10 :     use HTML;
11 :     use HTML::LinkExtor;
12 :     use URI::URL;
13 :    
14 :     my $fig = new FIG;
15 :     my $user_agent = LWP::UserAgent->new;
16 :     my $usage = "usage: to_jcsg [key1\tvalue1\nkey2\tvalue2]";
17 :     my @arguments_in;
18 :     my @imgs = ();
19 :     my $result;
20 :     my $base;
21 :    
22 :     if (@ARGV > 0)
23 :     {
24 :     @arguments_in = @ARGV;
25 :     }
26 :     else
27 :     {
28 :     die $usage;
29 :     }
30 :    
31 :     my %pairs = ();
32 :    
33 :     foreach (@arguments_in)
34 :     {
35 :     my ($name,$val) = split(/\t/,$_);
36 :     $pairs{$name} = $val;
37 :     }
38 :    
39 :     my @keys = keys %pairs;
40 :    
41 :     my $peg = $pairs{'peg'};
42 :     my $alias_filter = $pairs{'alias'};
43 :     my $url = $pairs{'url'};
44 :     my $comment = $pairs{'comment'};
45 :     my $url_end = $pairs{'url_end'};
46 :    
47 :     $peg =~ s/\%7C/\|/g;
48 :    
49 :     my $seq = $fig->get_translation($peg);
50 :     my @aliases=$fig->feature_aliases($peg);
51 :    
52 :     my @url_id = grep {/.*$alias_filter.*/} @aliases;
53 :    
54 :     #Clean the ids;
55 :    
56 :     my $clean_id = $url_id[0];
57 :     $clean_id=~ s/.*://;
58 : hwang 1.4 $clean_id=~ s/.*\|//;
59 : hwang 1.1 &to_url_by_id($clean_id);
60 :    
61 :    
62 :     ###############
63 :     # Subroutines
64 :     ###############
65 :    
66 :     sub to_url_by_id {
67 :    
68 :     my $id = $_[0];
69 :     if ( $id ne "") {
70 :     my $url_id = $id;
71 :     my $complete_url;
72 :    
73 :     if ($url_end ne "") {
74 :    
75 :     $complete_url = $url.$url_id.$url_end;
76 :     }
77 :     else {
78 :     $complete_url = $url.$url_id;
79 :     }
80 :    
81 :     my $p = HTML::LinkExtor->new(\&callback);
82 :    
83 :     my $response = $user_agent->request(HTTP::Request->new(GET => $complete_url),
84 :     sub {$p->parse($_[0])});
85 :     print "The $complete_url can not be accessed now. <p> "
86 :     unless $response->is_success;
87 :    
88 :     my $response_html = $user_agent->get( $complete_url );
89 :    
90 :     if(! ($response_html->content =~ m/Sorry/i) ) {
91 :    
92 :     $result = $response_html->content;
93 :     $result =~ s/<link rel=.*?>//g;
94 :    
95 :     #Relative urls needs to be changed to absolute urls
96 :     # If LinksToTools specify that the relative link is yes then put all the links in a hash.
97 :     # Key is relative url.
98 :     # Value is absolute url
99 :     $base = $response->base;
100 :    
101 :     if ( $pairs{'rel_links'} eq 'yes') {
102 :    
103 :     &fix_url;
104 :     }
105 :    
106 :     }
107 :    
108 :     print $result;
109 :     exit;
110 :     }
111 :    
112 :     else {
113 :    
114 :     print $comment;
115 :     }
116 :    
117 :     }
118 :    
119 :     sub callback {
120 :     my($tag, %attr) = @_;
121 :     return if $tag ne 'img';
122 :     push(@imgs, values %attr);
123 :     }
124 :    
125 :    
126 :     sub fix_url {
127 :    
128 :     my %url=();
129 :    
130 :     foreach my $rel_url(@imgs) {
131 :     $url{$rel_url} = url($rel_url, $base)->abs;
132 :     }
133 :    
134 :    
135 :     #Replace the relative urls with absolute url
136 :     while ( my ($key, $value) = each %url) {
137 :     $result =~ s/$key/$value/;
138 :     }
139 :    
140 :     #Some links can't be replace with a simple subsitution
141 :     #In LinksToTools, these are the problem links
142 :    
143 :     my @problem_links = split(/\s+/, $pairs{problem_links});
144 :     foreach (@problem_links) {
145 :     $result =~ s/$_/$pairs{problem_links_base}$_/g;
146 :     }
147 :    
148 :     my @home_dir_links = split(/\s+/, $pairs{home_dir});
149 :     foreach (@home_dir_links) {
150 :     my ($dot, $dir) = split(/\//, $_);
151 :     $result =~ s/$_/$pairs{home_dir_base}$dir/g;
152 :    
153 :     }
154 :    
155 :     #Append the base to the links that starts with /
156 :     #Did not put these in LinksToTools because other cases will be incorrectly
157 :     #overwritten
158 :     my $base = $pairs{'base'};
159 :     my @rel_before = split(/\s+/,$pairs{'append_before_base'});
160 :     my @rel_after = split(/\s+/,$pairs{'append_after_base'});
161 :    
162 :    
163 :     foreach (@rel_before) {
164 :     if ($result=~ m/$_/) {
165 :     my $abs = "$_$base";
166 :     $result=~ s/$_/$abs/g;
167 :     }
168 :     }
169 :    
170 :     foreach (@rel_after) {
171 :     if ($result=~ m/$_/) {
172 : hwang 1.2 $_=~ s/\"//g;
173 : hwang 1.1 my $abs = "$base$_";
174 :     $result=~ s/$_/$abs/g;
175 :     }
176 :     }
177 :    
178 :    
179 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3