git-cvsserver.perl

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