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