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