git-cvsserver.perl

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