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