Puppet::VcsTools::History - TK GUI for VcsTools::History

 require VcsTools::DataSpec::HpTnd ; # for instance
 # could be VcsTools::DataSpec::Rcs

 my $ds = new VcsTools::DataSpec::HpTnd ; # ditto

 my $hist = new Puppet::VcsTools::History 
  (
   dbHash => \%dbhash,         # for permanent data storage
   keyRoot => 'history root',  # key for permanent data storage
   'topTk' => $mw,
   name => 'Foo history',
   dataScanner => $ds          # log analyser
  );

package Puppet::VcsTools::History ;

use strict;
use Puppet::Show ;
use Puppet::VcsTools::Version ;
use Carp ;

use base 'VcsTools::History' ;

use vars qw($VERSION);

use AutoLoader qw/AUTOLOAD/ ;

$VERSION = sprintf "%d.%03d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;

sub new
  {
    my $type = shift ;
    my %args = @_ ;

    my $self = {};
    $self->{name}=$args{name};

    $self->{body} = new Puppet::Show
      (
       cloth => $self,
       podName => 'Puppet::VcsTools::History',
       podSection => 'WIDGET USAGE',
       @_
      ) ;

    my $usage = $self->{usage} = $args{usage} || 'File' ;

    #carp "new $type $args{name}: usage is deprecated" 
    #  if defined $args{usage};

    # we can't deprecate usage until the version list problem is
    # sorted.  version list is stored in the DB_file, while the SQL
    # interface rebuilds it. This leads to 2 different behaviors,
    # hence the usage parameter.  The solution could be to re-build
    # the version list from the keys of the DB_File even though this
    # is not efficient.

    # then again ,there's the problem of the historyUpdateTime ...

    if (defined $args{storageArgs})
      {
        # transition code, should be removed sooner or later
        my %storeArgs = %{$args{storageArgs}} ;
        carp "new $type $args{name}: storageArgs is deprecated";
        if ($usage eq 'MySql')
          {
            require VcsTools::HistSqlStorage;
            $args{storage} = new VcsTools::HistSqlStorage (%storeArgs) ;
          }
        else
          {
            $args{storage} =  new Puppet::Storage (name => $self->{name},
                                                   %storeArgs) ;
          }
        $self->{storageArgs}=$args{storageArgs};
      }


    # mandatory parameter
    foreach (qw/name dataScanner topTk storage/)
      {
        croak "No $_ passed to $self->{name}\n" unless 
          defined $args{$_};
        $self->{$_} = delete $args{$_} ;
      }

    bless $self,$type ;
  }

1;

__END__

#internal do not call from outside because there's no sanity checks
sub createVersionObj
  {
    my $self = shift ;
    my $rev = shift ;

    $self->{body}->printDebug("Creating puppet version object for rev $rev\n");
    
    my @store = defined $self->{storageArgs} ? 
      (storageArgs => $self->{storageArgs}) :
      (storage => $self->{storage} -> child(name => $rev)) ;

    return new Puppet::VcsTools::Version  
      (
       name => $rev,
       title => "$self->{name} v$rev",
       topTk => $self->{topTk},
       dataFormat => $self->{dataScanner}->getDescription,
       usage => $self->{usage},
       # this closure could be improved for performance with a cache
       # but the cleanup of cached versions object can be a problem
       getBrotherSub => sub{$self->getVersionObj(@_);},
       @store,
       revision => $rev
      ) ;
  }

sub getTreeGraph
  {
    my $self = shift ;
    return undef unless defined $self->{body}->myDisplay();

    return  $self->{body}->myDisplay()->getSlave($self->{treeName}) ;
  }

sub getInfoWidget
  {
    my $self = shift ;
    return undef unless defined $self->{body}->myDisplay();
    return  $self->{body}->myDisplay()->getSlave($self->{textName});
  }


sub display
  {
    my $self = shift ;

    my $top = $self->{body}->display (@_);

    return unless defined $top;
 
    require Puppet::VcsTools::GraphWidget ;

    $self->{treeName} = 'history graph';
    my $tree = $top ->newSlave
      (
       type => 'MultiVcsGraph', 
       title => $self->{treeName}
      );

    require Tk::Menubutton;

    $tree->addRev(@{$self->{storage}->getDbInfo('versionList')}) ;

    # a garder TBD ?
    $self->{textName}=$self->{name};
    $top -> newSlave
        (
         'type' => 'MultiText', 
         'title' => $self->{textName},
         'hidden' => 0 ,
         'help' => 'This text window display the results of the operations '.
         'invoked within the History graph widget'
        );


    # must add menu button related to the graph funcionnality
    # i.e draw, merge, show diff
    # these function will ask for currently selected nodes


    $tree->command(on => 'menu', -label=>'unselect all', 
                   command => sub{$tree->unselectAllNodes();});

    $tree->command
      (
       on => 'menu',
       -label=>'show cumulated log', 
       command => sub
       {
         my $info = $self->buildCumulatedInfo($tree->getSelectedNodes()) ;
         my $str = $self->{dataScanner}->buildLogString($info) ;
         $self->showResult($self->{dataScanner}->buildLogString($info));
       }
      );

    $tree->Subwidget('list')->bind
      (
       '<Double-1>' => sub 
       {
         my $item = shift ;
         my $rev = $item->get ('active') ;
         $self->body()->printEvent("drawing tree from rev $rev\n") ;
         $self->drawTree(revision =>$rev) ;
       }
      ) ;

    my $showLog = sub 
      {
        my %args = @_ ;
        my $str = $self->getLog(version => $args{to} || $args{nodeId}, 
                                key => 'log');
        $self->showResult($str) ;
      } ;
    
    my $showFullLog = sub 
      {
        my %args = @_ ;
        my $str = $self->getLog(version => $args{to}|| $args{nodeId});
        $self->showResult($str) ;
      } ;
    
    $tree->arrowBind
      (
       button => '<1>',
       color => 'red', 
       command => $showLog
      ) ;

    $tree->command 
      (
       on => 'arrow', 
       label => 'show log', 
       command => $showLog
      ) ;

    $tree->command 
      (
       on => 'arrow', 
       label => 'show full log', 
       command => $showFullLog
      ) ;
    
    $tree->command 
      (
       on => 'node', 
       label => 'show log', 
       command => $showLog
      ) ;

    $tree->command 
      (
       on => 'node', 
       label => 'show full log', 
       command => $showFullLog
      ) ;
    
    $tree->arrowBind
      (
       button => '<3>',
       color => 'orange', 
       command => sub {$tree->popupMenu(@_);}
      ) ;

    # bind double-1 to redraw the whole graph 
    $tree->nodeBind
      (
       button =>  '<Double-1>',
       color =>   'black', 
       command => sub {$self->drawTree(@_)}
      );

    # bind button <3> on nodes to pop up a menu
    $tree->nodeBind
      (
       button =>  '<3>',
       color =>   'red', 
       command => sub {$tree->popupMenu(@_);}
      ) ;

    $tree->command
      (
       on => 'node',
       label =>'draw from here',
       command => sub {$self->drawTree(@_)}
      );

    $tree->command
      (
       on => 'node',
       label => 'open version object',
       command => sub 
       {
         my %args = @_ ;
         $self->{body}->getContent($args{nodeId})->cloth()->display() ;
       }
      ) ;

    return $top ;
  }

sub closeDisplay
  {
    my $self = shift ;
    $self->{body}->closeDisplay();
  }
  

#internal
sub showResult
  {
    my $self = shift ;
    
    return unless defined $self->{body}->myDisplay();

    my $txt = $self->{body}->myDisplay()->getSlave($self->{textName}) ;
    $txt -> clear();
    my $ref =shift ;
    my $str = ref($ref) eq 'ARRAY' ? join("\n",@$ref) : $ref ;

    $txt->insertText($str) ;
  }

sub drawTree
  {
    my $self = shift ;
    my %args = @_ ;

    return unless defined $self->{body}->myDisplay();
    my $tree = $self->{body}->myDisplay()->getSlave($self->{treeName});
    $self->{drawRoot}=$args{revision} || $args{nodeId} || $self->{drawRoot} ;
    return unless defined $self->{drawRoot};

    $self->getVersionObj($self->{drawRoot})->drawTree($tree);
  }

# called to add a new version of the file (after an archive)
sub addNewVersion
   {
     my $self = shift ;

     my $obj = $self->SUPER::addNewVersion(@_);

     return unless defined $self->{body}->myDisplay();
     my $tree = $self->{body}->myDisplay()->getSlave($self->{treeName});
     $tree->addRev($obj->getRevision()) ;
     
     $self->drawTree();
   }

sub update
  {
    my $self = shift ;
    
    if (defined $self->{body}->myDisplay())
      {
        my $tree = $self->{body}->myDisplay()->getSlave($self->{treeName});
        $tree->Subwidget('graph')-> clear ;
        $tree->Subwidget('list')->delete(0,'end');
      } ;
    
    $self->SUPER::update(@_);
    
    if (defined $self->{body}->myDisplay())
      {
        my $tree = $self->{body}->myDisplay()->getSlave($self->{treeName});
        $tree->addRev(@{$self->{storage}->getDbInfo('versionList')}) ;

        $self->drawTree;
      }
  }
1;



# Pas testee
# sub findMerge
#   {
#     my $self = shift ;
#     my $rev1 = shift ;
#     my $rev2 = shift ;

#     # find in history if rev1 and rev2 are merged. return the merge version
#     foreach (("$rev1-$rev2","$rev2-$rev1"))
#       {
#         if (defined $self->{myDbHash}{info}{mergeList}{$_}) 
#           {
#             my $rev =  $self->{myDbHash}{info}{mergeList}{$_} ;

#             while ($self->{myDbHash}{state} eq 'Dead')
#               {
#                 my $old = $rev ;
#                 $rev = $self->{myDbHash}{lower} ;
#                 unless (defined $rev)
#                   {
#                     croak "Found Dead $self->{name} version $old for merge\n"  ;
#                     return undef ;
#                   } 
#               }
#             return $rev ;
#           }
#       }

#     return undef ;
#   }