git-cvsserver.perl

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