1#!/usr/local/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@laptop.org>
12####
13####
14#### Released under the GNU Public License, version 2.
15####
16####
17
18use 5.008;
19use strict;
20use warnings;
21use bytes;
22
23use Fcntl;
24use File::Temp qw/tempdir tempfile/;
25use File::Path qw/rmtree/;
26use File::Basename;
27use Getopt::Long qw(:config require_order no_ignore_case);
28
29my $VERSION = '@@GIT_VERSION@@';
30
31my $log = GITCVS::log->new();
32my $cfg;
33
34my $DATE_LIST = {
35    Jan => "01",
36    Feb => "02",
37    Mar => "03",
38    Apr => "04",
39    May => "05",
40    Jun => "06",
41    Jul => "07",
42    Aug => "08",
43    Sep => "09",
44    Oct => "10",
45    Nov => "11",
46    Dec => "12",
47};
48
49# Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50$| = 1;
51
52#### Definition and mappings of functions ####
53
54# NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented
55#  requests, this list is incomplete.  It is missing many rarer/optional
56#  requests.  Perhaps some clients require a claim of support for
57#  these specific requests for main functionality to work?
58my $methods = {
59    'Root'            => \&req_Root,
60    'Valid-responses' => \&req_Validresponses,
61    'valid-requests'  => \&req_validrequests,
62    'Directory'       => \&req_Directory,
63    'Sticky'          => \&req_Sticky,
64    'Entry'           => \&req_Entry,
65    'Modified'        => \&req_Modified,
66    'Unchanged'       => \&req_Unchanged,
67    'Questionable'    => \&req_Questionable,
68    'Argument'        => \&req_Argument,
69    'Argumentx'       => \&req_Argument,
70    'expand-modules'  => \&req_expandmodules,
71    'add'             => \&req_add,
72    'remove'          => \&req_remove,
73    'co'              => \&req_co,
74    'update'          => \&req_update,
75    'ci'              => \&req_ci,
76    'diff'            => \&req_diff,
77    'log'             => \&req_log,
78    'rlog'            => \&req_log,
79    'tag'             => \&req_CATCHALL,
80    'status'          => \&req_status,
81    'admin'           => \&req_CATCHALL,
82    'history'         => \&req_CATCHALL,
83    'watchers'        => \&req_EMPTY,
84    'editors'         => \&req_EMPTY,
85    'noop'            => \&req_EMPTY,
86    'annotate'        => \&req_annotate,
87    'Global_option'   => \&req_Globaloption,
88};
89
90##############################################
91
92
93# $state holds all the bits of information the clients sends us that could
94# potentially be useful when it comes to actually _doing_ something.
95my $state = { prependdir => '' };
96
97# Work is for managing temporary working directory
98my $work =
99    {
100        state => undef,  # undef, 1 (empty), 2 (with stuff)
101        workDir => undef,
102        index => undef,
103        emptyDir => undef,
104        tmpDir => undef
105    };
106
107$log->info("--------------- STARTING -----------------");
108
109my $usage =
110    "usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
111    "    --base-path <path>  : Prepend to requested CVSROOT\n".
112    "                          Can be read from GIT_CVSSERVER_BASE_PATH\n".
113    "    --strict-paths      : Don't allow recursing into subdirectories\n".
114    "    --export-all        : Don't check for gitcvs.enabled in config\n".
115    "    --version, -V       : Print version information and exit\n".
116    "    -h, -H              : Print usage information and exit\n".
117    "\n".
118    "<directory> ... is a list of allowed directories. If no directories\n".
119    "are given, all are allowed. This is an additional restriction, gitcvs\n".
120    "access still needs to be enabled by the gitcvs.enabled config option.\n".
121    "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
122
123my @opts = ( 'h|H', 'version|V',
124	     'base-path=s', 'strict-paths', 'export-all' );
125GetOptions( $state, @opts )
126    or die $usage;
127
128if ($state->{version}) {
129    print "git-cvsserver version $VERSION\n";
130    exit;
131}
132if ($state->{help}) {
133    print $usage;
134    exit;
135}
136
137my $TEMP_DIR = tempdir( CLEANUP => 1 );
138$log->debug("Temporary directory is '$TEMP_DIR'");
139
140$state->{method} = 'ext';
141if (@ARGV) {
142    if ($ARGV[0] eq 'pserver') {
143	$state->{method} = 'pserver';
144	shift @ARGV;
145    } elsif ($ARGV[0] eq 'server') {
146	shift @ARGV;
147    }
148}
149
150# everything else is a directory
151$state->{allowed_roots} = [ @ARGV ];
152
153# don't export the whole system unless the users requests it
154if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
155    die "--export-all can only be used together with an explicit whitelist\n";
156}
157
158# Environment handling for running under git-shell
159if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
160    if ($state->{'base-path'}) {
161	die "Cannot specify base path both ways.\n";
162    }
163    my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
164    $state->{'base-path'} = $base_path;
165    $log->debug("Picked up base path '$base_path' from environment.\n");
166}
167if (exists $ENV{GIT_CVSSERVER_ROOT}) {
168    if (@{$state->{allowed_roots}}) {
169	die "Cannot specify roots both ways: @ARGV\n";
170    }
171    my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
172    $state->{allowed_roots} = [ $allowed_root ];
173    $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
174}
175
176# if we are called with a pserver argument,
177# deal with the authentication cat before entering the
178# main loop
179if ($state->{method} eq 'pserver') {
180    my $line = <STDIN>; chomp $line;
181    unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
182       die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
183    }
184    my $request = $1;
185    $line = <STDIN>; chomp $line;
186    unless (req_Root('root', $line)) { # reuse Root
187       print "E Invalid root $line \n";
188       exit 1;
189    }
190    $line = <STDIN>; chomp $line;
191    my $user = $line;
192    $line = <STDIN>; chomp $line;
193    my $password = $line;
194
195    if ($user eq 'anonymous') {
196        # "A" will be 1 byte, use length instead in case the
197        # encryption method ever changes (yeah, right!)
198        if (length($password) > 1 ) {
199            print "E Don't supply a password for the `anonymous' user\n";
200            print "I HATE YOU\n";
201            exit 1;
202        }
203
204        # Fall through to LOVE
205    } else {
206        # Trying to authenticate a user
207        if (not exists $cfg->{gitcvs}->{authdb}) {
208            print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
209            print "I HATE YOU\n";
210            exit 1;
211        }
212
213        my $authdb = $cfg->{gitcvs}->{authdb};
214
215        unless (-e $authdb) {
216            print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
217            print "I HATE YOU\n";
218            exit 1;
219        }
220
221        my $auth_ok;
222        open my $passwd, "<", $authdb or die $!;
223        while (<$passwd>) {
224            if (m{^\Q$user\E:(.*)}) {
225                my $hash = crypt(descramble($password), $1);
226                if (defined $hash and $hash eq $1) {
227                    $auth_ok = 1;
228                }
229            }
230        }
231        close $passwd;
232
233        unless ($auth_ok) {
234            print "I HATE YOU\n";
235            exit 1;
236        }
237
238        # Fall through to LOVE
239    }
240
241    # For checking whether the user is anonymous on commit
242    $state->{user} = $user;
243
244    $line = <STDIN>; chomp $line;
245    unless ($line eq "END $request REQUEST") {
246       die "E Do not understand $line -- expecting END $request REQUEST\n";
247    }
248    print "I LOVE YOU\n";
249    exit if $request eq 'VERIFICATION'; # cvs login
250    # and now back to our regular programme...
251}
252
253# Keep going until the client closes the connection
254while (<STDIN>)
255{
256    chomp;
257
258    # Check to see if we've seen this method, and call appropriate function.
259    if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
260    {
261        # use the $methods hash to call the appropriate sub for this command
262        #$log->info("Method : $1");
263        &{$methods->{$1}}($1,$2);
264    } else {
265        # log fatal because we don't understand this function. If this happens
266        # we're fairly screwed because we don't know if the client is expecting
267        # a response. If it is, the client will hang, we'll hang, and the whole
268        # thing will be custard.
269        $log->fatal("Don't understand command $_\n");
270        die("Unknown command $_");
271    }
272}
273
274$log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
275$log->info("--------------- FINISH -----------------");
276
277chdir '/';
278exit 0;
279
280# Magic catchall method.
281#    This is the method that will handle all commands we haven't yet
282#    implemented. It simply sends a warning to the log file indicating a
283#    command that hasn't been implemented has been invoked.
284sub req_CATCHALL
285{
286    my ( $cmd, $data ) = @_;
287    $log->warn("Unhandled command : req_$cmd : $data");
288}
289
290# This method invariably succeeds with an empty response.
291sub req_EMPTY
292{
293    print "ok\n";
294}
295
296# Root pathname \n
297#     Response expected: no. Tell the server which CVSROOT to use. Note that
298#     pathname is a local directory and not a fully qualified CVSROOT variable.
299#     pathname must already exist; if creating a new root, use the init
300#     request, not Root. pathname does not include the hostname of the server,
301#     how to access the server, etc.; by the time the CVS protocol is in use,
302#     connection, authentication, etc., are already taken care of. The Root
303#     request must be sent only once, and it must be sent before any requests
304#     other than Valid-responses, valid-requests, UseUnchanged, Set or init.
305sub req_Root
306{
307    my ( $cmd, $data ) = @_;
308    $log->debug("req_Root : $data");
309
310    unless ($data =~ m#^/#) {
311	print "error 1 Root must be an absolute pathname\n";
312	return 0;
313    }
314
315    my $cvsroot = $state->{'base-path'} || '';
316    $cvsroot =~ s#/+$##;
317    $cvsroot .= $data;
318
319    if ($state->{CVSROOT}
320	&& ($state->{CVSROOT} ne $cvsroot)) {
321	print "error 1 Conflicting roots specified\n";
322	return 0;
323    }
324
325    $state->{CVSROOT} = $cvsroot;
326
327    $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
328
329    if (@{$state->{allowed_roots}}) {
330	my $allowed = 0;
331	foreach my $dir (@{$state->{allowed_roots}}) {
332	    next unless $dir =~ m#^/#;
333	    $dir =~ s#/+$##;
334	    if ($state->{'strict-paths'}) {
335		if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
336		    $allowed = 1;
337		    last;
338		}
339	    } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
340		$allowed = 1;
341		last;
342	    }
343	}
344
345	unless ($allowed) {
346	    print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
347	    print "E \n";
348	    print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
349	    return 0;
350	}
351    }
352
353    unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
354       print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
355       print "E \n";
356       print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
357       return 0;
358    }
359
360    my @gitvars = safe_pipe_capture(qw(git config -l));
361    if ($?) {
362       print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
363        print "E \n";
364        print "error 1 - problem executing git-config\n";
365       return 0;
366    }
367    foreach my $line ( @gitvars )
368    {
369        next unless ( $line =~ /^(gitcvs|extensions)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
370        unless ($2) {
371            $cfg->{$1}{$3} = $4;
372        } else {
373            $cfg->{$1}{$2}{$3} = $4;
374        }
375    }
376
377    my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
378		   || $cfg->{gitcvs}{enabled});
379    unless ($state->{'export-all'} ||
380	    ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
381        print "E GITCVS emulation needs to be enabled on this repo\n";
382        print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
383        print "E \n";
384        print "error 1 GITCVS emulation disabled\n";
385        return 0;
386    }
387
388    my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
389    if ( $logfile )
390    {
391        $log->setfile($logfile);
392    } else {
393        $log->nofile();
394    }
395
396    $state->{rawsz} = ($cfg->{'extensions'}{'objectformat'} || 'sha1') eq 'sha256' ? 32 : 20;
397    $state->{hexsz} = $state->{rawsz} * 2;
398
399    return 1;
400}
401
402# Global_option option \n
403#     Response expected: no. Transmit one of the global options `-q', `-Q',
404#     `-l', `-t', `-r', or `-n'. option must be one of those strings, no
405#     variations (such as combining of options) are allowed. For graceful
406#     handling of valid-requests, it is probably better to make new global
407#     options separate requests, rather than trying to add them to this
408#     request.
409sub req_Globaloption
410{
411    my ( $cmd, $data ) = @_;
412    $log->debug("req_Globaloption : $data");
413    $state->{globaloptions}{$data} = 1;
414}
415
416# Valid-responses request-list \n
417#     Response expected: no. Tell the server what responses the client will
418#     accept. request-list is a space separated list of tokens.
419sub req_Validresponses
420{
421    my ( $cmd, $data ) = @_;
422    $log->debug("req_Validresponses : $data");
423
424    # TODO : re-enable this, currently it's not particularly useful
425    #$state->{validresponses} = [ split /\s+/, $data ];
426}
427
428# valid-requests \n
429#     Response expected: yes. Ask the server to send back a Valid-requests
430#     response.
431sub req_validrequests
432{
433    my ( $cmd, $data ) = @_;
434
435    $log->debug("req_validrequests");
436
437    $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
438    $log->debug("SEND : ok");
439
440    print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
441    print "ok\n";
442}
443
444# Directory local-directory \n
445#     Additional data: repository \n. Response expected: no. Tell the server
446#     what directory to use. The repository should be a directory name from a
447#     previous server response. Note that this both gives a default for Entry
448#     and Modified and also for ci and the other commands; normal usage is to
449#     send Directory for each directory in which there will be an Entry or
450#     Modified, and then a final Directory for the original directory, then the
451#     command. The local-directory is relative to the top level at which the
452#     command is occurring (i.e. the last Directory which is sent before the
453#     command); to indicate that top level, `.' should be sent for
454#     local-directory.
455sub req_Directory
456{
457    my ( $cmd, $data ) = @_;
458
459    my $repository = <STDIN>;
460    chomp $repository;
461
462
463    $state->{localdir} = $data;
464    $state->{repository} = $repository;
465    $state->{path} = $repository;
466    $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
467    $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
468    $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
469
470    $state->{directory} = $state->{localdir};
471    $state->{directory} = "" if ( $state->{directory} eq "." );
472    $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
473
474    if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
475    {
476        $log->info("Setting prepend to '$state->{path}'");
477        $state->{prependdir} = $state->{path};
478        my %entries;
479        foreach my $entry ( keys %{$state->{entries}} )
480        {
481            $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry};
482        }
483        $state->{entries}=\%entries;
484
485        my %dirMap;
486        foreach my $dir ( keys %{$state->{dirMap}} )
487        {
488            $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir};
489        }
490        $state->{dirMap}=\%dirMap;
491    }
492
493    if ( defined ( $state->{prependdir} ) )
494    {
495        $log->debug("Prepending '$state->{prependdir}' to state|directory");
496        $state->{directory} = $state->{prependdir} . $state->{directory}
497    }
498
499    if ( ! defined($state->{dirMap}{$state->{directory}}) )
500    {
501        $state->{dirMap}{$state->{directory}} =
502            {
503                'names' => {}
504                #'tagspec' => undef
505            };
506    }
507
508    $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
509}
510
511# Sticky tagspec \n
512#     Response expected: no. Tell the server that the directory most
513#     recently specified with Directory has a sticky tag or date
514#     tagspec. The first character of tagspec is T for a tag, D for
515#     a date, or some other character supplied by a Set-sticky
516#     response from a previous request to the server. The remainder
517#     of tagspec contains the actual tag or date, again as supplied
518#     by Set-sticky.
519#          The server should remember Static-directory and Sticky requests
520#     for a particular directory; the client need not resend them each
521#     time it sends a Directory request for a given directory. However,
522#     the server is not obliged to remember them beyond the context
523#     of a single command.
524sub req_Sticky
525{
526    my ( $cmd, $tagspec ) = @_;
527
528    my ( $stickyInfo );
529    if($tagspec eq "")
530    {
531        # nothing
532    }
533    elsif($tagspec=~/^T([^ ]+)\s*$/)
534    {
535        $stickyInfo = { 'tag' => $1 };
536    }
537    elsif($tagspec=~/^D([0-9.]+)\s*$/)
538    {
539        $stickyInfo= { 'date' => $1 };
540    }
541    else
542    {
543        die "Unknown tag_or_date format\n";
544    }
545    $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo;
546
547    $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
548                . " path=$state->{path} directory=$state->{directory}"
549                . " module=$state->{module}");
550}
551
552# Entry entry-line \n
553#     Response expected: no. Tell the server what version of a file is on the
554#     local machine. The name in entry-line is a name relative to the directory
555#     most recently specified with Directory. If the user is operating on only
556#     some files in a directory, Entry requests for only those files need be
557#     included. If an Entry request is sent without Modified, Is-modified, or
558#     Unchanged, it means the file is lost (does not exist in the working
559#     directory). If both Entry and one of Modified, Is-modified, or Unchanged
560#     are sent for the same file, Entry must be sent first. For a given file,
561#     one can send Modified, Is-modified, or Unchanged, but not more than one
562#     of these three.
563sub req_Entry
564{
565    my ( $cmd, $data ) = @_;
566
567    #$log->debug("req_Entry : $data");
568
569    my @data = split(/\//, $data, -1);
570
571    $state->{entries}{$state->{directory}.$data[1]} = {
572        revision    => $data[2],
573        conflict    => $data[3],
574        options     => $data[4],
575        tag_or_date => $data[5],
576    };
577
578    $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F';
579
580    $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
581}
582
583# Questionable filename \n
584#     Response expected: no. Additional data: no. Tell the server to check
585#     whether filename should be ignored, and if not, next time the server
586#     sends responses, send (in a M response) `?' followed by the directory and
587#     filename. filename must not contain `/'; it needs to be a file in the
588#     directory named by the most recent Directory request.
589sub req_Questionable
590{
591    my ( $cmd, $data ) = @_;
592
593    $log->debug("req_Questionable : $data");
594    $state->{entries}{$state->{directory}.$data}{questionable} = 1;
595}
596
597# add \n
598#     Response expected: yes. Add a file or directory. This uses any previous
599#     Argument, Directory, Entry, or Modified requests, if they have been sent.
600#     The last Directory sent specifies the working directory at the time of
601#     the operation. To add a directory, send the directory to be added using
602#     Directory and Argument requests.
603sub req_add
604{
605    my ( $cmd, $data ) = @_;
606
607    argsplit("add");
608
609    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
610    $updater->update();
611
612    my $addcount = 0;
613
614    foreach my $filename ( @{$state->{args}} )
615    {
616        $filename = filecleanup($filename);
617
618        # no -r, -A, or -D with add
619        my $stickyInfo = resolveStickyInfo($filename);
620
621        my $meta = $updater->getmeta($filename,$stickyInfo);
622        my $wrev = revparse($filename);
623
624        if ($wrev && $meta && ($wrev=~/^-/))
625        {
626            # previously removed file, add back
627            $log->info("added file $filename was previously removed, send $meta->{revision}");
628
629            print "MT +updated\n";
630            print "MT text U \n";
631            print "MT fname $filename\n";
632            print "MT newline\n";
633            print "MT -updated\n";
634
635            unless ( $state->{globaloptions}{-n} )
636            {
637                my ( $filepart, $dirpart ) = filenamesplit($filename,1);
638
639                print "Created $dirpart\n";
640                print $state->{CVSROOT} . "/$state->{module}/$filename\n";
641
642                # this is an "entries" line
643                my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
644                my $entryLine = "/$filepart/$meta->{revision}//$kopts/";
645                $entryLine .= getStickyTagOrDate($stickyInfo);
646                $log->debug($entryLine);
647                print "$entryLine\n";
648                # permissions
649                $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
650                print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
651                # transmit file
652                transmitfile($meta->{filehash});
653            }
654
655            next;
656        }
657
658        unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
659        {
660            print "E cvs add: nothing known about `$filename'\n";
661            next;
662        }
663        # TODO : check we're not squashing an already existing file
664        if ( defined ( $state->{entries}{$filename}{revision} ) )
665        {
666            print "E cvs add: `$filename' has already been entered\n";
667            next;
668        }
669
670        my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
671
672        print "E cvs add: scheduling file `$filename' for addition\n";
673
674        print "Checked-in $dirpart\n";
675        print "$filename\n";
676        my $kopts = kopts_from_path($filename,"file",
677                        $state->{entries}{$filename}{modified_filename});
678        print "/$filepart/0//$kopts/" .
679              getStickyTagOrDate($stickyInfo) . "\n";
680
681        my $requestedKopts = $state->{opt}{k};
682        if(defined($requestedKopts))
683        {
684            $requestedKopts = "-k$requestedKopts";
685        }
686        else
687        {
688            $requestedKopts = "";
689        }
690        if( $kopts ne $requestedKopts )
691        {
692            $log->warn("Ignoring requested -k='$requestedKopts'"
693                        . " for '$filename'; detected -k='$kopts' instead");
694            #TODO: Also have option to send warning to user?
695        }
696
697        $addcount++;
698    }
699
700    if ( $addcount == 1 )
701    {
702        print "E cvs add: use `cvs commit' to add this file permanently\n";
703    }
704    elsif ( $addcount > 1 )
705    {
706        print "E cvs add: use `cvs commit' to add these files permanently\n";
707    }
708
709    print "ok\n";
710}
711
712# remove \n
713#     Response expected: yes. Remove a file. This uses any previous Argument,
714#     Directory, Entry, or Modified requests, if they have been sent. The last
715#     Directory sent specifies the working directory at the time of the
716#     operation. Note that this request does not actually do anything to the
717#     repository; the only effect of a successful remove request is to supply
718#     the client with a new entries line containing `-' to indicate a removed
719#     file. In fact, the client probably could perform this operation without
720#     contacting the server, although using remove may cause the server to
721#     perform a few more checks. The client sends a subsequent ci request to
722#     actually record the removal in the repository.
723sub req_remove
724{
725    my ( $cmd, $data ) = @_;
726
727    argsplit("remove");
728
729    # Grab a handle to the SQLite db and do any necessary updates
730    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
731    $updater->update();
732
733    #$log->debug("add state : " . Dumper($state));
734
735    my $rmcount = 0;
736
737    foreach my $filename ( @{$state->{args}} )
738    {
739        $filename = filecleanup($filename);
740
741        if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
742        {
743            print "E cvs remove: file `$filename' still in working directory\n";
744            next;
745        }
746
747        # only from entries
748        my $stickyInfo = resolveStickyInfo($filename);
749
750        my $meta = $updater->getmeta($filename,$stickyInfo);
751        my $wrev = revparse($filename);
752
753        unless ( defined ( $wrev ) )
754        {
755            print "E cvs remove: nothing known about `$filename'\n";
756            next;
757        }
758
759        if ( defined($wrev) and ($wrev=~/^-/) )
760        {
761            print "E cvs remove: file `$filename' already scheduled for removal\n";
762            next;
763        }
764
765        unless ( $wrev eq $meta->{revision} )
766        {
767            # TODO : not sure if the format of this message is quite correct.
768            print "E cvs remove: Up to date check failed for `$filename'\n";
769            next;
770        }
771
772
773        my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
774
775        print "E cvs remove: scheduling `$filename' for removal\n";
776
777        print "Checked-in $dirpart\n";
778        print "$filename\n";
779        my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
780        print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate($stickyInfo) . "\n";
781
782        $rmcount++;
783    }
784
785    if ( $rmcount == 1 )
786    {
787        print "E cvs remove: use `cvs commit' to remove this file permanently\n";
788    }
789    elsif ( $rmcount > 1 )
790    {
791        print "E cvs remove: use `cvs commit' to remove these files permanently\n";
792    }
793
794    print "ok\n";
795}
796
797# Modified filename \n
798#     Response expected: no. Additional data: mode, \n, file transmission. Send
799#     the server a copy of one locally modified file. filename is a file within
800#     the most recent directory sent with Directory; it must not contain `/'.
801#     If the user is operating on only some files in a directory, only those
802#     files need to be included. This can also be sent without Entry, if there
803#     is no entry for the file.
804sub req_Modified
805{
806    my ( $cmd, $data ) = @_;
807
808    my $mode = <STDIN>;
809    defined $mode
810        or (print "E end of file reading mode for $data\n"), return;
811    chomp $mode;
812    my $size = <STDIN>;
813    defined $size
814        or (print "E end of file reading size of $data\n"), return;
815    chomp $size;
816
817    # Grab config information
818    my $blocksize = 8192;
819    my $bytesleft = $size;
820    my $tmp;
821
822    # Get a filehandle/name to write it to
823    my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
824
825    # Loop over file data writing out to temporary file.
826    while ( $bytesleft )
827    {
828        $blocksize = $bytesleft if ( $bytesleft < $blocksize );
829        read STDIN, $tmp, $blocksize;
830        print $fh $tmp;
831        $bytesleft -= $blocksize;
832    }
833
834    close $fh
835        or (print "E failed to write temporary, $filename: $!\n"), return;
836
837    # Ensure we have something sensible for the file mode
838    if ( $mode =~ /u=(\w+)/ )
839    {
840        $mode = $1;
841    } else {
842        $mode = "rw";
843    }
844
845    # Save the file data in $state
846    $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
847    $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
848    $state->{entries}{$state->{directory}.$data}{modified_hash} = safe_pipe_capture('git','hash-object',$filename);
849    $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
850
851    #$log->debug("req_Modified : file=$data mode=$mode size=$size");
852}
853
854# Unchanged filename \n
855#     Response expected: no. Tell the server that filename has not been
856#     modified in the checked out directory. The filename is a file within the
857#     most recent directory sent with Directory; it must not contain `/'.
858sub req_Unchanged
859{
860    my ( $cmd, $data ) = @_;
861
862    $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
863
864    #$log->debug("req_Unchanged : $data");
865}
866
867# Argument text \n
868#     Response expected: no. Save argument for use in a subsequent command.
869#     Arguments accumulate until an argument-using command is given, at which
870#     point they are forgotten.
871# Argumentx text \n
872#     Response expected: no. Append \n followed by text to the current argument
873#     being saved.
874sub req_Argument
875{
876    my ( $cmd, $data ) = @_;
877
878    # Argumentx means: append to last Argument (with a newline in front)
879
880    $log->debug("$cmd : $data");
881
882    if ( $cmd eq 'Argumentx') {
883        ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
884    } else {
885        push @{$state->{arguments}}, $data;
886    }
887}
888
889# expand-modules \n
890#     Response expected: yes. Expand the modules which are specified in the
891#     arguments. Returns the data in Module-expansion responses. Note that the
892#     server can assume that this is checkout or export, not rtag or rdiff; the
893#     latter do not access the working directory and thus have no need to
894#     expand modules on the client side. Expand may not be the best word for
895#     what this request does. It does not necessarily tell you all the files
896#     contained in a module, for example. Basically it is a way of telling you
897#     which working directories the server needs to know about in order to
898#     handle a checkout of the specified modules. For example, suppose that the
899#     server has a module defined by
900#   aliasmodule -a 1dir
901#     That is, one can check out aliasmodule and it will take 1dir in the
902#     repository and check it out to 1dir in the working directory. Now suppose
903#     the client already has this module checked out and is planning on using
904#     the co request to update it. Without using expand-modules, the client
905#     would have two bad choices: it could either send information about all
906#     working directories under the current directory, which could be
907#     unnecessarily slow, or it could be ignorant of the fact that aliasmodule
908#     stands for 1dir, and neglect to send information for 1dir, which would
909#     lead to incorrect operation. With expand-modules, the client would first
910#     ask for the module to be expanded:
911sub req_expandmodules
912{
913    my ( $cmd, $data ) = @_;
914
915    argsplit();
916
917    $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
918
919    unless ( ref $state->{arguments} eq "ARRAY" )
920    {
921        print "ok\n";
922        return;
923    }
924
925    foreach my $module ( @{$state->{arguments}} )
926    {
927        $log->debug("SEND : Module-expansion $module");
928        print "Module-expansion $module\n";
929    }
930
931    print "ok\n";
932    statecleanup();
933}
934
935# co \n
936#     Response expected: yes. Get files from the repository. This uses any
937#     previous Argument, Directory, Entry, or Modified requests, if they have
938#     been sent. Arguments to this command are module names; the client cannot
939#     know what directories they correspond to except by (1) just sending the
940#     co request, and then seeing what directory names the server sends back in
941#     its responses, and (2) the expand-modules request.
942sub req_co
943{
944    my ( $cmd, $data ) = @_;
945
946    argsplit("co");
947
948    # Provide list of modules, if -c was used.
949    if (exists $state->{opt}{c}) {
950        my $showref = safe_pipe_capture(qw(git show-ref --heads));
951        for my $line (split '\n', $showref) {
952            if ( $line =~ m% refs/heads/(.*)$% ) {
953                print "M $1\t$1\n";
954            }
955        }
956        print "ok\n";
957        return 1;
958    }
959
960    my $stickyInfo = { 'tag' => $state->{opt}{r},
961                       'date' => $state->{opt}{D} };
962
963    my $module = $state->{args}[0];
964    $state->{module} = $module;
965    my $checkout_path = $module;
966
967    # use the user specified directory if we're given it
968    $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
969
970    $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
971
972    $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
973
974    $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
975
976    # Grab a handle to the SQLite db and do any necessary updates
977    my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
978    $updater->update();
979
980    my $headHash;
981    if( defined($stickyInfo) && defined($stickyInfo->{tag}) )
982    {
983        $headHash = $updater->lookupCommitRef($stickyInfo->{tag});
984        if( !defined($headHash) )
985        {
986            print "error 1 no such tag `$stickyInfo->{tag}'\n";
987            cleanupWorkTree();
988            exit;
989        }
990    }
991
992    $checkout_path =~ s|/$||; # get rid of trailing slashes
993
994    my %seendirs = ();
995    my $lastdir ='';
996
997    prepDirForOutput(
998            ".",
999            $state->{CVSROOT} . "/$module",
1000            $checkout_path,
1001            \%seendirs,
1002            'checkout',
1003            $state->{dirArgs} );
1004
1005    foreach my $git ( @{$updater->getAnyHead($headHash)} )
1006    {
1007        # Don't want to check out deleted files
1008        next if ( $git->{filehash} eq "deleted" );
1009
1010        my $fullName = $git->{name};
1011        ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
1012
1013        unless (exists($seendirs{$git->{dir}})) {
1014            prepDirForOutput($git->{dir}, $state->{CVSROOT} . "/$module/",
1015                             $checkout_path, \%seendirs, 'checkout',
1016                             $state->{dirArgs} );
1017            $lastdir = $git->{dir};
1018            $seendirs{$git->{dir}} = 1;
1019        }
1020
1021        # modification time of this file
1022        print "Mod-time $git->{modified}\n";
1023
1024        # print some information to the client
1025        if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
1026        {
1027            print "M U $checkout_path/$git->{dir}$git->{name}\n";
1028        } else {
1029            print "M U $checkout_path/$git->{name}\n";
1030        }
1031
1032       # instruct client we're sending a file to put in this path
1033       print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
1034
1035       print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
1036
1037        # this is an "entries" line
1038        my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
1039        print "/$git->{name}/$git->{revision}//$kopts/" .
1040                        getStickyTagOrDate($stickyInfo) . "\n";
1041        # permissions
1042        print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1043
1044        # transmit file
1045        transmitfile($git->{filehash});
1046    }
1047
1048    print "ok\n";
1049
1050    statecleanup();
1051}
1052
1053# used by req_co and req_update to set up directories for files
1054# recursively handles parents
1055sub prepDirForOutput
1056{
1057    my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
1058
1059    my $parent = dirname($dir);
1060    $dir       =~ s|/+$||;
1061    $repodir   =~ s|/+$||;
1062    $remotedir =~ s|/+$||;
1063    $parent    =~ s|/+$||;
1064
1065    if ($parent eq '.' || $parent eq './')
1066    {
1067        $parent = '';
1068    }
1069    # recurse to announce unseen parents first
1070    if( length($parent) &&
1071        !exists($seendirs->{$parent}) &&
1072        ( $request eq "checkout" ||
1073          exists($dirArgs->{$parent}) ) )
1074    {
1075        prepDirForOutput($parent, $repodir, $remotedir,
1076                         $seendirs, $request, $dirArgs);
1077    }
1078    # Announce that we are going to modify at the parent level
1079    if ($dir eq '.' || $dir eq './')
1080    {
1081        $dir = '';
1082    }
1083    if(exists($seendirs->{$dir}))
1084    {
1085        return;
1086    }
1087    $log->debug("announcedir $dir, $repodir, $remotedir" );
1088    my($thisRemoteDir,$thisRepoDir);
1089    if ($dir ne "")
1090    {
1091        $thisRepoDir="$repodir/$dir";
1092        if($remotedir eq ".")
1093        {
1094            $thisRemoteDir=$dir;
1095        }
1096        else
1097        {
1098            $thisRemoteDir="$remotedir/$dir";
1099        }
1100    }
1101    else
1102    {
1103        $thisRepoDir=$repodir;
1104        $thisRemoteDir=$remotedir;
1105    }
1106    unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1107    {
1108        print "E cvs $request: Updating $thisRemoteDir\n";
1109    }
1110
1111    my ($opt_r)=$state->{opt}{r};
1112    my $stickyInfo;
1113    if(exists($state->{opt}{A}))
1114    {
1115        # $stickyInfo=undef;
1116    }
1117    elsif( defined($opt_r) && $opt_r ne "" )
1118           # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
1119    {
1120        $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) };
1121
1122        # TODO: Convert -D value into the form 2011.04.10.04.46.57,
1123        #   similar to an entry line's sticky date, without the D prefix.
1124        #   It sometimes (always?) arrives as something more like
1125        #   '10 Apr 2011 04:46:57 -0000'...
1126        # $stickyInfo={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
1127    }
1128    else
1129    {
1130        $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir);
1131    }
1132
1133    my $stickyResponse;
1134    if(defined($stickyInfo))
1135    {
1136        $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
1137                          "$thisRepoDir/\n" .
1138                          getStickyTagOrDate($stickyInfo) . "\n";
1139    }
1140    else
1141    {
1142        $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
1143                          "$thisRepoDir/\n";
1144    }
1145
1146    unless ( $state->{globaloptions}{-n} )
1147    {
1148        print $stickyResponse;
1149
1150        print "Clear-static-directory $thisRemoteDir/\n";
1151        print "$thisRepoDir/\n";
1152        print $stickyResponse; # yes, twice
1153        print "Template $thisRemoteDir/\n";
1154        print "$thisRepoDir/\n";
1155        print "0\n";
1156    }
1157
1158    $seendirs->{$dir} = 1;
1159
1160    # FUTURE: This would more accurately emulate CVS by sending
1161    #   another copy of sticky after processing the files in that
1162    #   directory.  Or intermediate: perhaps send all sticky's for
1163    #   $seendirs after processing all files.
1164}
1165
1166# update \n
1167#     Response expected: yes. Actually do a cvs update command. This uses any
1168#     previous Argument, Directory, Entry, or Modified requests, if they have
1169#     been sent. The last Directory sent specifies the working directory at the
1170#     time of the operation. The -I option is not used--files which the client
1171#     can decide whether to ignore are not mentioned and the client sends the
1172#     Questionable request for others.
1173sub req_update
1174{
1175    my ( $cmd, $data ) = @_;
1176
1177    $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1178
1179    argsplit("update");
1180
1181    #
1182    # It may just be a client exploring the available heads/modules
1183    # in that case, list them as top level directories and leave it
1184    # at that. Eclipse uses this technique to offer you a list of
1185    # projects (heads in this case) to checkout.
1186    #
1187    if ($state->{module} eq '') {
1188        my $showref = safe_pipe_capture(qw(git show-ref --heads));
1189        print "E cvs update: Updating .\n";
1190        for my $line (split '\n', $showref) {
1191            if ( $line =~ m% refs/heads/(.*)$% ) {
1192                print "E cvs update: New directory `$1'\n";
1193            }
1194        }
1195        print "ok\n";
1196        return 1;
1197    }
1198
1199
1200    # Grab a handle to the SQLite db and do any necessary updates
1201    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1202
1203    $updater->update();
1204
1205    argsfromdir($updater);
1206
1207    #$log->debug("update state : " . Dumper($state));
1208
1209    my($repoDir);
1210    $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}";
1211
1212    my %seendirs = ();
1213
1214    # foreach file specified on the command line ...
1215    foreach my $argsFilename ( @{$state->{args}} )
1216    {
1217        my $filename;
1218        $filename = filecleanup($argsFilename);
1219
1220        $log->debug("Processing file $filename");
1221
1222        # if we have a -C we should pretend we never saw modified stuff
1223        if ( exists ( $state->{opt}{C} ) )
1224        {
1225            delete $state->{entries}{$filename}{modified_hash};
1226            delete $state->{entries}{$filename}{modified_filename};
1227            $state->{entries}{$filename}{unchanged} = 1;
1228        }
1229
1230        my $stickyInfo = resolveStickyInfo($filename,
1231                                           $state->{opt}{r},
1232                                           $state->{opt}{D},
1233                                           exists($state->{opt}{A}));
1234        my $meta = $updater->getmeta($filename, $stickyInfo);
1235
1236        # If -p was given, "print" the contents of the requested revision.
1237        if ( exists ( $state->{opt}{p} ) ) {
1238            if ( defined ( $meta->{revision} ) ) {
1239                $log->info("Printing '$filename' revision " . $meta->{revision});
1240
1241                transmitfile($meta->{filehash}, { print => 1 });
1242            }
1243
1244            next;
1245        }
1246
1247        # Directories:
1248        prepDirForOutput(
1249                dirname($argsFilename),
1250                $repoDir,
1251                ".",
1252                \%seendirs,
1253                "update",
1254                $state->{dirArgs} );
1255
1256        my $wrev = revparse($filename);
1257
1258	if ( ! defined $meta )
1259	{
1260	    $meta = {
1261	        name => $filename,
1262	        revision => '0',
1263	        filehash => 'added'
1264	    };
1265	    if($wrev ne "0")
1266	    {
1267	        $meta->{filehash}='deleted';
1268	    }
1269	}
1270
1271        my $oldmeta = $meta;
1272
1273        # If the working copy is an old revision, lets get that version too for comparison.
1274        my $oldWrev=$wrev;
1275        if(defined($oldWrev))
1276        {
1277            $oldWrev=~s/^-//;
1278            if($oldWrev ne $meta->{revision})
1279            {
1280                $oldmeta = $updater->getmeta($filename, $oldWrev);
1281            }
1282        }
1283
1284        #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1285
1286        # Files are up to date if the working copy and repo copy have the same revision,
1287        # and the working copy is unmodified _and_ the user hasn't specified -C
1288        next if ( defined ( $wrev )
1289                  and defined($meta->{revision})
1290                  and $wrev eq $meta->{revision}
1291                  and $state->{entries}{$filename}{unchanged}
1292                  and not exists ( $state->{opt}{C} ) );
1293
1294        # If the working copy and repo copy have the same revision,
1295        # but the working copy is modified, tell the client it's modified
1296        if ( defined ( $wrev )
1297             and defined($meta->{revision})
1298             and $wrev eq $meta->{revision}
1299             and $wrev ne "0"
1300             and defined($state->{entries}{$filename}{modified_hash})
1301             and not exists ( $state->{opt}{C} ) )
1302        {
1303            $log->info("Tell the client the file is modified");
1304            print "MT text M \n";
1305            print "MT fname $filename\n";
1306            print "MT newline\n";
1307            next;
1308        }
1309
1310        if ( $meta->{filehash} eq "deleted" && $wrev ne "0" )
1311        {
1312            # TODO: If it has been modified in the sandbox, error out
1313            #   with the appropriate message, rather than deleting a modified
1314            #   file.
1315
1316            my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1317
1318            $log->info("Removing '$filename' from working copy (no longer in the repo)");
1319
1320            print "E cvs update: `$filename' is no longer in the repository\n";
1321            # Don't want to actually _DO_ the update if -n specified
1322            unless ( $state->{globaloptions}{-n} ) {
1323		print "Removed $dirpart\n";
1324		print "$filepart\n";
1325	    }
1326        }
1327        elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1328		or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1329		or $meta->{filehash} eq 'added' )
1330        {
1331            # normal update, just send the new revision (either U=Update,
1332            # or A=Add, or R=Remove)
1333	    if ( defined($wrev) && ($wrev=~/^-/) )
1334	    {
1335	        $log->info("Tell the client the file is scheduled for removal");
1336		print "MT text R \n";
1337                print "MT fname $filename\n";
1338                print "MT newline\n";
1339		next;
1340	    }
1341	    elsif ( (!defined($wrev) || $wrev eq '0') &&
1342                    (!defined($meta->{revision}) || $meta->{revision} eq '0') )
1343	    {
1344	        $log->info("Tell the client the file is scheduled for addition");
1345		print "MT text A \n";
1346                print "MT fname $filename\n";
1347                print "MT newline\n";
1348		next;
1349
1350	    }
1351	    else {
1352                $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
1353                print "MT +updated\n";
1354                print "MT text U \n";
1355                print "MT fname $filename\n";
1356                print "MT newline\n";
1357		print "MT -updated\n";
1358	    }
1359
1360            my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1361
1362	    # Don't want to actually _DO_ the update if -n specified
1363	    unless ( $state->{globaloptions}{-n} )
1364	    {
1365		if ( defined ( $wrev ) )
1366		{
1367		    # instruct client we're sending a file to put in this path as a replacement
1368		    print "Update-existing $dirpart\n";
1369		    $log->debug("Updating existing file 'Update-existing $dirpart'");
1370		} else {
1371		    # instruct client we're sending a file to put in this path as a new file
1372
1373		    $log->debug("Creating new file 'Created $dirpart'");
1374		    print "Created $dirpart\n";
1375		}
1376		print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1377
1378		# this is an "entries" line
1379		my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1380                my $entriesLine = "/$filepart/$meta->{revision}//$kopts/";
1381                $entriesLine .= getStickyTagOrDate($stickyInfo);
1382		$log->debug($entriesLine);
1383		print "$entriesLine\n";
1384
1385		# permissions
1386		$log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1387		print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1388
1389		# transmit file
1390		transmitfile($meta->{filehash});
1391	    }
1392        } else {
1393            my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1394
1395            my $mergeDir = setupTmpDir();
1396
1397            my $file_local = $filepart . ".mine";
1398            my $mergedFile = "$mergeDir/$file_local";
1399            system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1400            my $file_old = $filepart . "." . $oldmeta->{revision};
1401            transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1402            my $file_new = $filepart . "." . $meta->{revision};
1403            transmitfile($meta->{filehash}, { targetfile => $file_new });
1404
1405            # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1406            $log->info("Merging $file_local, $file_old, $file_new");
1407            print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
1408
1409            $log->debug("Temporary directory for merge is $mergeDir");
1410
1411            my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1412            $return >>= 8;
1413
1414            cleanupTmpDir();
1415
1416            if ( $return == 0 )
1417            {
1418                $log->info("Merged successfully");
1419                print "M M $filename\n";
1420                $log->debug("Merged $dirpart");
1421
1422                # Don't want to actually _DO_ the update if -n specified
1423                unless ( $state->{globaloptions}{-n} )
1424                {
1425                    print "Merged $dirpart\n";
1426                    $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1427                    print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1428                    my $kopts = kopts_from_path("$dirpart/$filepart",
1429                                                "file",$mergedFile);
1430                    $log->debug("/$filepart/$meta->{revision}//$kopts/");
1431                    my $entriesLine="/$filepart/$meta->{revision}//$kopts/";
1432                    $entriesLine .= getStickyTagOrDate($stickyInfo);
1433                    print "$entriesLine\n";
1434                }
1435            }
1436            elsif ( $return == 1 )
1437            {
1438                $log->info("Merged with conflicts");
1439                print "E cvs update: conflicts found in $filename\n";
1440                print "M C $filename\n";
1441
1442                # Don't want to actually _DO_ the update if -n specified
1443                unless ( $state->{globaloptions}{-n} )
1444                {
1445                    print "Merged $dirpart\n";
1446                    print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1447                    my $kopts = kopts_from_path("$dirpart/$filepart",
1448                                                "file",$mergedFile);
1449                    my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/";
1450                    $entriesLine .= getStickyTagOrDate($stickyInfo);
1451                    print "$entriesLine\n";
1452                }
1453            }
1454            else
1455            {
1456                $log->warn("Merge failed");
1457                next;
1458            }
1459
1460            # Don't want to actually _DO_ the update if -n specified
1461            unless ( $state->{globaloptions}{-n} )
1462            {
1463                # permissions
1464                $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1465                print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1466
1467                # transmit file, format is single integer on a line by itself (file
1468                # size) followed by the file contents
1469                # TODO : we should copy files in blocks
1470                my $data = safe_pipe_capture('cat', $mergedFile);
1471                $log->debug("File size : " . length($data));
1472                print length($data) . "\n";
1473                print $data;
1474            }
1475        }
1476
1477    }
1478
1479    # prepDirForOutput() any other existing directories unless they already
1480    # have the right sticky tag:
1481    unless ( $state->{globaloptions}{n} )
1482    {
1483        my $dir;
1484        foreach $dir (keys(%{$state->{dirMap}}))
1485        {
1486            if( ! $seendirs{$dir} &&
1487                exists($state->{dirArgs}{$dir}) )
1488            {
1489                my($oldTag);
1490                $oldTag=$state->{dirMap}{$dir}{tagspec};
1491
1492                unless( ( exists($state->{opt}{A}) &&
1493                          defined($oldTag) ) ||
1494                          ( defined($state->{opt}{r}) &&
1495                            ( !defined($oldTag) ||
1496                              $state->{opt}{r} ne $oldTag ) ) )
1497                        # TODO?: OR sticky dir is different...
1498                {
1499                    next;
1500                }
1501
1502                prepDirForOutput(
1503                        $dir,
1504                        $repoDir,
1505                        ".",
1506                        \%seendirs,
1507                        'update',
1508                        $state->{dirArgs} );
1509            }
1510
1511            # TODO?: Consider sending a final duplicate Sticky response
1512            #   to more closely mimic real CVS.
1513        }
1514    }
1515
1516    print "ok\n";
1517}
1518
1519sub req_ci
1520{
1521    my ( $cmd, $data ) = @_;
1522
1523    argsplit("ci");
1524
1525    #$log->debug("State : " . Dumper($state));
1526
1527    $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1528
1529    if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1530    {
1531        print "error 1 anonymous user cannot commit via pserver\n";
1532        cleanupWorkTree();
1533        exit;
1534    }
1535
1536    if ( -e $state->{CVSROOT} . "/index" )
1537    {
1538        $log->warn("file 'index' already exists in the git repository");
1539        print "error 1 Index already exists in git repo\n";
1540        cleanupWorkTree();
1541        exit;
1542    }
1543
1544    # Grab a handle to the SQLite db and do any necessary updates
1545    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1546    $updater->update();
1547
1548    my @committedfiles = ();
1549    my %oldmeta;
1550    my $stickyInfo;
1551    my $branchRef;
1552    my $parenthash;
1553
1554    # foreach file specified on the command line ...
1555    foreach my $filename ( @{$state->{args}} )
1556    {
1557        my $committedfile = $filename;
1558        $filename = filecleanup($filename);
1559
1560        next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1561
1562        #####
1563        # Figure out which branch and parenthash we are committing
1564        # to, and setup worktree:
1565
1566        # should always come from entries:
1567        my $fileStickyInfo = resolveStickyInfo($filename);
1568        if( !defined($branchRef) )
1569        {
1570            $stickyInfo = $fileStickyInfo;
1571            if( defined($stickyInfo) &&
1572                ( defined($stickyInfo->{date}) ||
1573                  !defined($stickyInfo->{tag}) ) )
1574            {
1575                print "error 1 cannot commit with sticky date for file `$filename'\n";
1576                cleanupWorkTree();
1577                exit;
1578            }
1579
1580            $branchRef = "refs/heads/$state->{module}";
1581            if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1582            {
1583                $branchRef = "refs/heads/$stickyInfo->{tag}";
1584            }
1585
1586            $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef);
1587            chomp $parenthash;
1588            if ($parenthash !~ /^[0-9a-f]{$state->{hexsz}}$/)
1589            {
1590                if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1591                {
1592                    print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
1593                }
1594                else
1595                {
1596                    print "error 1 pserver cannot find the current HEAD of module";
1597                }
1598                cleanupWorkTree();
1599                exit;
1600            }
1601
1602            setupWorkTree($parenthash);
1603
1604            $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1605
1606            $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1607        }
1608        elsif( !refHashEqual($stickyInfo,$fileStickyInfo) )
1609        {
1610            #TODO: We could split the cvs commit into multiple
1611            #  git commits by distinct stickyTag values, but that
1612            #  is lowish priority.
1613            print "error 1 Committing different files to different"
1614                  . " branches is not currently supported\n";
1615            cleanupWorkTree();
1616            exit;
1617        }
1618
1619        #####
1620        # Process this file:
1621
1622        my $meta = $updater->getmeta($filename,$stickyInfo);
1623	$oldmeta{$filename} = $meta;
1624
1625        my $wrev = revparse($filename);
1626
1627        my ( $filepart, $dirpart ) = filenamesplit($filename);
1628
1629	# do a checkout of the file if it is part of this tree
1630        if ($wrev) {
1631            system('git', 'checkout-index', '-f', '-u', $filename);
1632            unless ($? == 0) {
1633                die "Error running git-checkout-index -f -u $filename : $!";
1634            }
1635        }
1636
1637        my $addflag = 0;
1638        my $rmflag = 0;
1639        $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1640        $addflag = 1 unless ( -e $filename );
1641
1642        # Do up to date checking
1643        unless ( $addflag or $wrev eq $meta->{revision} or
1644                 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
1645        {
1646            # fail everything if an up to date check fails
1647            print "error 1 Up to date check failed for $filename\n";
1648            cleanupWorkTree();
1649            exit;
1650        }
1651
1652        push @committedfiles, $committedfile;
1653        $log->info("Committing $filename");
1654
1655        system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1656
1657        unless ( $rmflag )
1658        {
1659            $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1660            rename $state->{entries}{$filename}{modified_filename},$filename;
1661
1662            # Calculate modes to remove
1663            my $invmode = "";
1664            foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1665
1666            $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1667            system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1668        }
1669
1670        if ( $rmflag )
1671        {
1672            $log->info("Removing file '$filename'");
1673            unlink($filename);
1674            system("git", "update-index", "--remove", $filename);
1675        }
1676        elsif ( $addflag )
1677        {
1678            $log->info("Adding file '$filename'");
1679            system("git", "update-index", "--add", $filename);
1680        } else {
1681            $log->info("UpdatingX2 file '$filename'");
1682            system("git", "update-index", $filename);
1683        }
1684    }
1685
1686    unless ( scalar(@committedfiles) > 0 )
1687    {
1688        print "E No files to commit\n";
1689        print "ok\n";
1690        cleanupWorkTree();
1691        return;
1692    }
1693
1694    my $treehash = safe_pipe_capture(qw(git write-tree));
1695    chomp $treehash;
1696
1697    $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1698
1699    # write our commit message out if we have one ...
1700    my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1701    print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1702    if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1703        if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1704            print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1705        }
1706    } else {
1707        print $msg_fh "\n\nvia git-CVS emulator\n";
1708    }
1709    close $msg_fh;
1710
1711    my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
1712    chomp($commithash);
1713    $log->info("Commit hash : $commithash");
1714
1715    unless ( $commithash =~ /[a-zA-Z0-9]{$state->{hexsz}}/ )
1716    {
1717        $log->warn("Commit failed (Invalid commit hash)");
1718        print "error 1 Commit failed (unknown reason)\n";
1719        cleanupWorkTree();
1720        exit;
1721    }
1722
1723	### Emulate git-receive-pack by running hooks/update
1724	my @hook = ( $ENV{GIT_DIR}.'hooks/update', $branchRef,
1725			$parenthash, $commithash );
1726	if( -x $hook[0] ) {
1727		unless( system( @hook ) == 0 )
1728		{
1729			$log->warn("Commit failed (update hook declined to update ref)");
1730			print "error 1 Commit failed (update hook declined)\n";
1731			cleanupWorkTree();
1732			exit;
1733		}
1734	}
1735
1736	### Update the ref
1737	if (system(qw(git update-ref -m), "cvsserver ci",
1738			$branchRef, $commithash, $parenthash)) {
1739		$log->warn("update-ref for $state->{module} failed.");
1740		print "error 1 Cannot commit -- update first\n";
1741		cleanupWorkTree();
1742		exit;
1743	}
1744
1745	### Emulate git-receive-pack by running hooks/post-receive
1746	my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1747	if( -x $hook ) {
1748		open(my $pipe, "| $hook") || die "can't fork $!";
1749
1750		local $SIG{PIPE} = sub { die 'pipe broke' };
1751
1752		print $pipe "$parenthash $commithash $branchRef\n";
1753
1754		close $pipe || die "bad pipe: $! $?";
1755	}
1756
1757    $updater->update();
1758
1759	### Then hooks/post-update
1760	$hook = $ENV{GIT_DIR}.'hooks/post-update';
1761	if (-x $hook) {
1762		system($hook, $branchRef);
1763	}
1764
1765    # foreach file specified on the command line ...
1766    foreach my $filename ( @committedfiles )
1767    {
1768        $filename = filecleanup($filename);
1769
1770        my $meta = $updater->getmeta($filename,$stickyInfo);
1771	unless (defined $meta->{revision}) {
1772	  $meta->{revision} = "1.1";
1773	}
1774
1775        my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1776
1777        $log->debug("Checked-in $dirpart : $filename");
1778
1779	print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1780        if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1781        {
1782            print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
1783            print "Remove-entry $dirpart\n";
1784            print "$filename\n";
1785        } else {
1786            if ($meta->{revision} eq "1.1") {
1787	        print "M initial revision: 1.1\n";
1788            } else {
1789	        print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
1790            }
1791            print "Checked-in $dirpart\n";
1792            print "$filename\n";
1793            my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1794            print "/$filepart/$meta->{revision}//$kopts/" .
1795                  getStickyTagOrDate($stickyInfo) . "\n";
1796        }
1797    }
1798
1799    cleanupWorkTree();
1800    print "ok\n";
1801}
1802
1803sub req_status
1804{
1805    my ( $cmd, $data ) = @_;
1806
1807    argsplit("status");
1808
1809    $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1810    #$log->debug("status state : " . Dumper($state));
1811
1812    # Grab a handle to the SQLite db and do any necessary updates
1813    my $updater;
1814    $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1815    $updater->update();
1816
1817    # if no files were specified, we need to work out what files we should
1818    # be providing status on ...
1819    argsfromdir($updater);
1820
1821    # foreach file specified on the command line ...
1822    foreach my $filename ( @{$state->{args}} )
1823    {
1824        $filename = filecleanup($filename);
1825
1826        if ( exists($state->{opt}{l}) &&
1827             index($filename, '/', length($state->{prependdir})) >= 0 )
1828        {
1829           next;
1830        }
1831
1832        my $wrev = revparse($filename);
1833
1834        my $stickyInfo = resolveStickyInfo($filename);
1835        my $meta = $updater->getmeta($filename,$stickyInfo);
1836        my $oldmeta = $meta;
1837
1838        # If the working copy is an old revision, lets get that
1839        # version too for comparison.
1840        if ( defined($wrev) and $wrev ne $meta->{revision} )
1841        {
1842            my($rmRev)=$wrev;
1843            $rmRev=~s/^-//;
1844            $oldmeta = $updater->getmeta($filename, $rmRev);
1845        }
1846
1847        # TODO : All possible statuses aren't yet implemented
1848        my $status;
1849        # Files are up to date if the working copy and repo copy have
1850        # the same revision, and the working copy is unmodified
1851        if ( defined ( $wrev ) and defined($meta->{revision}) and
1852             $wrev eq $meta->{revision} and
1853             ( ( $state->{entries}{$filename}{unchanged} and
1854                 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1855                   $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1856               ( defined($state->{entries}{$filename}{modified_hash}) and
1857                 $state->{entries}{$filename}{modified_hash} eq
1858                        $meta->{filehash} ) ) )
1859        {
1860            $status = "Up-to-date"
1861        }
1862
1863        # Need checkout if the working copy has a different (usually
1864        # older) revision than the repo copy, and the working copy is
1865        # unmodified
1866        if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1867             $meta->{revision} ne $wrev and
1868             ( $state->{entries}{$filename}{unchanged} or
1869               ( defined($state->{entries}{$filename}{modified_hash}) and
1870                 $state->{entries}{$filename}{modified_hash} eq
1871                                $oldmeta->{filehash} ) ) )
1872        {
1873            $status ||= "Needs Checkout";
1874        }
1875
1876        # Need checkout if it exists in the repo but doesn't have a working
1877        # copy
1878        if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
1879        {
1880            $status ||= "Needs Checkout";
1881        }
1882
1883        # Locally modified if working copy and repo copy have the
1884        # same revision but there are local changes
1885        if ( defined ( $wrev ) and defined($meta->{revision}) and
1886             $wrev eq $meta->{revision} and
1887             $wrev ne "0" and
1888             $state->{entries}{$filename}{modified_filename} )
1889        {
1890            $status ||= "Locally Modified";
1891        }
1892
1893        # Needs Merge if working copy revision is different
1894        # (usually older) than repo copy and there are local changes
1895        if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1896             $meta->{revision} ne $wrev and
1897             $state->{entries}{$filename}{modified_filename} )
1898        {
1899            $status ||= "Needs Merge";
1900        }
1901
1902        if ( defined ( $state->{entries}{$filename}{revision} ) and
1903             ( !defined($meta->{revision}) ||
1904               $meta->{revision} eq "0" ) )
1905        {
1906            $status ||= "Locally Added";
1907        }
1908        if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1909             $wrev eq "-$meta->{revision}" )
1910        {
1911            $status ||= "Locally Removed";
1912        }
1913        if ( defined ( $state->{entries}{$filename}{conflict} ) and
1914             $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1915        {
1916            $status ||= "Unresolved Conflict";
1917        }
1918        if ( 0 )
1919        {
1920            $status ||= "File had conflicts on merge";
1921        }
1922
1923        $status ||= "Unknown";
1924
1925        my ($filepart) = filenamesplit($filename);
1926
1927        print "M =======" . ( "=" x 60 ) . "\n";
1928        print "M File: $filepart\tStatus: $status\n";
1929        if ( defined($state->{entries}{$filename}{revision}) )
1930        {
1931            print "M Working revision:\t" .
1932                  $state->{entries}{$filename}{revision} . "\n";
1933        } else {
1934            print "M Working revision:\tNo entry for $filename\n";
1935        }
1936        if ( defined($meta->{revision}) )
1937        {
1938            print "M Repository revision:\t" .
1939                   $meta->{revision} .
1940                   "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1941            my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
1942            my($tag)=($tagOrDate=~m/^T(.+)$/);
1943            if( !defined($tag) )
1944            {
1945                $tag="(none)";
1946            }
1947            print "M Sticky Tag:\t\t$tag\n";
1948            my($date)=($tagOrDate=~m/^D(.+)$/);
1949            if( !defined($date) )
1950            {
1951                $date="(none)";
1952            }
1953            print "M Sticky Date:\t\t$date\n";
1954            my($options)=$state->{entries}{$filename}{options};
1955            if( $options eq "" )
1956            {
1957                $options="(none)";
1958            }
1959            print "M Sticky Options:\t\t$options\n";
1960        } else {
1961            print "M Repository revision:\tNo revision control file\n";
1962        }
1963        print "M\n";
1964    }
1965
1966    print "ok\n";
1967}
1968
1969sub req_diff
1970{
1971    my ( $cmd, $data ) = @_;
1972
1973    argsplit("diff");
1974
1975    $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1976    #$log->debug("status state : " . Dumper($state));
1977
1978    my ($revision1, $revision2);
1979    if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1980    {
1981        $revision1 = $state->{opt}{r}[0];
1982        $revision2 = $state->{opt}{r}[1];
1983    } else {
1984        $revision1 = $state->{opt}{r};
1985    }
1986
1987    $log->debug("Diffing revisions " .
1988                ( defined($revision1) ? $revision1 : "[NULL]" ) .
1989                " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1990
1991    # Grab a handle to the SQLite db and do any necessary updates
1992    my $updater;
1993    $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1994    $updater->update();
1995
1996    # if no files were specified, we need to work out what files we should
1997    # be providing status on ...
1998    argsfromdir($updater);
1999
2000    my($foundDiff);
2001
2002    # foreach file specified on the command line ...
2003    foreach my $argFilename ( @{$state->{args}} )
2004    {
2005        my($filename) = filecleanup($argFilename);
2006
2007        my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
2008
2009        my $wrev = revparse($filename);
2010
2011        # Priority for revision1:
2012        #  1. First -r (missing file: check -N)
2013        #  2. wrev from client's Entry line
2014        #      - missing line/file: check -N
2015        #      - "0": added file not committed (empty contents for rev1)
2016        #      - Prefixed with dash (to be removed): check -N
2017
2018        if ( defined ( $revision1 ) )
2019        {
2020            $meta1 = $updater->getmeta($filename, $revision1);
2021        }
2022        elsif( defined($wrev) && $wrev ne "0" )
2023        {
2024            my($rmRev)=$wrev;
2025            $rmRev=~s/^-//;
2026            $meta1 = $updater->getmeta($filename, $rmRev);
2027        }
2028        if ( !defined($meta1) ||
2029             $meta1->{filehash} eq "deleted" )
2030        {
2031            if( !exists($state->{opt}{N}) )
2032            {
2033                if(!defined($revision1))
2034                {
2035                    print "E File $filename at revision $revision1 doesn't exist\n";
2036                }
2037                next;
2038            }
2039            elsif( !defined($meta1) )
2040            {
2041                $meta1 = {
2042                    name => $filename,
2043                    revision => '0',
2044                    filehash => 'deleted'
2045                };
2046            }
2047        }
2048
2049        # Priority for revision2:
2050        #  1. Second -r (missing file: check -N)
2051        #  2. Modified file contents from client
2052        #  3. wrev from client's Entry line
2053        #      - missing line/file: check -N
2054        #      - Prefixed with dash (to be removed): check -N
2055
2056        # if we have a second -r switch, use it too
2057        if ( defined ( $revision2 ) )
2058        {
2059            $meta2 = $updater->getmeta($filename, $revision2);
2060        }
2061        elsif(defined($state->{entries}{$filename}{modified_filename}))
2062        {
2063            $file2 = $state->{entries}{$filename}{modified_filename};
2064	    $meta2 = {
2065                name => $filename,
2066	        revision => '0',
2067	        filehash => 'modified'
2068            };
2069        }
2070        elsif( defined($wrev) && ($wrev!~/^-/) )
2071        {
2072            if(!defined($revision1))  # no revision and no modifications:
2073            {
2074                next;
2075            }
2076            $meta2 = $updater->getmeta($filename, $wrev);
2077        }
2078        if(!defined($file2))
2079        {
2080            if ( !defined($meta2) ||
2081                 $meta2->{filehash} eq "deleted" )
2082            {
2083                if( !exists($state->{opt}{N}) )
2084                {
2085                    if(!defined($revision2))
2086                    {
2087                        print "E File $filename at revision $revision2 doesn't exist\n";
2088                    }
2089                    next;
2090                }
2091                elsif( !defined($meta2) )
2092                {
2093	            $meta2 = {
2094                        name => $filename,
2095	                revision => '0',
2096	                filehash => 'deleted'
2097                    };
2098                }
2099            }
2100        }
2101
2102        if( $meta1->{filehash} eq $meta2->{filehash} )
2103        {
2104            $log->info("unchanged $filename");
2105            next;
2106        }
2107
2108        # Retrieve revision contents:
2109        ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2110        transmitfile($meta1->{filehash}, { targetfile => $file1 });
2111
2112        if(!defined($file2))
2113        {
2114            ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2115            transmitfile($meta2->{filehash}, { targetfile => $file2 });
2116        }
2117
2118        # Generate the actual diff:
2119        print "M Index: $argFilename\n";
2120        print "M =======" . ( "=" x 60 ) . "\n";
2121        print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2122        if ( defined ( $meta1 ) && $meta1->{revision} ne "0" )
2123        {
2124            print "M retrieving revision $meta1->{revision}\n"
2125        }
2126        if ( defined ( $meta2 ) && $meta2->{revision} ne "0" )
2127        {
2128            print "M retrieving revision $meta2->{revision}\n"
2129        }
2130        print "M diff ";
2131        foreach my $opt ( sort keys %{$state->{opt}} )
2132        {
2133            if ( ref $state->{opt}{$opt} eq "ARRAY" )
2134            {
2135                foreach my $value ( @{$state->{opt}{$opt}} )
2136                {
2137                    print "-$opt $value ";
2138                }
2139            } else {
2140                print "-$opt ";
2141                if ( defined ( $state->{opt}{$opt} ) )
2142                {
2143                    print "$state->{opt}{$opt} "
2144                }
2145            }
2146        }
2147        print "$argFilename\n";
2148
2149        $log->info("Diffing $filename -r $meta1->{revision} -r " .
2150                   ( $meta2->{revision} or "workingcopy" ));
2151
2152        # TODO: Use --label instead of -L because -L is no longer
2153        #  documented and may go away someday.  Not sure if there are
2154        #  versions that only support -L, which would make this change risky?
2155        #  http://osdir.com/ml/bug-gnu-utils-gnu/2010-12/msg00060.html
2156        #    ("man diff" should actually document the best migration strategy,
2157        #  [current behavior, future changes, old compatibility issues
2158        #  or lack thereof, etc], not just stop mentioning the option...)
2159        # TODO: Real CVS seems to include a date in the label, before
2160        #  the revision part, without the keyword "revision".  The following
2161        #  has minimal changes compared to original versions of
2162        #  git-cvsserver.perl.  (Mostly tab vs space after filename.)
2163
2164        my (@diffCmd) = ( 'diff' );
2165        if ( exists($state->{opt}{N}) )
2166        {
2167            push @diffCmd,"-N";
2168        }
2169        if ( exists $state->{opt}{u} )
2170        {
2171            push @diffCmd,("-u","-L");
2172            if( $meta1->{filehash} eq "deleted" )
2173            {
2174                push @diffCmd,"/dev/null";
2175            } else {
2176                push @diffCmd,("$argFilename\trevision $meta1->{revision}");
2177            }
2178
2179            if( defined($meta2->{filehash}) )
2180            {
2181                if( $meta2->{filehash} eq "deleted" )
2182                {
2183                    push @diffCmd,("-L","/dev/null");
2184                } else {
2185                    push @diffCmd,("-L",
2186                                   "$argFilename\trevision $meta2->{revision}");
2187                }
2188            } else {
2189                push @diffCmd,("-L","$argFilename\tworking copy");
2190            }
2191        }
2192        push @diffCmd,($file1,$file2);
2193        if(!open(DIFF,"-|",@diffCmd))
2194        {
2195            $log->warn("Unable to run diff: $!");
2196        }
2197        my($diffLine);
2198        while(defined($diffLine=<DIFF>))
2199        {
2200            print "M $diffLine";
2201            $foundDiff=1;
2202        }
2203        close(DIFF);
2204    }
2205
2206    if($foundDiff)
2207    {
2208        print "error  \n";
2209    }
2210    else
2211    {
2212        print "ok\n";
2213    }
2214}
2215
2216sub req_log
2217{
2218    my ( $cmd, $data ) = @_;
2219
2220    argsplit("log");
2221
2222    $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
2223    #$log->debug("log state : " . Dumper($state));
2224
2225    my ( $revFilter );
2226    if ( defined ( $state->{opt}{r} ) )
2227    {
2228        $revFilter = $state->{opt}{r};
2229    }
2230
2231    # Grab a handle to the SQLite db and do any necessary updates
2232    my $updater;
2233    $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
2234    $updater->update();
2235
2236    # if no files were specified, we need to work out what files we
2237    # should be providing status on ...
2238    argsfromdir($updater);
2239
2240    # foreach file specified on the command line ...
2241    foreach my $filename ( @{$state->{args}} )
2242    {
2243        $filename = filecleanup($filename);
2244
2245        my $headmeta = $updater->getmeta($filename);
2246
2247        my ($revisions,$totalrevisions) = $updater->getlog($filename,
2248                                                           $revFilter);
2249
2250        next unless ( scalar(@$revisions) );
2251
2252        print "M \n";
2253        print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2254        print "M Working file: $filename\n";
2255        print "M head: $headmeta->{revision}\n";
2256        print "M branch:\n";
2257        print "M locks: strict\n";
2258        print "M access list:\n";
2259        print "M symbolic names:\n";
2260        print "M keyword substitution: kv\n";
2261        print "M total revisions: $totalrevisions;\tselected revisions: " .
2262              scalar(@$revisions) . "\n";
2263        print "M description:\n";
2264
2265        foreach my $revision ( @$revisions )
2266        {
2267            print "M ----------------------------\n";
2268            print "M revision $revision->{revision}\n";
2269            # reformat the date for log output
2270            if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
2271                 defined($DATE_LIST->{$2}) )
2272            {
2273                $revision->{modified} = sprintf('%04d/%02d/%02d %s',
2274                                            $3, $DATE_LIST->{$2}, $1, $4 );
2275            }
2276            $revision->{author} = cvs_author($revision->{author});
2277            print "M date: $revision->{modified};" .
2278                  "  author: $revision->{author};  state: " .
2279                  ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
2280                  ";  lines: +2 -3\n";
2281            my $commitmessage;
2282            $commitmessage = $updater->commitmessage($revision->{commithash});
2283            $commitmessage =~ s/^/M /mg;
2284            print $commitmessage . "\n";
2285        }
2286        print "M =======" . ( "=" x 70 ) . "\n";
2287    }
2288
2289    print "ok\n";
2290}
2291
2292sub req_annotate
2293{
2294    my ( $cmd, $data ) = @_;
2295
2296    argsplit("annotate");
2297
2298    $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
2299    #$log->debug("status state : " . Dumper($state));
2300
2301    # Grab a handle to the SQLite db and do any necessary updates
2302    my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
2303    $updater->update();
2304
2305    # if no files were specified, we need to work out what files we should be providing annotate on ...
2306    argsfromdir($updater);
2307
2308    # we'll need a temporary checkout dir
2309    setupWorkTree();
2310
2311    $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
2312
2313    # foreach file specified on the command line ...
2314    foreach my $filename ( @{$state->{args}} )
2315    {
2316        $filename = filecleanup($filename);
2317
2318        my $meta = $updater->getmeta($filename);
2319
2320        next unless ( $meta->{revision} );
2321
2322	# get all the commits that this file was in
2323	# in dense format -- aka skip dead revisions
2324        my $revisions   = $updater->gethistorydense($filename);
2325	my $lastseenin  = $revisions->[0][2];
2326
2327	# populate the temporary index based on the latest commit were we saw
2328	# the file -- but do it cheaply without checking out any files
2329	# TODO: if we got a revision from the client, use that instead
2330	# to look up the commithash in sqlite (still good to default to
2331	# the current head as we do now)
2332	system("git", "read-tree", $lastseenin);
2333	unless ($? == 0)
2334	{
2335	    print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
2336	    return;
2337	}
2338	$log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
2339
2340        # do a checkout of the file
2341        system('git', 'checkout-index', '-f', '-u', $filename);
2342        unless ($? == 0) {
2343            print "E error running git-checkout-index -f -u $filename : $!\n";
2344            return;
2345        }
2346
2347        $log->info("Annotate $filename");
2348
2349        # Prepare a file with the commits from the linearized
2350        # history that annotate should know about. This prevents
2351        # git-jsannotate telling us about commits we are hiding
2352        # from the client.
2353
2354        my $a_hints = "$work->{workDir}/.annotate_hints";
2355        if (!open(ANNOTATEHINTS, '>', $a_hints)) {
2356            print "E failed to open '$a_hints' for writing: $!\n";
2357            return;
2358        }
2359        for (my $i=0; $i < @$revisions; $i++)
2360        {
2361            print ANNOTATEHINTS $revisions->[$i][2];
2362            if ($i+1 < @$revisions) { # have we got a parent?
2363                print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2364            }
2365            print ANNOTATEHINTS "\n";
2366        }
2367
2368        print ANNOTATEHINTS "\n";
2369        close ANNOTATEHINTS
2370            or (print "E failed to write $a_hints: $!\n"), return;
2371
2372        my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
2373        if (!open(ANNOTATE, "-|", @cmd)) {
2374            print "E error invoking ". join(' ',@cmd) .": $!\n";
2375            return;
2376        }
2377        my $metadata = {};
2378        print "E Annotations for $filename\n";
2379        print "E ***************\n";
2380        while ( <ANNOTATE> )
2381        {
2382            if (m/^([a-zA-Z0-9]{$state->{hexsz}})\t\([^\)]*\)(.*)$/i)
2383            {
2384                my $commithash = $1;
2385                my $data = $2;
2386                unless ( defined ( $metadata->{$commithash} ) )
2387                {
2388                    $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2389                    $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
2390                    $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2391                }
2392                printf("M %-7s      (%-8s %10s): %s\n",
2393                    $metadata->{$commithash}{revision},
2394                    $metadata->{$commithash}{author},
2395                    $metadata->{$commithash}{modified},
2396                    $data
2397                );
2398            } else {
2399                $log->warn("Error in annotate output! LINE: $_");
2400                print "E Annotate error \n";
2401                next;
2402            }
2403        }
2404        close ANNOTATE;
2405    }
2406
2407    # done; get out of the tempdir
2408    cleanupWorkTree();
2409
2410    print "ok\n";
2411
2412}
2413
2414# This method takes the state->{arguments} array and produces two new arrays.
2415# The first is $state->{args} which is everything before the '--' argument, and
2416# the second is $state->{files} which is everything after it.
2417sub argsplit
2418{
2419    $state->{args} = [];
2420    $state->{files} = [];
2421    $state->{opt} = {};
2422
2423    return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2424
2425    my $type = shift;
2426
2427    if ( defined($type) )
2428    {
2429        my $opt = {};
2430        $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" );
2431        $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2432        $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" );
2433        $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2, N => 0 } if ( $type eq "diff" );
2434        $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2435        $opt = { k => 1, m => 1 } if ( $type eq "add" );
2436        $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2437        $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" );
2438
2439
2440        while ( scalar ( @{$state->{arguments}} ) > 0 )
2441        {
2442            my $arg = shift @{$state->{arguments}};
2443
2444            next if ( $arg eq "--" );
2445            next unless ( $arg =~ /\S/ );
2446
2447            # if the argument looks like a switch
2448            if ( $arg =~ /^-(\w)(.*)/ )
2449            {
2450                # if it's a switch that takes an argument
2451                if ( $opt->{$1} )
2452                {
2453                    # If this switch has already been provided
2454                    if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2455                    {
2456                        $state->{opt}{$1} = [ $state->{opt}{$1} ];
2457                        if ( length($2) > 0 )
2458                        {
2459                            push @{$state->{opt}{$1}},$2;
2460                        } else {
2461                            push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2462                        }
2463                    } else {
2464                        # if there's extra data in the arg, use that as the argument for the switch
2465                        if ( length($2) > 0 )
2466                        {
2467                            $state->{opt}{$1} = $2;
2468                        } else {
2469                            $state->{opt}{$1} = shift @{$state->{arguments}};
2470                        }
2471                    }
2472                } else {
2473                    $state->{opt}{$1} = undef;
2474                }
2475            }
2476            else
2477            {
2478                push @{$state->{args}}, $arg;
2479            }
2480        }
2481    }
2482    else
2483    {
2484        my $mode = 0;
2485
2486        foreach my $value ( @{$state->{arguments}} )
2487        {
2488            if ( $value eq "--" )
2489            {
2490                $mode++;
2491                next;
2492            }
2493            push @{$state->{args}}, $value if ( $mode == 0 );
2494            push @{$state->{files}}, $value if ( $mode == 1 );
2495        }
2496    }
2497}
2498
2499# Used by argsfromdir
2500sub expandArg
2501{
2502    my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
2503
2504    my $fullPath = filecleanup($path);
2505
2506      # Is it a directory?
2507    if( defined($state->{dirMap}{$fullPath}) ||
2508        defined($state->{dirMap}{"$fullPath/"}) )
2509    {
2510          # It is a directory in the user's sandbox.
2511        $isDir=1;
2512
2513        if(defined($state->{entries}{$fullPath}))
2514        {
2515            $log->fatal("Inconsistent file/dir type");
2516            die "Inconsistent file/dir type";
2517        }
2518    }
2519    elsif(defined($state->{entries}{$fullPath}))
2520    {
2521          # It is a file in the user's sandbox.
2522        $isDir=0;
2523    }
2524    my($revDirMap,$otherRevDirMap);
2525    if(!defined($isDir) || $isDir)
2526    {
2527          # Resolve version tree for sticky tag:
2528          # (for now we only want list of files for the version, not
2529          # particular versions of those files: assume it is a directory
2530          # for the moment; ignore Entry's stick tag)
2531
2532          # Order of precedence of sticky tags:
2533          #    -A       [head]
2534          #    -r /tag/
2535          #    [file entry sticky tag, but that is only relevant to files]
2536          #    [the tag specified in dir req_Sticky]
2537          #    [the tag specified in a parent dir req_Sticky]
2538          #    [head]
2539          # Also, -r may appear twice (for diff).
2540          #
2541          # FUTURE: When/if -j (merges) are supported, we also
2542          #  need to add relevant files from one or two
2543          #  versions specified with -j.
2544
2545        if(exists($state->{opt}{A}))
2546        {
2547            $revDirMap=$updater->getRevisionDirMap();
2548        }
2549        elsif( defined($state->{opt}{r}) and
2550               ref $state->{opt}{r} eq "ARRAY" )
2551        {
2552            $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]);
2553            $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]);
2554        }
2555        elsif(defined($state->{opt}{r}))
2556        {
2557            $revDirMap=$updater->getRevisionDirMap($state->{opt}{r});
2558        }
2559        else
2560        {
2561            my($sticky)=getDirStickyInfo($fullPath);
2562            $revDirMap=$updater->getRevisionDirMap($sticky->{tag});
2563        }
2564
2565          # Is it a directory?
2566        if( defined($revDirMap->{$fullPath}) ||
2567            defined($otherRevDirMap->{$fullPath}) )
2568        {
2569            $isDir=1;
2570        }
2571    }
2572
2573      # What to do with it?
2574    if(!$isDir)
2575    {
2576        $outNameMap->{$fullPath}=1;
2577    }
2578    else
2579    {
2580        $outDirMap->{$fullPath}=1;
2581
2582        if(defined($revDirMap->{$fullPath}))
2583        {
2584            addDirMapFiles($updater,$outNameMap,$outDirMap,
2585                           $revDirMap->{$fullPath});
2586        }
2587        if( defined($otherRevDirMap) &&
2588            defined($otherRevDirMap->{$fullPath}) )
2589        {
2590            addDirMapFiles($updater,$outNameMap,$outDirMap,
2591                           $otherRevDirMap->{$fullPath});
2592        }
2593    }
2594}
2595
2596# Used by argsfromdir
2597# Add entries from dirMap to outNameMap.  Also recurse into entries
2598# that are subdirectories.
2599sub addDirMapFiles
2600{
2601    my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
2602
2603    my($fullName);
2604    foreach $fullName (keys(%$dirMap))
2605    {
2606        my $cleanName=$fullName;
2607        if(defined($state->{prependdir}))
2608        {
2609            if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
2610            {
2611                $log->fatal("internal error stripping prependdir");
2612                die "internal error stripping prependdir";
2613            }
2614        }
2615
2616        if($dirMap->{$fullName} eq "F")
2617        {
2618            $outNameMap->{$cleanName}=1;
2619        }
2620        elsif($dirMap->{$fullName} eq "D")
2621        {
2622            if(!$state->{opt}{l})
2623            {
2624                expandArg($updater,$outNameMap,$outDirMap,$cleanName,1);
2625            }
2626        }
2627        else
2628        {
2629            $log->fatal("internal error in addDirMapFiles");
2630            die "internal error in addDirMapFiles";
2631        }
2632    }
2633}
2634
2635# This method replaces $state->{args} with a directory-expanded
2636# list of all relevant filenames (recursively unless -d), based
2637# on $state->{entries}, and the "current" list of files in
2638# each directory.  "Current" files as determined by
2639# either the requested (-r/-A) or "req_Sticky" version of
2640# that directory.
2641#    Both the input args and the new output args are relative
2642# to the cvs-client's CWD, although some of the internal
2643# computations are relative to the top of the project.
2644sub argsfromdir
2645{
2646    my $updater = shift;
2647
2648    # Notes about requirements for specific callers:
2649    #   update # "standard" case (entries; a single -r/-A/default; -l)
2650    #          # Special case: -d for create missing directories.
2651    #   diff # 0 or 1 -r's: "standard" case.
2652    #        # 2 -r's: We could ignore entries (just use the two -r's),
2653    #        # but it doesn't really matter.
2654    #   annotate # "standard" case
2655    #   log # Punting: log -r has a more complex non-"standard"
2656    #       # meaning, and we don't currently try to support log'ing
2657    #       # branches at all (need a lot of work to
2658    #       # support CVS-consistent branch relative version
2659    #       # numbering).
2660#HERE: But we still want to expand directories.  Maybe we should
2661#  essentially force "-A".
2662    #   status # "standard", except that -r/-A/default are not possible.
2663    #          # Mostly only used to expand entries only)
2664    #
2665    # Don't use argsfromdir at all:
2666    #   add # Explicit arguments required.  Directory args imply add
2667    #       # the directory itself, not the files in it.
2668    #   co  # Obtain list directly.
2669    #   remove # HERE: TEST: MAYBE client does the recursion for us,
2670    #          # since it only makes sense to remove stuff already in
2671    #          # the sandbox?
2672    #   ci # HERE: Similar to remove...
2673    #      # Don't try to implement the confusing/weird
2674    #      # ci -r bug er.."feature".
2675
2676    if(scalar(@{$state->{args}})==0)
2677    {
2678        $state->{args} = [ "." ];
2679    }
2680    my %allArgs;
2681    my %allDirs;
2682    for my $file (@{$state->{args}})
2683    {
2684        expandArg($updater,\%allArgs,\%allDirs,$file);
2685    }
2686
2687    # Include any entries from sandbox.  Generally client won't
2688    # send entries that shouldn't be used.
2689    foreach my $file (keys %{$state->{entries}})
2690    {
2691        $allArgs{remove_prependdir($file)} = 1;
2692    }
2693
2694    $state->{dirArgs} = \%allDirs;
2695    $state->{args} = [
2696        sort {
2697                # Sort priority: by directory depth, then actual file name:
2698            my @piecesA=split('/',$a);
2699            my @piecesB=split('/',$b);
2700
2701            my $count=scalar(@piecesA);
2702            my $tmp=scalar(@piecesB);
2703            return $count<=>$tmp if($count!=$tmp);
2704
2705            for($tmp=0;$tmp<$count;$tmp++)
2706            {
2707                if($piecesA[$tmp] ne $piecesB[$tmp])
2708                {
2709                    return $piecesA[$tmp] cmp $piecesB[$tmp]
2710                }
2711            }
2712            return 0;
2713        } keys(%allArgs) ];
2714}
2715
2716## look up directory sticky tag, of either fullPath or a parent:
2717sub getDirStickyInfo
2718{
2719    my($fullPath)=@_;
2720
2721    $fullPath=~s%/+$%%;
2722    while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"}))
2723    {
2724        $fullPath=~s%/?[^/]*$%%;
2725    }
2726
2727    if( !defined($state->{dirMap}{"$fullPath/"}) &&
2728        ( $fullPath eq "" ||
2729          $fullPath eq "." ) )
2730    {
2731        return $state->{dirMap}{""}{stickyInfo};
2732    }
2733    else
2734    {
2735        return $state->{dirMap}{"$fullPath/"}{stickyInfo};
2736    }
2737}
2738
2739# Resolve precedence of various ways of specifying which version of
2740# a file you want.  Returns undef (for default head), or a ref to a hash
2741# that contains "tag" and/or "date" keys.
2742sub resolveStickyInfo
2743{
2744    my($filename,$stickyTag,$stickyDate,$reset) = @_;
2745
2746    # Order of precedence of sticky tags:
2747    #    -A       [head]
2748    #    -r /tag/
2749    #    [file entry sticky tag]
2750    #    [the tag specified in dir req_Sticky]
2751    #    [the tag specified in a parent dir req_Sticky]
2752    #    [head]
2753
2754    my $result;
2755    if($reset)
2756    {
2757        # $result=undef;
2758    }
2759    elsif( defined($stickyTag) && $stickyTag ne "" )
2760           # || ( defined($stickyDate) && $stickyDate ne "" )   # TODO
2761    {
2762        $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) };
2763
2764        # TODO: Convert -D value into the form 2011.04.10.04.46.57,
2765        #   similar to an entry line's sticky date, without the D prefix.
2766        #   It sometimes (always?) arrives as something more like
2767        #   '10 Apr 2011 04:46:57 -0000'...
2768        # $result={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
2769    }
2770    elsif( defined($state->{entries}{$filename}) &&
2771           defined($state->{entries}{$filename}{tag_or_date}) &&
2772           $state->{entries}{$filename}{tag_or_date} ne "" )
2773    {
2774        my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
2775        if($tagOrDate=~/^T([^ ]+)\s*$/)
2776        {
2777            $result = { 'tag' => $1 };
2778        }
2779        elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
2780        {
2781            $result= { 'date' => $1 };
2782        }
2783        else
2784        {
2785            die "Unknown tag_or_date format\n";
2786        }
2787    }
2788    else
2789    {
2790        $result=getDirStickyInfo($filename);
2791    }
2792
2793    return $result;
2794}
2795
2796# Convert a stickyInfo (ref to a hash) as returned by resolveStickyInfo into
2797# a form appropriate for the sticky tag field of an Entries
2798# line (field index 5, 0-based).
2799sub getStickyTagOrDate
2800{
2801    my($stickyInfo)=@_;
2802
2803    my $result;
2804    if(defined($stickyInfo) && defined($stickyInfo->{tag}))
2805    {
2806        $result="T$stickyInfo->{tag}";
2807    }
2808    # TODO: When/if we actually pick versions by {date} properly,
2809    #   also handle it here:
2810    #   "D$stickyInfo->{date}" (example: "D2011.04.13.20.37.07").
2811    else
2812    {
2813        $result="";
2814    }
2815
2816    return $result;
2817}
2818
2819# This method cleans up the $state variable after a command that uses arguments has run
2820sub statecleanup
2821{
2822    $state->{files} = [];
2823    $state->{dirArgs} = {};
2824    $state->{args} = [];
2825    $state->{arguments} = [];
2826    $state->{entries} = {};
2827    $state->{dirMap} = {};
2828}
2829
2830# Return working directory CVS revision "1.X" out
2831# of the working directory "entries" state, for the given filename.
2832# This is prefixed with a dash if the file is scheduled for removal
2833# when it is committed.
2834sub revparse
2835{
2836    my $filename = shift;
2837
2838    return $state->{entries}{$filename}{revision};
2839}
2840
2841# This method takes a file hash and does a CVS "file transfer".  Its
2842# exact behaviour depends on a second, optional hash table argument:
2843# - If $options->{targetfile}, dump the contents to that file;
2844# - If $options->{print}, use M/MT to transmit the contents one line
2845#   at a time;
2846# - Otherwise, transmit the size of the file, followed by the file
2847#   contents.
2848sub transmitfile
2849{
2850    my $filehash = shift;
2851    my $options = shift;
2852
2853    if ( defined ( $filehash ) and $filehash eq "deleted" )
2854    {
2855        $log->warn("filehash is 'deleted'");
2856        return;
2857    }
2858
2859    die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
2860
2861    my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash);
2862    chomp $type;
2863
2864    die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2865
2866    my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash);
2867    chomp $size;
2868
2869    $log->debug("transmitfile($filehash) size=$size, type=$type");
2870
2871    if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2872    {
2873        if ( defined ( $options->{targetfile} ) )
2874        {
2875            my $targetfile = $options->{targetfile};
2876            open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2877            print NEWFILE $_ while ( <$fh> );
2878            close NEWFILE or die("Failed to write '$targetfile': $!");
2879        } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2880            while ( <$fh> ) {
2881                if( /\n\z/ ) {
2882                    print 'M ', $_;
2883                } else {
2884                    print 'MT text ', $_, "\n";
2885                }
2886            }
2887        } else {
2888            print "$size\n";
2889            print while ( <$fh> );
2890        }
2891        close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2892    } else {
2893        die("Couldn't execute git-cat-file");
2894    }
2895}
2896
2897# This method takes a file name, and returns ( $dirpart, $filepart ) which
2898# refers to the directory portion and the file portion of the filename
2899# respectively
2900sub filenamesplit
2901{
2902    my $filename = shift;
2903    my $fixforlocaldir = shift;
2904
2905    my ( $filepart, $dirpart ) = ( $filename, "." );
2906    ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2907    $dirpart .= "/";
2908
2909    if ( $fixforlocaldir )
2910    {
2911        $dirpart =~ s/^$state->{prependdir}//;
2912    }
2913
2914    return ( $filepart, $dirpart );
2915}
2916
2917# Cleanup various junk in filename (try to canonicalize it), and
2918# add prependdir to accommodate running CVS client from a
2919# subdirectory (so the output is relative to top directory of the project).
2920sub filecleanup
2921{
2922    my $filename = shift;
2923
2924    return undef unless(defined($filename));
2925    if ( $filename =~ /^\// )
2926    {
2927        print "E absolute filenames '$filename' not supported by server\n";
2928        return undef;
2929    }
2930
2931    if($filename eq ".")
2932    {
2933        $filename="";
2934    }
2935    $filename =~ s/^\.\///g;
2936    $filename =~ s%/+%/%g;
2937    $filename = $state->{prependdir} . $filename;
2938    $filename =~ s%/$%%;
2939    return $filename;
2940}
2941
2942# Remove prependdir from the path, so that it is relative to the directory
2943# the CVS client was started from, rather than the top of the project.
2944# Essentially the inverse of filecleanup().
2945sub remove_prependdir
2946{
2947    my($path) = @_;
2948    if(defined($state->{prependdir}) && $state->{prependdir} ne "")
2949    {
2950        my($pre)=$state->{prependdir};
2951        $pre=~s%/$%%;
2952        if(!($path=~s%^\Q$pre\E/?%%))
2953        {
2954            $log->fatal("internal error missing prependdir");
2955            die("internal error missing prependdir");
2956        }
2957    }
2958    return $path;
2959}
2960
2961sub validateGitDir
2962{
2963    if( !defined($state->{CVSROOT}) )
2964    {
2965        print "error 1 CVSROOT not specified\n";
2966        cleanupWorkTree();
2967        exit;
2968    }
2969    if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2970    {
2971        print "error 1 Internally inconsistent CVSROOT\n";
2972        cleanupWorkTree();
2973        exit;
2974    }
2975}
2976
2977# Setup working directory in a work tree with the requested version
2978# loaded in the index.
2979sub setupWorkTree
2980{
2981    my ($ver) = @_;
2982
2983    validateGitDir();
2984
2985    if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2986        defined($work->{tmpDir}) )
2987    {
2988        $log->warn("Bad work tree state management");
2989        print "error 1 Internal setup multiple work trees without cleanup\n";
2990        cleanupWorkTree();
2991        exit;
2992    }
2993
2994    $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2995
2996    if( !defined($work->{index}) )
2997    {
2998        (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2999    }
3000
3001    chdir $work->{workDir} or
3002        die "Unable to chdir to $work->{workDir}\n";
3003
3004    $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
3005
3006    $ENV{GIT_WORK_TREE} = ".";
3007    $ENV{GIT_INDEX_FILE} = $work->{index};
3008    $work->{state} = 2;
3009
3010    if($ver)
3011    {
3012        system("git","read-tree",$ver);
3013        unless ($? == 0)
3014        {
3015            $log->warn("Error running git-read-tree");
3016            die "Error running git-read-tree $ver in $work->{workDir} $!\n";
3017        }
3018    }
3019    # else # req_annotate reads tree for each file
3020}
3021
3022# Ensure current directory is in some kind of working directory,
3023# with a recent version loaded in the index.
3024sub ensureWorkTree
3025{
3026    if( defined($work->{tmpDir}) )
3027    {
3028        $log->warn("Bad work tree state management [ensureWorkTree()]");
3029        print "error 1 Internal setup multiple dirs without cleanup\n";
3030        cleanupWorkTree();
3031        exit;
3032    }
3033    if( $work->{state} )
3034    {
3035        return;
3036    }
3037
3038    validateGitDir();
3039
3040    if( !defined($work->{emptyDir}) )
3041    {
3042        $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
3043    }
3044    chdir $work->{emptyDir} or
3045        die "Unable to chdir to $work->{emptyDir}\n";
3046
3047    my $ver = safe_pipe_capture('git', 'show-ref', '-s', "refs/heads/$state->{module}");
3048    chomp $ver;
3049    if ($ver !~ /^[0-9a-f]{$state->{hexsz}}$/)
3050    {
3051        $log->warn("Error from git show-ref -s refs/head$state->{module}");
3052        print "error 1 cannot find the current HEAD of module";
3053        cleanupWorkTree();
3054        exit;
3055    }
3056
3057    if( !defined($work->{index}) )
3058    {
3059        (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3060    }
3061
3062    $ENV{GIT_WORK_TREE} = ".";
3063    $ENV{GIT_INDEX_FILE} = $work->{index};
3064    $work->{state} = 1;
3065
3066    system("git","read-tree",$ver);
3067    unless ($? == 0)
3068    {
3069        die "Error running git-read-tree $ver $!\n";
3070    }
3071}
3072
3073# Cleanup working directory that is not needed any longer.
3074sub cleanupWorkTree
3075{
3076    if( ! $work->{state} )
3077    {
3078        return;
3079    }
3080
3081    chdir "/" or die "Unable to chdir '/'\n";
3082
3083    if( defined($work->{workDir}) )
3084    {
3085        rmtree( $work->{workDir} );
3086        undef $work->{workDir};
3087    }
3088    undef $work->{state};
3089}
3090
3091# Setup a temporary directory (not a working tree), typically for
3092# merging dirty state as in req_update.
3093sub setupTmpDir
3094{
3095    $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
3096    chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
3097
3098    return $work->{tmpDir};
3099}
3100
3101# Clean up a previously setupTmpDir.  Restore previous work tree if
3102# appropriate.
3103sub cleanupTmpDir
3104{
3105    if ( !defined($work->{tmpDir}) )
3106    {
3107        $log->warn("cleanup tmpdir that has not been setup");
3108        die "Cleanup tmpDir that has not been setup\n";
3109    }
3110    if( defined($work->{state}) )
3111    {
3112        if( $work->{state} == 1 )
3113        {
3114            chdir $work->{emptyDir} or
3115                die "Unable to chdir to $work->{emptyDir}\n";
3116        }
3117        elsif( $work->{state} == 2 )
3118        {
3119            chdir $work->{workDir} or
3120                die "Unable to chdir to $work->{emptyDir}\n";
3121        }
3122        else
3123        {
3124            $log->warn("Inconsistent work dir state");
3125            die "Inconsistent work dir state\n";
3126        }
3127    }
3128    else
3129    {
3130        chdir "/" or die "Unable to chdir '/'\n";
3131    }
3132}
3133
3134# Given a path, this function returns a string containing the kopts
3135# that should go into that path's Entries line.  For example, a binary
3136# file should get -kb.
3137sub kopts_from_path
3138{
3139    my ($path, $srcType, $name) = @_;
3140
3141    if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
3142         $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
3143    {
3144        my ($val) = check_attr( "text", $path );
3145        if ( $val eq "unspecified" )
3146        {
3147            $val = check_attr( "crlf", $path );
3148        }
3149        if ( $val eq "unset" )
3150        {
3151            return "-kb"
3152        }
3153        elsif ( check_attr( "eol", $path ) ne "unspecified" ||
3154                $val eq "set" || $val eq "input" )
3155        {
3156            return "";
3157        }
3158        else
3159        {
3160            $log->info("Unrecognized check_attr crlf $path : $val");
3161        }
3162    }
3163
3164    if ( defined ( $cfg->{gitcvs}{allbinary} ) )
3165    {
3166        if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
3167        {
3168            return "-kb";
3169        }
3170        elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
3171        {
3172            if( is_binary($srcType,$name) )
3173            {
3174                $log->debug("... as binary");
3175                return "-kb";
3176            }
3177            else
3178            {
3179                $log->debug("... as text");
3180            }
3181        }
3182    }
3183    # Return "" to give no special treatment to any path
3184    return "";
3185}
3186
3187sub check_attr
3188{
3189    my ($attr,$path) = @_;
3190    ensureWorkTree();
3191    if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
3192    {
3193        my $val = <$fh>;
3194        close $fh;
3195        $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
3196        return $val;
3197    }
3198    else
3199    {
3200        return undef;
3201    }
3202}
3203
3204# This should have the same heuristics as convert.c:is_binary() and related.
3205# Note that the bare CR test is done by callers in convert.c.
3206sub is_binary
3207{
3208    my ($srcType,$name) = @_;
3209    $log->debug("is_binary($srcType,$name)");
3210
3211    # Minimize amount of interpreted code run in the inner per-character
3212    # loop for large files, by totalling each character value and
3213    # then analyzing the totals.
3214    my @counts;
3215    my $i;
3216    for($i=0;$i<256;$i++)
3217    {
3218        $counts[$i]=0;
3219    }
3220
3221    my $fh = open_blob_or_die($srcType,$name);
3222    my $line;
3223    while( defined($line=<$fh>) )
3224    {
3225        # Any '\0' and bare CR are considered binary.
3226        if( $line =~ /\0|(\r[^\n])/ )
3227        {
3228            close($fh);
3229            return 1;
3230        }
3231
3232        # Count up each character in the line:
3233        my $len=length($line);
3234        for($i=0;$i<$len;$i++)
3235        {
3236            $counts[ord(substr($line,$i,1))]++;
3237        }
3238    }
3239    close $fh;
3240
3241    # Don't count CR and LF as either printable/nonprintable
3242    $counts[ord("\n")]=0;
3243    $counts[ord("\r")]=0;
3244
3245    # Categorize individual character count into printable and nonprintable:
3246    my $printable=0;
3247    my $nonprintable=0;
3248    for($i=0;$i<256;$i++)
3249    {
3250        if( $i < 32 &&
3251            $i != ord("\b") &&
3252            $i != ord("\t") &&
3253            $i != 033 &&       # ESC
3254            $i != 014 )        # FF
3255        {
3256            $nonprintable+=$counts[$i];
3257        }
3258        elsif( $i==127 )  # DEL
3259        {
3260            $nonprintable+=$counts[$i];
3261        }
3262        else
3263        {
3264            $printable+=$counts[$i];
3265        }
3266    }
3267
3268    return ($printable >> 7) < $nonprintable;
3269}
3270
3271# Returns open file handle.  Possible invocations:
3272#  - open_blob_or_die("file",$filename);
3273#  - open_blob_or_die("sha1",$filehash);
3274sub open_blob_or_die
3275{
3276    my ($srcType,$name) = @_;
3277    my ($fh);
3278    if( $srcType eq "file" )
3279    {
3280        if( !open $fh,"<",$name )
3281        {
3282            $log->warn("Unable to open file $name: $!");
3283            die "Unable to open file $name: $!\n";
3284        }
3285    }
3286    elsif( $srcType eq "sha1" )
3287    {
3288        unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ )
3289        {
3290            $log->warn("Need filehash");
3291            die "Need filehash\n";
3292        }
3293
3294        my $type = safe_pipe_capture('git', 'cat-file', '-t', $name);
3295        chomp $type;
3296
3297        unless ( defined ( $type ) and $type eq "blob" )
3298        {
3299            $log->warn("Invalid type '$type' for '$name'");
3300            die ( "Invalid type '$type' (expected 'blob')" )
3301        }
3302
3303        my $size = safe_pipe_capture('git', 'cat-file', '-s', $name);
3304        chomp $size;
3305
3306        $log->debug("open_blob_or_die($name) size=$size, type=$type");
3307
3308        unless( open $fh, '-|', "git", "cat-file", "blob", $name )
3309        {
3310            $log->warn("Unable to open sha1 $name");
3311            die "Unable to open sha1 $name\n";
3312        }
3313    }
3314    else
3315    {
3316        $log->warn("Unknown type of blob source: $srcType");
3317        die "Unknown type of blob source: $srcType\n";
3318    }
3319    return $fh;
3320}
3321
3322# Generate a CVS author name from Git author information, by taking the local
3323# part of the email address and replacing characters not in the Portable
3324# Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
3325# Login names are Unix login names, which should be restricted to this
3326# character set.
3327sub cvs_author
3328{
3329    my $author_line = shift;
3330    (my $author) = $author_line =~ /<([^@>]*)/;
3331
3332    $author =~ s/[^-a-zA-Z0-9_.]/_/g;
3333    $author =~ s/^-/_/;
3334
3335    $author;
3336}
3337
3338
3339sub descramble
3340{
3341    # This table is from src/scramble.c in the CVS source
3342    my @SHIFTS = (
3343        0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15,
3344        16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
3345        114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
3346        111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
3347        41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
3348        125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
3349        36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
3350        58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
3351        225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
3352        199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
3353        174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
3354        207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
3355        192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
3356        227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
3357        182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
3358        243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
3359    );
3360    my ($str) = @_;
3361
3362    # This should never happen, the same password format (A) has been
3363    # used by CVS since the beginning of time
3364    {
3365        my $fmt = substr($str, 0, 1);
3366        die "invalid password format `$fmt'" unless $fmt eq 'A';
3367    }
3368
3369    my @str = unpack "C*", substr($str, 1);
3370    my $ret = join '', map { chr $SHIFTS[$_] } @str;
3371    return $ret;
3372}
3373
3374# Test if the (deep) values of two references to a hash are the same.
3375sub refHashEqual
3376{
3377    my($v1,$v2) = @_;
3378
3379    my $out;
3380    if(!defined($v1))
3381    {
3382        if(!defined($v2))
3383        {
3384            $out=1;
3385        }
3386    }
3387    elsif( !defined($v2) ||
3388           scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
3389    {
3390        # $out=undef;
3391    }
3392    else
3393    {
3394        $out=1;
3395
3396        my $key;
3397        foreach $key (keys(%{$v1}))
3398        {
3399            if( !exists($v2->{$key}) ||
3400                defined($v1->{$key}) ne defined($v2->{$key}) ||
3401                ( defined($v1->{$key}) &&
3402                  $v1->{$key} ne $v2->{$key} ) )
3403            {
3404               $out=undef;
3405               last;
3406            }
3407        }
3408    }
3409
3410    return $out;
3411}
3412
3413# an alternative to `command` that allows input to be passed as an array
3414# to work around shell problems with weird characters in arguments
3415
3416sub safe_pipe_capture {
3417
3418    my @output;
3419
3420    if (my $pid = open my $child, '-|') {
3421        @output = (<$child>);
3422        close $child or die join(' ',@_).": $! $?";
3423    } else {
3424        exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3425    }
3426    return wantarray ? @output : join('',@output);
3427}
3428
3429
3430package GITCVS::log;
3431
3432####
3433#### Copyright The Open University UK - 2006.
3434####
3435#### Authors: Martyn Smith    <martyn@catalyst.net.nz>
3436####          Martin Langhoff <martin@laptop.org>
3437####
3438####
3439
3440use strict;
3441use warnings;
3442
3443=head1 NAME
3444
3445GITCVS::log
3446
3447=head1 DESCRIPTION
3448
3449This module provides very crude logging with a similar interface to
3450Log::Log4perl
3451
3452=head1 METHODS
3453
3454=cut
3455
3456=head2 new
3457
3458Creates a new log object, optionally you can specify a filename here to
3459indicate the file to log to. If no log file is specified, you can specify one
3460later with method setfile, or indicate you no longer want logging with method
3461nofile.
3462
3463Until one of these methods is called, all log calls will buffer messages ready
3464to write out.
3465
3466=cut
3467sub new
3468{
3469    my $class = shift;
3470    my $filename = shift;
3471
3472    my $self = {};
3473
3474    bless $self, $class;
3475
3476    if ( defined ( $filename ) )
3477    {
3478        open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3479    }
3480
3481    return $self;
3482}
3483
3484=head2 setfile
3485
3486This methods takes a filename, and attempts to open that file as the log file.
3487If successful, all buffered data is written out to the file, and any further
3488logging is written directly to the file.
3489
3490=cut
3491sub setfile
3492{
3493    my $self = shift;
3494    my $filename = shift;
3495
3496    if ( defined ( $filename ) )
3497    {
3498        open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3499    }
3500
3501    return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3502
3503    while ( my $line = shift @{$self->{buffer}} )
3504    {
3505        print {$self->{fh}} $line;
3506    }
3507}
3508
3509=head2 nofile
3510
3511This method indicates no logging is going to be used. It flushes any entries in
3512the internal buffer, and sets a flag to ensure no further data is put there.
3513
3514=cut
3515sub nofile
3516{
3517    my $self = shift;
3518
3519    $self->{nolog} = 1;
3520
3521    return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3522
3523    $self->{buffer} = [];
3524}
3525
3526=head2 _logopen
3527
3528Internal method. Returns true if the log file is open, false otherwise.
3529
3530=cut
3531sub _logopen
3532{
3533    my $self = shift;
3534
3535    return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
3536    return 0;
3537}
3538
3539=head2 debug info warn fatal
3540
3541These four methods are wrappers to _log. They provide the actual interface for
3542logging data.
3543
3544=cut
3545sub debug { my $self = shift; $self->_log("debug", @_); }
3546sub info  { my $self = shift; $self->_log("info" , @_); }
3547sub warn  { my $self = shift; $self->_log("warn" , @_); }
3548sub fatal { my $self = shift; $self->_log("fatal", @_); }
3549
3550=head2 _log
3551
3552This is an internal method called by the logging functions. It generates a
3553timestamp and pushes the logged line either to file, or internal buffer.
3554
3555=cut
3556sub _log
3557{
3558    my $self = shift;
3559    my $level = shift;
3560
3561    return if ( $self->{nolog} );
3562
3563    my @time = localtime;
3564    my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
3565        $time[5] + 1900,
3566        $time[4] + 1,
3567        $time[3],
3568        $time[2],
3569        $time[1],
3570        $time[0],
3571        uc $level,
3572    );
3573
3574    if ( $self->_logopen )
3575    {
3576        print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
3577    } else {
3578        push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
3579    }
3580}
3581
3582=head2 DESTROY
3583
3584This method simply closes the file handle if one is open
3585
3586=cut
3587sub DESTROY
3588{
3589    my $self = shift;
3590
3591    if ( $self->_logopen )
3592    {
3593        close $self->{fh};
3594    }
3595}
3596
3597package GITCVS::updater;
3598
3599####
3600#### Copyright The Open University UK - 2006.
3601####
3602#### Authors: Martyn Smith    <martyn@catalyst.net.nz>
3603####          Martin Langhoff <martin@laptop.org>
3604####
3605####
3606
3607use strict;
3608use warnings;
3609use DBI;
3610
3611=head1 METHODS
3612
3613=cut
3614
3615=head2 new
3616
3617=cut
3618sub new
3619{
3620    my $class = shift;
3621    my $config = shift;
3622    my $module = shift;
3623    my $log = shift;
3624
3625    die "Need to specify a git repository" unless ( defined($config) and -d $config );
3626    die "Need to specify a module" unless ( defined($module) );
3627
3628    $class = ref($class) || $class;
3629
3630    my $self = {};
3631
3632    bless $self, $class;
3633
3634    $self->{valid_tables} = {'revision' => 1,
3635                             'revision_ix1' => 1,
3636                             'revision_ix2' => 1,
3637                             'head' => 1,
3638                             'head_ix1' => 1,
3639                             'properties' => 1,
3640                             'commitmsgs' => 1};
3641
3642    $self->{module} = $module;
3643    $self->{git_path} = $config . "/";
3644
3645    $self->{log} = $log;
3646
3647    die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
3648
3649    # Stores full sha1's for various branch/tag names, abbreviations, etc:
3650    $self->{commitRefCache} = {};
3651
3652    $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
3653        $cfg->{gitcvs}{dbdriver} || "SQLite";
3654    $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
3655        $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
3656    $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
3657        $cfg->{gitcvs}{dbuser} || "";
3658    $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
3659        $cfg->{gitcvs}{dbpass} || "";
3660    $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
3661        $cfg->{gitcvs}{dbtablenameprefix} || "";
3662    my %mapping = ( m => $module,
3663                    a => $state->{method},
3664                    u => getlogin || getpwuid($<) || $<,
3665                    G => $self->{git_path},
3666                    g => mangle_dirname($self->{git_path}),
3667                    );
3668    $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
3669    $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
3670    $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
3671    $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
3672
3673    die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
3674    die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
3675    $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
3676                                $self->{dbuser},
3677                                $self->{dbpass});
3678    die "Error connecting to database\n" unless defined $self->{dbh};
3679
3680    $self->{tables} = {};
3681    foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
3682    {
3683        $self->{tables}{$table} = 1;
3684    }
3685
3686    # Construct the revision table if required
3687    # The revision table stores an entry for each file, each time that file
3688    # changes.
3689    #   numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
3690    # This is not sufficient to support "-r {commithash}" for any
3691    # files except files that were modified by that commit (also,
3692    # some places in the code ignore/effectively strip out -r in
3693    # some cases, before it gets passed to getmeta()).
3694    # The "filehash" field typically has a git blob hash, but can also
3695    # be set to "dead" to indicate that the given version of the file
3696    # should not exist in the sandbox.
3697    unless ( $self->{tables}{$self->tablename("revision")} )
3698    {
3699        my $tablename = $self->tablename("revision");
3700        my $ix1name = $self->tablename("revision_ix1");
3701        my $ix2name = $self->tablename("revision_ix2");
3702        $self->{dbh}->do("
3703            CREATE TABLE $tablename (
3704                name       TEXT NOT NULL,
3705                revision   INTEGER NOT NULL,
3706                filehash   TEXT NOT NULL,
3707                commithash TEXT NOT NULL,
3708                author     TEXT NOT NULL,
3709                modified   TEXT NOT NULL,
3710                mode       TEXT NOT NULL
3711            )
3712        ");
3713        $self->{dbh}->do("
3714            CREATE INDEX $ix1name
3715            ON $tablename (name,revision)
3716        ");
3717        $self->{dbh}->do("
3718            CREATE INDEX $ix2name
3719            ON $tablename (name,commithash)
3720        ");
3721    }
3722
3723    # Construct the head table if required
3724    # The head table (along with the "last_commit" entry in the property
3725    # table) is the persisted working state of the "sub update" subroutine.
3726    # All of it's data is read entirely first, and completely recreated
3727    # last, every time "sub update" runs.
3728    # This is also used by "sub getmeta" when it is asked for the latest
3729    # version of a file (as opposed to some specific version).
3730    # Another way of thinking about it is as a single slice out of
3731    # "revisions", giving just the most recent revision information for
3732    # each file.
3733    unless ( $self->{tables}{$self->tablename("head")} )
3734    {
3735        my $tablename = $self->tablename("head");
3736        my $ix1name = $self->tablename("head_ix1");
3737        $self->{dbh}->do("
3738            CREATE TABLE $tablename (
3739                name       TEXT NOT NULL,
3740                revision   INTEGER NOT NULL,
3741                filehash   TEXT NOT NULL,
3742                commithash TEXT NOT NULL,
3743                author     TEXT NOT NULL,
3744                modified   TEXT NOT NULL,
3745                mode       TEXT NOT NULL
3746            )
3747        ");
3748        $self->{dbh}->do("
3749            CREATE INDEX $ix1name
3750            ON $tablename (name)
3751        ");
3752    }
3753
3754    # Construct the properties table if required
3755    #  - "last_commit" - Used by "sub update".
3756    unless ( $self->{tables}{$self->tablename("properties")} )
3757    {
3758        my $tablename = $self->tablename("properties");
3759        $self->{dbh}->do("
3760            CREATE TABLE $tablename (
3761                key        TEXT NOT NULL PRIMARY KEY,
3762                value      TEXT
3763            )
3764        ");
3765    }
3766
3767    # Construct the commitmsgs table if required
3768    # The commitmsgs table is only used for merge commits, since
3769    # "sub update" will only keep one branch of parents.  Shortlogs
3770    # for ignored commits (i.e. not on the chosen branch) will be used
3771    # to construct a replacement "collapsed" merge commit message,
3772    # which will be stored in this table.  See also "sub commitmessage".
3773    unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3774    {
3775        my $tablename = $self->tablename("commitmsgs");
3776        $self->{dbh}->do("
3777            CREATE TABLE $tablename (
3778                key        TEXT NOT NULL PRIMARY KEY,
3779                value      TEXT
3780            )
3781        ");
3782    }
3783
3784    return $self;
3785}
3786
3787=head2 tablename
3788
3789=cut
3790sub tablename
3791{
3792    my $self = shift;
3793    my $name = shift;
3794
3795    if (exists $self->{valid_tables}{$name}) {
3796        return $self->{dbtablenameprefix} . $name;
3797    } else {
3798        return undef;
3799    }
3800}
3801
3802=head2 update
3803
3804Bring the database up to date with the latest changes from
3805the git repository.
3806
3807Internal working state is read out of the "head" table and the
3808"last_commit" property, then it updates "revisions" based on that, and
3809finally it writes the new internal state back to the "head" table
3810so it can be used as a starting point the next time update is called.
3811
3812=cut
3813sub update
3814{
3815    my $self = shift;
3816
3817    # first lets get the commit list
3818    $ENV{GIT_DIR} = $self->{git_path};
3819
3820    my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module});
3821    chomp $commitsha1;
3822
3823    my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module});
3824    unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{$state->{hexsz}}/ )
3825    {
3826        die("Invalid module '$self->{module}'");
3827    }
3828
3829
3830    my $git_log;
3831    my $lastcommit = $self->_get_prop("last_commit");
3832
3833    if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3834         # invalidate the gethead cache
3835         $self->clearCommitRefCaches();
3836         return 1;
3837    }
3838
3839    # Start exclusive lock here...
3840    $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3841
3842    # TODO: log processing is memory bound
3843    # if we can parse into a 2nd file that is in reverse order
3844    # we can probably do something really efficient
3845    my @git_log_params = ('--pretty', '--parents', '--topo-order');
3846
3847    if (defined $lastcommit) {
3848        push @git_log_params, "$lastcommit..$self->{module}";
3849    } else {
3850        push @git_log_params, $self->{module};
3851    }
3852    # git-rev-list is the backend / plumbing version of git-log
3853    open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params)
3854                or die "Cannot call git-rev-list: $!";
3855    my @commits=readCommits($gitLogPipe);
3856    close $gitLogPipe;
3857
3858    # Now all the commits are in the @commits bucket
3859    # ordered by time DESC. for each commit that needs processing,
3860    # determine whether it's following the last head we've seen or if
3861    # it's on its own branch, grab a file list, and add whatever's changed
3862    # NOTE: $lastcommit refers to the last commit from previous run
3863    #       $lastpicked is the last commit we picked in this run
3864    my $lastpicked;
3865    my $head = {};
3866    if (defined $lastcommit) {
3867        $lastpicked = $lastcommit;
3868    }
3869
3870    my $committotal = scalar(@commits);
3871    my $commitcount = 0;
3872
3873    # Load the head table into $head (for cached lookups during the update process)
3874    foreach my $file ( @{$self->gethead(1)} )
3875    {
3876        $head->{$file->{name}} = $file;
3877    }
3878
3879    foreach my $commit ( @commits )
3880    {
3881        $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3882        if (defined $lastpicked)
3883        {
3884            if (!in_array($lastpicked, @{$commit->{parents}}))
3885            {
3886                # skip, we'll see this delta
3887                # as part of a merge later
3888                # warn "skipping off-track  $commit->{hash}\n";
3889                next;
3890            } elsif (@{$commit->{parents}} > 1) {
3891                # it is a merge commit, for each parent that is
3892                # not $lastpicked (not given a CVS revision number),
3893                # see if we can get a log
3894                # from the merge-base to that parent to put it
3895                # in the message as a merge summary.
3896                my @parents = @{$commit->{parents}};
3897                foreach my $parent (@parents) {
3898                    if ($parent eq $lastpicked) {
3899                        next;
3900                    }
3901                    # git-merge-base can potentially (but rarely) throw
3902                    # several candidate merge bases. let's assume
3903                    # that the first one is the best one.
3904		    my $base = eval {
3905			    ::safe_pipe_capture('git', 'merge-base',
3906						 $lastpicked, $parent);
3907		    };
3908		    # The two branches may not be related at all,
3909		    # in which case merge base simply fails to find
3910		    # any, but that's Ok.
3911		    next if ($@);
3912
3913                    chomp $base;
3914                    if ($base) {
3915                        my @merged;
3916                        # print "want to log between  $base $parent \n";
3917                        open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3918			  or die "Cannot call git-log: $!";
3919                        my $mergedhash;
3920                        while (<GITLOG>) {
3921                            chomp;
3922                            if (!defined $mergedhash) {
3923                                if (m/^commit\s+(.+)$/) {
3924                                    $mergedhash = $1;
3925                                } else {
3926                                    next;
3927                                }
3928                            } else {
3929                                # grab the first line that looks non-rfc822
3930                                # aka has content after leading space
3931                                if (m/^\s+(\S.*)$/) {
3932                                    my $title = $1;
3933                                    $title = substr($title,0,100); # truncate
3934                                    unshift @merged, "$mergedhash $title";
3935                                    undef $mergedhash;
3936                                }
3937                            }
3938                        }
3939                        close GITLOG;
3940                        if (@merged) {
3941                            $commit->{mergemsg} = $commit->{message};
3942                            $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3943                            foreach my $summary (@merged) {
3944                                $commit->{mergemsg} .= "\t$summary\n";
3945                            }
3946                            $commit->{mergemsg} .= "\n\n";
3947                            # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3948                        }
3949                    }
3950                }
3951            }
3952        }
3953
3954        # convert the date to CVS-happy format
3955        my $cvsDate = convertToCvsDate($commit->{date});
3956
3957        if ( defined ( $lastpicked ) )
3958        {
3959            my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3960	    local ($/) = "\0";
3961            while ( <FILELIST> )
3962            {
3963		chomp;
3964                unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{$state->{hexsz}}\s+([a-f0-9]{$state->{hexsz}})\s+(\w)$/o )
3965                {
3966                    die("Couldn't process git-diff-tree line : $_");
3967                }
3968		my ($mode, $hash, $change) = ($1, $2, $3);
3969		my $name = <FILELIST>;
3970		chomp($name);
3971
3972                # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3973
3974                my $dbMode = convertToDbMode($mode);
3975
3976                if ( $change eq "D" )
3977                {
3978                    #$log->debug("DELETE   $name");
3979                    $head->{$name} = {
3980                        name => $name,
3981                        revision => $head->{$name}{revision} + 1,
3982                        filehash => "deleted",
3983                        commithash => $commit->{hash},
3984                        modified => $cvsDate,
3985                        author => $commit->{author},
3986                        mode => $dbMode,
3987                    };
3988                    $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3989                }
3990                elsif ( $change eq "M" || $change eq "T" )
3991                {
3992                    #$log->debug("MODIFIED $name");
3993                    $head->{$name} = {
3994                        name => $name,
3995                        revision => $head->{$name}{revision} + 1,
3996                        filehash => $hash,
3997                        commithash => $commit->{hash},
3998                        modified => $cvsDate,
3999                        author => $commit->{author},
4000                        mode => $dbMode,
4001                    };
4002                    $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4003                }
4004                elsif ( $change eq "A" )
4005                {
4006                    #$log->debug("ADDED    $name");
4007                    $head->{$name} = {
4008                        name => $name,
4009                        revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
4010                        filehash => $hash,
4011                        commithash => $commit->{hash},
4012                        modified => $cvsDate,
4013                        author => $commit->{author},
4014                        mode => $dbMode,
4015                    };
4016                    $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4017                }
4018                else
4019                {
4020                    $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
4021                    die;
4022                }
4023            }
4024            close FILELIST;
4025        } else {
4026            # this is used to detect files removed from the repo
4027            my $seen_files = {};
4028
4029            my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
4030	    local $/ = "\0";
4031            while ( <FILELIST> )
4032            {
4033		chomp;
4034                unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4035                {
4036                    die("Couldn't process git-ls-tree line : $_");
4037                }
4038
4039                my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4040
4041                $seen_files->{$git_filename} = 1;
4042
4043                my ( $oldhash, $oldrevision, $oldmode ) = (
4044                    $head->{$git_filename}{filehash},
4045                    $head->{$git_filename}{revision},
4046                    $head->{$git_filename}{mode}
4047                );
4048
4049                my $dbMode = convertToDbMode($mode);
4050
4051                # unless the file exists with the same hash, we need to update it ...
4052                unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode )
4053                {
4054                    my $newrevision = ( $oldrevision or 0 ) + 1;
4055
4056                    $head->{$git_filename} = {
4057                        name => $git_filename,
4058                        revision => $newrevision,
4059                        filehash => $git_hash,
4060                        commithash => $commit->{hash},
4061                        modified => $cvsDate,
4062                        author => $commit->{author},
4063                        mode => $dbMode,
4064                    };
4065
4066
4067                    $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4068                }
4069            }
4070            close FILELIST;
4071
4072            # Detect deleted files
4073            foreach my $file ( sort keys %$head )
4074            {
4075                unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
4076                {
4077                    $head->{$file}{revision}++;
4078                    $head->{$file}{filehash} = "deleted";
4079                    $head->{$file}{commithash} = $commit->{hash};
4080                    $head->{$file}{modified} = $cvsDate;
4081                    $head->{$file}{author} = $commit->{author};
4082
4083                    $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode});
4084                }
4085            }
4086            # END : "Detect deleted files"
4087        }
4088
4089
4090        if (exists $commit->{mergemsg})
4091        {
4092            $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
4093        }
4094
4095        $lastpicked = $commit->{hash};
4096
4097        $self->_set_prop("last_commit", $commit->{hash});
4098    }
4099
4100    $self->delete_head();
4101    foreach my $file ( sort keys %$head )
4102    {
4103        $self->insert_head(
4104            $file,
4105            $head->{$file}{revision},
4106            $head->{$file}{filehash},
4107            $head->{$file}{commithash},
4108            $head->{$file}{modified},
4109            $head->{$file}{author},
4110            $head->{$file}{mode},
4111        );
4112    }
4113    # invalidate the gethead cache
4114    $self->clearCommitRefCaches();
4115
4116
4117    # Ending exclusive lock here
4118    $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
4119}
4120
4121sub readCommits
4122{
4123    my $pipeHandle = shift;
4124    my @commits;
4125
4126    my %commit = ();
4127
4128    while ( <$pipeHandle> )
4129    {
4130        chomp;
4131        if (m/^commit\s+(.*)$/) {
4132            # on ^commit lines put the just seen commit in the stack
4133            # and prime things for the next one
4134            if (keys %commit) {
4135                my %copy = %commit;
4136                unshift @commits, \%copy;
4137                %commit = ();
4138            }
4139            my @parents = split(m/\s+/, $1);
4140            $commit{hash} = shift @parents;
4141            $commit{parents} = \@parents;
4142        } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
4143            # on rfc822-like lines seen before we see any message,
4144            # lowercase the entry and put it in the hash as key-value
4145            $commit{lc($1)} = $2;
4146        } else {
4147            # message lines - skip initial empty line
4148            # and trim whitespace
4149            if (!exists($commit{message}) && m/^\s*$/) {
4150                # define it to mark the end of headers
4151                $commit{message} = '';
4152                next;
4153            }
4154            s/^\s+//; s/\s+$//; # trim ws
4155            $commit{message} .= $_ . "\n";
4156        }
4157    }
4158
4159    unshift @commits, \%commit if ( keys %commit );
4160
4161    return @commits;
4162}
4163
4164sub convertToCvsDate
4165{
4166    my $date = shift;
4167    # Convert from: "git rev-list --pretty" formatted date
4168    # Convert to: "the format specified by RFC822 as modified by RFC1123."
4169    # Example: 26 May 1997 13:01:40 -0400
4170    if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ )
4171    {
4172        $date = "$2 $1 $4 $3 $5";
4173    }
4174
4175    return $date;
4176}
4177
4178sub convertToDbMode
4179{
4180    my $mode = shift;
4181
4182    # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw",
4183    #  but the database "mode" column historically (and currently)
4184    #  only stores the "rw" (for user) part of the string.
4185    #    FUTURE: It might make more sense to persist the raw
4186    #  octal mode (or perhaps the final full CVS form) instead of
4187    #  this half-converted form, but it isn't currently worth the
4188    #  backwards compatibility headaches.
4189
4190    $mode=~/^\d{3}(\d)\d\d$/;
4191    my $userBits=$1;
4192
4193    my $dbMode = "";
4194    $dbMode .= "r" if ( $userBits & 4 );
4195    $dbMode .= "w" if ( $userBits & 2 );
4196    $dbMode .= "x" if ( $userBits & 1 );
4197    $dbMode = "rw" if ( $dbMode eq "" );
4198
4199    return $dbMode;
4200}
4201
4202sub insert_rev
4203{
4204    my $self = shift;
4205    my $name = shift;
4206    my $revision = shift;
4207    my $filehash = shift;
4208    my $commithash = shift;
4209    my $modified = shift;
4210    my $author = shift;
4211    my $mode = shift;
4212    my $tablename = $self->tablename("revision");
4213
4214    my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
4215    $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4216}
4217
4218sub insert_mergelog
4219{
4220    my $self = shift;
4221    my $key = shift;
4222    my $value = shift;
4223    my $tablename = $self->tablename("commitmsgs");
4224
4225    my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
4226    $insert_mergelog->execute($key, $value);
4227}
4228
4229sub delete_head
4230{
4231    my $self = shift;
4232    my $tablename = $self->tablename("head");
4233
4234    my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
4235    $delete_head->execute();
4236}
4237
4238sub insert_head
4239{
4240    my $self = shift;
4241    my $name = shift;
4242    my $revision = shift;
4243    my $filehash = shift;
4244    my $commithash = shift;
4245    my $modified = shift;
4246    my $author = shift;
4247    my $mode = shift;
4248    my $tablename = $self->tablename("head");
4249
4250    my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
4251    $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4252}
4253
4254sub _get_prop
4255{
4256    my $self = shift;
4257    my $key = shift;
4258    my $tablename = $self->tablename("properties");
4259
4260    my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
4261    $db_query->execute($key);
4262    my ( $value ) = $db_query->fetchrow_array;
4263
4264    return $value;
4265}
4266
4267sub _set_prop
4268{
4269    my $self = shift;
4270    my $key = shift;
4271    my $value = shift;
4272    my $tablename = $self->tablename("properties");
4273
4274    my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
4275    $db_query->execute($value, $key);
4276
4277    unless ( $db_query->rows )
4278    {
4279        $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
4280        $db_query->execute($key, $value);
4281    }
4282
4283    return $value;
4284}
4285
4286=head2 gethead
4287
4288=cut
4289
4290sub gethead
4291{
4292    my $self = shift;
4293    my $intRev = shift;
4294    my $tablename = $self->tablename("head");
4295
4296    return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
4297
4298    my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
4299    $db_query->execute();
4300
4301    my $tree = [];
4302    while ( my $file = $db_query->fetchrow_hashref )
4303    {
4304        if(!$intRev)
4305        {
4306            $file->{revision} = "1.$file->{revision}"
4307        }
4308        push @$tree, $file;
4309    }
4310
4311    $self->{gethead_cache} = $tree;
4312
4313    return $tree;
4314}
4315
4316=head2 getAnyHead
4317
4318Returns a reference to an array of getmeta structures, one
4319per file in the specified tree hash.
4320
4321=cut
4322
4323sub getAnyHead
4324{
4325    my ($self,$hash) = @_;
4326
4327    if(!defined($hash))
4328    {
4329        return $self->gethead();
4330    }
4331
4332    my @files;
4333    {
4334        open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4335                or die("Cannot call git-ls-tree : $!");
4336        local $/ = "\0";
4337        @files=<$filePipe>;
4338        close $filePipe;
4339    }
4340
4341    my $tree=[];
4342    my($line);
4343    foreach $line (@files)
4344    {
4345        $line=~s/\0$//;
4346        unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4347        {
4348            die("Couldn't process git-ls-tree line : $_");
4349        }
4350
4351        my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4352        push @$tree, $self->getMetaFromCommithash($git_filename,$hash);
4353    }
4354
4355    return $tree;
4356}
4357
4358=head2 getRevisionDirMap
4359
4360A "revision dir map" contains all the plain-file filenames associated
4361with a particular revision (tree-ish), organized by directory:
4362
4363  $type = $out->{$dir}{$fullName}
4364
4365The type of each is "F" (for ordinary file) or "D" (for directory,
4366for which the map $out->{$fullName} will also exist).
4367
4368=cut
4369
4370sub getRevisionDirMap
4371{
4372    my ($self,$ver)=@_;
4373
4374    if(!defined($self->{revisionDirMapCache}))
4375    {
4376        $self->{revisionDirMapCache}={};
4377    }
4378
4379        # Get file list (previously cached results are dependent on HEAD,
4380        # but are early in each case):
4381    my $cacheKey;
4382    my (@fileList);
4383    if( !defined($ver) || $ver eq "" )
4384    {
4385        $cacheKey="";
4386        if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4387        {
4388            return $self->{revisionDirMapCache}{$cacheKey};
4389        }
4390
4391        my @head = @{$self->gethead()};
4392        foreach my $file ( @head )
4393        {
4394            next if ( $file->{filehash} eq "deleted" );
4395
4396            push @fileList,$file->{name};
4397        }
4398    }
4399    else
4400    {
4401        my ($hash)=$self->lookupCommitRef($ver);
4402        if( !defined($hash) )
4403        {
4404            return undef;
4405        }
4406
4407        $cacheKey=$hash;
4408        if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4409        {
4410            return $self->{revisionDirMapCache}{$cacheKey};
4411        }
4412
4413        open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4414                or die("Cannot call git-ls-tree : $!");
4415        local $/ = "\0";
4416        while ( <$filePipe> )
4417        {
4418            chomp;
4419            unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4420            {
4421                die("Couldn't process git-ls-tree line : $_");
4422            }
4423
4424            my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4425
4426            push @fileList, $git_filename;
4427        }
4428        close $filePipe;
4429    }
4430
4431        # Convert to normalized form:
4432    my %revMap;
4433    my $file;
4434    foreach $file (@fileList)
4435    {
4436        my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%);
4437        $dir='' if(!defined($dir));
4438
4439            # parent directories:
4440            # ... create empty dir maps for parent dirs:
4441        my($td)=$dir;
4442        while(!defined($revMap{$td}))
4443        {
4444            $revMap{$td}={};
4445
4446            my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4447            $tp='' if(!defined($tp));
4448            $td=$tp;
4449        }
4450            # ... add children to parent maps (now that they exist):
4451        $td=$dir;
4452        while($td ne "")
4453        {
4454            my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4455            $tp='' if(!defined($tp));
4456
4457            if(defined($revMap{$tp}{$td}))
4458            {
4459                if($revMap{$tp}{$td} ne 'D')
4460                {
4461                    die "Weird file/directory inconsistency in $cacheKey";
4462                }
4463                last;   # loop exit
4464            }
4465            $revMap{$tp}{$td}='D';
4466
4467            $td=$tp;
4468        }
4469
4470            # file
4471        $revMap{$dir}{$file}='F';
4472    }
4473
4474        # Save in cache:
4475    $self->{revisionDirMapCache}{$cacheKey}=\%revMap;
4476    return $self->{revisionDirMapCache}{$cacheKey};
4477}
4478
4479=head2 getlog
4480
4481See also gethistorydense().
4482
4483=cut
4484
4485sub getlog
4486{
4487    my $self = shift;
4488    my $filename = shift;
4489    my $revFilter = shift;
4490
4491    my $tablename = $self->tablename("revision");
4492
4493    # Filters:
4494    # TODO: date, state, or by specific logins filters?
4495    # TODO: Handle comma-separated list of revFilter items, each item
4496    #   can be a range [only case currently handled] or individual
4497    #   rev or branch or "branch.".
4498    # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
4499    #   manually filtering the results of the query?
4500    my ( $minrev, $maxrev );
4501    if( defined($revFilter) and
4502        $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
4503    {
4504        my $control = $3;
4505        $minrev = $2;
4506        $maxrev = $5;
4507        $minrev++ if ( defined($minrev) and $control eq "::" );
4508    }
4509
4510    my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
4511    $db_query->execute($filename);
4512
4513    my $totalRevs=0;
4514    my $tree = [];
4515    while ( my $file = $db_query->fetchrow_hashref )
4516    {
4517        $totalRevs++;
4518        if( defined($minrev) and $file->{revision} < $minrev )
4519        {
4520            next;
4521        }
4522        if( defined($maxrev) and $file->{revision} > $maxrev )
4523        {
4524            next;
4525        }
4526
4527        $file->{revision} = "1." . $file->{revision};
4528        push @$tree, $file;
4529    }
4530
4531    return ($tree,$totalRevs);
4532}
4533
4534=head2 getmeta
4535
4536This function takes a filename (with path) argument and returns a hashref of
4537metadata for that file.
4538
4539There are several ways $revision can be specified:
4540
4541   - A reference to hash that contains a "tag" that is the
4542     actual revision (one of the below).  TODO: Also allow it to
4543     specify a "date" in the hash.
4544   - undef, to refer to the latest version on the main branch.
4545   - Full CVS client revision number (mapped to integer in DB, without the
4546     "1." prefix),
4547   - Complex CVS-compatible "special" revision number for
4548     non-linear history (see comment below)
4549   - git commit sha1 hash
4550   - branch or tag name
4551
4552=cut
4553
4554sub getmeta
4555{
4556    my $self = shift;
4557    my $filename = shift;
4558    my $revision = shift;
4559    my $tablename_rev = $self->tablename("revision");
4560    my $tablename_head = $self->tablename("head");
4561
4562    if ( ref($revision) eq "HASH" )
4563    {
4564        $revision = $revision->{tag};
4565    }
4566
4567    # Overview of CVS revision numbers:
4568    #
4569    # General CVS numbering scheme:
4570    #   - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc.
4571    #   - Result of "cvs checkin -r" (possible, but not really
4572    #     recommended): "2.1", "2.2", etc
4573    #   - Branch tag: "1.2.0.n", where "1.2" is revision it was branched
4574    #     from, "0" is a magic placeholder that identifies it as a
4575    #     branch tag instead of a version tag, and n is 2 times the
4576    #     branch number off of "1.2", starting with "2".
4577    #   - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n"
4578    #     is branch number off of "1.2" (like n above), and "x" is
4579    #     the version number on the branch.
4580    #   - Branches can branch off of branches: "1.3.2.7.4.1" (even number
4581    #     of components).
4582    #   - Odd "n"s are used by "vendor branches" that result
4583    #     from "cvs import".  Vendor branches have additional
4584    #     strangeness in the sense that the main rcs "head" of the main
4585    #     branch will (temporarily until first normal commit) point
4586    #     to the version on the vendor branch, rather than the actual
4587    #     main branch.  (FUTURE: This may provide an opportunity
4588    #     to use "strange" revision numbers for fast-forward-merged
4589    #     branch tip when CVS client is asking for the main branch.)
4590    #
4591    # git-cvsserver CVS-compatible special numbering schemes:
4592    #   - Currently git-cvsserver only tries to be identical to CVS for
4593    #     simple "1.x" numbers on the "main" branch (as identified
4594    #     by the module name that was originally cvs checkout'ed).
4595    #   - The database only stores the "x" part, for historical reasons.
4596    #     But most of the rest of the cvsserver preserves
4597    #     and thinks using the full revision number.
4598    #   - To handle non-linear history, it uses a version of the form
4599    #     "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely
4600    #     identify this as a special revision number, and there are
4601    #     20 b's that together encode the sha1 git commit from which
4602    #     this version of this file originated.  Each b is
4603    #     the numerical value of the corresponding byte plus
4604    #     100.
4605    #      - "plus 100" avoids "0"s, and also reduces the
4606    #        likelihood of a collision in the case that someone someday
4607    #        writes an import tool that tries to preserve original
4608    #        CVS revision numbers, and the original CVS data had done
4609    #        lots of branches off of branches and other strangeness to
4610    #        end up with a real version number that just happens to look
4611    #        like this special revision number form.  Also, if needed
4612    #        there are several ways to extend/identify alternative encodings
4613    #        within the "2.1.1.2000" part if necessary.
4614    #      - Unlike real CVS revisions, you can't really reconstruct what
4615    #        relation a revision of this form has to other revisions.
4616    #   - FUTURE: TODO: Rework database somehow to make up and remember
4617    #     fully-CVS-compatible branches and branch version numbers.
4618
4619    my $meta;
4620    if ( defined($revision) )
4621    {
4622        if ( $revision =~ /^1\.(\d+)$/ )
4623        {
4624            my ($intRev) = $1;
4625            my $db_query;
4626            $db_query = $self->{dbh}->prepare_cached(
4627                "SELECT * FROM $tablename_rev WHERE name=? AND revision=?",
4628                {},1);
4629            $db_query->execute($filename, $intRev);
4630            $meta = $db_query->fetchrow_hashref;
4631        }
4632        elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){$state->{rawsz}}$/ )
4633        {
4634            my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/);
4635            $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg;
4636            if($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/)
4637            {
4638                return $self->getMetaFromCommithash($filename,$commitHash);
4639            }
4640
4641            # error recovery: fall back on head version below
4642            print "E Failed to find $filename version=$revision or commit=$commitHash\n";
4643            $log->warning("failed get $revision with commithash=$commitHash");
4644            undef $revision;
4645        }
4646        elsif ( $revision =~ /^[0-9a-f]{$state->{hexsz}}$/ )
4647        {
4648            # Try DB first.  This is mostly only useful for req_annotate(),
4649            # which only calls this for stuff that should already be in
4650            # the DB.  It is fairly likely to be a waste of time
4651            # in most other cases [unless the file happened to be
4652            # modified in $revision specifically], but
4653            # it is probably in the noise compared to how long
4654            # getMetaFromCommithash() will take.
4655            my $db_query;
4656            $db_query = $self->{dbh}->prepare_cached(
4657                "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4658                {},1);
4659            $db_query->execute($filename, $revision);
4660            $meta = $db_query->fetchrow_hashref;
4661
4662            if(! $meta)
4663            {
4664                my($revCommit)=$self->lookupCommitRef($revision);
4665                if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
4666                {
4667                    return $self->getMetaFromCommithash($filename,$revCommit);
4668                }
4669
4670                # error recovery: nothing found:
4671                print "E Failed to find $filename version=$revision\n";
4672                $log->warning("failed get $revision");
4673                return $meta;
4674            }
4675        }
4676        else
4677        {
4678            my($revCommit)=$self->lookupCommitRef($revision);
4679            if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
4680            {
4681                return $self->getMetaFromCommithash($filename,$revCommit);
4682            }
4683
4684            # error recovery: fall back on head version below
4685            print "E Failed to find $filename version=$revision\n";
4686            $log->warning("failed get $revision");
4687            undef $revision;  # Allow fallback
4688        }
4689    }
4690
4691    if(!defined($revision))
4692    {
4693        my $db_query;
4694        $db_query = $self->{dbh}->prepare_cached(
4695                "SELECT * FROM $tablename_head WHERE name=?",{},1);
4696        $db_query->execute($filename);
4697        $meta = $db_query->fetchrow_hashref;
4698    }
4699
4700    if($meta)
4701    {
4702        $meta->{revision} = "1.$meta->{revision}";
4703    }
4704    return $meta;
4705}
4706
4707sub getMetaFromCommithash
4708{
4709    my $self = shift;
4710    my $filename = shift;
4711    my $revCommit = shift;
4712
4713    # NOTE: This function doesn't scale well (lots of forks), especially
4714    #   if you have many files that have not been modified for many commits
4715    #   (each git-rev-parse redoes a lot of work for each file
4716    #   that theoretically could be done in parallel by smarter
4717    #   graph traversal).
4718    #
4719    # TODO: Possible optimization strategies:
4720    #   - Solve the issue of assigning and remembering "real" CVS
4721    #     revision numbers for branches, and ensure the
4722    #     data structure can do this efficiently.  Perhaps something
4723    #     similar to "git notes", and carefully structured to take
4724    #     advantage same-sha1-is-same-contents, to roll the same
4725    #     unmodified subdirectory data onto multiple commits?
4726    #   - Write and use a C tool that is like git-blame, but
4727    #     operates on multiple files with file granularity, instead
4728    #     of one file with line granularity.  Cache
4729    #     most-recently-modified in $self->{commitRefCache}{$revCommit}.
4730    #     Try to be intelligent about how many files we do with
4731    #     one fork (perhaps one directory at a time, without recursion,
4732    #     and/or include directory as one line item, recurse from here
4733    #     instead of in C tool?).
4734    #   - Perhaps we could ask the DB for (filename,fileHash),
4735    #     and just guess that it is correct (that the file hadn't
4736    #     changed between $revCommit and the found commit, then
4737    #     changed back, confusing anything trying to interpret
4738    #     history).  Probably need to add another index to revisions
4739    #     DB table for this.
4740    #   - NOTE: Trying to store all (commit,file) keys in DB [to
4741    #     find "lastModfiedCommit] (instead of
4742    #     just files that changed in each commit as we do now) is
4743    #     probably not practical from a disk space perspective.
4744
4745        # Does the file exist in $revCommit?
4746    # TODO: Include file hash in dirmap cache.
4747    my($dirMap)=$self->getRevisionDirMap($revCommit);
4748    my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%);
4749    if(!defined($dir))
4750    {
4751        $dir="";
4752    }
4753    if( !defined($dirMap->{$dir}) ||
4754        !defined($dirMap->{$dir}{$filename}) )
4755    {
4756        my($fileHash)="deleted";
4757
4758        my($retVal)={};
4759        $retVal->{name}=$filename;
4760        $retVal->{filehash}=$fileHash;
4761
4762            # not needed and difficult to compute:
4763        $retVal->{revision}="0";  # $revision;
4764        $retVal->{commithash}=$revCommit;
4765        #$retVal->{author}=$commit->{author};
4766        #$retVal->{modified}=convertToCvsDate($commit->{date});
4767        #$retVal->{mode}=convertToDbMode($mode);
4768
4769        return $retVal;
4770    }
4771
4772    my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename");
4773    chomp $fileHash;
4774    if(!($fileHash=~/^[0-9a-f]{$state->{hexsz}}$/))
4775    {
4776        die "Invalid fileHash '$fileHash' looking up"
4777                    ." '$revCommit:$filename'\n";
4778    }
4779
4780    # information about most recent commit to modify $filename:
4781    open(my $gitLogPipe, '-|', 'git', 'rev-list',
4782         '--max-count=1', '--pretty', '--parents',
4783         $revCommit, '--', $filename)
4784                or die "Cannot call git-rev-list: $!";
4785    my @commits=readCommits($gitLogPipe);
4786    close $gitLogPipe;
4787    if(scalar(@commits)!=1)
4788    {
4789        die "Can't find most recent commit changing $filename\n";
4790    }
4791    my($commit)=$commits[0];
4792    if( !defined($commit) || !defined($commit->{hash}) )
4793    {
4794        return undef;
4795    }
4796
4797    # does this (commit,file) have a real assigned CVS revision number?
4798    my $tablename_rev = $self->tablename("revision");
4799    my $db_query;
4800    $db_query = $self->{dbh}->prepare_cached(
4801        "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4802        {},1);
4803    $db_query->execute($filename, $commit->{hash});
4804    my($meta)=$db_query->fetchrow_hashref;
4805    if($meta)
4806    {
4807        $meta->{revision} = "1.$meta->{revision}";
4808        return $meta;
4809    }
4810
4811    # fall back on special revision number
4812    my($revision)=$commit->{hash};
4813    $revision=~s/(..)/'.' . (hex($1)+100)/eg;
4814    $revision="2.1.1.2000$revision";
4815
4816    # meta data about $filename:
4817    open(my $filePipe, '-|', 'git', 'ls-tree', '-z',
4818                $commit->{hash}, '--', $filename)
4819            or die("Cannot call git-ls-tree : $!");
4820    local $/ = "\0";
4821    my $line;
4822    $line=<$filePipe>;
4823    if(defined(<$filePipe>))
4824    {
4825        die "Expected only a single file for git-ls-tree $filename\n";
4826    }
4827    close $filePipe;
4828
4829    chomp $line;
4830    unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4831    {
4832        die("Couldn't process git-ls-tree line : $line\n");
4833    }
4834    my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4835
4836    # save result:
4837    my($retVal)={};
4838    $retVal->{name}=$filename;
4839    $retVal->{revision}=$revision;
4840    $retVal->{filehash}=$fileHash;
4841    $retVal->{commithash}=$revCommit;
4842    $retVal->{author}=$commit->{author};
4843    $retVal->{modified}=convertToCvsDate($commit->{date});
4844    $retVal->{mode}=convertToDbMode($mode);
4845
4846    return $retVal;
4847}
4848
4849=head2 lookupCommitRef
4850
4851Convert tag/branch/abbreviation/etc into a commit sha1 hash.  Caches
4852the result so looking it up again is fast.
4853
4854=cut
4855
4856sub lookupCommitRef
4857{
4858    my $self = shift;
4859    my $ref = shift;
4860
4861    my $commitHash = $self->{commitRefCache}{$ref};
4862    if(defined($commitHash))
4863    {
4864        return $commitHash;
4865    }
4866
4867    $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet",
4868				      $self->unescapeRefName($ref));
4869    $commitHash=~s/\s*$//;
4870    if(!($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/))
4871    {
4872        $commitHash=undef;
4873    }
4874
4875    if( defined($commitHash) )
4876    {
4877        my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash);
4878        if( ! ($type=~/^commit\s*$/ ) )
4879        {
4880            $commitHash=undef;
4881        }
4882    }
4883    if(defined($commitHash))
4884    {
4885        $self->{commitRefCache}{$ref}=$commitHash;
4886    }
4887    return $commitHash;
4888}
4889
4890=head2 clearCommitRefCaches
4891
4892Clears cached commit cache (sha1's for various tags/abbeviations/etc),
4893and related caches.
4894
4895=cut
4896
4897sub clearCommitRefCaches
4898{
4899    my $self = shift;
4900    $self->{commitRefCache} = {};
4901    $self->{revisionDirMapCache} = undef;
4902    $self->{gethead_cache} = undef;
4903}
4904
4905=head2 commitmessage
4906
4907this function takes a commithash and returns the commit message for that commit
4908
4909=cut
4910sub commitmessage
4911{
4912    my $self = shift;
4913    my $commithash = shift;
4914    my $tablename = $self->tablename("commitmsgs");
4915
4916    die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
4917
4918    my $db_query;
4919    $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
4920    $db_query->execute($commithash);
4921
4922    my ( $message ) = $db_query->fetchrow_array;
4923
4924    if ( defined ( $message ) )
4925    {
4926        $message .= " " if ( $message =~ /\n$/ );
4927        return $message;
4928    }
4929
4930    my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash);
4931    shift @lines while ( $lines[0] =~ /\S/ );
4932    $message = join("",@lines);
4933    $message .= " " if ( $message =~ /\n$/ );
4934    return $message;
4935}
4936
4937=head2 gethistorydense
4938
4939This function takes a filename (with path) argument and returns an arrayofarrays
4940containing revision,filehash,commithash ordered by revision descending.
4941
4942This version of gethistory skips deleted entries -- so it is useful for annotate.
4943The 'dense' part is a reference to a '--dense' option available for git-rev-list
4944and other git tools that depend on it.
4945
4946See also getlog().
4947
4948=cut
4949sub gethistorydense
4950{
4951    my $self = shift;
4952    my $filename = shift;
4953    my $tablename = $self->tablename("revision");
4954
4955    my $db_query;
4956    $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
4957    $db_query->execute($filename);
4958
4959    my $result = $db_query->fetchall_arrayref;
4960
4961    my $i;
4962    for($i=0 ; $i<scalar(@$result) ; $i++)
4963    {
4964        $result->[$i][0]="1." . $result->[$i][0];
4965    }
4966
4967    return $result;
4968}
4969
4970=head2 escapeRefName
4971
4972Apply an escape mechanism to compensate for characters that
4973git ref names can have that CVS tags can not.
4974
4975=cut
4976sub escapeRefName
4977{
4978    my($self,$refName)=@_;
4979
4980    # CVS officially only allows [-_A-Za-z0-9] in tag names (or in
4981    # many contexts it can also be a CVS revision number).
4982    #
4983    # Git tags commonly use '/' and '.' as well, but also handle
4984    # anything else just in case:
4985    #
4986    #   = "_-s-"  For '/'.
4987    #   = "_-p-"  For '.'.
4988    #   = "_-u-"  For underscore, in case someone wants a literal "_-" in
4989    #     a tag name.
4990    #   = "_-xx-" Where "xx" is the hexadecimal representation of the
4991    #     desired ASCII character byte. (for anything else)
4992
4993    if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/)
4994    {
4995        $refName=~s/_-/_-u--/g;
4996        $refName=~s/\./_-p-/g;
4997        $refName=~s%/%_-s-%g;
4998        $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg;
4999    }
5000}
5001
5002=head2 unescapeRefName
5003
5004Undo an escape mechanism to compensate for characters that
5005git ref names can have that CVS tags can not.
5006
5007=cut
5008sub unescapeRefName
5009{
5010    my($self,$refName)=@_;
5011
5012    # see escapeRefName() for description of escape mechanism.
5013
5014    $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg;
5015
5016    # allowed tag names
5017    # TODO: Perhaps use git check-ref-format, with an in-process cache of
5018    #  validated names?
5019    if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) ||
5020        ( $refName=~m%[/.]$% ) ||
5021        ( $refName=~/\.lock$/ ) ||
5022        ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) )  # matching }
5023    {
5024        # Error:
5025        $log->warn("illegal refName: $refName");
5026        $refName=undef;
5027    }
5028    return $refName;
5029}
5030
5031sub unescapeRefNameChar
5032{
5033    my($char)=@_;
5034
5035    if($char eq "s")
5036    {
5037        $char="/";
5038    }
5039    elsif($char eq "p")
5040    {
5041        $char=".";
5042    }
5043    elsif($char eq "u")
5044    {
5045        $char="_";
5046    }
5047    elsif($char=~/^[0-9a-f][0-9a-f]$/)
5048    {
5049        $char=chr(hex($char));
5050    }
5051    else
5052    {
5053        # Error case: Maybe it has come straight from user, and
5054        # wasn't supposed to be escaped?  Restore it the way we got it:
5055        $char="_-$char-";
5056    }
5057
5058    return $char;
5059}
5060
5061=head2 in_array()
5062
5063from Array::PAT - mimics the in_array() function
5064found in PHP. Yuck but works for small arrays.
5065
5066=cut
5067sub in_array
5068{
5069    my ($check, @array) = @_;
5070    my $retval = 0;
5071    foreach my $test (@array){
5072        if($check eq $test){
5073            $retval =  1;
5074        }
5075    }
5076    return $retval;
5077}
5078
5079=head2 mangle_dirname
5080
5081create a string from a directory name that is suitable to use as
5082part of a filename, mainly by converting all chars except \w.- to _
5083
5084=cut
5085sub mangle_dirname {
5086    my $dirname = shift;
5087    return unless defined $dirname;
5088
5089    $dirname =~ s/[^\w.-]/_/g;
5090
5091    return $dirname;
5092}
5093
5094=head2 mangle_tablename
5095
5096create a string from a that is suitable to use as part of an SQL table
5097name, mainly by converting all chars except \w to _
5098
5099=cut
5100sub mangle_tablename {
5101    my $tablename = shift;
5102    return unless defined $tablename;
5103
5104    $tablename =~ s/[^\w_]/_/g;
5105
5106    return $tablename;
5107}
5108
51091;
5110