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

Diff of /FigKernelPackages/P2P.pm

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

revision 1.3, Wed Sep 22 20:39:01 2004 UTC revision 1.28, Thu Feb 10 16:55:46 2005 UTC
# Line 18  Line 18 
18    
19  use FIG_Config;  use FIG_Config;
20    
21    use AnyDBM_File;
22    use Fcntl;
23    
24  use strict;  use strict;
25  use Exporter;  use Exporter;
26  use base qw(Exporter);  use base qw(Exporter);
27    
28    use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
29    
30  use Data::Dumper;  use Data::Dumper;
31    
32  use vars qw(@EXPORT @EXPORT_OK);  use vars qw(@EXPORT @EXPORT_OK);
# Line 31  Line 36 
36  our $ns_p2p = "http://thefig.info/schemas/p2p_update";  our $ns_p2p = "http://thefig.info/schemas/p2p_update";
37  our $ns_relay = "http://thefig.info/schemas/p2p_relay";  our $ns_relay = "http://thefig.info/schemas/p2p_relay";
38    
39    my $peg_batch_size = 1000;
40    my $anno_batch_size = 1000;
41    my $assign_batch_size = 1000;
42    my $fin_batch_size = 1000;
43    
44    my $log_fh;
45    my $html_fh;
46    
47  =pod  =pod
48    
49  =head1 perform_update($peer)  =head1 perform_update($peer, $last_update, $skip_tough_search, $update_thru, $log_file, $html_file, $assignment_policy))
50    
51  Perform a peer-to-peer update with the given peer. $peer is an instance of  Perform a peer-to-peer update with the given peer. $peer is an instance of
52  P2P::Requestor which can connect to the peer. It is expected that the  P2P::Requestor which can connect to the peer. It is expected that the
# Line 43  Line 56 
56  This code executes the high-level protocol, maintaining state between  This code executes the high-level protocol, maintaining state between
57  calls to the peer to exchange the actual information.  calls to the peer to exchange the actual information.
58    
59        $last_update: Search for updates since this time.
60        $skip_tough_search: Do not use the time-consuming $fig->tough_search method as a last resort for peg mapping.
61        $update_thru: Search for updates until this time. Undef means to search for all since $last_update.
62        $log_file: Write logging information to this file.
63        $html_file: Write a HTML summary to this file.
64        $assignment_policy: If a list reference, contains the list of users from which we will accept assignments. If a code ref, a predicate that is passed ($peg, $timestamp, $author, $function) and returns true if the assignment should be made.
65    
66  =cut  =cut
67    
68  sub perform_update  sub perform_update
69  {  {
70      my($fig, $peer, $last_update) = @_;      my($fig, $peer, $last_update, $skip_tough_search, $update_thru, $log_file, $html_file,
71           $assignment_policy) = @_;
72    
73        my $allow_assignment;
74    
75        $log_file = "/dev/null" unless $log_file ne "";
76        open($log_fh, ">>$log_file") or die "Cannot open logfile $log_file: $!\n";
77        $log_fh->autoflush(1);
78    
79        $html_file = "/dev/null" unless $html_file ne "";
80        open($html_fh, ">$html_file") or die "Cannot open htmlfile $html_file: $!\n";
81        $html_fh->autoflush(1);
82    
83        if (!defined($assignment_policy))
84        {
85            $allow_assignment = sub { 1;};
86        }
87        elsif (ref($assignment_policy) eq "CODE")
88        {
89            $allow_assignment = $assignment_policy;
90        }
91        elsif (ref($assignment_policy) eq "ARRAY")
92        {
93            my $ahash = {};
94            map { $ahash->{$_}++; } @$assignment_policy;
95            $allow_assignment = sub {
96                return $ahash->{$_[2]};
97            };
98        }
99        elsif (ref($assignment_policy) eq "HASH")
100        {
101            $allow_assignment = sub {
102                return $assignment_policy->{$_[2]};
103            };
104        }
105        else
106        {
107            print $log_fh "Invalid assignment policy $assignment_policy\n";
108            die "Invalid assignment policy $assignment_policy\n";
109        }
110    
111      my $ret = $peer->request_update($last_update);      my $now = localtime();
112        my $last_str = localtime($last_update);
113        print $html_fh <<END;
114    <h1>P2P Update at $now</h1>
115    Peer URL $peer->{url}<br>
116    Update from: $last_str<br>
117    END
118    
119        print $log_fh "Beginning P2P update at $now\n";
120        print $log_fh "  Peer URL: $peer->{url}\n";
121        print $log_fh "  Update from: $last_str\n";
122        print $log_fh "\n";
123    
124        my $ret = $peer->request_update($last_update, $update_thru);
125    
126      if (!$ret or ref($ret) ne "ARRAY")      if (!$ret or ref($ret) ne "ARRAY")
127      {      {
128          die "perform_update: request_updated failed\n";          die "perform_update: request_update failed\n";
129      }      }
130    
131      my($session, $target_release, $num_annos, $num_pegs, $num_genomes,      my($session, $target_release, $num_assignments, $num_annos, $num_pegs, $num_genomes,
132         $target_time, $compatible) = @$ret;         $target_time, $compatible) = @$ret;
133    
134      print "perform_update: session=$session target=$target_release num_annos=$num_annos\n";      print "perform_update: session=$session target=@$target_release num_annos=$num_annos\n";
135      print "                num_pegs=$num_pegs num_genomes=$num_genomes target_time=$target_time compat=$compatible\n";      print "                num_pegs=$num_pegs num_genomes=$num_genomes target_time=$target_time compat=$compatible\n";
136    
137        my @my_release = $fig->get_release_info();
138    
139        print $log_fh "Session id = $session\n";
140        print $log_fh "Target release information: \n\t", join("\n\t", @$target_release), "\n";
141        print $log_fh "My release information: \n\t", join("\n\t", @my_release), "\n";
142        print $log_fh "$num_annos annotations\n";
143        print $log_fh "$num_assignments assignments\n";
144        print $log_fh "$num_pegs pegs\n";
145    
146        print $html_fh "Session id = $session<br>\n";
147        print $html_fh "Target release information: <br>\n\t", join("<br>\n\t", @$target_release), "<br>\n";
148        print $html_fh "My release information: <br>\n\t", join("<br>\n\t", @my_release), "<br>\n";
149        print $html_fh "$num_annos annotations<br>\n";
150        print $html_fh "$num_assignments assignments<br>\n";
151        print $html_fh "$num_pegs pegs<br>\n";
152    
153        #
154        # We now know the data release for our peer.
155        #
156        # Open up the peg translation cache database (a AnyDBM_File) tied
157        # to %peg_cache. We needn't worry about keeping it in a directory
158        # based on our current release, as it the cache directory is kept *in*
159        # the current data release directory.
160        #
161    
162        my $cache_handle;
163        my %peg_cache;
164        if ($target_release->[1] ne "")
165        {
166            my $cache_file = "pegcache.$target_release->[1].db";
167            my $cache_dir = "$FIG_Config::data/P2PQueue";
168            $fig->verify_dir($cache_dir);
169    
170            $cache_handle = tie(%peg_cache, "AnyDBM_File", "$cache_dir/$cache_file",
171                                O_CREAT | O_RDWR, 0666);
172            $cache_handle or warn "Could not tie peg_cache to $cache_dir/$cache_file: $!\n";
173        }
174    
175        #
176        # peg_mapping is the local mapping from remote->local peg. This might
177        # be replacable by peg_cache from above.
178        #
179        my %peg_mapping;
180    
181    
182      #      #
183      # We have  the information now to begin the update process. Retrieve the pegs.      # We have  the information now to begin the update process. Retrieve the pegs.
184      #      #
185    
186      $ret = $peer->get_pegs($session, 0, $num_pegs);      _compute_peg_mapping($fig, $peer, $session, $num_pegs, \%peg_mapping, \%peg_cache, $cache_handle,
187                             $skip_tough_search);
188    
189        eval { $cache_handle->sync();};
190        untie %peg_cache;
191    
192        #
193        # Create a list of locally-mapped annotations on a per-genome
194        # basis.
195        #
196    
197        my %genome_annos;
198    
199        #
200        # %genome_assignments is a hash mapping from genome to a hashref
201        # that maps  peg to function (since assignments are unique).
202        #
203        # (Hm. Unless two remote pegs map to the same local peg; unclear what to do
204        # then. Punt for now).
205        #
206        my %genome_assignments;
207    
208        #
209        # Retrieve the annotations, and generate a list of mapped annotations.
210        #
211    
212        for (my $anno_start = 0; $anno_start < $num_annos; $anno_start += $anno_batch_size)
213        {
214            my $anno_req_len = $num_annos - $anno_start;
215            $anno_req_len = $anno_batch_size if $anno_req_len > $anno_batch_size;
216    
217            print "Retrieve $anno_req_len annos at $anno_start\n";
218            print $log_fh "Retrieve $anno_req_len annos at $anno_start\n";
219    
220            my $annos = $peer->get_annotations($session, $anno_start, $anno_req_len);
221    
222            for my $anno (@$annos)
223            {
224                my($his_id, $ts, $author, $anno) = @$anno;
225    
226                my $my_id = $peg_mapping{$his_id};
227                next unless $my_id;
228    
229                my $genome = $fig->genome_of($my_id);
230    
231                push(@{$genome_annos{$genome}}, [$my_id, $ts, $author, $anno]);
232            }
233        }
234    
235        #
236        # Do the same for the assignments
237        #
238    
239        # print Dumper($assignments);
240    
241    
242        for (my $assign_start = 0; $assign_start < $num_assignments; $assign_start += $assign_batch_size)
243        {
244            my $assign_req_len = $num_assignments - $assign_start;
245            $assign_req_len = $assign_batch_size if $assign_req_len > $assign_batch_size;
246    
247            print "Retrieve $assign_req_len assigns at $assign_start\n";
248            print $log_fh "Retrieve $assign_req_len assigns at $assign_start\n";
249    
250            my $assignments = $peer->get_assignments($session, $assign_start, $assign_req_len);
251    
252            for my $assign (@$assignments)
253            {
254                my($his_id, $ts, $author, $func) = @$assign;
255    
256                my $my_id = $peg_mapping{$his_id};
257                next unless $my_id;
258    
259                my $genome = $fig->genome_of($my_id);
260    
261                $genome_assignments{$genome}->{$my_id} =  [$my_id, $ts, $author, $func];
262            }
263        }
264    
265        # print Dumper(\%genome_annos);
266    
267        #
268        # Now install annotations.
269        #
270    
271        for my $genome (keys(%genome_annos))
272        {
273            #
274            # Plan:  Apply the merge_annotations.pl logic. Read the annotations
275            # from the per-org annotations file, add the new ones here, sort, and remove duplicates.
276            # Write the results to the annotations file.
277            #
278            # When we are all done, rerun the index_annotations script.
279            #
280            # Why not do that incrementally? Partly because the annotation_seeks table doesn't
281            # have a column for the genome id, so a removal of old data would require a
282            # string-match query; since a complete reindex of the annotations is pretty
283            # fast (60 sec on a G4 laptop on a firewire disk), it's not clear whether the incremental
284            # update would actually be a win.
285            #
286    
287            my @annos = @{$genome_annos{$genome}};
288            my $assignments = $genome_assignments{$genome};
289            #
290            # %assignment_annos is a hash from peg to the list
291            # of annotations for that peg.
292            #
293            my %assignment_annos;
294    
295            my $dir = "$FIG_Config::organisms/$genome";
296            my $anno_file = "$dir/annotations";
297            my $anno_bak = "$dir/annotations." . time;
298    
299            my $new_count = @annos;
300    
301            #
302            # Rename the annotations file to a new name based on the current time.
303            #
304    
305            my $gs = $fig->genus_species($genome);
306            print $html_fh "<h1>Updates for $genome ($gs)</h1>\n";
307    
308            if (-f $anno_file)
309            {
310                rename($anno_file, $anno_bak) or die "Cannot rename $anno_file to $anno_bak: $!";
311                print $log_fh "Moved annotations file $anno_file to backup $anno_bak\n";
312            }
313    
314            if (open(my $fh, "<$anno_bak"))
315            {
316                #
317                # While we are scanning here, we look for the latest local assignment
318                # for any peg for which we are installing an assignment.
319                #
320                local($/) = "\n//\n";
321    
322                my($chunk, $peg, $ts, $author, $anno);
323    
324                while (defined($chunk = <$fh>))
325                {
326                    chomp $chunk;
327                    ($peg, $ts, $author, $anno) = split(/\n/, $chunk, 4);
328    
329                    if ($peg =~ /^fig\|/ and $ts =~ /^\d+$/)
330                    {
331                        #
332                        # The last field marks this as an "old" annotation (that is,
333                        # already in place in this system), so we don't
334                        # log its installation later.
335                        #
336                        my $ent = [$peg, $ts, $author, $anno, 1];
337                        push(@annos, $ent);
338    
339                        if (defined($assignments->{$peg}))
340                        {
341                            #
342                            # We have an incoming assignment for this peg.
343                            # Don't parse anything yet, but push the annotation
344                            # on a list so we can sort by date.
345                            #
346                            push(@{$assignment_annos{$peg}}, $ent);
347                        }
348                    }
349                }
350                close($fh);
351            }
352    
353            #
354            # Determine if we are going to install an assignment.
355            #
356    
357            my $cgi_url = &FIG::cgi_url();
358            print $html_fh "<h2>Assignments made</h2>\n";
359            print $html_fh "<table border=\"1\">\n";
360            print $html_fh "<tr><th>PEG</th><th>Old assignment</th><th>New assignment</th><tr>\n";
361    
362            for my $peg (keys %$assignments)
363            {
364                my(undef, $ts, $author, $func) = @{$assignments->{$peg}};
365    
366                #
367                # Sort the existing annotations for this peg by date.
368                #
369                # Recall that this list has entries [$peg, $timestamp, $author, $anno, $old_flag]
370                #
371    
372                my @eannos;
373                if (ref($assignment_annos{$peg}))
374                {
375                    @eannos = sort { $b->[1] <=> $a->[1] } @{$assignment_annos{$peg}};
376                }
377                else
378                {
379                    #
380                    # No assignment annotations found.
381                    #
382                    @eannos = ();
383                }
384    
385                # print "Assignment annos for $peg: ", Dumper(\@eannos);
386    
387                #
388                # Filter out just the master assignments that are newer than
389                # the one we are contemplating putting in place.
390                #
391    
392                my @cand = grep {
393                    ($_->[1] > $ts) and ($_->[3] =~ /Set master function to/)
394                    } @eannos;
395    
396                if (@cand > 0)
397                {
398                    #
399                    # Here is were some policy needs to be put in place --
400                    # we have a more recent annotation on the current system.
401                    #
402                    # For now, we will not install an assignment if there is any
403                    # newer assignment in place.
404                    #
405    
406                    warn "Skipping assignment for $peg $func due to more recent assignment $cand[0]->[3]\n";
407                    print $log_fh "Skipping assignment for $peg $func due to more recent assignment $cand[0]->[3]\n";
408                }
409                else
410                {
411                    #
412                    # Nothing is blocking us. While we are testing, just slam this assignment in.
413                    #
414    
415                    my $old = $fig->function_of($peg, 'master');
416    
417                    if ($old ne $func and &$allow_assignment($peg, $ts, $author, $func))
418                    {
419                        my $l = "$cgi_url/protein.cgi?prot=$peg";
420                        print $html_fh "<tr><td><a href=\"$l\">$peg</a></td><td>$old</td><td>$func</td></tr>\n";
421    
422                        print "Assign $peg $func\n";
423                        print $log_fh "Assign $peg $func\n";
424                        print $log_fh "   was $old\n";
425                        $fig->assign_function($peg, 'master', $func);
426    
427                    }
428                }
429            }
430    
431            print $html_fh "</table>\n";
432    
433            print $html_fh "<h2>Annotations added</h2>\n";
434            print $html_fh "<table border=\"1\">\n";
435            print $html_fh "<tr><th>PEG</th><th>Time</th><th>Author</th><th>Annotation</th></tr>\n";
436    
437            open(my $outfh, ">$anno_file") or die "Cannot open new annotation file $anno_file: $!\n";
438    
439            my $last;
440            my @sorted = sort { ($a->[0] cmp $b->[0]) or ($a->[1] <=> $b->[1]) } @annos;
441            my $inst = 0;
442            my $dup = 0;
443            foreach my $ann (@sorted)
444            {
445                my $txt = join("\n", @$ann);
446                #
447                # Drop the trailing \n if there is one; we  will add it back when we print and
448                # want to ensure the file format remains sane.
449                #
450                chomp $txt;
451                if ($txt ne $last)
452                {
453                    my $peg = $ann->[0];
454                    my $l = "$cgi_url/protein.cgi?prot=$peg";
455                    if (!$ann->[4])
456                    {
457                        print $html_fh "<tr>" . join("\n", map { "<td>$_</td>" }
458                                                     "<a href=\"$l\">$peg</a>",
459                                                     scalar(localtime($ann->[1])), $ann->[2], $ann->[3])
460                            . "</tr>\n";
461                    }
462    
463                    print $outfh "$txt\n//\n";
464                    $last = $txt;
465                    # print "Inst $ann->[0] $ann->[1] $ann->[2]\n";
466                    $inst++;
467                }
468                else
469                {
470                    # print "Dup $ann->[0] $ann->[1] $ann->[2]\n";
471                    $dup++;
472                }
473            }
474            print $html_fh "</table>\n";
475            close($outfh);
476            chmod(0666, $anno_file) or warn "Cannot chmod 0666 $anno_file: $!\n";
477            print "Wrote $anno_file. $new_count new annos, $inst installed, $dup duplicates\n";
478            print $log_fh "Wrote $anno_file. $new_count new annos, $inst installed, $dup duplicates\n";
479        }
480        close($html_fh);
481    }
482    
483    #
484    # Compute the peg mapping for a session.
485    #
486    # $fig          Active FIG instance
487    # $peer         P2P peer for this session.
488    # $session      P2P session ID
489    # $peg_mapping  Hash ref for the remote -> local PEG mapping
490    # $peg_cache    Hash ref for the persistent remote -> local PEG mapping cache db.
491    # $cache_handle AnyDBM_File handle corresponding to $peg_cache.
492    #
493    sub _compute_peg_mapping
494    {
495        my($fig, $peer, $session, $num_pegs, $peg_mapping, $peg_cache, $cache_handle, $skip_tough_search) = @_;
496    
497        #
498        # genome_map is a hash mapping from target genome id to a list of
499        # pegs on the target. This is used to construct a finalize_pegs request after
500        # the first phase of peg mapping.
501        #
502    
503        my %genome_map;
504    
505        #
506        # target_genome_info is a hash mapping from target genome
507        # identifier to the target-side information on the genome -
508        # number of contigs, number of nucleotides, checksum.
509        #
510        # We accumulate it here across possibly multiple batches of
511        # peg retrievals in order to create a single  finalization
512        # list.
513        #
514    
515        my %target_genome_info;
516    
517        #
518        # For very large transfers, we need to batch the peg processing.
519        #
520    
521        for (my $peg_start = 0; $peg_start < $num_pegs; $peg_start += $peg_batch_size)
522        {
523            my $peg_req_len = $num_pegs - $peg_start;
524            $peg_req_len = $peg_batch_size if $peg_req_len > $peg_batch_size;
525    
526            print "Getting $peg_req_len pegs at $peg_start\n";
527            print $log_fh "Getting $peg_req_len pegs at $peg_start\n";
528            my $ret = $peer->get_pegs($session, $peg_start, $peg_req_len);
529    
530      if (!$ret or ref($ret) ne "ARRAY")      if (!$ret or ref($ret) ne "ARRAY")
531      {      {
# Line 75  Line 534 
534    
535      my($peg_list, $genome_list) = @$ret;      my($peg_list, $genome_list) = @$ret;
536    
537            for my $gent (@$genome_list)
538            {
539                $target_genome_info{$gent->[0]} = $gent;
540            }
541    
542            _compute_peg_mapping_batch($fig, $peer, $session, $peg_mapping, $peg_cache, $cache_handle,
543                                       $peg_list, \%genome_map);
544        }
545    
546        #
547        # We have finished first pass. Now go over the per-genome mappings that need to be made.
548        #
549        # $genome_map{$genome_id} is a list of pegs that reside on that genome.
550        # The pegs and genome id are both target-based identifiers.
551        #
552        # %target_genome_info defines the list of genome information we have on the remote
553        # side.
554        #
555        # We build a request to be passed to finalize_pegs. Each entry in the request is either
556        # ['peg_genome', $peg] which means that we have a genome that corresponds to the
557        # genome the peg is in. We can attempt to map via contig locations.
558        #
559        # If that is not the case,  we pass a request entry of ['peg_unknown', $peg]
560        # which will result in the sequence data being returned.
561        #
562    
563        my @finalize_req = ();
564    
565        #
566        # local_genome maps a target peg identifier to the local genome id it translates to.
567        #
568        my %local_genome;
569    
570        for my $genome (keys(%target_genome_info))
571        {
572            my($tg, $n_contigs, $n_nucs, $cksum) = @{$target_genome_info{$genome}};
573    
574            $tg eq $genome or die "Invalid entry in target_genome_info for $genome => $tg, $n_contigs, $n_nucs, $cksum";
575    
576            #
577            # Don't bother unless we have any pegs to look up.
578            #
579            next unless defined($genome_map{$genome});
580    
581            #
582            # Determine if we have a local genome installed that matches precisely the
583            # genome on the target side.
584            #
585            my $my_genome = $fig->find_genome_by_content($genome, $n_contigs, $n_nucs, $cksum);
586    
587            my $pegs = $genome_map{$genome};
588    
589            if ($my_genome)
590            {
591                #
592                # We do have such a local genome. Generate a peg_genome request to
593                # get the location information from the target side.
594                #
595                # Also remember the local genome mapping for this peg.
596                #
597    
598                print "$genome mapped to $my_genome\n";
599                print $log_fh "$genome mapped to $my_genome\n";
600                for my $peg (@$pegs)
601                {
602                    push(@finalize_req, ['peg_genome', $peg]);
603                    $local_genome{$peg} = $my_genome;
604                }
605    
606            }
607            else
608            {
609                #
610                # We don't have such a genome. We need to retrieve the
611                # sequence data in order to finish mapping.
612                #
613                push(@finalize_req, map { ['peg_unknown', $_] } @$pegs);
614            }
615        }
616    
617        #
618        # We've built our finalization request. Handle it (possibly with batching here too).
619        #
620    
621        _process_finalization_request($fig, $peer, $session, $peg_mapping, $peg_cache, $cache_handle,
622                                     \%local_genome, \@finalize_req, $skip_tough_search);
623    
624    }
625    
626    #
627    # Process one batch of PEGs.
628    #
629    # Same args as _compute_peg_mapping, with the addition of:
630    #
631    #       $peg_list       List of pegs to be processed
632    #       $genome_map     Hash maintaining list of genomes with their pegs.
633    #       $target_genome_info     Hash maintaining overall list of target-side genome information.
634    #
635    sub _compute_peg_mapping_batch
636    {
637        my($fig, $peer, $session, $peg_mapping, $peg_cache, $cache_handle,
638           $peg_list, $genome_map, $target_genome_info) = @_;
639    
640        #
641        # Walk the list of pegs as returned from get_pegs() and determine what has to
642        # be done.
643        #
644        # If the entry is ['peg', $peg], we can use the peg ID as is.
645        #
646        # If the entry is ['peg_info', $peg, $alias_list, $genome], the peg
647        # has the given aliases, and is in the given genome.
648        #
649        for my $peg_info (@$peg_list)
650        {
651            my($key, $peg, @rest) = @$peg_info;
652    
653            if ($key eq 'peg')
654            {
655                #
656                # Peg id is directly usable.
657                #
658                $peg_mapping->{$peg} = $peg;
659            }
660            elsif ($key eq 'peg_info')
661            {
662                #
663                # Peg id not directly usable. See if we have it in the cache.
664                #
665    
666                if ((my $cached = $peg_cache->{$peg}) ne "")
667                {
668                    #
669                    # Cool, we've cached the result. Use it.
670                    #
671    
672                    $peg_mapping->{$peg} = $cached;
673                    # warn "Found cached mapping $peg => $cached\n";
674                    next;
675                }
676    
677                #
678                # It is not cached. Attempt to resolve by means of alias IDs.
679                #
680    
681                my($alias_list, $genome_id) = @rest;
682    
683                for my $alias (@$alias_list)
684                {
685                    my $mapped = $fig->by_alias($alias);
686                    if ($mapped)
687                    {
688                        print "$peg maps to $mapped via $alias\n";
689                        print $log_fh "$peg maps to $mapped via $alias\n";
690                        $peg_mapping->{$peg}= $mapped;
691                        $peg_cache->{$peg} = $mapped;
692                        last;
693                    }
694                }
695    
696      #      #
697      # Walk the peg-list to and generate @pegs_to_finalize.              # If we weren't able to resolve by ID,
698                # add to %genome_map as a PEG that will need
699                # to be resolved by means of contig location.
700      #      #
701    
702      my(%peg_mapping, %genome_map );              if (!defined($peg_mapping->{$peg}))
703                {
704                    push(@{$genome_map->{$genome_id}}, $peg);
705                    print "$peg did not map on first pass\n";
706                    print $log_fh "$peg did not map on first pass\n";
707                }
708            }
709        }
710    
711        #
712        # Flush the cache to write out any computed mappings.
713        #
714        eval { $cache_handle->sync();};
715    
716    }
717    
718    sub _process_finalization_request
719    {
720        my($fig, $peer, $session, $peg_mapping, $peg_cache, $cache_handle,
721           $local_genome, $finalize_req, $skip_tough_search) = @_;
722    
723        #
724        # Immediately return unless there's something to do.
725        #
726        return unless ref($finalize_req) and @$finalize_req > 0;
727    
728        while (@$finalize_req > 0)
729        {
730            my @req = splice(@$finalize_req, 0, $fin_batch_size);
731    
732            print "Invoking finalize_pegs on ", int(@req), " pegs\n";
733            print $log_fh "Invoking finalize_pegs on ", int(@req), " pegs\n";
734            my $ret = $peer->finalize_pegs($session, \@req);
735    
736            if (!$ret or ref($ret) ne "ARRAY")
737            {
738                die "perform_update: finalize_pegs failed\n";
739            }
740    
741            #
742            # The return is a list of either location entries or
743            # sequence data. Attempt to finish up the mapping.
744            #
745    
746            my(%sought, %sought_seq);
747    
748    
749            my $dbh = $fig->db_handle();
750            for my $entry (@$ret)
751            {
752                my($what, $peg, @rest) = @$entry;
753    
754                if ($what eq "peg_loc")
755                {
756                    my($strand, $start, $end, $cksum, $seq) = @rest;
757    
758                    #
759                    # We have a contig location. Try to find a matching contig
760                    # here, and see if it maps to something.
761                    #
762    
763                    my $my_genome = $local_genome->{$peg};
764                    my $local_contig = $fig->find_contig_with_checksum($my_genome, $cksum);
765                    if ($local_contig)
766                    {
767                        #
768                        # Now look up the local peg. We match on the end location; depending on the strand
769                        # the feature is on, we want to look at either minloc or maxloc.
770                        #
771    
772                        my($start_loc, $end_loc);
773    
774                        if ($strand eq '-')
775                        {
776                            $start_loc = 'maxloc';
777                            $end_loc = 'minloc';
778                        }
779                        else
780                        {
781                            $start_loc = 'minloc';
782                            $end_loc = 'maxloc';
783                        }
784    
785                        my $res = $dbh->SQL(qq!SELECT id, $start_loc from features
786                                               WHERE $end_loc = $end and genome = '$my_genome' and
787                                               contig = '$local_contig'
788                                            !);
789    
790      for my $peg_info (@$peg_list)                      if ($res and @$res > 0)
791      {      {
792          my($key, $peg, @rest) = @$peg_info;                          my $id;
793                            if (@$res == 1)
         if ($key eq 'peg')  
794          {          {
795              #              #
796              # Peg id is directly usable.                              # Found a unique mapping.
797              #              #
798                                $id = $res->[0]->[0];
799          }          }
800          elsif ($key eq 'peg_info')                          else
801          {          {
802              #              #
803              # Peg id not directly usable.                              # Multiple mappings found. See if one matches the
804                                # start location. If it doesn't, pick the one that
805                                # is closest in length.
806              #              #
807    
808              my($alias_list, $genome_id) = @rest;                              my @lens;
809    
810              for my $alias (@$alias_list)                              for my $res_ent (@$res)
811              {              {
812                  my $mapped = $fig->by_alias($alias);                                  my($rid, $rloc) = @$res_ent;
813                  if ($mapped)  
814                                    push(@lens, [$rid, abs($rloc - $end - ($start - $end))]);
815                                    warn "Matching $rid $rloc to $start\n";
816                                    if ($rloc == $start)
817                  {                  {
818                      print "$peg maps to $mapped via $alias\n";                                      $id = $rid;
819                      $peg_mapping{$peg}= $mapped;                                      warn "Matched $rid\n";
820                      last;                      last;
821                  }                  }
822              }              }
823    
824              #                              if (!$id)
825              # If we didn't succeed in mapping by alias,                              {
826              # stash this in the list of pegs to be mapped by                                  my @slens = sort { $a->[1] <=> $b->[1]} @lens;
827              # genome.                                  my $len;
828              #                                  ($id, $len) = @{$slens[0]};
829                                    warn "No unique match found, picking closest match $id (len=$len)\n";
830                                }
831                            }
832    
833              if (!defined($peg_mapping{$peg}))                          $peg_mapping->{$peg} = $id;
834                            $peg_cache->{$peg} = $id;
835                            print "Mapped $peg to $id via contigs\n";
836                        }
837                        else
838                        {
839                            print "failed: $peg  $my_genome and contig $local_contig start=$start end=$end strand=$strand\n";
840                            print $log_fh "failed: $peg  $my_genome and contig $local_contig start=$start end=$end strand=$strand\n";
841                            print $html_fh "Contig match failed: $peg $my_genome contig $local_contig start $start end $end strand $strand<br>\n";
842                            $sought{$peg}++;
843                            $sought_seq{$peg} = $seq;
844                        }
845                    }
846                    else
847              {              {
848                  push(@{$genome_map{$genome_id}}, $peg);                      print "Mapping failed for $my_genome checksum $cksum\n";
849                        print $log_fh "Mapping failed for $my_genome checksum $cksum\n";
850                        print $html_fh "Mapping failed for $my_genome checksum $cksum<br>\n";
851                        $sought{$peg}++;
852                        $sought_seq{$peg} = $seq;
853                    }
854              }              }
855                elsif ($what eq "peg_seq")
856                {
857                    my($seq) = @rest;
858    
859                    $sought{$peg}++;
860                    $sought_seq{$peg} = $seq;
861          }          }
862      }      }
863    
864      #      #
865      # finished first pass. Now go over the per-genome mappings that need to be made.          # Now see if we need to do a tough search.
866      #      #
867    
868      for my $genome_info (@$genome_list)          if (keys(%sought) > 0 and !$skip_tough_search)
869      {      {
870          my($genome, $n_contigs, $n_nucs, $cksum) = @$genome_info;              my %trans;
871    
872          next unless $genome_map{$genome};              print "Starting tough search\n";
873                print $log_fh "Starting tough search\n";
         my $my_genome = $fig->find_genome_by_content($genome, $n_contigs, $n_nucs, $cksum);  
874    
875          if ($my_genome)              $fig->tough_search(undef, \%sought_seq, \%trans, \%sought);
876                print "Tough search translated: \n";
877                print $log_fh "Tough search translated: \n";
878                while (my($tpeg, $ttrans) = each(%trans))
879          {          {
880              #                  print "  $tpeg -> $ttrans\n";
881              # Found a match.                  print $log_fh "  $tpeg -> $ttrans\n";
882              #                  $peg_mapping->{$tpeg} = $ttrans;
883              print "Genome $genome maps to $my_genome locally\n";                  $peg_cache->{$tpeg} = $ttrans;
   
884          }          }
         else  
         {  
             print "No mapping for $genome\n";  
885          }          }
886      }      }
887  }  }
888    
   
889  #############  #############
890  #  #
891  # P2P Relay  # P2P Relay
# Line 170  Line 905 
905  {  {
906      my($class, $url) = @_;      my($class, $url) = @_;
907    
908      my $proxy = SOAP::Lite->uri($P2P::ns_relay)->proxy($url);      my $creds = [];
909    
910        my $proxy = SOAP::Lite->uri($P2P::ns_relay)->proxy([$url,
911                                                            credentials => $creds]);
912    
913      my $self = {      my $self = {
914          url => $url,          url => $url,
# Line 243  Line 981 
981          # element in the body of the message.          # element in the body of the message.
982          #          #
983          my $ns = $reply->namespaceuriof('/Envelope/Body/[1]');          my $ns = $reply->namespaceuriof('/Envelope/Body/[1]');
984          print "Reply ns=$ns want $P2P::ns_relay\n";          # print "Reply ns=$ns want $P2P::ns_relay\n";
985    
986          if ($ns eq $P2P::ns_relay)          if ($ns eq $P2P::ns_relay)
987          {          {
988              my $val = $reply->result;              my $val = $reply->result;
989              print "got val=", Dumper($val);              # print "got val=", Dumper($val);
990              if ($val->[0] eq 'deferred')              if ($val->[0] eq 'deferred')
991              {              {
992                  #                  #
# Line 290  Line 1028 
1028  use strict;  use strict;
1029    
1030  use Data::Dumper;  use Data::Dumper;
1031    use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
1032    
1033  use SOAP::Lite;  use SOAP::Lite;
1034    
1035    #use SOAP::Lite +trace => [qw(transport dispatch result debug)];
1036  use P2P;  use P2P;
1037    
1038  #  #
# Line 301  Line 1042 
1042    
1043  sub new  sub new
1044  {  {
1045      my($class, $fig, $url, $peer_id, $relay) = @_;      my($class, $fig, $url, $peer_id, $relay, $credentials) = @_;
1046    
1047        $credentials = [] unless ref($credentials);
1048    
1049      my $proxy = SOAP::Lite->uri($ns_p2p)->proxy($url);      my $proxy = SOAP::Lite->uri($ns_p2p)->proxy($url, timeout => 3600);
1050    
1051        for my $cred (@$credentials)
1052        {
1053            $proxy->transport->credentials(@$cred);
1054        }
1055    
1056      my $self = {      my $self = {
1057          fig => $fig,          fig => $fig,
# Line 329  Line 1077 
1077    
1078  sub request_update  sub request_update
1079  {  {
1080      my($self, $last_update) = @_;      my($self, $last_update, $update_thru) = @_;
1081    
1082      my $rel = $self->{fig}->get_release_info();      my $rel = [$self->{fig}->get_release_info()];
1083    
1084      if (!defined($last_update))      if (!defined($last_update))
1085      {      {
1086          $last_update = $self->{fig}->get_peer_last_update($self->{peer_id});          $last_update = $self->{fig}->get_peer_last_update($self->{peer_id});
1087      }      }
1088    
1089      my $reply = $self->{proxy}->request_update($rel, $last_update);      print "Requesting update via $self->{proxy}\n";
1090        my $reply = $self->{proxy}->request_update($rel, $last_update, $update_thru);
1091        # print "Got reply ", Dumper($reply);
1092    
1093      if ($self->{relay})      if ($self->{relay})
1094      {      {
# Line 368  Line 1118 
1118      return $self->call("get_pegs", $session_id, $start, $length);      return $self->call("get_pegs", $session_id, $start, $length);
1119  }  }
1120    
1121    sub finalize_pegs
1122    {
1123        my($self, $session_id, $request) = @_;
1124    
1125        return $self->call("finalize_pegs", $session_id, $request);
1126    }
1127    
1128    sub get_annotations
1129    {
1130        my($self, $session_id, $start, $length) = @_;
1131    
1132        return $self->call("get_annotations", $session_id, $start, $length);
1133    }
1134    
1135    sub get_assignments
1136    {
1137        my($self, $session_id, $start, $length) = @_;
1138    
1139        return $self->call("get_assignments", $session_id, $start, $length);
1140    }
1141    
1142  sub call  sub call
1143  {  {
1144      my($self, $func, @args) = @_;      my($self, $func, @args) = @_;
1145    
1146        my $t0 = [gettimeofday()];
1147        print "Calling $func\n";
1148      my $reply = $self->{proxy}->$func(@args);      my $reply = $self->{proxy}->$func(@args);
1149        my $t1 = [gettimeofday()];
1150    
1151        my $elap = tv_interval($t0, $t1);
1152        print "Call to $func took $elap\n";
1153    
1154      if ($self->{relay})      if ($self->{relay})
1155      {      {
# Line 410  Line 1187 
1187    
1188  sub request_update  sub request_update
1189  {  {
1190      my($class, $his_release, $last_update)= @_;      my($class, $his_release, $last_update, $update_thru)= @_;
1191    
1192      #      #
1193      # Verify input.      # Verify input.
# Line 421  Line 1198 
1198          die "request_update: last_update must be a number (not '$last_update')\n";          die "request_update: last_update must be a number (not '$last_update')\n";
1199      }      }
1200    
1201        if ($update_thru eq "")
1202        {
1203            $update_thru = time + 10000;
1204        }
1205    
1206      #      #
1207      # Create a new session id and a spool directory to use for storage      # Create a new session id and a spool directory to use for storage
1208      # of information about it. This can go in the tempdir since it is      # of information about it. This can go in the tempdir since it is
# Line 428  Line 1210 
1210      #      #
1211    
1212      &FIG::verify_dir("$FIG_Config::temp/p2p_spool");      &FIG::verify_dir("$FIG_Config::temp/p2p_spool");
1213      #my $spool_dir = tempdir(DIR  => "$FIG_Config::temp/p2p_spool");      my $spool_dir = tempdir(DIR  => "$FIG_Config::temp/p2p_spool");
1214    
1215      my $spool_dir = "$FIG_Config::temp/p2p_spool/test";      #my $spool_dir = "$FIG_Config::temp/p2p_spool/test";
1216      &FIG::verify_dir($spool_dir);      &FIG::verify_dir($spool_dir);
1217    
1218      my $session_id = basename($spool_dir);      my $session_id = basename($spool_dir);
# Line 448  Line 1230 
1230    
1231      my %pegs;      my %pegs;
1232    
1233        #
1234        # We keep track of usernames that have been seen, so that
1235        # we can both update our local user database and
1236        # we can report them to our peer.
1237        #
1238    
1239        my %users;
1240    
1241      my $num_annos = 0;      my $num_annos = 0;
1242      my $num_genomes = 0;      my $num_genomes = 0;
1243      my $num_pegs = 0;      my $num_pegs = 0;
1244        my $num_assignments = 0;
1245    
1246      my $anno_fh;      my $anno_fh;
1247      open($anno_fh, ">$spool_dir/annos");      open($anno_fh, ">$spool_dir/annos");
# Line 461  Line 1252 
1252      my $genome_fh;      my $genome_fh;
1253      open($genome_fh, ">$spool_dir/genomes");      open($genome_fh, ">$spool_dir/genomes");
1254    
1255        my $assign_fh;
1256        open($assign_fh, ">$spool_dir/assignments");
1257    
1258        #
1259        # We originally used a query to get the PEGs that needed to have annotations
1260        # sent. Unfortunately, this performed very poorly due to all of the resultant
1261        # seeking around in the annotations files.
1262        #
1263        # The code below just runs through all of the anno files looking for annos.
1264        #
1265        # A better way to do this would be to do a query to retrieve the genome id's for
1266        # genomes that have updates. The problem here is that the annotation_seeks
1267        # table doesn't have an explicit genome field.
1268        #
1269        # Surprisingly, to me anyway, the following query appers to run quickly, in both
1270        # postgres and mysql:
1271        #
1272        # SELECT distinct(substring(fid from 5 for position('.peg.' in fid) - 5))
1273        # FROM annotation_seeks
1274        # WHERE dateof > some-date.
1275        #
1276        # The output of that can be parsed to get the genome id and just those
1277        # annotations files searched.
1278        #
1279    
1280      for my $genome (@$all_genomes)      for my $genome (@$all_genomes)
1281      {      {
1282          my $num_annos_for_genome = 0;          my $num_annos_for_genome = 0;
1283            my %assignment;
1284    
1285          my $genome_dir = "$FIG_Config::organisms/$genome";          my $genome_dir = "$FIG_Config::organisms/$genome";
1286          next unless -d $genome_dir;          next unless -d $genome_dir;
# Line 480  Line 1297 
1297    
1298                  if ((($fid, $anno_time, $who, $anno_text) =                  if ((($fid, $anno_time, $who, $anno_text) =
1299                       ($ann =~ /^(fig\|\d+\.\d+\.peg\.\d+)\n(\d+)\n(\S+)\n(.*\S)/s)) and                       ($ann =~ /^(fig\|\d+\.\d+\.peg\.\d+)\n(\d+)\n(\S+)\n(.*\S)/s)) and
1300                      $anno_time > $last_update)                      $anno_time > $last_update and
1301                        $anno_time < $update_thru)
1302    
1303                  {                  {
1304                      #                      #
1305                        # Update users list.
1306                        #
1307    
1308                        $users{$who}++;
1309    
1310                        #
1311                      # Look up aliases if we haven't seen this fid before.                      # Look up aliases if we haven't seen this fid before.
1312                      #                      #
1313    
# Line 501  Line 1325 
1325    
1326                      $num_annos_for_genome++;                      $num_annos_for_genome++;
1327                      $num_annos++;                      $num_annos++;
1328    
1329                        #
1330                        # While we're here, see if this is an assignment. We check in the
1331                        # %assignment hash, which is keyed on fid, to see if we already
1332                        # saw an assignment for this fid. If we have, we keep this one only if
1333                        # the assignment time on it is later than the one we saw already.
1334                        #
1335                        # We are only looking at master assignments for now. We will need
1336                        # to return to this issue and reexamine it, but in order to move
1337                        # forward I am only matching master assignments.
1338                        #
1339    
1340                        if ($anno_text =~ /Set master function to\n(\S[^\n]+\S)/)
1341                        {
1342                            my $func = $1;
1343    
1344                            my $other = $assignment{$fid};
1345    
1346                            #
1347                            # If we haven't seen an assignment for this fid,
1348                            # or if it the other assignment has a timestamp that
1349                            # is earlier than this one, set the assignment.
1350                            #
1351    
1352                            if (!defined($other) or
1353                                ($other->[1] < $anno_time))
1354                            {
1355                                $assignment{$fid} = [$fid, $anno_time, $who, $func];
1356                            }
1357                        }
1358                  }                  }
1359              }              }
1360              close($afh);              close($afh);
1361    
1362                #
1363                # Write out the assignments that remain.
1364                #
1365    
1366                for my $fid (sort keys(%assignment))
1367                {
1368                    print $assign_fh join("\t", @{$assignment{$fid}}), "\n";
1369                    $num_assignments++;
1370                }
1371          }          }
1372    
1373    
1374          #          #
1375          # Determine genome information if we have annotations for this one.          # Determine genome information if we have annotations for this one.
1376          #          #
# Line 537  Line 1402 
1402      close($anno_fh);      close($anno_fh);
1403      close($peg_fh);      close($peg_fh);
1404      close($genome_fh);      close($genome_fh);
1405        close($assign_fh);
1406    
1407      print "Pegs: $num_pegs\n";      print "Pegs: $num_pegs\n";
1408      print "Genomes: $num_genomes\n";      print "Genomes: $num_genomes\n";
# Line 546  Line 1412 
1412      # Check compatibility.      # Check compatibility.
1413      #      #
1414    
1415      my $my_release = $fig->get_release_info();      my $my_release = [$fig->get_release_info()];
1416      my $compatible = (defined($my_release) && ($my_release == $his_release)) ? 1 : 0;  
1417        #
1418        # Release id is $my_release->[1].
1419        #
1420    
1421        my $compatible;
1422        if ($my_release->[1] ne "" and $his_release->[1] ne "")
1423        {
1424            #
1425            # Both releases must be defined for them to be compatible.
1426            #
1427            # At some point we need to consider the derived-release issue.
1428            #
1429    
1430            $compatible = $my_release->[1] eq $his_release->[1];
1431        }
1432        else
1433        {
1434            $compatible = 0;
1435        }
1436    
1437      open(my $fh, ">$spool_dir/INFO");      open(my $fh, ">$spool_dir/INFO");
1438      print $fh "requestor_release\t$his_release\n";      print $fh "requestor_release\t$his_release\n";
1439      print $fh "last_update\t$last_update\n";      print $fh "last_update\t$last_update\n";
1440        print $fh "update_thru\t$update_thru\n";
1441      print $fh "cur_update\t$now\n";      print $fh "cur_update\t$now\n";
1442      print $fh "target_release\t$my_release\n";      print $fh "target_release\t$my_release\n";
1443      print $fh "compatible\t$compatible\n";      print $fh "compatible\t$compatible\n";
1444      print $fh "num_pegs\t$num_pegs\n";      print $fh "num_pegs\t$num_pegs\n";
1445      print $fh "num_genomes\t$num_genomes\n";      print $fh "num_genomes\t$num_genomes\n";
1446      print $fh "num_annos\t$num_annos\n";      print $fh "num_annos\t$num_annos\n";
1447        print $fh "num_assignments\t$num_assignments\n";
1448      close($fh);      close($fh);
1449    
1450      return [$session_id, $my_release, $num_annos, $num_pegs, $num_genomes, $now, $compatible];      #
1451        # Construct list of users, and pdate local user database.
1452        #
1453    
1454        my @users = keys(%users);
1455        # $fig->ensure_users(\@users);
1456    
1457        return [$session_id, $my_release, $num_assignments, $num_annos, $num_pegs, $num_genomes,
1458                $now, $compatible, \@users];
1459  }  }
1460    
1461    
# Line 673  Line 1568 
1568    
1569      return [$peg_output, $genome_output];      return [$peg_output, $genome_output];
1570  }  }
1571    
1572    sub finalize_pegs
1573    {
1574        my($self, $session, $request) = @_;
1575        my($out);
1576    
1577        my $fig = new FIG;
1578    
1579        #
1580        # Walk the request handling appropriately. This is fairly easy, as it
1581        # is just a matter of pulling either sequence or location/contig data.
1582        #
1583    
1584        for my $item (@$request)
1585        {
1586            my($what, $peg) = @$item;
1587    
1588            if ($what eq "peg_genome")
1589            {
1590                #
1591                # Return the location and contig checksum for this peg.
1592                #
1593                # We also include the sequence in case the contig mapping doesn't work.
1594                #
1595    
1596                my $loc = $fig->feature_location($peg);
1597                my $contig = $fig->contig_of($loc);
1598                my $cksum = $fig->contig_checksum($fig->genome_of($peg), $contig);
1599                my $seq = $fig->get_translation($peg);
1600    
1601                push(@$out, ['peg_loc', $peg,
1602                            $fig->strand_of($peg),
1603                            $fig->beg_of($loc), $fig->end_of($loc),
1604                            $cksum, $seq]);
1605    
1606            }
1607            elsif ($what eq "peg_unknown")
1608            {
1609                my $seq = $fig->get_translation($peg);
1610                push(@$out, ['peg_seq', $peg, $seq]);
1611            }
1612        }
1613        return $out;
1614    }
1615    
1616    
1617    sub get_annotations
1618    {
1619        my($self, $session_id, $start, $len) = @_;
1620    
1621        #
1622        # This is now easy; just run thru the saved annotations and return.
1623        #
1624    
1625        my(%session_info);
1626    
1627        my $spool_dir = "$FIG_Config::temp/p2p_spool/$session_id";
1628    
1629        -d $spool_dir or die "Invalid session id $session_id";
1630    
1631        #
1632        # Read in the cached information for this session.
1633        #
1634    
1635        open(my $info_fh, "<$spool_dir/INFO") or die "Cannot open INFO file: $!";
1636        while (<$info_fh>)
1637        {
1638            chomp;
1639            my($var, $val) = split(/\t/, $_, 2);
1640            $session_info{$var} = $val;
1641        }
1642        close($info_fh);
1643    
1644        #
1645        # Sanity check start and length.
1646        #
1647    
1648        if ($start < 0 or $start >= $session_info{num_annos})
1649        {
1650            die "Invalid start position $start";
1651        }
1652    
1653        if ($len < 0 or ($start + $len - 1) >= $session_info{num_annos})
1654        {
1655            die "Invalid length $len";
1656        }
1657    
1658        #
1659        # Open file, spin to the starting line, then start reading.
1660        #
1661    
1662        open(my $anno_fh, "<$spool_dir/annos") or die "Cannot open annos file: $!";
1663    
1664        my $anno_output = [];
1665    
1666        my $anno_num = 0;
1667    
1668        local $/ = "//\n";
1669        while (<$anno_fh>)
1670        {
1671            next if ($anno_num < $start);
1672    
1673            last if ($anno_num > ($start + $len));
1674    
1675            chomp;
1676    
1677            my($id, $date, $author, $anno) = split(/\n/, $_, 4);
1678    
1679            push(@$anno_output, [$id, $date, $author, $anno]);
1680        }
1681        continue
1682        {
1683            $anno_num++;
1684        }
1685    
1686        return $anno_output;
1687    }
1688    
1689    sub get_assignments
1690    {
1691        my($self, $session_id, $start, $len) = @_;
1692    
1693        #
1694        # This is now easy; just run thru the saved assignments and return.
1695        #
1696    
1697        my(%session_info);
1698    
1699        my $spool_dir = "$FIG_Config::temp/p2p_spool/$session_id";
1700    
1701        -d $spool_dir or die "Invalid session id $session_id";
1702    
1703        #
1704        # Read in the cached information for this session.
1705        #
1706    
1707        open(my $info_fh, "<$spool_dir/INFO") or die "Cannot open INFO file: $!";
1708        while (<$info_fh>)
1709        {
1710            chomp;
1711            my($var, $val) = split(/\t/, $_, 2);
1712            $session_info{$var} = $val;
1713        }
1714        close($info_fh);
1715    
1716        #
1717        # Sanity check start and length.
1718        #
1719    
1720        if ($start < 0 or $start >= $session_info{num_assignments})
1721        {
1722            die "Invalid start position $start";
1723        }
1724    
1725        if ($len < 0 or ($start + $len - 1) >= $session_info{num_assignments})
1726        {
1727            die "Invalid length $len";
1728        }
1729    
1730        #
1731        # Open file, spin to the starting line, then start reading.
1732        #
1733    
1734        open(my $assign_fh, "<$spool_dir/assignments") or die "Cannot open assignments file: $!";
1735    
1736        my $assign_output = [];
1737    
1738        my $assign_num = 0;
1739    
1740        while (<$assign_fh>)
1741        {
1742            next if ($assign_num < $start);
1743    
1744            last if ($assign_num > ($start + $len));
1745    
1746            chomp;
1747    
1748            my($id, $date, $author, $func) = split(/\t/, $_, 4);
1749    
1750            push(@$assign_output, [$id, $date, $author, $func]);
1751        }
1752        continue
1753        {
1754            $assign_num++;
1755        }
1756    
1757        return $assign_output;
1758    }
1759    
1760    1;

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.28

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3