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