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