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

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