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