git-cvsserver.perl

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