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