git-cvsserver.perlon commit Merge part of np/delta (d00e0f8)
   1#!/usr/bin/perl
   2
   3####
   4#### This application is a CVS emulation layer for git.
   5#### It is intended for clients to connect over SSH.
   6#### See the documentation for more details.
   7####
   8#### Copyright The Open University UK - 2006.
   9####
  10#### Authors: Martyn Smith    <martyn@catalyst.net.nz>
  11####          Martin Langhoff <martin@catalyst.net.nz>
  12####
  13####
  14#### Released under the GNU Public License, version 2.
  15####
  16####
  17
  18use strict;
  19use warnings;
  20
  21use Fcntl;
  22use File::Temp qw/tempdir tempfile/;
  23use File::Basename;
  24
  25my $log = GITCVS::log->new();
  26my $cfg;
  27
  28my $DATE_LIST = {
  29    Jan => "01",
  30    Feb => "02",
  31    Mar => "03",
  32    Apr => "04",
  33    May => "05",
  34    Jun => "06",
  35    Jul => "07",
  36    Aug => "08",
  37    Sep => "09",
  38    Oct => "10",
  39    Nov => "11",
  40    Dec => "12",
  41};
  42
  43# Enable autoflush for STDOUT (otherwise the whole thing falls apart)
  44$| = 1;
  45
  46#### Definition and mappings of functions ####
  47
  48my $methods = {
  49    'Root'            => \&req_Root,
  50    'Valid-responses' => \&req_Validresponses,
  51    'valid-requests'  => \&req_validrequests,
  52    'Directory'       => \&req_Directory,
  53    'Entry'           => \&req_Entry,
  54    'Modified'        => \&req_Modified,
  55    'Unchanged'       => \&req_Unchanged,
  56    'Argument'        => \&req_Argument,
  57    'Argumentx'       => \&req_Argument,
  58    'expand-modules'  => \&req_expandmodules,
  59    'add'             => \&req_add,
  60    'remove'          => \&req_remove,
  61    'co'              => \&req_co,
  62    'update'          => \&req_update,
  63    'ci'              => \&req_ci,
  64    'diff'            => \&req_diff,
  65    'log'             => \&req_log,
  66    'tag'             => \&req_CATCHALL,
  67    'status'          => \&req_status,
  68    'admin'           => \&req_CATCHALL,
  69    'history'         => \&req_CATCHALL,
  70    'watchers'        => \&req_CATCHALL,
  71    'editors'         => \&req_CATCHALL,
  72    'annotate'        => \&req_annotate,
  73    'Global_option'   => \&req_Globaloption,
  74    #'annotate'        => \&req_CATCHALL,
  75};
  76
  77##############################################
  78
  79
  80# $state holds all the bits of information the clients sends us that could
  81# potentially be useful when it comes to actually _doing_ something.
  82my $state = {};
  83$log->info("--------------- STARTING -----------------");
  84
  85my $TEMP_DIR = tempdir( CLEANUP => 1 );
  86$log->debug("Temporary directory is '$TEMP_DIR'");
  87
  88# Keep going until the client closes the connection
  89while (<STDIN>)
  90{
  91    chomp;
  92
  93    # Check to see if we've seen this method, and call appropiate function.
  94    if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
  95    {
  96        # use the $methods hash to call the appropriate sub for this command
  97        #$log->info("Method : $1");
  98        &{$methods->{$1}}($1,$2);
  99    } else {
 100        # log fatal because we don't understand this function. If this happens
 101        # we're fairly screwed because we don't know if the client is expecting
 102        # a response. If it is, the client will hang, we'll hang, and the whole
 103        # thing will be custard.
 104        $log->fatal("Don't understand command $_\n");
 105        die("Unknown command $_");
 106    }
 107}
 108
 109$log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
 110$log->info("--------------- FINISH -----------------");
 111
 112# Magic catchall method.
 113#    This is the method that will handle all commands we haven't yet
 114#    implemented. It simply sends a warning to the log file indicating a
 115#    command that hasn't been implemented has been invoked.
 116sub req_CATCHALL
 117{
 118    my ( $cmd, $data ) = @_;
 119    $log->warn("Unhandled command : req_$cmd : $data");
 120}
 121
 122
 123# Root pathname \n
 124#     Response expected: no. Tell the server which CVSROOT to use. Note that
 125#     pathname is a local directory and not a fully qualified CVSROOT variable.
 126#     pathname must already exist; if creating a new root, use the init
 127#     request, not Root. pathname does not include the hostname of the server,
 128#     how to access the server, etc.; by the time the CVS protocol is in use,
 129#     connection, authentication, etc., are already taken care of. The Root
 130#     request must be sent only once, and it must be sent before any requests
 131#     other than Valid-responses, valid-requests, UseUnchanged, Set or init.
 132sub req_Root
 133{
 134    my ( $cmd, $data ) = @_;
 135    $log->debug("req_Root : $data");
 136
 137    $state->{CVSROOT} = $data;
 138
 139    $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
 140
 141    foreach my $line ( `git-var -l` )
 142    {
 143        next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
 144        $cfg->{$1}{$2} = $3;
 145    }
 146
 147    unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
 148    {
 149        print "E GITCVS emulation needs to be enabled on this repo\n";
 150        print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
 151        print "E \n";
 152        print "error 1 GITCVS emulation disabled\n";
 153    }
 154
 155    if ( defined ( $cfg->{gitcvs}{logfile} ) )
 156    {
 157        $log->setfile($cfg->{gitcvs}{logfile});
 158    } else {
 159        $log->nofile();
 160    }
 161}
 162
 163# Global_option option \n
 164#     Response expected: no. Transmit one of the global options `-q', `-Q',
 165#     `-l', `-t', `-r', or `-n'. option must be one of those strings, no
 166#     variations (such as combining of options) are allowed. For graceful
 167#     handling of valid-requests, it is probably better to make new global
 168#     options separate requests, rather than trying to add them to this
 169#     request.
 170sub req_Globaloption
 171{
 172    my ( $cmd, $data ) = @_;
 173    $log->debug("req_Globaloption : $data");
 174
 175    # TODO : is this data useful ???
 176}
 177
 178# Valid-responses request-list \n
 179#     Response expected: no. Tell the server what responses the client will
 180#     accept. request-list is a space separated list of tokens.
 181sub req_Validresponses
 182{
 183    my ( $cmd, $data ) = @_;
 184    $log->debug("req_Validrepsonses : $data");
 185
 186    # TODO : re-enable this, currently it's not particularly useful
 187    #$state->{validresponses} = [ split /\s+/, $data ];
 188}
 189
 190# valid-requests \n
 191#     Response expected: yes. Ask the server to send back a Valid-requests
 192#     response.
 193sub req_validrequests
 194{
 195    my ( $cmd, $data ) = @_;
 196
 197    $log->debug("req_validrequests");
 198
 199    $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
 200    $log->debug("SEND : ok");
 201
 202    print "Valid-requests " . join(" ",keys %$methods) . "\n";
 203    print "ok\n";
 204}
 205
 206# Directory local-directory \n
 207#     Additional data: repository \n. Response expected: no. Tell the server
 208#     what directory to use. The repository should be a directory name from a
 209#     previous server response. Note that this both gives a default for Entry
 210#     and Modified and also for ci and the other commands; normal usage is to
 211#     send Directory for each directory in which there will be an Entry or
 212#     Modified, and then a final Directory for the original directory, then the
 213#     command. The local-directory is relative to the top level at which the
 214#     command is occurring (i.e. the last Directory which is sent before the
 215#     command); to indicate that top level, `.' should be sent for
 216#     local-directory.
 217sub req_Directory
 218{
 219    my ( $cmd, $data ) = @_;
 220
 221    my $repository = <STDIN>;
 222    chomp $repository;
 223
 224
 225    $state->{localdir} = $data;
 226    $state->{repository} = $repository;
 227    $state->{directory} = $repository;
 228    $state->{directory} =~ s/^$state->{CVSROOT}\///;
 229    $state->{module} = $1 if ($state->{directory} =~ s/^(.*?)(\/|$)//);
 230    $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
 231
 232    $log->debug("req_Directory : localdir=$data repository=$repository directory=$state->{directory} module=$state->{module}");
 233}
 234
 235# Entry entry-line \n
 236#     Response expected: no. Tell the server what version of a file is on the
 237#     local machine. The name in entry-line is a name relative to the directory
 238#     most recently specified with Directory. If the user is operating on only
 239#     some files in a directory, Entry requests for only those files need be
 240#     included. If an Entry request is sent without Modified, Is-modified, or
 241#     Unchanged, it means the file is lost (does not exist in the working
 242#     directory). If both Entry and one of Modified, Is-modified, or Unchanged
 243#     are sent for the same file, Entry must be sent first. For a given file,
 244#     one can send Modified, Is-modified, or Unchanged, but not more than one
 245#     of these three.
 246sub req_Entry
 247{
 248    my ( $cmd, $data ) = @_;
 249
 250    $log->debug("req_Entry : $data");
 251
 252    my @data = split(/\//, $data);
 253
 254    $state->{entries}{$state->{directory}.$data[1]} = {
 255        revision    => $data[2],
 256        conflict    => $data[3],
 257        options     => $data[4],
 258        tag_or_date => $data[5],
 259    };
 260}
 261
 262# add \n
 263#     Response expected: yes. Add a file or directory. This uses any previous
 264#     Argument, Directory, Entry, or Modified requests, if they have been sent.
 265#     The last Directory sent specifies the working directory at the time of
 266#     the operation. To add a directory, send the directory to be added using
 267#     Directory and Argument requests.
 268sub req_add
 269{
 270    my ( $cmd, $data ) = @_;
 271
 272    argsplit("add");
 273
 274    my $addcount = 0;
 275
 276    foreach my $filename ( @{$state->{args}} )
 277    {
 278        $filename = filecleanup($filename);
 279
 280        unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
 281        {
 282            print "E cvs add: nothing known about `$filename'\n";
 283            next;
 284        }
 285        # TODO : check we're not squashing an already existing file
 286        if ( defined ( $state->{entries}{$filename}{revision} ) )
 287        {
 288            print "E cvs add: `$filename' has already been entered\n";
 289            next;
 290        }
 291
 292
 293        my ( $filepart, $dirpart ) = filenamesplit($filename);
 294
 295        print "E cvs add: scheduling file `$filename' for addition\n";
 296
 297        print "Checked-in $dirpart\n";
 298        print "$filename\n";
 299        print "/$filepart/0///\n";
 300
 301        $addcount++;
 302    }
 303
 304    if ( $addcount == 1 )
 305    {
 306        print "E cvs add: use `cvs commit' to add this file permanently\n";
 307    }
 308    elsif ( $addcount > 1 )
 309    {
 310        print "E cvs add: use `cvs commit' to add these files permanently\n";
 311    }
 312
 313    print "ok\n";
 314}
 315
 316# remove \n
 317#     Response expected: yes. Remove a file. This uses any previous Argument,
 318#     Directory, Entry, or Modified requests, if they have been sent. The last
 319#     Directory sent specifies the working directory at the time of the
 320#     operation. Note that this request does not actually do anything to the
 321#     repository; the only effect of a successful remove request is to supply
 322#     the client with a new entries line containing `-' to indicate a removed
 323#     file. In fact, the client probably could perform this operation without
 324#     contacting the server, although using remove may cause the server to
 325#     perform a few more checks. The client sends a subsequent ci request to
 326#     actually record the removal in the repository.
 327sub req_remove
 328{
 329    my ( $cmd, $data ) = @_;
 330
 331    argsplit("remove");
 332
 333    # Grab a handle to the SQLite db and do any necessary updates
 334    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 335    $updater->update();
 336
 337    #$log->debug("add state : " . Dumper($state));
 338
 339    my $rmcount = 0;
 340
 341    foreach my $filename ( @{$state->{args}} )
 342    {
 343        $filename = filecleanup($filename);
 344
 345        if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
 346        {
 347            print "E cvs remove: file `$filename' still in working directory\n";
 348            next;
 349        }
 350
 351        my $meta = $updater->getmeta($filename);
 352        my $wrev = revparse($filename);
 353
 354        unless ( defined ( $wrev ) )
 355        {
 356            print "E cvs remove: nothing known about `$filename'\n";
 357            next;
 358        }
 359
 360        if ( defined($wrev) and $wrev < 0 )
 361        {
 362            print "E cvs remove: file `$filename' already scheduled for removal\n";
 363            next;
 364        }
 365
 366        unless ( $wrev == $meta->{revision} )
 367        {
 368            # TODO : not sure if the format of this message is quite correct.
 369            print "E cvs remove: Up to date check failed for `$filename'\n";
 370            next;
 371        }
 372
 373
 374        my ( $filepart, $dirpart ) = filenamesplit($filename);
 375
 376        print "E cvs remove: scheduling `$filename' for removal\n";
 377
 378        print "Checked-in $dirpart\n";
 379        print "$filename\n";
 380        print "/$filepart/-1.$wrev///\n";
 381
 382        $rmcount++;
 383    }
 384
 385    if ( $rmcount == 1 )
 386    {
 387        print "E cvs remove: use `cvs commit' to remove this file permanently\n";
 388    }
 389    elsif ( $rmcount > 1 )
 390    {
 391        print "E cvs remove: use `cvs commit' to remove these files permanently\n";
 392    }
 393
 394    print "ok\n";
 395}
 396
 397# Modified filename \n
 398#     Response expected: no. Additional data: mode, \n, file transmission. Send
 399#     the server a copy of one locally modified file. filename is a file within
 400#     the most recent directory sent with Directory; it must not contain `/'.
 401#     If the user is operating on only some files in a directory, only those
 402#     files need to be included. This can also be sent without Entry, if there
 403#     is no entry for the file.
 404sub req_Modified
 405{
 406    my ( $cmd, $data ) = @_;
 407
 408    my $mode = <STDIN>;
 409    chomp $mode;
 410    my $size = <STDIN>;
 411    chomp $size;
 412
 413    # Grab config information
 414    my $blocksize = 8192;
 415    my $bytesleft = $size;
 416    my $tmp;
 417
 418    # Get a filehandle/name to write it to
 419    my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
 420
 421    # Loop over file data writing out to temporary file.
 422    while ( $bytesleft )
 423    {
 424        $blocksize = $bytesleft if ( $bytesleft < $blocksize );
 425        read STDIN, $tmp, $blocksize;
 426        print $fh $tmp;
 427        $bytesleft -= $blocksize;
 428    }
 429
 430    close $fh;
 431
 432    # Ensure we have something sensible for the file mode
 433    if ( $mode =~ /u=(\w+)/ )
 434    {
 435        $mode = $1;
 436    } else {
 437        $mode = "rw";
 438    }
 439
 440    # Save the file data in $state
 441    $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
 442    $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
 443    $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
 444    $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
 445
 446    #$log->debug("req_Modified : file=$data mode=$mode size=$size");
 447}
 448
 449# Unchanged filename \n
 450#     Response expected: no. Tell the server that filename has not been
 451#     modified in the checked out directory. The filename is a file within the
 452#     most recent directory sent with Directory; it must not contain `/'.
 453sub req_Unchanged
 454{
 455    my ( $cmd, $data ) = @_;
 456
 457    $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
 458
 459    #$log->debug("req_Unchanged : $data");
 460}
 461
 462# Argument text \n
 463#     Response expected: no. Save argument for use in a subsequent command.
 464#     Arguments accumulate until an argument-using command is given, at which
 465#     point they are forgotten.
 466# Argumentx text \n
 467#     Response expected: no. Append \n followed by text to the current argument
 468#     being saved.
 469sub req_Argument
 470{
 471    my ( $cmd, $data ) = @_;
 472
 473    # TODO :  Not quite sure how Argument and Argumentx differ, but I assume
 474    # it's for multi-line arguments ... somehow ...
 475
 476    $log->debug("$cmd : $data");
 477
 478    push @{$state->{arguments}}, $data;
 479}
 480
 481# expand-modules \n
 482#     Response expected: yes. Expand the modules which are specified in the
 483#     arguments. Returns the data in Module-expansion responses. Note that the
 484#     server can assume that this is checkout or export, not rtag or rdiff; the
 485#     latter do not access the working directory and thus have no need to
 486#     expand modules on the client side. Expand may not be the best word for
 487#     what this request does. It does not necessarily tell you all the files
 488#     contained in a module, for example. Basically it is a way of telling you
 489#     which working directories the server needs to know about in order to
 490#     handle a checkout of the specified modules. For example, suppose that the
 491#     server has a module defined by
 492#   aliasmodule -a 1dir
 493#     That is, one can check out aliasmodule and it will take 1dir in the
 494#     repository and check it out to 1dir in the working directory. Now suppose
 495#     the client already has this module checked out and is planning on using
 496#     the co request to update it. Without using expand-modules, the client
 497#     would have two bad choices: it could either send information about all
 498#     working directories under the current directory, which could be
 499#     unnecessarily slow, or it could be ignorant of the fact that aliasmodule
 500#     stands for 1dir, and neglect to send information for 1dir, which would
 501#     lead to incorrect operation. With expand-modules, the client would first
 502#     ask for the module to be expanded:
 503sub req_expandmodules
 504{
 505    my ( $cmd, $data ) = @_;
 506
 507    argsplit();
 508
 509    $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
 510
 511    unless ( ref $state->{arguments} eq "ARRAY" )
 512    {
 513        print "ok\n";
 514        return;
 515    }
 516
 517    foreach my $module ( @{$state->{arguments}} )
 518    {
 519        $log->debug("SEND : Module-expansion $module");
 520        print "Module-expansion $module\n";
 521    }
 522
 523    print "ok\n";
 524    statecleanup();
 525}
 526
 527# co \n
 528#     Response expected: yes. Get files from the repository. This uses any
 529#     previous Argument, Directory, Entry, or Modified requests, if they have
 530#     been sent. Arguments to this command are module names; the client cannot
 531#     know what directories they correspond to except by (1) just sending the
 532#     co request, and then seeing what directory names the server sends back in
 533#     its responses, and (2) the expand-modules request.
 534sub req_co
 535{
 536    my ( $cmd, $data ) = @_;
 537
 538    argsplit("co");
 539
 540    my $module = $state->{args}[0];
 541    my $checkout_path = $module;
 542
 543    # use the user specified directory if we're given it
 544    $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
 545
 546    $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
 547
 548    $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
 549
 550    $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
 551
 552    # Grab a handle to the SQLite db and do any necessary updates
 553    my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
 554    $updater->update();
 555
 556    # instruct the client that we're checking out to $checkout_path
 557    print "E cvs server: updating $checkout_path\n";
 558
 559    foreach my $git ( @{$updater->gethead} )
 560    {
 561        # Don't want to check out deleted files
 562        next if ( $git->{filehash} eq "deleted" );
 563
 564        ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
 565
 566        # modification time of this file
 567        print "Mod-time $git->{modified}\n";
 568
 569        # print some information to the client
 570        print "MT +updated\n";
 571        print "MT text U\n";
 572        if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
 573        {
 574            print "MT fname $checkout_path/$git->{dir}$git->{name}\n";
 575        } else {
 576            print "MT fname $checkout_path/$git->{name}\n";
 577        }
 578        print "MT newline\n";
 579        print "MT -updated\n";
 580
 581        # instruct client we're sending a file to put in this path
 582        print "Created $checkout_path/" . ( defined ( $git->{dir} ) ? $git->{dir} . "/" : "" ) . "\n";
 583
 584        print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
 585
 586        # this is an "entries" line
 587        print "/$git->{name}/1.$git->{revision}///\n";
 588        # permissions
 589        print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
 590
 591        # transmit file
 592        transmitfile($git->{filehash});
 593    }
 594
 595    print "ok\n";
 596
 597    statecleanup();
 598}
 599
 600# update \n
 601#     Response expected: yes. Actually do a cvs update command. This uses any
 602#     previous Argument, Directory, Entry, or Modified requests, if they have
 603#     been sent. The last Directory sent specifies the working directory at the
 604#     time of the operation. The -I option is not used--files which the client
 605#     can decide whether to ignore are not mentioned and the client sends the
 606#     Questionable request for others.
 607sub req_update
 608{
 609    my ( $cmd, $data ) = @_;
 610
 611    $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
 612
 613    argsplit("update");
 614
 615    # Grab a handle to the SQLite db and do any necessary updates
 616    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 617
 618    $updater->update();
 619
 620    # if no files were specified, we need to work out what files we should be providing status on ...
 621    argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
 622
 623    #$log->debug("update state : " . Dumper($state));
 624
 625    # foreach file specified on the commandline ...
 626    foreach my $filename ( @{$state->{args}} )
 627    {
 628        $filename = filecleanup($filename);
 629
 630        # if we have a -C we should pretend we never saw modified stuff
 631        if ( exists ( $state->{opt}{C} ) )
 632        {
 633            delete $state->{entries}{$filename}{modified_hash};
 634            delete $state->{entries}{$filename}{modified_filename};
 635            $state->{entries}{$filename}{unchanged} = 1;
 636        }
 637
 638        my $meta;
 639        if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
 640        {
 641            $meta = $updater->getmeta($filename, $1);
 642        } else {
 643            $meta = $updater->getmeta($filename);
 644        }
 645
 646        next unless ( $meta->{revision} );
 647
 648        my $oldmeta = $meta;
 649
 650        my $wrev = revparse($filename);
 651
 652        # If the working copy is an old revision, lets get that version too for comparison.
 653        if ( defined($wrev) and $wrev != $meta->{revision} )
 654        {
 655            $oldmeta = $updater->getmeta($filename, $wrev);
 656        }
 657
 658        #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
 659
 660        # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified _and_ the user hasn't specified -C
 661        next if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{unchanged} and not exists ( $state->{opt}{C} ) );
 662
 663        if ( $meta->{filehash} eq "deleted" )
 664        {
 665            my ( $filepart, $dirpart ) = filenamesplit($filename);
 666
 667            $log->info("Removing '$filename' from working copy (no longer in the repo)");
 668
 669            print "E cvs update: `$filename' is no longer in the repository\n";
 670            print "Removed $dirpart\n";
 671            print "$filepart\n";
 672        }
 673        elsif ( not defined ( $state->{entries}{$filename}{modified_hash} ) or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} )
 674        {
 675            $log->info("Updating '$filename'");
 676            # normal update, just send the new revision (either U=Update, or A=Add, or R=Remove)
 677            print "MT +updated\n";
 678            print "MT text U\n";
 679            print "MT fname $filename\n";
 680            print "MT newline\n";
 681            print "MT -updated\n";
 682
 683            my ( $filepart, $dirpart ) = filenamesplit($filename);
 684            $dirpart =~ s/^$state->{directory}//;
 685
 686            if ( defined ( $wrev ) )
 687            {
 688                # instruct client we're sending a file to put in this path as a replacement
 689                print "Update-existing $dirpart\n";
 690                $log->debug("Updating existing file 'Update-existing $dirpart'");
 691            } else {
 692                # instruct client we're sending a file to put in this path as a new file
 693                print "Created $dirpart\n";
 694                $log->debug("Creating new file 'Created $dirpart'");
 695            }
 696            print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 697
 698            # this is an "entries" line
 699            $log->debug("/$filepart/1.$meta->{revision}///");
 700            print "/$filepart/1.$meta->{revision}///\n";
 701
 702            # permissions
 703            $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
 704            print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
 705
 706            # transmit file
 707            transmitfile($meta->{filehash});
 708        } else {
 709            my ( $filepart, $dirpart ) = filenamesplit($meta->{name});
 710
 711            my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
 712
 713            chdir $dir;
 714            my $file_local = $filepart . ".mine";
 715            system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
 716            my $file_old = $filepart . "." . $oldmeta->{revision};
 717            transmitfile($oldmeta->{filehash}, $file_old);
 718            my $file_new = $filepart . "." . $meta->{revision};
 719            transmitfile($meta->{filehash}, $file_new);
 720
 721            # we need to merge with the local changes ( M=successful merge, C=conflict merge )
 722            $log->info("Merging $file_local, $file_old, $file_new");
 723
 724            $log->debug("Temporary directory for merge is $dir");
 725
 726            my $return = system("merge", $file_local, $file_old, $file_new);
 727            $return >>= 8;
 728
 729            if ( $return == 0 )
 730            {
 731                $log->info("Merged successfully");
 732                print "M M $filename\n";
 733                $log->debug("Update-existing $dirpart");
 734                print "Update-existing $dirpart\n";
 735                $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
 736                print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 737                $log->debug("/$filepart/1.$meta->{revision}///");
 738                print "/$filepart/1.$meta->{revision}///\n";
 739            }
 740            elsif ( $return == 1 )
 741            {
 742                $log->info("Merged with conflicts");
 743                print "M C $filename\n";
 744                print "Update-existing $dirpart\n";
 745                print $state->{CVSROOT} . "/$state->{module}/$filename\n";
 746                print "/$filepart/1.$meta->{revision}/+//\n";
 747            }
 748            else
 749            {
 750                $log->warn("Merge failed");
 751                next;
 752            }
 753
 754            # permissions
 755            $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
 756            print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
 757
 758            # transmit file, format is single integer on a line by itself (file
 759            # size) followed by the file contents
 760            # TODO : we should copy files in blocks
 761            my $data = `cat $file_local`;
 762            $log->debug("File size : " . length($data));
 763            print length($data) . "\n";
 764            print $data;
 765
 766            chdir "/";
 767        }
 768
 769    }
 770
 771    print "ok\n";
 772}
 773
 774sub req_ci
 775{
 776    my ( $cmd, $data ) = @_;
 777
 778    argsplit("ci");
 779
 780    #$log->debug("State : " . Dumper($state));
 781
 782    $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
 783
 784    if ( -e $state->{CVSROOT} . "/index" )
 785    {
 786        print "error 1 Index already exists in git repo\n";
 787        exit;
 788    }
 789
 790    my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
 791    unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
 792    {
 793        print "error 1 Lock file '$lockfile' already exists, please try again\n";
 794        exit;
 795    }
 796
 797    # Grab a handle to the SQLite db and do any necessary updates
 798    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 799    $updater->update();
 800
 801    my $tmpdir = tempdir ( DIR => $TEMP_DIR );
 802    my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
 803    $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
 804
 805    $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
 806    $ENV{GIT_INDEX_FILE} = $file_index;
 807
 808    chdir $tmpdir;
 809
 810    # populate the temporary index based
 811    system("git-read-tree", $state->{module});
 812    unless ($? == 0)
 813    {
 814        die "Error running git-read-tree $state->{module} $file_index $!";
 815    }
 816    $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
 817
 818
 819    my @committedfiles = ();
 820
 821    # foreach file specified on the commandline ...
 822    foreach my $filename ( @{$state->{args}} )
 823    {
 824        $filename = filecleanup($filename);
 825
 826        next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
 827
 828        my $meta = $updater->getmeta($filename);
 829
 830        my $wrev = revparse($filename);
 831
 832        my ( $filepart, $dirpart ) = filenamesplit($filename);
 833
 834        # do a checkout of the file if it part of this tree
 835        if ($wrev) {
 836            system('git-checkout-index', '-f', '-u', $filename);
 837            unless ($? == 0) {
 838                die "Error running git-checkout-index -f -u $filename : $!";
 839            }
 840        }
 841
 842        my $addflag = 0;
 843        my $rmflag = 0;
 844        $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
 845        $addflag = 1 unless ( -e $filename );
 846
 847        # Do up to date checking
 848        unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
 849        {
 850            # fail everything if an up to date check fails
 851            print "error 1 Up to date check failed for $filename\n";
 852            close LOCKFILE;
 853            unlink($lockfile);
 854            chdir "/";
 855            exit;
 856        }
 857
 858        push @committedfiles, $filename;
 859        $log->info("Committing $filename");
 860
 861        system("mkdir","-p",$dirpart) unless ( -d $dirpart );
 862
 863        unless ( $rmflag )
 864        {
 865            $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
 866            rename $state->{entries}{$filename}{modified_filename},$filename;
 867
 868            # Calculate modes to remove
 869            my $invmode = "";
 870            foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
 871
 872            $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
 873            system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
 874        }
 875
 876        if ( $rmflag )
 877        {
 878            $log->info("Removing file '$filename'");
 879            unlink($filename);
 880            system("git-update-index", "--remove", $filename);
 881        }
 882        elsif ( $addflag )
 883        {
 884            $log->info("Adding file '$filename'");
 885            system("git-update-index", "--add", $filename);
 886        } else {
 887            $log->info("Updating file '$filename'");
 888            system("git-update-index", $filename);
 889        }
 890    }
 891
 892    unless ( scalar(@committedfiles) > 0 )
 893    {
 894        print "E No files to commit\n";
 895        print "ok\n";
 896        close LOCKFILE;
 897        unlink($lockfile);
 898        chdir "/";
 899        return;
 900    }
 901
 902    my $treehash = `git-write-tree`;
 903    my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
 904    chomp $treehash;
 905    chomp $parenthash;
 906
 907    $log->debug("Treehash : $treehash, Parenthash : $parenthash");
 908
 909    # write our commit message out if we have one ...
 910    my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
 911    print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
 912    print $msg_fh "\n\nvia git-CVS emulator\n";
 913    close $msg_fh;
 914
 915    my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
 916    $log->info("Commit hash : $commithash");
 917
 918    unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
 919    {
 920        $log->warn("Commit failed (Invalid commit hash)");
 921        print "error 1 Commit failed (unknown reason)\n";
 922        close LOCKFILE;
 923        unlink($lockfile);
 924        chdir "/";
 925        exit;
 926    }
 927
 928    open FILE, ">", "$ENV{GIT_DIR}refs/heads/$state->{module}";
 929    print FILE $commithash;
 930    close FILE;
 931
 932    $updater->update();
 933
 934    # foreach file specified on the commandline ...
 935    foreach my $filename ( @committedfiles )
 936    {
 937        $filename = filecleanup($filename);
 938
 939        my $meta = $updater->getmeta($filename);
 940
 941        my ( $filepart, $dirpart ) = filenamesplit($filename);
 942
 943        $log->debug("Checked-in $dirpart : $filename");
 944
 945        if ( $meta->{filehash} eq "deleted" )
 946        {
 947            print "Remove-entry $dirpart\n";
 948            print "$filename\n";
 949        } else {
 950            print "Checked-in $dirpart\n";
 951            print "$filename\n";
 952            print "/$filepart/1.$meta->{revision}///\n";
 953        }
 954    }
 955
 956    close LOCKFILE;
 957    unlink($lockfile);
 958    chdir "/";
 959
 960    print "ok\n";
 961}
 962
 963sub req_status
 964{
 965    my ( $cmd, $data ) = @_;
 966
 967    argsplit("status");
 968
 969    $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
 970    #$log->debug("status state : " . Dumper($state));
 971
 972    # Grab a handle to the SQLite db and do any necessary updates
 973    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
 974    $updater->update();
 975
 976    # if no files were specified, we need to work out what files we should be providing status on ...
 977    argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
 978
 979    # foreach file specified on the commandline ...
 980    foreach my $filename ( @{$state->{args}} )
 981    {
 982        $filename = filecleanup($filename);
 983
 984        my $meta = $updater->getmeta($filename);
 985        my $oldmeta = $meta;
 986
 987        my $wrev = revparse($filename);
 988
 989        # If the working copy is an old revision, lets get that version too for comparison.
 990        if ( defined($wrev) and $wrev != $meta->{revision} )
 991        {
 992            $oldmeta = $updater->getmeta($filename, $wrev);
 993        }
 994
 995        # TODO : All possible statuses aren't yet implemented
 996        my $status;
 997        # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
 998        $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
 999                                    and
1000                                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1001                                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1002                                   );
1003
1004        # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1005        $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1006                                          and
1007                                          ( $state->{entries}{$filename}{unchanged}
1008                                            or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1009                                        );
1010
1011        # Need checkout if it exists in the repo but doesn't have a working copy
1012        $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1013
1014        # Locally modified if working copy and repo copy have the same revision but there are local changes
1015        $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1016
1017        # Needs Merge if working copy revision is less than repo copy and there are local changes
1018        $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1019
1020        $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1021        $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1022        $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1023        $status ||= "File had conflicts on merge" if ( 0 );
1024
1025        $status ||= "Unknown";
1026
1027        print "M ===================================================================\n";
1028        print "M File: $filename\tStatus: $status\n";
1029        if ( defined($state->{entries}{$filename}{revision}) )
1030        {
1031            print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1032        } else {
1033            print "M Working revision:\tNo entry for $filename\n";
1034        }
1035        if ( defined($meta->{revision}) )
1036        {
1037            print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1038            print "M Sticky Tag:\t\t(none)\n";
1039            print "M Sticky Date:\t\t(none)\n";
1040            print "M Sticky Options:\t\t(none)\n";
1041        } else {
1042            print "M Repository revision:\tNo revision control file\n";
1043        }
1044        print "M\n";
1045    }
1046
1047    print "ok\n";
1048}
1049
1050sub req_diff
1051{
1052    my ( $cmd, $data ) = @_;
1053
1054    argsplit("diff");
1055
1056    $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1057    #$log->debug("status state : " . Dumper($state));
1058
1059    my ($revision1, $revision2);
1060    if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1061    {
1062        $revision1 = $state->{opt}{r}[0];
1063        $revision2 = $state->{opt}{r}[1];
1064    } else {
1065        $revision1 = $state->{opt}{r};
1066    }
1067
1068    $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1069    $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1070
1071    $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1072
1073    # Grab a handle to the SQLite db and do any necessary updates
1074    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1075    $updater->update();
1076
1077    # if no files were specified, we need to work out what files we should be providing status on ...
1078    argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1079
1080    # foreach file specified on the commandline ...
1081    foreach my $filename ( @{$state->{args}} )
1082    {
1083        $filename = filecleanup($filename);
1084
1085        my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1086
1087        my $wrev = revparse($filename);
1088
1089        # We need _something_ to diff against
1090        next unless ( defined ( $wrev ) );
1091
1092        # if we have a -r switch, use it
1093        if ( defined ( $revision1 ) )
1094        {
1095            ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1096            $meta1 = $updater->getmeta($filename, $revision1);
1097            unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1098            {
1099                print "E File $filename at revision 1.$revision1 doesn't exist\n";
1100                next;
1101            }
1102            transmitfile($meta1->{filehash}, $file1);
1103        }
1104        # otherwise we just use the working copy revision
1105        else
1106        {
1107            ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1108            $meta1 = $updater->getmeta($filename, $wrev);
1109            transmitfile($meta1->{filehash}, $file1);
1110        }
1111
1112        # if we have a second -r switch, use it too
1113        if ( defined ( $revision2 ) )
1114        {
1115            ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1116            $meta2 = $updater->getmeta($filename, $revision2);
1117
1118            unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1119            {
1120                print "E File $filename at revision 1.$revision2 doesn't exist\n";
1121                next;
1122            }
1123
1124            transmitfile($meta2->{filehash}, $file2);
1125        }
1126        # otherwise we just use the working copy
1127        else
1128        {
1129            $file2 = $state->{entries}{$filename}{modified_filename};
1130        }
1131
1132        # if we have been given -r, and we don't have a $file2 yet, lets get one
1133        if ( defined ( $revision1 ) and not defined ( $file2 ) )
1134        {
1135            ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1136            $meta2 = $updater->getmeta($filename, $wrev);
1137            transmitfile($meta2->{filehash}, $file2);
1138        }
1139
1140        # We need to have retrieved something useful
1141        next unless ( defined ( $meta1 ) );
1142
1143        # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1144        next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1145                  and
1146                   ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1147                     or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1148                  );
1149
1150        # Apparently we only show diffs for locally modified files
1151        next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1152
1153        print "M Index: $filename\n";
1154        print "M ===================================================================\n";
1155        print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1156        print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1157        print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1158        print "M diff ";
1159        foreach my $opt ( keys %{$state->{opt}} )
1160        {
1161            if ( ref $state->{opt}{$opt} eq "ARRAY" )
1162            {
1163                foreach my $value ( @{$state->{opt}{$opt}} )
1164                {
1165                    print "-$opt $value ";
1166                }
1167            } else {
1168                print "-$opt ";
1169                print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1170            }
1171        }
1172        print "$filename\n";
1173
1174        $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1175
1176        ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1177
1178        if ( exists $state->{opt}{u} )
1179        {
1180            system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1181        } else {
1182            system("diff $file1 $file2 > $filediff");
1183        }
1184
1185        while ( <$fh> )
1186        {
1187            print "M $_";
1188        }
1189        close $fh;
1190    }
1191
1192    print "ok\n";
1193}
1194
1195sub req_log
1196{
1197    my ( $cmd, $data ) = @_;
1198
1199    argsplit("log");
1200
1201    $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1202    #$log->debug("log state : " . Dumper($state));
1203
1204    my ( $minrev, $maxrev );
1205    if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1206    {
1207        my $control = $2;
1208        $minrev = $1;
1209        $maxrev = $3;
1210        $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1211        $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1212        $minrev++ if ( defined($minrev) and $control eq "::" );
1213    }
1214
1215    # Grab a handle to the SQLite db and do any necessary updates
1216    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1217    $updater->update();
1218
1219    # if no files were specified, we need to work out what files we should be providing status on ...
1220    argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1221
1222    # foreach file specified on the commandline ...
1223    foreach my $filename ( @{$state->{args}} )
1224    {
1225        $filename = filecleanup($filename);
1226
1227        my $headmeta = $updater->getmeta($filename);
1228
1229        my $revisions = $updater->getlog($filename);
1230        my $totalrevisions = scalar(@$revisions);
1231
1232        if ( defined ( $minrev ) )
1233        {
1234            $log->debug("Removing revisions less than $minrev");
1235            while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1236            {
1237                pop @$revisions;
1238            }
1239        }
1240        if ( defined ( $maxrev ) )
1241        {
1242            $log->debug("Removing revisions greater than $maxrev");
1243            while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1244            {
1245                shift @$revisions;
1246            }
1247        }
1248
1249        next unless ( scalar(@$revisions) );
1250
1251        print "M \n";
1252        print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1253        print "M Working file: $filename\n";
1254        print "M head: 1.$headmeta->{revision}\n";
1255        print "M branch:\n";
1256        print "M locks: strict\n";
1257        print "M access list:\n";
1258        print "M symbolic names:\n";
1259        print "M keyword substitution: kv\n";
1260        print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1261        print "M description:\n";
1262
1263        foreach my $revision ( @$revisions )
1264        {
1265            print "M ----------------------------\n";
1266            print "M revision 1.$revision->{revision}\n";
1267            # reformat the date for log output
1268            $revision->{modified} = sprintf('%04d/%02d/%02d %s', $3, $DATE_LIST->{$2}, $1, $4 ) if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and defined($DATE_LIST->{$2}) );
1269            $revision->{author} =~ s/\s+.*//;
1270            $revision->{author} =~ s/^(.{8}).*/$1/;
1271            print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1272            my $commitmessage = $updater->commitmessage($revision->{commithash});
1273            $commitmessage =~ s/^/M /mg;
1274            print $commitmessage . "\n";
1275        }
1276        print "M =============================================================================\n";
1277    }
1278
1279    print "ok\n";
1280}
1281
1282sub req_annotate
1283{
1284    my ( $cmd, $data ) = @_;
1285
1286    argsplit("annotate");
1287
1288    $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1289    #$log->debug("status state : " . Dumper($state));
1290
1291    # Grab a handle to the SQLite db and do any necessary updates
1292    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1293    $updater->update();
1294
1295    # if no files were specified, we need to work out what files we should be providing annotate on ...
1296    argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1297
1298    # we'll need a temporary checkout dir
1299    my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1300    my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1301    $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1302
1303    $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1304    $ENV{GIT_INDEX_FILE} = $file_index;
1305
1306    chdir $tmpdir;
1307
1308    # foreach file specified on the commandline ...
1309    foreach my $filename ( @{$state->{args}} )
1310    {
1311        $filename = filecleanup($filename);
1312
1313        my $meta = $updater->getmeta($filename);
1314
1315        next unless ( $meta->{revision} );
1316
1317        # get all the commits that this file was in
1318        # in dense format -- aka skip dead revisions
1319        my $revisions   = $updater->gethistorydense($filename);
1320        my $lastseenin  = $revisions->[0][2];
1321
1322        # populate the temporary index based on the latest commit were we saw
1323        # the file -- but do it cheaply without checking out any files
1324        # TODO: if we got a revision from the client, use that instead
1325        # to look up the commithash in sqlite (still good to default to
1326        # the current head as we do now)
1327        system("git-read-tree", $lastseenin);
1328        unless ($? == 0)
1329        {
1330            die "Error running git-read-tree $lastseenin $file_index $!";
1331        }
1332        $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1333
1334        # do a checkout of the file
1335        system('git-checkout-index', '-f', '-u', $filename);
1336        unless ($? == 0) {
1337            die "Error running git-checkout-index -f -u $filename : $!";
1338        }
1339
1340        $log->info("Annotate $filename");
1341
1342        # Prepare a file with the commits from the linearized
1343        # history that annotate should know about. This prevents
1344        # git-jsannotate telling us about commits we are hiding
1345        # from the client.
1346
1347        open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1348        for (my $i=0; $i < @$revisions; $i++)
1349        {
1350            print ANNOTATEHINTS $revisions->[$i][2];
1351            if ($i+1 < @$revisions) { # have we got a parent?
1352                print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1353            }
1354            print ANNOTATEHINTS "\n";
1355        }
1356
1357        print ANNOTATEHINTS "\n";
1358        close ANNOTATEHINTS;
1359
1360        my $annotatecmd = 'git-annotate';
1361        open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1362            or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1363        my $metadata = {};
1364        print "E Annotations for $filename\n";
1365        print "E ***************\n";
1366        while ( <ANNOTATE> )
1367        {
1368            if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1369            {
1370                my $commithash = $1;
1371                my $data = $2;
1372                unless ( defined ( $metadata->{$commithash} ) )
1373                {
1374                    $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1375                    $metadata->{$commithash}{author} =~ s/\s+.*//;
1376                    $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1377                    $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1378                }
1379                printf("M 1.%-5d      (%-8s %10s): %s\n",
1380                    $metadata->{$commithash}{revision},
1381                    $metadata->{$commithash}{author},
1382                    $metadata->{$commithash}{modified},
1383                    $data
1384                );
1385            } else {
1386                $log->warn("Error in annotate output! LINE: $_");
1387                print "E Annotate error \n";
1388                next;
1389            }
1390        }
1391        close ANNOTATE;
1392    }
1393
1394    # done; get out of the tempdir
1395    chdir "/";
1396
1397    print "ok\n";
1398
1399}
1400
1401# This method takes the state->{arguments} array and produces two new arrays.
1402# The first is $state->{args} which is everything before the '--' argument, and
1403# the second is $state->{files} which is everything after it.
1404sub argsplit
1405{
1406    return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1407
1408    my $type = shift;
1409
1410    $state->{args} = [];
1411    $state->{files} = [];
1412    $state->{opt} = {};
1413
1414    if ( defined($type) )
1415    {
1416        my $opt = {};
1417        $opt = { A => 0, N => 0, P => 0, R => 0, c => 0, f => 0, l => 0, n => 0, p => 0, s => 0, r => 1, D => 1, d => 1, k => 1, j => 1, } if ( $type eq "co" );
1418        $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1419        $opt = { A => 0, P => 0, C => 0, d => 0, f => 0, l => 0, R => 0, p => 0, k => 1, r => 1, D => 1, j => 1, I => 1, W => 1 } if ( $type eq "update" );
1420        $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1421        $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1422        $opt = { k => 1, m => 1 } if ( $type eq "add" );
1423        $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1424        $opt = { l => 0, b => 0, h => 0, R => 0, t => 0, N => 0, S => 0, r => 1, d => 1, s => 1, w => 1 } if ( $type eq "log" );
1425
1426
1427        while ( scalar ( @{$state->{arguments}} ) > 0 )
1428        {
1429            my $arg = shift @{$state->{arguments}};
1430
1431            next if ( $arg eq "--" );
1432            next unless ( $arg =~ /\S/ );
1433
1434            # if the argument looks like a switch
1435            if ( $arg =~ /^-(\w)(.*)/ )
1436            {
1437                # if it's a switch that takes an argument
1438                if ( $opt->{$1} )
1439                {
1440                    # If this switch has already been provided
1441                    if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1442                    {
1443                        $state->{opt}{$1} = [ $state->{opt}{$1} ];
1444                        if ( length($2) > 0 )
1445                        {
1446                            push @{$state->{opt}{$1}},$2;
1447                        } else {
1448                            push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1449                        }
1450                    } else {
1451                        # if there's extra data in the arg, use that as the argument for the switch
1452                        if ( length($2) > 0 )
1453                        {
1454                            $state->{opt}{$1} = $2;
1455                        } else {
1456                            $state->{opt}{$1} = shift @{$state->{arguments}};
1457                        }
1458                    }
1459                } else {
1460                    $state->{opt}{$1} = undef;
1461                }
1462            }
1463            else
1464            {
1465                push @{$state->{args}}, $arg;
1466            }
1467        }
1468    }
1469    else
1470    {
1471        my $mode = 0;
1472
1473        foreach my $value ( @{$state->{arguments}} )
1474        {
1475            if ( $value eq "--" )
1476            {
1477                $mode++;
1478                next;
1479            }
1480            push @{$state->{args}}, $value if ( $mode == 0 );
1481            push @{$state->{files}}, $value if ( $mode == 1 );
1482        }
1483    }
1484}
1485
1486# This method uses $state->{directory} to populate $state->{args} with a list of filenames
1487sub argsfromdir
1488{
1489    my $updater = shift;
1490
1491    $state->{args} = [];
1492
1493    foreach my $file ( @{$updater->gethead} )
1494    {
1495        next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1496        next unless ( $file->{name} =~ s/^$state->{directory}// );
1497        push @{$state->{args}}, $file->{name};
1498    }
1499}
1500
1501# This method cleans up the $state variable after a command that uses arguments has run
1502sub statecleanup
1503{
1504    $state->{files} = [];
1505    $state->{args} = [];
1506    $state->{arguments} = [];
1507    $state->{entries} = {};
1508}
1509
1510sub revparse
1511{
1512    my $filename = shift;
1513
1514    return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1515
1516    return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1517    return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1518
1519    return undef;
1520}
1521
1522# This method takes a file hash and does a CVS "file transfer" which transmits the
1523# size of the file, and then the file contents.
1524# If a second argument $targetfile is given, the file is instead written out to
1525# a file by the name of $targetfile
1526sub transmitfile
1527{
1528    my $filehash = shift;
1529    my $targetfile = shift;
1530
1531    if ( defined ( $filehash ) and $filehash eq "deleted" )
1532    {
1533        $log->warn("filehash is 'deleted'");
1534        return;
1535    }
1536
1537    die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1538
1539    my $type = `git-cat-file -t $filehash`;
1540    chomp $type;
1541
1542    die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1543
1544    my $size = `git-cat-file -s $filehash`;
1545    chomp $size;
1546
1547    $log->debug("transmitfile($filehash) size=$size, type=$type");
1548
1549    if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1550    {
1551        if ( defined ( $targetfile ) )
1552        {
1553            open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1554            print NEWFILE $_ while ( <$fh> );
1555            close NEWFILE;
1556        } else {
1557            print "$size\n";
1558            print while ( <$fh> );
1559        }
1560        close $fh or die ("Couldn't close filehandle for transmitfile()");
1561    } else {
1562        die("Couldn't execute git-cat-file");
1563    }
1564}
1565
1566# This method takes a file name, and returns ( $dirpart, $filepart ) which
1567# refers to the directory porition and the file portion of the filename
1568# respectively
1569sub filenamesplit
1570{
1571    my $filename = shift;
1572
1573    my ( $filepart, $dirpart ) = ( $filename, "." );
1574    ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1575    $dirpart .= "/";
1576
1577    return ( $filepart, $dirpart );
1578}
1579
1580sub filecleanup
1581{
1582    my $filename = shift;
1583
1584    return undef unless(defined($filename));
1585    if ( $filename =~ /^\// )
1586    {
1587        print "E absolute filenames '$filename' not supported by server\n";
1588        return undef;
1589    }
1590
1591    $filename =~ s/^\.\///g;
1592    $filename = $state->{directory} . $filename;
1593
1594    return $filename;
1595}
1596
1597package GITCVS::log;
1598
1599####
1600#### Copyright The Open University UK - 2006.
1601####
1602#### Authors: Martyn Smith    <martyn@catalyst.net.nz>
1603####          Martin Langhoff <martin@catalyst.net.nz>
1604####
1605####
1606
1607use strict;
1608use warnings;
1609
1610=head1 NAME
1611
1612GITCVS::log
1613
1614=head1 DESCRIPTION
1615
1616This module provides very crude logging with a similar interface to
1617Log::Log4perl
1618
1619=head1 METHODS
1620
1621=cut
1622
1623=head2 new
1624
1625Creates a new log object, optionally you can specify a filename here to
1626indicate the file to log to. If no log file is specified, you can specifiy one
1627later with method setfile, or indicate you no longer want logging with method
1628nofile.
1629
1630Until one of these methods is called, all log calls will buffer messages ready
1631to write out.
1632
1633=cut
1634sub new
1635{
1636    my $class = shift;
1637    my $filename = shift;
1638
1639    my $self = {};
1640
1641    bless $self, $class;
1642
1643    if ( defined ( $filename ) )
1644    {
1645        open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1646    }
1647
1648    return $self;
1649}
1650
1651=head2 setfile
1652
1653This methods takes a filename, and attempts to open that file as the log file.
1654If successful, all buffered data is written out to the file, and any further
1655logging is written directly to the file.
1656
1657=cut
1658sub setfile
1659{
1660    my $self = shift;
1661    my $filename = shift;
1662
1663    if ( defined ( $filename ) )
1664    {
1665        open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1666    }
1667
1668    return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1669
1670    while ( my $line = shift @{$self->{buffer}} )
1671    {
1672        print {$self->{fh}} $line;
1673    }
1674}
1675
1676=head2 nofile
1677
1678This method indicates no logging is going to be used. It flushes any entries in
1679the internal buffer, and sets a flag to ensure no further data is put there.
1680
1681=cut
1682sub nofile
1683{
1684    my $self = shift;
1685
1686    $self->{nolog} = 1;
1687
1688    return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1689
1690    $self->{buffer} = [];
1691}
1692
1693=head2 _logopen
1694
1695Internal method. Returns true if the log file is open, false otherwise.
1696
1697=cut
1698sub _logopen
1699{
1700    my $self = shift;
1701
1702    return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1703    return 0;
1704}
1705
1706=head2 debug info warn fatal
1707
1708These four methods are wrappers to _log. They provide the actual interface for
1709logging data.
1710
1711=cut
1712sub debug { my $self = shift; $self->_log("debug", @_); }
1713sub info  { my $self = shift; $self->_log("info" , @_); }
1714sub warn  { my $self = shift; $self->_log("warn" , @_); }
1715sub fatal { my $self = shift; $self->_log("fatal", @_); }
1716
1717=head2 _log
1718
1719This is an internal method called by the logging functions. It generates a
1720timestamp and pushes the logged line either to file, or internal buffer.
1721
1722=cut
1723sub _log
1724{
1725    my $self = shift;
1726    my $level = shift;
1727
1728    return if ( $self->{nolog} );
1729
1730    my @time = localtime;
1731    my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
1732        $time[5] + 1900,
1733        $time[4] + 1,
1734        $time[3],
1735        $time[2],
1736        $time[1],
1737        $time[0],
1738        uc $level,
1739    );
1740
1741    if ( $self->_logopen )
1742    {
1743        print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
1744    } else {
1745        push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
1746    }
1747}
1748
1749=head2 DESTROY
1750
1751This method simply closes the file handle if one is open
1752
1753=cut
1754sub DESTROY
1755{
1756    my $self = shift;
1757
1758    if ( $self->_logopen )
1759    {
1760        close $self->{fh};
1761    }
1762}
1763
1764package GITCVS::updater;
1765
1766####
1767#### Copyright The Open University UK - 2006.
1768####
1769#### Authors: Martyn Smith    <martyn@catalyst.net.nz>
1770####          Martin Langhoff <martin@catalyst.net.nz>
1771####
1772####
1773
1774use strict;
1775use warnings;
1776use DBI;
1777
1778=head1 METHODS
1779
1780=cut
1781
1782=head2 new
1783
1784=cut
1785sub new
1786{
1787    my $class = shift;
1788    my $config = shift;
1789    my $module = shift;
1790    my $log = shift;
1791
1792    die "Need to specify a git repository" unless ( defined($config) and -d $config );
1793    die "Need to specify a module" unless ( defined($module) );
1794
1795    $class = ref($class) || $class;
1796
1797    my $self = {};
1798
1799    bless $self, $class;
1800
1801    $self->{dbdir} = $config . "/";
1802    die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
1803
1804    $self->{module} = $module;
1805    $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
1806
1807    $self->{git_path} = $config . "/";
1808
1809    $self->{log} = $log;
1810
1811    die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
1812
1813    $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
1814
1815    $self->{tables} = {};
1816    foreach my $table ( $self->{dbh}->tables )
1817    {
1818        $table =~ s/^"//;
1819        $table =~ s/"$//;
1820        $self->{tables}{$table} = 1;
1821    }
1822
1823    # Construct the revision table if required
1824    unless ( $self->{tables}{revision} )
1825    {
1826        $self->{dbh}->do("
1827            CREATE TABLE revision (
1828                name       TEXT NOT NULL,
1829                revision   INTEGER NOT NULL,
1830                filehash   TEXT NOT NULL,
1831                commithash TEXT NOT NULL,
1832                author     TEXT NOT NULL,
1833                modified   TEXT NOT NULL,
1834                mode       TEXT NOT NULL
1835            )
1836        ");
1837    }
1838
1839    # Construct the revision table if required
1840    unless ( $self->{tables}{head} )
1841    {
1842        $self->{dbh}->do("
1843            CREATE TABLE head (
1844                name       TEXT NOT NULL,
1845                revision   INTEGER NOT NULL,
1846                filehash   TEXT NOT NULL,
1847                commithash TEXT NOT NULL,
1848                author     TEXT NOT NULL,
1849                modified   TEXT NOT NULL,
1850                mode       TEXT NOT NULL
1851            )
1852        ");
1853    }
1854
1855    # Construct the properties table if required
1856    unless ( $self->{tables}{properties} )
1857    {
1858        $self->{dbh}->do("
1859            CREATE TABLE properties (
1860                key        TEXT NOT NULL PRIMARY KEY,
1861                value      TEXT
1862            )
1863        ");
1864    }
1865
1866    # Construct the commitmsgs table if required
1867    unless ( $self->{tables}{commitmsgs} )
1868    {
1869        $self->{dbh}->do("
1870            CREATE TABLE commitmsgs (
1871                key        TEXT NOT NULL PRIMARY KEY,
1872                value      TEXT
1873            )
1874        ");
1875    }
1876
1877    return $self;
1878}
1879
1880=head2 update
1881
1882=cut
1883sub update
1884{
1885    my $self = shift;
1886
1887    # first lets get the commit list
1888    $ENV{GIT_DIR} = $self->{git_path};
1889
1890    # prepare database queries
1891    my $db_insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
1892    my $db_insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
1893    my $db_delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
1894    my $db_insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
1895
1896    my $commitinfo = `git-cat-file commit $self->{module} 2>&1`;
1897    unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
1898    {
1899        die("Invalid module '$self->{module}'");
1900    }
1901
1902
1903    my $git_log;
1904    my $lastcommit = $self->_get_prop("last_commit");
1905
1906    # Start exclusive lock here...
1907    $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
1908
1909    # TODO: log processing is memory bound
1910    # if we can parse into a 2nd file that is in reverse order
1911    # we can probably do something really efficient
1912    my @git_log_params = ('--parents', '--topo-order');
1913
1914    if (defined $lastcommit) {
1915        push @git_log_params, "$lastcommit..$self->{module}";
1916    } else {
1917        push @git_log_params, $self->{module};
1918    }
1919    open(GITLOG, '-|', 'git-log', @git_log_params) or die "Cannot call git-log: $!";
1920
1921    my @commits;
1922
1923    my %commit = ();
1924
1925    while ( <GITLOG> )
1926    {
1927        chomp;
1928        if (m/^commit\s+(.*)$/) {
1929            # on ^commit lines put the just seen commit in the stack
1930            # and prime things for the next one
1931            if (keys %commit) {
1932                my %copy = %commit;
1933                unshift @commits, \%copy;
1934                %commit = ();
1935            }
1936            my @parents = split(m/\s+/, $1);
1937            $commit{hash} = shift @parents;
1938            $commit{parents} = \@parents;
1939        } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
1940            # on rfc822-like lines seen before we see any message,
1941            # lowercase the entry and put it in the hash as key-value
1942            $commit{lc($1)} = $2;
1943        } else {
1944            # message lines - skip initial empty line
1945            # and trim whitespace
1946            if (!exists($commit{message}) && m/^\s*$/) {
1947                # define it to mark the end of headers
1948                $commit{message} = '';
1949                next;
1950            }
1951            s/^\s+//; s/\s+$//; # trim ws
1952            $commit{message} .= $_ . "\n";
1953        }
1954    }
1955    close GITLOG;
1956
1957    unshift @commits, \%commit if ( keys %commit );
1958
1959    # Now all the commits are in the @commits bucket
1960    # ordered by time DESC. for each commit that needs processing,
1961    # determine whether it's following the last head we've seen or if
1962    # it's on its own branch, grab a file list, and add whatever's changed
1963    # NOTE: $lastcommit refers to the last commit from previous run
1964    #       $lastpicked is the last commit we picked in this run
1965    my $lastpicked;
1966    my $head = {};
1967    if (defined $lastcommit) {
1968        $lastpicked = $lastcommit;
1969    }
1970
1971    my $committotal = scalar(@commits);
1972    my $commitcount = 0;
1973
1974    # Load the head table into $head (for cached lookups during the update process)
1975    foreach my $file ( @{$self->gethead()} )
1976    {
1977        $head->{$file->{name}} = $file;
1978    }
1979
1980    foreach my $commit ( @commits )
1981    {
1982        $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
1983        if (defined $lastpicked)
1984        {
1985            if (!in_array($lastpicked, @{$commit->{parents}}))
1986            {
1987                # skip, we'll see this delta
1988                # as part of a merge later
1989                # warn "skipping off-track  $commit->{hash}\n";
1990                next;
1991            } elsif (@{$commit->{parents}} > 1) {
1992                # it is a merge commit, for each parent that is
1993                # not $lastpicked, see if we can get a log
1994                # from the merge-base to that parent to put it
1995                # in the message as a merge summary.
1996                my @parents = @{$commit->{parents}};
1997                foreach my $parent (@parents) {
1998                    # git-merge-base can potentially (but rarely) throw
1999                    # several candidate merge bases. let's assume
2000                    # that the first one is the best one.
2001                    if ($parent eq $lastpicked) {
2002                        next;
2003                    }
2004                    open my $p, 'git-merge-base '. $lastpicked . ' '
2005                    . $parent . '|';
2006                    my @output = (<$p>);
2007                    close $p;
2008                    my $base = join('', @output);
2009                    chomp $base;
2010                    if ($base) {
2011                        my @merged;
2012                        # print "want to log between  $base $parent \n";
2013                        open(GITLOG, '-|', 'git-log', "$base..$parent")
2014                        or die "Cannot call git-log: $!";
2015                        my $mergedhash;
2016                        while (<GITLOG>) {
2017                            chomp;
2018                            if (!defined $mergedhash) {
2019                                if (m/^commit\s+(.+)$/) {
2020                                    $mergedhash = $1;
2021                                } else {
2022                                    next;
2023                                }
2024                            } else {
2025                                # grab the first line that looks non-rfc822
2026                                # aka has content after leading space
2027                                if (m/^\s+(\S.*)$/) {
2028                                    my $title = $1;
2029                                    $title = substr($title,0,100); # truncate
2030                                    unshift @merged, "$mergedhash $title";
2031                                    undef $mergedhash;
2032                                }
2033                            }
2034                        }
2035                        close GITLOG;
2036                        if (@merged) {
2037                            $commit->{mergemsg} = $commit->{message};
2038                            $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2039                            foreach my $summary (@merged) {
2040                                $commit->{mergemsg} .= "\t$summary\n";
2041                            }
2042                            $commit->{mergemsg} .= "\n\n";
2043                            # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2044                        }
2045                    }
2046                }
2047            }
2048        }
2049
2050        # convert the date to CVS-happy format
2051        $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2052
2053        if ( defined ( $lastpicked ) )
2054        {
2055            my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2056            while ( <FILELIST> )
2057            {
2058                unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)\s+(.*)$/o )
2059                {
2060                    die("Couldn't process git-diff-tree line : $_");
2061                }
2062
2063                # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2064
2065                my $git_perms = "";
2066                $git_perms .= "r" if ( $1 & 4 );
2067                $git_perms .= "w" if ( $1 & 2 );
2068                $git_perms .= "x" if ( $1 & 1 );
2069                $git_perms = "rw" if ( $git_perms eq "" );
2070
2071                if ( $3 eq "D" )
2072                {
2073                    #$log->debug("DELETE   $4");
2074                    $head->{$4} = {
2075                        name => $4,
2076                        revision => $head->{$4}{revision} + 1,
2077                        filehash => "deleted",
2078                        commithash => $commit->{hash},
2079                        modified => $commit->{date},
2080                        author => $commit->{author},
2081                        mode => $git_perms,
2082                    };
2083                    $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2084                }
2085                elsif ( $3 eq "M" )
2086                {
2087                    #$log->debug("MODIFIED $4");
2088                    $head->{$4} = {
2089                        name => $4,
2090                        revision => $head->{$4}{revision} + 1,
2091                        filehash => $2,
2092                        commithash => $commit->{hash},
2093                        modified => $commit->{date},
2094                        author => $commit->{author},
2095                        mode => $git_perms,
2096                    };
2097                    $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2098                }
2099                elsif ( $3 eq "A" )
2100                {
2101                    #$log->debug("ADDED    $4");
2102                    $head->{$4} = {
2103                        name => $4,
2104                        revision => 1,
2105                        filehash => $2,
2106                        commithash => $commit->{hash},
2107                        modified => $commit->{date},
2108                        author => $commit->{author},
2109                        mode => $git_perms,
2110                    };
2111                    $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2112                }
2113                else
2114                {
2115                    $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
2116                    die;
2117                }
2118            }
2119            close FILELIST;
2120        } else {
2121            # this is used to detect files removed from the repo
2122            my $seen_files = {};
2123
2124            my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2125            while ( <FILELIST> )
2126            {
2127                unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2128                {
2129                    die("Couldn't process git-ls-tree line : $_");
2130                }
2131
2132                my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2133
2134                $seen_files->{$git_filename} = 1;
2135
2136                my ( $oldhash, $oldrevision, $oldmode ) = (
2137                    $head->{$git_filename}{filehash},
2138                    $head->{$git_filename}{revision},
2139                    $head->{$git_filename}{mode}
2140                );
2141
2142                if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2143                {
2144                    $git_perms = "";
2145                    $git_perms .= "r" if ( $1 & 4 );
2146                    $git_perms .= "w" if ( $1 & 2 );
2147                    $git_perms .= "x" if ( $1 & 1 );
2148                } else {
2149                    $git_perms = "rw";
2150                }
2151
2152                # unless the file exists with the same hash, we need to update it ...
2153                unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2154                {
2155                    my $newrevision = ( $oldrevision or 0 ) + 1;
2156
2157                    $head->{$git_filename} = {
2158                        name => $git_filename,
2159                        revision => $newrevision,
2160                        filehash => $git_hash,
2161                        commithash => $commit->{hash},
2162                        modified => $commit->{date},
2163                        author => $commit->{author},
2164                        mode => $git_perms,
2165                    };
2166
2167
2168                    $db_insert_rev->execute($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2169                }
2170            }
2171            close FILELIST;
2172
2173            # Detect deleted files
2174            foreach my $file ( keys %$head )
2175            {
2176                unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2177                {
2178                    $head->{$file}{revision}++;
2179                    $head->{$file}{filehash} = "deleted";
2180                    $head->{$file}{commithash} = $commit->{hash};
2181                    $head->{$file}{modified} = $commit->{date};
2182                    $head->{$file}{author} = $commit->{author};
2183
2184                    $db_insert_rev->execute($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2185                }
2186            }
2187            # END : "Detect deleted files"
2188        }
2189
2190
2191        if (exists $commit->{mergemsg})
2192        {
2193            $db_insert_mergelog->execute($commit->{hash}, $commit->{mergemsg});
2194        }
2195
2196        $lastpicked = $commit->{hash};
2197
2198        $self->_set_prop("last_commit", $commit->{hash});
2199    }
2200
2201    $db_delete_head->execute();
2202    foreach my $file ( keys %$head )
2203    {
2204        $db_insert_head->execute(
2205            $file,
2206            $head->{$file}{revision},
2207            $head->{$file}{filehash},
2208            $head->{$file}{commithash},
2209            $head->{$file}{modified},
2210            $head->{$file}{author},
2211            $head->{$file}{mode},
2212        );
2213    }
2214    # invalidate the gethead cache
2215    $self->{gethead_cache} = undef;
2216
2217
2218    # Ending exclusive lock here
2219    $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2220}
2221
2222sub _headrev
2223{
2224    my $self = shift;
2225    my $filename = shift;
2226
2227    my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2228    $db_query->execute($filename);
2229    my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2230
2231    return ( $hash, $revision, $mode );
2232}
2233
2234sub _get_prop
2235{
2236    my $self = shift;
2237    my $key = shift;
2238
2239    my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2240    $db_query->execute($key);
2241    my ( $value ) = $db_query->fetchrow_array;
2242
2243    return $value;
2244}
2245
2246sub _set_prop
2247{
2248    my $self = shift;
2249    my $key = shift;
2250    my $value = shift;
2251
2252    my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2253    $db_query->execute($value, $key);
2254
2255    unless ( $db_query->rows )
2256    {
2257        $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2258        $db_query->execute($key, $value);
2259    }
2260
2261    return $value;
2262}
2263
2264=head2 gethead
2265
2266=cut
2267
2268sub gethead
2269{
2270    my $self = shift;
2271
2272    return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2273
2274    my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head",{},1);
2275    $db_query->execute();
2276
2277    my $tree = [];
2278    while ( my $file = $db_query->fetchrow_hashref )
2279    {
2280        push @$tree, $file;
2281    }
2282
2283    $self->{gethead_cache} = $tree;
2284
2285    return $tree;
2286}
2287
2288=head2 getlog
2289
2290=cut
2291
2292sub getlog
2293{
2294    my $self = shift;
2295    my $filename = shift;
2296
2297    my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2298    $db_query->execute($filename);
2299
2300    my $tree = [];
2301    while ( my $file = $db_query->fetchrow_hashref )
2302    {
2303        push @$tree, $file;
2304    }
2305
2306    return $tree;
2307}
2308
2309=head2 getmeta
2310
2311This function takes a filename (with path) argument and returns a hashref of
2312metadata for that file.
2313
2314=cut
2315
2316sub getmeta
2317{
2318    my $self = shift;
2319    my $filename = shift;
2320    my $revision = shift;
2321
2322    my $db_query;
2323    if ( defined($revision) and $revision =~ /^\d+$/ )
2324    {
2325        $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2326        $db_query->execute($filename, $revision);
2327    }
2328    elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2329    {
2330        $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2331        $db_query->execute($filename, $revision);
2332    } else {
2333        $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2334        $db_query->execute($filename);
2335    }
2336
2337    return $db_query->fetchrow_hashref;
2338}
2339
2340=head2 commitmessage
2341
2342this function takes a commithash and returns the commit message for that commit
2343
2344=cut
2345sub commitmessage
2346{
2347    my $self = shift;
2348    my $commithash = shift;
2349
2350    die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2351
2352    my $db_query;
2353    $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2354    $db_query->execute($commithash);
2355
2356    my ( $message ) = $db_query->fetchrow_array;
2357
2358    if ( defined ( $message ) )
2359    {
2360        $message .= " " if ( $message =~ /\n$/ );
2361        return $message;
2362    }
2363
2364    my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2365    shift @lines while ( $lines[0] =~ /\S/ );
2366    $message = join("",@lines);
2367    $message .= " " if ( $message =~ /\n$/ );
2368    return $message;
2369}
2370
2371=head2 gethistory
2372
2373This function takes a filename (with path) argument and returns an arrayofarrays
2374containing revision,filehash,commithash ordered by revision descending
2375
2376=cut
2377sub gethistory
2378{
2379    my $self = shift;
2380    my $filename = shift;
2381
2382    my $db_query;
2383    $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2384    $db_query->execute($filename);
2385
2386    return $db_query->fetchall_arrayref;
2387}
2388
2389=head2 gethistorydense
2390
2391This function takes a filename (with path) argument and returns an arrayofarrays
2392containing revision,filehash,commithash ordered by revision descending.
2393
2394This version of gethistory skips deleted entries -- so it is useful for annotate.
2395The 'dense' part is a reference to a '--dense' option available for git-rev-list
2396and other git tools that depend on it.
2397
2398=cut
2399sub gethistorydense
2400{
2401    my $self = shift;
2402    my $filename = shift;
2403
2404    my $db_query;
2405    $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2406    $db_query->execute($filename);
2407
2408    return $db_query->fetchall_arrayref;
2409}
2410
2411=head2 in_array()
2412
2413from Array::PAT - mimics the in_array() function
2414found in PHP. Yuck but works for small arrays.
2415
2416=cut
2417sub in_array
2418{
2419    my ($check, @array) = @_;
2420    my $retval = 0;
2421    foreach my $test (@array){
2422        if($check eq $test){
2423            $retval =  1;
2424        }
2425    }
2426    return $retval;
2427}
2428
2429=head2 safe_pipe_capture
2430
2431an alterative to `command` that allows input to be passed as an array
2432to work around shell problems with weird characters in arguments
2433
2434=cut
2435sub safe_pipe_capture {
2436
2437    my @output;
2438
2439    if (my $pid = open my $child, '-|') {
2440        @output = (<$child>);
2441        close $child or die join(' ',@_).": $! $?";
2442    } else {
2443        exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2444    }
2445    return wantarray ? @output : join('',@output);
2446}
2447
2448
24491;