git.oblomov.eu Git - git/blob - git-cvsserver.perl

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