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