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