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