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

Annotation of /Clearinghouse/utils.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3