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