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