[Bio] / Clearinghouse / utils.pm Repository:
ViewVC logotype

Annotation of /Clearinghouse/utils.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : olson 1.1
2 :     #
3 :     # Clearinghouse utility functions.
4 :     #
5 :    
6 :     use strict;
7 :     use base 'Exporter';
8 :    
9 : olson 1.3 use IO::Handle;
10 :     use IPC::Open3;
11 : olson 1.7 use FileHandle;
12 : olson 1.2 use HTML;
13 : olson 1.1 use Clearinghouse::ch_database;
14 : olson 1.3 use FIG;
15 :     use FIG_Config;
16 :    
17 :     our $fig;
18 : olson 1.7 our $log_fh;
19 : olson 1.1
20 :     our @EXPORT = qw(check_types
21 : disz 1.5 lock_init
22 :     type_init
23 : olson 1.2 get_lock
24 :     release_lock
25 :     get_page_header
26 : olson 1.3 validate_package
27 : disz 1.4 make_accession
28 :     insert_ch_record
29 :     insert_meta_data
30 :     insert_package_location
31 : disz 1.6 check_for_duplicates
32 : olson 1.7 log
33 : olson 1.8 allocate_feature_id
34 : olson 1.1 );
35 :    
36 : olson 1.7 sub ch_log
37 :     {
38 :     my($str) = @_;
39 :     if (not defined($log_fh))
40 :     {
41 :     &FIG::verify_dir("$FIG_Config::fig/var");
42 :     $log_fh = new FileHandle ">>$FIG_Config::fig/var/clearinghouse.log";
43 :     $log_fh->autoflush(1);
44 :     }
45 :    
46 :     print $log_fh $str;
47 :     }
48 :    
49 : olson 1.3 sub validate_package
50 :     {
51 :     my($pkg, $type) = @_;
52 :    
53 :     my %meta;
54 :    
55 :     my $stdin = new IO::Handle;
56 :     my $stdout = new IO::Handle;
57 :     my $stderr = new IO::Handle;
58 :    
59 :     my $cmd;
60 :    
61 :     if ($type eq "SUBSYSTEM" or $type eq "1-SUBSYSTEM")
62 :     {
63 :     $cmd = "$FIG_Config::bin/validate_subsystem";
64 :     }
65 :     elsif ($type eq "GENOME")
66 :     {
67 :     $cmd = "$FIG_Config::bin/validate_genome_gff";
68 :     }
69 :     else
70 :     {
71 :     die "validate_package: invalid type $type\n";
72 :     }
73 :    
74 :     my $pid = open3($stdin, $stdout, $stderr, "$cmd $pkg");
75 :    
76 :     $pid or die "Cannot run $cmd $pkg: $!";
77 :    
78 :     close($stdin);
79 :    
80 :     my @out = <$stdout>;
81 :    
82 :     my @err = <$stderr>;
83 :    
84 :     close($stdout);
85 :     close($stderr);
86 :    
87 :     waitpid($pid, 0);
88 :    
89 :     if ($?)
90 :     {
91 :     die "Validate failed with exit code $?. Error output:\n@out\n";
92 :     }
93 :    
94 :     foreach $_ (@out)
95 :     {
96 :     chomp;
97 :     my($k, $v) = split(/\t/);
98 :     $meta{$k} = $v;
99 :     }
100 :    
101 :     return %meta;
102 :     }
103 :    
104 : olson 1.2 sub get_page_header
105 :     {
106 :     my @page_header = &HTML::compute_html_header(undef, undef,
107 :     header_name => 'clearinghouse.hdr',
108 :     tail_name => 'clearinghouse.tail',
109 :     no_fig_search => 1,
110 :     no_release_info => 1);
111 :     return join("\n", @page_header);
112 :     }
113 :    
114 : olson 1.1 sub check_types {
115 :     my ($type) = @_;
116 :     my $db = db_init();
117 :    
118 :     my $ar = $db->SQL(qq(SELECT type FROM types WHERE type = '$type'));
119 :     return @$ar; #length = 0, if no rows
120 :     }
121 :    
122 : disz 1.6 sub check_for_duplicates {
123 :     my ($type, $meta_data) = @_;
124 :     my $db = db_init();
125 :     if ($type eq 'GENOME') {
126 :     return check_for_duplicate_genome($meta_data);
127 :     } elsif ($type eq 'SUBSYSTEM') {
128 :     return check_for_duplicate_subsystem($meta_data);
129 :     } else {
130 :     return 1;
131 :     }
132 :     }
133 :    
134 :     sub check_for_duplicate_genome {
135 :     my ($meta_data) = @_;
136 :     my $genome_id;
137 :    
138 :    
139 :     my @md = split (/\n/, $meta_data);
140 :     for my $i (@md) {
141 :     my ($tag, $value) = split(/\t/, $i);
142 :     if ($tag eq 'genome_id') {
143 :     $genome_id = $value;
144 :     last;
145 :     }
146 :     }
147 :    
148 :     my $db = db_init();
149 :     my $ar = $db->SQL(qq(SELECT ch_id FROM meta_data WHERE tag = 'genome_id' AND value = '$genome_id'));
150 :     return @$ar; #length = 0, if no rows
151 :     }
152 :    
153 :     sub check_for_duplicate_subsystem {
154 :     my ($meta_data) = @_;
155 :     my ($name, $version);
156 :     my @md = split (/\n/, $meta_data);
157 :     for my $i (@md) {
158 :     my ($tag, $value) = split(/\t/, $i);
159 :     if ($tag eq 'name') {
160 :     $name = $value;
161 :     }
162 :     if ($tag eq 'version') {
163 :     $version = $value;
164 :     }
165 :     }
166 :     my $db = db_init();
167 :    
168 :     print STDERR "NAME $name, VERSION $version\n";
169 :     my $ar = $db->SQL(qq(SELECT c.id FROM meta_data m1, meta_data m2, clearing_house c WHERE (c.id = m1.ch_id AND c.id = m2.ch_id AND
170 :     m1.tag = 'name' and m1.value = '$name' AND
171 :     m2.tag = 'version' and m2.value = '$version' AND
172 :     c.type = 'SUBSYSTEM')));
173 :    
174 :     return @$ar; #length = 0, if no rows
175 :     }
176 :    
177 :    
178 :    
179 : disz 1.5 sub lock_init {
180 :     my ($dbh) = @_;
181 :    
182 :     my $sth = $dbh->{_dbh}->prepare(q(INSERT into locks (name, lock)
183 :     VALUES (?, ?)
184 :     )) or die $dbh->{_dbh}->errstr;
185 :     $sth->execute("genome", 0);
186 :     $sth->execute("feature", 0);
187 :     }
188 :    
189 :     sub type_init {
190 :     my ($dbh) = @_;
191 :    
192 :     my $sth = $dbh->{_dbh}->prepare(q(INSERT into types (type)
193 :     VALUES (?)
194 :     )) or die $dbh->{_dbh}->errstr;
195 :    
196 :     # Initialize the known set of types.
197 :     #
198 :    
199 :     $sth->execute("GENOME");
200 :     $sth->execute("ANNOTATION");
201 :     $sth->execute("SUBSYSTEM");
202 :     $sth->execute("1-SUBSYSTEM");
203 :     $sth->execute("SIMS");
204 :     $sth->execute("FEATURE");
205 :     }
206 : olson 1.1
207 :    
208 :     sub get_lock {
209 :     my ($dbh, $name, $timeout) = @_;
210 :    
211 :     my $sth = $dbh->prepare(q{UPDATE locks set lock = 1 where name = ? and lock = 0}) or die $dbh->errstr;
212 :     my $res = $sth->execute($name);
213 :     while ($sth->rows == 0) {
214 :     if ($timeout-- == 0) {
215 :     die "Lock timout";
216 :     }
217 :     sleep 1;
218 :     my $res = $sth->execute($name);
219 :     }
220 :     }
221 :    
222 :    
223 :     sub release_lock {
224 :     my ($dbh, $name) = @_;
225 :    
226 :     my $sth = $dbh->prepare(q{UPDATE locks set lock = 0 where name = ?}) or die $dbh->errstr;
227 :     $sth->execute($name);
228 :     }
229 :    
230 :    
231 : disz 1.4 sub make_accession {
232 :     my ($db, $who, $source) = @_;
233 :     my $dbh = $db->{_dbh};
234 :     my $timestamp = time();
235 :     my $accession_id;
236 :    
237 :     my $sth = $dbh->prepare(q{INSERT into accession (who, accession_date, comments, source) VALUES (?, ?,?,?)}) or die $dbh->errstr;
238 :     $sth->execute($who, $timestamp, '', $source) or die $dbh->errstr;
239 :     #check the result here. check what execute returne wrt errors
240 :     my $accession_id = $db->get_inserted_id('accession', $sth);
241 :     return $accession_id;
242 :     }
243 :    
244 :     sub insert_ch_record {
245 :     my ($db, $accession_id, $type, $meta_data, $description) = @_;
246 :     my $dbh = $db->{_dbh};
247 :     my $sth = $dbh->prepare(q{INSERT into clearing_house (accession_id, type, meta_data, description) VALUES (?,?,?,?) }) or die $dbh->errstr;
248 :     $sth->execute($accession_id, $type, $meta_data, $description);
249 :     my $ch_id = $db->get_inserted_id('clearing_house', $sth);
250 :     return $ch_id;
251 :     }
252 :    
253 :    
254 :     sub insert_meta_data {
255 :     my ($dbh, $ch_id, $meta_data) = @_;
256 :    
257 :     my $sth = $dbh->prepare(q{INSERT into meta_data (ch_id, tag, value) VALUES (?, ?,?)}) or die $dbh->errstr;
258 :     my @md = split (/\n/, $meta_data);
259 :     for my $i (@md) {
260 :     my ($tag, $value) = split(/\t/, $i);
261 :     $sth->execute($ch_id, $tag, $value);
262 :     }
263 :     }
264 :    
265 :     sub insert_package_location {
266 :     my ($dbh, $ch_id, $path) = @_;
267 :     my $sth = $dbh->prepare(q{INSERT into package_location (ch_id, pathname) VALUES (?,?)}) or die $dbh->errstr;
268 :     $sth->execute($ch_id, $path);
269 :    
270 :     }
271 :    
272 : olson 1.8 #
273 :     # Allocate the next feature ID for a genome.
274 :     #
275 :     sub allocate_feature_id
276 :     {
277 :     my($dbh, $genome, $type, $number) = @_;
278 :     get_lock($dbh, "feature", 10);
279 :    
280 :     #if this feature is not in table, insert it
281 :     #get the next value, then update the next value
282 :    
283 :     my $sth = $dbh->prepare(q(SELECT next_id
284 :     FROM next_feature_id
285 :     WHERE genome_id = ? and type = ?));
286 :     $sth->execute($genome, $type);
287 :     my $rows = $sth->rows;
288 :     if ($sth->rows == 0) {
289 :     my $sth1 = $dbh->prepare(q(INSERT into next_feature_id (genome_id, type, next_id)
290 :     VALUES (?, ?, ?)
291 :     )) or die $dbh->errstr;
292 :     $sth1->execute($genome, $type, 1); #Start all new features at 1
293 :     $sth->execute($genome, $type);
294 :     }
295 :    
296 :     my $next_id;
297 :     $sth->bind_columns(\$next_id);
298 :     $sth->fetch;
299 :     my $next_id1 = $next_id+$number;
300 :     my $sth = $dbh->prepare(q{UPDATE next_feature_id set next_id = ? where genome_id=? and type = ? });
301 :     if (not $sth)
302 :     {
303 :     release_lock($dbh, "feature");
304 :     die $dbh->errstr;
305 :     }
306 :     $sth->execute($next_id1, $genome, $type);
307 :     $rows = $sth->rows;
308 :     #print STDERR "update rows = $rows, next_id = $next_id\n";
309 :     release_lock($dbh, "feature");
310 : disz 1.4
311 : olson 1.8 return $next_id;
312 :     }
313 : olson 1.1
314 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3