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             # TODO: If it has been modified in the sandbox, error out
1148             #   with the appropriate message, rather than deleting a modified
1149             #   file.
1150
1151             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1152
1153             $log->info("Removing '$filename' from working copy (no longer in the repo)");
1154
1155             print "E cvs update: `$filename' is no longer in the repository\n";
1156             # Don't want to actually _DO_ the update if -n specified
1157             unless ( $state->{globaloptions}{-n} ) {
1158                 print "Removed $dirpart\n";
1159                 print "$filepart\n";
1160             }
1161         }
1162         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1163                 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1164                 or $meta->{filehash} eq 'added' )
1165         {
1166             # normal update, just send the new revision (either U=Update,
1167             # or A=Add, or R=Remove)
1168             if ( defined($wrev) && $wrev < 0 )
1169             {
1170                 $log->info("Tell the client the file is scheduled for removal");
1171                 print "MT text R \n";
1172                 print "MT fname $filename\n";
1173                 print "MT newline\n";
1174                 next;
1175             }
1176             elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1177             {
1178                 $log->info("Tell the client the file is scheduled for addition");
1179                 print "MT text A \n";
1180                 print "MT fname $filename\n";
1181                 print "MT newline\n";
1182                 next;
1183
1184             }
1185             else {
1186                 $log->info("Updating '$filename' to ".$meta->{revision});
1187                 print "MT +updated\n";
1188                 print "MT text U \n";
1189                 print "MT fname $filename\n";
1190                 print "MT newline\n";
1191                 print "MT -updated\n";
1192             }
1193
1194             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1195
1196             # Don't want to actually _DO_ the update if -n specified
1197             unless ( $state->{globaloptions}{-n} )
1198             {
1199                 if ( defined ( $wrev ) )
1200                 {
1201                     # instruct client we're sending a file to put in this path as a replacement
1202                     print "Update-existing $dirpart\n";
1203                     $log->debug("Updating existing file 'Update-existing $dirpart'");
1204                 } else {
1205                     # instruct client we're sending a file to put in this path as a new file
1206                     print "Clear-static-directory $dirpart\n";
1207                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1208                     print "Clear-sticky $dirpart\n";
1209                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1210
1211                     $log->debug("Creating new file 'Created $dirpart'");
1212                     print "Created $dirpart\n";
1213                 }
1214                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1215
1216                 # this is an "entries" line
1217                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1218                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1219                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1220
1221                 # permissions
1222                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1223                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1224
1225                 # transmit file
1226                 transmitfile($meta->{filehash});
1227             }
1228         } else {
1229             $log->info("Updating '$filename'");
1230             my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1231
1232             my $mergeDir = setupTmpDir();
1233
1234             my $file_local = $filepart . ".mine";
1235             my $mergedFile = "$mergeDir/$file_local";
1236             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1237             my $file_old = $filepart . "." . $oldmeta->{revision};
1238             transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1239             my $file_new = $filepart . "." . $meta->{revision};
1240             transmitfile($meta->{filehash}, { targetfile => $file_new });
1241
1242             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1243             $log->info("Merging $file_local, $file_old, $file_new");
1244             print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1245
1246             $log->debug("Temporary directory for merge is $mergeDir");
1247
1248             my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1249             $return >>= 8;
1250
1251             cleanupTmpDir();
1252
1253             if ( $return == 0 )
1254             {
1255                 $log->info("Merged successfully");
1256                 print "M M $filename\n";
1257                 $log->debug("Merged $dirpart");
1258
1259                 # Don't want to actually _DO_ the update if -n specified
1260                 unless ( $state->{globaloptions}{-n} )
1261                 {
1262                     print "Merged $dirpart\n";
1263                     $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1264                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1265                     my $kopts = kopts_from_path("$dirpart/$filepart",
1266                                                 "file",$mergedFile);
1267                     $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1268                     print "/$filepart/1.$meta->{revision}//$kopts/\n";
1269                 }
1270             }
1271             elsif ( $return == 1 )
1272             {
1273                 $log->info("Merged with conflicts");
1274                 print "E cvs update: conflicts found in $filename\n";
1275                 print "M C $filename\n";
1276
1277                 # Don't want to actually _DO_ the update if -n specified
1278                 unless ( $state->{globaloptions}{-n} )
1279                 {
1280                     print "Merged $dirpart\n";
1281                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1282                     my $kopts = kopts_from_path("$dirpart/$filepart",
1283                                                 "file",$mergedFile);
1284                     print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1285                 }
1286             }
1287             else
1288             {
1289                 $log->warn("Merge failed");
1290                 next;
1291             }
1292
1293             # Don't want to actually _DO_ the update if -n specified
1294             unless ( $state->{globaloptions}{-n} )
1295             {
1296                 # permissions
1297                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1298                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1299
1300                 # transmit file, format is single integer on a line by itself (file
1301                 # size) followed by the file contents
1302                 # TODO : we should copy files in blocks
1303                 my $data = `cat $mergedFile`;
1304                 $log->debug("File size : " . length($data));
1305                 print length($data) . "\n";
1306                 print $data;
1307             }
1308         }
1309
1310     }
1311
1312     print "ok\n";
1313 }
1314
1315 sub req_ci
1316 {
1317     my ( $cmd, $data ) = @_;
1318
1319     argsplit("ci");
1320
1321     #$log->debug("State : " . Dumper($state));
1322
1323     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1324
1325     if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1326     {
1327         print "error 1 anonymous user cannot commit via pserver\n";
1328         cleanupWorkTree();
1329         exit;
1330     }
1331
1332     if ( -e $state->{CVSROOT} . "/index" )
1333     {
1334         $log->warn("file 'index' already exists in the git repository");
1335         print "error 1 Index already exists in git repo\n";
1336         cleanupWorkTree();
1337         exit;
1338     }
1339
1340     # Grab a handle to the SQLite db and do any necessary updates
1341     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1342     $updater->update();
1343
1344     # Remember where the head was at the beginning.
1345     my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1346     chomp $parenthash;
1347     if ($parenthash !~ /^[0-9a-f]{40}$/) {
1348             print "error 1 pserver cannot find the current HEAD of module";
1349             cleanupWorkTree();
1350             exit;
1351     }
1352
1353     setupWorkTree($parenthash);
1354
1355     $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1356
1357     $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1358
1359     my @committedfiles = ();
1360     my %oldmeta;
1361
1362     # foreach file specified on the command line ...
1363     foreach my $filename ( @{$state->{args}} )
1364     {
1365         my $committedfile = $filename;
1366         $filename = filecleanup($filename);
1367
1368         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1369
1370         my $meta = $updater->getmeta($filename);
1371         $oldmeta{$filename} = $meta;
1372
1373         my $wrev = revparse($filename);
1374
1375         my ( $filepart, $dirpart ) = filenamesplit($filename);
1376
1377         # do a checkout of the file if it is part of this tree
1378         if ($wrev) {
1379             system('git', 'checkout-index', '-f', '-u', $filename);
1380             unless ($? == 0) {
1381                 die "Error running git-checkout-index -f -u $filename : $!";
1382             }
1383         }
1384
1385         my $addflag = 0;
1386         my $rmflag = 0;
1387         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1388         $addflag = 1 unless ( -e $filename );
1389
1390         # Do up to date checking
1391         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1392         {
1393             # fail everything if an up to date check fails
1394             print "error 1 Up to date check failed for $filename\n";
1395             cleanupWorkTree();
1396             exit;
1397         }
1398
1399         push @committedfiles, $committedfile;
1400         $log->info("Committing $filename");
1401
1402         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1403
1404         unless ( $rmflag )
1405         {
1406             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1407             rename $state->{entries}{$filename}{modified_filename},$filename;
1408
1409             # Calculate modes to remove
1410             my $invmode = "";
1411             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1412
1413             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1414             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1415         }
1416
1417         if ( $rmflag )
1418         {
1419             $log->info("Removing file '$filename'");
1420             unlink($filename);
1421             system("git", "update-index", "--remove", $filename);
1422         }
1423         elsif ( $addflag )
1424         {
1425             $log->info("Adding file '$filename'");
1426             system("git", "update-index", "--add", $filename);
1427         } else {
1428             $log->info("Updating file '$filename'");
1429             system("git", "update-index", $filename);
1430         }
1431     }
1432
1433     unless ( scalar(@committedfiles) > 0 )
1434     {
1435         print "E No files to commit\n";
1436         print "ok\n";
1437         cleanupWorkTree();
1438         return;
1439     }
1440
1441     my $treehash = `git write-tree`;
1442     chomp $treehash;
1443
1444     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1445
1446     # write our commit message out if we have one ...
1447     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1448     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1449     if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1450         if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1451             print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1452         }
1453     } else {
1454         print $msg_fh "\n\nvia git-CVS emulator\n";
1455     }
1456     close $msg_fh;
1457
1458     my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1459     chomp($commithash);
1460     $log->info("Commit hash : $commithash");
1461
1462     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1463     {
1464         $log->warn("Commit failed (Invalid commit hash)");
1465         print "error 1 Commit failed (unknown reason)\n";
1466         cleanupWorkTree();
1467         exit;
1468     }
1469
1470         ### Emulate git-receive-pack by running hooks/update
1471         my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1472                         $parenthash, $commithash );
1473         if( -x $hook[0] ) {
1474                 unless( system( @hook ) == 0 )
1475                 {
1476                         $log->warn("Commit failed (update hook declined to update ref)");
1477                         print "error 1 Commit failed (update hook declined)\n";
1478                         cleanupWorkTree();
1479                         exit;
1480                 }
1481         }
1482
1483         ### Update the ref
1484         if (system(qw(git update-ref -m), "cvsserver ci",
1485                         "refs/heads/$state->{module}", $commithash, $parenthash)) {
1486                 $log->warn("update-ref for $state->{module} failed.");
1487                 print "error 1 Cannot commit -- update first\n";
1488                 cleanupWorkTree();
1489                 exit;
1490         }
1491
1492         ### Emulate git-receive-pack by running hooks/post-receive
1493         my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1494         if( -x $hook ) {
1495                 open(my $pipe, "| $hook") || die "can't fork $!";
1496
1497                 local $SIG{PIPE} = sub { die 'pipe broke' };
1498
1499                 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1500
1501                 close $pipe || die "bad pipe: $! $?";
1502         }
1503
1504     $updater->update();
1505
1506         ### Then hooks/post-update
1507         $hook = $ENV{GIT_DIR}.'hooks/post-update';
1508         if (-x $hook) {
1509                 system($hook, "refs/heads/$state->{module}");
1510         }
1511
1512     # foreach file specified on the command line ...
1513     foreach my $filename ( @committedfiles )
1514     {
1515         $filename = filecleanup($filename);
1516
1517         my $meta = $updater->getmeta($filename);
1518         unless (defined $meta->{revision}) {
1519           $meta->{revision} = 1;
1520         }
1521
1522         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1523
1524         $log->debug("Checked-in $dirpart : $filename");
1525
1526         print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1527         if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1528         {
1529             print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1530             print "Remove-entry $dirpart\n";
1531             print "$filename\n";
1532         } else {
1533             if ($meta->{revision} == 1) {
1534                 print "M initial revision: 1.1\n";
1535             } else {
1536                 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1537             }
1538             print "Checked-in $dirpart\n";
1539             print "$filename\n";
1540             my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1541             print "/$filepart/1.$meta->{revision}//$kopts/\n";
1542         }
1543     }
1544
1545     cleanupWorkTree();
1546     print "ok\n";
1547 }
1548
1549 sub req_status
1550 {
1551     my ( $cmd, $data ) = @_;
1552
1553     argsplit("status");
1554
1555     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1556     #$log->debug("status state : " . Dumper($state));
1557
1558     # Grab a handle to the SQLite db and do any necessary updates
1559     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1560     $updater->update();
1561
1562     # if no files were specified, we need to work out what files we should be providing status on ...
1563     argsfromdir($updater);
1564
1565     # foreach file specified on the command line ...
1566     foreach my $filename ( @{$state->{args}} )
1567     {
1568         $filename = filecleanup($filename);
1569
1570         next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1571
1572         my $meta = $updater->getmeta($filename);
1573         my $oldmeta = $meta;
1574
1575         my $wrev = revparse($filename);
1576
1577         # If the working copy is an old revision, lets get that version too for comparison.
1578         if ( defined($wrev) and $wrev != $meta->{revision} )
1579         {
1580             $oldmeta = $updater->getmeta($filename, $wrev);
1581         }
1582
1583         # TODO : All possible statuses aren't yet implemented
1584         my $status;
1585         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1586         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1587                                     and
1588                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1589                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1590                                    );
1591
1592         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1593         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1594                                           and
1595                                           ( $state->{entries}{$filename}{unchanged}
1596                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1597                                         );
1598
1599         # Need checkout if it exists in the repo but doesn't have a working copy
1600         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1601
1602         # Locally modified if working copy and repo copy have the same revision but there are local changes
1603         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1604
1605         # Needs Merge if working copy revision is less than repo copy and there are local changes
1606         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1607
1608         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1609         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1610         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1611         $status ||= "File had conflicts on merge" if ( 0 );
1612
1613         $status ||= "Unknown";
1614
1615         my ($filepart) = filenamesplit($filename);
1616
1617         print "M ===================================================================\n";
1618         print "M File: $filepart\tStatus: $status\n";
1619         if ( defined($state->{entries}{$filename}{revision}) )
1620         {
1621             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1622         } else {
1623             print "M Working revision:\tNo entry for $filename\n";
1624         }
1625         if ( defined($meta->{revision}) )
1626         {
1627             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1628             print "M Sticky Tag:\t\t(none)\n";
1629             print "M Sticky Date:\t\t(none)\n";
1630             print "M Sticky Options:\t\t(none)\n";
1631         } else {
1632             print "M Repository revision:\tNo revision control file\n";
1633         }
1634         print "M\n";
1635     }
1636
1637     print "ok\n";
1638 }
1639
1640 sub req_diff
1641 {
1642     my ( $cmd, $data ) = @_;
1643
1644     argsplit("diff");
1645
1646     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1647     #$log->debug("status state : " . Dumper($state));
1648
1649     my ($revision1, $revision2);
1650     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1651     {
1652         $revision1 = $state->{opt}{r}[0];
1653         $revision2 = $state->{opt}{r}[1];
1654     } else {
1655         $revision1 = $state->{opt}{r};
1656     }
1657
1658     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1659     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1660
1661     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1662
1663     # Grab a handle to the SQLite db and do any necessary updates
1664     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1665     $updater->update();
1666
1667     # if no files were specified, we need to work out what files we should be providing status on ...
1668     argsfromdir($updater);
1669
1670     # foreach file specified on the command line ...
1671     foreach my $filename ( @{$state->{args}} )
1672     {
1673         $filename = filecleanup($filename);
1674
1675         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1676
1677         my $wrev = revparse($filename);
1678
1679         # We need _something_ to diff against
1680         next unless ( defined ( $wrev ) );
1681
1682         # if we have a -r switch, use it
1683         if ( defined ( $revision1 ) )
1684         {
1685             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1686             $meta1 = $updater->getmeta($filename, $revision1);
1687             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1688             {
1689                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1690                 next;
1691             }
1692             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1693         }
1694         # otherwise we just use the working copy revision
1695         else
1696         {
1697             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1698             $meta1 = $updater->getmeta($filename, $wrev);
1699             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1700         }
1701
1702         # if we have a second -r switch, use it too
1703         if ( defined ( $revision2 ) )
1704         {
1705             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1706             $meta2 = $updater->getmeta($filename, $revision2);
1707
1708             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1709             {
1710                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1711                 next;
1712             }
1713
1714             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1715         }
1716         # otherwise we just use the working copy
1717         else
1718         {
1719             $file2 = $state->{entries}{$filename}{modified_filename};
1720         }
1721
1722         # if we have been given -r, and we don't have a $file2 yet, lets get one
1723         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1724         {
1725             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1726             $meta2 = $updater->getmeta($filename, $wrev);
1727             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1728         }
1729
1730         # We need to have retrieved something useful
1731         next unless ( defined ( $meta1 ) );
1732
1733         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1734         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1735                   and
1736                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1737                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1738                   );
1739
1740         # Apparently we only show diffs for locally modified files
1741         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1742
1743         print "M Index: $filename\n";
1744         print "M ===================================================================\n";
1745         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1746         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1747         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1748         print "M diff ";
1749         foreach my $opt ( keys %{$state->{opt}} )
1750         {
1751             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1752             {
1753                 foreach my $value ( @{$state->{opt}{$opt}} )
1754                 {
1755                     print "-$opt $value ";
1756                 }
1757             } else {
1758                 print "-$opt ";
1759                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1760             }
1761         }
1762         print "$filename\n";
1763
1764         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1765
1766         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1767
1768         if ( exists $state->{opt}{u} )
1769         {
1770             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1771         } else {
1772             system("diff $file1 $file2 > $filediff");
1773         }
1774
1775         while ( <$fh> )
1776         {
1777             print "M $_";
1778         }
1779         close $fh;
1780     }
1781
1782     print "ok\n";
1783 }
1784
1785 sub req_log
1786 {
1787     my ( $cmd, $data ) = @_;
1788
1789     argsplit("log");
1790
1791     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1792     #$log->debug("log state : " . Dumper($state));
1793
1794     my ( $minrev, $maxrev );
1795     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1796     {
1797         my $control = $2;
1798         $minrev = $1;
1799         $maxrev = $3;
1800         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1801         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1802         $minrev++ if ( defined($minrev) and $control eq "::" );
1803     }
1804
1805     # Grab a handle to the SQLite db and do any necessary updates
1806     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1807     $updater->update();
1808
1809     # if no files were specified, we need to work out what files we should be providing status on ...
1810     argsfromdir($updater);
1811
1812     # foreach file specified on the command line ...
1813     foreach my $filename ( @{$state->{args}} )
1814     {
1815         $filename = filecleanup($filename);
1816
1817         my $headmeta = $updater->getmeta($filename);
1818
1819         my $revisions = $updater->getlog($filename);
1820         my $totalrevisions = scalar(@$revisions);
1821
1822         if ( defined ( $minrev ) )
1823         {
1824             $log->debug("Removing revisions less than $minrev");
1825             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1826             {
1827                 pop @$revisions;
1828             }
1829         }
1830         if ( defined ( $maxrev ) )
1831         {
1832             $log->debug("Removing revisions greater than $maxrev");
1833             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1834             {
1835                 shift @$revisions;
1836             }
1837         }
1838
1839         next unless ( scalar(@$revisions) );
1840
1841         print "M \n";
1842         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1843         print "M Working file: $filename\n";
1844         print "M head: 1.$headmeta->{revision}\n";
1845         print "M branch:\n";
1846         print "M locks: strict\n";
1847         print "M access list:\n";
1848         print "M symbolic names:\n";
1849         print "M keyword substitution: kv\n";
1850         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1851         print "M description:\n";
1852
1853         foreach my $revision ( @$revisions )
1854         {
1855             print "M ----------------------------\n";
1856             print "M revision 1.$revision->{revision}\n";
1857             # reformat the date for log output
1858             $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}) );
1859             $revision->{author} = cvs_author($revision->{author});
1860             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1861             my $commitmessage = $updater->commitmessage($revision->{commithash});
1862             $commitmessage =~ s/^/M /mg;
1863             print $commitmessage . "\n";
1864         }
1865         print "M =============================================================================\n";
1866     }
1867
1868     print "ok\n";
1869 }
1870
1871 sub req_annotate
1872 {
1873     my ( $cmd, $data ) = @_;
1874
1875     argsplit("annotate");
1876
1877     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1878     #$log->debug("status state : " . Dumper($state));
1879
1880     # Grab a handle to the SQLite db and do any necessary updates
1881     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1882     $updater->update();
1883
1884     # if no files were specified, we need to work out what files we should be providing annotate on ...
1885     argsfromdir($updater);
1886
1887     # we'll need a temporary checkout dir
1888     setupWorkTree();
1889
1890     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1891
1892     # foreach file specified on the command line ...
1893     foreach my $filename ( @{$state->{args}} )
1894     {
1895         $filename = filecleanup($filename);
1896
1897         my $meta = $updater->getmeta($filename);
1898
1899         next unless ( $meta->{revision} );
1900
1901         # get all the commits that this file was in
1902         # in dense format -- aka skip dead revisions
1903         my $revisions   = $updater->gethistorydense($filename);
1904         my $lastseenin  = $revisions->[0][2];
1905
1906         # populate the temporary index based on the latest commit were we saw
1907         # the file -- but do it cheaply without checking out any files
1908         # TODO: if we got a revision from the client, use that instead
1909         # to look up the commithash in sqlite (still good to default to
1910         # the current head as we do now)
1911         system("git", "read-tree", $lastseenin);
1912         unless ($? == 0)
1913         {
1914             print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1915             return;
1916         }
1917         $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1918
1919         # do a checkout of the file
1920         system('git', 'checkout-index', '-f', '-u', $filename);
1921         unless ($? == 0) {
1922             print "E error running git-checkout-index -f -u $filename : $!\n";
1923             return;
1924         }
1925
1926         $log->info("Annotate $filename");
1927
1928         # Prepare a file with the commits from the linearized
1929         # history that annotate should know about. This prevents
1930         # git-jsannotate telling us about commits we are hiding
1931         # from the client.
1932
1933         my $a_hints = "$work->{workDir}/.annotate_hints";
1934         if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1935             print "E failed to open '$a_hints' for writing: $!\n";
1936             return;
1937         }
1938         for (my $i=0; $i < @$revisions; $i++)
1939         {
1940             print ANNOTATEHINTS $revisions->[$i][2];
1941             if ($i+1 < @$revisions) { # have we got a parent?
1942                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1943             }
1944             print ANNOTATEHINTS "\n";
1945         }
1946
1947         print ANNOTATEHINTS "\n";
1948         close ANNOTATEHINTS
1949             or (print "E failed to write $a_hints: $!\n"), return;
1950
1951         my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
1952         if (!open(ANNOTATE, "-|", @cmd)) {
1953             print "E error invoking ". join(' ',@cmd) .": $!\n";
1954             return;
1955         }
1956         my $metadata = {};
1957         print "E Annotations for $filename\n";
1958         print "E ***************\n";
1959         while ( <ANNOTATE> )
1960         {
1961             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1962             {
1963                 my $commithash = $1;
1964                 my $data = $2;
1965                 unless ( defined ( $metadata->{$commithash} ) )
1966                 {
1967                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1968                     $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1969                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1970                 }
1971                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1972                     $metadata->{$commithash}{revision},
1973                     $metadata->{$commithash}{author},
1974                     $metadata->{$commithash}{modified},
1975                     $data
1976                 );
1977             } else {
1978                 $log->warn("Error in annotate output! LINE: $_");
1979                 print "E Annotate error \n";
1980                 next;
1981             }
1982         }
1983         close ANNOTATE;
1984     }
1985
1986     # done; get out of the tempdir
1987     cleanupWorkTree();
1988
1989     print "ok\n";
1990
1991 }
1992
1993 # This method takes the state->{arguments} array and produces two new arrays.
1994 # The first is $state->{args} which is everything before the '--' argument, and
1995 # the second is $state->{files} which is everything after it.
1996 sub argsplit
1997 {
1998     $state->{args} = [];
1999     $state->{files} = [];
2000     $state->{opt} = {};
2001
2002     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2003
2004     my $type = shift;
2005
2006     if ( defined($type) )
2007     {
2008         my $opt = {};
2009         $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" );
2010         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2011         $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" );
2012         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
2013         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2014         $opt = { k => 1, m => 1 } if ( $type eq "add" );
2015         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2016         $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" );
2017
2018
2019         while ( scalar ( @{$state->{arguments}} ) > 0 )
2020         {
2021             my $arg = shift @{$state->{arguments}};
2022
2023             next if ( $arg eq "--" );
2024             next unless ( $arg =~ /\S/ );
2025
2026             # if the argument looks like a switch
2027             if ( $arg =~ /^-(\w)(.*)/ )
2028             {
2029                 # if it's a switch that takes an argument
2030                 if ( $opt->{$1} )
2031                 {
2032                     # If this switch has already been provided
2033                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2034                     {
2035                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
2036                         if ( length($2) > 0 )
2037                         {
2038                             push @{$state->{opt}{$1}},$2;
2039                         } else {
2040                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2041                         }
2042                     } else {
2043                         # if there's extra data in the arg, use that as the argument for the switch
2044                         if ( length($2) > 0 )
2045                         {
2046                             $state->{opt}{$1} = $2;
2047                         } else {
2048                             $state->{opt}{$1} = shift @{$state->{arguments}};
2049                         }
2050                     }
2051                 } else {
2052                     $state->{opt}{$1} = undef;
2053                 }
2054             }
2055             else
2056             {
2057                 push @{$state->{args}}, $arg;
2058             }
2059         }
2060     }
2061     else
2062     {
2063         my $mode = 0;
2064
2065         foreach my $value ( @{$state->{arguments}} )
2066         {
2067             if ( $value eq "--" )
2068             {
2069                 $mode++;
2070                 next;
2071             }
2072             push @{$state->{args}}, $value if ( $mode == 0 );
2073             push @{$state->{files}}, $value if ( $mode == 1 );
2074         }
2075     }
2076 }
2077
2078 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2079 sub argsfromdir
2080 {
2081     my $updater = shift;
2082
2083     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2084
2085     return if ( scalar ( @{$state->{args}} ) > 1 );
2086
2087     my @gethead = @{$updater->gethead};
2088
2089     # push added files
2090     foreach my $file (keys %{$state->{entries}}) {
2091         if ( exists $state->{entries}{$file}{revision} &&
2092                 $state->{entries}{$file}{revision} == 0 )
2093         {
2094             push @gethead, { name => $file, filehash => 'added' };
2095         }
2096     }
2097
2098     if ( scalar(@{$state->{args}}) == 1 )
2099     {
2100         my $arg = $state->{args}[0];
2101         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2102
2103         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2104
2105         foreach my $file ( @gethead )
2106         {
2107             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2108             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
2109             push @{$state->{args}}, $file->{name};
2110         }
2111
2112         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2113     } else {
2114         $log->info("Only one arg specified, populating file list automatically");
2115
2116         $state->{args} = [];
2117
2118         foreach my $file ( @gethead )
2119         {
2120             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2121             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2122             push @{$state->{args}}, $file->{name};
2123         }
2124     }
2125 }
2126
2127 # This method cleans up the $state variable after a command that uses arguments has run
2128 sub statecleanup
2129 {
2130     $state->{files} = [];
2131     $state->{args} = [];
2132     $state->{arguments} = [];
2133     $state->{entries} = {};
2134 }
2135
2136 # Return working directory revision int "X" from CVS revision "1.X" out
2137 # of the the working directory "entries" state, for the given filename.
2138 # Return negative "X" to represent the file is scheduled for removal
2139 # when it is committed.
2140 sub revparse
2141 {
2142     my $filename = shift;
2143
2144     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2145
2146     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2147     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2148
2149     return undef;
2150 }
2151
2152 # This method takes a file hash and does a CVS "file transfer".  Its
2153 # exact behaviour depends on a second, optional hash table argument:
2154 # - If $options->{targetfile}, dump the contents to that file;
2155 # - If $options->{print}, use M/MT to transmit the contents one line
2156 #   at a time;
2157 # - Otherwise, transmit the size of the file, followed by the file
2158 #   contents.
2159 sub transmitfile
2160 {
2161     my $filehash = shift;
2162     my $options = shift;
2163
2164     if ( defined ( $filehash ) and $filehash eq "deleted" )
2165     {
2166         $log->warn("filehash is 'deleted'");
2167         return;
2168     }
2169
2170     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2171
2172     my $type = `git cat-file -t $filehash`;
2173     chomp $type;
2174
2175     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2176
2177     my $size = `git cat-file -s $filehash`;
2178     chomp $size;
2179
2180     $log->debug("transmitfile($filehash) size=$size, type=$type");
2181
2182     if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2183     {
2184         if ( defined ( $options->{targetfile} ) )
2185         {
2186             my $targetfile = $options->{targetfile};
2187             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2188             print NEWFILE $_ while ( <$fh> );
2189             close NEWFILE or die("Failed to write '$targetfile': $!");
2190         } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2191             while ( <$fh> ) {
2192                 if( /\n\z/ ) {
2193                     print 'M ', $_;
2194                 } else {
2195                     print 'MT text ', $_, "\n";
2196                 }
2197             }
2198         } else {
2199             print "$size\n";
2200             print while ( <$fh> );
2201         }
2202         close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2203     } else {
2204         die("Couldn't execute git-cat-file");
2205     }
2206 }
2207
2208 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2209 # refers to the directory portion and the file portion of the filename
2210 # respectively
2211 sub filenamesplit
2212 {
2213     my $filename = shift;
2214     my $fixforlocaldir = shift;
2215
2216     my ( $filepart, $dirpart ) = ( $filename, "." );
2217     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2218     $dirpart .= "/";
2219
2220     if ( $fixforlocaldir )
2221     {
2222         $dirpart =~ s/^$state->{prependdir}//;
2223     }
2224
2225     return ( $filepart, $dirpart );
2226 }
2227
2228 sub filecleanup
2229 {
2230     my $filename = shift;
2231
2232     return undef unless(defined($filename));
2233     if ( $filename =~ /^\// )
2234     {
2235         print "E absolute filenames '$filename' not supported by server\n";
2236         return undef;
2237     }
2238
2239     $filename =~ s/^\.\///g;
2240     $filename = $state->{prependdir} . $filename;
2241     return $filename;
2242 }
2243
2244 sub validateGitDir
2245 {
2246     if( !defined($state->{CVSROOT}) )
2247     {
2248         print "error 1 CVSROOT not specified\n";
2249         cleanupWorkTree();
2250         exit;
2251     }
2252     if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2253     {
2254         print "error 1 Internally inconsistent CVSROOT\n";
2255         cleanupWorkTree();
2256         exit;
2257     }
2258 }
2259
2260 # Setup working directory in a work tree with the requested version
2261 # loaded in the index.
2262 sub setupWorkTree
2263 {
2264     my ($ver) = @_;
2265
2266     validateGitDir();
2267
2268     if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2269         defined($work->{tmpDir}) )
2270     {
2271         $log->warn("Bad work tree state management");
2272         print "error 1 Internal setup multiple work trees without cleanup\n";
2273         cleanupWorkTree();
2274         exit;
2275     }
2276
2277     $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2278
2279     if( !defined($work->{index}) )
2280     {
2281         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2282     }
2283
2284     chdir $work->{workDir} or
2285         die "Unable to chdir to $work->{workDir}\n";
2286
2287     $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2288
2289     $ENV{GIT_WORK_TREE} = ".";
2290     $ENV{GIT_INDEX_FILE} = $work->{index};
2291     $work->{state} = 2;
2292
2293     if($ver)
2294     {
2295         system("git","read-tree",$ver);
2296         unless ($? == 0)
2297         {
2298             $log->warn("Error running git-read-tree");
2299             die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2300         }
2301     }
2302     # else # req_annotate reads tree for each file
2303 }
2304
2305 # Ensure current directory is in some kind of working directory,
2306 # with a recent version loaded in the index.
2307 sub ensureWorkTree
2308 {
2309     if( defined($work->{tmpDir}) )
2310     {
2311         $log->warn("Bad work tree state management [ensureWorkTree()]");
2312         print "error 1 Internal setup multiple dirs without cleanup\n";
2313         cleanupWorkTree();
2314         exit;
2315     }
2316     if( $work->{state} )
2317     {
2318         return;
2319     }
2320
2321     validateGitDir();
2322
2323     if( !defined($work->{emptyDir}) )
2324     {
2325         $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2326     }
2327     chdir $work->{emptyDir} or
2328         die "Unable to chdir to $work->{emptyDir}\n";
2329
2330     my $ver = `git show-ref -s refs/heads/$state->{module}`;
2331     chomp $ver;
2332     if ($ver !~ /^[0-9a-f]{40}$/)
2333     {
2334         $log->warn("Error from git show-ref -s refs/head$state->{module}");
2335         print "error 1 cannot find the current HEAD of module";
2336         cleanupWorkTree();
2337         exit;
2338     }
2339
2340     if( !defined($work->{index}) )
2341     {
2342         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2343     }
2344
2345     $ENV{GIT_WORK_TREE} = ".";
2346     $ENV{GIT_INDEX_FILE} = $work->{index};
2347     $work->{state} = 1;
2348
2349     system("git","read-tree",$ver);
2350     unless ($? == 0)
2351     {
2352         die "Error running git-read-tree $ver $!\n";
2353     }
2354 }
2355
2356 # Cleanup working directory that is not needed any longer.
2357 sub cleanupWorkTree
2358 {
2359     if( ! $work->{state} )
2360     {
2361         return;
2362     }
2363
2364     chdir "/" or die "Unable to chdir '/'\n";
2365
2366     if( defined($work->{workDir}) )
2367     {
2368         rmtree( $work->{workDir} );
2369         undef $work->{workDir};
2370     }
2371     undef $work->{state};
2372 }
2373
2374 # Setup a temporary directory (not a working tree), typically for
2375 # merging dirty state as in req_update.
2376 sub setupTmpDir
2377 {
2378     $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2379     chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2380
2381     return $work->{tmpDir};
2382 }
2383
2384 # Clean up a previously setupTmpDir.  Restore previous work tree if
2385 # appropriate.
2386 sub cleanupTmpDir
2387 {
2388     if ( !defined($work->{tmpDir}) )
2389     {
2390         $log->warn("cleanup tmpdir that has not been setup");
2391         die "Cleanup tmpDir that has not been setup\n";
2392     }
2393     if( defined($work->{state}) )
2394     {
2395         if( $work->{state} == 1 )
2396         {
2397             chdir $work->{emptyDir} or
2398                 die "Unable to chdir to $work->{emptyDir}\n";
2399         }
2400         elsif( $work->{state} == 2 )
2401         {
2402             chdir $work->{workDir} or
2403                 die "Unable to chdir to $work->{emptyDir}\n";
2404         }
2405         else
2406         {
2407             $log->warn("Inconsistent work dir state");
2408             die "Inconsistent work dir state\n";
2409         }
2410     }
2411     else
2412     {
2413         chdir "/" or die "Unable to chdir '/'\n";
2414     }
2415 }
2416
2417 # Given a path, this function returns a string containing the kopts
2418 # that should go into that path's Entries line.  For example, a binary
2419 # file should get -kb.
2420 sub kopts_from_path
2421 {
2422     my ($path, $srcType, $name) = @_;
2423
2424     if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2425          $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2426     {
2427         my ($val) = check_attr( "text", $path );
2428         if ( $val eq "unspecified" )
2429         {
2430             $val = check_attr( "crlf", $path );
2431         }
2432         if ( $val eq "unset" )
2433         {
2434             return "-kb"
2435         }
2436         elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2437                 $val eq "set" || $val eq "input" )
2438         {
2439             return "";
2440         }
2441         else
2442         {
2443             $log->info("Unrecognized check_attr crlf $path : $val");
2444         }
2445     }
2446
2447     if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2448     {
2449         if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2450         {
2451             return "-kb";
2452         }
2453         elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2454         {
2455             if( is_binary($srcType,$name) )
2456             {
2457                 $log->debug("... as binary");
2458                 return "-kb";
2459             }
2460             else
2461             {
2462                 $log->debug("... as text");
2463             }
2464         }
2465     }
2466     # Return "" to give no special treatment to any path
2467     return "";
2468 }
2469
2470 sub check_attr
2471 {
2472     my ($attr,$path) = @_;
2473     ensureWorkTree();
2474     if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2475     {
2476         my $val = <$fh>;
2477         close $fh;
2478         $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2479         return $val;
2480     }
2481     else
2482     {
2483         return undef;
2484     }
2485 }
2486
2487 # This should have the same heuristics as convert.c:is_binary() and related.
2488 # Note that the bare CR test is done by callers in convert.c.
2489 sub is_binary
2490 {
2491     my ($srcType,$name) = @_;
2492     $log->debug("is_binary($srcType,$name)");
2493
2494     # Minimize amount of interpreted code run in the inner per-character
2495     # loop for large files, by totalling each character value and
2496     # then analyzing the totals.
2497     my @counts;
2498     my $i;
2499     for($i=0;$i<256;$i++)
2500     {
2501         $counts[$i]=0;
2502     }
2503
2504     my $fh = open_blob_or_die($srcType,$name);
2505     my $line;
2506     while( defined($line=<$fh>) )
2507     {
2508         # Any '\0' and bare CR are considered binary.
2509         if( $line =~ /\0|(\r[^\n])/ )
2510         {
2511             close($fh);
2512             return 1;
2513         }
2514
2515         # Count up each character in the line:
2516         my $len=length($line);
2517         for($i=0;$i<$len;$i++)
2518         {
2519             $counts[ord(substr($line,$i,1))]++;
2520         }
2521     }
2522     close $fh;
2523
2524     # Don't count CR and LF as either printable/nonprintable
2525     $counts[ord("\n")]=0;
2526     $counts[ord("\r")]=0;
2527
2528     # Categorize individual character count into printable and nonprintable:
2529     my $printable=0;
2530     my $nonprintable=0;
2531     for($i=0;$i<256;$i++)
2532     {
2533         if( $i < 32 &&
2534             $i != ord("\b") &&
2535             $i != ord("\t") &&
2536             $i != 033 &&       # ESC
2537             $i != 014 )        # FF
2538         {
2539             $nonprintable+=$counts[$i];
2540         }
2541         elsif( $i==127 )  # DEL
2542         {
2543             $nonprintable+=$counts[$i];
2544         }
2545         else
2546         {
2547             $printable+=$counts[$i];
2548         }
2549     }
2550
2551     return ($printable >> 7) < $nonprintable;
2552 }
2553
2554 # Returns open file handle.  Possible invocations:
2555 #  - open_blob_or_die("file",$filename);
2556 #  - open_blob_or_die("sha1",$filehash);
2557 sub open_blob_or_die
2558 {
2559     my ($srcType,$name) = @_;
2560     my ($fh);
2561     if( $srcType eq "file" )
2562     {
2563         if( !open $fh,"<",$name )
2564         {
2565             $log->warn("Unable to open file $name: $!");
2566             die "Unable to open file $name: $!\n";
2567         }
2568     }
2569     elsif( $srcType eq "sha1" )
2570     {
2571         unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2572         {
2573             $log->warn("Need filehash");
2574             die "Need filehash\n";
2575         }
2576
2577         my $type = `git cat-file -t $name`;
2578         chomp $type;
2579
2580         unless ( defined ( $type ) and $type eq "blob" )
2581         {
2582             $log->warn("Invalid type '$type' for '$name'");
2583             die ( "Invalid type '$type' (expected 'blob')" )
2584         }
2585
2586         my $size = `git cat-file -s $name`;
2587         chomp $size;
2588
2589         $log->debug("open_blob_or_die($name) size=$size, type=$type");
2590
2591         unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2592         {
2593             $log->warn("Unable to open sha1 $name");
2594             die "Unable to open sha1 $name\n";
2595         }
2596     }
2597     else
2598     {
2599         $log->warn("Unknown type of blob source: $srcType");
2600         die "Unknown type of blob source: $srcType\n";
2601     }
2602     return $fh;
2603 }
2604
2605 # Generate a CVS author name from Git author information, by taking the local
2606 # part of the email address and replacing characters not in the Portable
2607 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2608 # Login names are Unix login names, which should be restricted to this
2609 # character set.
2610 sub cvs_author
2611 {
2612     my $author_line = shift;
2613     (my $author) = $author_line =~ /<([^@>]*)/;
2614
2615     $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2616     $author =~ s/^-/_/;
2617
2618     $author;
2619 }
2620
2621
2622 sub descramble
2623 {
2624     # This table is from src/scramble.c in the CVS source
2625     my @SHIFTS = (
2626         0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15,
2627         16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2628         114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2629         111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2630         41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2631         125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2632         36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2633         58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2634         225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2635         199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2636         174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2637         207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2638         192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2639         227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2640         182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2641         243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2642     );
2643     my ($str) = @_;
2644
2645     # This should never happen, the same password format (A) has been
2646     # used by CVS since the beginning of time
2647     {
2648         my $fmt = substr($str, 0, 1);
2649         die "invalid password format `$fmt'" unless $fmt eq 'A';
2650     }
2651
2652     my @str = unpack "C*", substr($str, 1);
2653     my $ret = join '', map { chr $SHIFTS[$_] } @str;
2654     return $ret;
2655 }
2656
2657
2658 package GITCVS::log;
2659
2660 ####
2661 #### Copyright The Open University UK - 2006.
2662 ####
2663 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2664 ####          Martin Langhoff <martin@laptop.org>
2665 ####
2666 ####
2667
2668 use strict;
2669 use warnings;
2670
2671 =head1 NAME
2672
2673 GITCVS::log
2674
2675 =head1 DESCRIPTION
2676
2677 This module provides very crude logging with a similar interface to
2678 Log::Log4perl
2679
2680 =head1 METHODS
2681
2682 =cut
2683
2684 =head2 new
2685
2686 Creates a new log object, optionally you can specify a filename here to
2687 indicate the file to log to. If no log file is specified, you can specify one
2688 later with method setfile, or indicate you no longer want logging with method
2689 nofile.
2690
2691 Until one of these methods is called, all log calls will buffer messages ready
2692 to write out.
2693
2694 =cut
2695 sub new
2696 {
2697     my $class = shift;
2698     my $filename = shift;
2699
2700     my $self = {};
2701
2702     bless $self, $class;
2703
2704     if ( defined ( $filename ) )
2705     {
2706         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2707     }
2708
2709     return $self;
2710 }
2711
2712 =head2 setfile
2713
2714 This methods takes a filename, and attempts to open that file as the log file.
2715 If successful, all buffered data is written out to the file, and any further
2716 logging is written directly to the file.
2717
2718 =cut
2719 sub setfile
2720 {
2721     my $self = shift;
2722     my $filename = shift;
2723
2724     if ( defined ( $filename ) )
2725     {
2726         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2727     }
2728
2729     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2730
2731     while ( my $line = shift @{$self->{buffer}} )
2732     {
2733         print {$self->{fh}} $line;
2734     }
2735 }
2736
2737 =head2 nofile
2738
2739 This method indicates no logging is going to be used. It flushes any entries in
2740 the internal buffer, and sets a flag to ensure no further data is put there.
2741
2742 =cut
2743 sub nofile
2744 {
2745     my $self = shift;
2746
2747     $self->{nolog} = 1;
2748
2749     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2750
2751     $self->{buffer} = [];
2752 }
2753
2754 =head2 _logopen
2755
2756 Internal method. Returns true if the log file is open, false otherwise.
2757
2758 =cut
2759 sub _logopen
2760 {
2761     my $self = shift;
2762
2763     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2764     return 0;
2765 }
2766
2767 =head2 debug info warn fatal
2768
2769 These four methods are wrappers to _log. They provide the actual interface for
2770 logging data.
2771
2772 =cut
2773 sub debug { my $self = shift; $self->_log("debug", @_); }
2774 sub info  { my $self = shift; $self->_log("info" , @_); }
2775 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2776 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2777
2778 =head2 _log
2779
2780 This is an internal method called by the logging functions. It generates a
2781 timestamp and pushes the logged line either to file, or internal buffer.
2782
2783 =cut
2784 sub _log
2785 {
2786     my $self = shift;
2787     my $level = shift;
2788
2789     return if ( $self->{nolog} );
2790
2791     my @time = localtime;
2792     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2793         $time[5] + 1900,
2794         $time[4] + 1,
2795         $time[3],
2796         $time[2],
2797         $time[1],
2798         $time[0],
2799         uc $level,
2800     );
2801
2802     if ( $self->_logopen )
2803     {
2804         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2805     } else {
2806         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2807     }
2808 }
2809
2810 =head2 DESTROY
2811
2812 This method simply closes the file handle if one is open
2813
2814 =cut
2815 sub DESTROY
2816 {
2817     my $self = shift;
2818
2819     if ( $self->_logopen )
2820     {
2821         close $self->{fh};
2822     }
2823 }
2824
2825 package GITCVS::updater;
2826
2827 ####
2828 #### Copyright The Open University UK - 2006.
2829 ####
2830 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2831 ####          Martin Langhoff <martin@laptop.org>
2832 ####
2833 ####
2834
2835 use strict;
2836 use warnings;
2837 use DBI;
2838
2839 =head1 METHODS
2840
2841 =cut
2842
2843 =head2 new
2844
2845 =cut
2846 sub new
2847 {
2848     my $class = shift;
2849     my $config = shift;
2850     my $module = shift;
2851     my $log = shift;
2852
2853     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2854     die "Need to specify a module" unless ( defined($module) );
2855
2856     $class = ref($class) || $class;
2857
2858     my $self = {};
2859
2860     bless $self, $class;
2861
2862     $self->{valid_tables} = {'revision' => 1,
2863                              'revision_ix1' => 1,
2864                              'revision_ix2' => 1,
2865                              'head' => 1,
2866                              'head_ix1' => 1,
2867                              'properties' => 1,
2868                              'commitmsgs' => 1};
2869
2870     $self->{module} = $module;
2871     $self->{git_path} = $config . "/";
2872
2873     $self->{log} = $log;
2874
2875     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2876
2877     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2878         $cfg->{gitcvs}{dbdriver} || "SQLite";
2879     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2880         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2881     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2882         $cfg->{gitcvs}{dbuser} || "";
2883     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2884         $cfg->{gitcvs}{dbpass} || "";
2885     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2886         $cfg->{gitcvs}{dbtablenameprefix} || "";
2887     my %mapping = ( m => $module,
2888                     a => $state->{method},
2889                     u => getlogin || getpwuid($<) || $<,
2890                     G => $self->{git_path},
2891                     g => mangle_dirname($self->{git_path}),
2892                     );
2893     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2894     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2895     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2896     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2897
2898     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2899     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2900     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2901                                 $self->{dbuser},
2902                                 $self->{dbpass});
2903     die "Error connecting to database\n" unless defined $self->{dbh};
2904
2905     $self->{tables} = {};
2906     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2907     {
2908         $self->{tables}{$table} = 1;
2909     }
2910
2911     # Construct the revision table if required
2912     # The revision table stores an entry for each file, each time that file
2913     # changes.
2914     #   numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
2915     # This is not sufficient to support "-r {commithash}" for any
2916     # files except files that were modified by that commit (also,
2917     # some places in the code ignore/effectively strip out -r in
2918     # some cases, before it gets passed to getmeta()).
2919     # The "filehash" field typically has a git blob hash, but can also
2920     # be set to "dead" to indicate that the given version of the file
2921     # should not exist in the sandbox.
2922     unless ( $self->{tables}{$self->tablename("revision")} )
2923     {
2924         my $tablename = $self->tablename("revision");
2925         my $ix1name = $self->tablename("revision_ix1");
2926         my $ix2name = $self->tablename("revision_ix2");
2927         $self->{dbh}->do("
2928             CREATE TABLE $tablename (
2929                 name       TEXT NOT NULL,
2930                 revision   INTEGER NOT NULL,
2931                 filehash   TEXT NOT NULL,
2932                 commithash TEXT NOT NULL,
2933                 author     TEXT NOT NULL,
2934                 modified   TEXT NOT NULL,
2935                 mode       TEXT NOT NULL
2936             )
2937         ");
2938         $self->{dbh}->do("
2939             CREATE INDEX $ix1name
2940             ON $tablename (name,revision)
2941         ");
2942         $self->{dbh}->do("
2943             CREATE INDEX $ix2name
2944             ON $tablename (name,commithash)
2945         ");
2946     }
2947
2948     # Construct the head table if required
2949     # The head table (along with the "last_commit" entry in the property
2950     # table) is the persisted working state of the "sub update" subroutine.
2951     # All of it's data is read entirely first, and completely recreated
2952     # last, every time "sub update" runs.
2953     # This is also used by "sub getmeta" when it is asked for the latest
2954     # version of a file (as opposed to some specific version).
2955     # Another way of thinking about it is as a single slice out of
2956     # "revisions", giving just the most recent revision information for
2957     # each file.
2958     unless ( $self->{tables}{$self->tablename("head")} )
2959     {
2960         my $tablename = $self->tablename("head");
2961         my $ix1name = $self->tablename("head_ix1");
2962         $self->{dbh}->do("
2963             CREATE TABLE $tablename (
2964                 name       TEXT NOT NULL,
2965                 revision   INTEGER NOT NULL,
2966                 filehash   TEXT NOT NULL,
2967                 commithash TEXT NOT NULL,
2968                 author     TEXT NOT NULL,
2969                 modified   TEXT NOT NULL,
2970                 mode       TEXT NOT NULL
2971             )
2972         ");
2973         $self->{dbh}->do("
2974             CREATE INDEX $ix1name
2975             ON $tablename (name)
2976         ");
2977     }
2978
2979     # Construct the properties table if required
2980     #  - "last_commit" - Used by "sub update".
2981     unless ( $self->{tables}{$self->tablename("properties")} )
2982     {
2983         my $tablename = $self->tablename("properties");
2984         $self->{dbh}->do("
2985             CREATE TABLE $tablename (
2986                 key        TEXT NOT NULL PRIMARY KEY,
2987                 value      TEXT
2988             )
2989         ");
2990     }
2991
2992     # Construct the commitmsgs table if required
2993     # The commitmsgs table is only used for merge commits, since
2994     # "sub update" will only keep one branch of parents.  Shortlogs
2995     # for ignored commits (i.e. not on the chosen branch) will be used
2996     # to construct a replacement "collapsed" merge commit message,
2997     # which will be stored in this table.  See also "sub commitmessage".
2998     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2999     {
3000         my $tablename = $self->tablename("commitmsgs");
3001         $self->{dbh}->do("
3002             CREATE TABLE $tablename (
3003                 key        TEXT NOT NULL PRIMARY KEY,
3004                 value      TEXT
3005             )
3006         ");
3007     }
3008
3009     return $self;
3010 }
3011
3012 =head2 tablename
3013
3014 =cut
3015 sub tablename
3016 {
3017     my $self = shift;
3018     my $name = shift;
3019
3020     if (exists $self->{valid_tables}{$name}) {
3021         return $self->{dbtablenameprefix} . $name;
3022     } else {
3023         return undef;
3024     }
3025 }
3026
3027 =head2 update
3028
3029 Bring the database up to date with the latest changes from
3030 the git repository.
3031
3032 Internal working state is read out of the "head" table and the
3033 "last_commit" property, then it updates "revisions" based on that, and
3034 finally it writes the new internal state back to the "head" table
3035 so it can be used as a starting point the next time update is called.
3036
3037 =cut
3038 sub update
3039 {
3040     my $self = shift;
3041
3042     # first lets get the commit list
3043     $ENV{GIT_DIR} = $self->{git_path};
3044
3045     my $commitsha1 = `git rev-parse $self->{module}`;
3046     chomp $commitsha1;
3047
3048     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3049     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3050     {
3051         die("Invalid module '$self->{module}'");
3052     }
3053
3054
3055     my $git_log;
3056     my $lastcommit = $self->_get_prop("last_commit");
3057
3058     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3059          return 1;
3060     }
3061
3062     # Start exclusive lock here...
3063     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3064
3065     # TODO: log processing is memory bound
3066     # if we can parse into a 2nd file that is in reverse order
3067     # we can probably do something really efficient
3068     my @git_log_params = ('--pretty', '--parents', '--topo-order');
3069
3070     if (defined $lastcommit) {
3071         push @git_log_params, "$lastcommit..$self->{module}";
3072     } else {
3073         push @git_log_params, $self->{module};
3074     }
3075     # git-rev-list is the backend / plumbing version of git-log
3076     open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3077
3078     my @commits;
3079
3080     my %commit = ();
3081
3082     while ( <GITLOG> )
3083     {
3084         chomp;
3085         if (m/^commit\s+(.*)$/) {
3086             # on ^commit lines put the just seen commit in the stack
3087             # and prime things for the next one
3088             if (keys %commit) {
3089                 my %copy = %commit;
3090                 unshift @commits, \%copy;
3091                 %commit = ();
3092             }
3093             my @parents = split(m/\s+/, $1);
3094             $commit{hash} = shift @parents;
3095             $commit{parents} = \@parents;
3096         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3097             # on rfc822-like lines seen before we see any message,
3098             # lowercase the entry and put it in the hash as key-value
3099             $commit{lc($1)} = $2;
3100         } else {
3101             # message lines - skip initial empty line
3102             # and trim whitespace
3103             if (!exists($commit{message}) && m/^\s*$/) {
3104                 # define it to mark the end of headers
3105                 $commit{message} = '';
3106                 next;
3107             }
3108             s/^\s+//; s/\s+$//; # trim ws
3109             $commit{message} .= $_ . "\n";
3110         }
3111     }
3112     close GITLOG;
3113
3114     unshift @commits, \%commit if ( keys %commit );
3115
3116     # Now all the commits are in the @commits bucket
3117     # ordered by time DESC. for each commit that needs processing,
3118     # determine whether it's following the last head we've seen or if
3119     # it's on its own branch, grab a file list, and add whatever's changed
3120     # NOTE: $lastcommit refers to the last commit from previous run
3121     #       $lastpicked is the last commit we picked in this run
3122     my $lastpicked;
3123     my $head = {};
3124     if (defined $lastcommit) {
3125         $lastpicked = $lastcommit;
3126     }
3127
3128     my $committotal = scalar(@commits);
3129     my $commitcount = 0;
3130
3131     # Load the head table into $head (for cached lookups during the update process)
3132     foreach my $file ( @{$self->gethead()} )
3133     {
3134         $head->{$file->{name}} = $file;
3135     }
3136
3137     foreach my $commit ( @commits )
3138     {
3139         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3140         if (defined $lastpicked)
3141         {
3142             if (!in_array($lastpicked, @{$commit->{parents}}))
3143             {
3144                 # skip, we'll see this delta
3145                 # as part of a merge later
3146                 # warn "skipping off-track  $commit->{hash}\n";
3147                 next;
3148             } elsif (@{$commit->{parents}} > 1) {
3149                 # it is a merge commit, for each parent that is
3150                 # not $lastpicked (not given a CVS revision number),
3151                 # see if we can get a log
3152                 # from the merge-base to that parent to put it
3153                 # in the message as a merge summary.
3154                 my @parents = @{$commit->{parents}};
3155                 foreach my $parent (@parents) {
3156                     if ($parent eq $lastpicked) {
3157                         next;
3158                     }
3159                     # git-merge-base can potentially (but rarely) throw
3160                     # several candidate merge bases. let's assume
3161                     # that the first one is the best one.
3162                     my $base = eval {
3163                             safe_pipe_capture('git', 'merge-base',
3164                                                  $lastpicked, $parent);
3165                     };
3166                     # The two branches may not be related at all,
3167                     # in which case merge base simply fails to find
3168                     # any, but that's Ok.
3169                     next if ($@);
3170
3171                     chomp $base;
3172                     if ($base) {
3173                         my @merged;
3174                         # print "want to log between  $base $parent \n";
3175                         open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3176                           or die "Cannot call git-log: $!";
3177                         my $mergedhash;
3178                         while (<GITLOG>) {
3179                             chomp;
3180                             if (!defined $mergedhash) {
3181                                 if (m/^commit\s+(.+)$/) {
3182                                     $mergedhash = $1;
3183                                 } else {
3184                                     next;
3185                                 }
3186                             } else {
3187                                 # grab the first line that looks non-rfc822
3188                                 # aka has content after leading space
3189                                 if (m/^\s+(\S.*)$/) {
3190                                     my $title = $1;
3191                                     $title = substr($title,0,100); # truncate
3192                                     unshift @merged, "$mergedhash $title";
3193                                     undef $mergedhash;
3194                                 }
3195                             }
3196                         }
3197                         close GITLOG;
3198                         if (@merged) {
3199                             $commit->{mergemsg} = $commit->{message};
3200                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3201                             foreach my $summary (@merged) {
3202                                 $commit->{mergemsg} .= "\t$summary\n";
3203                             }
3204                             $commit->{mergemsg} .= "\n\n";
3205                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3206                         }
3207                     }
3208                 }
3209             }
3210         }
3211
3212         # convert the date to CVS-happy format
3213         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3214
3215         if ( defined ( $lastpicked ) )
3216         {
3217             my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3218             local ($/) = "\0";
3219             while ( <FILELIST> )
3220             {
3221                 chomp;
3222                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3223                 {
3224                     die("Couldn't process git-diff-tree line : $_");
3225                 }
3226                 my ($mode, $hash, $change) = ($1, $2, $3);
3227                 my $name = <FILELIST>;
3228                 chomp($name);
3229
3230                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3231
3232                 my $git_perms = "";
3233                 $git_perms .= "r" if ( $mode & 4 );
3234                 $git_perms .= "w" if ( $mode & 2 );
3235                 $git_perms .= "x" if ( $mode & 1 );
3236                 $git_perms = "rw" if ( $git_perms eq "" );
3237
3238                 if ( $change eq "D" )
3239                 {
3240                     #$log->debug("DELETE   $name");
3241                     $head->{$name} = {
3242                         name => $name,
3243                         revision => $head->{$name}{revision} + 1,
3244                         filehash => "deleted",
3245                         commithash => $commit->{hash},
3246                         modified => $commit->{date},
3247                         author => $commit->{author},
3248                         mode => $git_perms,
3249                     };
3250                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3251                 }
3252                 elsif ( $change eq "M" || $change eq "T" )
3253                 {
3254                     #$log->debug("MODIFIED $name");
3255                     $head->{$name} = {
3256                         name => $name,
3257                         revision => $head->{$name}{revision} + 1,
3258                         filehash => $hash,
3259                         commithash => $commit->{hash},
3260                         modified => $commit->{date},
3261                         author => $commit->{author},
3262                         mode => $git_perms,
3263                     };
3264                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3265                 }
3266                 elsif ( $change eq "A" )
3267                 {
3268                     #$log->debug("ADDED    $name");
3269                     $head->{$name} = {
3270                         name => $name,
3271                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3272                         filehash => $hash,
3273                         commithash => $commit->{hash},
3274                         modified => $commit->{date},
3275                         author => $commit->{author},
3276                         mode => $git_perms,
3277                     };
3278                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3279                 }
3280                 else
3281                 {
3282                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3283                     die;
3284                 }
3285             }
3286             close FILELIST;
3287         } else {
3288             # this is used to detect files removed from the repo
3289             my $seen_files = {};
3290
3291             my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3292             local $/ = "\0";
3293             while ( <FILELIST> )
3294             {
3295                 chomp;
3296                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3297                 {
3298                     die("Couldn't process git-ls-tree line : $_");
3299                 }
3300
3301                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3302
3303                 $seen_files->{$git_filename} = 1;
3304
3305                 my ( $oldhash, $oldrevision, $oldmode ) = (
3306                     $head->{$git_filename}{filehash},
3307                     $head->{$git_filename}{revision},
3308                     $head->{$git_filename}{mode}
3309                 );
3310
3311                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3312                 {
3313                     $git_perms = "";
3314                     $git_perms .= "r" if ( $1 & 4 );
3315                     $git_perms .= "w" if ( $1 & 2 );
3316                     $git_perms .= "x" if ( $1 & 1 );
3317                 } else {
3318                     $git_perms = "rw";
3319                 }
3320
3321                 # unless the file exists with the same hash, we need to update it ...
3322                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3323                 {
3324                     my $newrevision = ( $oldrevision or 0 ) + 1;
3325
3326                     $head->{$git_filename} = {
3327                         name => $git_filename,
3328                         revision => $newrevision,
3329                         filehash => $git_hash,
3330                         commithash => $commit->{hash},
3331                         modified => $commit->{date},
3332                         author => $commit->{author},
3333                         mode => $git_perms,
3334                     };
3335
3336
3337                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3338                 }
3339             }
3340             close FILELIST;
3341
3342             # Detect deleted files
3343             foreach my $file ( keys %$head )
3344             {
3345                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3346                 {
3347                     $head->{$file}{revision}++;
3348                     $head->{$file}{filehash} = "deleted";
3349                     $head->{$file}{commithash} = $commit->{hash};
3350                     $head->{$file}{modified} = $commit->{date};
3351                     $head->{$file}{author} = $commit->{author};
3352
3353                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3354                 }
3355             }
3356             # END : "Detect deleted files"
3357         }
3358
3359
3360         if (exists $commit->{mergemsg})
3361         {
3362             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3363         }
3364
3365         $lastpicked = $commit->{hash};
3366
3367         $self->_set_prop("last_commit", $commit->{hash});
3368     }
3369
3370     $self->delete_head();
3371     foreach my $file ( keys %$head )
3372     {
3373         $self->insert_head(
3374             $file,
3375             $head->{$file}{revision},
3376             $head->{$file}{filehash},
3377             $head->{$file}{commithash},
3378             $head->{$file}{modified},
3379             $head->{$file}{author},
3380             $head->{$file}{mode},
3381         );
3382     }
3383     # invalidate the gethead cache
3384     $self->{gethead_cache} = undef;
3385
3386
3387     # Ending exclusive lock here
3388     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3389 }
3390
3391 sub insert_rev
3392 {
3393     my $self = shift;
3394     my $name = shift;
3395     my $revision = shift;
3396     my $filehash = shift;
3397     my $commithash = shift;
3398     my $modified = shift;
3399     my $author = shift;
3400     my $mode = shift;
3401     my $tablename = $self->tablename("revision");
3402
3403     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3404     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3405 }
3406
3407 sub insert_mergelog
3408 {
3409     my $self = shift;
3410     my $key = shift;
3411     my $value = shift;
3412     my $tablename = $self->tablename("commitmsgs");
3413
3414     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3415     $insert_mergelog->execute($key, $value);
3416 }
3417
3418 sub delete_head
3419 {
3420     my $self = shift;
3421     my $tablename = $self->tablename("head");
3422
3423     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3424     $delete_head->execute();
3425 }
3426
3427 sub insert_head
3428 {
3429     my $self = shift;
3430     my $name = shift;
3431     my $revision = shift;
3432     my $filehash = shift;
3433     my $commithash = shift;
3434     my $modified = shift;
3435     my $author = shift;
3436     my $mode = shift;
3437     my $tablename = $self->tablename("head");
3438
3439     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3440     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3441 }
3442
3443 sub _get_prop
3444 {
3445     my $self = shift;
3446     my $key = shift;
3447     my $tablename = $self->tablename("properties");
3448
3449     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3450     $db_query->execute($key);
3451     my ( $value ) = $db_query->fetchrow_array;
3452
3453     return $value;
3454 }
3455
3456 sub _set_prop
3457 {
3458     my $self = shift;
3459     my $key = shift;
3460     my $value = shift;
3461     my $tablename = $self->tablename("properties");
3462
3463     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3464     $db_query->execute($value, $key);
3465
3466     unless ( $db_query->rows )
3467     {
3468         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3469         $db_query->execute($key, $value);
3470     }
3471
3472     return $value;
3473 }
3474
3475 =head2 gethead
3476
3477 =cut
3478
3479 sub gethead
3480 {
3481     my $self = shift;
3482     my $tablename = $self->tablename("head");
3483
3484     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3485
3486     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3487     $db_query->execute();
3488
3489     my $tree = [];
3490     while ( my $file = $db_query->fetchrow_hashref )
3491     {
3492         push @$tree, $file;
3493     }
3494
3495     $self->{gethead_cache} = $tree;
3496
3497     return $tree;
3498 }
3499
3500 =head2 getlog
3501
3502 See also gethistorydense().
3503
3504 =cut
3505
3506 sub getlog
3507 {
3508     my $self = shift;
3509     my $filename = shift;
3510     my $tablename = $self->tablename("revision");
3511
3512     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3513     $db_query->execute($filename);
3514
3515     my $tree = [];
3516     while ( my $file = $db_query->fetchrow_hashref )
3517     {
3518         push @$tree, $file;
3519     }
3520
3521     return $tree;
3522 }
3523
3524 =head2 getmeta
3525
3526 This function takes a filename (with path) argument and returns a hashref of
3527 metadata for that file.
3528
3529 =cut
3530
3531 sub getmeta
3532 {
3533     my $self = shift;
3534     my $filename = shift;
3535     my $revision = shift;
3536     my $tablename_rev = $self->tablename("revision");
3537     my $tablename_head = $self->tablename("head");
3538
3539     my $db_query;
3540     if ( defined($revision) and $revision =~ /^\d+$/ )
3541     {
3542         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3543         $db_query->execute($filename, $revision);
3544     }
3545     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3546     {
3547         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3548         $db_query->execute($filename, $revision);
3549     } else {
3550         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3551         $db_query->execute($filename);
3552     }
3553
3554     return $db_query->fetchrow_hashref;
3555 }
3556
3557 =head2 commitmessage
3558
3559 this function takes a commithash and returns the commit message for that commit
3560
3561 =cut
3562 sub commitmessage
3563 {
3564     my $self = shift;
3565     my $commithash = shift;
3566     my $tablename = $self->tablename("commitmsgs");
3567
3568     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3569
3570     my $db_query;
3571     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3572     $db_query->execute($commithash);
3573
3574     my ( $message ) = $db_query->fetchrow_array;
3575
3576     if ( defined ( $message ) )
3577     {
3578         $message .= " " if ( $message =~ /\n$/ );
3579         return $message;
3580     }
3581
3582     my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3583     shift @lines while ( $lines[0] =~ /\S/ );
3584     $message = join("",@lines);
3585     $message .= " " if ( $message =~ /\n$/ );
3586     return $message;
3587 }
3588
3589 =head2 gethistorydense
3590
3591 This function takes a filename (with path) argument and returns an arrayofarrays
3592 containing revision,filehash,commithash ordered by revision descending.
3593
3594 This version of gethistory skips deleted entries -- so it is useful for annotate.
3595 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3596 and other git tools that depend on it.
3597
3598 See also getlog().
3599
3600 =cut
3601 sub gethistorydense
3602 {
3603     my $self = shift;
3604     my $filename = shift;
3605     my $tablename = $self->tablename("revision");
3606
3607     my $db_query;
3608     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3609     $db_query->execute($filename);
3610
3611     return $db_query->fetchall_arrayref;
3612 }
3613
3614 =head2 in_array()
3615
3616 from Array::PAT - mimics the in_array() function
3617 found in PHP. Yuck but works for small arrays.
3618
3619 =cut
3620 sub in_array
3621 {
3622     my ($check, @array) = @_;
3623     my $retval = 0;
3624     foreach my $test (@array){
3625         if($check eq $test){
3626             $retval =  1;
3627         }
3628     }
3629     return $retval;
3630 }
3631
3632 =head2 safe_pipe_capture
3633
3634 an alternative to `command` that allows input to be passed as an array
3635 to work around shell problems with weird characters in arguments
3636
3637 =cut
3638 sub safe_pipe_capture {
3639
3640     my @output;
3641
3642     if (my $pid = open my $child, '-|') {
3643         @output = (<$child>);
3644         close $child or die join(' ',@_).": $! $?";
3645     } else {
3646         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3647     }
3648     return wantarray ? @output : join('',@output);
3649 }
3650
3651 =head2 mangle_dirname
3652
3653 create a string from a directory name that is suitable to use as
3654 part of a filename, mainly by converting all chars except \w.- to _
3655
3656 =cut
3657 sub mangle_dirname {
3658     my $dirname = shift;
3659     return unless defined $dirname;
3660
3661     $dirname =~ s/[^\w.-]/_/g;
3662
3663     return $dirname;
3664 }
3665
3666 =head2 mangle_tablename
3667
3668 create a string from a that is suitable to use as part of an SQL table
3669 name, mainly by converting all chars except \w to _
3670
3671 =cut
3672 sub mangle_tablename {
3673     my $tablename = shift;
3674     return unless defined $tablename;
3675
3676     $tablename =~ s/[^\w_]/_/g;
3677
3678     return $tablename;
3679 }
3680
3681 1;