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/^$state->{CVSROOT}\///;
 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     # foreach file specified on the command line ...
1005     foreach my $filename ( @{$state->{args}} )
1006     {
1007         $filename = filecleanup($filename);
1008
1009         $log->debug("Processing file $filename");
1010
1011         # if we have a -C we should pretend we never saw modified stuff
1012         if ( exists ( $state->{opt}{C} ) )
1013         {
1014             delete $state->{entries}{$filename}{modified_hash};
1015             delete $state->{entries}{$filename}{modified_filename};
1016             $state->{entries}{$filename}{unchanged} = 1;
1017         }
1018
1019         my $meta;
1020         if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1021         {
1022             $meta = $updater->getmeta($filename, $1);
1023         } else {
1024             $meta = $updater->getmeta($filename);
1025         }
1026
1027         # If -p was given, "print" the contents of the requested revision.
1028         if ( exists ( $state->{opt}{p} ) ) {
1029             if ( defined ( $meta->{revision} ) ) {
1030                 $log->info("Printing '$filename' revision " . $meta->{revision});
1031
1032                 transmitfile($meta->{filehash}, { print => 1 });
1033             }
1034
1035             next;
1036         }
1037
1038         if ( ! defined $meta )
1039         {
1040             $meta = {
1041                 name => $filename,
1042                 revision => 0,
1043                 filehash => 'added'
1044             };
1045         }
1046
1047         my $oldmeta = $meta;
1048
1049         my $wrev = revparse($filename);
1050
1051         # If the working copy is an old revision, lets get that version too for comparison.
1052         if ( defined($wrev) and $wrev != $meta->{revision} )
1053         {
1054             $oldmeta = $updater->getmeta($filename, $wrev);
1055         }
1056
1057         #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1058
1059         # Files are up to date if the working copy and repo copy have the same revision,
1060         # and the working copy is unmodified _and_ the user hasn't specified -C
1061         next if ( defined ( $wrev )
1062                   and defined($meta->{revision})
1063                   and $wrev == $meta->{revision}
1064                   and $state->{entries}{$filename}{unchanged}
1065                   and not exists ( $state->{opt}{C} ) );
1066
1067         # If the working copy and repo copy have the same revision,
1068         # but the working copy is modified, tell the client it's modified
1069         if ( defined ( $wrev )
1070              and defined($meta->{revision})
1071              and $wrev == $meta->{revision}
1072              and defined($state->{entries}{$filename}{modified_hash})
1073              and not exists ( $state->{opt}{C} ) )
1074         {
1075             $log->info("Tell the client the file is modified");
1076             print "MT text M \n";
1077             print "MT fname $filename\n";
1078             print "MT newline\n";
1079             next;
1080         }
1081
1082         if ( $meta->{filehash} eq "deleted" )
1083         {
1084             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1085
1086             $log->info("Removing '$filename' from working copy (no longer in the repo)");
1087
1088             print "E cvs update: `$filename' is no longer in the repository\n";
1089             # Don't want to actually _DO_ the update if -n specified
1090             unless ( $state->{globaloptions}{-n} ) {
1091                 print "Removed $dirpart\n";
1092                 print "$filepart\n";
1093             }
1094         }
1095         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1096                 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1097                 or $meta->{filehash} eq 'added' )
1098         {
1099             # normal update, just send the new revision (either U=Update,
1100             # or A=Add, or R=Remove)
1101             if ( defined($wrev) && $wrev < 0 )
1102             {
1103                 $log->info("Tell the client the file is scheduled for removal");
1104                 print "MT text R \n";
1105                 print "MT fname $filename\n";
1106                 print "MT newline\n";
1107                 next;
1108             }
1109             elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1110             {
1111                 $log->info("Tell the client the file is scheduled for addition");
1112                 print "MT text A \n";
1113                 print "MT fname $filename\n";
1114                 print "MT newline\n";
1115                 next;
1116
1117             }
1118             else {
1119                 $log->info("Updating '$filename' to ".$meta->{revision});
1120                 print "MT +updated\n";
1121                 print "MT text U \n";
1122                 print "MT fname $filename\n";
1123                 print "MT newline\n";
1124                 print "MT -updated\n";
1125             }
1126
1127             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1128
1129             # Don't want to actually _DO_ the update if -n specified
1130             unless ( $state->{globaloptions}{-n} )
1131             {
1132                 if ( defined ( $wrev ) )
1133                 {
1134                     # instruct client we're sending a file to put in this path as a replacement
1135                     print "Update-existing $dirpart\n";
1136                     $log->debug("Updating existing file 'Update-existing $dirpart'");
1137                 } else {
1138                     # instruct client we're sending a file to put in this path as a new file
1139                     print "Clear-static-directory $dirpart\n";
1140                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1141                     print "Clear-sticky $dirpart\n";
1142                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1143
1144                     $log->debug("Creating new file 'Created $dirpart'");
1145                     print "Created $dirpart\n";
1146                 }
1147                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1148
1149                 # this is an "entries" line
1150                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1151                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1152                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1153
1154                 # permissions
1155                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1156                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1157
1158                 # transmit file
1159                 transmitfile($meta->{filehash});
1160             }
1161         } else {
1162             $log->info("Updating '$filename'");
1163             my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1164
1165             my $mergeDir = setupTmpDir();
1166
1167             my $file_local = $filepart . ".mine";
1168             my $mergedFile = "$mergeDir/$file_local";
1169             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1170             my $file_old = $filepart . "." . $oldmeta->{revision};
1171             transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1172             my $file_new = $filepart . "." . $meta->{revision};
1173             transmitfile($meta->{filehash}, { targetfile => $file_new });
1174
1175             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1176             $log->info("Merging $file_local, $file_old, $file_new");
1177             print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1178
1179             $log->debug("Temporary directory for merge is $mergeDir");
1180
1181             my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1182             $return >>= 8;
1183
1184             cleanupTmpDir();
1185
1186             if ( $return == 0 )
1187             {
1188                 $log->info("Merged successfully");
1189                 print "M M $filename\n";
1190                 $log->debug("Merged $dirpart");
1191
1192                 # Don't want to actually _DO_ the update if -n specified
1193                 unless ( $state->{globaloptions}{-n} )
1194                 {
1195                     print "Merged $dirpart\n";
1196                     $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1197                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1198                     my $kopts = kopts_from_path("$dirpart/$filepart",
1199                                                 "file",$mergedFile);
1200                     $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1201                     print "/$filepart/1.$meta->{revision}//$kopts/\n";
1202                 }
1203             }
1204             elsif ( $return == 1 )
1205             {
1206                 $log->info("Merged with conflicts");
1207                 print "E cvs update: conflicts found in $filename\n";
1208                 print "M C $filename\n";
1209
1210                 # Don't want to actually _DO_ the update if -n specified
1211                 unless ( $state->{globaloptions}{-n} )
1212                 {
1213                     print "Merged $dirpart\n";
1214                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1215                     my $kopts = kopts_from_path("$dirpart/$filepart",
1216                                                 "file",$mergedFile);
1217                     print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1218                 }
1219             }
1220             else
1221             {
1222                 $log->warn("Merge failed");
1223                 next;
1224             }
1225
1226             # Don't want to actually _DO_ the update if -n specified
1227             unless ( $state->{globaloptions}{-n} )
1228             {
1229                 # permissions
1230                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1231                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1232
1233                 # transmit file, format is single integer on a line by itself (file
1234                 # size) followed by the file contents
1235                 # TODO : we should copy files in blocks
1236                 my $data = `cat $mergedFile`;
1237                 $log->debug("File size : " . length($data));
1238                 print length($data) . "\n";
1239                 print $data;
1240             }
1241         }
1242
1243     }
1244
1245     print "ok\n";
1246 }
1247
1248 sub req_ci
1249 {
1250     my ( $cmd, $data ) = @_;
1251
1252     argsplit("ci");
1253
1254     #$log->debug("State : " . Dumper($state));
1255
1256     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1257
1258     if ( $state->{method} eq 'pserver')
1259     {
1260         print "error 1 pserver access cannot commit\n";
1261         cleanupWorkTree();
1262         exit;
1263     }
1264
1265     if ( -e $state->{CVSROOT} . "/index" )
1266     {
1267         $log->warn("file 'index' already exists in the git repository");
1268         print "error 1 Index already exists in git repo\n";
1269         cleanupWorkTree();
1270         exit;
1271     }
1272
1273     # Grab a handle to the SQLite db and do any necessary updates
1274     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1275     $updater->update();
1276
1277     # Remember where the head was at the beginning.
1278     my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1279     chomp $parenthash;
1280     if ($parenthash !~ /^[0-9a-f]{40}$/) {
1281             print "error 1 pserver cannot find the current HEAD of module";
1282             cleanupWorkTree();
1283             exit;
1284     }
1285
1286     setupWorkTree($parenthash);
1287
1288     $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1289
1290     $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1291
1292     my @committedfiles = ();
1293     my %oldmeta;
1294
1295     # foreach file specified on the command line ...
1296     foreach my $filename ( @{$state->{args}} )
1297     {
1298         my $committedfile = $filename;
1299         $filename = filecleanup($filename);
1300
1301         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1302
1303         my $meta = $updater->getmeta($filename);
1304         $oldmeta{$filename} = $meta;
1305
1306         my $wrev = revparse($filename);
1307
1308         my ( $filepart, $dirpart ) = filenamesplit($filename);
1309
1310         # do a checkout of the file if it is part of this tree
1311         if ($wrev) {
1312             system('git', 'checkout-index', '-f', '-u', $filename);
1313             unless ($? == 0) {
1314                 die "Error running git-checkout-index -f -u $filename : $!";
1315             }
1316         }
1317
1318         my $addflag = 0;
1319         my $rmflag = 0;
1320         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1321         $addflag = 1 unless ( -e $filename );
1322
1323         # Do up to date checking
1324         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1325         {
1326             # fail everything if an up to date check fails
1327             print "error 1 Up to date check failed for $filename\n";
1328             cleanupWorkTree();
1329             exit;
1330         }
1331
1332         push @committedfiles, $committedfile;
1333         $log->info("Committing $filename");
1334
1335         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1336
1337         unless ( $rmflag )
1338         {
1339             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1340             rename $state->{entries}{$filename}{modified_filename},$filename;
1341
1342             # Calculate modes to remove
1343             my $invmode = "";
1344             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1345
1346             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1347             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1348         }
1349
1350         if ( $rmflag )
1351         {
1352             $log->info("Removing file '$filename'");
1353             unlink($filename);
1354             system("git", "update-index", "--remove", $filename);
1355         }
1356         elsif ( $addflag )
1357         {
1358             $log->info("Adding file '$filename'");
1359             system("git", "update-index", "--add", $filename);
1360         } else {
1361             $log->info("Updating file '$filename'");
1362             system("git", "update-index", $filename);
1363         }
1364     }
1365
1366     unless ( scalar(@committedfiles) > 0 )
1367     {
1368         print "E No files to commit\n";
1369         print "ok\n";
1370         cleanupWorkTree();
1371         return;
1372     }
1373
1374     my $treehash = `git write-tree`;
1375     chomp $treehash;
1376
1377     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1378
1379     # write our commit message out if we have one ...
1380     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1381     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1382     if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1383         if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1384             print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1385         }
1386     } else {
1387         print $msg_fh "\n\nvia git-CVS emulator\n";
1388     }
1389     close $msg_fh;
1390
1391     my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1392     chomp($commithash);
1393     $log->info("Commit hash : $commithash");
1394
1395     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1396     {
1397         $log->warn("Commit failed (Invalid commit hash)");
1398         print "error 1 Commit failed (unknown reason)\n";
1399         cleanupWorkTree();
1400         exit;
1401     }
1402
1403         ### Emulate git-receive-pack by running hooks/update
1404         my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1405                         $parenthash, $commithash );
1406         if( -x $hook[0] ) {
1407                 unless( system( @hook ) == 0 )
1408                 {
1409                         $log->warn("Commit failed (update hook declined to update ref)");
1410                         print "error 1 Commit failed (update hook declined)\n";
1411                         cleanupWorkTree();
1412                         exit;
1413                 }
1414         }
1415
1416         ### Update the ref
1417         if (system(qw(git update-ref -m), "cvsserver ci",
1418                         "refs/heads/$state->{module}", $commithash, $parenthash)) {
1419                 $log->warn("update-ref for $state->{module} failed.");
1420                 print "error 1 Cannot commit -- update first\n";
1421                 cleanupWorkTree();
1422                 exit;
1423         }
1424
1425         ### Emulate git-receive-pack by running hooks/post-receive
1426         my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1427         if( -x $hook ) {
1428                 open(my $pipe, "| $hook") || die "can't fork $!";
1429
1430                 local $SIG{PIPE} = sub { die 'pipe broke' };
1431
1432                 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1433
1434                 close $pipe || die "bad pipe: $! $?";
1435         }
1436
1437     $updater->update();
1438
1439         ### Then hooks/post-update
1440         $hook = $ENV{GIT_DIR}.'hooks/post-update';
1441         if (-x $hook) {
1442                 system($hook, "refs/heads/$state->{module}");
1443         }
1444
1445     # foreach file specified on the command line ...
1446     foreach my $filename ( @committedfiles )
1447     {
1448         $filename = filecleanup($filename);
1449
1450         my $meta = $updater->getmeta($filename);
1451         unless (defined $meta->{revision}) {
1452           $meta->{revision} = 1;
1453         }
1454
1455         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1456
1457         $log->debug("Checked-in $dirpart : $filename");
1458
1459         print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1460         if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1461         {
1462             print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1463             print "Remove-entry $dirpart\n";
1464             print "$filename\n";
1465         } else {
1466             if ($meta->{revision} == 1) {
1467                 print "M initial revision: 1.1\n";
1468             } else {
1469                 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1470             }
1471             print "Checked-in $dirpart\n";
1472             print "$filename\n";
1473             my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1474             print "/$filepart/1.$meta->{revision}//$kopts/\n";
1475         }
1476     }
1477
1478     cleanupWorkTree();
1479     print "ok\n";
1480 }
1481
1482 sub req_status
1483 {
1484     my ( $cmd, $data ) = @_;
1485
1486     argsplit("status");
1487
1488     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1489     #$log->debug("status state : " . Dumper($state));
1490
1491     # Grab a handle to the SQLite db and do any necessary updates
1492     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1493     $updater->update();
1494
1495     # if no files were specified, we need to work out what files we should be providing status on ...
1496     argsfromdir($updater);
1497
1498     # foreach file specified on the command line ...
1499     foreach my $filename ( @{$state->{args}} )
1500     {
1501         $filename = filecleanup($filename);
1502
1503         next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1504
1505         my $meta = $updater->getmeta($filename);
1506         my $oldmeta = $meta;
1507
1508         my $wrev = revparse($filename);
1509
1510         # If the working copy is an old revision, lets get that version too for comparison.
1511         if ( defined($wrev) and $wrev != $meta->{revision} )
1512         {
1513             $oldmeta = $updater->getmeta($filename, $wrev);
1514         }
1515
1516         # TODO : All possible statuses aren't yet implemented
1517         my $status;
1518         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1519         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1520                                     and
1521                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1522                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1523                                    );
1524
1525         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1526         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1527                                           and
1528                                           ( $state->{entries}{$filename}{unchanged}
1529                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1530                                         );
1531
1532         # Need checkout if it exists in the repo but doesn't have a working copy
1533         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1534
1535         # Locally modified if working copy and repo copy have the same revision but there are local changes
1536         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1537
1538         # Needs Merge if working copy revision is less than repo copy and there are local changes
1539         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1540
1541         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1542         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1543         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1544         $status ||= "File had conflicts on merge" if ( 0 );
1545
1546         $status ||= "Unknown";
1547
1548         my ($filepart) = filenamesplit($filename);
1549
1550         print "M ===================================================================\n";
1551         print "M File: $filepart\tStatus: $status\n";
1552         if ( defined($state->{entries}{$filename}{revision}) )
1553         {
1554             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1555         } else {
1556             print "M Working revision:\tNo entry for $filename\n";
1557         }
1558         if ( defined($meta->{revision}) )
1559         {
1560             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1561             print "M Sticky Tag:\t\t(none)\n";
1562             print "M Sticky Date:\t\t(none)\n";
1563             print "M Sticky Options:\t\t(none)\n";
1564         } else {
1565             print "M Repository revision:\tNo revision control file\n";
1566         }
1567         print "M\n";
1568     }
1569
1570     print "ok\n";
1571 }
1572
1573 sub req_diff
1574 {
1575     my ( $cmd, $data ) = @_;
1576
1577     argsplit("diff");
1578
1579     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1580     #$log->debug("status state : " . Dumper($state));
1581
1582     my ($revision1, $revision2);
1583     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1584     {
1585         $revision1 = $state->{opt}{r}[0];
1586         $revision2 = $state->{opt}{r}[1];
1587     } else {
1588         $revision1 = $state->{opt}{r};
1589     }
1590
1591     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1592     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1593
1594     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1595
1596     # Grab a handle to the SQLite db and do any necessary updates
1597     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1598     $updater->update();
1599
1600     # if no files were specified, we need to work out what files we should be providing status on ...
1601     argsfromdir($updater);
1602
1603     # foreach file specified on the command line ...
1604     foreach my $filename ( @{$state->{args}} )
1605     {
1606         $filename = filecleanup($filename);
1607
1608         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1609
1610         my $wrev = revparse($filename);
1611
1612         # We need _something_ to diff against
1613         next unless ( defined ( $wrev ) );
1614
1615         # if we have a -r switch, use it
1616         if ( defined ( $revision1 ) )
1617         {
1618             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1619             $meta1 = $updater->getmeta($filename, $revision1);
1620             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1621             {
1622                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1623                 next;
1624             }
1625             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1626         }
1627         # otherwise we just use the working copy revision
1628         else
1629         {
1630             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1631             $meta1 = $updater->getmeta($filename, $wrev);
1632             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1633         }
1634
1635         # if we have a second -r switch, use it too
1636         if ( defined ( $revision2 ) )
1637         {
1638             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1639             $meta2 = $updater->getmeta($filename, $revision2);
1640
1641             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1642             {
1643                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1644                 next;
1645             }
1646
1647             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1648         }
1649         # otherwise we just use the working copy
1650         else
1651         {
1652             $file2 = $state->{entries}{$filename}{modified_filename};
1653         }
1654
1655         # if we have been given -r, and we don't have a $file2 yet, lets get one
1656         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1657         {
1658             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1659             $meta2 = $updater->getmeta($filename, $wrev);
1660             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1661         }
1662
1663         # We need to have retrieved something useful
1664         next unless ( defined ( $meta1 ) );
1665
1666         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1667         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1668                   and
1669                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1670                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1671                   );
1672
1673         # Apparently we only show diffs for locally modified files
1674         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1675
1676         print "M Index: $filename\n";
1677         print "M ===================================================================\n";
1678         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1679         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1680         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1681         print "M diff ";
1682         foreach my $opt ( keys %{$state->{opt}} )
1683         {
1684             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1685             {
1686                 foreach my $value ( @{$state->{opt}{$opt}} )
1687                 {
1688                     print "-$opt $value ";
1689                 }
1690             } else {
1691                 print "-$opt ";
1692                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1693             }
1694         }
1695         print "$filename\n";
1696
1697         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1698
1699         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1700
1701         if ( exists $state->{opt}{u} )
1702         {
1703             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1704         } else {
1705             system("diff $file1 $file2 > $filediff");
1706         }
1707
1708         while ( <$fh> )
1709         {
1710             print "M $_";
1711         }
1712         close $fh;
1713     }
1714
1715     print "ok\n";
1716 }
1717
1718 sub req_log
1719 {
1720     my ( $cmd, $data ) = @_;
1721
1722     argsplit("log");
1723
1724     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1725     #$log->debug("log state : " . Dumper($state));
1726
1727     my ( $minrev, $maxrev );
1728     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1729     {
1730         my $control = $2;
1731         $minrev = $1;
1732         $maxrev = $3;
1733         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1734         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1735         $minrev++ if ( defined($minrev) and $control eq "::" );
1736     }
1737
1738     # Grab a handle to the SQLite db and do any necessary updates
1739     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1740     $updater->update();
1741
1742     # if no files were specified, we need to work out what files we should be providing status on ...
1743     argsfromdir($updater);
1744
1745     # foreach file specified on the command line ...
1746     foreach my $filename ( @{$state->{args}} )
1747     {
1748         $filename = filecleanup($filename);
1749
1750         my $headmeta = $updater->getmeta($filename);
1751
1752         my $revisions = $updater->getlog($filename);
1753         my $totalrevisions = scalar(@$revisions);
1754
1755         if ( defined ( $minrev ) )
1756         {
1757             $log->debug("Removing revisions less than $minrev");
1758             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1759             {
1760                 pop @$revisions;
1761             }
1762         }
1763         if ( defined ( $maxrev ) )
1764         {
1765             $log->debug("Removing revisions greater than $maxrev");
1766             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1767             {
1768                 shift @$revisions;
1769             }
1770         }
1771
1772         next unless ( scalar(@$revisions) );
1773
1774         print "M \n";
1775         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1776         print "M Working file: $filename\n";
1777         print "M head: 1.$headmeta->{revision}\n";
1778         print "M branch:\n";
1779         print "M locks: strict\n";
1780         print "M access list:\n";
1781         print "M symbolic names:\n";
1782         print "M keyword substitution: kv\n";
1783         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1784         print "M description:\n";
1785
1786         foreach my $revision ( @$revisions )
1787         {
1788             print "M ----------------------------\n";
1789             print "M revision 1.$revision->{revision}\n";
1790             # reformat the date for log output
1791             $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}) );
1792             $revision->{author} = cvs_author($revision->{author});
1793             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1794             my $commitmessage = $updater->commitmessage($revision->{commithash});
1795             $commitmessage =~ s/^/M /mg;
1796             print $commitmessage . "\n";
1797         }
1798         print "M =============================================================================\n";
1799     }
1800
1801     print "ok\n";
1802 }
1803
1804 sub req_annotate
1805 {
1806     my ( $cmd, $data ) = @_;
1807
1808     argsplit("annotate");
1809
1810     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1811     #$log->debug("status state : " . Dumper($state));
1812
1813     # Grab a handle to the SQLite db and do any necessary updates
1814     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1815     $updater->update();
1816
1817     # if no files were specified, we need to work out what files we should be providing annotate on ...
1818     argsfromdir($updater);
1819
1820     # we'll need a temporary checkout dir
1821     setupWorkTree();
1822
1823     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1824
1825     # foreach file specified on the command line ...
1826     foreach my $filename ( @{$state->{args}} )
1827     {
1828         $filename = filecleanup($filename);
1829
1830         my $meta = $updater->getmeta($filename);
1831
1832         next unless ( $meta->{revision} );
1833
1834         # get all the commits that this file was in
1835         # in dense format -- aka skip dead revisions
1836         my $revisions   = $updater->gethistorydense($filename);
1837         my $lastseenin  = $revisions->[0][2];
1838
1839         # populate the temporary index based on the latest commit were we saw
1840         # the file -- but do it cheaply without checking out any files
1841         # TODO: if we got a revision from the client, use that instead
1842         # to look up the commithash in sqlite (still good to default to
1843         # the current head as we do now)
1844         system("git", "read-tree", $lastseenin);
1845         unless ($? == 0)
1846         {
1847             print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1848             return;
1849         }
1850         $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1851
1852         # do a checkout of the file
1853         system('git', 'checkout-index', '-f', '-u', $filename);
1854         unless ($? == 0) {
1855             print "E error running git-checkout-index -f -u $filename : $!\n";
1856             return;
1857         }
1858
1859         $log->info("Annotate $filename");
1860
1861         # Prepare a file with the commits from the linearized
1862         # history that annotate should know about. This prevents
1863         # git-jsannotate telling us about commits we are hiding
1864         # from the client.
1865
1866         my $a_hints = "$work->{workDir}/.annotate_hints";
1867         if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1868             print "E failed to open '$a_hints' for writing: $!\n";
1869             return;
1870         }
1871         for (my $i=0; $i < @$revisions; $i++)
1872         {
1873             print ANNOTATEHINTS $revisions->[$i][2];
1874             if ($i+1 < @$revisions) { # have we got a parent?
1875                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1876             }
1877             print ANNOTATEHINTS "\n";
1878         }
1879
1880         print ANNOTATEHINTS "\n";
1881         close ANNOTATEHINTS
1882             or (print "E failed to write $a_hints: $!\n"), return;
1883
1884         my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
1885         if (!open(ANNOTATE, "-|", @cmd)) {
1886             print "E error invoking ". join(' ',@cmd) .": $!\n";
1887             return;
1888         }
1889         my $metadata = {};
1890         print "E Annotations for $filename\n";
1891         print "E ***************\n";
1892         while ( <ANNOTATE> )
1893         {
1894             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1895             {
1896                 my $commithash = $1;
1897                 my $data = $2;
1898                 unless ( defined ( $metadata->{$commithash} ) )
1899                 {
1900                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1901                     $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1902                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1903                 }
1904                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1905                     $metadata->{$commithash}{revision},
1906                     $metadata->{$commithash}{author},
1907                     $metadata->{$commithash}{modified},
1908                     $data
1909                 );
1910             } else {
1911                 $log->warn("Error in annotate output! LINE: $_");
1912                 print "E Annotate error \n";
1913                 next;
1914             }
1915         }
1916         close ANNOTATE;
1917     }
1918
1919     # done; get out of the tempdir
1920     cleanupWorkTree();
1921
1922     print "ok\n";
1923
1924 }
1925
1926 # This method takes the state->{arguments} array and produces two new arrays.
1927 # The first is $state->{args} which is everything before the '--' argument, and
1928 # the second is $state->{files} which is everything after it.
1929 sub argsplit
1930 {
1931     $state->{args} = [];
1932     $state->{files} = [];
1933     $state->{opt} = {};
1934
1935     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1936
1937     my $type = shift;
1938
1939     if ( defined($type) )
1940     {
1941         my $opt = {};
1942         $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" );
1943         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1944         $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" );
1945         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1946         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1947         $opt = { k => 1, m => 1 } if ( $type eq "add" );
1948         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1949         $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" );
1950
1951
1952         while ( scalar ( @{$state->{arguments}} ) > 0 )
1953         {
1954             my $arg = shift @{$state->{arguments}};
1955
1956             next if ( $arg eq "--" );
1957             next unless ( $arg =~ /\S/ );
1958
1959             # if the argument looks like a switch
1960             if ( $arg =~ /^-(\w)(.*)/ )
1961             {
1962                 # if it's a switch that takes an argument
1963                 if ( $opt->{$1} )
1964                 {
1965                     # If this switch has already been provided
1966                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1967                     {
1968                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
1969                         if ( length($2) > 0 )
1970                         {
1971                             push @{$state->{opt}{$1}},$2;
1972                         } else {
1973                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1974                         }
1975                     } else {
1976                         # if there's extra data in the arg, use that as the argument for the switch
1977                         if ( length($2) > 0 )
1978                         {
1979                             $state->{opt}{$1} = $2;
1980                         } else {
1981                             $state->{opt}{$1} = shift @{$state->{arguments}};
1982                         }
1983                     }
1984                 } else {
1985                     $state->{opt}{$1} = undef;
1986                 }
1987             }
1988             else
1989             {
1990                 push @{$state->{args}}, $arg;
1991             }
1992         }
1993     }
1994     else
1995     {
1996         my $mode = 0;
1997
1998         foreach my $value ( @{$state->{arguments}} )
1999         {
2000             if ( $value eq "--" )
2001             {
2002                 $mode++;
2003                 next;
2004             }
2005             push @{$state->{args}}, $value if ( $mode == 0 );
2006             push @{$state->{files}}, $value if ( $mode == 1 );
2007         }
2008     }
2009 }
2010
2011 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2012 sub argsfromdir
2013 {
2014     my $updater = shift;
2015
2016     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2017
2018     return if ( scalar ( @{$state->{args}} ) > 1 );
2019
2020     my @gethead = @{$updater->gethead};
2021
2022     # push added files
2023     foreach my $file (keys %{$state->{entries}}) {
2024         if ( exists $state->{entries}{$file}{revision} &&
2025                 $state->{entries}{$file}{revision} == 0 )
2026         {
2027             push @gethead, { name => $file, filehash => 'added' };
2028         }
2029     }
2030
2031     if ( scalar(@{$state->{args}}) == 1 )
2032     {
2033         my $arg = $state->{args}[0];
2034         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2035
2036         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2037
2038         foreach my $file ( @gethead )
2039         {
2040             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2041             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
2042             push @{$state->{args}}, $file->{name};
2043         }
2044
2045         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2046     } else {
2047         $log->info("Only one arg specified, populating file list automatically");
2048
2049         $state->{args} = [];
2050
2051         foreach my $file ( @gethead )
2052         {
2053             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2054             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2055             push @{$state->{args}}, $file->{name};
2056         }
2057     }
2058 }
2059
2060 # This method cleans up the $state variable after a command that uses arguments has run
2061 sub statecleanup
2062 {
2063     $state->{files} = [];
2064     $state->{args} = [];
2065     $state->{arguments} = [];
2066     $state->{entries} = {};
2067 }
2068
2069 sub revparse
2070 {
2071     my $filename = shift;
2072
2073     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2074
2075     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2076     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2077
2078     return undef;
2079 }
2080
2081 # This method takes a file hash and does a CVS "file transfer".  Its
2082 # exact behaviour depends on a second, optional hash table argument:
2083 # - If $options->{targetfile}, dump the contents to that file;
2084 # - If $options->{print}, use M/MT to transmit the contents one line
2085 #   at a time;
2086 # - Otherwise, transmit the size of the file, followed by the file
2087 #   contents.
2088 sub transmitfile
2089 {
2090     my $filehash = shift;
2091     my $options = shift;
2092
2093     if ( defined ( $filehash ) and $filehash eq "deleted" )
2094     {
2095         $log->warn("filehash is 'deleted'");
2096         return;
2097     }
2098
2099     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2100
2101     my $type = `git cat-file -t $filehash`;
2102     chomp $type;
2103
2104     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2105
2106     my $size = `git cat-file -s $filehash`;
2107     chomp $size;
2108
2109     $log->debug("transmitfile($filehash) size=$size, type=$type");
2110
2111     if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2112     {
2113         if ( defined ( $options->{targetfile} ) )
2114         {
2115             my $targetfile = $options->{targetfile};
2116             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2117             print NEWFILE $_ while ( <$fh> );
2118             close NEWFILE or die("Failed to write '$targetfile': $!");
2119         } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2120             while ( <$fh> ) {
2121                 if( /\n\z/ ) {
2122                     print 'M ', $_;
2123                 } else {
2124                     print 'MT text ', $_, "\n";
2125                 }
2126             }
2127         } else {
2128             print "$size\n";
2129             print while ( <$fh> );
2130         }
2131         close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2132     } else {
2133         die("Couldn't execute git-cat-file");
2134     }
2135 }
2136
2137 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2138 # refers to the directory portion and the file portion of the filename
2139 # respectively
2140 sub filenamesplit
2141 {
2142     my $filename = shift;
2143     my $fixforlocaldir = shift;
2144
2145     my ( $filepart, $dirpart ) = ( $filename, "." );
2146     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2147     $dirpart .= "/";
2148
2149     if ( $fixforlocaldir )
2150     {
2151         $dirpart =~ s/^$state->{prependdir}//;
2152     }
2153
2154     return ( $filepart, $dirpart );
2155 }
2156
2157 sub filecleanup
2158 {
2159     my $filename = shift;
2160
2161     return undef unless(defined($filename));
2162     if ( $filename =~ /^\// )
2163     {
2164         print "E absolute filenames '$filename' not supported by server\n";
2165         return undef;
2166     }
2167
2168     $filename =~ s/^\.\///g;
2169     $filename = $state->{prependdir} . $filename;
2170     return $filename;
2171 }
2172
2173 sub validateGitDir
2174 {
2175     if( !defined($state->{CVSROOT}) )
2176     {
2177         print "error 1 CVSROOT not specified\n";
2178         cleanupWorkTree();
2179         exit;
2180     }
2181     if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2182     {
2183         print "error 1 Internally inconsistent CVSROOT\n";
2184         cleanupWorkTree();
2185         exit;
2186     }
2187 }
2188
2189 # Setup working directory in a work tree with the requested version
2190 # loaded in the index.
2191 sub setupWorkTree
2192 {
2193     my ($ver) = @_;
2194
2195     validateGitDir();
2196
2197     if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2198         defined($work->{tmpDir}) )
2199     {
2200         $log->warn("Bad work tree state management");
2201         print "error 1 Internal setup multiple work trees without cleanup\n";
2202         cleanupWorkTree();
2203         exit;
2204     }
2205
2206     $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2207
2208     if( !defined($work->{index}) )
2209     {
2210         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2211     }
2212
2213     chdir $work->{workDir} or
2214         die "Unable to chdir to $work->{workDir}\n";
2215
2216     $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2217
2218     $ENV{GIT_WORK_TREE} = ".";
2219     $ENV{GIT_INDEX_FILE} = $work->{index};
2220     $work->{state} = 2;
2221
2222     if($ver)
2223     {
2224         system("git","read-tree",$ver);
2225         unless ($? == 0)
2226         {
2227             $log->warn("Error running git-read-tree");
2228             die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2229         }
2230     }
2231     # else # req_annotate reads tree for each file
2232 }
2233
2234 # Ensure current directory is in some kind of working directory,
2235 # with a recent version loaded in the index.
2236 sub ensureWorkTree
2237 {
2238     if( defined($work->{tmpDir}) )
2239     {
2240         $log->warn("Bad work tree state management [ensureWorkTree()]");
2241         print "error 1 Internal setup multiple dirs without cleanup\n";
2242         cleanupWorkTree();
2243         exit;
2244     }
2245     if( $work->{state} )
2246     {
2247         return;
2248     }
2249
2250     validateGitDir();
2251
2252     if( !defined($work->{emptyDir}) )
2253     {
2254         $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2255     }
2256     chdir $work->{emptyDir} or
2257         die "Unable to chdir to $work->{emptyDir}\n";
2258
2259     my $ver = `git show-ref -s refs/heads/$state->{module}`;
2260     chomp $ver;
2261     if ($ver !~ /^[0-9a-f]{40}$/)
2262     {
2263         $log->warn("Error from git show-ref -s refs/head$state->{module}");
2264         print "error 1 cannot find the current HEAD of module";
2265         cleanupWorkTree();
2266         exit;
2267     }
2268
2269     if( !defined($work->{index}) )
2270     {
2271         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2272     }
2273
2274     $ENV{GIT_WORK_TREE} = ".";
2275     $ENV{GIT_INDEX_FILE} = $work->{index};
2276     $work->{state} = 1;
2277
2278     system("git","read-tree",$ver);
2279     unless ($? == 0)
2280     {
2281         die "Error running git-read-tree $ver $!\n";
2282     }
2283 }
2284
2285 # Cleanup working directory that is not needed any longer.
2286 sub cleanupWorkTree
2287 {
2288     if( ! $work->{state} )
2289     {
2290         return;
2291     }
2292
2293     chdir "/" or die "Unable to chdir '/'\n";
2294
2295     if( defined($work->{workDir}) )
2296     {
2297         rmtree( $work->{workDir} );
2298         undef $work->{workDir};
2299     }
2300     undef $work->{state};
2301 }
2302
2303 # Setup a temporary directory (not a working tree), typically for
2304 # merging dirty state as in req_update.
2305 sub setupTmpDir
2306 {
2307     $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2308     chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2309
2310     return $work->{tmpDir};
2311 }
2312
2313 # Clean up a previously setupTmpDir.  Restore previous work tree if
2314 # appropriate.
2315 sub cleanupTmpDir
2316 {
2317     if ( !defined($work->{tmpDir}) )
2318     {
2319         $log->warn("cleanup tmpdir that has not been setup");
2320         die "Cleanup tmpDir that has not been setup\n";
2321     }
2322     if( defined($work->{state}) )
2323     {
2324         if( $work->{state} == 1 )
2325         {
2326             chdir $work->{emptyDir} or
2327                 die "Unable to chdir to $work->{emptyDir}\n";
2328         }
2329         elsif( $work->{state} == 2 )
2330         {
2331             chdir $work->{workDir} or
2332                 die "Unable to chdir to $work->{emptyDir}\n";
2333         }
2334         else
2335         {
2336             $log->warn("Inconsistent work dir state");
2337             die "Inconsistent work dir state\n";
2338         }
2339     }
2340     else
2341     {
2342         chdir "/" or die "Unable to chdir '/'\n";
2343     }
2344 }
2345
2346 # Given a path, this function returns a string containing the kopts
2347 # that should go into that path's Entries line.  For example, a binary
2348 # file should get -kb.
2349 sub kopts_from_path
2350 {
2351     my ($path, $srcType, $name) = @_;
2352
2353     if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2354          $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2355     {
2356         my ($val) = check_attr( "crlf", $path );
2357         if ( $val eq "set" )
2358         {
2359             return "";
2360         }
2361         elsif ( $val eq "unset" )
2362         {
2363             return "-kb"
2364         }
2365         else
2366         {
2367             $log->info("Unrecognized check_attr crlf $path : $val");
2368         }
2369     }
2370
2371     if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2372     {
2373         if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2374         {
2375             return "-kb";
2376         }
2377         elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2378         {
2379             if( $srcType eq "sha1Or-k" &&
2380                 !defined($name) )
2381             {
2382                 my ($ret)=$state->{entries}{$path}{options};
2383                 if( !defined($ret) )
2384                 {
2385                     $ret=$state->{opt}{k};
2386                     if(defined($ret))
2387                     {
2388                         $ret="-k$ret";
2389                     }
2390                     else
2391                     {
2392                         $ret="";
2393                     }
2394                 }
2395                 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2396                 {
2397                     print "E Bad -k option\n";
2398                     $log->warn("Bad -k option: $ret");
2399                     die "Error: Bad -k option: $ret\n";
2400                 }
2401
2402                 return $ret;
2403             }
2404             else
2405             {
2406                 if( is_binary($srcType,$name) )
2407                 {
2408                     $log->debug("... as binary");
2409                     return "-kb";
2410                 }
2411                 else
2412                 {
2413                     $log->debug("... as text");
2414                 }
2415             }
2416         }
2417     }
2418     # Return "" to give no special treatment to any path
2419     return "";
2420 }
2421
2422 sub check_attr
2423 {
2424     my ($attr,$path) = @_;
2425     ensureWorkTree();
2426     if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2427     {
2428         my $val = <$fh>;
2429         close $fh;
2430         $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2431         return $val;
2432     }
2433     else
2434     {
2435         return undef;
2436     }
2437 }
2438
2439 # This should have the same heuristics as convert.c:is_binary() and related.
2440 # Note that the bare CR test is done by callers in convert.c.
2441 sub is_binary
2442 {
2443     my ($srcType,$name) = @_;
2444     $log->debug("is_binary($srcType,$name)");
2445
2446     # Minimize amount of interpreted code run in the inner per-character
2447     # loop for large files, by totalling each character value and
2448     # then analyzing the totals.
2449     my @counts;
2450     my $i;
2451     for($i=0;$i<256;$i++)
2452     {
2453         $counts[$i]=0;
2454     }
2455
2456     my $fh = open_blob_or_die($srcType,$name);
2457     my $line;
2458     while( defined($line=<$fh>) )
2459     {
2460         # Any '\0' and bare CR are considered binary.
2461         if( $line =~ /\0|(\r[^\n])/ )
2462         {
2463             close($fh);
2464             return 1;
2465         }
2466
2467         # Count up each character in the line:
2468         my $len=length($line);
2469         for($i=0;$i<$len;$i++)
2470         {
2471             $counts[ord(substr($line,$i,1))]++;
2472         }
2473     }
2474     close $fh;
2475
2476     # Don't count CR and LF as either printable/nonprintable
2477     $counts[ord("\n")]=0;
2478     $counts[ord("\r")]=0;
2479
2480     # Categorize individual character count into printable and nonprintable:
2481     my $printable=0;
2482     my $nonprintable=0;
2483     for($i=0;$i<256;$i++)
2484     {
2485         if( $i < 32 &&
2486             $i != ord("\b") &&
2487             $i != ord("\t") &&
2488             $i != 033 &&       # ESC
2489             $i != 014 )        # FF
2490         {
2491             $nonprintable+=$counts[$i];
2492         }
2493         elsif( $i==127 )  # DEL
2494         {
2495             $nonprintable+=$counts[$i];
2496         }
2497         else
2498         {
2499             $printable+=$counts[$i];
2500         }
2501     }
2502
2503     return ($printable >> 7) < $nonprintable;
2504 }
2505
2506 # Returns open file handle.  Possible invocations:
2507 #  - open_blob_or_die("file",$filename);
2508 #  - open_blob_or_die("sha1",$filehash);
2509 sub open_blob_or_die
2510 {
2511     my ($srcType,$name) = @_;
2512     my ($fh);
2513     if( $srcType eq "file" )
2514     {
2515         if( !open $fh,"<",$name )
2516         {
2517             $log->warn("Unable to open file $name: $!");
2518             die "Unable to open file $name: $!\n";
2519         }
2520     }
2521     elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2522     {
2523         unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2524         {
2525             $log->warn("Need filehash");
2526             die "Need filehash\n";
2527         }
2528
2529         my $type = `git cat-file -t $name`;
2530         chomp $type;
2531
2532         unless ( defined ( $type ) and $type eq "blob" )
2533         {
2534             $log->warn("Invalid type '$type' for '$name'");
2535             die ( "Invalid type '$type' (expected 'blob')" )
2536         }
2537
2538         my $size = `git cat-file -s $name`;
2539         chomp $size;
2540
2541         $log->debug("open_blob_or_die($name) size=$size, type=$type");
2542
2543         unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2544         {
2545             $log->warn("Unable to open sha1 $name");
2546             die "Unable to open sha1 $name\n";
2547         }
2548     }
2549     else
2550     {
2551         $log->warn("Unknown type of blob source: $srcType");
2552         die "Unknown type of blob source: $srcType\n";
2553     }
2554     return $fh;
2555 }
2556
2557 # Generate a CVS author name from Git author information, by taking the local
2558 # part of the email address and replacing characters not in the Portable
2559 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2560 # Login names are Unix login names, which should be restricted to this
2561 # character set.
2562 sub cvs_author
2563 {
2564     my $author_line = shift;
2565     (my $author) = $author_line =~ /<([^@>]*)/;
2566
2567     $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2568     $author =~ s/^-/_/;
2569
2570     $author;
2571 }
2572
2573 package GITCVS::log;
2574
2575 ####
2576 #### Copyright The Open University UK - 2006.
2577 ####
2578 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2579 ####          Martin Langhoff <martin@catalyst.net.nz>
2580 ####
2581 ####
2582
2583 use strict;
2584 use warnings;
2585
2586 =head1 NAME
2587
2588 GITCVS::log
2589
2590 =head1 DESCRIPTION
2591
2592 This module provides very crude logging with a similar interface to
2593 Log::Log4perl
2594
2595 =head1 METHODS
2596
2597 =cut
2598
2599 =head2 new
2600
2601 Creates a new log object, optionally you can specify a filename here to
2602 indicate the file to log to. If no log file is specified, you can specify one
2603 later with method setfile, or indicate you no longer want logging with method
2604 nofile.
2605
2606 Until one of these methods is called, all log calls will buffer messages ready
2607 to write out.
2608
2609 =cut
2610 sub new
2611 {
2612     my $class = shift;
2613     my $filename = shift;
2614
2615     my $self = {};
2616
2617     bless $self, $class;
2618
2619     if ( defined ( $filename ) )
2620     {
2621         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2622     }
2623
2624     return $self;
2625 }
2626
2627 =head2 setfile
2628
2629 This methods takes a filename, and attempts to open that file as the log file.
2630 If successful, all buffered data is written out to the file, and any further
2631 logging is written directly to the file.
2632
2633 =cut
2634 sub setfile
2635 {
2636     my $self = shift;
2637     my $filename = shift;
2638
2639     if ( defined ( $filename ) )
2640     {
2641         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2642     }
2643
2644     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2645
2646     while ( my $line = shift @{$self->{buffer}} )
2647     {
2648         print {$self->{fh}} $line;
2649     }
2650 }
2651
2652 =head2 nofile
2653
2654 This method indicates no logging is going to be used. It flushes any entries in
2655 the internal buffer, and sets a flag to ensure no further data is put there.
2656
2657 =cut
2658 sub nofile
2659 {
2660     my $self = shift;
2661
2662     $self->{nolog} = 1;
2663
2664     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2665
2666     $self->{buffer} = [];
2667 }
2668
2669 =head2 _logopen
2670
2671 Internal method. Returns true if the log file is open, false otherwise.
2672
2673 =cut
2674 sub _logopen
2675 {
2676     my $self = shift;
2677
2678     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2679     return 0;
2680 }
2681
2682 =head2 debug info warn fatal
2683
2684 These four methods are wrappers to _log. They provide the actual interface for
2685 logging data.
2686
2687 =cut
2688 sub debug { my $self = shift; $self->_log("debug", @_); }
2689 sub info  { my $self = shift; $self->_log("info" , @_); }
2690 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2691 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2692
2693 =head2 _log
2694
2695 This is an internal method called by the logging functions. It generates a
2696 timestamp and pushes the logged line either to file, or internal buffer.
2697
2698 =cut
2699 sub _log
2700 {
2701     my $self = shift;
2702     my $level = shift;
2703
2704     return if ( $self->{nolog} );
2705
2706     my @time = localtime;
2707     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2708         $time[5] + 1900,
2709         $time[4] + 1,
2710         $time[3],
2711         $time[2],
2712         $time[1],
2713         $time[0],
2714         uc $level,
2715     );
2716
2717     if ( $self->_logopen )
2718     {
2719         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2720     } else {
2721         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2722     }
2723 }
2724
2725 =head2 DESTROY
2726
2727 This method simply closes the file handle if one is open
2728
2729 =cut
2730 sub DESTROY
2731 {
2732     my $self = shift;
2733
2734     if ( $self->_logopen )
2735     {
2736         close $self->{fh};
2737     }
2738 }
2739
2740 package GITCVS::updater;
2741
2742 ####
2743 #### Copyright The Open University UK - 2006.
2744 ####
2745 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2746 ####          Martin Langhoff <martin@catalyst.net.nz>
2747 ####
2748 ####
2749
2750 use strict;
2751 use warnings;
2752 use DBI;
2753
2754 =head1 METHODS
2755
2756 =cut
2757
2758 =head2 new
2759
2760 =cut
2761 sub new
2762 {
2763     my $class = shift;
2764     my $config = shift;
2765     my $module = shift;
2766     my $log = shift;
2767
2768     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2769     die "Need to specify a module" unless ( defined($module) );
2770
2771     $class = ref($class) || $class;
2772
2773     my $self = {};
2774
2775     bless $self, $class;
2776
2777     $self->{valid_tables} = {'revision' => 1,
2778                              'revision_ix1' => 1,
2779                              'revision_ix2' => 1,
2780                              'head' => 1,
2781                              'head_ix1' => 1,
2782                              'properties' => 1,
2783                              'commitmsgs' => 1};
2784
2785     $self->{module} = $module;
2786     $self->{git_path} = $config . "/";
2787
2788     $self->{log} = $log;
2789
2790     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2791
2792     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2793         $cfg->{gitcvs}{dbdriver} || "SQLite";
2794     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2795         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2796     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2797         $cfg->{gitcvs}{dbuser} || "";
2798     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2799         $cfg->{gitcvs}{dbpass} || "";
2800     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2801         $cfg->{gitcvs}{dbtablenameprefix} || "";
2802     my %mapping = ( m => $module,
2803                     a => $state->{method},
2804                     u => getlogin || getpwuid($<) || $<,
2805                     G => $self->{git_path},
2806                     g => mangle_dirname($self->{git_path}),
2807                     );
2808     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2809     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2810     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2811     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2812
2813     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2814     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2815     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2816                                 $self->{dbuser},
2817                                 $self->{dbpass});
2818     die "Error connecting to database\n" unless defined $self->{dbh};
2819
2820     $self->{tables} = {};
2821     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2822     {
2823         $self->{tables}{$table} = 1;
2824     }
2825
2826     # Construct the revision table if required
2827     unless ( $self->{tables}{$self->tablename("revision")} )
2828     {
2829         my $tablename = $self->tablename("revision");
2830         my $ix1name = $self->tablename("revision_ix1");
2831         my $ix2name = $self->tablename("revision_ix2");
2832         $self->{dbh}->do("
2833             CREATE TABLE $tablename (
2834                 name       TEXT NOT NULL,
2835                 revision   INTEGER NOT NULL,
2836                 filehash   TEXT NOT NULL,
2837                 commithash TEXT NOT NULL,
2838                 author     TEXT NOT NULL,
2839                 modified   TEXT NOT NULL,
2840                 mode       TEXT NOT NULL
2841             )
2842         ");
2843         $self->{dbh}->do("
2844             CREATE INDEX $ix1name
2845             ON $tablename (name,revision)
2846         ");
2847         $self->{dbh}->do("
2848             CREATE INDEX $ix2name
2849             ON $tablename (name,commithash)
2850         ");
2851     }
2852
2853     # Construct the head table if required
2854     unless ( $self->{tables}{$self->tablename("head")} )
2855     {
2856         my $tablename = $self->tablename("head");
2857         my $ix1name = $self->tablename("head_ix1");
2858         $self->{dbh}->do("
2859             CREATE TABLE $tablename (
2860                 name       TEXT NOT NULL,
2861                 revision   INTEGER NOT NULL,
2862                 filehash   TEXT NOT NULL,
2863                 commithash TEXT NOT NULL,
2864                 author     TEXT NOT NULL,
2865                 modified   TEXT NOT NULL,
2866                 mode       TEXT NOT NULL
2867             )
2868         ");
2869         $self->{dbh}->do("
2870             CREATE INDEX $ix1name
2871             ON $tablename (name)
2872         ");
2873     }
2874
2875     # Construct the properties table if required
2876     unless ( $self->{tables}{$self->tablename("properties")} )
2877     {
2878         my $tablename = $self->tablename("properties");
2879         $self->{dbh}->do("
2880             CREATE TABLE $tablename (
2881                 key        TEXT NOT NULL PRIMARY KEY,
2882                 value      TEXT
2883             )
2884         ");
2885     }
2886
2887     # Construct the commitmsgs table if required
2888     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2889     {
2890         my $tablename = $self->tablename("commitmsgs");
2891         $self->{dbh}->do("
2892             CREATE TABLE $tablename (
2893                 key        TEXT NOT NULL PRIMARY KEY,
2894                 value      TEXT
2895             )
2896         ");
2897     }
2898
2899     return $self;
2900 }
2901
2902 =head2 tablename
2903
2904 =cut
2905 sub tablename
2906 {
2907     my $self = shift;
2908     my $name = shift;
2909
2910     if (exists $self->{valid_tables}{$name}) {
2911         return $self->{dbtablenameprefix} . $name;
2912     } else {
2913         return undef;
2914     }
2915 }
2916
2917 =head2 update
2918
2919 =cut
2920 sub update
2921 {
2922     my $self = shift;
2923
2924     # first lets get the commit list
2925     $ENV{GIT_DIR} = $self->{git_path};
2926
2927     my $commitsha1 = `git rev-parse $self->{module}`;
2928     chomp $commitsha1;
2929
2930     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2931     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2932     {
2933         die("Invalid module '$self->{module}'");
2934     }
2935
2936
2937     my $git_log;
2938     my $lastcommit = $self->_get_prop("last_commit");
2939
2940     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2941          return 1;
2942     }
2943
2944     # Start exclusive lock here...
2945     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2946
2947     # TODO: log processing is memory bound
2948     # if we can parse into a 2nd file that is in reverse order
2949     # we can probably do something really efficient
2950     my @git_log_params = ('--pretty', '--parents', '--topo-order');
2951
2952     if (defined $lastcommit) {
2953         push @git_log_params, "$lastcommit..$self->{module}";
2954     } else {
2955         push @git_log_params, $self->{module};
2956     }
2957     # git-rev-list is the backend / plumbing version of git-log
2958     open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2959
2960     my @commits;
2961
2962     my %commit = ();
2963
2964     while ( <GITLOG> )
2965     {
2966         chomp;
2967         if (m/^commit\s+(.*)$/) {
2968             # on ^commit lines put the just seen commit in the stack
2969             # and prime things for the next one
2970             if (keys %commit) {
2971                 my %copy = %commit;
2972                 unshift @commits, \%copy;
2973                 %commit = ();
2974             }
2975             my @parents = split(m/\s+/, $1);
2976             $commit{hash} = shift @parents;
2977             $commit{parents} = \@parents;
2978         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2979             # on rfc822-like lines seen before we see any message,
2980             # lowercase the entry and put it in the hash as key-value
2981             $commit{lc($1)} = $2;
2982         } else {
2983             # message lines - skip initial empty line
2984             # and trim whitespace
2985             if (!exists($commit{message}) && m/^\s*$/) {
2986                 # define it to mark the end of headers
2987                 $commit{message} = '';
2988                 next;
2989             }
2990             s/^\s+//; s/\s+$//; # trim ws
2991             $commit{message} .= $_ . "\n";
2992         }
2993     }
2994     close GITLOG;
2995
2996     unshift @commits, \%commit if ( keys %commit );
2997
2998     # Now all the commits are in the @commits bucket
2999     # ordered by time DESC. for each commit that needs processing,
3000     # determine whether it's following the last head we've seen or if
3001     # it's on its own branch, grab a file list, and add whatever's changed
3002     # NOTE: $lastcommit refers to the last commit from previous run
3003     #       $lastpicked is the last commit we picked in this run
3004     my $lastpicked;
3005     my $head = {};
3006     if (defined $lastcommit) {
3007         $lastpicked = $lastcommit;
3008     }
3009
3010     my $committotal = scalar(@commits);
3011     my $commitcount = 0;
3012
3013     # Load the head table into $head (for cached lookups during the update process)
3014     foreach my $file ( @{$self->gethead()} )
3015     {
3016         $head->{$file->{name}} = $file;
3017     }
3018
3019     foreach my $commit ( @commits )
3020     {
3021         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3022         if (defined $lastpicked)
3023         {
3024             if (!in_array($lastpicked, @{$commit->{parents}}))
3025             {
3026                 # skip, we'll see this delta
3027                 # as part of a merge later
3028                 # warn "skipping off-track  $commit->{hash}\n";
3029                 next;
3030             } elsif (@{$commit->{parents}} > 1) {
3031                 # it is a merge commit, for each parent that is
3032                 # not $lastpicked, see if we can get a log
3033                 # from the merge-base to that parent to put it
3034                 # in the message as a merge summary.
3035                 my @parents = @{$commit->{parents}};
3036                 foreach my $parent (@parents) {
3037                     # git-merge-base can potentially (but rarely) throw
3038                     # several candidate merge bases. let's assume
3039                     # that the first one is the best one.
3040                     if ($parent eq $lastpicked) {
3041                         next;
3042                     }
3043                     my $base = eval {
3044                             safe_pipe_capture('git', 'merge-base',
3045                                                  $lastpicked, $parent);
3046                     };
3047                     # The two branches may not be related at all,
3048                     # in which case merge base simply fails to find
3049                     # any, but that's Ok.
3050                     next if ($@);
3051
3052                     chomp $base;
3053                     if ($base) {
3054                         my @merged;
3055                         # print "want to log between  $base $parent \n";
3056                         open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3057                           or die "Cannot call git-log: $!";
3058                         my $mergedhash;
3059                         while (<GITLOG>) {
3060                             chomp;
3061                             if (!defined $mergedhash) {
3062                                 if (m/^commit\s+(.+)$/) {
3063                                     $mergedhash = $1;
3064                                 } else {
3065                                     next;
3066                                 }
3067                             } else {
3068                                 # grab the first line that looks non-rfc822
3069                                 # aka has content after leading space
3070                                 if (m/^\s+(\S.*)$/) {
3071                                     my $title = $1;
3072                                     $title = substr($title,0,100); # truncate
3073                                     unshift @merged, "$mergedhash $title";
3074                                     undef $mergedhash;
3075                                 }
3076                             }
3077                         }
3078                         close GITLOG;
3079                         if (@merged) {
3080                             $commit->{mergemsg} = $commit->{message};
3081                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3082                             foreach my $summary (@merged) {
3083                                 $commit->{mergemsg} .= "\t$summary\n";
3084                             }
3085                             $commit->{mergemsg} .= "\n\n";
3086                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3087                         }
3088                     }
3089                 }
3090             }
3091         }
3092
3093         # convert the date to CVS-happy format
3094         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3095
3096         if ( defined ( $lastpicked ) )
3097         {
3098             my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3099             local ($/) = "\0";
3100             while ( <FILELIST> )
3101             {
3102                 chomp;
3103                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3104                 {
3105                     die("Couldn't process git-diff-tree line : $_");
3106                 }
3107                 my ($mode, $hash, $change) = ($1, $2, $3);
3108                 my $name = <FILELIST>;
3109                 chomp($name);
3110
3111                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3112
3113                 my $git_perms = "";
3114                 $git_perms .= "r" if ( $mode & 4 );
3115                 $git_perms .= "w" if ( $mode & 2 );
3116                 $git_perms .= "x" if ( $mode & 1 );
3117                 $git_perms = "rw" if ( $git_perms eq "" );
3118
3119                 if ( $change eq "D" )
3120                 {
3121                     #$log->debug("DELETE   $name");
3122                     $head->{$name} = {
3123                         name => $name,
3124                         revision => $head->{$name}{revision} + 1,
3125                         filehash => "deleted",
3126                         commithash => $commit->{hash},
3127                         modified => $commit->{date},
3128                         author => $commit->{author},
3129                         mode => $git_perms,
3130                     };
3131                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3132                 }
3133                 elsif ( $change eq "M" || $change eq "T" )
3134                 {
3135                     #$log->debug("MODIFIED $name");
3136                     $head->{$name} = {
3137                         name => $name,
3138                         revision => $head->{$name}{revision} + 1,
3139                         filehash => $hash,
3140                         commithash => $commit->{hash},
3141                         modified => $commit->{date},
3142                         author => $commit->{author},
3143                         mode => $git_perms,
3144                     };
3145                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3146                 }
3147                 elsif ( $change eq "A" )
3148                 {
3149                     #$log->debug("ADDED    $name");
3150                     $head->{$name} = {
3151                         name => $name,
3152                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3153                         filehash => $hash,
3154                         commithash => $commit->{hash},
3155                         modified => $commit->{date},
3156                         author => $commit->{author},
3157                         mode => $git_perms,
3158                     };
3159                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3160                 }
3161                 else
3162                 {
3163                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3164                     die;
3165                 }
3166             }
3167             close FILELIST;
3168         } else {
3169             # this is used to detect files removed from the repo
3170             my $seen_files = {};
3171
3172             my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3173             local $/ = "\0";
3174             while ( <FILELIST> )
3175             {
3176                 chomp;
3177                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3178                 {
3179                     die("Couldn't process git-ls-tree line : $_");
3180                 }
3181
3182                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3183
3184                 $seen_files->{$git_filename} = 1;
3185
3186                 my ( $oldhash, $oldrevision, $oldmode ) = (
3187                     $head->{$git_filename}{filehash},
3188                     $head->{$git_filename}{revision},
3189                     $head->{$git_filename}{mode}
3190                 );
3191
3192                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3193                 {
3194                     $git_perms = "";
3195                     $git_perms .= "r" if ( $1 & 4 );
3196                     $git_perms .= "w" if ( $1 & 2 );
3197                     $git_perms .= "x" if ( $1 & 1 );
3198                 } else {
3199                     $git_perms = "rw";
3200                 }
3201
3202                 # unless the file exists with the same hash, we need to update it ...
3203                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3204                 {
3205                     my $newrevision = ( $oldrevision or 0 ) + 1;
3206
3207                     $head->{$git_filename} = {
3208                         name => $git_filename,
3209                         revision => $newrevision,
3210                         filehash => $git_hash,
3211                         commithash => $commit->{hash},
3212                         modified => $commit->{date},
3213                         author => $commit->{author},
3214                         mode => $git_perms,
3215                     };
3216
3217
3218                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3219                 }
3220             }
3221             close FILELIST;
3222
3223             # Detect deleted files
3224             foreach my $file ( keys %$head )
3225             {
3226                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3227                 {
3228                     $head->{$file}{revision}++;
3229                     $head->{$file}{filehash} = "deleted";
3230                     $head->{$file}{commithash} = $commit->{hash};
3231                     $head->{$file}{modified} = $commit->{date};
3232                     $head->{$file}{author} = $commit->{author};
3233
3234                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3235                 }
3236             }
3237             # END : "Detect deleted files"
3238         }
3239
3240
3241         if (exists $commit->{mergemsg})
3242         {
3243             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3244         }
3245
3246         $lastpicked = $commit->{hash};
3247
3248         $self->_set_prop("last_commit", $commit->{hash});
3249     }
3250
3251     $self->delete_head();
3252     foreach my $file ( keys %$head )
3253     {
3254         $self->insert_head(
3255             $file,
3256             $head->{$file}{revision},
3257             $head->{$file}{filehash},
3258             $head->{$file}{commithash},
3259             $head->{$file}{modified},
3260             $head->{$file}{author},
3261             $head->{$file}{mode},
3262         );
3263     }
3264     # invalidate the gethead cache
3265     $self->{gethead_cache} = undef;
3266
3267
3268     # Ending exclusive lock here
3269     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3270 }
3271
3272 sub insert_rev
3273 {
3274     my $self = shift;
3275     my $name = shift;
3276     my $revision = shift;
3277     my $filehash = shift;
3278     my $commithash = shift;
3279     my $modified = shift;
3280     my $author = shift;
3281     my $mode = shift;
3282     my $tablename = $self->tablename("revision");
3283
3284     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3285     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3286 }
3287
3288 sub insert_mergelog
3289 {
3290     my $self = shift;
3291     my $key = shift;
3292     my $value = shift;
3293     my $tablename = $self->tablename("commitmsgs");
3294
3295     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3296     $insert_mergelog->execute($key, $value);
3297 }
3298
3299 sub delete_head
3300 {
3301     my $self = shift;
3302     my $tablename = $self->tablename("head");
3303
3304     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3305     $delete_head->execute();
3306 }
3307
3308 sub insert_head
3309 {
3310     my $self = shift;
3311     my $name = shift;
3312     my $revision = shift;
3313     my $filehash = shift;
3314     my $commithash = shift;
3315     my $modified = shift;
3316     my $author = shift;
3317     my $mode = shift;
3318     my $tablename = $self->tablename("head");
3319
3320     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3321     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3322 }
3323
3324 sub _headrev
3325 {
3326     my $self = shift;
3327     my $filename = shift;
3328     my $tablename = $self->tablename("head");
3329
3330     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3331     $db_query->execute($filename);
3332     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3333
3334     return ( $hash, $revision, $mode );
3335 }
3336
3337 sub _get_prop
3338 {
3339     my $self = shift;
3340     my $key = shift;
3341     my $tablename = $self->tablename("properties");
3342
3343     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3344     $db_query->execute($key);
3345     my ( $value ) = $db_query->fetchrow_array;
3346
3347     return $value;
3348 }
3349
3350 sub _set_prop
3351 {
3352     my $self = shift;
3353     my $key = shift;
3354     my $value = shift;
3355     my $tablename = $self->tablename("properties");
3356
3357     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3358     $db_query->execute($value, $key);
3359
3360     unless ( $db_query->rows )
3361     {
3362         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3363         $db_query->execute($key, $value);
3364     }
3365
3366     return $value;
3367 }
3368
3369 =head2 gethead
3370
3371 =cut
3372
3373 sub gethead
3374 {
3375     my $self = shift;
3376     my $tablename = $self->tablename("head");
3377
3378     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3379
3380     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3381     $db_query->execute();
3382
3383     my $tree = [];
3384     while ( my $file = $db_query->fetchrow_hashref )
3385     {
3386         push @$tree, $file;
3387     }
3388
3389     $self->{gethead_cache} = $tree;
3390
3391     return $tree;
3392 }
3393
3394 =head2 getlog
3395
3396 =cut
3397
3398 sub getlog
3399 {
3400     my $self = shift;
3401     my $filename = shift;
3402     my $tablename = $self->tablename("revision");
3403
3404     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3405     $db_query->execute($filename);
3406
3407     my $tree = [];
3408     while ( my $file = $db_query->fetchrow_hashref )
3409     {
3410         push @$tree, $file;
3411     }
3412
3413     return $tree;
3414 }
3415
3416 =head2 getmeta
3417
3418 This function takes a filename (with path) argument and returns a hashref of
3419 metadata for that file.
3420
3421 =cut
3422
3423 sub getmeta
3424 {
3425     my $self = shift;
3426     my $filename = shift;
3427     my $revision = shift;
3428     my $tablename_rev = $self->tablename("revision");
3429     my $tablename_head = $self->tablename("head");
3430
3431     my $db_query;
3432     if ( defined($revision) and $revision =~ /^\d+$/ )
3433     {
3434         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3435         $db_query->execute($filename, $revision);
3436     }
3437     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3438     {
3439         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3440         $db_query->execute($filename, $revision);
3441     } else {
3442         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3443         $db_query->execute($filename);
3444     }
3445
3446     return $db_query->fetchrow_hashref;
3447 }
3448
3449 =head2 commitmessage
3450
3451 this function takes a commithash and returns the commit message for that commit
3452
3453 =cut
3454 sub commitmessage
3455 {
3456     my $self = shift;
3457     my $commithash = shift;
3458     my $tablename = $self->tablename("commitmsgs");
3459
3460     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3461
3462     my $db_query;
3463     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3464     $db_query->execute($commithash);
3465
3466     my ( $message ) = $db_query->fetchrow_array;
3467
3468     if ( defined ( $message ) )
3469     {
3470         $message .= " " if ( $message =~ /\n$/ );
3471         return $message;
3472     }
3473
3474     my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3475     shift @lines while ( $lines[0] =~ /\S/ );
3476     $message = join("",@lines);
3477     $message .= " " if ( $message =~ /\n$/ );
3478     return $message;
3479 }
3480
3481 =head2 gethistory
3482
3483 This function takes a filename (with path) argument and returns an arrayofarrays
3484 containing revision,filehash,commithash ordered by revision descending
3485
3486 =cut
3487 sub gethistory
3488 {
3489     my $self = shift;
3490     my $filename = shift;
3491     my $tablename = $self->tablename("revision");
3492
3493     my $db_query;
3494     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3495     $db_query->execute($filename);
3496
3497     return $db_query->fetchall_arrayref;
3498 }
3499
3500 =head2 gethistorydense
3501
3502 This function takes a filename (with path) argument and returns an arrayofarrays
3503 containing revision,filehash,commithash ordered by revision descending.
3504
3505 This version of gethistory skips deleted entries -- so it is useful for annotate.
3506 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3507 and other git tools that depend on it.
3508
3509 =cut
3510 sub gethistorydense
3511 {
3512     my $self = shift;
3513     my $filename = shift;
3514     my $tablename = $self->tablename("revision");
3515
3516     my $db_query;
3517     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3518     $db_query->execute($filename);
3519
3520     return $db_query->fetchall_arrayref;
3521 }
3522
3523 =head2 in_array()
3524
3525 from Array::PAT - mimics the in_array() function
3526 found in PHP. Yuck but works for small arrays.
3527
3528 =cut
3529 sub in_array
3530 {
3531     my ($check, @array) = @_;
3532     my $retval = 0;
3533     foreach my $test (@array){
3534         if($check eq $test){
3535             $retval =  1;
3536         }
3537     }
3538     return $retval;
3539 }
3540
3541 =head2 safe_pipe_capture
3542
3543 an alternative to `command` that allows input to be passed as an array
3544 to work around shell problems with weird characters in arguments
3545
3546 =cut
3547 sub safe_pipe_capture {
3548
3549     my @output;
3550
3551     if (my $pid = open my $child, '-|') {
3552         @output = (<$child>);
3553         close $child or die join(' ',@_).": $! $?";
3554     } else {
3555         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3556     }
3557     return wantarray ? @output : join('',@output);
3558 }
3559
3560 =head2 mangle_dirname
3561
3562 create a string from a directory name that is suitable to use as
3563 part of a filename, mainly by converting all chars except \w.- to _
3564
3565 =cut
3566 sub mangle_dirname {
3567     my $dirname = shift;
3568     return unless defined $dirname;
3569
3570     $dirname =~ s/[^\w.-]/_/g;
3571
3572     return $dirname;
3573 }
3574
3575 =head2 mangle_tablename
3576
3577 create a string from a that is suitable to use as part of an SQL table
3578 name, mainly by converting all chars except \w to _
3579
3580 =cut
3581 sub mangle_tablename {
3582     my $tablename = shift;
3583     return unless defined $tablename;
3584
3585     $tablename =~ s/[^\w_]/_/g;
3586
3587     return $tablename;
3588 }
3589
3590 1;