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