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

Diff of /FigKernelPackages/FIG.pm

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

revision 1.465, Thu May 4 20:05:54 2006 UTC revision 1.466, Fri May 5 14:38:00 2006 UTC
# Line 467  Line 467 
467  ### requires "delete_genomes"  ### requires "delete_genomes"
468  ###  ###
469  sub mark_deleted_genomes {  sub mark_deleted_genomes {
470      my($self,$genomes) = @_;      my($self,$user,$genomes) = @_;
471      my($genome);      my($genome);
472    
473      my $x = join(",",@$genomes);      foreach $genome (@$genomes)
474      &log_update("mark_deleted_genomes\t$x");      {
475            $self->log_update($user,$genome,$self->genus_species($genome),"Marked Deleted Genome $genome");
476        }
477        return $self->mark_deleted_genomes_body($user,$genomes);
478    }
479    
480    sub mark_deleted_genomes_body {
481        my($self,$user,$genomes) = @_;
482        my($genome);
483    
484      my $rdbH = $self->db_handle;      my $rdbH = $self->db_handle;
485    
# Line 486  Line 494 
494          }          }
495          close(DEL);          close(DEL);
496      }      }
497        $self->{_is_genome} = {};
498      return $n;      return $n;
499  }  }
500    
501  sub unmark_deleted_genomes {  sub unmark_deleted_genomes {
502      my($self,$genomes) = @_;      my($self,$user,$genomes) = @_;
503      my($genome);      my($genome);
504    
505      my $x = join(",",@$genomes);      foreach $genome (@$genomes)
506      &log_update("unmark_deleted_genomes\t$x");      {
507            $self->log_update($user,$genome,$self->genus_species($genome),"Unmarked Deleted Genome $genome");
508        }
509    
510      my $rdbH = $self->db_handle;      my $rdbH = $self->db_handle;
511    
512      my $n = 0;      my $n = 0;
# Line 507  Line 519 
519              $n++;              $n++;
520          }          }
521      }      }
522        $self->{_is_genome} = {};
523      return $n;      return $n;
524  }  }
525    
526    sub replace_genome {
527        my($self,$user,$old_genome,$genomeF, $mapping, $force, $skipnr) = @_;
528    
529        ($genomeF =~ /(\d+\.\d+)$/)
530            || die "$genomeF must have a valid genome ID as the last part of the path";
531        my $genome = $1;
532    
533        open(TMP,"<$genomeF/GENOME") || die "could not open $genome/GENOME";
534        my $gs = <TMP>;
535        chomp $gs;
536        close(TMP);
537    
538        $self->log_update($user,$genome,$gs,"Replaced genome $old_genome with $genome\n$genomeF $force $skipnr",$genomeF,$mapping);
539    
540        $self->mark_deleted_genomes($user,[$old_genome]);
541        return $self->add_genome_body($user,$genomeF,$force,$skipnr);
542    }
543    
544  =head3 add_genome  =head3 add_genome
545    
546  C<< my $ok = $fig->add_genome($genomeF, $force, $skipnr); >>  C<< my $ok = $fig->add_genome($genomeF, $force, $skipnr); >>
# Line 546  Line 577 
577  =cut  =cut
578  #: Return Type $;  #: Return Type $;
579  sub add_genome {  sub add_genome {
580      my($self,$genomeF, $force, $skipnr, $dont_mark_complete) = @_;      my($self,$user,$genomeF, $force, $skipnr, $dont_mark_complete) = @_;
581    
582        ($genomeF =~ /(\d+\.\d+)$/)
583            || die "$genomeF must have a valid genome ID as the last part of the path";
584        my $genome = $1;
585    
586      &log_update("add_genome $genomeF $force $skipnr $dont_mark_complete",$genomeF);      open(TMP,"<$genomeF/GENOME") || die "could not open $genome/GENOME";
587        my $gs = <TMP>;
588        chomp $gs;
589        close(TMP);
590    
591        $self->log_update($user,$genome,$gs,"Added genome $genome\n$genomeF $force $skipnr",$genomeF);
592    
593        return $self->add_genome_body($user,$genomeF,$force,$skipnr,$dont_mark_complete);
594    }
595    
596    sub add_genome_body {
597        my($self,$user,$genomeF, $force, $skipnr,$dont_mark_complete) = @_;
598    
599      my $rc = 0;      my $rc = 0;
600    
# Line 632  Line 678 
678      return $rc;      return $rc;
679  }  }
680    
681    sub get_index {
682        my($self,$gs) = @_;
683    
684        my($index,$max);
685        $gs || confess "MISSING GS";
686    
687        my $indexF = "$FIG_Config::data/LOGS/GenomeLog/index";
688        if (open(INDEX,"<$indexF"))
689        {
690            while ((! $index) && ($_ = <INDEX>))
691            {
692                if ($_ =~ /^(\d+)/)
693                {
694                    $max = $1;
695                    if (($_ =~ /^(\d+)\t(\S.*\S)/) && ($2 eq $gs))
696                    {
697                        $index = $1;
698                    }
699                }
700            }
701            close(INDEX);
702        }
703    
704        if (! $index)
705        {
706            open(INDEX,">>$indexF") || die "could not open $indexF";
707            $index = defined($max) ? $max+1 : 1;
708            print INDEX "$index\t$gs\n";
709            close(INDEX);
710            &verify_dir("$FIG_Config::data/LOGS/GenomeLog/Entries/$index");
711        }
712        return $index;
713    }
714    
715  sub log_update {  sub log_update {
716      my($msg,@data) = @_;      my($self,$user,$genome,$gs,$msg,@data) = @_;
717    
718      my $time_made = time;      my $time_made = time;
719      &verify_dir("$FIG_Config::data/Logs/Tars");      &verify_dir("$FIG_Config::data/LOGS/GenomeLog");
720        my $index_id = $self->get_index($gs);
721        $index_id || die "could not make an index entry for $gs";
722        my $gs_dir = "$FIG_Config::data/LOGS/GenomeLog/Entries/$index_id";
723    
724      my($i,$file_or_dir,@tars);      my($i,$file_or_dir,@tars);
725      for ($i=0; ($i < @data); $i++)      for ($i=0; ($i < @data); $i++)
726      {      {
# Line 650  Line 734 
734          {          {
735              ($dir,$file) = (".",$file_or_dir);              ($dir,$file) = (".",$file_or_dir);
736          }          }
737          my $tar = "$FIG_Config::data/Logs/Tars/$time_made.$i.tgz";          my $tar = "$gs_dir/$time_made.$i.tgz";
738          &run("cd $dir; tar czf $tar $file");          &run("cd $dir; tar czf $tar $file");
739          push(@tars,$tar);          push(@tars,$tar);
740      }      }
741      open(LOG,">>$FIG_Config::data/Logs/update.log")      open(LOG,">>$gs_dir/log")
742          || die "could not open $FIG_Config::data/Logs/update.log";          || die "could not open $gs_dir/log";
743      print LOG "$time_made\t$msg\t",join(",",@tars),"\n";      print LOG "$time_made\n$user\n$genome\n$msg\n";
744        if (@tars > 0)
745        {
746            print LOG join(",",@tars),"\n";
747        }
748        print LOG "//\n";
749      close(LOG);      close(LOG);
750  }  }
751    
   
752  =head3 parse_genome_args  =head3 parse_genome_args
753    
754  C<< my ($mode, @genomes) = FIG::parse_genome_args(@args); >>  C<< my ($mode, @genomes) = FIG::parse_genome_args(@args); >>
# Line 6823  Line 6911 
6911    
6912      $txt .= " return 1; }\n";      $txt .= " return 1; }\n";
6913    
6914      print STDERR "Filter text: $txt\n";      #print STDERR "Filter text: $txt\n";
6915    
6916      my $initial_filter = eval $txt;      my $initial_filter = eval $txt;
6917    
# Line 7073  Line 7161 
7161    
7162      my $ua = LWP::UserAgent->new();      my $ua = LWP::UserAgent->new();
7163      my $req = "$url?$args";      my $req = "$url?$args";
7164      print STDERR "Request $req\n";      # print STDERR "Request $req\n";
7165    
7166      my @sims;      my @sims;
7167      my $tail;      my $tail;
# Line 7083  Line 7171 
7171      # as they come in from the server.      # as they come in from the server.
7172      #      #
7173      my $cb = sub {      my $cb = sub {
7174  #       eval {          eval {
7175              my $c = $tail . shift;              my $c = $tail . shift;
7176                local $/ = "\n";
7177    
7178                my @lines = split(/\n/, $c);
7179    
7180              #   print "GOT <$c>\n";              if (substr($c, -1, 1) ne "\n")
             while ($c =~ s/^([^\n]*)\n//gs)  
7181              {              {
7182                  my @s = split(/\t/, $1);                  $tail = pop(@lines);
7183                  @s > 8 or next;  #               print "Frag, tail=$tail\n";
7184                }
7185    
7186                for my $l (@lines)
7187                {
7188                    my @s = split(/\t/, $l);
7189                    if (@s < 9)
7190                    {
7191    #                   print STDERR "Bad line '$l'\n";
7192                        next;
7193                    }
7194    
7195                    my $id1 = $s[0];
7196                  my $id2 = $s[1];                  my $id2 = $s[1];
7197                  next if ($self->is_deleted_fid($id2));                  if ($self->is_deleted_fid($id2))
7198                    {
7199    #                   print STDERR "is deleted $id2\n";
7200                        next;
7201                    }
7202                  if ($seen->{$id2})                  if ($seen->{$id2})
7203                  {                  {
7204    #                   print STDERR "already seen $id1 $id2\n";
7205                      next;                      next;
7206                  }                  }
7207                  else                  else
7208                  {                  {
7209    #                   print STDERR "take $id1 $id2\n";
7210                      $seen->{$id2} = 1;                      $seen->{$id2} = 1;
7211                  }                  }
7212    
# Line 7106  Line 7214 
7214  #               $s[14] =~ s/blastp/blastp_net/;  #               $s[14] =~ s/blastp/blastp_net/;
7215                  push(@sims, bless \@s, 'Sim');                  push(@sims, bless \@s, 'Sim');
7216              }              }
7217              $tail = $c;  #           $tail = $c;
7218  #           print "TAIL <$tail>\n";  #           print "TAIL <$tail>\n";
7219  #       }; $@ and print STDERR "Failed with $@";          }; $@ and print STDERR "Failed with $@";
7220      };      };
7221    
7222      my $resp = $ua->get($req, ':content_cb' => $cb);      my $resp = $ua->get($req, ':content_cb' => $cb);
# Line 14595  Line 14703 
14703    
14704  =head3 delete_feature  =head3 delete_feature
14705    
14706  usage: $fig->delete_feature($fid)  usage: $fig->delete_feature($user,$fid)
14707    
14708  Invoking this routine deletes the feature designated by $fid.  Invoking this routine deletes the feature designated by $fid.
14709    
14710  =cut  =cut
14711    
14712  sub delete_feature {  sub delete_feature {
14713      my($self,$fid) = @_;      my($self,$user,$fid) = @_;
14714    
     &log_update("delete_feature $fid");  
14715      my $genome = &genome_of($fid);      my $genome = &genome_of($fid);
14716        $self->log_update($user,$genome,$self->genus_species($genome),"Deleted Feature $fid");
14717      my $type   = &ftype($fid);      my $type   = &ftype($fid);
14718      my $dbh = $self->db_handle();      my $dbh = $self->db_handle();
14719      my $file = $self->table_exists('deleted_fids') ? "$FIG_Config::organisms/$genome/Features/$type/deleted.features"      my $file = $self->table_exists('deleted_fids') ? "$FIG_Config::organisms/$genome/Features/$type/deleted.features"
# Line 14625  Line 14733 
14733  }  }
14734    
14735  sub undelete_feature {  sub undelete_feature {
14736      my($self,$fid) = @_;      my($self,$user,$fid) = @_;
14737    
14738      my $genome = &genome_of($fid);      my $genome = &genome_of($fid);
14739        $self->log_update($user,$genome,$self->genus_species($genome),"Undeleted Feature $fid");
14740    
14741      my $type   = &ftype($fid);      my $type   = &ftype($fid);
14742      my $dbh = $self->db_handle();      my $dbh = $self->db_handle();
14743      &undelete_from_file($fid,"$FIG_Config::global/deleted.features");      &undelete_from_file($fid,"$FIG_Config::global/deleted.features");
# Line 14661  Line 14771 
14771    
14772  =head3 add_feature  =head3 add_feature
14773    
14774  C<< my $fid = $fig->add_feature($genome,$type,$location,$aliases,$translation,$fid); >>  C<< my $fid = $fig->add_feature($user,$genome,$type,$location,$aliases,$translation,$fid); >>
14775    
14776  Invoking this routine adds the feature, returning a new (generated) $fid. It is  Invoking this routine adds the feature, returning a new (generated) $fid. It is
14777  also possible to specify the feature ID, which is recommended if the feature is  also possible to specify the feature ID, which is recommended if the feature is
# Line 14708  Line 14818 
14818  =cut  =cut
14819    
14820  sub add_feature {  sub add_feature {
14821      my( $self, $genome, $type, $location, $aliases, $translation, $fid ) = @_;      my( $self, $user, $genome, $type, $location, $aliases, $translation, $fid ) = @_;
14822    
14823      my $dbh = $self->db_handle();      my $dbh = $self->db_handle();
14824    
# Line 14814  Line 14924 
14924                     . "   translation = $translation\n";                     . "   translation = $translation\n";
14925      }      }
14926    
14927      &log_update("add_feature\t$fid\t$fidN\t$type\t$genome\t$location\t$contig\t$beg\t$end\t$aliases\t$translation");      $self->log_update($user,$genome,$self->genus_species($genome),"Added Feature $fid at $contig\_$beg\_$end");
14928    
14929      &add_tbl_entry( $fid, $location, $aliasesT );      &add_tbl_entry( $fid, $location, $aliasesT );
14930    
# Line 14887  Line 14997 
14997  }  }
14998    
14999  sub replace_feature_with {  sub replace_feature_with {
15000      my($self,$from_fid,$to_fid) = @_;      my($self,$user,$from_fid,$to_fid) = @_;
   
     &log_update("replace_feature_with\t$from_fid\t$to_fid");  
15001    
15002      my $genome = &genome_of($from_fid);      my $genome = &genome_of($from_fid);
15003        $self->log_update($user,$genome,$self->genus_species($genome),"Replaced Feature $from_fid with $to_fid");
15004    
15005      my $type   = &ftype($from_fid);      my $type   = &ftype($from_fid);
15006      if (($genome ne &genome_of($to_fid)) || ($type ne &ftype($to_fid))) { return undef }      if (($genome ne &genome_of($to_fid)) || ($type ne &ftype($to_fid))) { return undef }
15007    

Legend:
Removed from v.1.465  
changed lines
  Added in v.1.466

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3