git.oblomov.eu Git - git/blob - git-cvsserver.perl

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