git-cvsserver.perl

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