Merge branch 'backport/js/ci-gcc-12-fixes'
[git/debian.git] / git-cvsserver.perl
blobf6f3fc192c8713555fa0752c29b0c45146d6ed6c
1 #!/usr/bin/perl
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 ####
18 use 5.008;
19 use strict;
20 use warnings;
21 use bytes;
23 use Fcntl;
24 use File::Temp qw/tempdir tempfile/;
25 use File::Path qw/rmtree/;
26 use File::Basename;
27 use Getopt::Long qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS::log->new();
32 my $cfg;
34 my $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",
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50 $| = 1;
52 #### Definition and mappings of functions ####
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?
58 my $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,
90 ##############################################
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.
95 my $state = { prependdir => '' };
97 # Work is for managing temporary working directory
98 my $work =
100 state => undef, # undef, 1 (empty), 2 (with stuff)
101 workDir => undef,
102 index => undef,
103 emptyDir => undef,
104 tmpDir => undef
107 $log->info("--------------- STARTING -----------------");
109 my $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";
123 my @opts = ( 'h|H', 'version|V',
124 'base-path=s', 'strict-paths', 'export-all' );
125 GetOptions( $state, @opts )
126 or die $usage;
128 if ($state->{version}) {
129 print "git-cvsserver version $VERSION\n";
130 exit;
132 if ($state->{help}) {
133 print $usage;
134 exit;
137 my $TEMP_DIR = tempdir( CLEANUP => 1 );
138 $log->debug("Temporary directory is '$TEMP_DIR'");
140 $state->{method} = 'ext';
141 if (@ARGV) {
142 if ($ARGV[0] eq 'pserver') {
143 $state->{method} = 'pserver';
144 shift @ARGV;
145 } elsif ($ARGV[0] eq 'server') {
146 shift @ARGV;
150 # everything else is a directory
151 $state->{allowed_roots} = [ @ARGV ];
153 # don't export the whole system unless the users requests it
154 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
155 die "--export-all can only be used together with an explicit whitelist\n";
158 # Environment handling for running under git-shell
159 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
160 if ($state->{'base-path'}) {
161 die "Cannot specify base path both ways.\n";
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");
167 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
168 if (@{$state->{allowed_roots}}) {
169 die "Cannot specify roots both ways: @ARGV\n";
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");
176 # if we are called with a pserver argument,
177 # deal with the authentication cat before entering the
178 # main loop
179 if ($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";
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;
190 $line = <STDIN>; chomp $line;
191 my $user = $line;
192 $line = <STDIN>; chomp $line;
193 my $password = $line;
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;
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;
213 my $authdb = $cfg->{gitcvs}->{authdb};
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;
221 my $auth_ok;
222 open my $passwd, "<", $authdb or die $!;
223 while (<$passwd>) {
224 if (m{^\Q$user\E:(.*)}) {
225 if (crypt($user, descramble($password)) eq $1) {
226 $auth_ok = 1;
230 close $passwd;
232 unless ($auth_ok) {
233 print "I HATE YOU\n";
234 exit 1;
237 # Fall through to LOVE
240 # For checking whether the user is anonymous on commit
241 $state->{user} = $user;
243 $line = <STDIN>; chomp $line;
244 unless ($line eq "END $request REQUEST") {
245 die "E Do not understand $line -- expecting END $request REQUEST\n";
247 print "I LOVE YOU\n";
248 exit if $request eq 'VERIFICATION'; # cvs login
249 # and now back to our regular programme...
252 # Keep going until the client closes the connection
253 while (<STDIN>)
255 chomp;
257 # Check to see if we've seen this method, and call appropriate function.
258 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
260 # use the $methods hash to call the appropriate sub for this command
261 #$log->info("Method : $1");
262 &{$methods->{$1}}($1,$2);
263 } else {
264 # log fatal because we don't understand this function. If this happens
265 # we're fairly screwed because we don't know if the client is expecting
266 # a response. If it is, the client will hang, we'll hang, and the whole
267 # thing will be custard.
268 $log->fatal("Don't understand command $_\n");
269 die("Unknown command $_");
273 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
274 $log->info("--------------- FINISH -----------------");
276 chdir '/';
277 exit 0;
279 # Magic catchall method.
280 # This is the method that will handle all commands we haven't yet
281 # implemented. It simply sends a warning to the log file indicating a
282 # command that hasn't been implemented has been invoked.
283 sub req_CATCHALL
285 my ( $cmd, $data ) = @_;
286 $log->warn("Unhandled command : req_$cmd : $data");
289 # This method invariably succeeds with an empty response.
290 sub req_EMPTY
292 print "ok\n";
295 # Root pathname \n
296 # Response expected: no. Tell the server which CVSROOT to use. Note that
297 # pathname is a local directory and not a fully qualified CVSROOT variable.
298 # pathname must already exist; if creating a new root, use the init
299 # request, not Root. pathname does not include the hostname of the server,
300 # how to access the server, etc.; by the time the CVS protocol is in use,
301 # connection, authentication, etc., are already taken care of. The Root
302 # request must be sent only once, and it must be sent before any requests
303 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
304 sub req_Root
306 my ( $cmd, $data ) = @_;
307 $log->debug("req_Root : $data");
309 unless ($data =~ m#^/#) {
310 print "error 1 Root must be an absolute pathname\n";
311 return 0;
314 my $cvsroot = $state->{'base-path'} || '';
315 $cvsroot =~ s#/+$##;
316 $cvsroot .= $data;
318 if ($state->{CVSROOT}
319 && ($state->{CVSROOT} ne $cvsroot)) {
320 print "error 1 Conflicting roots specified\n";
321 return 0;
324 $state->{CVSROOT} = $cvsroot;
326 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
328 if (@{$state->{allowed_roots}}) {
329 my $allowed = 0;
330 foreach my $dir (@{$state->{allowed_roots}}) {
331 next unless $dir =~ m#^/#;
332 $dir =~ s#/+$##;
333 if ($state->{'strict-paths'}) {
334 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
335 $allowed = 1;
336 last;
338 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
339 $allowed = 1;
340 last;
344 unless ($allowed) {
345 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
346 print "E \n";
347 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
348 return 0;
352 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
353 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
354 print "E \n";
355 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
356 return 0;
359 my @gitvars = safe_pipe_capture(qw(git config -l));
360 if ($?) {
361 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
362 print "E \n";
363 print "error 1 - problem executing git-config\n";
364 return 0;
366 foreach my $line ( @gitvars )
368 next unless ( $line =~ /^(gitcvs|extensions)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
369 unless ($2) {
370 $cfg->{$1}{$3} = $4;
371 } else {
372 $cfg->{$1}{$2}{$3} = $4;
376 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
377 || $cfg->{gitcvs}{enabled});
378 unless ($state->{'export-all'} ||
379 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
380 print "E GITCVS emulation needs to be enabled on this repo\n";
381 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
382 print "E \n";
383 print "error 1 GITCVS emulation disabled\n";
384 return 0;
387 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
388 if ( $logfile )
390 $log->setfile($logfile);
391 } else {
392 $log->nofile();
395 $state->{rawsz} = ($cfg->{'extensions'}{'objectformat'} || 'sha1') eq 'sha256' ? 32 : 20;
396 $state->{hexsz} = $state->{rawsz} * 2;
398 return 1;
401 # Global_option option \n
402 # Response expected: no. Transmit one of the global options `-q', `-Q',
403 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
404 # variations (such as combining of options) are allowed. For graceful
405 # handling of valid-requests, it is probably better to make new global
406 # options separate requests, rather than trying to add them to this
407 # request.
408 sub req_Globaloption
410 my ( $cmd, $data ) = @_;
411 $log->debug("req_Globaloption : $data");
412 $state->{globaloptions}{$data} = 1;
415 # Valid-responses request-list \n
416 # Response expected: no. Tell the server what responses the client will
417 # accept. request-list is a space separated list of tokens.
418 sub req_Validresponses
420 my ( $cmd, $data ) = @_;
421 $log->debug("req_Validresponses : $data");
423 # TODO : re-enable this, currently it's not particularly useful
424 #$state->{validresponses} = [ split /\s+/, $data ];
427 # valid-requests \n
428 # Response expected: yes. Ask the server to send back a Valid-requests
429 # response.
430 sub req_validrequests
432 my ( $cmd, $data ) = @_;
434 $log->debug("req_validrequests");
436 $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
437 $log->debug("SEND : ok");
439 print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
440 print "ok\n";
443 # Directory local-directory \n
444 # Additional data: repository \n. Response expected: no. Tell the server
445 # what directory to use. The repository should be a directory name from a
446 # previous server response. Note that this both gives a default for Entry
447 # and Modified and also for ci and the other commands; normal usage is to
448 # send Directory for each directory in which there will be an Entry or
449 # Modified, and then a final Directory for the original directory, then the
450 # command. The local-directory is relative to the top level at which the
451 # command is occurring (i.e. the last Directory which is sent before the
452 # command); to indicate that top level, `.' should be sent for
453 # local-directory.
454 sub req_Directory
456 my ( $cmd, $data ) = @_;
458 my $repository = <STDIN>;
459 chomp $repository;
462 $state->{localdir} = $data;
463 $state->{repository} = $repository;
464 $state->{path} = $repository;
465 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
466 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
467 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
469 $state->{directory} = $state->{localdir};
470 $state->{directory} = "" if ( $state->{directory} eq "." );
471 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
473 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
475 $log->info("Setting prepend to '$state->{path}'");
476 $state->{prependdir} = $state->{path};
477 my %entries;
478 foreach my $entry ( keys %{$state->{entries}} )
480 $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry};
482 $state->{entries}=\%entries;
484 my %dirMap;
485 foreach my $dir ( keys %{$state->{dirMap}} )
487 $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir};
489 $state->{dirMap}=\%dirMap;
492 if ( defined ( $state->{prependdir} ) )
494 $log->debug("Prepending '$state->{prependdir}' to state|directory");
495 $state->{directory} = $state->{prependdir} . $state->{directory}
498 if ( ! defined($state->{dirMap}{$state->{directory}}) )
500 $state->{dirMap}{$state->{directory}} =
502 'names' => {}
503 #'tagspec' => undef
507 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
510 # Sticky tagspec \n
511 # Response expected: no. Tell the server that the directory most
512 # recently specified with Directory has a sticky tag or date
513 # tagspec. The first character of tagspec is T for a tag, D for
514 # a date, or some other character supplied by a Set-sticky
515 # response from a previous request to the server. The remainder
516 # of tagspec contains the actual tag or date, again as supplied
517 # by Set-sticky.
518 # The server should remember Static-directory and Sticky requests
519 # for a particular directory; the client need not resend them each
520 # time it sends a Directory request for a given directory. However,
521 # the server is not obliged to remember them beyond the context
522 # of a single command.
523 sub req_Sticky
525 my ( $cmd, $tagspec ) = @_;
527 my ( $stickyInfo );
528 if($tagspec eq "")
530 # nothing
532 elsif($tagspec=~/^T([^ ]+)\s*$/)
534 $stickyInfo = { 'tag' => $1 };
536 elsif($tagspec=~/^D([0-9.]+)\s*$/)
538 $stickyInfo= { 'date' => $1 };
540 else
542 die "Unknown tag_or_date format\n";
544 $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo;
546 $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
547 . " path=$state->{path} directory=$state->{directory}"
548 . " module=$state->{module}");
551 # Entry entry-line \n
552 # Response expected: no. Tell the server what version of a file is on the
553 # local machine. The name in entry-line is a name relative to the directory
554 # most recently specified with Directory. If the user is operating on only
555 # some files in a directory, Entry requests for only those files need be
556 # included. If an Entry request is sent without Modified, Is-modified, or
557 # Unchanged, it means the file is lost (does not exist in the working
558 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
559 # are sent for the same file, Entry must be sent first. For a given file,
560 # one can send Modified, Is-modified, or Unchanged, but not more than one
561 # of these three.
562 sub req_Entry
564 my ( $cmd, $data ) = @_;
566 #$log->debug("req_Entry : $data");
568 my @data = split(/\//, $data, -1);
570 $state->{entries}{$state->{directory}.$data[1]} = {
571 revision => $data[2],
572 conflict => $data[3],
573 options => $data[4],
574 tag_or_date => $data[5],
577 $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F';
579 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
582 # Questionable filename \n
583 # Response expected: no. Additional data: no. Tell the server to check
584 # whether filename should be ignored, and if not, next time the server
585 # sends responses, send (in a M response) `?' followed by the directory and
586 # filename. filename must not contain `/'; it needs to be a file in the
587 # directory named by the most recent Directory request.
588 sub req_Questionable
590 my ( $cmd, $data ) = @_;
592 $log->debug("req_Questionable : $data");
593 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
596 # add \n
597 # Response expected: yes. Add a file or directory. This uses any previous
598 # Argument, Directory, Entry, or Modified requests, if they have been sent.
599 # The last Directory sent specifies the working directory at the time of
600 # the operation. To add a directory, send the directory to be added using
601 # Directory and Argument requests.
602 sub req_add
604 my ( $cmd, $data ) = @_;
606 argsplit("add");
608 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
609 $updater->update();
611 my $addcount = 0;
613 foreach my $filename ( @{$state->{args}} )
615 $filename = filecleanup($filename);
617 # no -r, -A, or -D with add
618 my $stickyInfo = resolveStickyInfo($filename);
620 my $meta = $updater->getmeta($filename,$stickyInfo);
621 my $wrev = revparse($filename);
623 if ($wrev && $meta && ($wrev=~/^-/))
625 # previously removed file, add back
626 $log->info("added file $filename was previously removed, send $meta->{revision}");
628 print "MT +updated\n";
629 print "MT text U \n";
630 print "MT fname $filename\n";
631 print "MT newline\n";
632 print "MT -updated\n";
634 unless ( $state->{globaloptions}{-n} )
636 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
638 print "Created $dirpart\n";
639 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
641 # this is an "entries" line
642 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
643 my $entryLine = "/$filepart/$meta->{revision}//$kopts/";
644 $entryLine .= getStickyTagOrDate($stickyInfo);
645 $log->debug($entryLine);
646 print "$entryLine\n";
647 # permissions
648 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
649 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
650 # transmit file
651 transmitfile($meta->{filehash});
654 next;
657 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
659 print "E cvs add: nothing known about `$filename'\n";
660 next;
662 # TODO : check we're not squashing an already existing file
663 if ( defined ( $state->{entries}{$filename}{revision} ) )
665 print "E cvs add: `$filename' has already been entered\n";
666 next;
669 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
671 print "E cvs add: scheduling file `$filename' for addition\n";
673 print "Checked-in $dirpart\n";
674 print "$filename\n";
675 my $kopts = kopts_from_path($filename,"file",
676 $state->{entries}{$filename}{modified_filename});
677 print "/$filepart/0//$kopts/" .
678 getStickyTagOrDate($stickyInfo) . "\n";
680 my $requestedKopts = $state->{opt}{k};
681 if(defined($requestedKopts))
683 $requestedKopts = "-k$requestedKopts";
685 else
687 $requestedKopts = "";
689 if( $kopts ne $requestedKopts )
691 $log->warn("Ignoring requested -k='$requestedKopts'"
692 . " for '$filename'; detected -k='$kopts' instead");
693 #TODO: Also have option to send warning to user?
696 $addcount++;
699 if ( $addcount == 1 )
701 print "E cvs add: use `cvs commit' to add this file permanently\n";
703 elsif ( $addcount > 1 )
705 print "E cvs add: use `cvs commit' to add these files permanently\n";
708 print "ok\n";
711 # remove \n
712 # Response expected: yes. Remove a file. This uses any previous Argument,
713 # Directory, Entry, or Modified requests, if they have been sent. The last
714 # Directory sent specifies the working directory at the time of the
715 # operation. Note that this request does not actually do anything to the
716 # repository; the only effect of a successful remove request is to supply
717 # the client with a new entries line containing `-' to indicate a removed
718 # file. In fact, the client probably could perform this operation without
719 # contacting the server, although using remove may cause the server to
720 # perform a few more checks. The client sends a subsequent ci request to
721 # actually record the removal in the repository.
722 sub req_remove
724 my ( $cmd, $data ) = @_;
726 argsplit("remove");
728 # Grab a handle to the SQLite db and do any necessary updates
729 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
730 $updater->update();
732 #$log->debug("add state : " . Dumper($state));
734 my $rmcount = 0;
736 foreach my $filename ( @{$state->{args}} )
738 $filename = filecleanup($filename);
740 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
742 print "E cvs remove: file `$filename' still in working directory\n";
743 next;
746 # only from entries
747 my $stickyInfo = resolveStickyInfo($filename);
749 my $meta = $updater->getmeta($filename,$stickyInfo);
750 my $wrev = revparse($filename);
752 unless ( defined ( $wrev ) )
754 print "E cvs remove: nothing known about `$filename'\n";
755 next;
758 if ( defined($wrev) and ($wrev=~/^-/) )
760 print "E cvs remove: file `$filename' already scheduled for removal\n";
761 next;
764 unless ( $wrev eq $meta->{revision} )
766 # TODO : not sure if the format of this message is quite correct.
767 print "E cvs remove: Up to date check failed for `$filename'\n";
768 next;
772 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
774 print "E cvs remove: scheduling `$filename' for removal\n";
776 print "Checked-in $dirpart\n";
777 print "$filename\n";
778 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
779 print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate($stickyInfo) . "\n";
781 $rmcount++;
784 if ( $rmcount == 1 )
786 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
788 elsif ( $rmcount > 1 )
790 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
793 print "ok\n";
796 # Modified filename \n
797 # Response expected: no. Additional data: mode, \n, file transmission. Send
798 # the server a copy of one locally modified file. filename is a file within
799 # the most recent directory sent with Directory; it must not contain `/'.
800 # If the user is operating on only some files in a directory, only those
801 # files need to be included. This can also be sent without Entry, if there
802 # is no entry for the file.
803 sub req_Modified
805 my ( $cmd, $data ) = @_;
807 my $mode = <STDIN>;
808 defined $mode
809 or (print "E end of file reading mode for $data\n"), return;
810 chomp $mode;
811 my $size = <STDIN>;
812 defined $size
813 or (print "E end of file reading size of $data\n"), return;
814 chomp $size;
816 # Grab config information
817 my $blocksize = 8192;
818 my $bytesleft = $size;
819 my $tmp;
821 # Get a filehandle/name to write it to
822 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
824 # Loop over file data writing out to temporary file.
825 while ( $bytesleft )
827 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
828 read STDIN, $tmp, $blocksize;
829 print $fh $tmp;
830 $bytesleft -= $blocksize;
833 close $fh
834 or (print "E failed to write temporary, $filename: $!\n"), return;
836 # Ensure we have something sensible for the file mode
837 if ( $mode =~ /u=(\w+)/ )
839 $mode = $1;
840 } else {
841 $mode = "rw";
844 # Save the file data in $state
845 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
846 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
847 $state->{entries}{$state->{directory}.$data}{modified_hash} = safe_pipe_capture('git','hash-object',$filename);
848 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
850 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
853 # Unchanged filename \n
854 # Response expected: no. Tell the server that filename has not been
855 # modified in the checked out directory. The filename is a file within the
856 # most recent directory sent with Directory; it must not contain `/'.
857 sub req_Unchanged
859 my ( $cmd, $data ) = @_;
861 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
863 #$log->debug("req_Unchanged : $data");
866 # Argument text \n
867 # Response expected: no. Save argument for use in a subsequent command.
868 # Arguments accumulate until an argument-using command is given, at which
869 # point they are forgotten.
870 # Argumentx text \n
871 # Response expected: no. Append \n followed by text to the current argument
872 # being saved.
873 sub req_Argument
875 my ( $cmd, $data ) = @_;
877 # Argumentx means: append to last Argument (with a newline in front)
879 $log->debug("$cmd : $data");
881 if ( $cmd eq 'Argumentx') {
882 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
883 } else {
884 push @{$state->{arguments}}, $data;
888 # expand-modules \n
889 # Response expected: yes. Expand the modules which are specified in the
890 # arguments. Returns the data in Module-expansion responses. Note that the
891 # server can assume that this is checkout or export, not rtag or rdiff; the
892 # latter do not access the working directory and thus have no need to
893 # expand modules on the client side. Expand may not be the best word for
894 # what this request does. It does not necessarily tell you all the files
895 # contained in a module, for example. Basically it is a way of telling you
896 # which working directories the server needs to know about in order to
897 # handle a checkout of the specified modules. For example, suppose that the
898 # server has a module defined by
899 # aliasmodule -a 1dir
900 # That is, one can check out aliasmodule and it will take 1dir in the
901 # repository and check it out to 1dir in the working directory. Now suppose
902 # the client already has this module checked out and is planning on using
903 # the co request to update it. Without using expand-modules, the client
904 # would have two bad choices: it could either send information about all
905 # working directories under the current directory, which could be
906 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
907 # stands for 1dir, and neglect to send information for 1dir, which would
908 # lead to incorrect operation. With expand-modules, the client would first
909 # ask for the module to be expanded:
910 sub req_expandmodules
912 my ( $cmd, $data ) = @_;
914 argsplit();
916 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
918 unless ( ref $state->{arguments} eq "ARRAY" )
920 print "ok\n";
921 return;
924 foreach my $module ( @{$state->{arguments}} )
926 $log->debug("SEND : Module-expansion $module");
927 print "Module-expansion $module\n";
930 print "ok\n";
931 statecleanup();
934 # co \n
935 # Response expected: yes. Get files from the repository. This uses any
936 # previous Argument, Directory, Entry, or Modified requests, if they have
937 # been sent. Arguments to this command are module names; the client cannot
938 # know what directories they correspond to except by (1) just sending the
939 # co request, and then seeing what directory names the server sends back in
940 # its responses, and (2) the expand-modules request.
941 sub req_co
943 my ( $cmd, $data ) = @_;
945 argsplit("co");
947 # Provide list of modules, if -c was used.
948 if (exists $state->{opt}{c}) {
949 my $showref = safe_pipe_capture(qw(git show-ref --heads));
950 for my $line (split '\n', $showref) {
951 if ( $line =~ m% refs/heads/(.*)$% ) {
952 print "M $1\t$1\n";
955 print "ok\n";
956 return 1;
959 my $stickyInfo = { 'tag' => $state->{opt}{r},
960 'date' => $state->{opt}{D} };
962 my $module = $state->{args}[0];
963 $state->{module} = $module;
964 my $checkout_path = $module;
966 # use the user specified directory if we're given it
967 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
969 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
971 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
973 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
975 # Grab a handle to the SQLite db and do any necessary updates
976 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
977 $updater->update();
979 my $headHash;
980 if( defined($stickyInfo) && defined($stickyInfo->{tag}) )
982 $headHash = $updater->lookupCommitRef($stickyInfo->{tag});
983 if( !defined($headHash) )
985 print "error 1 no such tag `$stickyInfo->{tag}'\n";
986 cleanupWorkTree();
987 exit;
991 $checkout_path =~ s|/$||; # get rid of trailing slashes
993 my %seendirs = ();
994 my $lastdir ='';
996 prepDirForOutput(
997 ".",
998 $state->{CVSROOT} . "/$module",
999 $checkout_path,
1000 \%seendirs,
1001 'checkout',
1002 $state->{dirArgs} );
1004 foreach my $git ( @{$updater->getAnyHead($headHash)} )
1006 # Don't want to check out deleted files
1007 next if ( $git->{filehash} eq "deleted" );
1009 my $fullName = $git->{name};
1010 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
1012 unless (exists($seendirs{$git->{dir}})) {
1013 prepDirForOutput($git->{dir}, $state->{CVSROOT} . "/$module/",
1014 $checkout_path, \%seendirs, 'checkout',
1015 $state->{dirArgs} );
1016 $lastdir = $git->{dir};
1017 $seendirs{$git->{dir}} = 1;
1020 # modification time of this file
1021 print "Mod-time $git->{modified}\n";
1023 # print some information to the client
1024 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
1026 print "M U $checkout_path/$git->{dir}$git->{name}\n";
1027 } else {
1028 print "M U $checkout_path/$git->{name}\n";
1031 # instruct client we're sending a file to put in this path
1032 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
1034 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
1036 # this is an "entries" line
1037 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
1038 print "/$git->{name}/$git->{revision}//$kopts/" .
1039 getStickyTagOrDate($stickyInfo) . "\n";
1040 # permissions
1041 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1043 # transmit file
1044 transmitfile($git->{filehash});
1047 print "ok\n";
1049 statecleanup();
1052 # used by req_co and req_update to set up directories for files
1053 # recursively handles parents
1054 sub prepDirForOutput
1056 my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
1058 my $parent = dirname($dir);
1059 $dir =~ s|/+$||;
1060 $repodir =~ s|/+$||;
1061 $remotedir =~ s|/+$||;
1062 $parent =~ s|/+$||;
1064 if ($parent eq '.' || $parent eq './')
1066 $parent = '';
1068 # recurse to announce unseen parents first
1069 if( length($parent) &&
1070 !exists($seendirs->{$parent}) &&
1071 ( $request eq "checkout" ||
1072 exists($dirArgs->{$parent}) ) )
1074 prepDirForOutput($parent, $repodir, $remotedir,
1075 $seendirs, $request, $dirArgs);
1077 # Announce that we are going to modify at the parent level
1078 if ($dir eq '.' || $dir eq './')
1080 $dir = '';
1082 if(exists($seendirs->{$dir}))
1084 return;
1086 $log->debug("announcedir $dir, $repodir, $remotedir" );
1087 my($thisRemoteDir,$thisRepoDir);
1088 if ($dir ne "")
1090 $thisRepoDir="$repodir/$dir";
1091 if($remotedir eq ".")
1093 $thisRemoteDir=$dir;
1095 else
1097 $thisRemoteDir="$remotedir/$dir";
1100 else
1102 $thisRepoDir=$repodir;
1103 $thisRemoteDir=$remotedir;
1105 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1107 print "E cvs $request: Updating $thisRemoteDir\n";
1110 my ($opt_r)=$state->{opt}{r};
1111 my $stickyInfo;
1112 if(exists($state->{opt}{A}))
1114 # $stickyInfo=undef;
1116 elsif( defined($opt_r) && $opt_r ne "" )
1117 # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
1119 $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) };
1121 # TODO: Convert -D value into the form 2011.04.10.04.46.57,
1122 # similar to an entry line's sticky date, without the D prefix.
1123 # It sometimes (always?) arrives as something more like
1124 # '10 Apr 2011 04:46:57 -0000'...
1125 # $stickyInfo={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
1127 else
1129 $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir);
1132 my $stickyResponse;
1133 if(defined($stickyInfo))
1135 $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
1136 "$thisRepoDir/\n" .
1137 getStickyTagOrDate($stickyInfo) . "\n";
1139 else
1141 $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
1142 "$thisRepoDir/\n";
1145 unless ( $state->{globaloptions}{-n} )
1147 print $stickyResponse;
1149 print "Clear-static-directory $thisRemoteDir/\n";
1150 print "$thisRepoDir/\n";
1151 print $stickyResponse; # yes, twice
1152 print "Template $thisRemoteDir/\n";
1153 print "$thisRepoDir/\n";
1154 print "0\n";
1157 $seendirs->{$dir} = 1;
1159 # FUTURE: This would more accurately emulate CVS by sending
1160 # another copy of sticky after processing the files in that
1161 # directory. Or intermediate: perhaps send all sticky's for
1162 # $seendirs after processing all files.
1165 # update \n
1166 # Response expected: yes. Actually do a cvs update command. This uses any
1167 # previous Argument, Directory, Entry, or Modified requests, if they have
1168 # been sent. The last Directory sent specifies the working directory at the
1169 # time of the operation. The -I option is not used--files which the client
1170 # can decide whether to ignore are not mentioned and the client sends the
1171 # Questionable request for others.
1172 sub req_update
1174 my ( $cmd, $data ) = @_;
1176 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1178 argsplit("update");
1181 # It may just be a client exploring the available heads/modules
1182 # in that case, list them as top level directories and leave it
1183 # at that. Eclipse uses this technique to offer you a list of
1184 # projects (heads in this case) to checkout.
1186 if ($state->{module} eq '') {
1187 my $showref = safe_pipe_capture(qw(git show-ref --heads));
1188 print "E cvs update: Updating .\n";
1189 for my $line (split '\n', $showref) {
1190 if ( $line =~ m% refs/heads/(.*)$% ) {
1191 print "E cvs update: New directory `$1'\n";
1194 print "ok\n";
1195 return 1;
1199 # Grab a handle to the SQLite db and do any necessary updates
1200 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1202 $updater->update();
1204 argsfromdir($updater);
1206 #$log->debug("update state : " . Dumper($state));
1208 my($repoDir);
1209 $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}";
1211 my %seendirs = ();
1213 # foreach file specified on the command line ...
1214 foreach my $argsFilename ( @{$state->{args}} )
1216 my $filename;
1217 $filename = filecleanup($argsFilename);
1219 $log->debug("Processing file $filename");
1221 # if we have a -C we should pretend we never saw modified stuff
1222 if ( exists ( $state->{opt}{C} ) )
1224 delete $state->{entries}{$filename}{modified_hash};
1225 delete $state->{entries}{$filename}{modified_filename};
1226 $state->{entries}{$filename}{unchanged} = 1;
1229 my $stickyInfo = resolveStickyInfo($filename,
1230 $state->{opt}{r},
1231 $state->{opt}{D},
1232 exists($state->{opt}{A}));
1233 my $meta = $updater->getmeta($filename, $stickyInfo);
1235 # If -p was given, "print" the contents of the requested revision.
1236 if ( exists ( $state->{opt}{p} ) ) {
1237 if ( defined ( $meta->{revision} ) ) {
1238 $log->info("Printing '$filename' revision " . $meta->{revision});
1240 transmitfile($meta->{filehash}, { print => 1 });
1243 next;
1246 # Directories:
1247 prepDirForOutput(
1248 dirname($argsFilename),
1249 $repoDir,
1250 ".",
1251 \%seendirs,
1252 "update",
1253 $state->{dirArgs} );
1255 my $wrev = revparse($filename);
1257 if ( ! defined $meta )
1259 $meta = {
1260 name => $filename,
1261 revision => '0',
1262 filehash => 'added'
1264 if($wrev ne "0")
1266 $meta->{filehash}='deleted';
1270 my $oldmeta = $meta;
1272 # If the working copy is an old revision, lets get that version too for comparison.
1273 my $oldWrev=$wrev;
1274 if(defined($oldWrev))
1276 $oldWrev=~s/^-//;
1277 if($oldWrev ne $meta->{revision})
1279 $oldmeta = $updater->getmeta($filename, $oldWrev);
1283 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1285 # Files are up to date if the working copy and repo copy have the same revision,
1286 # and the working copy is unmodified _and_ the user hasn't specified -C
1287 next if ( defined ( $wrev )
1288 and defined($meta->{revision})
1289 and $wrev eq $meta->{revision}
1290 and $state->{entries}{$filename}{unchanged}
1291 and not exists ( $state->{opt}{C} ) );
1293 # If the working copy and repo copy have the same revision,
1294 # but the working copy is modified, tell the client it's modified
1295 if ( defined ( $wrev )
1296 and defined($meta->{revision})
1297 and $wrev eq $meta->{revision}
1298 and $wrev ne "0"
1299 and defined($state->{entries}{$filename}{modified_hash})
1300 and not exists ( $state->{opt}{C} ) )
1302 $log->info("Tell the client the file is modified");
1303 print "MT text M \n";
1304 print "MT fname $filename\n";
1305 print "MT newline\n";
1306 next;
1309 if ( $meta->{filehash} eq "deleted" && $wrev ne "0" )
1311 # TODO: If it has been modified in the sandbox, error out
1312 # with the appropriate message, rather than deleting a modified
1313 # file.
1315 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1317 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1319 print "E cvs update: `$filename' is no longer in the repository\n";
1320 # Don't want to actually _DO_ the update if -n specified
1321 unless ( $state->{globaloptions}{-n} ) {
1322 print "Removed $dirpart\n";
1323 print "$filepart\n";
1326 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1327 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1328 or $meta->{filehash} eq 'added' )
1330 # normal update, just send the new revision (either U=Update,
1331 # or A=Add, or R=Remove)
1332 if ( defined($wrev) && ($wrev=~/^-/) )
1334 $log->info("Tell the client the file is scheduled for removal");
1335 print "MT text R \n";
1336 print "MT fname $filename\n";
1337 print "MT newline\n";
1338 next;
1340 elsif ( (!defined($wrev) || $wrev eq '0') &&
1341 (!defined($meta->{revision}) || $meta->{revision} eq '0') )
1343 $log->info("Tell the client the file is scheduled for addition");
1344 print "MT text A \n";
1345 print "MT fname $filename\n";
1346 print "MT newline\n";
1347 next;
1350 else {
1351 $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
1352 print "MT +updated\n";
1353 print "MT text U \n";
1354 print "MT fname $filename\n";
1355 print "MT newline\n";
1356 print "MT -updated\n";
1359 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1361 # Don't want to actually _DO_ the update if -n specified
1362 unless ( $state->{globaloptions}{-n} )
1364 if ( defined ( $wrev ) )
1366 # instruct client we're sending a file to put in this path as a replacement
1367 print "Update-existing $dirpart\n";
1368 $log->debug("Updating existing file 'Update-existing $dirpart'");
1369 } else {
1370 # instruct client we're sending a file to put in this path as a new file
1372 $log->debug("Creating new file 'Created $dirpart'");
1373 print "Created $dirpart\n";
1375 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1377 # this is an "entries" line
1378 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1379 my $entriesLine = "/$filepart/$meta->{revision}//$kopts/";
1380 $entriesLine .= getStickyTagOrDate($stickyInfo);
1381 $log->debug($entriesLine);
1382 print "$entriesLine\n";
1384 # permissions
1385 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1386 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1388 # transmit file
1389 transmitfile($meta->{filehash});
1391 } else {
1392 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1394 my $mergeDir = setupTmpDir();
1396 my $file_local = $filepart . ".mine";
1397 my $mergedFile = "$mergeDir/$file_local";
1398 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1399 my $file_old = $filepart . "." . $oldmeta->{revision};
1400 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1401 my $file_new = $filepart . "." . $meta->{revision};
1402 transmitfile($meta->{filehash}, { targetfile => $file_new });
1404 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1405 $log->info("Merging $file_local, $file_old, $file_new");
1406 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
1408 $log->debug("Temporary directory for merge is $mergeDir");
1410 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1411 $return >>= 8;
1413 cleanupTmpDir();
1415 if ( $return == 0 )
1417 $log->info("Merged successfully");
1418 print "M M $filename\n";
1419 $log->debug("Merged $dirpart");
1421 # Don't want to actually _DO_ the update if -n specified
1422 unless ( $state->{globaloptions}{-n} )
1424 print "Merged $dirpart\n";
1425 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1426 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1427 my $kopts = kopts_from_path("$dirpart/$filepart",
1428 "file",$mergedFile);
1429 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1430 my $entriesLine="/$filepart/$meta->{revision}//$kopts/";
1431 $entriesLine .= getStickyTagOrDate($stickyInfo);
1432 print "$entriesLine\n";
1435 elsif ( $return == 1 )
1437 $log->info("Merged with conflicts");
1438 print "E cvs update: conflicts found in $filename\n";
1439 print "M C $filename\n";
1441 # Don't want to actually _DO_ the update if -n specified
1442 unless ( $state->{globaloptions}{-n} )
1444 print "Merged $dirpart\n";
1445 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1446 my $kopts = kopts_from_path("$dirpart/$filepart",
1447 "file",$mergedFile);
1448 my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/";
1449 $entriesLine .= getStickyTagOrDate($stickyInfo);
1450 print "$entriesLine\n";
1453 else
1455 $log->warn("Merge failed");
1456 next;
1459 # Don't want to actually _DO_ the update if -n specified
1460 unless ( $state->{globaloptions}{-n} )
1462 # permissions
1463 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1464 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1466 # transmit file, format is single integer on a line by itself (file
1467 # size) followed by the file contents
1468 # TODO : we should copy files in blocks
1469 my $data = safe_pipe_capture('cat', $mergedFile);
1470 $log->debug("File size : " . length($data));
1471 print length($data) . "\n";
1472 print $data;
1478 # prepDirForOutput() any other existing directories unless they already
1479 # have the right sticky tag:
1480 unless ( $state->{globaloptions}{n} )
1482 my $dir;
1483 foreach $dir (keys(%{$state->{dirMap}}))
1485 if( ! $seendirs{$dir} &&
1486 exists($state->{dirArgs}{$dir}) )
1488 my($oldTag);
1489 $oldTag=$state->{dirMap}{$dir}{tagspec};
1491 unless( ( exists($state->{opt}{A}) &&
1492 defined($oldTag) ) ||
1493 ( defined($state->{opt}{r}) &&
1494 ( !defined($oldTag) ||
1495 $state->{opt}{r} ne $oldTag ) ) )
1496 # TODO?: OR sticky dir is different...
1498 next;
1501 prepDirForOutput(
1502 $dir,
1503 $repoDir,
1504 ".",
1505 \%seendirs,
1506 'update',
1507 $state->{dirArgs} );
1510 # TODO?: Consider sending a final duplicate Sticky response
1511 # to more closely mimic real CVS.
1515 print "ok\n";
1518 sub req_ci
1520 my ( $cmd, $data ) = @_;
1522 argsplit("ci");
1524 #$log->debug("State : " . Dumper($state));
1526 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1528 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1530 print "error 1 anonymous user cannot commit via pserver\n";
1531 cleanupWorkTree();
1532 exit;
1535 if ( -e $state->{CVSROOT} . "/index" )
1537 $log->warn("file 'index' already exists in the git repository");
1538 print "error 1 Index already exists in git repo\n";
1539 cleanupWorkTree();
1540 exit;
1543 # Grab a handle to the SQLite db and do any necessary updates
1544 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1545 $updater->update();
1547 my @committedfiles = ();
1548 my %oldmeta;
1549 my $stickyInfo;
1550 my $branchRef;
1551 my $parenthash;
1553 # foreach file specified on the command line ...
1554 foreach my $filename ( @{$state->{args}} )
1556 my $committedfile = $filename;
1557 $filename = filecleanup($filename);
1559 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1561 #####
1562 # Figure out which branch and parenthash we are committing
1563 # to, and setup worktree:
1565 # should always come from entries:
1566 my $fileStickyInfo = resolveStickyInfo($filename);
1567 if( !defined($branchRef) )
1569 $stickyInfo = $fileStickyInfo;
1570 if( defined($stickyInfo) &&
1571 ( defined($stickyInfo->{date}) ||
1572 !defined($stickyInfo->{tag}) ) )
1574 print "error 1 cannot commit with sticky date for file `$filename'\n";
1575 cleanupWorkTree();
1576 exit;
1579 $branchRef = "refs/heads/$state->{module}";
1580 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1582 $branchRef = "refs/heads/$stickyInfo->{tag}";
1585 $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef);
1586 chomp $parenthash;
1587 if ($parenthash !~ /^[0-9a-f]{$state->{hexsz}}$/)
1589 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1591 print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
1593 else
1595 print "error 1 pserver cannot find the current HEAD of module";
1597 cleanupWorkTree();
1598 exit;
1601 setupWorkTree($parenthash);
1603 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1605 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1607 elsif( !refHashEqual($stickyInfo,$fileStickyInfo) )
1609 #TODO: We could split the cvs commit into multiple
1610 # git commits by distinct stickyTag values, but that
1611 # is lowish priority.
1612 print "error 1 Committing different files to different"
1613 . " branches is not currently supported\n";
1614 cleanupWorkTree();
1615 exit;
1618 #####
1619 # Process this file:
1621 my $meta = $updater->getmeta($filename,$stickyInfo);
1622 $oldmeta{$filename} = $meta;
1624 my $wrev = revparse($filename);
1626 my ( $filepart, $dirpart ) = filenamesplit($filename);
1628 # do a checkout of the file if it is part of this tree
1629 if ($wrev) {
1630 system('git', 'checkout-index', '-f', '-u', $filename);
1631 unless ($? == 0) {
1632 die "Error running git-checkout-index -f -u $filename : $!";
1636 my $addflag = 0;
1637 my $rmflag = 0;
1638 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1639 $addflag = 1 unless ( -e $filename );
1641 # Do up to date checking
1642 unless ( $addflag or $wrev eq $meta->{revision} or
1643 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
1645 # fail everything if an up to date check fails
1646 print "error 1 Up to date check failed for $filename\n";
1647 cleanupWorkTree();
1648 exit;
1651 push @committedfiles, $committedfile;
1652 $log->info("Committing $filename");
1654 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1656 unless ( $rmflag )
1658 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1659 rename $state->{entries}{$filename}{modified_filename},$filename;
1661 # Calculate modes to remove
1662 my $invmode = "";
1663 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1665 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1666 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1669 if ( $rmflag )
1671 $log->info("Removing file '$filename'");
1672 unlink($filename);
1673 system("git", "update-index", "--remove", $filename);
1675 elsif ( $addflag )
1677 $log->info("Adding file '$filename'");
1678 system("git", "update-index", "--add", $filename);
1679 } else {
1680 $log->info("UpdatingX2 file '$filename'");
1681 system("git", "update-index", $filename);
1685 unless ( scalar(@committedfiles) > 0 )
1687 print "E No files to commit\n";
1688 print "ok\n";
1689 cleanupWorkTree();
1690 return;
1693 my $treehash = safe_pipe_capture(qw(git write-tree));
1694 chomp $treehash;
1696 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1698 # write our commit message out if we have one ...
1699 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1700 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1701 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1702 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1703 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1705 } else {
1706 print $msg_fh "\n\nvia git-CVS emulator\n";
1708 close $msg_fh;
1710 my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
1711 chomp($commithash);
1712 $log->info("Commit hash : $commithash");
1714 unless ( $commithash =~ /[a-zA-Z0-9]{$state->{hexsz}}/ )
1716 $log->warn("Commit failed (Invalid commit hash)");
1717 print "error 1 Commit failed (unknown reason)\n";
1718 cleanupWorkTree();
1719 exit;
1722 ### Emulate git-receive-pack by running hooks/update
1723 my @hook = ( $ENV{GIT_DIR}.'hooks/update', $branchRef,
1724 $parenthash, $commithash );
1725 if( -x $hook[0] ) {
1726 unless( system( @hook ) == 0 )
1728 $log->warn("Commit failed (update hook declined to update ref)");
1729 print "error 1 Commit failed (update hook declined)\n";
1730 cleanupWorkTree();
1731 exit;
1735 ### Update the ref
1736 if (system(qw(git update-ref -m), "cvsserver ci",
1737 $branchRef, $commithash, $parenthash)) {
1738 $log->warn("update-ref for $state->{module} failed.");
1739 print "error 1 Cannot commit -- update first\n";
1740 cleanupWorkTree();
1741 exit;
1744 ### Emulate git-receive-pack by running hooks/post-receive
1745 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1746 if( -x $hook ) {
1747 open(my $pipe, "| $hook") || die "can't fork $!";
1749 local $SIG{PIPE} = sub { die 'pipe broke' };
1751 print $pipe "$parenthash $commithash $branchRef\n";
1753 close $pipe || die "bad pipe: $! $?";
1756 $updater->update();
1758 ### Then hooks/post-update
1759 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1760 if (-x $hook) {
1761 system($hook, $branchRef);
1764 # foreach file specified on the command line ...
1765 foreach my $filename ( @committedfiles )
1767 $filename = filecleanup($filename);
1769 my $meta = $updater->getmeta($filename,$stickyInfo);
1770 unless (defined $meta->{revision}) {
1771 $meta->{revision} = "1.1";
1774 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1776 $log->debug("Checked-in $dirpart : $filename");
1778 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1779 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1781 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
1782 print "Remove-entry $dirpart\n";
1783 print "$filename\n";
1784 } else {
1785 if ($meta->{revision} eq "1.1") {
1786 print "M initial revision: 1.1\n";
1787 } else {
1788 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
1790 print "Checked-in $dirpart\n";
1791 print "$filename\n";
1792 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1793 print "/$filepart/$meta->{revision}//$kopts/" .
1794 getStickyTagOrDate($stickyInfo) . "\n";
1798 cleanupWorkTree();
1799 print "ok\n";
1802 sub req_status
1804 my ( $cmd, $data ) = @_;
1806 argsplit("status");
1808 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1809 #$log->debug("status state : " . Dumper($state));
1811 # Grab a handle to the SQLite db and do any necessary updates
1812 my $updater;
1813 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1814 $updater->update();
1816 # if no files were specified, we need to work out what files we should
1817 # be providing status on ...
1818 argsfromdir($updater);
1820 # foreach file specified on the command line ...
1821 foreach my $filename ( @{$state->{args}} )
1823 $filename = filecleanup($filename);
1825 if ( exists($state->{opt}{l}) &&
1826 index($filename, '/', length($state->{prependdir})) >= 0 )
1828 next;
1831 my $wrev = revparse($filename);
1833 my $stickyInfo = resolveStickyInfo($filename);
1834 my $meta = $updater->getmeta($filename,$stickyInfo);
1835 my $oldmeta = $meta;
1837 # If the working copy is an old revision, lets get that
1838 # version too for comparison.
1839 if ( defined($wrev) and $wrev ne $meta->{revision} )
1841 my($rmRev)=$wrev;
1842 $rmRev=~s/^-//;
1843 $oldmeta = $updater->getmeta($filename, $rmRev);
1846 # TODO : All possible statuses aren't yet implemented
1847 my $status;
1848 # Files are up to date if the working copy and repo copy have
1849 # the same revision, and the working copy is unmodified
1850 if ( defined ( $wrev ) and defined($meta->{revision}) and
1851 $wrev eq $meta->{revision} and
1852 ( ( $state->{entries}{$filename}{unchanged} and
1853 ( not defined ( $state->{entries}{$filename}{conflict} ) or
1854 $state->{entries}{$filename}{conflict} !~ /^\+=/ ) ) or
1855 ( defined($state->{entries}{$filename}{modified_hash}) and
1856 $state->{entries}{$filename}{modified_hash} eq
1857 $meta->{filehash} ) ) )
1859 $status = "Up-to-date"
1862 # Need checkout if the working copy has a different (usually
1863 # older) revision than the repo copy, and the working copy is
1864 # unmodified
1865 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1866 $meta->{revision} ne $wrev and
1867 ( $state->{entries}{$filename}{unchanged} or
1868 ( defined($state->{entries}{$filename}{modified_hash}) and
1869 $state->{entries}{$filename}{modified_hash} eq
1870 $oldmeta->{filehash} ) ) )
1872 $status ||= "Needs Checkout";
1875 # Need checkout if it exists in the repo but doesn't have a working
1876 # copy
1877 if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
1879 $status ||= "Needs Checkout";
1882 # Locally modified if working copy and repo copy have the
1883 # same revision but there are local changes
1884 if ( defined ( $wrev ) and defined($meta->{revision}) and
1885 $wrev eq $meta->{revision} and
1886 $wrev ne "0" and
1887 $state->{entries}{$filename}{modified_filename} )
1889 $status ||= "Locally Modified";
1892 # Needs Merge if working copy revision is different
1893 # (usually older) than repo copy and there are local changes
1894 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1895 $meta->{revision} ne $wrev and
1896 $state->{entries}{$filename}{modified_filename} )
1898 $status ||= "Needs Merge";
1901 if ( defined ( $state->{entries}{$filename}{revision} ) and
1902 ( !defined($meta->{revision}) ||
1903 $meta->{revision} eq "0" ) )
1905 $status ||= "Locally Added";
1907 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
1908 $wrev eq "-$meta->{revision}" )
1910 $status ||= "Locally Removed";
1912 if ( defined ( $state->{entries}{$filename}{conflict} ) and
1913 $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1915 $status ||= "Unresolved Conflict";
1917 if ( 0 )
1919 $status ||= "File had conflicts on merge";
1922 $status ||= "Unknown";
1924 my ($filepart) = filenamesplit($filename);
1926 print "M =======" . ( "=" x 60 ) . "\n";
1927 print "M File: $filepart\tStatus: $status\n";
1928 if ( defined($state->{entries}{$filename}{revision}) )
1930 print "M Working revision:\t" .
1931 $state->{entries}{$filename}{revision} . "\n";
1932 } else {
1933 print "M Working revision:\tNo entry for $filename\n";
1935 if ( defined($meta->{revision}) )
1937 print "M Repository revision:\t" .
1938 $meta->{revision} .
1939 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1940 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
1941 my($tag)=($tagOrDate=~m/^T(.+)$/);
1942 if( !defined($tag) )
1944 $tag="(none)";
1946 print "M Sticky Tag:\t\t$tag\n";
1947 my($date)=($tagOrDate=~m/^D(.+)$/);
1948 if( !defined($date) )
1950 $date="(none)";
1952 print "M Sticky Date:\t\t$date\n";
1953 my($options)=$state->{entries}{$filename}{options};
1954 if( $options eq "" )
1956 $options="(none)";
1958 print "M Sticky Options:\t\t$options\n";
1959 } else {
1960 print "M Repository revision:\tNo revision control file\n";
1962 print "M\n";
1965 print "ok\n";
1968 sub req_diff
1970 my ( $cmd, $data ) = @_;
1972 argsplit("diff");
1974 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1975 #$log->debug("status state : " . Dumper($state));
1977 my ($revision1, $revision2);
1978 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1980 $revision1 = $state->{opt}{r}[0];
1981 $revision2 = $state->{opt}{r}[1];
1982 } else {
1983 $revision1 = $state->{opt}{r};
1986 $log->debug("Diffing revisions " .
1987 ( defined($revision1) ? $revision1 : "[NULL]" ) .
1988 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1990 # Grab a handle to the SQLite db and do any necessary updates
1991 my $updater;
1992 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1993 $updater->update();
1995 # if no files were specified, we need to work out what files we should
1996 # be providing status on ...
1997 argsfromdir($updater);
1999 my($foundDiff);
2001 # foreach file specified on the command line ...
2002 foreach my $argFilename ( @{$state->{args}} )
2004 my($filename) = filecleanup($argFilename);
2006 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
2008 my $wrev = revparse($filename);
2010 # Priority for revision1:
2011 # 1. First -r (missing file: check -N)
2012 # 2. wrev from client's Entry line
2013 # - missing line/file: check -N
2014 # - "0": added file not committed (empty contents for rev1)
2015 # - Prefixed with dash (to be removed): check -N
2017 if ( defined ( $revision1 ) )
2019 $meta1 = $updater->getmeta($filename, $revision1);
2021 elsif( defined($wrev) && $wrev ne "0" )
2023 my($rmRev)=$wrev;
2024 $rmRev=~s/^-//;
2025 $meta1 = $updater->getmeta($filename, $rmRev);
2027 if ( !defined($meta1) ||
2028 $meta1->{filehash} eq "deleted" )
2030 if( !exists($state->{opt}{N}) )
2032 if(!defined($revision1))
2034 print "E File $filename at revision $revision1 doesn't exist\n";
2036 next;
2038 elsif( !defined($meta1) )
2040 $meta1 = {
2041 name => $filename,
2042 revision => '0',
2043 filehash => 'deleted'
2048 # Priority for revision2:
2049 # 1. Second -r (missing file: check -N)
2050 # 2. Modified file contents from client
2051 # 3. wrev from client's Entry line
2052 # - missing line/file: check -N
2053 # - Prefixed with dash (to be removed): check -N
2055 # if we have a second -r switch, use it too
2056 if ( defined ( $revision2 ) )
2058 $meta2 = $updater->getmeta($filename, $revision2);
2060 elsif(defined($state->{entries}{$filename}{modified_filename}))
2062 $file2 = $state->{entries}{$filename}{modified_filename};
2063 $meta2 = {
2064 name => $filename,
2065 revision => '0',
2066 filehash => 'modified'
2069 elsif( defined($wrev) && ($wrev!~/^-/) )
2071 if(!defined($revision1)) # no revision and no modifications:
2073 next;
2075 $meta2 = $updater->getmeta($filename, $wrev);
2077 if(!defined($file2))
2079 if ( !defined($meta2) ||
2080 $meta2->{filehash} eq "deleted" )
2082 if( !exists($state->{opt}{N}) )
2084 if(!defined($revision2))
2086 print "E File $filename at revision $revision2 doesn't exist\n";
2088 next;
2090 elsif( !defined($meta2) )
2092 $meta2 = {
2093 name => $filename,
2094 revision => '0',
2095 filehash => 'deleted'
2101 if( $meta1->{filehash} eq $meta2->{filehash} )
2103 $log->info("unchanged $filename");
2104 next;
2107 # Retrieve revision contents:
2108 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2109 transmitfile($meta1->{filehash}, { targetfile => $file1 });
2111 if(!defined($file2))
2113 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2114 transmitfile($meta2->{filehash}, { targetfile => $file2 });
2117 # Generate the actual diff:
2118 print "M Index: $argFilename\n";
2119 print "M =======" . ( "=" x 60 ) . "\n";
2120 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2121 if ( defined ( $meta1 ) && $meta1->{revision} ne "0" )
2123 print "M retrieving revision $meta1->{revision}\n"
2125 if ( defined ( $meta2 ) && $meta2->{revision} ne "0" )
2127 print "M retrieving revision $meta2->{revision}\n"
2129 print "M diff ";
2130 foreach my $opt ( sort keys %{$state->{opt}} )
2132 if ( ref $state->{opt}{$opt} eq "ARRAY" )
2134 foreach my $value ( @{$state->{opt}{$opt}} )
2136 print "-$opt $value ";
2138 } else {
2139 print "-$opt ";
2140 if ( defined ( $state->{opt}{$opt} ) )
2142 print "$state->{opt}{$opt} "
2146 print "$argFilename\n";
2148 $log->info("Diffing $filename -r $meta1->{revision} -r " .
2149 ( $meta2->{revision} or "workingcopy" ));
2151 # TODO: Use --label instead of -L because -L is no longer
2152 # documented and may go away someday. Not sure if there there are
2153 # versions that only support -L, which would make this change risky?
2154 # http://osdir.com/ml/bug-gnu-utils-gnu/2010-12/msg00060.html
2155 # ("man diff" should actually document the best migration strategy,
2156 # [current behavior, future changes, old compatibility issues
2157 # or lack thereof, etc], not just stop mentioning the option...)
2158 # TODO: Real CVS seems to include a date in the label, before
2159 # the revision part, without the keyword "revision". The following
2160 # has minimal changes compared to original versions of
2161 # git-cvsserver.perl. (Mostly tab vs space after filename.)
2163 my (@diffCmd) = ( 'diff' );
2164 if ( exists($state->{opt}{N}) )
2166 push @diffCmd,"-N";
2168 if ( exists $state->{opt}{u} )
2170 push @diffCmd,("-u","-L");
2171 if( $meta1->{filehash} eq "deleted" )
2173 push @diffCmd,"/dev/null";
2174 } else {
2175 push @diffCmd,("$argFilename\trevision $meta1->{revision}");
2178 if( defined($meta2->{filehash}) )
2180 if( $meta2->{filehash} eq "deleted" )
2182 push @diffCmd,("-L","/dev/null");
2183 } else {
2184 push @diffCmd,("-L",
2185 "$argFilename\trevision $meta2->{revision}");
2187 } else {
2188 push @diffCmd,("-L","$argFilename\tworking copy");
2191 push @diffCmd,($file1,$file2);
2192 if(!open(DIFF,"-|",@diffCmd))
2194 $log->warn("Unable to run diff: $!");
2196 my($diffLine);
2197 while(defined($diffLine=<DIFF>))
2199 print "M $diffLine";
2200 $foundDiff=1;
2202 close(DIFF);
2205 if($foundDiff)
2207 print "error \n";
2209 else
2211 print "ok\n";
2215 sub req_log
2217 my ( $cmd, $data ) = @_;
2219 argsplit("log");
2221 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
2222 #$log->debug("log state : " . Dumper($state));
2224 my ( $revFilter );
2225 if ( defined ( $state->{opt}{r} ) )
2227 $revFilter = $state->{opt}{r};
2230 # Grab a handle to the SQLite db and do any necessary updates
2231 my $updater;
2232 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
2233 $updater->update();
2235 # if no files were specified, we need to work out what files we
2236 # should be providing status on ...
2237 argsfromdir($updater);
2239 # foreach file specified on the command line ...
2240 foreach my $filename ( @{$state->{args}} )
2242 $filename = filecleanup($filename);
2244 my $headmeta = $updater->getmeta($filename);
2246 my ($revisions,$totalrevisions) = $updater->getlog($filename,
2247 $revFilter);
2249 next unless ( scalar(@$revisions) );
2251 print "M \n";
2252 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2253 print "M Working file: $filename\n";
2254 print "M head: $headmeta->{revision}\n";
2255 print "M branch:\n";
2256 print "M locks: strict\n";
2257 print "M access list:\n";
2258 print "M symbolic names:\n";
2259 print "M keyword substitution: kv\n";
2260 print "M total revisions: $totalrevisions;\tselected revisions: " .
2261 scalar(@$revisions) . "\n";
2262 print "M description:\n";
2264 foreach my $revision ( @$revisions )
2266 print "M ----------------------------\n";
2267 print "M revision $revision->{revision}\n";
2268 # reformat the date for log output
2269 if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
2270 defined($DATE_LIST->{$2}) )
2272 $revision->{modified} = sprintf('%04d/%02d/%02d %s',
2273 $3, $DATE_LIST->{$2}, $1, $4 );
2275 $revision->{author} = cvs_author($revision->{author});
2276 print "M date: $revision->{modified};" .
2277 " author: $revision->{author}; state: " .
2278 ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
2279 "; lines: +2 -3\n";
2280 my $commitmessage;
2281 $commitmessage = $updater->commitmessage($revision->{commithash});
2282 $commitmessage =~ s/^/M /mg;
2283 print $commitmessage . "\n";
2285 print "M =======" . ( "=" x 70 ) . "\n";
2288 print "ok\n";
2291 sub req_annotate
2293 my ( $cmd, $data ) = @_;
2295 argsplit("annotate");
2297 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
2298 #$log->debug("status state : " . Dumper($state));
2300 # Grab a handle to the SQLite db and do any necessary updates
2301 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
2302 $updater->update();
2304 # if no files were specified, we need to work out what files we should be providing annotate on ...
2305 argsfromdir($updater);
2307 # we'll need a temporary checkout dir
2308 setupWorkTree();
2310 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
2312 # foreach file specified on the command line ...
2313 foreach my $filename ( @{$state->{args}} )
2315 $filename = filecleanup($filename);
2317 my $meta = $updater->getmeta($filename);
2319 next unless ( $meta->{revision} );
2321 # get all the commits that this file was in
2322 # in dense format -- aka skip dead revisions
2323 my $revisions = $updater->gethistorydense($filename);
2324 my $lastseenin = $revisions->[0][2];
2326 # populate the temporary index based on the latest commit were we saw
2327 # the file -- but do it cheaply without checking out any files
2328 # TODO: if we got a revision from the client, use that instead
2329 # to look up the commithash in sqlite (still good to default to
2330 # the current head as we do now)
2331 system("git", "read-tree", $lastseenin);
2332 unless ($? == 0)
2334 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
2335 return;
2337 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
2339 # do a checkout of the file
2340 system('git', 'checkout-index', '-f', '-u', $filename);
2341 unless ($? == 0) {
2342 print "E error running git-checkout-index -f -u $filename : $!\n";
2343 return;
2346 $log->info("Annotate $filename");
2348 # Prepare a file with the commits from the linearized
2349 # history that annotate should know about. This prevents
2350 # git-jsannotate telling us about commits we are hiding
2351 # from the client.
2353 my $a_hints = "$work->{workDir}/.annotate_hints";
2354 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
2355 print "E failed to open '$a_hints' for writing: $!\n";
2356 return;
2358 for (my $i=0; $i < @$revisions; $i++)
2360 print ANNOTATEHINTS $revisions->[$i][2];
2361 if ($i+1 < @$revisions) { # have we got a parent?
2362 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2364 print ANNOTATEHINTS "\n";
2367 print ANNOTATEHINTS "\n";
2368 close ANNOTATEHINTS
2369 or (print "E failed to write $a_hints: $!\n"), return;
2371 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
2372 if (!open(ANNOTATE, "-|", @cmd)) {
2373 print "E error invoking ". join(' ',@cmd) .": $!\n";
2374 return;
2376 my $metadata = {};
2377 print "E Annotations for $filename\n";
2378 print "E ***************\n";
2379 while ( <ANNOTATE> )
2381 if (m/^([a-zA-Z0-9]{$state->{hexsz}})\t\([^\)]*\)(.*)$/i)
2383 my $commithash = $1;
2384 my $data = $2;
2385 unless ( defined ( $metadata->{$commithash} ) )
2387 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2388 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
2389 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2391 printf("M %-7s (%-8s %10s): %s\n",
2392 $metadata->{$commithash}{revision},
2393 $metadata->{$commithash}{author},
2394 $metadata->{$commithash}{modified},
2395 $data
2397 } else {
2398 $log->warn("Error in annotate output! LINE: $_");
2399 print "E Annotate error \n";
2400 next;
2403 close ANNOTATE;
2406 # done; get out of the tempdir
2407 cleanupWorkTree();
2409 print "ok\n";
2413 # This method takes the state->{arguments} array and produces two new arrays.
2414 # The first is $state->{args} which is everything before the '--' argument, and
2415 # the second is $state->{files} which is everything after it.
2416 sub argsplit
2418 $state->{args} = [];
2419 $state->{files} = [];
2420 $state->{opt} = {};
2422 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2424 my $type = shift;
2426 if ( defined($type) )
2428 my $opt = {};
2429 $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" );
2430 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2431 $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" );
2432 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2, N => 0 } if ( $type eq "diff" );
2433 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2434 $opt = { k => 1, m => 1 } if ( $type eq "add" );
2435 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2436 $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" );
2439 while ( scalar ( @{$state->{arguments}} ) > 0 )
2441 my $arg = shift @{$state->{arguments}};
2443 next if ( $arg eq "--" );
2444 next unless ( $arg =~ /\S/ );
2446 # if the argument looks like a switch
2447 if ( $arg =~ /^-(\w)(.*)/ )
2449 # if it's a switch that takes an argument
2450 if ( $opt->{$1} )
2452 # If this switch has already been provided
2453 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2455 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2456 if ( length($2) > 0 )
2458 push @{$state->{opt}{$1}},$2;
2459 } else {
2460 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2462 } else {
2463 # if there's extra data in the arg, use that as the argument for the switch
2464 if ( length($2) > 0 )
2466 $state->{opt}{$1} = $2;
2467 } else {
2468 $state->{opt}{$1} = shift @{$state->{arguments}};
2471 } else {
2472 $state->{opt}{$1} = undef;
2475 else
2477 push @{$state->{args}}, $arg;
2481 else
2483 my $mode = 0;
2485 foreach my $value ( @{$state->{arguments}} )
2487 if ( $value eq "--" )
2489 $mode++;
2490 next;
2492 push @{$state->{args}}, $value if ( $mode == 0 );
2493 push @{$state->{files}}, $value if ( $mode == 1 );
2498 # Used by argsfromdir
2499 sub expandArg
2501 my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
2503 my $fullPath = filecleanup($path);
2505 # Is it a directory?
2506 if( defined($state->{dirMap}{$fullPath}) ||
2507 defined($state->{dirMap}{"$fullPath/"}) )
2509 # It is a directory in the user's sandbox.
2510 $isDir=1;
2512 if(defined($state->{entries}{$fullPath}))
2514 $log->fatal("Inconsistent file/dir type");
2515 die "Inconsistent file/dir type";
2518 elsif(defined($state->{entries}{$fullPath}))
2520 # It is a file in the user's sandbox.
2521 $isDir=0;
2523 my($revDirMap,$otherRevDirMap);
2524 if(!defined($isDir) || $isDir)
2526 # Resolve version tree for sticky tag:
2527 # (for now we only want list of files for the version, not
2528 # particular versions of those files: assume it is a directory
2529 # for the moment; ignore Entry's stick tag)
2531 # Order of precedence of sticky tags:
2532 # -A [head]
2533 # -r /tag/
2534 # [file entry sticky tag, but that is only relevant to files]
2535 # [the tag specified in dir req_Sticky]
2536 # [the tag specified in a parent dir req_Sticky]
2537 # [head]
2538 # Also, -r may appear twice (for diff).
2540 # FUTURE: When/if -j (merges) are supported, we also
2541 # need to add relevant files from one or two
2542 # versions specified with -j.
2544 if(exists($state->{opt}{A}))
2546 $revDirMap=$updater->getRevisionDirMap();
2548 elsif( defined($state->{opt}{r}) and
2549 ref $state->{opt}{r} eq "ARRAY" )
2551 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]);
2552 $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]);
2554 elsif(defined($state->{opt}{r}))
2556 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r});
2558 else
2560 my($sticky)=getDirStickyInfo($fullPath);
2561 $revDirMap=$updater->getRevisionDirMap($sticky->{tag});
2564 # Is it a directory?
2565 if( defined($revDirMap->{$fullPath}) ||
2566 defined($otherRevDirMap->{$fullPath}) )
2568 $isDir=1;
2572 # What to do with it?
2573 if(!$isDir)
2575 $outNameMap->{$fullPath}=1;
2577 else
2579 $outDirMap->{$fullPath}=1;
2581 if(defined($revDirMap->{$fullPath}))
2583 addDirMapFiles($updater,$outNameMap,$outDirMap,
2584 $revDirMap->{$fullPath});
2586 if( defined($otherRevDirMap) &&
2587 defined($otherRevDirMap->{$fullPath}) )
2589 addDirMapFiles($updater,$outNameMap,$outDirMap,
2590 $otherRevDirMap->{$fullPath});
2595 # Used by argsfromdir
2596 # Add entries from dirMap to outNameMap. Also recurse into entries
2597 # that are subdirectories.
2598 sub addDirMapFiles
2600 my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
2602 my($fullName);
2603 foreach $fullName (keys(%$dirMap))
2605 my $cleanName=$fullName;
2606 if(defined($state->{prependdir}))
2608 if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
2610 $log->fatal("internal error stripping prependdir");
2611 die "internal error stripping prependdir";
2615 if($dirMap->{$fullName} eq "F")
2617 $outNameMap->{$cleanName}=1;
2619 elsif($dirMap->{$fullName} eq "D")
2621 if(!$state->{opt}{l})
2623 expandArg($updater,$outNameMap,$outDirMap,$cleanName,1);
2626 else
2628 $log->fatal("internal error in addDirMapFiles");
2629 die "internal error in addDirMapFiles";
2634 # This method replaces $state->{args} with a directory-expanded
2635 # list of all relevant filenames (recursively unless -d), based
2636 # on $state->{entries}, and the "current" list of files in
2637 # each directory. "Current" files as determined by
2638 # either the requested (-r/-A) or "req_Sticky" version of
2639 # that directory.
2640 # Both the input args and the new output args are relative
2641 # to the cvs-client's CWD, although some of the internal
2642 # computations are relative to the top of the project.
2643 sub argsfromdir
2645 my $updater = shift;
2647 # Notes about requirements for specific callers:
2648 # update # "standard" case (entries; a single -r/-A/default; -l)
2649 # # Special case: -d for create missing directories.
2650 # diff # 0 or 1 -r's: "standard" case.
2651 # # 2 -r's: We could ignore entries (just use the two -r's),
2652 # # but it doesn't really matter.
2653 # annotate # "standard" case
2654 # log # Punting: log -r has a more complex non-"standard"
2655 # # meaning, and we don't currently try to support log'ing
2656 # # branches at all (need a lot of work to
2657 # # support CVS-consistent branch relative version
2658 # # numbering).
2659 #HERE: But we still want to expand directories. Maybe we should
2660 # essentially force "-A".
2661 # status # "standard", except that -r/-A/default are not possible.
2662 # # Mostly only used to expand entries only)
2664 # Don't use argsfromdir at all:
2665 # add # Explicit arguments required. Directory args imply add
2666 # # the directory itself, not the files in it.
2667 # co # Obtain list directly.
2668 # remove # HERE: TEST: MAYBE client does the recursion for us,
2669 # # since it only makes sense to remove stuff already in
2670 # # the sandbox?
2671 # ci # HERE: Similar to remove...
2672 # # Don't try to implement the confusing/weird
2673 # # ci -r bug er.."feature".
2675 if(scalar(@{$state->{args}})==0)
2677 $state->{args} = [ "." ];
2679 my %allArgs;
2680 my %allDirs;
2681 for my $file (@{$state->{args}})
2683 expandArg($updater,\%allArgs,\%allDirs,$file);
2686 # Include any entries from sandbox. Generally client won't
2687 # send entries that shouldn't be used.
2688 foreach my $file (keys %{$state->{entries}})
2690 $allArgs{remove_prependdir($file)} = 1;
2693 $state->{dirArgs} = \%allDirs;
2694 $state->{args} = [
2695 sort {
2696 # Sort priority: by directory depth, then actual file name:
2697 my @piecesA=split('/',$a);
2698 my @piecesB=split('/',$b);
2700 my $count=scalar(@piecesA);
2701 my $tmp=scalar(@piecesB);
2702 return $count<=>$tmp if($count!=$tmp);
2704 for($tmp=0;$tmp<$count;$tmp++)
2706 if($piecesA[$tmp] ne $piecesB[$tmp])
2708 return $piecesA[$tmp] cmp $piecesB[$tmp]
2711 return 0;
2712 } keys(%allArgs) ];
2715 ## look up directory sticky tag, of either fullPath or a parent:
2716 sub getDirStickyInfo
2718 my($fullPath)=@_;
2720 $fullPath=~s%/+$%%;
2721 while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"}))
2723 $fullPath=~s%/?[^/]*$%%;
2726 if( !defined($state->{dirMap}{"$fullPath/"}) &&
2727 ( $fullPath eq "" ||
2728 $fullPath eq "." ) )
2730 return $state->{dirMap}{""}{stickyInfo};
2732 else
2734 return $state->{dirMap}{"$fullPath/"}{stickyInfo};
2738 # Resolve precedence of various ways of specifying which version of
2739 # a file you want. Returns undef (for default head), or a ref to a hash
2740 # that contains "tag" and/or "date" keys.
2741 sub resolveStickyInfo
2743 my($filename,$stickyTag,$stickyDate,$reset) = @_;
2745 # Order of precedence of sticky tags:
2746 # -A [head]
2747 # -r /tag/
2748 # [file entry sticky tag]
2749 # [the tag specified in dir req_Sticky]
2750 # [the tag specified in a parent dir req_Sticky]
2751 # [head]
2753 my $result;
2754 if($reset)
2756 # $result=undef;
2758 elsif( defined($stickyTag) && $stickyTag ne "" )
2759 # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO
2761 $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) };
2763 # TODO: Convert -D value into the form 2011.04.10.04.46.57,
2764 # similar to an entry line's sticky date, without the D prefix.
2765 # It sometimes (always?) arrives as something more like
2766 # '10 Apr 2011 04:46:57 -0000'...
2767 # $result={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
2769 elsif( defined($state->{entries}{$filename}) &&
2770 defined($state->{entries}{$filename}{tag_or_date}) &&
2771 $state->{entries}{$filename}{tag_or_date} ne "" )
2773 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
2774 if($tagOrDate=~/^T([^ ]+)\s*$/)
2776 $result = { 'tag' => $1 };
2778 elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
2780 $result= { 'date' => $1 };
2782 else
2784 die "Unknown tag_or_date format\n";
2787 else
2789 $result=getDirStickyInfo($filename);
2792 return $result;
2795 # Convert a stickyInfo (ref to a hash) as returned by resolveStickyInfo into
2796 # a form appropriate for the sticky tag field of an Entries
2797 # line (field index 5, 0-based).
2798 sub getStickyTagOrDate
2800 my($stickyInfo)=@_;
2802 my $result;
2803 if(defined($stickyInfo) && defined($stickyInfo->{tag}))
2805 $result="T$stickyInfo->{tag}";
2807 # TODO: When/if we actually pick versions by {date} properly,
2808 # also handle it here:
2809 # "D$stickyInfo->{date}" (example: "D2011.04.13.20.37.07").
2810 else
2812 $result="";
2815 return $result;
2818 # This method cleans up the $state variable after a command that uses arguments has run
2819 sub statecleanup
2821 $state->{files} = [];
2822 $state->{dirArgs} = {};
2823 $state->{args} = [];
2824 $state->{arguments} = [];
2825 $state->{entries} = {};
2826 $state->{dirMap} = {};
2829 # Return working directory CVS revision "1.X" out
2830 # of the working directory "entries" state, for the given filename.
2831 # This is prefixed with a dash if the file is scheduled for removal
2832 # when it is committed.
2833 sub revparse
2835 my $filename = shift;
2837 return $state->{entries}{$filename}{revision};
2840 # This method takes a file hash and does a CVS "file transfer". Its
2841 # exact behaviour depends on a second, optional hash table argument:
2842 # - If $options->{targetfile}, dump the contents to that file;
2843 # - If $options->{print}, use M/MT to transmit the contents one line
2844 # at a time;
2845 # - Otherwise, transmit the size of the file, followed by the file
2846 # contents.
2847 sub transmitfile
2849 my $filehash = shift;
2850 my $options = shift;
2852 if ( defined ( $filehash ) and $filehash eq "deleted" )
2854 $log->warn("filehash is 'deleted'");
2855 return;
2858 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
2860 my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash);
2861 chomp $type;
2863 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2865 my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash);
2866 chomp $size;
2868 $log->debug("transmitfile($filehash) size=$size, type=$type");
2870 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2872 if ( defined ( $options->{targetfile} ) )
2874 my $targetfile = $options->{targetfile};
2875 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2876 print NEWFILE $_ while ( <$fh> );
2877 close NEWFILE or die("Failed to write '$targetfile': $!");
2878 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2879 while ( <$fh> ) {
2880 if( /\n\z/ ) {
2881 print 'M ', $_;
2882 } else {
2883 print 'MT text ', $_, "\n";
2886 } else {
2887 print "$size\n";
2888 print while ( <$fh> );
2890 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2891 } else {
2892 die("Couldn't execute git-cat-file");
2896 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2897 # refers to the directory portion and the file portion of the filename
2898 # respectively
2899 sub filenamesplit
2901 my $filename = shift;
2902 my $fixforlocaldir = shift;
2904 my ( $filepart, $dirpart ) = ( $filename, "." );
2905 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2906 $dirpart .= "/";
2908 if ( $fixforlocaldir )
2910 $dirpart =~ s/^$state->{prependdir}//;
2913 return ( $filepart, $dirpart );
2916 # Cleanup various junk in filename (try to canonicalize it), and
2917 # add prependdir to accommodate running CVS client from a
2918 # subdirectory (so the output is relative to top directory of the project).
2919 sub filecleanup
2921 my $filename = shift;
2923 return undef unless(defined($filename));
2924 if ( $filename =~ /^\// )
2926 print "E absolute filenames '$filename' not supported by server\n";
2927 return undef;
2930 if($filename eq ".")
2932 $filename="";
2934 $filename =~ s/^\.\///g;
2935 $filename =~ s%/+%/%g;
2936 $filename = $state->{prependdir} . $filename;
2937 $filename =~ s%/$%%;
2938 return $filename;
2941 # Remove prependdir from the path, so that it is relative to the directory
2942 # the CVS client was started from, rather than the top of the project.
2943 # Essentially the inverse of filecleanup().
2944 sub remove_prependdir
2946 my($path) = @_;
2947 if(defined($state->{prependdir}) && $state->{prependdir} ne "")
2949 my($pre)=$state->{prependdir};
2950 $pre=~s%/$%%;
2951 if(!($path=~s%^\Q$pre\E/?%%))
2953 $log->fatal("internal error missing prependdir");
2954 die("internal error missing prependdir");
2957 return $path;
2960 sub validateGitDir
2962 if( !defined($state->{CVSROOT}) )
2964 print "error 1 CVSROOT not specified\n";
2965 cleanupWorkTree();
2966 exit;
2968 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2970 print "error 1 Internally inconsistent CVSROOT\n";
2971 cleanupWorkTree();
2972 exit;
2976 # Setup working directory in a work tree with the requested version
2977 # loaded in the index.
2978 sub setupWorkTree
2980 my ($ver) = @_;
2982 validateGitDir();
2984 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2985 defined($work->{tmpDir}) )
2987 $log->warn("Bad work tree state management");
2988 print "error 1 Internal setup multiple work trees without cleanup\n";
2989 cleanupWorkTree();
2990 exit;
2993 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2995 if( !defined($work->{index}) )
2997 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3000 chdir $work->{workDir} or
3001 die "Unable to chdir to $work->{workDir}\n";
3003 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
3005 $ENV{GIT_WORK_TREE} = ".";
3006 $ENV{GIT_INDEX_FILE} = $work->{index};
3007 $work->{state} = 2;
3009 if($ver)
3011 system("git","read-tree",$ver);
3012 unless ($? == 0)
3014 $log->warn("Error running git-read-tree");
3015 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
3018 # else # req_annotate reads tree for each file
3021 # Ensure current directory is in some kind of working directory,
3022 # with a recent version loaded in the index.
3023 sub ensureWorkTree
3025 if( defined($work->{tmpDir}) )
3027 $log->warn("Bad work tree state management [ensureWorkTree()]");
3028 print "error 1 Internal setup multiple dirs without cleanup\n";
3029 cleanupWorkTree();
3030 exit;
3032 if( $work->{state} )
3034 return;
3037 validateGitDir();
3039 if( !defined($work->{emptyDir}) )
3041 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
3043 chdir $work->{emptyDir} or
3044 die "Unable to chdir to $work->{emptyDir}\n";
3046 my $ver = safe_pipe_capture('git', 'show-ref', '-s', "refs/heads/$state->{module}");
3047 chomp $ver;
3048 if ($ver !~ /^[0-9a-f]{$state->{hexsz}}$/)
3050 $log->warn("Error from git show-ref -s refs/head$state->{module}");
3051 print "error 1 cannot find the current HEAD of module";
3052 cleanupWorkTree();
3053 exit;
3056 if( !defined($work->{index}) )
3058 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3061 $ENV{GIT_WORK_TREE} = ".";
3062 $ENV{GIT_INDEX_FILE} = $work->{index};
3063 $work->{state} = 1;
3065 system("git","read-tree",$ver);
3066 unless ($? == 0)
3068 die "Error running git-read-tree $ver $!\n";
3072 # Cleanup working directory that is not needed any longer.
3073 sub cleanupWorkTree
3075 if( ! $work->{state} )
3077 return;
3080 chdir "/" or die "Unable to chdir '/'\n";
3082 if( defined($work->{workDir}) )
3084 rmtree( $work->{workDir} );
3085 undef $work->{workDir};
3087 undef $work->{state};
3090 # Setup a temporary directory (not a working tree), typically for
3091 # merging dirty state as in req_update.
3092 sub setupTmpDir
3094 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
3095 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
3097 return $work->{tmpDir};
3100 # Clean up a previously setupTmpDir. Restore previous work tree if
3101 # appropriate.
3102 sub cleanupTmpDir
3104 if ( !defined($work->{tmpDir}) )
3106 $log->warn("cleanup tmpdir that has not been setup");
3107 die "Cleanup tmpDir that has not been setup\n";
3109 if( defined($work->{state}) )
3111 if( $work->{state} == 1 )
3113 chdir $work->{emptyDir} or
3114 die "Unable to chdir to $work->{emptyDir}\n";
3116 elsif( $work->{state} == 2 )
3118 chdir $work->{workDir} or
3119 die "Unable to chdir to $work->{emptyDir}\n";
3121 else
3123 $log->warn("Inconsistent work dir state");
3124 die "Inconsistent work dir state\n";
3127 else
3129 chdir "/" or die "Unable to chdir '/'\n";
3133 # Given a path, this function returns a string containing the kopts
3134 # that should go into that path's Entries line. For example, a binary
3135 # file should get -kb.
3136 sub kopts_from_path
3138 my ($path, $srcType, $name) = @_;
3140 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
3141 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
3143 my ($val) = check_attr( "text", $path );
3144 if ( $val eq "unspecified" )
3146 $val = check_attr( "crlf", $path );
3148 if ( $val eq "unset" )
3150 return "-kb"
3152 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
3153 $val eq "set" || $val eq "input" )
3155 return "";
3157 else
3159 $log->info("Unrecognized check_attr crlf $path : $val");
3163 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
3165 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
3167 return "-kb";
3169 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
3171 if( is_binary($srcType,$name) )
3173 $log->debug("... as binary");
3174 return "-kb";
3176 else
3178 $log->debug("... as text");
3182 # Return "" to give no special treatment to any path
3183 return "";
3186 sub check_attr
3188 my ($attr,$path) = @_;
3189 ensureWorkTree();
3190 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
3192 my $val = <$fh>;
3193 close $fh;
3194 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
3195 return $val;
3197 else
3199 return undef;
3203 # This should have the same heuristics as convert.c:is_binary() and related.
3204 # Note that the bare CR test is done by callers in convert.c.
3205 sub is_binary
3207 my ($srcType,$name) = @_;
3208 $log->debug("is_binary($srcType,$name)");
3210 # Minimize amount of interpreted code run in the inner per-character
3211 # loop for large files, by totalling each character value and
3212 # then analyzing the totals.
3213 my @counts;
3214 my $i;
3215 for($i=0;$i<256;$i++)
3217 $counts[$i]=0;
3220 my $fh = open_blob_or_die($srcType,$name);
3221 my $line;
3222 while( defined($line=<$fh>) )
3224 # Any '\0' and bare CR are considered binary.
3225 if( $line =~ /\0|(\r[^\n])/ )
3227 close($fh);
3228 return 1;
3231 # Count up each character in the line:
3232 my $len=length($line);
3233 for($i=0;$i<$len;$i++)
3235 $counts[ord(substr($line,$i,1))]++;
3238 close $fh;
3240 # Don't count CR and LF as either printable/nonprintable
3241 $counts[ord("\n")]=0;
3242 $counts[ord("\r")]=0;
3244 # Categorize individual character count into printable and nonprintable:
3245 my $printable=0;
3246 my $nonprintable=0;
3247 for($i=0;$i<256;$i++)
3249 if( $i < 32 &&
3250 $i != ord("\b") &&
3251 $i != ord("\t") &&
3252 $i != 033 && # ESC
3253 $i != 014 ) # FF
3255 $nonprintable+=$counts[$i];
3257 elsif( $i==127 ) # DEL
3259 $nonprintable+=$counts[$i];
3261 else
3263 $printable+=$counts[$i];
3267 return ($printable >> 7) < $nonprintable;
3270 # Returns open file handle. Possible invocations:
3271 # - open_blob_or_die("file",$filename);
3272 # - open_blob_or_die("sha1",$filehash);
3273 sub open_blob_or_die
3275 my ($srcType,$name) = @_;
3276 my ($fh);
3277 if( $srcType eq "file" )
3279 if( !open $fh,"<",$name )
3281 $log->warn("Unable to open file $name: $!");
3282 die "Unable to open file $name: $!\n";
3285 elsif( $srcType eq "sha1" )
3287 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ )
3289 $log->warn("Need filehash");
3290 die "Need filehash\n";
3293 my $type = safe_pipe_capture('git', 'cat-file', '-t', $name);
3294 chomp $type;
3296 unless ( defined ( $type ) and $type eq "blob" )
3298 $log->warn("Invalid type '$type' for '$name'");
3299 die ( "Invalid type '$type' (expected 'blob')" )
3302 my $size = safe_pipe_capture('git', 'cat-file', '-s', $name);
3303 chomp $size;
3305 $log->debug("open_blob_or_die($name) size=$size, type=$type");
3307 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
3309 $log->warn("Unable to open sha1 $name");
3310 die "Unable to open sha1 $name\n";
3313 else
3315 $log->warn("Unknown type of blob source: $srcType");
3316 die "Unknown type of blob source: $srcType\n";
3318 return $fh;
3321 # Generate a CVS author name from Git author information, by taking the local
3322 # part of the email address and replacing characters not in the Portable
3323 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
3324 # Login names are Unix login names, which should be restricted to this
3325 # character set.
3326 sub cvs_author
3328 my $author_line = shift;
3329 (my $author) = $author_line =~ /<([^@>]*)/;
3331 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
3332 $author =~ s/^-/_/;
3334 $author;
3338 sub descramble
3340 # This table is from src/scramble.c in the CVS source
3341 my @SHIFTS = (
3342 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
3343 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
3344 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
3345 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
3346 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
3347 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
3348 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
3349 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
3350 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
3351 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
3352 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
3353 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
3354 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
3355 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
3356 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
3357 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
3359 my ($str) = @_;
3361 # This should never happen, the same password format (A) has been
3362 # used by CVS since the beginning of time
3364 my $fmt = substr($str, 0, 1);
3365 die "invalid password format `$fmt'" unless $fmt eq 'A';
3368 my @str = unpack "C*", substr($str, 1);
3369 my $ret = join '', map { chr $SHIFTS[$_] } @str;
3370 return $ret;
3373 # Test if the (deep) values of two references to a hash are the same.
3374 sub refHashEqual
3376 my($v1,$v2) = @_;
3378 my $out;
3379 if(!defined($v1))
3381 if(!defined($v2))
3383 $out=1;
3386 elsif( !defined($v2) ||
3387 scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
3389 # $out=undef;
3391 else
3393 $out=1;
3395 my $key;
3396 foreach $key (keys(%{$v1}))
3398 if( !exists($v2->{$key}) ||
3399 defined($v1->{$key}) ne defined($v2->{$key}) ||
3400 ( defined($v1->{$key}) &&
3401 $v1->{$key} ne $v2->{$key} ) )
3403 $out=undef;
3404 last;
3409 return $out;
3412 # an alternative to `command` that allows input to be passed as an array
3413 # to work around shell problems with weird characters in arguments
3415 sub safe_pipe_capture {
3417 my @output;
3419 if (my $pid = open my $child, '-|') {
3420 @output = (<$child>);
3421 close $child or die join(' ',@_).": $! $?";
3422 } else {
3423 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3425 return wantarray ? @output : join('',@output);
3429 package GITCVS::log;
3431 ####
3432 #### Copyright The Open University UK - 2006.
3433 ####
3434 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
3435 #### Martin Langhoff <martin@laptop.org>
3436 ####
3437 ####
3439 use strict;
3440 use warnings;
3442 =head1 NAME
3444 GITCVS::log
3446 =head1 DESCRIPTION
3448 This module provides very crude logging with a similar interface to
3449 Log::Log4perl
3451 =head1 METHODS
3453 =cut
3455 =head2 new
3457 Creates a new log object, optionally you can specify a filename here to
3458 indicate the file to log to. If no log file is specified, you can specify one
3459 later with method setfile, or indicate you no longer want logging with method
3460 nofile.
3462 Until one of these methods is called, all log calls will buffer messages ready
3463 to write out.
3465 =cut
3466 sub new
3468 my $class = shift;
3469 my $filename = shift;
3471 my $self = {};
3473 bless $self, $class;
3475 if ( defined ( $filename ) )
3477 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3480 return $self;
3483 =head2 setfile
3485 This methods takes a filename, and attempts to open that file as the log file.
3486 If successful, all buffered data is written out to the file, and any further
3487 logging is written directly to the file.
3489 =cut
3490 sub setfile
3492 my $self = shift;
3493 my $filename = shift;
3495 if ( defined ( $filename ) )
3497 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3500 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3502 while ( my $line = shift @{$self->{buffer}} )
3504 print {$self->{fh}} $line;
3508 =head2 nofile
3510 This method indicates no logging is going to be used. It flushes any entries in
3511 the internal buffer, and sets a flag to ensure no further data is put there.
3513 =cut
3514 sub nofile
3516 my $self = shift;
3518 $self->{nolog} = 1;
3520 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3522 $self->{buffer} = [];
3525 =head2 _logopen
3527 Internal method. Returns true if the log file is open, false otherwise.
3529 =cut
3530 sub _logopen
3532 my $self = shift;
3534 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
3535 return 0;
3538 =head2 debug info warn fatal
3540 These four methods are wrappers to _log. They provide the actual interface for
3541 logging data.
3543 =cut
3544 sub debug { my $self = shift; $self->_log("debug", @_); }
3545 sub info { my $self = shift; $self->_log("info" , @_); }
3546 sub warn { my $self = shift; $self->_log("warn" , @_); }
3547 sub fatal { my $self = shift; $self->_log("fatal", @_); }
3549 =head2 _log
3551 This is an internal method called by the logging functions. It generates a
3552 timestamp and pushes the logged line either to file, or internal buffer.
3554 =cut
3555 sub _log
3557 my $self = shift;
3558 my $level = shift;
3560 return if ( $self->{nolog} );
3562 my @time = localtime;
3563 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
3564 $time[5] + 1900,
3565 $time[4] + 1,
3566 $time[3],
3567 $time[2],
3568 $time[1],
3569 $time[0],
3570 uc $level,
3573 if ( $self->_logopen )
3575 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
3576 } else {
3577 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
3581 =head2 DESTROY
3583 This method simply closes the file handle if one is open
3585 =cut
3586 sub DESTROY
3588 my $self = shift;
3590 if ( $self->_logopen )
3592 close $self->{fh};
3596 package GITCVS::updater;
3598 ####
3599 #### Copyright The Open University UK - 2006.
3600 ####
3601 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
3602 #### Martin Langhoff <martin@laptop.org>
3603 ####
3604 ####
3606 use strict;
3607 use warnings;
3608 use DBI;
3610 =head1 METHODS
3612 =cut
3614 =head2 new
3616 =cut
3617 sub new
3619 my $class = shift;
3620 my $config = shift;
3621 my $module = shift;
3622 my $log = shift;
3624 die "Need to specify a git repository" unless ( defined($config) and -d $config );
3625 die "Need to specify a module" unless ( defined($module) );
3627 $class = ref($class) || $class;
3629 my $self = {};
3631 bless $self, $class;
3633 $self->{valid_tables} = {'revision' => 1,
3634 'revision_ix1' => 1,
3635 'revision_ix2' => 1,
3636 'head' => 1,
3637 'head_ix1' => 1,
3638 'properties' => 1,
3639 'commitmsgs' => 1};
3641 $self->{module} = $module;
3642 $self->{git_path} = $config . "/";
3644 $self->{log} = $log;
3646 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
3648 # Stores full sha1's for various branch/tag names, abbreviations, etc:
3649 $self->{commitRefCache} = {};
3651 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
3652 $cfg->{gitcvs}{dbdriver} || "SQLite";
3653 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
3654 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
3655 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
3656 $cfg->{gitcvs}{dbuser} || "";
3657 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
3658 $cfg->{gitcvs}{dbpass} || "";
3659 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
3660 $cfg->{gitcvs}{dbtablenameprefix} || "";
3661 my %mapping = ( m => $module,
3662 a => $state->{method},
3663 u => getlogin || getpwuid($<) || $<,
3664 G => $self->{git_path},
3665 g => mangle_dirname($self->{git_path}),
3667 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
3668 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
3669 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
3670 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
3672 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
3673 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
3674 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
3675 $self->{dbuser},
3676 $self->{dbpass});
3677 die "Error connecting to database\n" unless defined $self->{dbh};
3679 $self->{tables} = {};
3680 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
3682 $self->{tables}{$table} = 1;
3685 # Construct the revision table if required
3686 # The revision table stores an entry for each file, each time that file
3687 # changes.
3688 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
3689 # This is not sufficient to support "-r {commithash}" for any
3690 # files except files that were modified by that commit (also,
3691 # some places in the code ignore/effectively strip out -r in
3692 # some cases, before it gets passed to getmeta()).
3693 # The "filehash" field typically has a git blob hash, but can also
3694 # be set to "dead" to indicate that the given version of the file
3695 # should not exist in the sandbox.
3696 unless ( $self->{tables}{$self->tablename("revision")} )
3698 my $tablename = $self->tablename("revision");
3699 my $ix1name = $self->tablename("revision_ix1");
3700 my $ix2name = $self->tablename("revision_ix2");
3701 $self->{dbh}->do("
3702 CREATE TABLE $tablename (
3703 name TEXT NOT NULL,
3704 revision INTEGER NOT NULL,
3705 filehash TEXT NOT NULL,
3706 commithash TEXT NOT NULL,
3707 author TEXT NOT NULL,
3708 modified TEXT NOT NULL,
3709 mode TEXT NOT NULL
3712 $self->{dbh}->do("
3713 CREATE INDEX $ix1name
3714 ON $tablename (name,revision)
3716 $self->{dbh}->do("
3717 CREATE INDEX $ix2name
3718 ON $tablename (name,commithash)
3722 # Construct the head table if required
3723 # The head table (along with the "last_commit" entry in the property
3724 # table) is the persisted working state of the "sub update" subroutine.
3725 # All of it's data is read entirely first, and completely recreated
3726 # last, every time "sub update" runs.
3727 # This is also used by "sub getmeta" when it is asked for the latest
3728 # version of a file (as opposed to some specific version).
3729 # Another way of thinking about it is as a single slice out of
3730 # "revisions", giving just the most recent revision information for
3731 # each file.
3732 unless ( $self->{tables}{$self->tablename("head")} )
3734 my $tablename = $self->tablename("head");
3735 my $ix1name = $self->tablename("head_ix1");
3736 $self->{dbh}->do("
3737 CREATE TABLE $tablename (
3738 name TEXT NOT NULL,
3739 revision INTEGER NOT NULL,
3740 filehash TEXT NOT NULL,
3741 commithash TEXT NOT NULL,
3742 author TEXT NOT NULL,
3743 modified TEXT NOT NULL,
3744 mode TEXT NOT NULL
3747 $self->{dbh}->do("
3748 CREATE INDEX $ix1name
3749 ON $tablename (name)
3753 # Construct the properties table if required
3754 # - "last_commit" - Used by "sub update".
3755 unless ( $self->{tables}{$self->tablename("properties")} )
3757 my $tablename = $self->tablename("properties");
3758 $self->{dbh}->do("
3759 CREATE TABLE $tablename (
3760 key TEXT NOT NULL PRIMARY KEY,
3761 value TEXT
3766 # Construct the commitmsgs table if required
3767 # The commitmsgs table is only used for merge commits, since
3768 # "sub update" will only keep one branch of parents. Shortlogs
3769 # for ignored commits (i.e. not on the chosen branch) will be used
3770 # to construct a replacement "collapsed" merge commit message,
3771 # which will be stored in this table. See also "sub commitmessage".
3772 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3774 my $tablename = $self->tablename("commitmsgs");
3775 $self->{dbh}->do("
3776 CREATE TABLE $tablename (
3777 key TEXT NOT NULL PRIMARY KEY,
3778 value TEXT
3783 return $self;
3786 =head2 tablename
3788 =cut
3789 sub tablename
3791 my $self = shift;
3792 my $name = shift;
3794 if (exists $self->{valid_tables}{$name}) {
3795 return $self->{dbtablenameprefix} . $name;
3796 } else {
3797 return undef;
3801 =head2 update
3803 Bring the database up to date with the latest changes from
3804 the git repository.
3806 Internal working state is read out of the "head" table and the
3807 "last_commit" property, then it updates "revisions" based on that, and
3808 finally it writes the new internal state back to the "head" table
3809 so it can be used as a starting point the next time update is called.
3811 =cut
3812 sub update
3814 my $self = shift;
3816 # first lets get the commit list
3817 $ENV{GIT_DIR} = $self->{git_path};
3819 my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module});
3820 chomp $commitsha1;
3822 my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module});
3823 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{$state->{hexsz}}/ )
3825 die("Invalid module '$self->{module}'");
3829 my $git_log;
3830 my $lastcommit = $self->_get_prop("last_commit");
3832 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3833 # invalidate the gethead cache
3834 $self->clearCommitRefCaches();
3835 return 1;
3838 # Start exclusive lock here...
3839 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3841 # TODO: log processing is memory bound
3842 # if we can parse into a 2nd file that is in reverse order
3843 # we can probably do something really efficient
3844 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3846 if (defined $lastcommit) {
3847 push @git_log_params, "$lastcommit..$self->{module}";
3848 } else {
3849 push @git_log_params, $self->{module};
3851 # git-rev-list is the backend / plumbing version of git-log
3852 open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params)
3853 or die "Cannot call git-rev-list: $!";
3854 my @commits=readCommits($gitLogPipe);
3855 close $gitLogPipe;
3857 # Now all the commits are in the @commits bucket
3858 # ordered by time DESC. for each commit that needs processing,
3859 # determine whether it's following the last head we've seen or if
3860 # it's on its own branch, grab a file list, and add whatever's changed
3861 # NOTE: $lastcommit refers to the last commit from previous run
3862 # $lastpicked is the last commit we picked in this run
3863 my $lastpicked;
3864 my $head = {};
3865 if (defined $lastcommit) {
3866 $lastpicked = $lastcommit;
3869 my $committotal = scalar(@commits);
3870 my $commitcount = 0;
3872 # Load the head table into $head (for cached lookups during the update process)
3873 foreach my $file ( @{$self->gethead(1)} )
3875 $head->{$file->{name}} = $file;
3878 foreach my $commit ( @commits )
3880 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3881 if (defined $lastpicked)
3883 if (!in_array($lastpicked, @{$commit->{parents}}))
3885 # skip, we'll see this delta
3886 # as part of a merge later
3887 # warn "skipping off-track $commit->{hash}\n";
3888 next;
3889 } elsif (@{$commit->{parents}} > 1) {
3890 # it is a merge commit, for each parent that is
3891 # not $lastpicked (not given a CVS revision number),
3892 # see if we can get a log
3893 # from the merge-base to that parent to put it
3894 # in the message as a merge summary.
3895 my @parents = @{$commit->{parents}};
3896 foreach my $parent (@parents) {
3897 if ($parent eq $lastpicked) {
3898 next;
3900 # git-merge-base can potentially (but rarely) throw
3901 # several candidate merge bases. let's assume
3902 # that the first one is the best one.
3903 my $base = eval {
3904 ::safe_pipe_capture('git', 'merge-base',
3905 $lastpicked, $parent);
3907 # The two branches may not be related at all,
3908 # in which case merge base simply fails to find
3909 # any, but that's Ok.
3910 next if ($@);
3912 chomp $base;
3913 if ($base) {
3914 my @merged;
3915 # print "want to log between $base $parent \n";
3916 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3917 or die "Cannot call git-log: $!";
3918 my $mergedhash;
3919 while (<GITLOG>) {
3920 chomp;
3921 if (!defined $mergedhash) {
3922 if (m/^commit\s+(.+)$/) {
3923 $mergedhash = $1;
3924 } else {
3925 next;
3927 } else {
3928 # grab the first line that looks non-rfc822
3929 # aka has content after leading space
3930 if (m/^\s+(\S.*)$/) {
3931 my $title = $1;
3932 $title = substr($title,0,100); # truncate
3933 unshift @merged, "$mergedhash $title";
3934 undef $mergedhash;
3938 close GITLOG;
3939 if (@merged) {
3940 $commit->{mergemsg} = $commit->{message};
3941 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3942 foreach my $summary (@merged) {
3943 $commit->{mergemsg} .= "\t$summary\n";
3945 $commit->{mergemsg} .= "\n\n";
3946 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3953 # convert the date to CVS-happy format
3954 my $cvsDate = convertToCvsDate($commit->{date});
3956 if ( defined ( $lastpicked ) )
3958 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3959 local ($/) = "\0";
3960 while ( <FILELIST> )
3962 chomp;
3963 unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{$state->{hexsz}}\s+([a-f0-9]{$state->{hexsz}})\s+(\w)$/o )
3965 die("Couldn't process git-diff-tree line : $_");
3967 my ($mode, $hash, $change) = ($1, $2, $3);
3968 my $name = <FILELIST>;
3969 chomp($name);
3971 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3973 my $dbMode = convertToDbMode($mode);
3975 if ( $change eq "D" )
3977 #$log->debug("DELETE $name");
3978 $head->{$name} = {
3979 name => $name,
3980 revision => $head->{$name}{revision} + 1,
3981 filehash => "deleted",
3982 commithash => $commit->{hash},
3983 modified => $cvsDate,
3984 author => $commit->{author},
3985 mode => $dbMode,
3987 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3989 elsif ( $change eq "M" || $change eq "T" )
3991 #$log->debug("MODIFIED $name");
3992 $head->{$name} = {
3993 name => $name,
3994 revision => $head->{$name}{revision} + 1,
3995 filehash => $hash,
3996 commithash => $commit->{hash},
3997 modified => $cvsDate,
3998 author => $commit->{author},
3999 mode => $dbMode,
4001 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4003 elsif ( $change eq "A" )
4005 #$log->debug("ADDED $name");
4006 $head->{$name} = {
4007 name => $name,
4008 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
4009 filehash => $hash,
4010 commithash => $commit->{hash},
4011 modified => $cvsDate,
4012 author => $commit->{author},
4013 mode => $dbMode,
4015 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4017 else
4019 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
4020 die;
4023 close FILELIST;
4024 } else {
4025 # this is used to detect files removed from the repo
4026 my $seen_files = {};
4028 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
4029 local $/ = "\0";
4030 while ( <FILELIST> )
4032 chomp;
4033 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4035 die("Couldn't process git-ls-tree line : $_");
4038 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4040 $seen_files->{$git_filename} = 1;
4042 my ( $oldhash, $oldrevision, $oldmode ) = (
4043 $head->{$git_filename}{filehash},
4044 $head->{$git_filename}{revision},
4045 $head->{$git_filename}{mode}
4048 my $dbMode = convertToDbMode($mode);
4050 # unless the file exists with the same hash, we need to update it ...
4051 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode )
4053 my $newrevision = ( $oldrevision or 0 ) + 1;
4055 $head->{$git_filename} = {
4056 name => $git_filename,
4057 revision => $newrevision,
4058 filehash => $git_hash,
4059 commithash => $commit->{hash},
4060 modified => $cvsDate,
4061 author => $commit->{author},
4062 mode => $dbMode,
4066 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
4069 close FILELIST;
4071 # Detect deleted files
4072 foreach my $file ( sort keys %$head )
4074 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
4076 $head->{$file}{revision}++;
4077 $head->{$file}{filehash} = "deleted";
4078 $head->{$file}{commithash} = $commit->{hash};
4079 $head->{$file}{modified} = $cvsDate;
4080 $head->{$file}{author} = $commit->{author};
4082 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode});
4085 # END : "Detect deleted files"
4089 if (exists $commit->{mergemsg})
4091 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
4094 $lastpicked = $commit->{hash};
4096 $self->_set_prop("last_commit", $commit->{hash});
4099 $self->delete_head();
4100 foreach my $file ( sort keys %$head )
4102 $self->insert_head(
4103 $file,
4104 $head->{$file}{revision},
4105 $head->{$file}{filehash},
4106 $head->{$file}{commithash},
4107 $head->{$file}{modified},
4108 $head->{$file}{author},
4109 $head->{$file}{mode},
4112 # invalidate the gethead cache
4113 $self->clearCommitRefCaches();
4116 # Ending exclusive lock here
4117 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
4120 sub readCommits
4122 my $pipeHandle = shift;
4123 my @commits;
4125 my %commit = ();
4127 while ( <$pipeHandle> )
4129 chomp;
4130 if (m/^commit\s+(.*)$/) {
4131 # on ^commit lines put the just seen commit in the stack
4132 # and prime things for the next one
4133 if (keys %commit) {
4134 my %copy = %commit;
4135 unshift @commits, \%copy;
4136 %commit = ();
4138 my @parents = split(m/\s+/, $1);
4139 $commit{hash} = shift @parents;
4140 $commit{parents} = \@parents;
4141 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
4142 # on rfc822-like lines seen before we see any message,
4143 # lowercase the entry and put it in the hash as key-value
4144 $commit{lc($1)} = $2;
4145 } else {
4146 # message lines - skip initial empty line
4147 # and trim whitespace
4148 if (!exists($commit{message}) && m/^\s*$/) {
4149 # define it to mark the end of headers
4150 $commit{message} = '';
4151 next;
4153 s/^\s+//; s/\s+$//; # trim ws
4154 $commit{message} .= $_ . "\n";
4158 unshift @commits, \%commit if ( keys %commit );
4160 return @commits;
4163 sub convertToCvsDate
4165 my $date = shift;
4166 # Convert from: "git rev-list --pretty" formatted date
4167 # Convert to: "the format specified by RFC822 as modified by RFC1123."
4168 # Example: 26 May 1997 13:01:40 -0400
4169 if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ )
4171 $date = "$2 $1 $4 $3 $5";
4174 return $date;
4177 sub convertToDbMode
4179 my $mode = shift;
4181 # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw",
4182 # but the database "mode" column historically (and currently)
4183 # only stores the "rw" (for user) part of the string.
4184 # FUTURE: It might make more sense to persist the raw
4185 # octal mode (or perhaps the final full CVS form) instead of
4186 # this half-converted form, but it isn't currently worth the
4187 # backwards compatibility headaches.
4189 $mode=~/^\d{3}(\d)\d\d$/;
4190 my $userBits=$1;
4192 my $dbMode = "";
4193 $dbMode .= "r" if ( $userBits & 4 );
4194 $dbMode .= "w" if ( $userBits & 2 );
4195 $dbMode .= "x" if ( $userBits & 1 );
4196 $dbMode = "rw" if ( $dbMode eq "" );
4198 return $dbMode;
4201 sub insert_rev
4203 my $self = shift;
4204 my $name = shift;
4205 my $revision = shift;
4206 my $filehash = shift;
4207 my $commithash = shift;
4208 my $modified = shift;
4209 my $author = shift;
4210 my $mode = shift;
4211 my $tablename = $self->tablename("revision");
4213 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
4214 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4217 sub insert_mergelog
4219 my $self = shift;
4220 my $key = shift;
4221 my $value = shift;
4222 my $tablename = $self->tablename("commitmsgs");
4224 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
4225 $insert_mergelog->execute($key, $value);
4228 sub delete_head
4230 my $self = shift;
4231 my $tablename = $self->tablename("head");
4233 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
4234 $delete_head->execute();
4237 sub insert_head
4239 my $self = shift;
4240 my $name = shift;
4241 my $revision = shift;
4242 my $filehash = shift;
4243 my $commithash = shift;
4244 my $modified = shift;
4245 my $author = shift;
4246 my $mode = shift;
4247 my $tablename = $self->tablename("head");
4249 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
4250 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4253 sub _get_prop
4255 my $self = shift;
4256 my $key = shift;
4257 my $tablename = $self->tablename("properties");
4259 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
4260 $db_query->execute($key);
4261 my ( $value ) = $db_query->fetchrow_array;
4263 return $value;
4266 sub _set_prop
4268 my $self = shift;
4269 my $key = shift;
4270 my $value = shift;
4271 my $tablename = $self->tablename("properties");
4273 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
4274 $db_query->execute($value, $key);
4276 unless ( $db_query->rows )
4278 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
4279 $db_query->execute($key, $value);
4282 return $value;
4285 =head2 gethead
4287 =cut
4289 sub gethead
4291 my $self = shift;
4292 my $intRev = shift;
4293 my $tablename = $self->tablename("head");
4295 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
4297 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
4298 $db_query->execute();
4300 my $tree = [];
4301 while ( my $file = $db_query->fetchrow_hashref )
4303 if(!$intRev)
4305 $file->{revision} = "1.$file->{revision}"
4307 push @$tree, $file;
4310 $self->{gethead_cache} = $tree;
4312 return $tree;
4315 =head2 getAnyHead
4317 Returns a reference to an array of getmeta structures, one
4318 per file in the specified tree hash.
4320 =cut
4322 sub getAnyHead
4324 my ($self,$hash) = @_;
4326 if(!defined($hash))
4328 return $self->gethead();
4331 my @files;
4333 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4334 or die("Cannot call git-ls-tree : $!");
4335 local $/ = "\0";
4336 @files=<$filePipe>;
4337 close $filePipe;
4340 my $tree=[];
4341 my($line);
4342 foreach $line (@files)
4344 $line=~s/\0$//;
4345 unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4347 die("Couldn't process git-ls-tree line : $_");
4350 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4351 push @$tree, $self->getMetaFromCommithash($git_filename,$hash);
4354 return $tree;
4357 =head2 getRevisionDirMap
4359 A "revision dir map" contains all the plain-file filenames associated
4360 with a particular revision (tree-ish), organized by directory:
4362 $type = $out->{$dir}{$fullName}
4364 The type of each is "F" (for ordinary file) or "D" (for directory,
4365 for which the map $out->{$fullName} will also exist).
4367 =cut
4369 sub getRevisionDirMap
4371 my ($self,$ver)=@_;
4373 if(!defined($self->{revisionDirMapCache}))
4375 $self->{revisionDirMapCache}={};
4378 # Get file list (previously cached results are dependent on HEAD,
4379 # but are early in each case):
4380 my $cacheKey;
4381 my (@fileList);
4382 if( !defined($ver) || $ver eq "" )
4384 $cacheKey="";
4385 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4387 return $self->{revisionDirMapCache}{$cacheKey};
4390 my @head = @{$self->gethead()};
4391 foreach my $file ( @head )
4393 next if ( $file->{filehash} eq "deleted" );
4395 push @fileList,$file->{name};
4398 else
4400 my ($hash)=$self->lookupCommitRef($ver);
4401 if( !defined($hash) )
4403 return undef;
4406 $cacheKey=$hash;
4407 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4409 return $self->{revisionDirMapCache}{$cacheKey};
4412 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4413 or die("Cannot call git-ls-tree : $!");
4414 local $/ = "\0";
4415 while ( <$filePipe> )
4417 chomp;
4418 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4420 die("Couldn't process git-ls-tree line : $_");
4423 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4425 push @fileList, $git_filename;
4427 close $filePipe;
4430 # Convert to normalized form:
4431 my %revMap;
4432 my $file;
4433 foreach $file (@fileList)
4435 my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%);
4436 $dir='' if(!defined($dir));
4438 # parent directories:
4439 # ... create empty dir maps for parent dirs:
4440 my($td)=$dir;
4441 while(!defined($revMap{$td}))
4443 $revMap{$td}={};
4445 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4446 $tp='' if(!defined($tp));
4447 $td=$tp;
4449 # ... add children to parent maps (now that they exist):
4450 $td=$dir;
4451 while($td ne "")
4453 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4454 $tp='' if(!defined($tp));
4456 if(defined($revMap{$tp}{$td}))
4458 if($revMap{$tp}{$td} ne 'D')
4460 die "Weird file/directory inconsistency in $cacheKey";
4462 last; # loop exit
4464 $revMap{$tp}{$td}='D';
4466 $td=$tp;
4469 # file
4470 $revMap{$dir}{$file}='F';
4473 # Save in cache:
4474 $self->{revisionDirMapCache}{$cacheKey}=\%revMap;
4475 return $self->{revisionDirMapCache}{$cacheKey};
4478 =head2 getlog
4480 See also gethistorydense().
4482 =cut
4484 sub getlog
4486 my $self = shift;
4487 my $filename = shift;
4488 my $revFilter = shift;
4490 my $tablename = $self->tablename("revision");
4492 # Filters:
4493 # TODO: date, state, or by specific logins filters?
4494 # TODO: Handle comma-separated list of revFilter items, each item
4495 # can be a range [only case currently handled] or individual
4496 # rev or branch or "branch.".
4497 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
4498 # manually filtering the results of the query?
4499 my ( $minrev, $maxrev );
4500 if( defined($revFilter) and
4501 $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
4503 my $control = $3;
4504 $minrev = $2;
4505 $maxrev = $5;
4506 $minrev++ if ( defined($minrev) and $control eq "::" );
4509 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
4510 $db_query->execute($filename);
4512 my $totalRevs=0;
4513 my $tree = [];
4514 while ( my $file = $db_query->fetchrow_hashref )
4516 $totalRevs++;
4517 if( defined($minrev) and $file->{revision} < $minrev )
4519 next;
4521 if( defined($maxrev) and $file->{revision} > $maxrev )
4523 next;
4526 $file->{revision} = "1." . $file->{revision};
4527 push @$tree, $file;
4530 return ($tree,$totalRevs);
4533 =head2 getmeta
4535 This function takes a filename (with path) argument and returns a hashref of
4536 metadata for that file.
4538 There are several ways $revision can be specified:
4540 - A reference to hash that contains a "tag" that is the
4541 actual revision (one of the below). TODO: Also allow it to
4542 specify a "date" in the hash.
4543 - undef, to refer to the latest version on the main branch.
4544 - Full CVS client revision number (mapped to integer in DB, without the
4545 "1." prefix),
4546 - Complex CVS-compatible "special" revision number for
4547 non-linear history (see comment below)
4548 - git commit sha1 hash
4549 - branch or tag name
4551 =cut
4553 sub getmeta
4555 my $self = shift;
4556 my $filename = shift;
4557 my $revision = shift;
4558 my $tablename_rev = $self->tablename("revision");
4559 my $tablename_head = $self->tablename("head");
4561 if ( ref($revision) eq "HASH" )
4563 $revision = $revision->{tag};
4566 # Overview of CVS revision numbers:
4568 # General CVS numbering scheme:
4569 # - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc.
4570 # - Result of "cvs checkin -r" (possible, but not really
4571 # recommended): "2.1", "2.2", etc
4572 # - Branch tag: "1.2.0.n", where "1.2" is revision it was branched
4573 # from, "0" is a magic placeholder that identifies it as a
4574 # branch tag instead of a version tag, and n is 2 times the
4575 # branch number off of "1.2", starting with "2".
4576 # - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n"
4577 # is branch number off of "1.2" (like n above), and "x" is
4578 # the version number on the branch.
4579 # - Branches can branch off of branches: "1.3.2.7.4.1" (even number
4580 # of components).
4581 # - Odd "n"s are used by "vendor branches" that result
4582 # from "cvs import". Vendor branches have additional
4583 # strangeness in the sense that the main rcs "head" of the main
4584 # branch will (temporarily until first normal commit) point
4585 # to the version on the vendor branch, rather than the actual
4586 # main branch. (FUTURE: This may provide an opportunity
4587 # to use "strange" revision numbers for fast-forward-merged
4588 # branch tip when CVS client is asking for the main branch.)
4590 # git-cvsserver CVS-compatible special numbering schemes:
4591 # - Currently git-cvsserver only tries to be identical to CVS for
4592 # simple "1.x" numbers on the "main" branch (as identified
4593 # by the module name that was originally cvs checkout'ed).
4594 # - The database only stores the "x" part, for historical reasons.
4595 # But most of the rest of the cvsserver preserves
4596 # and thinks using the full revision number.
4597 # - To handle non-linear history, it uses a version of the form
4598 # "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely
4599 # identify this as a special revision number, and there are
4600 # 20 b's that together encode the sha1 git commit from which
4601 # this version of this file originated. Each b is
4602 # the numerical value of the corresponding byte plus
4603 # 100.
4604 # - "plus 100" avoids "0"s, and also reduces the
4605 # likelihood of a collision in the case that someone someday
4606 # writes an import tool that tries to preserve original
4607 # CVS revision numbers, and the original CVS data had done
4608 # lots of branches off of branches and other strangeness to
4609 # end up with a real version number that just happens to look
4610 # like this special revision number form. Also, if needed
4611 # there are several ways to extend/identify alternative encodings
4612 # within the "2.1.1.2000" part if necessary.
4613 # - Unlike real CVS revisions, you can't really reconstruct what
4614 # relation a revision of this form has to other revisions.
4615 # - FUTURE: TODO: Rework database somehow to make up and remember
4616 # fully-CVS-compatible branches and branch version numbers.
4618 my $meta;
4619 if ( defined($revision) )
4621 if ( $revision =~ /^1\.(\d+)$/ )
4623 my ($intRev) = $1;
4624 my $db_query;
4625 $db_query = $self->{dbh}->prepare_cached(
4626 "SELECT * FROM $tablename_rev WHERE name=? AND revision=?",
4627 {},1);
4628 $db_query->execute($filename, $intRev);
4629 $meta = $db_query->fetchrow_hashref;
4631 elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){$state->{rawsz}}$/ )
4633 my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/);
4634 $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg;
4635 if($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/)
4637 return $self->getMetaFromCommithash($filename,$commitHash);
4640 # error recovery: fall back on head version below
4641 print "E Failed to find $filename version=$revision or commit=$commitHash\n";
4642 $log->warning("failed get $revision with commithash=$commitHash");
4643 undef $revision;
4645 elsif ( $revision =~ /^[0-9a-f]{$state->{hexsz}}$/ )
4647 # Try DB first. This is mostly only useful for req_annotate(),
4648 # which only calls this for stuff that should already be in
4649 # the DB. It is fairly likely to be a waste of time
4650 # in most other cases [unless the file happened to be
4651 # modified in $revision specifically], but
4652 # it is probably in the noise compared to how long
4653 # getMetaFromCommithash() will take.
4654 my $db_query;
4655 $db_query = $self->{dbh}->prepare_cached(
4656 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4657 {},1);
4658 $db_query->execute($filename, $revision);
4659 $meta = $db_query->fetchrow_hashref;
4661 if(! $meta)
4663 my($revCommit)=$self->lookupCommitRef($revision);
4664 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
4666 return $self->getMetaFromCommithash($filename,$revCommit);
4669 # error recovery: nothing found:
4670 print "E Failed to find $filename version=$revision\n";
4671 $log->warning("failed get $revision");
4672 return $meta;
4675 else
4677 my($revCommit)=$self->lookupCommitRef($revision);
4678 if($revCommit=~/^[0-9a-f]{$state->{hexsz}}$/)
4680 return $self->getMetaFromCommithash($filename,$revCommit);
4683 # error recovery: fall back on head version below
4684 print "E Failed to find $filename version=$revision\n";
4685 $log->warning("failed get $revision");
4686 undef $revision; # Allow fallback
4690 if(!defined($revision))
4692 my $db_query;
4693 $db_query = $self->{dbh}->prepare_cached(
4694 "SELECT * FROM $tablename_head WHERE name=?",{},1);
4695 $db_query->execute($filename);
4696 $meta = $db_query->fetchrow_hashref;
4699 if($meta)
4701 $meta->{revision} = "1.$meta->{revision}";
4703 return $meta;
4706 sub getMetaFromCommithash
4708 my $self = shift;
4709 my $filename = shift;
4710 my $revCommit = shift;
4712 # NOTE: This function doesn't scale well (lots of forks), especially
4713 # if you have many files that have not been modified for many commits
4714 # (each git-rev-parse redoes a lot of work for each file
4715 # that theoretically could be done in parallel by smarter
4716 # graph traversal).
4718 # TODO: Possible optimization strategies:
4719 # - Solve the issue of assigning and remembering "real" CVS
4720 # revision numbers for branches, and ensure the
4721 # data structure can do this efficiently. Perhaps something
4722 # similar to "git notes", and carefully structured to take
4723 # advantage same-sha1-is-same-contents, to roll the same
4724 # unmodified subdirectory data onto multiple commits?
4725 # - Write and use a C tool that is like git-blame, but
4726 # operates on multiple files with file granularity, instead
4727 # of one file with line granularity. Cache
4728 # most-recently-modified in $self->{commitRefCache}{$revCommit}.
4729 # Try to be intelligent about how many files we do with
4730 # one fork (perhaps one directory at a time, without recursion,
4731 # and/or include directory as one line item, recurse from here
4732 # instead of in C tool?).
4733 # - Perhaps we could ask the DB for (filename,fileHash),
4734 # and just guess that it is correct (that the file hadn't
4735 # changed between $revCommit and the found commit, then
4736 # changed back, confusing anything trying to interpret
4737 # history). Probably need to add another index to revisions
4738 # DB table for this.
4739 # - NOTE: Trying to store all (commit,file) keys in DB [to
4740 # find "lastModfiedCommit] (instead of
4741 # just files that changed in each commit as we do now) is
4742 # probably not practical from a disk space perspective.
4744 # Does the file exist in $revCommit?
4745 # TODO: Include file hash in dirmap cache.
4746 my($dirMap)=$self->getRevisionDirMap($revCommit);
4747 my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%);
4748 if(!defined($dir))
4750 $dir="";
4752 if( !defined($dirMap->{$dir}) ||
4753 !defined($dirMap->{$dir}{$filename}) )
4755 my($fileHash)="deleted";
4757 my($retVal)={};
4758 $retVal->{name}=$filename;
4759 $retVal->{filehash}=$fileHash;
4761 # not needed and difficult to compute:
4762 $retVal->{revision}="0"; # $revision;
4763 $retVal->{commithash}=$revCommit;
4764 #$retVal->{author}=$commit->{author};
4765 #$retVal->{modified}=convertToCvsDate($commit->{date});
4766 #$retVal->{mode}=convertToDbMode($mode);
4768 return $retVal;
4771 my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename");
4772 chomp $fileHash;
4773 if(!($fileHash=~/^[0-9a-f]{$state->{hexsz}}$/))
4775 die "Invalid fileHash '$fileHash' looking up"
4776 ." '$revCommit:$filename'\n";
4779 # information about most recent commit to modify $filename:
4780 open(my $gitLogPipe, '-|', 'git', 'rev-list',
4781 '--max-count=1', '--pretty', '--parents',
4782 $revCommit, '--', $filename)
4783 or die "Cannot call git-rev-list: $!";
4784 my @commits=readCommits($gitLogPipe);
4785 close $gitLogPipe;
4786 if(scalar(@commits)!=1)
4788 die "Can't find most recent commit changing $filename\n";
4790 my($commit)=$commits[0];
4791 if( !defined($commit) || !defined($commit->{hash}) )
4793 return undef;
4796 # does this (commit,file) have a real assigned CVS revision number?
4797 my $tablename_rev = $self->tablename("revision");
4798 my $db_query;
4799 $db_query = $self->{dbh}->prepare_cached(
4800 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4801 {},1);
4802 $db_query->execute($filename, $commit->{hash});
4803 my($meta)=$db_query->fetchrow_hashref;
4804 if($meta)
4806 $meta->{revision} = "1.$meta->{revision}";
4807 return $meta;
4810 # fall back on special revision number
4811 my($revision)=$commit->{hash};
4812 $revision=~s/(..)/'.' . (hex($1)+100)/eg;
4813 $revision="2.1.1.2000$revision";
4815 # meta data about $filename:
4816 open(my $filePipe, '-|', 'git', 'ls-tree', '-z',
4817 $commit->{hash}, '--', $filename)
4818 or die("Cannot call git-ls-tree : $!");
4819 local $/ = "\0";
4820 my $line;
4821 $line=<$filePipe>;
4822 if(defined(<$filePipe>))
4824 die "Expected only a single file for git-ls-tree $filename\n";
4826 close $filePipe;
4828 chomp $line;
4829 unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4831 die("Couldn't process git-ls-tree line : $line\n");
4833 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4835 # save result:
4836 my($retVal)={};
4837 $retVal->{name}=$filename;
4838 $retVal->{revision}=$revision;
4839 $retVal->{filehash}=$fileHash;
4840 $retVal->{commithash}=$revCommit;
4841 $retVal->{author}=$commit->{author};
4842 $retVal->{modified}=convertToCvsDate($commit->{date});
4843 $retVal->{mode}=convertToDbMode($mode);
4845 return $retVal;
4848 =head2 lookupCommitRef
4850 Convert tag/branch/abbreviation/etc into a commit sha1 hash. Caches
4851 the result so looking it up again is fast.
4853 =cut
4855 sub lookupCommitRef
4857 my $self = shift;
4858 my $ref = shift;
4860 my $commitHash = $self->{commitRefCache}{$ref};
4861 if(defined($commitHash))
4863 return $commitHash;
4866 $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet",
4867 $self->unescapeRefName($ref));
4868 $commitHash=~s/\s*$//;
4869 if(!($commitHash=~/^[0-9a-f]{$state->{hexsz}}$/))
4871 $commitHash=undef;
4874 if( defined($commitHash) )
4876 my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash);
4877 if( ! ($type=~/^commit\s*$/ ) )
4879 $commitHash=undef;
4882 if(defined($commitHash))
4884 $self->{commitRefCache}{$ref}=$commitHash;
4886 return $commitHash;
4889 =head2 clearCommitRefCaches
4891 Clears cached commit cache (sha1's for various tags/abbeviations/etc),
4892 and related caches.
4894 =cut
4896 sub clearCommitRefCaches
4898 my $self = shift;
4899 $self->{commitRefCache} = {};
4900 $self->{revisionDirMapCache} = undef;
4901 $self->{gethead_cache} = undef;
4904 =head2 commitmessage
4906 this function takes a commithash and returns the commit message for that commit
4908 =cut
4909 sub commitmessage
4911 my $self = shift;
4912 my $commithash = shift;
4913 my $tablename = $self->tablename("commitmsgs");
4915 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{$state->{hexsz}}$/ );
4917 my $db_query;
4918 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
4919 $db_query->execute($commithash);
4921 my ( $message ) = $db_query->fetchrow_array;
4923 if ( defined ( $message ) )
4925 $message .= " " if ( $message =~ /\n$/ );
4926 return $message;
4929 my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash);
4930 shift @lines while ( $lines[0] =~ /\S/ );
4931 $message = join("",@lines);
4932 $message .= " " if ( $message =~ /\n$/ );
4933 return $message;
4936 =head2 gethistorydense
4938 This function takes a filename (with path) argument and returns an arrayofarrays
4939 containing revision,filehash,commithash ordered by revision descending.
4941 This version of gethistory skips deleted entries -- so it is useful for annotate.
4942 The 'dense' part is a reference to a '--dense' option available for git-rev-list
4943 and other git tools that depend on it.
4945 See also getlog().
4947 =cut
4948 sub gethistorydense
4950 my $self = shift;
4951 my $filename = shift;
4952 my $tablename = $self->tablename("revision");
4954 my $db_query;
4955 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
4956 $db_query->execute($filename);
4958 my $result = $db_query->fetchall_arrayref;
4960 my $i;
4961 for($i=0 ; $i<scalar(@$result) ; $i++)
4963 $result->[$i][0]="1." . $result->[$i][0];
4966 return $result;
4969 =head2 escapeRefName
4971 Apply an escape mechanism to compensate for characters that
4972 git ref names can have that CVS tags can not.
4974 =cut
4975 sub escapeRefName
4977 my($self,$refName)=@_;
4979 # CVS officially only allows [-_A-Za-z0-9] in tag names (or in
4980 # many contexts it can also be a CVS revision number).
4982 # Git tags commonly use '/' and '.' as well, but also handle
4983 # anything else just in case:
4985 # = "_-s-" For '/'.
4986 # = "_-p-" For '.'.
4987 # = "_-u-" For underscore, in case someone wants a literal "_-" in
4988 # a tag name.
4989 # = "_-xx-" Where "xx" is the hexadecimal representation of the
4990 # desired ASCII character byte. (for anything else)
4992 if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/)
4994 $refName=~s/_-/_-u--/g;
4995 $refName=~s/\./_-p-/g;
4996 $refName=~s%/%_-s-%g;
4997 $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg;
5001 =head2 unescapeRefName
5003 Undo an escape mechanism to compensate for characters that
5004 git ref names can have that CVS tags can not.
5006 =cut
5007 sub unescapeRefName
5009 my($self,$refName)=@_;
5011 # see escapeRefName() for description of escape mechanism.
5013 $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg;
5015 # allowed tag names
5016 # TODO: Perhaps use git check-ref-format, with an in-process cache of
5017 # validated names?
5018 if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) ||
5019 ( $refName=~m%[/.]$% ) ||
5020 ( $refName=~/\.lock$/ ) ||
5021 ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) ) # matching }
5023 # Error:
5024 $log->warn("illegal refName: $refName");
5025 $refName=undef;
5027 return $refName;
5030 sub unescapeRefNameChar
5032 my($char)=@_;
5034 if($char eq "s")
5036 $char="/";
5038 elsif($char eq "p")
5040 $char=".";
5042 elsif($char eq "u")
5044 $char="_";
5046 elsif($char=~/^[0-9a-f][0-9a-f]$/)
5048 $char=chr(hex($char));
5050 else
5052 # Error case: Maybe it has come straight from user, and
5053 # wasn't supposed to be escaped? Restore it the way we got it:
5054 $char="_-$char-";
5057 return $char;
5060 =head2 in_array()
5062 from Array::PAT - mimics the in_array() function
5063 found in PHP. Yuck but works for small arrays.
5065 =cut
5066 sub in_array
5068 my ($check, @array) = @_;
5069 my $retval = 0;
5070 foreach my $test (@array){
5071 if($check eq $test){
5072 $retval = 1;
5075 return $retval;
5078 =head2 mangle_dirname
5080 create a string from a directory name that is suitable to use as
5081 part of a filename, mainly by converting all chars except \w.- to _
5083 =cut
5084 sub mangle_dirname {
5085 my $dirname = shift;
5086 return unless defined $dirname;
5088 $dirname =~ s/[^\w.-]/_/g;
5090 return $dirname;
5093 =head2 mangle_tablename
5095 create a string from a that is suitable to use as part of an SQL table
5096 name, mainly by converting all chars except \w to _
5098 =cut
5099 sub mangle_tablename {
5100 my $tablename = shift;
5101 return unless defined $tablename;
5103 $tablename =~ s/[^\w_]/_/g;
5105 return $tablename;