Andrew's git - gitweb.git/blob - git-cvsserver.perl

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