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( "text", $path );
2419         if ( $val eq "unspecified" )
2420         {
2421             $val = check_attr( "crlf", $path );
2422         }
2423         if ( $val eq "unset" )
2424         {
2425             return "-kb"
2426         }
2427         elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2428                 $val eq "set" || $val eq "input" )
2429         {
2430             return "";
2431         }
2432         else
2433         {
2434             $log->info("Unrecognized check_attr crlf $path : $val");
2435         }
2436     }
2437
2438     if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2439     {
2440         if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2441         {
2442             return "-kb";
2443         }
2444         elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2445         {
2446             if( $srcType eq "sha1Or-k" &&
2447                 !defined($name) )
2448             {
2449                 my ($ret)=$state->{entries}{$path}{options};
2450                 if( !defined($ret) )
2451                 {
2452                     $ret=$state->{opt}{k};
2453                     if(defined($ret))
2454                     {
2455                         $ret="-k$ret";
2456                     }
2457                     else
2458                     {
2459                         $ret="";
2460                     }
2461                 }
2462                 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2463                 {
2464                     print "E Bad -k option\n";
2465                     $log->warn("Bad -k option: $ret");
2466                     die "Error: Bad -k option: $ret\n";
2467                 }
2468
2469                 return $ret;
2470             }
2471             else
2472             {
2473                 if( is_binary($srcType,$name) )
2474                 {
2475                     $log->debug("... as binary");
2476                     return "-kb";
2477                 }
2478                 else
2479                 {
2480                     $log->debug("... as text");
2481                 }
2482             }
2483         }
2484     }
2485     # Return "" to give no special treatment to any path
2486     return "";
2487 }
2488
2489 sub check_attr
2490 {
2491     my ($attr,$path) = @_;
2492     ensureWorkTree();
2493     if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2494     {
2495         my $val = <$fh>;
2496         close $fh;
2497         $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2498         return $val;
2499     }
2500     else
2501     {
2502         return undef;
2503     }
2504 }
2505
2506 # This should have the same heuristics as convert.c:is_binary() and related.
2507 # Note that the bare CR test is done by callers in convert.c.
2508 sub is_binary
2509 {
2510     my ($srcType,$name) = @_;
2511     $log->debug("is_binary($srcType,$name)");
2512
2513     # Minimize amount of interpreted code run in the inner per-character
2514     # loop for large files, by totalling each character value and
2515     # then analyzing the totals.
2516     my @counts;
2517     my $i;
2518     for($i=0;$i<256;$i++)
2519     {
2520         $counts[$i]=0;
2521     }
2522
2523     my $fh = open_blob_or_die($srcType,$name);
2524     my $line;
2525     while( defined($line=<$fh>) )
2526     {
2527         # Any '\0' and bare CR are considered binary.
2528         if( $line =~ /\0|(\r[^\n])/ )
2529         {
2530             close($fh);
2531             return 1;
2532         }
2533
2534         # Count up each character in the line:
2535         my $len=length($line);
2536         for($i=0;$i<$len;$i++)
2537         {
2538             $counts[ord(substr($line,$i,1))]++;
2539         }
2540     }
2541     close $fh;
2542
2543     # Don't count CR and LF as either printable/nonprintable
2544     $counts[ord("\n")]=0;
2545     $counts[ord("\r")]=0;
2546
2547     # Categorize individual character count into printable and nonprintable:
2548     my $printable=0;
2549     my $nonprintable=0;
2550     for($i=0;$i<256;$i++)
2551     {
2552         if( $i < 32 &&
2553             $i != ord("\b") &&
2554             $i != ord("\t") &&
2555             $i != 033 &&       # ESC
2556             $i != 014 )        # FF
2557         {
2558             $nonprintable+=$counts[$i];
2559         }
2560         elsif( $i==127 )  # DEL
2561         {
2562             $nonprintable+=$counts[$i];
2563         }
2564         else
2565         {
2566             $printable+=$counts[$i];
2567         }
2568     }
2569
2570     return ($printable >> 7) < $nonprintable;
2571 }
2572
2573 # Returns open file handle.  Possible invocations:
2574 #  - open_blob_or_die("file",$filename);
2575 #  - open_blob_or_die("sha1",$filehash);
2576 sub open_blob_or_die
2577 {
2578     my ($srcType,$name) = @_;
2579     my ($fh);
2580     if( $srcType eq "file" )
2581     {
2582         if( !open $fh,"<",$name )
2583         {
2584             $log->warn("Unable to open file $name: $!");
2585             die "Unable to open file $name: $!\n";
2586         }
2587     }
2588     elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2589     {
2590         unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2591         {
2592             $log->warn("Need filehash");
2593             die "Need filehash\n";
2594         }
2595
2596         my $type = `git cat-file -t $name`;
2597         chomp $type;
2598
2599         unless ( defined ( $type ) and $type eq "blob" )
2600         {
2601             $log->warn("Invalid type '$type' for '$name'");
2602             die ( "Invalid type '$type' (expected 'blob')" )
2603         }
2604
2605         my $size = `git cat-file -s $name`;
2606         chomp $size;
2607
2608         $log->debug("open_blob_or_die($name) size=$size, type=$type");
2609
2610         unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2611         {
2612             $log->warn("Unable to open sha1 $name");
2613             die "Unable to open sha1 $name\n";
2614         }
2615     }
2616     else
2617     {
2618         $log->warn("Unknown type of blob source: $srcType");
2619         die "Unknown type of blob source: $srcType\n";
2620     }
2621     return $fh;
2622 }
2623
2624 # Generate a CVS author name from Git author information, by taking the local
2625 # part of the email address and replacing characters not in the Portable
2626 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2627 # Login names are Unix login names, which should be restricted to this
2628 # character set.
2629 sub cvs_author
2630 {
2631     my $author_line = shift;
2632     (my $author) = $author_line =~ /<([^@>]*)/;
2633
2634     $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2635     $author =~ s/^-/_/;
2636
2637     $author;
2638 }
2639
2640
2641 sub descramble
2642 {
2643     # This table is from src/scramble.c in the CVS source
2644     my @SHIFTS = (
2645         0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15,
2646         16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2647         114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2648         111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2649         41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2650         125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2651         36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2652         58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2653         225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2654         199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2655         174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2656         207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2657         192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2658         227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2659         182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2660         243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2661     );
2662     my ($str) = @_;
2663
2664     # This should never happen, the same password format (A) bas been
2665     # used by CVS since the beginning of time
2666     die "invalid password format $1" unless substr($str, 0, 1) eq 'A';
2667
2668     my @str = unpack "C*", substr($str, 1);
2669     my $ret = join '', map { chr $SHIFTS[$_] } @str;
2670     return $ret;
2671 }
2672
2673
2674 package GITCVS::log;
2675
2676 ####
2677 #### Copyright The Open University UK - 2006.
2678 ####
2679 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2680 ####          Martin Langhoff <martin@catalyst.net.nz>
2681 ####
2682 ####
2683
2684 use strict;
2685 use warnings;
2686
2687 =head1 NAME
2688
2689 GITCVS::log
2690
2691 =head1 DESCRIPTION
2692
2693 This module provides very crude logging with a similar interface to
2694 Log::Log4perl
2695
2696 =head1 METHODS
2697
2698 =cut
2699
2700 =head2 new
2701
2702 Creates a new log object, optionally you can specify a filename here to
2703 indicate the file to log to. If no log file is specified, you can specify one
2704 later with method setfile, or indicate you no longer want logging with method
2705 nofile.
2706
2707 Until one of these methods is called, all log calls will buffer messages ready
2708 to write out.
2709
2710 =cut
2711 sub new
2712 {
2713     my $class = shift;
2714     my $filename = shift;
2715
2716     my $self = {};
2717
2718     bless $self, $class;
2719
2720     if ( defined ( $filename ) )
2721     {
2722         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2723     }
2724
2725     return $self;
2726 }
2727
2728 =head2 setfile
2729
2730 This methods takes a filename, and attempts to open that file as the log file.
2731 If successful, all buffered data is written out to the file, and any further
2732 logging is written directly to the file.
2733
2734 =cut
2735 sub setfile
2736 {
2737     my $self = shift;
2738     my $filename = shift;
2739
2740     if ( defined ( $filename ) )
2741     {
2742         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2743     }
2744
2745     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2746
2747     while ( my $line = shift @{$self->{buffer}} )
2748     {
2749         print {$self->{fh}} $line;
2750     }
2751 }
2752
2753 =head2 nofile
2754
2755 This method indicates no logging is going to be used. It flushes any entries in
2756 the internal buffer, and sets a flag to ensure no further data is put there.
2757
2758 =cut
2759 sub nofile
2760 {
2761     my $self = shift;
2762
2763     $self->{nolog} = 1;
2764
2765     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2766
2767     $self->{buffer} = [];
2768 }
2769
2770 =head2 _logopen
2771
2772 Internal method. Returns true if the log file is open, false otherwise.
2773
2774 =cut
2775 sub _logopen
2776 {
2777     my $self = shift;
2778
2779     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2780     return 0;
2781 }
2782
2783 =head2 debug info warn fatal
2784
2785 These four methods are wrappers to _log. They provide the actual interface for
2786 logging data.
2787
2788 =cut
2789 sub debug { my $self = shift; $self->_log("debug", @_); }
2790 sub info  { my $self = shift; $self->_log("info" , @_); }
2791 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2792 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2793
2794 =head2 _log
2795
2796 This is an internal method called by the logging functions. It generates a
2797 timestamp and pushes the logged line either to file, or internal buffer.
2798
2799 =cut
2800 sub _log
2801 {
2802     my $self = shift;
2803     my $level = shift;
2804
2805     return if ( $self->{nolog} );
2806
2807     my @time = localtime;
2808     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2809         $time[5] + 1900,
2810         $time[4] + 1,
2811         $time[3],
2812         $time[2],
2813         $time[1],
2814         $time[0],
2815         uc $level,
2816     );
2817
2818     if ( $self->_logopen )
2819     {
2820         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2821     } else {
2822         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2823     }
2824 }
2825
2826 =head2 DESTROY
2827
2828 This method simply closes the file handle if one is open
2829
2830 =cut
2831 sub DESTROY
2832 {
2833     my $self = shift;
2834
2835     if ( $self->_logopen )
2836     {
2837         close $self->{fh};
2838     }
2839 }
2840
2841 package GITCVS::updater;
2842
2843 ####
2844 #### Copyright The Open University UK - 2006.
2845 ####
2846 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2847 ####          Martin Langhoff <martin@catalyst.net.nz>
2848 ####
2849 ####
2850
2851 use strict;
2852 use warnings;
2853 use DBI;
2854
2855 =head1 METHODS
2856
2857 =cut
2858
2859 =head2 new
2860
2861 =cut
2862 sub new
2863 {
2864     my $class = shift;
2865     my $config = shift;
2866     my $module = shift;
2867     my $log = shift;
2868
2869     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2870     die "Need to specify a module" unless ( defined($module) );
2871
2872     $class = ref($class) || $class;
2873
2874     my $self = {};
2875
2876     bless $self, $class;
2877
2878     $self->{valid_tables} = {'revision' => 1,
2879                              'revision_ix1' => 1,
2880                              'revision_ix2' => 1,
2881                              'head' => 1,
2882                              'head_ix1' => 1,
2883                              'properties' => 1,
2884                              'commitmsgs' => 1};
2885
2886     $self->{module} = $module;
2887     $self->{git_path} = $config . "/";
2888
2889     $self->{log} = $log;
2890
2891     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2892
2893     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2894         $cfg->{gitcvs}{dbdriver} || "SQLite";
2895     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2896         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2897     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2898         $cfg->{gitcvs}{dbuser} || "";
2899     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2900         $cfg->{gitcvs}{dbpass} || "";
2901     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2902         $cfg->{gitcvs}{dbtablenameprefix} || "";
2903     my %mapping = ( m => $module,
2904                     a => $state->{method},
2905                     u => getlogin || getpwuid($<) || $<,
2906                     G => $self->{git_path},
2907                     g => mangle_dirname($self->{git_path}),
2908                     );
2909     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2910     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2911     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2912     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2913
2914     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2915     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2916     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2917                                 $self->{dbuser},
2918                                 $self->{dbpass});
2919     die "Error connecting to database\n" unless defined $self->{dbh};
2920
2921     $self->{tables} = {};
2922     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2923     {
2924         $self->{tables}{$table} = 1;
2925     }
2926
2927     # Construct the revision table if required
2928     unless ( $self->{tables}{$self->tablename("revision")} )
2929     {
2930         my $tablename = $self->tablename("revision");
2931         my $ix1name = $self->tablename("revision_ix1");
2932         my $ix2name = $self->tablename("revision_ix2");
2933         $self->{dbh}->do("
2934             CREATE TABLE $tablename (
2935                 name       TEXT NOT NULL,
2936                 revision   INTEGER NOT NULL,
2937                 filehash   TEXT NOT NULL,
2938                 commithash TEXT NOT NULL,
2939                 author     TEXT NOT NULL,
2940                 modified   TEXT NOT NULL,
2941                 mode       TEXT NOT NULL
2942             )
2943         ");
2944         $self->{dbh}->do("
2945             CREATE INDEX $ix1name
2946             ON $tablename (name,revision)
2947         ");
2948         $self->{dbh}->do("
2949             CREATE INDEX $ix2name
2950             ON $tablename (name,commithash)
2951         ");
2952     }
2953
2954     # Construct the head table if required
2955     unless ( $self->{tables}{$self->tablename("head")} )
2956     {
2957         my $tablename = $self->tablename("head");
2958         my $ix1name = $self->tablename("head_ix1");
2959         $self->{dbh}->do("
2960             CREATE TABLE $tablename (
2961                 name       TEXT NOT NULL,
2962                 revision   INTEGER NOT NULL,
2963                 filehash   TEXT NOT NULL,
2964                 commithash TEXT NOT NULL,
2965                 author     TEXT NOT NULL,
2966                 modified   TEXT NOT NULL,
2967                 mode       TEXT NOT NULL
2968             )
2969         ");
2970         $self->{dbh}->do("
2971             CREATE INDEX $ix1name
2972             ON $tablename (name)
2973         ");
2974     }
2975
2976     # Construct the properties table if required
2977     unless ( $self->{tables}{$self->tablename("properties")} )
2978     {
2979         my $tablename = $self->tablename("properties");
2980         $self->{dbh}->do("
2981             CREATE TABLE $tablename (
2982                 key        TEXT NOT NULL PRIMARY KEY,
2983                 value      TEXT
2984             )
2985         ");
2986     }
2987
2988     # Construct the commitmsgs table if required
2989     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2990     {
2991         my $tablename = $self->tablename("commitmsgs");
2992         $self->{dbh}->do("
2993             CREATE TABLE $tablename (
2994                 key        TEXT NOT NULL PRIMARY KEY,
2995                 value      TEXT
2996             )
2997         ");
2998     }
2999
3000     return $self;
3001 }
3002
3003 =head2 tablename
3004
3005 =cut
3006 sub tablename
3007 {
3008     my $self = shift;
3009     my $name = shift;
3010
3011     if (exists $self->{valid_tables}{$name}) {
3012         return $self->{dbtablenameprefix} . $name;
3013     } else {
3014         return undef;
3015     }
3016 }
3017
3018 =head2 update
3019
3020 =cut
3021 sub update
3022 {
3023     my $self = shift;
3024
3025     # first lets get the commit list
3026     $ENV{GIT_DIR} = $self->{git_path};
3027
3028     my $commitsha1 = `git rev-parse $self->{module}`;
3029     chomp $commitsha1;
3030
3031     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3032     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3033     {
3034         die("Invalid module '$self->{module}'");
3035     }
3036
3037
3038     my $git_log;
3039     my $lastcommit = $self->_get_prop("last_commit");
3040
3041     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3042          return 1;
3043     }
3044
3045     # Start exclusive lock here...
3046     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3047
3048     # TODO: log processing is memory bound
3049     # if we can parse into a 2nd file that is in reverse order
3050     # we can probably do something really efficient
3051     my @git_log_params = ('--pretty', '--parents', '--topo-order');
3052
3053     if (defined $lastcommit) {
3054         push @git_log_params, "$lastcommit..$self->{module}";
3055     } else {
3056         push @git_log_params, $self->{module};
3057     }
3058     # git-rev-list is the backend / plumbing version of git-log
3059     open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3060
3061     my @commits;
3062
3063     my %commit = ();
3064
3065     while ( <GITLOG> )
3066     {
3067         chomp;
3068         if (m/^commit\s+(.*)$/) {
3069             # on ^commit lines put the just seen commit in the stack
3070             # and prime things for the next one
3071             if (keys %commit) {
3072                 my %copy = %commit;
3073                 unshift @commits, \%copy;
3074                 %commit = ();
3075             }
3076             my @parents = split(m/\s+/, $1);
3077             $commit{hash} = shift @parents;
3078             $commit{parents} = \@parents;
3079         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3080             # on rfc822-like lines seen before we see any message,
3081             # lowercase the entry and put it in the hash as key-value
3082             $commit{lc($1)} = $2;
3083         } else {
3084             # message lines - skip initial empty line
3085             # and trim whitespace
3086             if (!exists($commit{message}) && m/^\s*$/) {
3087                 # define it to mark the end of headers
3088                 $commit{message} = '';
3089                 next;
3090             }
3091             s/^\s+//; s/\s+$//; # trim ws
3092             $commit{message} .= $_ . "\n";
3093         }
3094     }
3095     close GITLOG;
3096
3097     unshift @commits, \%commit if ( keys %commit );
3098
3099     # Now all the commits are in the @commits bucket
3100     # ordered by time DESC. for each commit that needs processing,
3101     # determine whether it's following the last head we've seen or if
3102     # it's on its own branch, grab a file list, and add whatever's changed
3103     # NOTE: $lastcommit refers to the last commit from previous run
3104     #       $lastpicked is the last commit we picked in this run
3105     my $lastpicked;
3106     my $head = {};
3107     if (defined $lastcommit) {
3108         $lastpicked = $lastcommit;
3109     }
3110
3111     my $committotal = scalar(@commits);
3112     my $commitcount = 0;
3113
3114     # Load the head table into $head (for cached lookups during the update process)
3115     foreach my $file ( @{$self->gethead()} )
3116     {
3117         $head->{$file->{name}} = $file;
3118     }
3119
3120     foreach my $commit ( @commits )
3121     {
3122         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3123         if (defined $lastpicked)
3124         {
3125             if (!in_array($lastpicked, @{$commit->{parents}}))
3126             {
3127                 # skip, we'll see this delta
3128                 # as part of a merge later
3129                 # warn "skipping off-track  $commit->{hash}\n";
3130                 next;
3131             } elsif (@{$commit->{parents}} > 1) {
3132                 # it is a merge commit, for each parent that is
3133                 # not $lastpicked, see if we can get a log
3134                 # from the merge-base to that parent to put it
3135                 # in the message as a merge summary.
3136                 my @parents = @{$commit->{parents}};
3137                 foreach my $parent (@parents) {
3138                     # git-merge-base can potentially (but rarely) throw
3139                     # several candidate merge bases. let's assume
3140                     # that the first one is the best one.
3141                     if ($parent eq $lastpicked) {
3142                         next;
3143                     }
3144                     my $base = eval {
3145                             safe_pipe_capture('git', 'merge-base',
3146                                                  $lastpicked, $parent);
3147                     };
3148                     # The two branches may not be related at all,
3149                     # in which case merge base simply fails to find
3150                     # any, but that's Ok.
3151                     next if ($@);
3152
3153                     chomp $base;
3154                     if ($base) {
3155                         my @merged;
3156                         # print "want to log between  $base $parent \n";
3157                         open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3158                           or die "Cannot call git-log: $!";
3159                         my $mergedhash;
3160                         while (<GITLOG>) {
3161                             chomp;
3162                             if (!defined $mergedhash) {
3163                                 if (m/^commit\s+(.+)$/) {
3164                                     $mergedhash = $1;
3165                                 } else {
3166                                     next;
3167                                 }
3168                             } else {
3169                                 # grab the first line that looks non-rfc822
3170                                 # aka has content after leading space
3171                                 if (m/^\s+(\S.*)$/) {
3172                                     my $title = $1;
3173                                     $title = substr($title,0,100); # truncate
3174                                     unshift @merged, "$mergedhash $title";
3175                                     undef $mergedhash;
3176                                 }
3177                             }
3178                         }
3179                         close GITLOG;
3180                         if (@merged) {
3181                             $commit->{mergemsg} = $commit->{message};
3182                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3183                             foreach my $summary (@merged) {
3184                                 $commit->{mergemsg} .= "\t$summary\n";
3185                             }
3186                             $commit->{mergemsg} .= "\n\n";
3187                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3188                         }
3189                     }
3190                 }
3191             }
3192         }
3193
3194         # convert the date to CVS-happy format
3195         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3196
3197         if ( defined ( $lastpicked ) )
3198         {
3199             my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3200             local ($/) = "\0";
3201             while ( <FILELIST> )
3202             {
3203                 chomp;
3204                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3205                 {
3206                     die("Couldn't process git-diff-tree line : $_");
3207                 }
3208                 my ($mode, $hash, $change) = ($1, $2, $3);
3209                 my $name = <FILELIST>;
3210                 chomp($name);
3211
3212                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3213
3214                 my $git_perms = "";
3215                 $git_perms .= "r" if ( $mode & 4 );
3216                 $git_perms .= "w" if ( $mode & 2 );
3217                 $git_perms .= "x" if ( $mode & 1 );
3218                 $git_perms = "rw" if ( $git_perms eq "" );
3219
3220                 if ( $change eq "D" )
3221                 {
3222                     #$log->debug("DELETE   $name");
3223                     $head->{$name} = {
3224                         name => $name,
3225                         revision => $head->{$name}{revision} + 1,
3226                         filehash => "deleted",
3227                         commithash => $commit->{hash},
3228                         modified => $commit->{date},
3229                         author => $commit->{author},
3230                         mode => $git_perms,
3231                     };
3232                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3233                 }
3234                 elsif ( $change eq "M" || $change eq "T" )
3235                 {
3236                     #$log->debug("MODIFIED $name");
3237                     $head->{$name} = {
3238                         name => $name,
3239                         revision => $head->{$name}{revision} + 1,
3240                         filehash => $hash,
3241                         commithash => $commit->{hash},
3242                         modified => $commit->{date},
3243                         author => $commit->{author},
3244                         mode => $git_perms,
3245                     };
3246                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3247                 }
3248                 elsif ( $change eq "A" )
3249                 {
3250                     #$log->debug("ADDED    $name");
3251                     $head->{$name} = {
3252                         name => $name,
3253                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3254                         filehash => $hash,
3255                         commithash => $commit->{hash},
3256                         modified => $commit->{date},
3257                         author => $commit->{author},
3258                         mode => $git_perms,
3259                     };
3260                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3261                 }
3262                 else
3263                 {
3264                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3265                     die;
3266                 }
3267             }
3268             close FILELIST;
3269         } else {
3270             # this is used to detect files removed from the repo
3271             my $seen_files = {};
3272
3273             my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3274             local $/ = "\0";
3275             while ( <FILELIST> )
3276             {
3277                 chomp;
3278                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3279                 {
3280                     die("Couldn't process git-ls-tree line : $_");
3281                 }
3282
3283                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3284
3285                 $seen_files->{$git_filename} = 1;
3286
3287                 my ( $oldhash, $oldrevision, $oldmode ) = (
3288                     $head->{$git_filename}{filehash},
3289                     $head->{$git_filename}{revision},
3290                     $head->{$git_filename}{mode}
3291                 );
3292
3293                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3294                 {
3295                     $git_perms = "";
3296                     $git_perms .= "r" if ( $1 & 4 );
3297                     $git_perms .= "w" if ( $1 & 2 );
3298                     $git_perms .= "x" if ( $1 & 1 );
3299                 } else {
3300                     $git_perms = "rw";
3301                 }
3302
3303                 # unless the file exists with the same hash, we need to update it ...
3304                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3305                 {
3306                     my $newrevision = ( $oldrevision or 0 ) + 1;
3307
3308                     $head->{$git_filename} = {
3309                         name => $git_filename,
3310                         revision => $newrevision,
3311                         filehash => $git_hash,
3312                         commithash => $commit->{hash},
3313                         modified => $commit->{date},
3314                         author => $commit->{author},
3315                         mode => $git_perms,
3316                     };
3317
3318
3319                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3320                 }
3321             }
3322             close FILELIST;
3323
3324             # Detect deleted files
3325             foreach my $file ( keys %$head )
3326             {
3327                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3328                 {
3329                     $head->{$file}{revision}++;
3330                     $head->{$file}{filehash} = "deleted";
3331                     $head->{$file}{commithash} = $commit->{hash};
3332                     $head->{$file}{modified} = $commit->{date};
3333                     $head->{$file}{author} = $commit->{author};
3334
3335                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3336                 }
3337             }
3338             # END : "Detect deleted files"
3339         }
3340
3341
3342         if (exists $commit->{mergemsg})
3343         {
3344             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3345         }
3346
3347         $lastpicked = $commit->{hash};
3348
3349         $self->_set_prop("last_commit", $commit->{hash});
3350     }
3351
3352     $self->delete_head();
3353     foreach my $file ( keys %$head )
3354     {
3355         $self->insert_head(
3356             $file,
3357             $head->{$file}{revision},
3358             $head->{$file}{filehash},
3359             $head->{$file}{commithash},
3360             $head->{$file}{modified},
3361             $head->{$file}{author},
3362             $head->{$file}{mode},
3363         );
3364     }
3365     # invalidate the gethead cache
3366     $self->{gethead_cache} = undef;
3367
3368
3369     # Ending exclusive lock here
3370     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3371 }
3372
3373 sub insert_rev
3374 {
3375     my $self = shift;
3376     my $name = shift;
3377     my $revision = shift;
3378     my $filehash = shift;
3379     my $commithash = shift;
3380     my $modified = shift;
3381     my $author = shift;
3382     my $mode = shift;
3383     my $tablename = $self->tablename("revision");
3384
3385     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3386     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3387 }
3388
3389 sub insert_mergelog
3390 {
3391     my $self = shift;
3392     my $key = shift;
3393     my $value = shift;
3394     my $tablename = $self->tablename("commitmsgs");
3395
3396     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3397     $insert_mergelog->execute($key, $value);
3398 }
3399
3400 sub delete_head
3401 {
3402     my $self = shift;
3403     my $tablename = $self->tablename("head");
3404
3405     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3406     $delete_head->execute();
3407 }
3408
3409 sub insert_head
3410 {
3411     my $self = shift;
3412     my $name = shift;
3413     my $revision = shift;
3414     my $filehash = shift;
3415     my $commithash = shift;
3416     my $modified = shift;
3417     my $author = shift;
3418     my $mode = shift;
3419     my $tablename = $self->tablename("head");
3420
3421     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3422     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3423 }
3424
3425 sub _headrev
3426 {
3427     my $self = shift;
3428     my $filename = shift;
3429     my $tablename = $self->tablename("head");
3430
3431     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3432     $db_query->execute($filename);
3433     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3434
3435     return ( $hash, $revision, $mode );
3436 }
3437
3438 sub _get_prop
3439 {
3440     my $self = shift;
3441     my $key = shift;
3442     my $tablename = $self->tablename("properties");
3443
3444     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3445     $db_query->execute($key);
3446     my ( $value ) = $db_query->fetchrow_array;
3447
3448     return $value;
3449 }
3450
3451 sub _set_prop
3452 {
3453     my $self = shift;
3454     my $key = shift;
3455     my $value = shift;
3456     my $tablename = $self->tablename("properties");
3457
3458     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3459     $db_query->execute($value, $key);
3460
3461     unless ( $db_query->rows )
3462     {
3463         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3464         $db_query->execute($key, $value);
3465     }
3466
3467     return $value;
3468 }
3469
3470 =head2 gethead
3471
3472 =cut
3473
3474 sub gethead
3475 {
3476     my $self = shift;
3477     my $tablename = $self->tablename("head");
3478
3479     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3480
3481     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3482     $db_query->execute();
3483
3484     my $tree = [];
3485     while ( my $file = $db_query->fetchrow_hashref )
3486     {
3487         push @$tree, $file;
3488     }
3489
3490     $self->{gethead_cache} = $tree;
3491
3492     return $tree;
3493 }
3494
3495 =head2 getlog
3496
3497 =cut
3498
3499 sub getlog
3500 {
3501     my $self = shift;
3502     my $filename = shift;
3503     my $tablename = $self->tablename("revision");
3504
3505     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3506     $db_query->execute($filename);
3507
3508     my $tree = [];
3509     while ( my $file = $db_query->fetchrow_hashref )
3510     {
3511         push @$tree, $file;
3512     }
3513
3514     return $tree;
3515 }
3516
3517 =head2 getmeta
3518
3519 This function takes a filename (with path) argument and returns a hashref of
3520 metadata for that file.
3521
3522 =cut
3523
3524 sub getmeta
3525 {
3526     my $self = shift;
3527     my $filename = shift;
3528     my $revision = shift;
3529     my $tablename_rev = $self->tablename("revision");
3530     my $tablename_head = $self->tablename("head");
3531
3532     my $db_query;
3533     if ( defined($revision) and $revision =~ /^\d+$/ )
3534     {
3535         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3536         $db_query->execute($filename, $revision);
3537     }
3538     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3539     {
3540         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3541         $db_query->execute($filename, $revision);
3542     } else {
3543         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3544         $db_query->execute($filename);
3545     }
3546
3547     return $db_query->fetchrow_hashref;
3548 }
3549
3550 =head2 commitmessage
3551
3552 this function takes a commithash and returns the commit message for that commit
3553
3554 =cut
3555 sub commitmessage
3556 {
3557     my $self = shift;
3558     my $commithash = shift;
3559     my $tablename = $self->tablename("commitmsgs");
3560
3561     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3562
3563     my $db_query;
3564     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3565     $db_query->execute($commithash);
3566
3567     my ( $message ) = $db_query->fetchrow_array;
3568
3569     if ( defined ( $message ) )
3570     {
3571         $message .= " " if ( $message =~ /\n$/ );
3572         return $message;
3573     }
3574
3575     my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3576     shift @lines while ( $lines[0] =~ /\S/ );
3577     $message = join("",@lines);
3578     $message .= " " if ( $message =~ /\n$/ );
3579     return $message;
3580 }
3581
3582 =head2 gethistory
3583
3584 This function takes a filename (with path) argument and returns an arrayofarrays
3585 containing revision,filehash,commithash ordered by revision descending
3586
3587 =cut
3588 sub gethistory
3589 {
3590     my $self = shift;
3591     my $filename = shift;
3592     my $tablename = $self->tablename("revision");
3593
3594     my $db_query;
3595     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3596     $db_query->execute($filename);
3597
3598     return $db_query->fetchall_arrayref;
3599 }
3600
3601 =head2 gethistorydense
3602
3603 This function takes a filename (with path) argument and returns an arrayofarrays
3604 containing revision,filehash,commithash ordered by revision descending.
3605
3606 This version of gethistory skips deleted entries -- so it is useful for annotate.
3607 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3608 and other git tools that depend on it.
3609
3610 =cut
3611 sub gethistorydense
3612 {
3613     my $self = shift;
3614     my $filename = shift;
3615     my $tablename = $self->tablename("revision");
3616
3617     my $db_query;
3618     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3619     $db_query->execute($filename);
3620
3621     return $db_query->fetchall_arrayref;
3622 }
3623
3624 =head2 in_array()
3625
3626 from Array::PAT - mimics the in_array() function
3627 found in PHP. Yuck but works for small arrays.
3628
3629 =cut
3630 sub in_array
3631 {
3632     my ($check, @array) = @_;
3633     my $retval = 0;
3634     foreach my $test (@array){
3635         if($check eq $test){
3636             $retval =  1;
3637         }
3638     }
3639     return $retval;
3640 }
3641
3642 =head2 safe_pipe_capture
3643
3644 an alternative to `command` that allows input to be passed as an array
3645 to work around shell problems with weird characters in arguments
3646
3647 =cut
3648 sub safe_pipe_capture {
3649
3650     my @output;
3651
3652     if (my $pid = open my $child, '-|') {
3653         @output = (<$child>);
3654         close $child or die join(' ',@_).": $! $?";
3655     } else {
3656         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3657     }
3658     return wantarray ? @output : join('',@output);
3659 }
3660
3661 =head2 mangle_dirname
3662
3663 create a string from a directory name that is suitable to use as
3664 part of a filename, mainly by converting all chars except \w.- to _
3665
3666 =cut
3667 sub mangle_dirname {
3668     my $dirname = shift;
3669     return unless defined $dirname;
3670
3671     $dirname =~ s/[^\w.-]/_/g;
3672
3673     return $dirname;
3674 }
3675
3676 =head2 mangle_tablename
3677
3678 create a string from a that is suitable to use as part of an SQL table
3679 name, mainly by converting all chars except \w to _
3680
3681 =cut
3682 sub mangle_tablename {
3683     my $tablename = shift;
3684     return unless defined $tablename;
3685
3686     $tablename =~ s/[^\w_]/_/g;
3687
3688     return $tablename;
3689 }
3690
3691 1;