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