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