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 based
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' with 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 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         # Check that this is allowed, just as we would with a receive-pack
1328         my @cmd = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1329                         $parenthash, $commithash );
1330         if( -x $cmd[0] ) {
1331                 unless( system( @cmd ) == 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         if (system(qw(git update-ref -m), "cvsserver ci",
1341                         "refs/heads/$state->{module}", $commithash, $parenthash)) {
1342                 $log->warn("update-ref for $state->{module} failed.");
1343                 print "error 1 Cannot commit -- update first\n";
1344                 exit;
1345         }
1346
1347     $updater->update();
1348
1349     # foreach file specified on the command line ...
1350     foreach my $filename ( @committedfiles )
1351     {
1352         $filename = filecleanup($filename);
1353
1354         my $meta = $updater->getmeta($filename);
1355         unless (defined $meta->{revision}) {
1356           $meta->{revision} = 1;
1357         }
1358
1359         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1360
1361         $log->debug("Checked-in $dirpart : $filename");
1362
1363         print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1364         if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1365         {
1366             print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1367             print "Remove-entry $dirpart\n";
1368             print "$filename\n";
1369         } else {
1370             if ($meta->{revision} == 1) {
1371                 print "M initial revision: 1.1\n";
1372             } else {
1373                 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1374             }
1375             print "Checked-in $dirpart\n";
1376             print "$filename\n";
1377             my $kopts = kopts_from_path($filepart);
1378             print "/$filepart/1.$meta->{revision}//$kopts/\n";
1379         }
1380     }
1381
1382     chdir "/";
1383     print "ok\n";
1384 }
1385
1386 sub req_status
1387 {
1388     my ( $cmd, $data ) = @_;
1389
1390     argsplit("status");
1391
1392     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1393     #$log->debug("status state : " . Dumper($state));
1394
1395     # Grab a handle to the SQLite db and do any necessary updates
1396     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1397     $updater->update();
1398
1399     # if no files were specified, we need to work out what files we should be providing status on ...
1400     argsfromdir($updater);
1401
1402     # foreach file specified on the command line ...
1403     foreach my $filename ( @{$state->{args}} )
1404     {
1405         $filename = filecleanup($filename);
1406
1407         my $meta = $updater->getmeta($filename);
1408         my $oldmeta = $meta;
1409
1410         my $wrev = revparse($filename);
1411
1412         # If the working copy is an old revision, lets get that version too for comparison.
1413         if ( defined($wrev) and $wrev != $meta->{revision} )
1414         {
1415             $oldmeta = $updater->getmeta($filename, $wrev);
1416         }
1417
1418         # TODO : All possible statuses aren't yet implemented
1419         my $status;
1420         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1421         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1422                                     and
1423                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1424                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1425                                    );
1426
1427         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1428         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1429                                           and
1430                                           ( $state->{entries}{$filename}{unchanged}
1431                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1432                                         );
1433
1434         # Need checkout if it exists in the repo but doesn't have a working copy
1435         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1436
1437         # Locally modified if working copy and repo copy have the same revision but there are local changes
1438         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1439
1440         # Needs Merge if working copy revision is less than repo copy and there are local changes
1441         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1442
1443         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1444         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1445         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1446         $status ||= "File had conflicts on merge" if ( 0 );
1447
1448         $status ||= "Unknown";
1449
1450         print "M ===================================================================\n";
1451         print "M File: $filename\tStatus: $status\n";
1452         if ( defined($state->{entries}{$filename}{revision}) )
1453         {
1454             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1455         } else {
1456             print "M Working revision:\tNo entry for $filename\n";
1457         }
1458         if ( defined($meta->{revision}) )
1459         {
1460             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1461             print "M Sticky Tag:\t\t(none)\n";
1462             print "M Sticky Date:\t\t(none)\n";
1463             print "M Sticky Options:\t\t(none)\n";
1464         } else {
1465             print "M Repository revision:\tNo revision control file\n";
1466         }
1467         print "M\n";
1468     }
1469
1470     print "ok\n";
1471 }
1472
1473 sub req_diff
1474 {
1475     my ( $cmd, $data ) = @_;
1476
1477     argsplit("diff");
1478
1479     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1480     #$log->debug("status state : " . Dumper($state));
1481
1482     my ($revision1, $revision2);
1483     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1484     {
1485         $revision1 = $state->{opt}{r}[0];
1486         $revision2 = $state->{opt}{r}[1];
1487     } else {
1488         $revision1 = $state->{opt}{r};
1489     }
1490
1491     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1492     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1493
1494     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1495
1496     # Grab a handle to the SQLite db and do any necessary updates
1497     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1498     $updater->update();
1499
1500     # if no files were specified, we need to work out what files we should be providing status on ...
1501     argsfromdir($updater);
1502
1503     # foreach file specified on the command line ...
1504     foreach my $filename ( @{$state->{args}} )
1505     {
1506         $filename = filecleanup($filename);
1507
1508         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1509
1510         my $wrev = revparse($filename);
1511
1512         # We need _something_ to diff against
1513         next unless ( defined ( $wrev ) );
1514
1515         # if we have a -r switch, use it
1516         if ( defined ( $revision1 ) )
1517         {
1518             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1519             $meta1 = $updater->getmeta($filename, $revision1);
1520             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1521             {
1522                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1523                 next;
1524             }
1525             transmitfile($meta1->{filehash}, $file1);
1526         }
1527         # otherwise we just use the working copy revision
1528         else
1529         {
1530             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1531             $meta1 = $updater->getmeta($filename, $wrev);
1532             transmitfile($meta1->{filehash}, $file1);
1533         }
1534
1535         # if we have a second -r switch, use it too
1536         if ( defined ( $revision2 ) )
1537         {
1538             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1539             $meta2 = $updater->getmeta($filename, $revision2);
1540
1541             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1542             {
1543                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1544                 next;
1545             }
1546
1547             transmitfile($meta2->{filehash}, $file2);
1548         }
1549         # otherwise we just use the working copy
1550         else
1551         {
1552             $file2 = $state->{entries}{$filename}{modified_filename};
1553         }
1554
1555         # if we have been given -r, and we don't have a $file2 yet, lets get one
1556         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1557         {
1558             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1559             $meta2 = $updater->getmeta($filename, $wrev);
1560             transmitfile($meta2->{filehash}, $file2);
1561         }
1562
1563         # We need to have retrieved something useful
1564         next unless ( defined ( $meta1 ) );
1565
1566         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1567         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1568                   and
1569                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1570                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1571                   );
1572
1573         # Apparently we only show diffs for locally modified files
1574         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1575
1576         print "M Index: $filename\n";
1577         print "M ===================================================================\n";
1578         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1579         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1580         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1581         print "M diff ";
1582         foreach my $opt ( keys %{$state->{opt}} )
1583         {
1584             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1585             {
1586                 foreach my $value ( @{$state->{opt}{$opt}} )
1587                 {
1588                     print "-$opt $value ";
1589                 }
1590             } else {
1591                 print "-$opt ";
1592                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1593             }
1594         }
1595         print "$filename\n";
1596
1597         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1598
1599         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1600
1601         if ( exists $state->{opt}{u} )
1602         {
1603             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1604         } else {
1605             system("diff $file1 $file2 > $filediff");
1606         }
1607
1608         while ( <$fh> )
1609         {
1610             print "M $_";
1611         }
1612         close $fh;
1613     }
1614
1615     print "ok\n";
1616 }
1617
1618 sub req_log
1619 {
1620     my ( $cmd, $data ) = @_;
1621
1622     argsplit("log");
1623
1624     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1625     #$log->debug("log state : " . Dumper($state));
1626
1627     my ( $minrev, $maxrev );
1628     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1629     {
1630         my $control = $2;
1631         $minrev = $1;
1632         $maxrev = $3;
1633         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1634         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1635         $minrev++ if ( defined($minrev) and $control eq "::" );
1636     }
1637
1638     # Grab a handle to the SQLite db and do any necessary updates
1639     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1640     $updater->update();
1641
1642     # if no files were specified, we need to work out what files we should be providing status on ...
1643     argsfromdir($updater);
1644
1645     # foreach file specified on the command line ...
1646     foreach my $filename ( @{$state->{args}} )
1647     {
1648         $filename = filecleanup($filename);
1649
1650         my $headmeta = $updater->getmeta($filename);
1651
1652         my $revisions = $updater->getlog($filename);
1653         my $totalrevisions = scalar(@$revisions);
1654
1655         if ( defined ( $minrev ) )
1656         {
1657             $log->debug("Removing revisions less than $minrev");
1658             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1659             {
1660                 pop @$revisions;
1661             }
1662         }
1663         if ( defined ( $maxrev ) )
1664         {
1665             $log->debug("Removing revisions greater than $maxrev");
1666             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1667             {
1668                 shift @$revisions;
1669             }
1670         }
1671
1672         next unless ( scalar(@$revisions) );
1673
1674         print "M \n";
1675         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1676         print "M Working file: $filename\n";
1677         print "M head: 1.$headmeta->{revision}\n";
1678         print "M branch:\n";
1679         print "M locks: strict\n";
1680         print "M access list:\n";
1681         print "M symbolic names:\n";
1682         print "M keyword substitution: kv\n";
1683         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1684         print "M description:\n";
1685
1686         foreach my $revision ( @$revisions )
1687         {
1688             print "M ----------------------------\n";
1689             print "M revision 1.$revision->{revision}\n";
1690             # reformat the date for log output
1691             $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}) );
1692             $revision->{author} =~ s/\s+.*//;
1693             $revision->{author} =~ s/^(.{8}).*/$1/;
1694             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1695             my $commitmessage = $updater->commitmessage($revision->{commithash});
1696             $commitmessage =~ s/^/M /mg;
1697             print $commitmessage . "\n";
1698         }
1699         print "M =============================================================================\n";
1700     }
1701
1702     print "ok\n";
1703 }
1704
1705 sub req_annotate
1706 {
1707     my ( $cmd, $data ) = @_;
1708
1709     argsplit("annotate");
1710
1711     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1712     #$log->debug("status state : " . Dumper($state));
1713
1714     # Grab a handle to the SQLite db and do any necessary updates
1715     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1716     $updater->update();
1717
1718     # if no files were specified, we need to work out what files we should be providing annotate on ...
1719     argsfromdir($updater);
1720
1721     # we'll need a temporary checkout dir
1722     my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1723     my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1724     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1725
1726     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1727     $ENV{GIT_WORK_TREE} = ".";
1728     $ENV{GIT_INDEX_FILE} = $file_index;
1729
1730     chdir $tmpdir;
1731
1732     # foreach file specified on the command line ...
1733     foreach my $filename ( @{$state->{args}} )
1734     {
1735         $filename = filecleanup($filename);
1736
1737         my $meta = $updater->getmeta($filename);
1738
1739         next unless ( $meta->{revision} );
1740
1741         # get all the commits that this file was in
1742         # in dense format -- aka skip dead revisions
1743         my $revisions   = $updater->gethistorydense($filename);
1744         my $lastseenin  = $revisions->[0][2];
1745
1746         # populate the temporary index based on the latest commit were we saw
1747         # the file -- but do it cheaply without checking out any files
1748         # TODO: if we got a revision from the client, use that instead
1749         # to look up the commithash in sqlite (still good to default to
1750         # the current head as we do now)
1751         system("git-read-tree", $lastseenin);
1752         unless ($? == 0)
1753         {
1754             print "E error running git-read-tree $lastseenin $file_index $!\n";
1755             return;
1756         }
1757         $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1758
1759         # do a checkout of the file
1760         system('git-checkout-index', '-f', '-u', $filename);
1761         unless ($? == 0) {
1762             print "E error running git-checkout-index -f -u $filename : $!\n";
1763             return;
1764         }
1765
1766         $log->info("Annotate $filename");
1767
1768         # Prepare a file with the commits from the linearized
1769         # history that annotate should know about. This prevents
1770         # git-jsannotate telling us about commits we are hiding
1771         # from the client.
1772
1773         my $a_hints = "$tmpdir/.annotate_hints";
1774         if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1775             print "E failed to open '$a_hints' for writing: $!\n";
1776             return;
1777         }
1778         for (my $i=0; $i < @$revisions; $i++)
1779         {
1780             print ANNOTATEHINTS $revisions->[$i][2];
1781             if ($i+1 < @$revisions) { # have we got a parent?
1782                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1783             }
1784             print ANNOTATEHINTS "\n";
1785         }
1786
1787         print ANNOTATEHINTS "\n";
1788         close ANNOTATEHINTS
1789             or (print "E failed to write $a_hints: $!\n"), return;
1790
1791         my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1792         if (!open(ANNOTATE, "-|", @cmd)) {
1793             print "E error invoking ". join(' ',@cmd) .": $!\n";
1794             return;
1795         }
1796         my $metadata = {};
1797         print "E Annotations for $filename\n";
1798         print "E ***************\n";
1799         while ( <ANNOTATE> )
1800         {
1801             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1802             {
1803                 my $commithash = $1;
1804                 my $data = $2;
1805                 unless ( defined ( $metadata->{$commithash} ) )
1806                 {
1807                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1808                     $metadata->{$commithash}{author} =~ s/\s+.*//;
1809                     $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1810                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1811                 }
1812                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1813                     $metadata->{$commithash}{revision},
1814                     $metadata->{$commithash}{author},
1815                     $metadata->{$commithash}{modified},
1816                     $data
1817                 );
1818             } else {
1819                 $log->warn("Error in annotate output! LINE: $_");
1820                 print "E Annotate error \n";
1821                 next;
1822             }
1823         }
1824         close ANNOTATE;
1825     }
1826
1827     # done; get out of the tempdir
1828     chdir "/";
1829
1830     print "ok\n";
1831
1832 }
1833
1834 # This method takes the state->{arguments} array and produces two new arrays.
1835 # The first is $state->{args} which is everything before the '--' argument, and
1836 # the second is $state->{files} which is everything after it.
1837 sub argsplit
1838 {
1839     $state->{args} = [];
1840     $state->{files} = [];
1841     $state->{opt} = {};
1842
1843     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1844
1845     my $type = shift;
1846
1847     if ( defined($type) )
1848     {
1849         my $opt = {};
1850         $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" );
1851         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1852         $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" );
1853         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1854         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1855         $opt = { k => 1, m => 1 } if ( $type eq "add" );
1856         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1857         $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" );
1858
1859
1860         while ( scalar ( @{$state->{arguments}} ) > 0 )
1861         {
1862             my $arg = shift @{$state->{arguments}};
1863
1864             next if ( $arg eq "--" );
1865             next unless ( $arg =~ /\S/ );
1866
1867             # if the argument looks like a switch
1868             if ( $arg =~ /^-(\w)(.*)/ )
1869             {
1870                 # if it's a switch that takes an argument
1871                 if ( $opt->{$1} )
1872                 {
1873                     # If this switch has already been provided
1874                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1875                     {
1876                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
1877                         if ( length($2) > 0 )
1878                         {
1879                             push @{$state->{opt}{$1}},$2;
1880                         } else {
1881                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1882                         }
1883                     } else {
1884                         # if there's extra data in the arg, use that as the argument for the switch
1885                         if ( length($2) > 0 )
1886                         {
1887                             $state->{opt}{$1} = $2;
1888                         } else {
1889                             $state->{opt}{$1} = shift @{$state->{arguments}};
1890                         }
1891                     }
1892                 } else {
1893                     $state->{opt}{$1} = undef;
1894                 }
1895             }
1896             else
1897             {
1898                 push @{$state->{args}}, $arg;
1899             }
1900         }
1901     }
1902     else
1903     {
1904         my $mode = 0;
1905
1906         foreach my $value ( @{$state->{arguments}} )
1907         {
1908             if ( $value eq "--" )
1909             {
1910                 $mode++;
1911                 next;
1912             }
1913             push @{$state->{args}}, $value if ( $mode == 0 );
1914             push @{$state->{files}}, $value if ( $mode == 1 );
1915         }
1916     }
1917 }
1918
1919 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1920 sub argsfromdir
1921 {
1922     my $updater = shift;
1923
1924     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1925
1926     return if ( scalar ( @{$state->{args}} ) > 1 );
1927
1928     my @gethead = @{$updater->gethead};
1929
1930     # push added files
1931     foreach my $file (keys %{$state->{entries}}) {
1932         if ( exists $state->{entries}{$file}{revision} &&
1933                 $state->{entries}{$file}{revision} == 0 )
1934         {
1935             push @gethead, { name => $file, filehash => 'added' };
1936         }
1937     }
1938
1939     if ( scalar(@{$state->{args}}) == 1 )
1940     {
1941         my $arg = $state->{args}[0];
1942         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1943
1944         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1945
1946         foreach my $file ( @gethead )
1947         {
1948             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1949             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
1950             push @{$state->{args}}, $file->{name};
1951         }
1952
1953         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1954     } else {
1955         $log->info("Only one arg specified, populating file list automatically");
1956
1957         $state->{args} = [];
1958
1959         foreach my $file ( @gethead )
1960         {
1961             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1962             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1963             push @{$state->{args}}, $file->{name};
1964         }
1965     }
1966 }
1967
1968 # This method cleans up the $state variable after a command that uses arguments has run
1969 sub statecleanup
1970 {
1971     $state->{files} = [];
1972     $state->{args} = [];
1973     $state->{arguments} = [];
1974     $state->{entries} = {};
1975 }
1976
1977 sub revparse
1978 {
1979     my $filename = shift;
1980
1981     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1982
1983     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1984     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1985
1986     return undef;
1987 }
1988
1989 # This method takes a file hash and does a CVS "file transfer" which transmits the
1990 # size of the file, and then the file contents.
1991 # If a second argument $targetfile is given, the file is instead written out to
1992 # a file by the name of $targetfile
1993 sub transmitfile
1994 {
1995     my $filehash = shift;
1996     my $targetfile = shift;
1997
1998     if ( defined ( $filehash ) and $filehash eq "deleted" )
1999     {
2000         $log->warn("filehash is 'deleted'");
2001         return;
2002     }
2003
2004     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2005
2006     my $type = `git-cat-file -t $filehash`;
2007     chomp $type;
2008
2009     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2010
2011     my $size = `git-cat-file -s $filehash`;
2012     chomp $size;
2013
2014     $log->debug("transmitfile($filehash) size=$size, type=$type");
2015
2016     if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2017     {
2018         if ( defined ( $targetfile ) )
2019         {
2020             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2021             print NEWFILE $_ while ( <$fh> );
2022             close NEWFILE or die("Failed to write '$targetfile': $!");
2023         } else {
2024             print "$size\n";
2025             print while ( <$fh> );
2026         }
2027         close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2028     } else {
2029         die("Couldn't execute git-cat-file");
2030     }
2031 }
2032
2033 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2034 # refers to the directory portion and the file portion of the filename
2035 # respectively
2036 sub filenamesplit
2037 {
2038     my $filename = shift;
2039     my $fixforlocaldir = shift;
2040
2041     my ( $filepart, $dirpart ) = ( $filename, "." );
2042     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2043     $dirpart .= "/";
2044
2045     if ( $fixforlocaldir )
2046     {
2047         $dirpart =~ s/^$state->{prependdir}//;
2048     }
2049
2050     return ( $filepart, $dirpart );
2051 }
2052
2053 sub filecleanup
2054 {
2055     my $filename = shift;
2056
2057     return undef unless(defined($filename));
2058     if ( $filename =~ /^\// )
2059     {
2060         print "E absolute filenames '$filename' not supported by server\n";
2061         return undef;
2062     }
2063
2064     $filename =~ s/^\.\///g;
2065     $filename = $state->{prependdir} . $filename;
2066     return $filename;
2067 }
2068
2069 # Given a path, this function returns a string containing the kopts
2070 # that should go into that path's Entries line.  For example, a binary
2071 # file should get -kb.
2072 sub kopts_from_path
2073 {
2074         my ($path) = @_;
2075
2076         # Once it exists, the git attributes system should be used to look up
2077         # what attributes apply to this path.
2078
2079         # Until then, take the setting from the config file
2080     unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
2081     {
2082                 # Return "" to give no special treatment to any path
2083                 return "";
2084     } else {
2085                 # Alternatively, to have all files treated as if they are binary (which
2086                 # is more like git itself), always return the "-kb" option
2087                 return "-kb";
2088     }
2089 }
2090
2091 package GITCVS::log;
2092
2093 ####
2094 #### Copyright The Open University UK - 2006.
2095 ####
2096 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2097 ####          Martin Langhoff <martin@catalyst.net.nz>
2098 ####
2099 ####
2100
2101 use strict;
2102 use warnings;
2103
2104 =head1 NAME
2105
2106 GITCVS::log
2107
2108 =head1 DESCRIPTION
2109
2110 This module provides very crude logging with a similar interface to
2111 Log::Log4perl
2112
2113 =head1 METHODS
2114
2115 =cut
2116
2117 =head2 new
2118
2119 Creates a new log object, optionally you can specify a filename here to
2120 indicate the file to log to. If no log file is specified, you can specify one
2121 later with method setfile, or indicate you no longer want logging with method
2122 nofile.
2123
2124 Until one of these methods is called, all log calls will buffer messages ready
2125 to write out.
2126
2127 =cut
2128 sub new
2129 {
2130     my $class = shift;
2131     my $filename = shift;
2132
2133     my $self = {};
2134
2135     bless $self, $class;
2136
2137     if ( defined ( $filename ) )
2138     {
2139         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2140     }
2141
2142     return $self;
2143 }
2144
2145 =head2 setfile
2146
2147 This methods takes a filename, and attempts to open that file as the log file.
2148 If successful, all buffered data is written out to the file, and any further
2149 logging is written directly to the file.
2150
2151 =cut
2152 sub setfile
2153 {
2154     my $self = shift;
2155     my $filename = shift;
2156
2157     if ( defined ( $filename ) )
2158     {
2159         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2160     }
2161
2162     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2163
2164     while ( my $line = shift @{$self->{buffer}} )
2165     {
2166         print {$self->{fh}} $line;
2167     }
2168 }
2169
2170 =head2 nofile
2171
2172 This method indicates no logging is going to be used. It flushes any entries in
2173 the internal buffer, and sets a flag to ensure no further data is put there.
2174
2175 =cut
2176 sub nofile
2177 {
2178     my $self = shift;
2179
2180     $self->{nolog} = 1;
2181
2182     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2183
2184     $self->{buffer} = [];
2185 }
2186
2187 =head2 _logopen
2188
2189 Internal method. Returns true if the log file is open, false otherwise.
2190
2191 =cut
2192 sub _logopen
2193 {
2194     my $self = shift;
2195
2196     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2197     return 0;
2198 }
2199
2200 =head2 debug info warn fatal
2201
2202 These four methods are wrappers to _log. They provide the actual interface for
2203 logging data.
2204
2205 =cut
2206 sub debug { my $self = shift; $self->_log("debug", @_); }
2207 sub info  { my $self = shift; $self->_log("info" , @_); }
2208 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2209 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2210
2211 =head2 _log
2212
2213 This is an internal method called by the logging functions. It generates a
2214 timestamp and pushes the logged line either to file, or internal buffer.
2215
2216 =cut
2217 sub _log
2218 {
2219     my $self = shift;
2220     my $level = shift;
2221
2222     return if ( $self->{nolog} );
2223
2224     my @time = localtime;
2225     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2226         $time[5] + 1900,
2227         $time[4] + 1,
2228         $time[3],
2229         $time[2],
2230         $time[1],
2231         $time[0],
2232         uc $level,
2233     );
2234
2235     if ( $self->_logopen )
2236     {
2237         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2238     } else {
2239         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2240     }
2241 }
2242
2243 =head2 DESTROY
2244
2245 This method simply closes the file handle if one is open
2246
2247 =cut
2248 sub DESTROY
2249 {
2250     my $self = shift;
2251
2252     if ( $self->_logopen )
2253     {
2254         close $self->{fh};
2255     }
2256 }
2257
2258 package GITCVS::updater;
2259
2260 ####
2261 #### Copyright The Open University UK - 2006.
2262 ####
2263 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2264 ####          Martin Langhoff <martin@catalyst.net.nz>
2265 ####
2266 ####
2267
2268 use strict;
2269 use warnings;
2270 use DBI;
2271
2272 =head1 METHODS
2273
2274 =cut
2275
2276 =head2 new
2277
2278 =cut
2279 sub new
2280 {
2281     my $class = shift;
2282     my $config = shift;
2283     my $module = shift;
2284     my $log = shift;
2285
2286     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2287     die "Need to specify a module" unless ( defined($module) );
2288
2289     $class = ref($class) || $class;
2290
2291     my $self = {};
2292
2293     bless $self, $class;
2294
2295     $self->{module} = $module;
2296     $self->{git_path} = $config . "/";
2297
2298     $self->{log} = $log;
2299
2300     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2301
2302     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2303         $cfg->{gitcvs}{dbdriver} || "SQLite";
2304     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2305         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2306     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2307         $cfg->{gitcvs}{dbuser} || "";
2308     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2309         $cfg->{gitcvs}{dbpass} || "";
2310     my %mapping = ( m => $module,
2311                     a => $state->{method},
2312                     u => getlogin || getpwuid($<) || $<,
2313                     G => $self->{git_path},
2314                     g => mangle_dirname($self->{git_path}),
2315                     );
2316     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2317     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2318
2319     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2320     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2321     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2322                                 $self->{dbuser},
2323                                 $self->{dbpass});
2324     die "Error connecting to database\n" unless defined $self->{dbh};
2325
2326     $self->{tables} = {};
2327     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2328     {
2329         $self->{tables}{$table} = 1;
2330     }
2331
2332     # Construct the revision table if required
2333     unless ( $self->{tables}{revision} )
2334     {
2335         $self->{dbh}->do("
2336             CREATE TABLE revision (
2337                 name       TEXT NOT NULL,
2338                 revision   INTEGER NOT NULL,
2339                 filehash   TEXT NOT NULL,
2340                 commithash TEXT NOT NULL,
2341                 author     TEXT NOT NULL,
2342                 modified   TEXT NOT NULL,
2343                 mode       TEXT NOT NULL
2344             )
2345         ");
2346         $self->{dbh}->do("
2347             CREATE INDEX revision_ix1
2348             ON revision (name,revision)
2349         ");
2350         $self->{dbh}->do("
2351             CREATE INDEX revision_ix2
2352             ON revision (name,commithash)
2353         ");
2354     }
2355
2356     # Construct the head table if required
2357     unless ( $self->{tables}{head} )
2358     {
2359         $self->{dbh}->do("
2360             CREATE TABLE head (
2361                 name       TEXT NOT NULL,
2362                 revision   INTEGER NOT NULL,
2363                 filehash   TEXT NOT NULL,
2364                 commithash TEXT NOT NULL,
2365                 author     TEXT NOT NULL,
2366                 modified   TEXT NOT NULL,
2367                 mode       TEXT NOT NULL
2368             )
2369         ");
2370         $self->{dbh}->do("
2371             CREATE INDEX head_ix1
2372             ON head (name)
2373         ");
2374     }
2375
2376     # Construct the properties table if required
2377     unless ( $self->{tables}{properties} )
2378     {
2379         $self->{dbh}->do("
2380             CREATE TABLE properties (
2381                 key        TEXT NOT NULL PRIMARY KEY,
2382                 value      TEXT
2383             )
2384         ");
2385     }
2386
2387     # Construct the commitmsgs table if required
2388     unless ( $self->{tables}{commitmsgs} )
2389     {
2390         $self->{dbh}->do("
2391             CREATE TABLE commitmsgs (
2392                 key        TEXT NOT NULL PRIMARY KEY,
2393                 value      TEXT
2394             )
2395         ");
2396     }
2397
2398     return $self;
2399 }
2400
2401 =head2 update
2402
2403 =cut
2404 sub update
2405 {
2406     my $self = shift;
2407
2408     # first lets get the commit list
2409     $ENV{GIT_DIR} = $self->{git_path};
2410
2411     my $commitsha1 = `git rev-parse $self->{module}`;
2412     chomp $commitsha1;
2413
2414     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2415     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2416     {
2417         die("Invalid module '$self->{module}'");
2418     }
2419
2420
2421     my $git_log;
2422     my $lastcommit = $self->_get_prop("last_commit");
2423
2424     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2425          return 1;
2426     }
2427
2428     # Start exclusive lock here...
2429     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2430
2431     # TODO: log processing is memory bound
2432     # if we can parse into a 2nd file that is in reverse order
2433     # we can probably do something really efficient
2434     my @git_log_params = ('--pretty', '--parents', '--topo-order');
2435
2436     if (defined $lastcommit) {
2437         push @git_log_params, "$lastcommit..$self->{module}";
2438     } else {
2439         push @git_log_params, $self->{module};
2440     }
2441     # git-rev-list is the backend / plumbing version of git-log
2442     open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2443
2444     my @commits;
2445
2446     my %commit = ();
2447
2448     while ( <GITLOG> )
2449     {
2450         chomp;
2451         if (m/^commit\s+(.*)$/) {
2452             # on ^commit lines put the just seen commit in the stack
2453             # and prime things for the next one
2454             if (keys %commit) {
2455                 my %copy = %commit;
2456                 unshift @commits, \%copy;
2457                 %commit = ();
2458             }
2459             my @parents = split(m/\s+/, $1);
2460             $commit{hash} = shift @parents;
2461             $commit{parents} = \@parents;
2462         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2463             # on rfc822-like lines seen before we see any message,
2464             # lowercase the entry and put it in the hash as key-value
2465             $commit{lc($1)} = $2;
2466         } else {
2467             # message lines - skip initial empty line
2468             # and trim whitespace
2469             if (!exists($commit{message}) && m/^\s*$/) {
2470                 # define it to mark the end of headers
2471                 $commit{message} = '';
2472                 next;
2473             }
2474             s/^\s+//; s/\s+$//; # trim ws
2475             $commit{message} .= $_ . "\n";
2476         }
2477     }
2478     close GITLOG;
2479
2480     unshift @commits, \%commit if ( keys %commit );
2481
2482     # Now all the commits are in the @commits bucket
2483     # ordered by time DESC. for each commit that needs processing,
2484     # determine whether it's following the last head we've seen or if
2485     # it's on its own branch, grab a file list, and add whatever's changed
2486     # NOTE: $lastcommit refers to the last commit from previous run
2487     #       $lastpicked is the last commit we picked in this run
2488     my $lastpicked;
2489     my $head = {};
2490     if (defined $lastcommit) {
2491         $lastpicked = $lastcommit;
2492     }
2493
2494     my $committotal = scalar(@commits);
2495     my $commitcount = 0;
2496
2497     # Load the head table into $head (for cached lookups during the update process)
2498     foreach my $file ( @{$self->gethead()} )
2499     {
2500         $head->{$file->{name}} = $file;
2501     }
2502
2503     foreach my $commit ( @commits )
2504     {
2505         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2506         if (defined $lastpicked)
2507         {
2508             if (!in_array($lastpicked, @{$commit->{parents}}))
2509             {
2510                 # skip, we'll see this delta
2511                 # as part of a merge later
2512                 # warn "skipping off-track  $commit->{hash}\n";
2513                 next;
2514             } elsif (@{$commit->{parents}} > 1) {
2515                 # it is a merge commit, for each parent that is
2516                 # not $lastpicked, see if we can get a log
2517                 # from the merge-base to that parent to put it
2518                 # in the message as a merge summary.
2519                 my @parents = @{$commit->{parents}};
2520                 foreach my $parent (@parents) {
2521                     # git-merge-base can potentially (but rarely) throw
2522                     # several candidate merge bases. let's assume
2523                     # that the first one is the best one.
2524                     if ($parent eq $lastpicked) {
2525                         next;
2526                     }
2527                     my $base = safe_pipe_capture('git-merge-base',
2528                                                  $lastpicked, $parent);
2529                     chomp $base;
2530                     if ($base) {
2531                         my @merged;
2532                         # print "want to log between  $base $parent \n";
2533                         open(GITLOG, '-|', 'git-log', "$base..$parent")
2534                           or die "Cannot call git-log: $!";
2535                         my $mergedhash;
2536                         while (<GITLOG>) {
2537                             chomp;
2538                             if (!defined $mergedhash) {
2539                                 if (m/^commit\s+(.+)$/) {
2540                                     $mergedhash = $1;
2541                                 } else {
2542                                     next;
2543                                 }
2544                             } else {
2545                                 # grab the first line that looks non-rfc822
2546                                 # aka has content after leading space
2547                                 if (m/^\s+(\S.*)$/) {
2548                                     my $title = $1;
2549                                     $title = substr($title,0,100); # truncate
2550                                     unshift @merged, "$mergedhash $title";
2551                                     undef $mergedhash;
2552                                 }
2553                             }
2554                         }
2555                         close GITLOG;
2556                         if (@merged) {
2557                             $commit->{mergemsg} = $commit->{message};
2558                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2559                             foreach my $summary (@merged) {
2560                                 $commit->{mergemsg} .= "\t$summary\n";
2561                             }
2562                             $commit->{mergemsg} .= "\n\n";
2563                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2564                         }
2565                     }
2566                 }
2567             }
2568         }
2569
2570         # convert the date to CVS-happy format
2571         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2572
2573         if ( defined ( $lastpicked ) )
2574         {
2575             my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2576             local ($/) = "\0";
2577             while ( <FILELIST> )
2578             {
2579                 chomp;
2580                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2581                 {
2582                     die("Couldn't process git-diff-tree line : $_");
2583                 }
2584                 my ($mode, $hash, $change) = ($1, $2, $3);
2585                 my $name = <FILELIST>;
2586                 chomp($name);
2587
2588                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2589
2590                 my $git_perms = "";
2591                 $git_perms .= "r" if ( $mode & 4 );
2592                 $git_perms .= "w" if ( $mode & 2 );
2593                 $git_perms .= "x" if ( $mode & 1 );
2594                 $git_perms = "rw" if ( $git_perms eq "" );
2595
2596                 if ( $change eq "D" )
2597                 {
2598                     #$log->debug("DELETE   $name");
2599                     $head->{$name} = {
2600                         name => $name,
2601                         revision => $head->{$name}{revision} + 1,
2602                         filehash => "deleted",
2603                         commithash => $commit->{hash},
2604                         modified => $commit->{date},
2605                         author => $commit->{author},
2606                         mode => $git_perms,
2607                     };
2608                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2609                 }
2610                 elsif ( $change eq "M" )
2611                 {
2612                     #$log->debug("MODIFIED $name");
2613                     $head->{$name} = {
2614                         name => $name,
2615                         revision => $head->{$name}{revision} + 1,
2616                         filehash => $hash,
2617                         commithash => $commit->{hash},
2618                         modified => $commit->{date},
2619                         author => $commit->{author},
2620                         mode => $git_perms,
2621                     };
2622                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2623                 }
2624                 elsif ( $change eq "A" )
2625                 {
2626                     #$log->debug("ADDED    $name");
2627                     $head->{$name} = {
2628                         name => $name,
2629                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
2630                         filehash => $hash,
2631                         commithash => $commit->{hash},
2632                         modified => $commit->{date},
2633                         author => $commit->{author},
2634                         mode => $git_perms,
2635                     };
2636                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2637                 }
2638                 else
2639                 {
2640                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2641                     die;
2642                 }
2643             }
2644             close FILELIST;
2645         } else {
2646             # this is used to detect files removed from the repo
2647             my $seen_files = {};
2648
2649             my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2650             local $/ = "\0";
2651             while ( <FILELIST> )
2652             {
2653                 chomp;
2654                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2655                 {
2656                     die("Couldn't process git-ls-tree line : $_");
2657                 }
2658
2659                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2660
2661                 $seen_files->{$git_filename} = 1;
2662
2663                 my ( $oldhash, $oldrevision, $oldmode ) = (
2664                     $head->{$git_filename}{filehash},
2665                     $head->{$git_filename}{revision},
2666                     $head->{$git_filename}{mode}
2667                 );
2668
2669                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2670                 {
2671                     $git_perms = "";
2672                     $git_perms .= "r" if ( $1 & 4 );
2673                     $git_perms .= "w" if ( $1 & 2 );
2674                     $git_perms .= "x" if ( $1 & 1 );
2675                 } else {
2676                     $git_perms = "rw";
2677                 }
2678
2679                 # unless the file exists with the same hash, we need to update it ...
2680                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2681                 {
2682                     my $newrevision = ( $oldrevision or 0 ) + 1;
2683
2684                     $head->{$git_filename} = {
2685                         name => $git_filename,
2686                         revision => $newrevision,
2687                         filehash => $git_hash,
2688                         commithash => $commit->{hash},
2689                         modified => $commit->{date},
2690                         author => $commit->{author},
2691                         mode => $git_perms,
2692                     };
2693
2694
2695                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2696                 }
2697             }
2698             close FILELIST;
2699
2700             # Detect deleted files
2701             foreach my $file ( keys %$head )
2702             {
2703                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2704                 {
2705                     $head->{$file}{revision}++;
2706                     $head->{$file}{filehash} = "deleted";
2707                     $head->{$file}{commithash} = $commit->{hash};
2708                     $head->{$file}{modified} = $commit->{date};
2709                     $head->{$file}{author} = $commit->{author};
2710
2711                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2712                 }
2713             }
2714             # END : "Detect deleted files"
2715         }
2716
2717
2718         if (exists $commit->{mergemsg})
2719         {
2720             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2721         }
2722
2723         $lastpicked = $commit->{hash};
2724
2725         $self->_set_prop("last_commit", $commit->{hash});
2726     }
2727
2728     $self->delete_head();
2729     foreach my $file ( keys %$head )
2730     {
2731         $self->insert_head(
2732             $file,
2733             $head->{$file}{revision},
2734             $head->{$file}{filehash},
2735             $head->{$file}{commithash},
2736             $head->{$file}{modified},
2737             $head->{$file}{author},
2738             $head->{$file}{mode},
2739         );
2740     }
2741     # invalidate the gethead cache
2742     $self->{gethead_cache} = undef;
2743
2744
2745     # Ending exclusive lock here
2746     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2747 }
2748
2749 sub insert_rev
2750 {
2751     my $self = shift;
2752     my $name = shift;
2753     my $revision = shift;
2754     my $filehash = shift;
2755     my $commithash = shift;
2756     my $modified = shift;
2757     my $author = shift;
2758     my $mode = shift;
2759
2760     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2761     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2762 }
2763
2764 sub insert_mergelog
2765 {
2766     my $self = shift;
2767     my $key = shift;
2768     my $value = shift;
2769
2770     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2771     $insert_mergelog->execute($key, $value);
2772 }
2773
2774 sub delete_head
2775 {
2776     my $self = shift;
2777
2778     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2779     $delete_head->execute();
2780 }
2781
2782 sub insert_head
2783 {
2784     my $self = shift;
2785     my $name = shift;
2786     my $revision = shift;
2787     my $filehash = shift;
2788     my $commithash = shift;
2789     my $modified = shift;
2790     my $author = shift;
2791     my $mode = shift;
2792
2793     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2794     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2795 }
2796
2797 sub _headrev
2798 {
2799     my $self = shift;
2800     my $filename = shift;
2801
2802     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2803     $db_query->execute($filename);
2804     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2805
2806     return ( $hash, $revision, $mode );
2807 }
2808
2809 sub _get_prop
2810 {
2811     my $self = shift;
2812     my $key = shift;
2813
2814     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2815     $db_query->execute($key);
2816     my ( $value ) = $db_query->fetchrow_array;
2817
2818     return $value;
2819 }
2820
2821 sub _set_prop
2822 {
2823     my $self = shift;
2824     my $key = shift;
2825     my $value = shift;
2826
2827     my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2828     $db_query->execute($value, $key);
2829
2830     unless ( $db_query->rows )
2831     {
2832         $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2833         $db_query->execute($key, $value);
2834     }
2835
2836     return $value;
2837 }
2838
2839 =head2 gethead
2840
2841 =cut
2842
2843 sub gethead
2844 {
2845     my $self = shift;
2846
2847     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2848
2849     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2850     $db_query->execute();
2851
2852     my $tree = [];
2853     while ( my $file = $db_query->fetchrow_hashref )
2854     {
2855         push @$tree, $file;
2856     }
2857
2858     $self->{gethead_cache} = $tree;
2859
2860     return $tree;
2861 }
2862
2863 =head2 getlog
2864
2865 =cut
2866
2867 sub getlog
2868 {
2869     my $self = shift;
2870     my $filename = shift;
2871
2872     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2873     $db_query->execute($filename);
2874
2875     my $tree = [];
2876     while ( my $file = $db_query->fetchrow_hashref )
2877     {
2878         push @$tree, $file;
2879     }
2880
2881     return $tree;
2882 }
2883
2884 =head2 getmeta
2885
2886 This function takes a filename (with path) argument and returns a hashref of
2887 metadata for that file.
2888
2889 =cut
2890
2891 sub getmeta
2892 {
2893     my $self = shift;
2894     my $filename = shift;
2895     my $revision = shift;
2896
2897     my $db_query;
2898     if ( defined($revision) and $revision =~ /^\d+$/ )
2899     {
2900         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2901         $db_query->execute($filename, $revision);
2902     }
2903     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2904     {
2905         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2906         $db_query->execute($filename, $revision);
2907     } else {
2908         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2909         $db_query->execute($filename);
2910     }
2911
2912     return $db_query->fetchrow_hashref;
2913 }
2914
2915 =head2 commitmessage
2916
2917 this function takes a commithash and returns the commit message for that commit
2918
2919 =cut
2920 sub commitmessage
2921 {
2922     my $self = shift;
2923     my $commithash = shift;
2924
2925     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2926
2927     my $db_query;
2928     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2929     $db_query->execute($commithash);
2930
2931     my ( $message ) = $db_query->fetchrow_array;
2932
2933     if ( defined ( $message ) )
2934     {
2935         $message .= " " if ( $message =~ /\n$/ );
2936         return $message;
2937     }
2938
2939     my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2940     shift @lines while ( $lines[0] =~ /\S/ );
2941     $message = join("",@lines);
2942     $message .= " " if ( $message =~ /\n$/ );
2943     return $message;
2944 }
2945
2946 =head2 gethistory
2947
2948 This function takes a filename (with path) argument and returns an arrayofarrays
2949 containing revision,filehash,commithash ordered by revision descending
2950
2951 =cut
2952 sub gethistory
2953 {
2954     my $self = shift;
2955     my $filename = shift;
2956
2957     my $db_query;
2958     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2959     $db_query->execute($filename);
2960
2961     return $db_query->fetchall_arrayref;
2962 }
2963
2964 =head2 gethistorydense
2965
2966 This function takes a filename (with path) argument and returns an arrayofarrays
2967 containing revision,filehash,commithash ordered by revision descending.
2968
2969 This version of gethistory skips deleted entries -- so it is useful for annotate.
2970 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2971 and other git tools that depend on it.
2972
2973 =cut
2974 sub gethistorydense
2975 {
2976     my $self = shift;
2977     my $filename = shift;
2978
2979     my $db_query;
2980     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2981     $db_query->execute($filename);
2982
2983     return $db_query->fetchall_arrayref;
2984 }
2985
2986 =head2 in_array()
2987
2988 from Array::PAT - mimics the in_array() function
2989 found in PHP. Yuck but works for small arrays.
2990
2991 =cut
2992 sub in_array
2993 {
2994     my ($check, @array) = @_;
2995     my $retval = 0;
2996     foreach my $test (@array){
2997         if($check eq $test){
2998             $retval =  1;
2999         }
3000     }
3001     return $retval;
3002 }
3003
3004 =head2 safe_pipe_capture
3005
3006 an alternative to `command` that allows input to be passed as an array
3007 to work around shell problems with weird characters in arguments
3008
3009 =cut
3010 sub safe_pipe_capture {
3011
3012     my @output;
3013
3014     if (my $pid = open my $child, '-|') {
3015         @output = (<$child>);
3016         close $child or die join(' ',@_).": $! $?";
3017     } else {
3018         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3019     }
3020     return wantarray ? @output : join('',@output);
3021 }
3022
3023 =head2 mangle_dirname
3024
3025 create a string from a directory name that is suitable to use as
3026 part of a filename, mainly by converting all chars except \w.- to _
3027
3028 =cut
3029 sub mangle_dirname {
3030     my $dirname = shift;
3031     return unless defined $dirname;
3032
3033     $dirname =~ s/[^\w.-]/_/g;
3034
3035     return $dirname;
3036 }
3037
3038 1;