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 the local
2537 # part of the email address and replacing characters not in the Portable
2538 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2539 # Login names are Unix login names, which should be restricted to this
2540 # character set.
2541 sub cvs_author
2542 {
2543     my $author_line = shift;
2544     (my $author) = $author_line =~ /<([^@>]*)/;
2545
2546     $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2547     $author =~ s/^-/_/;
2548
2549     $author;
2550 }
2551
2552 package GITCVS::log;
2553
2554 ####
2555 #### Copyright The Open University UK - 2006.
2556 ####
2557 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2558 ####          Martin Langhoff <martin@catalyst.net.nz>
2559 ####
2560 ####
2561
2562 use strict;
2563 use warnings;
2564
2565 =head1 NAME
2566
2567 GITCVS::log
2568
2569 =head1 DESCRIPTION
2570
2571 This module provides very crude logging with a similar interface to
2572 Log::Log4perl
2573
2574 =head1 METHODS
2575
2576 =cut
2577
2578 =head2 new
2579
2580 Creates a new log object, optionally you can specify a filename here to
2581 indicate the file to log to. If no log file is specified, you can specify one
2582 later with method setfile, or indicate you no longer want logging with method
2583 nofile.
2584
2585 Until one of these methods is called, all log calls will buffer messages ready
2586 to write out.
2587
2588 =cut
2589 sub new
2590 {
2591     my $class = shift;
2592     my $filename = shift;
2593
2594     my $self = {};
2595
2596     bless $self, $class;
2597
2598     if ( defined ( $filename ) )
2599     {
2600         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2601     }
2602
2603     return $self;
2604 }
2605
2606 =head2 setfile
2607
2608 This methods takes a filename, and attempts to open that file as the log file.
2609 If successful, all buffered data is written out to the file, and any further
2610 logging is written directly to the file.
2611
2612 =cut
2613 sub setfile
2614 {
2615     my $self = shift;
2616     my $filename = shift;
2617
2618     if ( defined ( $filename ) )
2619     {
2620         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2621     }
2622
2623     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2624
2625     while ( my $line = shift @{$self->{buffer}} )
2626     {
2627         print {$self->{fh}} $line;
2628     }
2629 }
2630
2631 =head2 nofile
2632
2633 This method indicates no logging is going to be used. It flushes any entries in
2634 the internal buffer, and sets a flag to ensure no further data is put there.
2635
2636 =cut
2637 sub nofile
2638 {
2639     my $self = shift;
2640
2641     $self->{nolog} = 1;
2642
2643     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2644
2645     $self->{buffer} = [];
2646 }
2647
2648 =head2 _logopen
2649
2650 Internal method. Returns true if the log file is open, false otherwise.
2651
2652 =cut
2653 sub _logopen
2654 {
2655     my $self = shift;
2656
2657     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2658     return 0;
2659 }
2660
2661 =head2 debug info warn fatal
2662
2663 These four methods are wrappers to _log. They provide the actual interface for
2664 logging data.
2665
2666 =cut
2667 sub debug { my $self = shift; $self->_log("debug", @_); }
2668 sub info  { my $self = shift; $self->_log("info" , @_); }
2669 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2670 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2671
2672 =head2 _log
2673
2674 This is an internal method called by the logging functions. It generates a
2675 timestamp and pushes the logged line either to file, or internal buffer.
2676
2677 =cut
2678 sub _log
2679 {
2680     my $self = shift;
2681     my $level = shift;
2682
2683     return if ( $self->{nolog} );
2684
2685     my @time = localtime;
2686     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2687         $time[5] + 1900,
2688         $time[4] + 1,
2689         $time[3],
2690         $time[2],
2691         $time[1],
2692         $time[0],
2693         uc $level,
2694     );
2695
2696     if ( $self->_logopen )
2697     {
2698         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2699     } else {
2700         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2701     }
2702 }
2703
2704 =head2 DESTROY
2705
2706 This method simply closes the file handle if one is open
2707
2708 =cut
2709 sub DESTROY
2710 {
2711     my $self = shift;
2712
2713     if ( $self->_logopen )
2714     {
2715         close $self->{fh};
2716     }
2717 }
2718
2719 package GITCVS::updater;
2720
2721 ####
2722 #### Copyright The Open University UK - 2006.
2723 ####
2724 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2725 ####          Martin Langhoff <martin@catalyst.net.nz>
2726 ####
2727 ####
2728
2729 use strict;
2730 use warnings;
2731 use DBI;
2732
2733 =head1 METHODS
2734
2735 =cut
2736
2737 =head2 new
2738
2739 =cut
2740 sub new
2741 {
2742     my $class = shift;
2743     my $config = shift;
2744     my $module = shift;
2745     my $log = shift;
2746
2747     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2748     die "Need to specify a module" unless ( defined($module) );
2749
2750     $class = ref($class) || $class;
2751
2752     my $self = {};
2753
2754     bless $self, $class;
2755
2756     $self->{valid_tables} = {'revision' => 1,
2757                              'revision_ix1' => 1,
2758                              'revision_ix2' => 1,
2759                              'head' => 1,
2760                              'head_ix1' => 1,
2761                              'properties' => 1,
2762                              'commitmsgs' => 1};
2763
2764     $self->{module} = $module;
2765     $self->{git_path} = $config . "/";
2766
2767     $self->{log} = $log;
2768
2769     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2770
2771     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2772         $cfg->{gitcvs}{dbdriver} || "SQLite";
2773     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2774         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2775     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2776         $cfg->{gitcvs}{dbuser} || "";
2777     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2778         $cfg->{gitcvs}{dbpass} || "";
2779     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2780         $cfg->{gitcvs}{dbtablenameprefix} || "";
2781     my %mapping = ( m => $module,
2782                     a => $state->{method},
2783                     u => getlogin || getpwuid($<) || $<,
2784                     G => $self->{git_path},
2785                     g => mangle_dirname($self->{git_path}),
2786                     );
2787     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2788     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2789     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2790     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2791
2792     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2793     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2794     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2795                                 $self->{dbuser},
2796                                 $self->{dbpass});
2797     die "Error connecting to database\n" unless defined $self->{dbh};
2798
2799     $self->{tables} = {};
2800     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2801     {
2802         $self->{tables}{$table} = 1;
2803     }
2804
2805     # Construct the revision table if required
2806     unless ( $self->{tables}{$self->tablename("revision")} )
2807     {
2808         my $tablename = $self->tablename("revision");
2809         my $ix1name = $self->tablename("revision_ix1");
2810         my $ix2name = $self->tablename("revision_ix2");
2811         $self->{dbh}->do("
2812             CREATE TABLE $tablename (
2813                 name       TEXT NOT NULL,
2814                 revision   INTEGER NOT NULL,
2815                 filehash   TEXT NOT NULL,
2816                 commithash TEXT NOT NULL,
2817                 author     TEXT NOT NULL,
2818                 modified   TEXT NOT NULL,
2819                 mode       TEXT NOT NULL
2820             )
2821         ");
2822         $self->{dbh}->do("
2823             CREATE INDEX $ix1name
2824             ON $tablename (name,revision)
2825         ");
2826         $self->{dbh}->do("
2827             CREATE INDEX $ix2name
2828             ON $tablename (name,commithash)
2829         ");
2830     }
2831
2832     # Construct the head table if required
2833     unless ( $self->{tables}{$self->tablename("head")} )
2834     {
2835         my $tablename = $self->tablename("head");
2836         my $ix1name = $self->tablename("head_ix1");
2837         $self->{dbh}->do("
2838             CREATE TABLE $tablename (
2839                 name       TEXT NOT NULL,
2840                 revision   INTEGER NOT NULL,
2841                 filehash   TEXT NOT NULL,
2842                 commithash TEXT NOT NULL,
2843                 author     TEXT NOT NULL,
2844                 modified   TEXT NOT NULL,
2845                 mode       TEXT NOT NULL
2846             )
2847         ");
2848         $self->{dbh}->do("
2849             CREATE INDEX $ix1name
2850             ON $tablename (name)
2851         ");
2852     }
2853
2854     # Construct the properties table if required
2855     unless ( $self->{tables}{$self->tablename("properties")} )
2856     {
2857         my $tablename = $self->tablename("properties");
2858         $self->{dbh}->do("
2859             CREATE TABLE $tablename (
2860                 key        TEXT NOT NULL PRIMARY KEY,
2861                 value      TEXT
2862             )
2863         ");
2864     }
2865
2866     # Construct the commitmsgs table if required
2867     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2868     {
2869         my $tablename = $self->tablename("commitmsgs");
2870         $self->{dbh}->do("
2871             CREATE TABLE $tablename (
2872                 key        TEXT NOT NULL PRIMARY KEY,
2873                 value      TEXT
2874             )
2875         ");
2876     }
2877
2878     return $self;
2879 }
2880
2881 =head2 tablename
2882
2883 =cut
2884 sub tablename
2885 {
2886     my $self = shift;
2887     my $name = shift;
2888
2889     if (exists $self->{valid_tables}{$name}) {
2890         return $self->{dbtablenameprefix} . $name;
2891     } else {
2892         return undef;
2893     }
2894 }
2895
2896 =head2 update
2897
2898 =cut
2899 sub update
2900 {
2901     my $self = shift;
2902
2903     # first lets get the commit list
2904     $ENV{GIT_DIR} = $self->{git_path};
2905
2906     my $commitsha1 = `git rev-parse $self->{module}`;
2907     chomp $commitsha1;
2908
2909     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2910     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2911     {
2912         die("Invalid module '$self->{module}'");
2913     }
2914
2915
2916     my $git_log;
2917     my $lastcommit = $self->_get_prop("last_commit");
2918
2919     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2920          return 1;
2921     }
2922
2923     # Start exclusive lock here...
2924     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2925
2926     # TODO: log processing is memory bound
2927     # if we can parse into a 2nd file that is in reverse order
2928     # we can probably do something really efficient
2929     my @git_log_params = ('--pretty', '--parents', '--topo-order');
2930
2931     if (defined $lastcommit) {
2932         push @git_log_params, "$lastcommit..$self->{module}";
2933     } else {
2934         push @git_log_params, $self->{module};
2935     }
2936     # git-rev-list is the backend / plumbing version of git-log
2937     open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2938
2939     my @commits;
2940
2941     my %commit = ();
2942
2943     while ( <GITLOG> )
2944     {
2945         chomp;
2946         if (m/^commit\s+(.*)$/) {
2947             # on ^commit lines put the just seen commit in the stack
2948             # and prime things for the next one
2949             if (keys %commit) {
2950                 my %copy = %commit;
2951                 unshift @commits, \%copy;
2952                 %commit = ();
2953             }
2954             my @parents = split(m/\s+/, $1);
2955             $commit{hash} = shift @parents;
2956             $commit{parents} = \@parents;
2957         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2958             # on rfc822-like lines seen before we see any message,
2959             # lowercase the entry and put it in the hash as key-value
2960             $commit{lc($1)} = $2;
2961         } else {
2962             # message lines - skip initial empty line
2963             # and trim whitespace
2964             if (!exists($commit{message}) && m/^\s*$/) {
2965                 # define it to mark the end of headers
2966                 $commit{message} = '';
2967                 next;
2968             }
2969             s/^\s+//; s/\s+$//; # trim ws
2970             $commit{message} .= $_ . "\n";
2971         }
2972     }
2973     close GITLOG;
2974
2975     unshift @commits, \%commit if ( keys %commit );
2976
2977     # Now all the commits are in the @commits bucket
2978     # ordered by time DESC. for each commit that needs processing,
2979     # determine whether it's following the last head we've seen or if
2980     # it's on its own branch, grab a file list, and add whatever's changed
2981     # NOTE: $lastcommit refers to the last commit from previous run
2982     #       $lastpicked is the last commit we picked in this run
2983     my $lastpicked;
2984     my $head = {};
2985     if (defined $lastcommit) {
2986         $lastpicked = $lastcommit;
2987     }
2988
2989     my $committotal = scalar(@commits);
2990     my $commitcount = 0;
2991
2992     # Load the head table into $head (for cached lookups during the update process)
2993     foreach my $file ( @{$self->gethead()} )
2994     {
2995         $head->{$file->{name}} = $file;
2996     }
2997
2998     foreach my $commit ( @commits )
2999     {
3000         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3001         if (defined $lastpicked)
3002         {
3003             if (!in_array($lastpicked, @{$commit->{parents}}))
3004             {
3005                 # skip, we'll see this delta
3006                 # as part of a merge later
3007                 # warn "skipping off-track  $commit->{hash}\n";
3008                 next;
3009             } elsif (@{$commit->{parents}} > 1) {
3010                 # it is a merge commit, for each parent that is
3011                 # not $lastpicked, see if we can get a log
3012                 # from the merge-base to that parent to put it
3013                 # in the message as a merge summary.
3014                 my @parents = @{$commit->{parents}};
3015                 foreach my $parent (@parents) {
3016                     # git-merge-base can potentially (but rarely) throw
3017                     # several candidate merge bases. let's assume
3018                     # that the first one is the best one.
3019                     if ($parent eq $lastpicked) {
3020                         next;
3021                     }
3022                     my $base = eval {
3023                             safe_pipe_capture('git-merge-base',
3024                                                  $lastpicked, $parent);
3025                     };
3026                     # The two branches may not be related at all,
3027                     # in which case merge base simply fails to find
3028                     # any, but that's Ok.
3029                     next if ($@);
3030
3031                     chomp $base;
3032                     if ($base) {
3033                         my @merged;
3034                         # print "want to log between  $base $parent \n";
3035                         open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
3036                           or die "Cannot call git-log: $!";
3037                         my $mergedhash;
3038                         while (<GITLOG>) {
3039                             chomp;
3040                             if (!defined $mergedhash) {
3041                                 if (m/^commit\s+(.+)$/) {
3042                                     $mergedhash = $1;
3043                                 } else {
3044                                     next;
3045                                 }
3046                             } else {
3047                                 # grab the first line that looks non-rfc822
3048                                 # aka has content after leading space
3049                                 if (m/^\s+(\S.*)$/) {
3050                                     my $title = $1;
3051                                     $title = substr($title,0,100); # truncate
3052                                     unshift @merged, "$mergedhash $title";
3053                                     undef $mergedhash;
3054                                 }
3055                             }
3056                         }
3057                         close GITLOG;
3058                         if (@merged) {
3059                             $commit->{mergemsg} = $commit->{message};
3060                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3061                             foreach my $summary (@merged) {
3062                                 $commit->{mergemsg} .= "\t$summary\n";
3063                             }
3064                             $commit->{mergemsg} .= "\n\n";
3065                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3066                         }
3067                     }
3068                 }
3069             }
3070         }
3071
3072         # convert the date to CVS-happy format
3073         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3074
3075         if ( defined ( $lastpicked ) )
3076         {
3077             my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3078             local ($/) = "\0";
3079             while ( <FILELIST> )
3080             {
3081                 chomp;
3082                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3083                 {
3084                     die("Couldn't process git-diff-tree line : $_");
3085                 }
3086                 my ($mode, $hash, $change) = ($1, $2, $3);
3087                 my $name = <FILELIST>;
3088                 chomp($name);
3089
3090                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3091
3092                 my $git_perms = "";
3093                 $git_perms .= "r" if ( $mode & 4 );
3094                 $git_perms .= "w" if ( $mode & 2 );
3095                 $git_perms .= "x" if ( $mode & 1 );
3096                 $git_perms = "rw" if ( $git_perms eq "" );
3097
3098                 if ( $change eq "D" )
3099                 {
3100                     #$log->debug("DELETE   $name");
3101                     $head->{$name} = {
3102                         name => $name,
3103                         revision => $head->{$name}{revision} + 1,
3104                         filehash => "deleted",
3105                         commithash => $commit->{hash},
3106                         modified => $commit->{date},
3107                         author => $commit->{author},
3108                         mode => $git_perms,
3109                     };
3110                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3111                 }
3112                 elsif ( $change eq "M" || $change eq "T" )
3113                 {
3114                     #$log->debug("MODIFIED $name");
3115                     $head->{$name} = {
3116                         name => $name,
3117                         revision => $head->{$name}{revision} + 1,
3118                         filehash => $hash,
3119                         commithash => $commit->{hash},
3120                         modified => $commit->{date},
3121                         author => $commit->{author},
3122                         mode => $git_perms,
3123                     };
3124                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3125                 }
3126                 elsif ( $change eq "A" )
3127                 {
3128                     #$log->debug("ADDED    $name");
3129                     $head->{$name} = {
3130                         name => $name,
3131                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3132                         filehash => $hash,
3133                         commithash => $commit->{hash},
3134                         modified => $commit->{date},
3135                         author => $commit->{author},
3136                         mode => $git_perms,
3137                     };
3138                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3139                 }
3140                 else
3141                 {
3142                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3143                     die;
3144                 }
3145             }
3146             close FILELIST;
3147         } else {
3148             # this is used to detect files removed from the repo
3149             my $seen_files = {};
3150
3151             my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3152             local $/ = "\0";
3153             while ( <FILELIST> )
3154             {
3155                 chomp;
3156                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3157                 {
3158                     die("Couldn't process git-ls-tree line : $_");
3159                 }
3160
3161                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3162
3163                 $seen_files->{$git_filename} = 1;
3164
3165                 my ( $oldhash, $oldrevision, $oldmode ) = (
3166                     $head->{$git_filename}{filehash},
3167                     $head->{$git_filename}{revision},
3168                     $head->{$git_filename}{mode}
3169                 );
3170
3171                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3172                 {
3173                     $git_perms = "";
3174                     $git_perms .= "r" if ( $1 & 4 );
3175                     $git_perms .= "w" if ( $1 & 2 );
3176                     $git_perms .= "x" if ( $1 & 1 );
3177                 } else {
3178                     $git_perms = "rw";
3179                 }
3180
3181                 # unless the file exists with the same hash, we need to update it ...
3182                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3183                 {
3184                     my $newrevision = ( $oldrevision or 0 ) + 1;
3185
3186                     $head->{$git_filename} = {
3187                         name => $git_filename,
3188                         revision => $newrevision,
3189                         filehash => $git_hash,
3190                         commithash => $commit->{hash},
3191                         modified => $commit->{date},
3192                         author => $commit->{author},
3193                         mode => $git_perms,
3194                     };
3195
3196
3197                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3198                 }
3199             }
3200             close FILELIST;
3201
3202             # Detect deleted files
3203             foreach my $file ( keys %$head )
3204             {
3205                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3206                 {
3207                     $head->{$file}{revision}++;
3208                     $head->{$file}{filehash} = "deleted";
3209                     $head->{$file}{commithash} = $commit->{hash};
3210                     $head->{$file}{modified} = $commit->{date};
3211                     $head->{$file}{author} = $commit->{author};
3212
3213                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3214                 }
3215             }
3216             # END : "Detect deleted files"
3217         }
3218
3219
3220         if (exists $commit->{mergemsg})
3221         {
3222             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3223         }
3224
3225         $lastpicked = $commit->{hash};
3226
3227         $self->_set_prop("last_commit", $commit->{hash});
3228     }
3229
3230     $self->delete_head();
3231     foreach my $file ( keys %$head )
3232     {
3233         $self->insert_head(
3234             $file,
3235             $head->{$file}{revision},
3236             $head->{$file}{filehash},
3237             $head->{$file}{commithash},
3238             $head->{$file}{modified},
3239             $head->{$file}{author},
3240             $head->{$file}{mode},
3241         );
3242     }
3243     # invalidate the gethead cache
3244     $self->{gethead_cache} = undef;
3245
3246
3247     # Ending exclusive lock here
3248     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3249 }
3250
3251 sub insert_rev
3252 {
3253     my $self = shift;
3254     my $name = shift;
3255     my $revision = shift;
3256     my $filehash = shift;
3257     my $commithash = shift;
3258     my $modified = shift;
3259     my $author = shift;
3260     my $mode = shift;
3261     my $tablename = $self->tablename("revision");
3262
3263     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3264     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3265 }
3266
3267 sub insert_mergelog
3268 {
3269     my $self = shift;
3270     my $key = shift;
3271     my $value = shift;
3272     my $tablename = $self->tablename("commitmsgs");
3273
3274     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3275     $insert_mergelog->execute($key, $value);
3276 }
3277
3278 sub delete_head
3279 {
3280     my $self = shift;
3281     my $tablename = $self->tablename("head");
3282
3283     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3284     $delete_head->execute();
3285 }
3286
3287 sub insert_head
3288 {
3289     my $self = shift;
3290     my $name = shift;
3291     my $revision = shift;
3292     my $filehash = shift;
3293     my $commithash = shift;
3294     my $modified = shift;
3295     my $author = shift;
3296     my $mode = shift;
3297     my $tablename = $self->tablename("head");
3298
3299     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3300     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3301 }
3302
3303 sub _headrev
3304 {
3305     my $self = shift;
3306     my $filename = shift;
3307     my $tablename = $self->tablename("head");
3308
3309     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3310     $db_query->execute($filename);
3311     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3312
3313     return ( $hash, $revision, $mode );
3314 }
3315
3316 sub _get_prop
3317 {
3318     my $self = shift;
3319     my $key = shift;
3320     my $tablename = $self->tablename("properties");
3321
3322     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3323     $db_query->execute($key);
3324     my ( $value ) = $db_query->fetchrow_array;
3325
3326     return $value;
3327 }
3328
3329 sub _set_prop
3330 {
3331     my $self = shift;
3332     my $key = shift;
3333     my $value = shift;
3334     my $tablename = $self->tablename("properties");
3335
3336     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3337     $db_query->execute($value, $key);
3338
3339     unless ( $db_query->rows )
3340     {
3341         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3342         $db_query->execute($key, $value);
3343     }
3344
3345     return $value;
3346 }
3347
3348 =head2 gethead
3349
3350 =cut
3351
3352 sub gethead
3353 {
3354     my $self = shift;
3355     my $tablename = $self->tablename("head");
3356
3357     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3358
3359     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3360     $db_query->execute();
3361
3362     my $tree = [];
3363     while ( my $file = $db_query->fetchrow_hashref )
3364     {
3365         push @$tree, $file;
3366     }
3367
3368     $self->{gethead_cache} = $tree;
3369
3370     return $tree;
3371 }
3372
3373 =head2 getlog
3374
3375 =cut
3376
3377 sub getlog
3378 {
3379     my $self = shift;
3380     my $filename = shift;
3381     my $tablename = $self->tablename("revision");
3382
3383     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3384     $db_query->execute($filename);
3385
3386     my $tree = [];
3387     while ( my $file = $db_query->fetchrow_hashref )
3388     {
3389         push @$tree, $file;
3390     }
3391
3392     return $tree;
3393 }
3394
3395 =head2 getmeta
3396
3397 This function takes a filename (with path) argument and returns a hashref of
3398 metadata for that file.
3399
3400 =cut
3401
3402 sub getmeta
3403 {
3404     my $self = shift;
3405     my $filename = shift;
3406     my $revision = shift;
3407     my $tablename_rev = $self->tablename("revision");
3408     my $tablename_head = $self->tablename("head");
3409
3410     my $db_query;
3411     if ( defined($revision) and $revision =~ /^\d+$/ )
3412     {
3413         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3414         $db_query->execute($filename, $revision);
3415     }
3416     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3417     {
3418         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3419         $db_query->execute($filename, $revision);
3420     } else {
3421         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3422         $db_query->execute($filename);
3423     }
3424
3425     return $db_query->fetchrow_hashref;
3426 }
3427
3428 =head2 commitmessage
3429
3430 this function takes a commithash and returns the commit message for that commit
3431
3432 =cut
3433 sub commitmessage
3434 {
3435     my $self = shift;
3436     my $commithash = shift;
3437     my $tablename = $self->tablename("commitmsgs");
3438
3439     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3440
3441     my $db_query;
3442     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3443     $db_query->execute($commithash);
3444
3445     my ( $message ) = $db_query->fetchrow_array;
3446
3447     if ( defined ( $message ) )
3448     {
3449         $message .= " " if ( $message =~ /\n$/ );
3450         return $message;
3451     }
3452
3453     my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3454     shift @lines while ( $lines[0] =~ /\S/ );
3455     $message = join("",@lines);
3456     $message .= " " if ( $message =~ /\n$/ );
3457     return $message;
3458 }
3459
3460 =head2 gethistory
3461
3462 This function takes a filename (with path) argument and returns an arrayofarrays
3463 containing revision,filehash,commithash ordered by revision descending
3464
3465 =cut
3466 sub gethistory
3467 {
3468     my $self = shift;
3469     my $filename = shift;
3470     my $tablename = $self->tablename("revision");
3471
3472     my $db_query;
3473     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3474     $db_query->execute($filename);
3475
3476     return $db_query->fetchall_arrayref;
3477 }
3478
3479 =head2 gethistorydense
3480
3481 This function takes a filename (with path) argument and returns an arrayofarrays
3482 containing revision,filehash,commithash ordered by revision descending.
3483
3484 This version of gethistory skips deleted entries -- so it is useful for annotate.
3485 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3486 and other git tools that depend on it.
3487
3488 =cut
3489 sub gethistorydense
3490 {
3491     my $self = shift;
3492     my $filename = shift;
3493     my $tablename = $self->tablename("revision");
3494
3495     my $db_query;
3496     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3497     $db_query->execute($filename);
3498
3499     return $db_query->fetchall_arrayref;
3500 }
3501
3502 =head2 in_array()
3503
3504 from Array::PAT - mimics the in_array() function
3505 found in PHP. Yuck but works for small arrays.
3506
3507 =cut
3508 sub in_array
3509 {
3510     my ($check, @array) = @_;
3511     my $retval = 0;
3512     foreach my $test (@array){
3513         if($check eq $test){
3514             $retval =  1;
3515         }
3516     }
3517     return $retval;
3518 }
3519
3520 =head2 safe_pipe_capture
3521
3522 an alternative to `command` that allows input to be passed as an array
3523 to work around shell problems with weird characters in arguments
3524
3525 =cut
3526 sub safe_pipe_capture {
3527
3528     my @output;
3529
3530     if (my $pid = open my $child, '-|') {
3531         @output = (<$child>);
3532         close $child or die join(' ',@_).": $! $?";
3533     } else {
3534         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3535     }
3536     return wantarray ? @output : join('',@output);
3537 }
3538
3539 =head2 mangle_dirname
3540
3541 create a string from a directory name that is suitable to use as
3542 part of a filename, mainly by converting all chars except \w.- to _
3543
3544 =cut
3545 sub mangle_dirname {
3546     my $dirname = shift;
3547     return unless defined $dirname;
3548
3549     $dirname =~ s/[^\w.-]/_/g;
3550
3551     return $dirname;
3552 }
3553
3554 =head2 mangle_tablename
3555
3556 create a string from a that is suitable to use as part of an SQL table
3557 name, mainly by converting all chars except \w to _
3558
3559 =cut
3560 sub mangle_tablename {
3561     my $tablename = shift;
3562     return unless defined $tablename;
3563
3564     $tablename =~ s/[^\w_]/_/g;
3565
3566     return $tablename;
3567 }
3568
3569 1;