[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.19, Wed Jan 5 22:10:06 2005 UTC revision 1.20, Thu Jan 6 04:37:54 2005 UTC
# Line 52  Line 52 
52    
53  sub perform_update  sub perform_update
54  {  {
55      my($fig, $peer, $last_update, $skip_tough_search) = @_;      my($fig, $peer, $last_update, $skip_tough_search, $update_thru) = @_;
56    
57      my $ret = $peer->request_update($last_update);      my $ret = $peer->request_update($last_update, $update_thru);
58    
59      if (!$ret or ref($ret) ne "ARRAY")      if (!$ret or ref($ret) ne "ARRAY")
60      {      {
# Line 369  Line 369 
369      # Do the same for the assignments      # Do the same for the assignments
370      #      #
371    
372        # print Dumper($assignments);
373    
374      for my $assign (@$assignments)      for my $assign (@$assignments)
375      {      {
376          my($his_id, $ts, $author, $func) = @$assign;          my($his_id, $ts, $author, $func) = @$assign;
# Line 389  Line 391 
391      # Now install annotations.      # Now install annotations.
392      #      #
393    
394        open(my $old_assignments, ">old_assignments");
395    
396      for my $genome (keys(%genome_annos))      for my $genome (keys(%genome_annos))
397      {      {
398          #          #
# Line 468  Line 472 
472    
473          for my $peg (keys %$assignments)          for my $peg (keys %$assignments)
474          {          {
475              my(undef, $ts, $author, $func) = $assignments->{$peg};              my(undef, $ts, $author, $func) = @{$assignments->{$peg}};
476    
477                #
478                # Sort the existing annotations for this peg by date.
479                #
480                # Recall that this list has entries [$peg, $timestamp, $author, $anno]
481                #
482    
483                my @eannos;
484                if (ref($assignment_annos{$peg}))
485                {
486                    @eannos = sort { $b->[1] <=> $a->[1] } @{$assignment_annos{$peg}};
487                }
488                else
489                {
490                    #
491                    # No assignment annotations found.
492                    #
493                    @eannos = ();
494                }
495    
496                # print "Assignment annos for $peg: ", Dumper(\@eannos);
497    
498              #              #
499              # Sort the existing annotations for this peg by date.#              # Filter out just the master assignments that are newer than
500                # the one we are contemplating putting in place.
501              #              #
502    
503              my @eannos = sort { $b->[1] <=> $a->[1] } @{$assignment_annos{$peg}};              my @cand = grep {
504                    ($_->[1] > $ts) and ($_->[3] =~ /Set master function to/)
505                    } @eannos;
506    
507              print "Assignment annos for $peg: ", Dumper(\@eannos);              if (@cand > 0)
508                {
509                    #
510                    # Here is were some policy needs to be put in place --
511                    # we have a more recent annotation on the current system.
512                    #
513                    # For now, we will not install an assignment if there is any
514                    # newer assignment in place.
515                    #
516    
517                    warn "Skipping assignment for $peg $func due to more recent assignment $cand[0]->[3]\n";
518                }
519                else
520                {
521                    #
522                    # Nothing is blocking us. While we are testing, just slam this assignment in.
523                    #
524    
525                    my $old = $fig->function_of($peg, 'master');
526                    print $old_assignments "$peg\t$old\n";
527    
528                    print "Assign $peg $func\n";
529                    $fig->assign_function($peg, 'master', $func);
530                }
531          }          }
532    
533          open(my $outfh, ">$anno_file") or die "Cannot open new annotation file $anno_file: $!\n";          open(my $outfh, ">$anno_file") or die "Cannot open new annotation file $anno_file: $!\n";
# Line 514  Line 564 
564          #          #
565          # _install_genome_annos($fig, $genome, $genome_annos{$genome});          # _install_genome_annos($fig, $genome, $genome_annos{$genome});
566      }      }
567        close($old_assignments);
568  }  }
569    
570    
# Line 610  Line 661 
661          # element in the body of the message.          # element in the body of the message.
662          #          #
663          my $ns = $reply->namespaceuriof('/Envelope/Body/[1]');          my $ns = $reply->namespaceuriof('/Envelope/Body/[1]');
664          print "Reply ns=$ns want $P2P::ns_relay\n";          # print "Reply ns=$ns want $P2P::ns_relay\n";
665    
666          if ($ns eq $P2P::ns_relay)          if ($ns eq $P2P::ns_relay)
667          {          {
668              my $val = $reply->result;              my $val = $reply->result;
669              print "got val=", Dumper($val);              # print "got val=", Dumper($val);
670              if ($val->[0] eq 'deferred')              if ($val->[0] eq 'deferred')
671              {              {
672                  #                  #
# Line 699  Line 750 
750    
751  sub request_update  sub request_update
752  {  {
753      my($self, $last_update) = @_;      my($self, $last_update, $update_thru) = @_;
754    
755      my $rel = [$self->{fig}->get_release_info()];      my $rel = [$self->{fig}->get_release_info()];
756    
# Line 709  Line 760 
760      }      }
761    
762      print "Requesting update via $self->{proxy}\n";      print "Requesting update via $self->{proxy}\n";
763      my $reply = $self->{proxy}->request_update($rel, $last_update);      my $reply = $self->{proxy}->request_update($rel, $last_update, $update_thru);
764      print "Got reply ", Dumper($reply);      # print "Got reply ", Dumper($reply);
765    
766      if ($self->{relay})      if ($self->{relay})
767      {      {
# Line 809  Line 860 
860    
861  sub request_update  sub request_update
862  {  {
863      my($class, $his_release, $last_update)= @_;      my($class, $his_release, $last_update, $update_thru)= @_;
864    
865      #      #
866      # Verify input.      # Verify input.
# Line 820  Line 871 
871          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";
872      }      }
873    
874        if ($update_thru eq "")
875        {
876            $update_thru = time + 10000;
877        }
878    
879      #      #
880      # 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
881      # 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 892  Line 948 
948    
949                  if ((($fid, $anno_time, $who, $anno_text) =                  if ((($fid, $anno_time, $who, $anno_text) =
950                       ($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
951                      $anno_time > $last_update)                      $anno_time > $last_update and
952                        $anno_time < $update_thru)
953    
954                  {                  {
955                      #                      #
# Line 1031  Line 1088 
1088      open(my $fh, ">$spool_dir/INFO");      open(my $fh, ">$spool_dir/INFO");
1089      print $fh "requestor_release\t$his_release\n";      print $fh "requestor_release\t$his_release\n";
1090      print $fh "last_update\t$last_update\n";      print $fh "last_update\t$last_update\n";
1091        print $fh "update_thru\t$update_thru\n";
1092      print $fh "cur_update\t$now\n";      print $fh "cur_update\t$now\n";
1093      print $fh "target_release\t$my_release\n";      print $fh "target_release\t$my_release\n";
1094      print $fh "compatible\t$compatible\n";      print $fh "compatible\t$compatible\n";

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3