remote: make guess_remote_head() use exact HEAD lookup if it is available
[git/mingw.git] / git-cvsserver.perl
blobab6cea3e538047c30a5d728c7a16ee3c935c070b
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@catalyst.net.nz>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use strict;
19 use warnings;
20 use bytes;
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Path qw/rmtree/;
25 use File::Basename;
26 use Getopt::Long qw(:config require_order no_ignore_case);
28 my $VERSION = '@@GIT_VERSION@@';
30 my $log = GITCVS::log->new();
31 my $cfg;
33 my $DATE_LIST = {
34 Jan => "01",
35 Feb => "02",
36 Mar => "03",
37 Apr => "04",
38 May => "05",
39 Jun => "06",
40 Jul => "07",
41 Aug => "08",
42 Sep => "09",
43 Oct => "10",
44 Nov => "11",
45 Dec => "12",
48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
49 $| = 1;
51 #### Definition and mappings of functions ####
53 my $methods = {
54 'Root' => \&req_Root,
55 'Valid-responses' => \&req_Validresponses,
56 'valid-requests' => \&req_validrequests,
57 'Directory' => \&req_Directory,
58 'Entry' => \&req_Entry,
59 'Modified' => \&req_Modified,
60 'Unchanged' => \&req_Unchanged,
61 'Questionable' => \&req_Questionable,
62 'Argument' => \&req_Argument,
63 'Argumentx' => \&req_Argument,
64 'expand-modules' => \&req_expandmodules,
65 'add' => \&req_add,
66 'remove' => \&req_remove,
67 'co' => \&req_co,
68 'update' => \&req_update,
69 'ci' => \&req_ci,
70 'diff' => \&req_diff,
71 'log' => \&req_log,
72 'rlog' => \&req_log,
73 'tag' => \&req_CATCHALL,
74 'status' => \&req_status,
75 'admin' => \&req_CATCHALL,
76 'history' => \&req_CATCHALL,
77 'watchers' => \&req_EMPTY,
78 'editors' => \&req_EMPTY,
79 'noop' => \&req_EMPTY,
80 'annotate' => \&req_annotate,
81 'Global_option' => \&req_Globaloption,
82 #'annotate' => \&req_CATCHALL,
85 ##############################################
88 # $state holds all the bits of information the clients sends us that could
89 # potentially be useful when it comes to actually _doing_ something.
90 my $state = { prependdir => '' };
92 # Work is for managing temporary working directory
93 my $work =
95 state => undef, # undef, 1 (empty), 2 (with stuff)
96 workDir => undef,
97 index => undef,
98 emptyDir => undef,
99 tmpDir => undef
102 $log->info("--------------- STARTING -----------------");
104 my $usage =
105 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
106 " --base-path <path> : Prepend to requested CVSROOT\n".
107 " --strict-paths : Don't allow recursing into subdirectories\n".
108 " --export-all : Don't check for gitcvs.enabled in config\n".
109 " --version, -V : Print version information and exit\n".
110 " --help, -h, -H : Print usage information and exit\n".
111 "\n".
112 "<directory> ... is a list of allowed directories. If no directories\n".
113 "are given, all are allowed. This is an additional restriction, gitcvs\n".
114 "access still needs to be enabled by the gitcvs.enabled config option.\n";
116 my @opts = ( 'help|h|H', 'version|V',
117 'base-path=s', 'strict-paths', 'export-all' );
118 GetOptions( $state, @opts )
119 or die $usage;
121 if ($state->{version}) {
122 print "git-cvsserver version $VERSION\n";
123 exit;
125 if ($state->{help}) {
126 print $usage;
127 exit;
130 my $TEMP_DIR = tempdir( CLEANUP => 1 );
131 $log->debug("Temporary directory is '$TEMP_DIR'");
133 $state->{method} = 'ext';
134 if (@ARGV) {
135 if ($ARGV[0] eq 'pserver') {
136 $state->{method} = 'pserver';
137 shift @ARGV;
138 } elsif ($ARGV[0] eq 'server') {
139 shift @ARGV;
143 # everything else is a directory
144 $state->{allowed_roots} = [ @ARGV ];
146 # don't export the whole system unless the users requests it
147 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
148 die "--export-all can only be used together with an explicit whitelist\n";
151 # if we are called with a pserver argument,
152 # deal with the authentication cat before entering the
153 # main loop
154 if ($state->{method} eq 'pserver') {
155 my $line = <STDIN>; chomp $line;
156 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
157 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
159 my $request = $1;
160 $line = <STDIN>; chomp $line;
161 unless (req_Root('root', $line)) { # reuse Root
162 print "E Invalid root $line \n";
163 exit 1;
165 $line = <STDIN>; chomp $line;
166 unless ($line eq 'anonymous') {
167 print "E Only anonymous user allowed via pserver\n";
168 print "I HATE YOU\n";
169 exit 1;
171 $line = <STDIN>; chomp $line; # validate the password?
172 $line = <STDIN>; chomp $line;
173 unless ($line eq "END $request REQUEST") {
174 die "E Do not understand $line -- expecting END $request REQUEST\n";
176 print "I LOVE YOU\n";
177 exit if $request eq 'VERIFICATION'; # cvs login
178 # and now back to our regular programme...
181 # Keep going until the client closes the connection
182 while (<STDIN>)
184 chomp;
186 # Check to see if we've seen this method, and call appropriate function.
187 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
189 # use the $methods hash to call the appropriate sub for this command
190 #$log->info("Method : $1");
191 &{$methods->{$1}}($1,$2);
192 } else {
193 # log fatal because we don't understand this function. If this happens
194 # we're fairly screwed because we don't know if the client is expecting
195 # a response. If it is, the client will hang, we'll hang, and the whole
196 # thing will be custard.
197 $log->fatal("Don't understand command $_\n");
198 die("Unknown command $_");
202 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
203 $log->info("--------------- FINISH -----------------");
205 chdir '/';
206 exit 0;
208 # Magic catchall method.
209 # This is the method that will handle all commands we haven't yet
210 # implemented. It simply sends a warning to the log file indicating a
211 # command that hasn't been implemented has been invoked.
212 sub req_CATCHALL
214 my ( $cmd, $data ) = @_;
215 $log->warn("Unhandled command : req_$cmd : $data");
218 # This method invariably succeeds with an empty response.
219 sub req_EMPTY
221 print "ok\n";
224 # Root pathname \n
225 # Response expected: no. Tell the server which CVSROOT to use. Note that
226 # pathname is a local directory and not a fully qualified CVSROOT variable.
227 # pathname must already exist; if creating a new root, use the init
228 # request, not Root. pathname does not include the hostname of the server,
229 # how to access the server, etc.; by the time the CVS protocol is in use,
230 # connection, authentication, etc., are already taken care of. The Root
231 # request must be sent only once, and it must be sent before any requests
232 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
233 sub req_Root
235 my ( $cmd, $data ) = @_;
236 $log->debug("req_Root : $data");
238 unless ($data =~ m#^/#) {
239 print "error 1 Root must be an absolute pathname\n";
240 return 0;
243 my $cvsroot = $state->{'base-path'} || '';
244 $cvsroot =~ s#/+$##;
245 $cvsroot .= $data;
247 if ($state->{CVSROOT}
248 && ($state->{CVSROOT} ne $cvsroot)) {
249 print "error 1 Conflicting roots specified\n";
250 return 0;
253 $state->{CVSROOT} = $cvsroot;
255 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
257 if (@{$state->{allowed_roots}}) {
258 my $allowed = 0;
259 foreach my $dir (@{$state->{allowed_roots}}) {
260 next unless $dir =~ m#^/#;
261 $dir =~ s#/+$##;
262 if ($state->{'strict-paths'}) {
263 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
264 $allowed = 1;
265 last;
267 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
268 $allowed = 1;
269 last;
273 unless ($allowed) {
274 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
275 print "E \n";
276 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
277 return 0;
281 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
282 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
283 print "E \n";
284 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
285 return 0;
288 my @gitvars = `git-config -l`;
289 if ($?) {
290 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
291 print "E \n";
292 print "error 1 - problem executing git-config\n";
293 return 0;
295 foreach my $line ( @gitvars )
297 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
298 unless ($2) {
299 $cfg->{$1}{$3} = $4;
300 } else {
301 $cfg->{$1}{$2}{$3} = $4;
305 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
306 || $cfg->{gitcvs}{enabled});
307 unless ($state->{'export-all'} ||
308 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
309 print "E GITCVS emulation needs to be enabled on this repo\n";
310 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
311 print "E \n";
312 print "error 1 GITCVS emulation disabled\n";
313 return 0;
316 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
317 if ( $logfile )
319 $log->setfile($logfile);
320 } else {
321 $log->nofile();
324 return 1;
327 # Global_option option \n
328 # Response expected: no. Transmit one of the global options `-q', `-Q',
329 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
330 # variations (such as combining of options) are allowed. For graceful
331 # handling of valid-requests, it is probably better to make new global
332 # options separate requests, rather than trying to add them to this
333 # request.
334 sub req_Globaloption
336 my ( $cmd, $data ) = @_;
337 $log->debug("req_Globaloption : $data");
338 $state->{globaloptions}{$data} = 1;
341 # Valid-responses request-list \n
342 # Response expected: no. Tell the server what responses the client will
343 # accept. request-list is a space separated list of tokens.
344 sub req_Validresponses
346 my ( $cmd, $data ) = @_;
347 $log->debug("req_Validresponses : $data");
349 # TODO : re-enable this, currently it's not particularly useful
350 #$state->{validresponses} = [ split /\s+/, $data ];
353 # valid-requests \n
354 # Response expected: yes. Ask the server to send back a Valid-requests
355 # response.
356 sub req_validrequests
358 my ( $cmd, $data ) = @_;
360 $log->debug("req_validrequests");
362 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
363 $log->debug("SEND : ok");
365 print "Valid-requests " . join(" ",keys %$methods) . "\n";
366 print "ok\n";
369 # Directory local-directory \n
370 # Additional data: repository \n. Response expected: no. Tell the server
371 # what directory to use. The repository should be a directory name from a
372 # previous server response. Note that this both gives a default for Entry
373 # and Modified and also for ci and the other commands; normal usage is to
374 # send Directory for each directory in which there will be an Entry or
375 # Modified, and then a final Directory for the original directory, then the
376 # command. The local-directory is relative to the top level at which the
377 # command is occurring (i.e. the last Directory which is sent before the
378 # command); to indicate that top level, `.' should be sent for
379 # local-directory.
380 sub req_Directory
382 my ( $cmd, $data ) = @_;
384 my $repository = <STDIN>;
385 chomp $repository;
388 $state->{localdir} = $data;
389 $state->{repository} = $repository;
390 $state->{path} = $repository;
391 $state->{path} =~ s/^$state->{CVSROOT}\///;
392 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
393 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
395 $state->{directory} = $state->{localdir};
396 $state->{directory} = "" if ( $state->{directory} eq "." );
397 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
399 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
401 $log->info("Setting prepend to '$state->{path}'");
402 $state->{prependdir} = $state->{path};
403 foreach my $entry ( keys %{$state->{entries}} )
405 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
406 delete $state->{entries}{$entry};
410 if ( defined ( $state->{prependdir} ) )
412 $log->debug("Prepending '$state->{prependdir}' to state|directory");
413 $state->{directory} = $state->{prependdir} . $state->{directory}
415 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
418 # Entry entry-line \n
419 # Response expected: no. Tell the server what version of a file is on the
420 # local machine. The name in entry-line is a name relative to the directory
421 # most recently specified with Directory. If the user is operating on only
422 # some files in a directory, Entry requests for only those files need be
423 # included. If an Entry request is sent without Modified, Is-modified, or
424 # Unchanged, it means the file is lost (does not exist in the working
425 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
426 # are sent for the same file, Entry must be sent first. For a given file,
427 # one can send Modified, Is-modified, or Unchanged, but not more than one
428 # of these three.
429 sub req_Entry
431 my ( $cmd, $data ) = @_;
433 #$log->debug("req_Entry : $data");
435 my @data = split(/\//, $data);
437 $state->{entries}{$state->{directory}.$data[1]} = {
438 revision => $data[2],
439 conflict => $data[3],
440 options => $data[4],
441 tag_or_date => $data[5],
444 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
447 # Questionable filename \n
448 # Response expected: no. Additional data: no. Tell the server to check
449 # whether filename should be ignored, and if not, next time the server
450 # sends responses, send (in a M response) `?' followed by the directory and
451 # filename. filename must not contain `/'; it needs to be a file in the
452 # directory named by the most recent Directory request.
453 sub req_Questionable
455 my ( $cmd, $data ) = @_;
457 $log->debug("req_Questionable : $data");
458 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
461 # add \n
462 # Response expected: yes. Add a file or directory. This uses any previous
463 # Argument, Directory, Entry, or Modified requests, if they have been sent.
464 # The last Directory sent specifies the working directory at the time of
465 # the operation. To add a directory, send the directory to be added using
466 # Directory and Argument requests.
467 sub req_add
469 my ( $cmd, $data ) = @_;
471 argsplit("add");
473 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
474 $updater->update();
476 argsfromdir($updater);
478 my $addcount = 0;
480 foreach my $filename ( @{$state->{args}} )
482 $filename = filecleanup($filename);
484 my $meta = $updater->getmeta($filename);
485 my $wrev = revparse($filename);
487 if ($wrev && $meta && ($wrev < 0))
489 # previously removed file, add back
490 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
492 print "MT +updated\n";
493 print "MT text U \n";
494 print "MT fname $filename\n";
495 print "MT newline\n";
496 print "MT -updated\n";
498 unless ( $state->{globaloptions}{-n} )
500 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
502 print "Created $dirpart\n";
503 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
505 # this is an "entries" line
506 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
507 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
508 print "/$filepart/1.$meta->{revision}//$kopts/\n";
509 # permissions
510 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
511 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
512 # transmit file
513 transmitfile($meta->{filehash});
516 next;
519 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
521 print "E cvs add: nothing known about `$filename'\n";
522 next;
524 # TODO : check we're not squashing an already existing file
525 if ( defined ( $state->{entries}{$filename}{revision} ) )
527 print "E cvs add: `$filename' has already been entered\n";
528 next;
531 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
533 print "E cvs add: scheduling file `$filename' for addition\n";
535 print "Checked-in $dirpart\n";
536 print "$filename\n";
537 my $kopts = kopts_from_path($filename,"file",
538 $state->{entries}{$filename}{modified_filename});
539 print "/$filepart/0//$kopts/\n";
541 my $requestedKopts = $state->{opt}{k};
542 if(defined($requestedKopts))
544 $requestedKopts = "-k$requestedKopts";
546 else
548 $requestedKopts = "";
550 if( $kopts ne $requestedKopts )
552 $log->warn("Ignoring requested -k='$requestedKopts'"
553 . " for '$filename'; detected -k='$kopts' instead");
554 #TODO: Also have option to send warning to user?
557 $addcount++;
560 if ( $addcount == 1 )
562 print "E cvs add: use `cvs commit' to add this file permanently\n";
564 elsif ( $addcount > 1 )
566 print "E cvs add: use `cvs commit' to add these files permanently\n";
569 print "ok\n";
572 # remove \n
573 # Response expected: yes. Remove a file. This uses any previous Argument,
574 # Directory, Entry, or Modified requests, if they have been sent. The last
575 # Directory sent specifies the working directory at the time of the
576 # operation. Note that this request does not actually do anything to the
577 # repository; the only effect of a successful remove request is to supply
578 # the client with a new entries line containing `-' to indicate a removed
579 # file. In fact, the client probably could perform this operation without
580 # contacting the server, although using remove may cause the server to
581 # perform a few more checks. The client sends a subsequent ci request to
582 # actually record the removal in the repository.
583 sub req_remove
585 my ( $cmd, $data ) = @_;
587 argsplit("remove");
589 # Grab a handle to the SQLite db and do any necessary updates
590 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
591 $updater->update();
593 #$log->debug("add state : " . Dumper($state));
595 my $rmcount = 0;
597 foreach my $filename ( @{$state->{args}} )
599 $filename = filecleanup($filename);
601 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
603 print "E cvs remove: file `$filename' still in working directory\n";
604 next;
607 my $meta = $updater->getmeta($filename);
608 my $wrev = revparse($filename);
610 unless ( defined ( $wrev ) )
612 print "E cvs remove: nothing known about `$filename'\n";
613 next;
616 if ( defined($wrev) and $wrev < 0 )
618 print "E cvs remove: file `$filename' already scheduled for removal\n";
619 next;
622 unless ( $wrev == $meta->{revision} )
624 # TODO : not sure if the format of this message is quite correct.
625 print "E cvs remove: Up to date check failed for `$filename'\n";
626 next;
630 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
632 print "E cvs remove: scheduling `$filename' for removal\n";
634 print "Checked-in $dirpart\n";
635 print "$filename\n";
636 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
637 print "/$filepart/-1.$wrev//$kopts/\n";
639 $rmcount++;
642 if ( $rmcount == 1 )
644 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
646 elsif ( $rmcount > 1 )
648 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
651 print "ok\n";
654 # Modified filename \n
655 # Response expected: no. Additional data: mode, \n, file transmission. Send
656 # the server a copy of one locally modified file. filename is a file within
657 # the most recent directory sent with Directory; it must not contain `/'.
658 # If the user is operating on only some files in a directory, only those
659 # files need to be included. This can also be sent without Entry, if there
660 # is no entry for the file.
661 sub req_Modified
663 my ( $cmd, $data ) = @_;
665 my $mode = <STDIN>;
666 defined $mode
667 or (print "E end of file reading mode for $data\n"), return;
668 chomp $mode;
669 my $size = <STDIN>;
670 defined $size
671 or (print "E end of file reading size of $data\n"), return;
672 chomp $size;
674 # Grab config information
675 my $blocksize = 8192;
676 my $bytesleft = $size;
677 my $tmp;
679 # Get a filehandle/name to write it to
680 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
682 # Loop over file data writing out to temporary file.
683 while ( $bytesleft )
685 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
686 read STDIN, $tmp, $blocksize;
687 print $fh $tmp;
688 $bytesleft -= $blocksize;
691 close $fh
692 or (print "E failed to write temporary, $filename: $!\n"), return;
694 # Ensure we have something sensible for the file mode
695 if ( $mode =~ /u=(\w+)/ )
697 $mode = $1;
698 } else {
699 $mode = "rw";
702 # Save the file data in $state
703 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
704 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
705 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
706 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
708 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
711 # Unchanged filename \n
712 # Response expected: no. Tell the server that filename has not been
713 # modified in the checked out directory. The filename is a file within the
714 # most recent directory sent with Directory; it must not contain `/'.
715 sub req_Unchanged
717 my ( $cmd, $data ) = @_;
719 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
721 #$log->debug("req_Unchanged : $data");
724 # Argument text \n
725 # Response expected: no. Save argument for use in a subsequent command.
726 # Arguments accumulate until an argument-using command is given, at which
727 # point they are forgotten.
728 # Argumentx text \n
729 # Response expected: no. Append \n followed by text to the current argument
730 # being saved.
731 sub req_Argument
733 my ( $cmd, $data ) = @_;
735 # Argumentx means: append to last Argument (with a newline in front)
737 $log->debug("$cmd : $data");
739 if ( $cmd eq 'Argumentx') {
740 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
741 } else {
742 push @{$state->{arguments}}, $data;
746 # expand-modules \n
747 # Response expected: yes. Expand the modules which are specified in the
748 # arguments. Returns the data in Module-expansion responses. Note that the
749 # server can assume that this is checkout or export, not rtag or rdiff; the
750 # latter do not access the working directory and thus have no need to
751 # expand modules on the client side. Expand may not be the best word for
752 # what this request does. It does not necessarily tell you all the files
753 # contained in a module, for example. Basically it is a way of telling you
754 # which working directories the server needs to know about in order to
755 # handle a checkout of the specified modules. For example, suppose that the
756 # server has a module defined by
757 # aliasmodule -a 1dir
758 # That is, one can check out aliasmodule and it will take 1dir in the
759 # repository and check it out to 1dir in the working directory. Now suppose
760 # the client already has this module checked out and is planning on using
761 # the co request to update it. Without using expand-modules, the client
762 # would have two bad choices: it could either send information about all
763 # working directories under the current directory, which could be
764 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
765 # stands for 1dir, and neglect to send information for 1dir, which would
766 # lead to incorrect operation. With expand-modules, the client would first
767 # ask for the module to be expanded:
768 sub req_expandmodules
770 my ( $cmd, $data ) = @_;
772 argsplit();
774 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
776 unless ( ref $state->{arguments} eq "ARRAY" )
778 print "ok\n";
779 return;
782 foreach my $module ( @{$state->{arguments}} )
784 $log->debug("SEND : Module-expansion $module");
785 print "Module-expansion $module\n";
788 print "ok\n";
789 statecleanup();
792 # co \n
793 # Response expected: yes. Get files from the repository. This uses any
794 # previous Argument, Directory, Entry, or Modified requests, if they have
795 # been sent. Arguments to this command are module names; the client cannot
796 # know what directories they correspond to except by (1) just sending the
797 # co request, and then seeing what directory names the server sends back in
798 # its responses, and (2) the expand-modules request.
799 sub req_co
801 my ( $cmd, $data ) = @_;
803 argsplit("co");
805 # Provide list of modules, if -c was used.
806 if (exists $state->{opt}{c}) {
807 my $showref = `git show-ref --heads`;
808 for my $line (split '\n', $showref) {
809 if ( $line =~ m% refs/heads/(.*)$% ) {
810 print "M $1\t$1\n";
813 print "ok\n";
814 return 1;
817 my $module = $state->{args}[0];
818 $state->{module} = $module;
819 my $checkout_path = $module;
821 # use the user specified directory if we're given it
822 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
824 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
826 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
828 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
830 # Grab a handle to the SQLite db and do any necessary updates
831 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
832 $updater->update();
834 $checkout_path =~ s|/$||; # get rid of trailing slashes
836 # Eclipse seems to need the Clear-sticky command
837 # to prepare the 'Entries' file for the new directory.
838 print "Clear-sticky $checkout_path/\n";
839 print $state->{CVSROOT} . "/$module/\n";
840 print "Clear-static-directory $checkout_path/\n";
841 print $state->{CVSROOT} . "/$module/\n";
842 print "Clear-sticky $checkout_path/\n"; # yes, twice
843 print $state->{CVSROOT} . "/$module/\n";
844 print "Template $checkout_path/\n";
845 print $state->{CVSROOT} . "/$module/\n";
846 print "0\n";
848 # instruct the client that we're checking out to $checkout_path
849 print "E cvs checkout: Updating $checkout_path\n";
851 my %seendirs = ();
852 my $lastdir ='';
854 # recursive
855 sub prepdir {
856 my ($dir, $repodir, $remotedir, $seendirs) = @_;
857 my $parent = dirname($dir);
858 $dir =~ s|/+$||;
859 $repodir =~ s|/+$||;
860 $remotedir =~ s|/+$||;
861 $parent =~ s|/+$||;
862 $log->debug("announcedir $dir, $repodir, $remotedir" );
864 if ($parent eq '.' || $parent eq './') {
865 $parent = '';
867 # recurse to announce unseen parents first
868 if (length($parent) && !exists($seendirs->{$parent})) {
869 prepdir($parent, $repodir, $remotedir, $seendirs);
871 # Announce that we are going to modify at the parent level
872 if ($parent) {
873 print "E cvs checkout: Updating $remotedir/$parent\n";
874 } else {
875 print "E cvs checkout: Updating $remotedir\n";
877 print "Clear-sticky $remotedir/$parent/\n";
878 print "$repodir/$parent/\n";
880 print "Clear-static-directory $remotedir/$dir/\n";
881 print "$repodir/$dir/\n";
882 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
883 print "$repodir/$parent/\n";
884 print "Template $remotedir/$dir/\n";
885 print "$repodir/$dir/\n";
886 print "0\n";
888 $seendirs->{$dir} = 1;
891 foreach my $git ( @{$updater->gethead} )
893 # Don't want to check out deleted files
894 next if ( $git->{filehash} eq "deleted" );
896 my $fullName = $git->{name};
897 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
899 if (length($git->{dir}) && $git->{dir} ne './'
900 && $git->{dir} ne $lastdir ) {
901 unless (exists($seendirs{$git->{dir}})) {
902 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
903 $checkout_path, \%seendirs);
904 $lastdir = $git->{dir};
905 $seendirs{$git->{dir}} = 1;
907 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
910 # modification time of this file
911 print "Mod-time $git->{modified}\n";
913 # print some information to the client
914 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
916 print "M U $checkout_path/$git->{dir}$git->{name}\n";
917 } else {
918 print "M U $checkout_path/$git->{name}\n";
921 # instruct client we're sending a file to put in this path
922 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
924 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
926 # this is an "entries" line
927 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
928 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
929 # permissions
930 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
932 # transmit file
933 transmitfile($git->{filehash});
936 print "ok\n";
938 statecleanup();
941 # update \n
942 # Response expected: yes. Actually do a cvs update command. This uses any
943 # previous Argument, Directory, Entry, or Modified requests, if they have
944 # been sent. The last Directory sent specifies the working directory at the
945 # time of the operation. The -I option is not used--files which the client
946 # can decide whether to ignore are not mentioned and the client sends the
947 # Questionable request for others.
948 sub req_update
950 my ( $cmd, $data ) = @_;
952 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
954 argsplit("update");
957 # It may just be a client exploring the available heads/modules
958 # in that case, list them as top level directories and leave it
959 # at that. Eclipse uses this technique to offer you a list of
960 # projects (heads in this case) to checkout.
962 if ($state->{module} eq '') {
963 my $showref = `git show-ref --heads`;
964 print "E cvs update: Updating .\n";
965 for my $line (split '\n', $showref) {
966 if ( $line =~ m% refs/heads/(.*)$% ) {
967 print "E cvs update: New directory `$1'\n";
970 print "ok\n";
971 return 1;
975 # Grab a handle to the SQLite db and do any necessary updates
976 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
978 $updater->update();
980 argsfromdir($updater);
982 #$log->debug("update state : " . Dumper($state));
984 # foreach file specified on the command line ...
985 foreach my $filename ( @{$state->{args}} )
987 $filename = filecleanup($filename);
989 $log->debug("Processing file $filename");
991 # if we have a -C we should pretend we never saw modified stuff
992 if ( exists ( $state->{opt}{C} ) )
994 delete $state->{entries}{$filename}{modified_hash};
995 delete $state->{entries}{$filename}{modified_filename};
996 $state->{entries}{$filename}{unchanged} = 1;
999 my $meta;
1000 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1002 $meta = $updater->getmeta($filename, $1);
1003 } else {
1004 $meta = $updater->getmeta($filename);
1007 # If -p was given, "print" the contents of the requested revision.
1008 if ( exists ( $state->{opt}{p} ) ) {
1009 if ( defined ( $meta->{revision} ) ) {
1010 $log->info("Printing '$filename' revision " . $meta->{revision});
1012 transmitfile($meta->{filehash}, { print => 1 });
1015 next;
1018 if ( ! defined $meta )
1020 $meta = {
1021 name => $filename,
1022 revision => 0,
1023 filehash => 'added'
1027 my $oldmeta = $meta;
1029 my $wrev = revparse($filename);
1031 # If the working copy is an old revision, lets get that version too for comparison.
1032 if ( defined($wrev) and $wrev != $meta->{revision} )
1034 $oldmeta = $updater->getmeta($filename, $wrev);
1037 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1039 # Files are up to date if the working copy and repo copy have the same revision,
1040 # and the working copy is unmodified _and_ the user hasn't specified -C
1041 next if ( defined ( $wrev )
1042 and defined($meta->{revision})
1043 and $wrev == $meta->{revision}
1044 and $state->{entries}{$filename}{unchanged}
1045 and not exists ( $state->{opt}{C} ) );
1047 # If the working copy and repo copy have the same revision,
1048 # but the working copy is modified, tell the client it's modified
1049 if ( defined ( $wrev )
1050 and defined($meta->{revision})
1051 and $wrev == $meta->{revision}
1052 and defined($state->{entries}{$filename}{modified_hash})
1053 and not exists ( $state->{opt}{C} ) )
1055 $log->info("Tell the client the file is modified");
1056 print "MT text M \n";
1057 print "MT fname $filename\n";
1058 print "MT newline\n";
1059 next;
1062 if ( $meta->{filehash} eq "deleted" )
1064 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1066 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1068 print "E cvs update: `$filename' is no longer in the repository\n";
1069 # Don't want to actually _DO_ the update if -n specified
1070 unless ( $state->{globaloptions}{-n} ) {
1071 print "Removed $dirpart\n";
1072 print "$filepart\n";
1075 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1076 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1077 or $meta->{filehash} eq 'added' )
1079 # normal update, just send the new revision (either U=Update,
1080 # or A=Add, or R=Remove)
1081 if ( defined($wrev) && $wrev < 0 )
1083 $log->info("Tell the client the file is scheduled for removal");
1084 print "MT text R \n";
1085 print "MT fname $filename\n";
1086 print "MT newline\n";
1087 next;
1089 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1091 $log->info("Tell the client the file is scheduled for addition");
1092 print "MT text A \n";
1093 print "MT fname $filename\n";
1094 print "MT newline\n";
1095 next;
1098 else {
1099 $log->info("Updating '$filename' to ".$meta->{revision});
1100 print "MT +updated\n";
1101 print "MT text U \n";
1102 print "MT fname $filename\n";
1103 print "MT newline\n";
1104 print "MT -updated\n";
1107 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1109 # Don't want to actually _DO_ the update if -n specified
1110 unless ( $state->{globaloptions}{-n} )
1112 if ( defined ( $wrev ) )
1114 # instruct client we're sending a file to put in this path as a replacement
1115 print "Update-existing $dirpart\n";
1116 $log->debug("Updating existing file 'Update-existing $dirpart'");
1117 } else {
1118 # instruct client we're sending a file to put in this path as a new file
1119 print "Clear-static-directory $dirpart\n";
1120 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1121 print "Clear-sticky $dirpart\n";
1122 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1124 $log->debug("Creating new file 'Created $dirpart'");
1125 print "Created $dirpart\n";
1127 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1129 # this is an "entries" line
1130 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1131 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1132 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1134 # permissions
1135 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1136 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1138 # transmit file
1139 transmitfile($meta->{filehash});
1141 } else {
1142 $log->info("Updating '$filename'");
1143 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1145 my $mergeDir = setupTmpDir();
1147 my $file_local = $filepart . ".mine";
1148 my $mergedFile = "$mergeDir/$file_local";
1149 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1150 my $file_old = $filepart . "." . $oldmeta->{revision};
1151 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1152 my $file_new = $filepart . "." . $meta->{revision};
1153 transmitfile($meta->{filehash}, { targetfile => $file_new });
1155 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1156 $log->info("Merging $file_local, $file_old, $file_new");
1157 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1159 $log->debug("Temporary directory for merge is $mergeDir");
1161 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1162 $return >>= 8;
1164 cleanupTmpDir();
1166 if ( $return == 0 )
1168 $log->info("Merged successfully");
1169 print "M M $filename\n";
1170 $log->debug("Merged $dirpart");
1172 # Don't want to actually _DO_ the update if -n specified
1173 unless ( $state->{globaloptions}{-n} )
1175 print "Merged $dirpart\n";
1176 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1177 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1178 my $kopts = kopts_from_path("$dirpart/$filepart",
1179 "file",$mergedFile);
1180 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1181 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1184 elsif ( $return == 1 )
1186 $log->info("Merged with conflicts");
1187 print "E cvs update: conflicts found in $filename\n";
1188 print "M C $filename\n";
1190 # Don't want to actually _DO_ the update if -n specified
1191 unless ( $state->{globaloptions}{-n} )
1193 print "Merged $dirpart\n";
1194 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1195 my $kopts = kopts_from_path("$dirpart/$filepart",
1196 "file",$mergedFile);
1197 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1200 else
1202 $log->warn("Merge failed");
1203 next;
1206 # Don't want to actually _DO_ the update if -n specified
1207 unless ( $state->{globaloptions}{-n} )
1209 # permissions
1210 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1211 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1213 # transmit file, format is single integer on a line by itself (file
1214 # size) followed by the file contents
1215 # TODO : we should copy files in blocks
1216 my $data = `cat $mergedFile`;
1217 $log->debug("File size : " . length($data));
1218 print length($data) . "\n";
1219 print $data;
1225 print "ok\n";
1228 sub req_ci
1230 my ( $cmd, $data ) = @_;
1232 argsplit("ci");
1234 #$log->debug("State : " . Dumper($state));
1236 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1238 if ( $state->{method} eq 'pserver')
1240 print "error 1 pserver access cannot commit\n";
1241 cleanupWorkTree();
1242 exit;
1245 if ( -e $state->{CVSROOT} . "/index" )
1247 $log->warn("file 'index' already exists in the git repository");
1248 print "error 1 Index already exists in git repo\n";
1249 cleanupWorkTree();
1250 exit;
1253 # Grab a handle to the SQLite db and do any necessary updates
1254 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1255 $updater->update();
1257 # Remember where the head was at the beginning.
1258 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1259 chomp $parenthash;
1260 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1261 print "error 1 pserver cannot find the current HEAD of module";
1262 cleanupWorkTree();
1263 exit;
1266 setupWorkTree($parenthash);
1268 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1270 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1272 my @committedfiles = ();
1273 my %oldmeta;
1275 # foreach file specified on the command line ...
1276 foreach my $filename ( @{$state->{args}} )
1278 my $committedfile = $filename;
1279 $filename = filecleanup($filename);
1281 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1283 my $meta = $updater->getmeta($filename);
1284 $oldmeta{$filename} = $meta;
1286 my $wrev = revparse($filename);
1288 my ( $filepart, $dirpart ) = filenamesplit($filename);
1290 # do a checkout of the file if it is part of this tree
1291 if ($wrev) {
1292 system('git-checkout-index', '-f', '-u', $filename);
1293 unless ($? == 0) {
1294 die "Error running git-checkout-index -f -u $filename : $!";
1298 my $addflag = 0;
1299 my $rmflag = 0;
1300 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1301 $addflag = 1 unless ( -e $filename );
1303 # Do up to date checking
1304 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1306 # fail everything if an up to date check fails
1307 print "error 1 Up to date check failed for $filename\n";
1308 cleanupWorkTree();
1309 exit;
1312 push @committedfiles, $committedfile;
1313 $log->info("Committing $filename");
1315 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1317 unless ( $rmflag )
1319 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1320 rename $state->{entries}{$filename}{modified_filename},$filename;
1322 # Calculate modes to remove
1323 my $invmode = "";
1324 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1326 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1327 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1330 if ( $rmflag )
1332 $log->info("Removing file '$filename'");
1333 unlink($filename);
1334 system("git-update-index", "--remove", $filename);
1336 elsif ( $addflag )
1338 $log->info("Adding file '$filename'");
1339 system("git-update-index", "--add", $filename);
1340 } else {
1341 $log->info("Updating file '$filename'");
1342 system("git-update-index", $filename);
1346 unless ( scalar(@committedfiles) > 0 )
1348 print "E No files to commit\n";
1349 print "ok\n";
1350 cleanupWorkTree();
1351 return;
1354 my $treehash = `git-write-tree`;
1355 chomp $treehash;
1357 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1359 # write our commit message out if we have one ...
1360 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1361 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1362 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1363 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1364 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1366 } else {
1367 print $msg_fh "\n\nvia git-CVS emulator\n";
1369 close $msg_fh;
1371 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1372 chomp($commithash);
1373 $log->info("Commit hash : $commithash");
1375 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1377 $log->warn("Commit failed (Invalid commit hash)");
1378 print "error 1 Commit failed (unknown reason)\n";
1379 cleanupWorkTree();
1380 exit;
1383 ### Emulate git-receive-pack by running hooks/update
1384 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1385 $parenthash, $commithash );
1386 if( -x $hook[0] ) {
1387 unless( system( @hook ) == 0 )
1389 $log->warn("Commit failed (update hook declined to update ref)");
1390 print "error 1 Commit failed (update hook declined)\n";
1391 cleanupWorkTree();
1392 exit;
1396 ### Update the ref
1397 if (system(qw(git update-ref -m), "cvsserver ci",
1398 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1399 $log->warn("update-ref for $state->{module} failed.");
1400 print "error 1 Cannot commit -- update first\n";
1401 cleanupWorkTree();
1402 exit;
1405 ### Emulate git-receive-pack by running hooks/post-receive
1406 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1407 if( -x $hook ) {
1408 open(my $pipe, "| $hook") || die "can't fork $!";
1410 local $SIG{PIPE} = sub { die 'pipe broke' };
1412 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1414 close $pipe || die "bad pipe: $! $?";
1417 $updater->update();
1419 ### Then hooks/post-update
1420 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1421 if (-x $hook) {
1422 system($hook, "refs/heads/$state->{module}");
1425 # foreach file specified on the command line ...
1426 foreach my $filename ( @committedfiles )
1428 $filename = filecleanup($filename);
1430 my $meta = $updater->getmeta($filename);
1431 unless (defined $meta->{revision}) {
1432 $meta->{revision} = 1;
1435 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1437 $log->debug("Checked-in $dirpart : $filename");
1439 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1440 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1442 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1443 print "Remove-entry $dirpart\n";
1444 print "$filename\n";
1445 } else {
1446 if ($meta->{revision} == 1) {
1447 print "M initial revision: 1.1\n";
1448 } else {
1449 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1451 print "Checked-in $dirpart\n";
1452 print "$filename\n";
1453 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1454 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1458 cleanupWorkTree();
1459 print "ok\n";
1462 sub req_status
1464 my ( $cmd, $data ) = @_;
1466 argsplit("status");
1468 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1469 #$log->debug("status state : " . Dumper($state));
1471 # Grab a handle to the SQLite db and do any necessary updates
1472 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1473 $updater->update();
1475 # if no files were specified, we need to work out what files we should be providing status on ...
1476 argsfromdir($updater);
1478 # foreach file specified on the command line ...
1479 foreach my $filename ( @{$state->{args}} )
1481 $filename = filecleanup($filename);
1483 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1485 my $meta = $updater->getmeta($filename);
1486 my $oldmeta = $meta;
1488 my $wrev = revparse($filename);
1490 # If the working copy is an old revision, lets get that version too for comparison.
1491 if ( defined($wrev) and $wrev != $meta->{revision} )
1493 $oldmeta = $updater->getmeta($filename, $wrev);
1496 # TODO : All possible statuses aren't yet implemented
1497 my $status;
1498 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1499 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1501 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1502 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1505 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1506 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1508 ( $state->{entries}{$filename}{unchanged}
1509 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1512 # Need checkout if it exists in the repo but doesn't have a working copy
1513 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1515 # Locally modified if working copy and repo copy have the same revision but there are local changes
1516 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1518 # Needs Merge if working copy revision is less than repo copy and there are local changes
1519 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1521 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1522 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1523 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1524 $status ||= "File had conflicts on merge" if ( 0 );
1526 $status ||= "Unknown";
1528 my ($filepart) = filenamesplit($filename);
1530 print "M ===================================================================\n";
1531 print "M File: $filepart\tStatus: $status\n";
1532 if ( defined($state->{entries}{$filename}{revision}) )
1534 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1535 } else {
1536 print "M Working revision:\tNo entry for $filename\n";
1538 if ( defined($meta->{revision}) )
1540 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1541 print "M Sticky Tag:\t\t(none)\n";
1542 print "M Sticky Date:\t\t(none)\n";
1543 print "M Sticky Options:\t\t(none)\n";
1544 } else {
1545 print "M Repository revision:\tNo revision control file\n";
1547 print "M\n";
1550 print "ok\n";
1553 sub req_diff
1555 my ( $cmd, $data ) = @_;
1557 argsplit("diff");
1559 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1560 #$log->debug("status state : " . Dumper($state));
1562 my ($revision1, $revision2);
1563 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1565 $revision1 = $state->{opt}{r}[0];
1566 $revision2 = $state->{opt}{r}[1];
1567 } else {
1568 $revision1 = $state->{opt}{r};
1571 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1572 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1574 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1576 # Grab a handle to the SQLite db and do any necessary updates
1577 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1578 $updater->update();
1580 # if no files were specified, we need to work out what files we should be providing status on ...
1581 argsfromdir($updater);
1583 # foreach file specified on the command line ...
1584 foreach my $filename ( @{$state->{args}} )
1586 $filename = filecleanup($filename);
1588 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1590 my $wrev = revparse($filename);
1592 # We need _something_ to diff against
1593 next unless ( defined ( $wrev ) );
1595 # if we have a -r switch, use it
1596 if ( defined ( $revision1 ) )
1598 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1599 $meta1 = $updater->getmeta($filename, $revision1);
1600 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1602 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1603 next;
1605 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1607 # otherwise we just use the working copy revision
1608 else
1610 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1611 $meta1 = $updater->getmeta($filename, $wrev);
1612 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1615 # if we have a second -r switch, use it too
1616 if ( defined ( $revision2 ) )
1618 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1619 $meta2 = $updater->getmeta($filename, $revision2);
1621 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1623 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1624 next;
1627 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1629 # otherwise we just use the working copy
1630 else
1632 $file2 = $state->{entries}{$filename}{modified_filename};
1635 # if we have been given -r, and we don't have a $file2 yet, lets get one
1636 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1638 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1639 $meta2 = $updater->getmeta($filename, $wrev);
1640 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1643 # We need to have retrieved something useful
1644 next unless ( defined ( $meta1 ) );
1646 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1647 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1649 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1650 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1653 # Apparently we only show diffs for locally modified files
1654 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1656 print "M Index: $filename\n";
1657 print "M ===================================================================\n";
1658 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1659 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1660 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1661 print "M diff ";
1662 foreach my $opt ( keys %{$state->{opt}} )
1664 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1666 foreach my $value ( @{$state->{opt}{$opt}} )
1668 print "-$opt $value ";
1670 } else {
1671 print "-$opt ";
1672 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1675 print "$filename\n";
1677 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1679 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1681 if ( exists $state->{opt}{u} )
1683 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1684 } else {
1685 system("diff $file1 $file2 > $filediff");
1688 while ( <$fh> )
1690 print "M $_";
1692 close $fh;
1695 print "ok\n";
1698 sub req_log
1700 my ( $cmd, $data ) = @_;
1702 argsplit("log");
1704 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1705 #$log->debug("log state : " . Dumper($state));
1707 my ( $minrev, $maxrev );
1708 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1710 my $control = $2;
1711 $minrev = $1;
1712 $maxrev = $3;
1713 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1714 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1715 $minrev++ if ( defined($minrev) and $control eq "::" );
1718 # Grab a handle to the SQLite db and do any necessary updates
1719 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1720 $updater->update();
1722 # if no files were specified, we need to work out what files we should be providing status on ...
1723 argsfromdir($updater);
1725 # foreach file specified on the command line ...
1726 foreach my $filename ( @{$state->{args}} )
1728 $filename = filecleanup($filename);
1730 my $headmeta = $updater->getmeta($filename);
1732 my $revisions = $updater->getlog($filename);
1733 my $totalrevisions = scalar(@$revisions);
1735 if ( defined ( $minrev ) )
1737 $log->debug("Removing revisions less than $minrev");
1738 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1740 pop @$revisions;
1743 if ( defined ( $maxrev ) )
1745 $log->debug("Removing revisions greater than $maxrev");
1746 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1748 shift @$revisions;
1752 next unless ( scalar(@$revisions) );
1754 print "M \n";
1755 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1756 print "M Working file: $filename\n";
1757 print "M head: 1.$headmeta->{revision}\n";
1758 print "M branch:\n";
1759 print "M locks: strict\n";
1760 print "M access list:\n";
1761 print "M symbolic names:\n";
1762 print "M keyword substitution: kv\n";
1763 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1764 print "M description:\n";
1766 foreach my $revision ( @$revisions )
1768 print "M ----------------------------\n";
1769 print "M revision 1.$revision->{revision}\n";
1770 # reformat the date for log output
1771 $revision->{modified} = sprintf('%04d/%02d/%02d %s', $3, $DATE_LIST->{$2}, $1, $4 ) if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and defined($DATE_LIST->{$2}) );
1772 $revision->{author} = cvs_author($revision->{author});
1773 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1774 my $commitmessage = $updater->commitmessage($revision->{commithash});
1775 $commitmessage =~ s/^/M /mg;
1776 print $commitmessage . "\n";
1778 print "M =============================================================================\n";
1781 print "ok\n";
1784 sub req_annotate
1786 my ( $cmd, $data ) = @_;
1788 argsplit("annotate");
1790 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1791 #$log->debug("status state : " . Dumper($state));
1793 # Grab a handle to the SQLite db and do any necessary updates
1794 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1795 $updater->update();
1797 # if no files were specified, we need to work out what files we should be providing annotate on ...
1798 argsfromdir($updater);
1800 # we'll need a temporary checkout dir
1801 setupWorkTree();
1803 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1805 # foreach file specified on the command line ...
1806 foreach my $filename ( @{$state->{args}} )
1808 $filename = filecleanup($filename);
1810 my $meta = $updater->getmeta($filename);
1812 next unless ( $meta->{revision} );
1814 # get all the commits that this file was in
1815 # in dense format -- aka skip dead revisions
1816 my $revisions = $updater->gethistorydense($filename);
1817 my $lastseenin = $revisions->[0][2];
1819 # populate the temporary index based on the latest commit were we saw
1820 # the file -- but do it cheaply without checking out any files
1821 # TODO: if we got a revision from the client, use that instead
1822 # to look up the commithash in sqlite (still good to default to
1823 # the current head as we do now)
1824 system("git-read-tree", $lastseenin);
1825 unless ($? == 0)
1827 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1828 return;
1830 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1832 # do a checkout of the file
1833 system('git-checkout-index', '-f', '-u', $filename);
1834 unless ($? == 0) {
1835 print "E error running git-checkout-index -f -u $filename : $!\n";
1836 return;
1839 $log->info("Annotate $filename");
1841 # Prepare a file with the commits from the linearized
1842 # history that annotate should know about. This prevents
1843 # git-jsannotate telling us about commits we are hiding
1844 # from the client.
1846 my $a_hints = "$work->{workDir}/.annotate_hints";
1847 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1848 print "E failed to open '$a_hints' for writing: $!\n";
1849 return;
1851 for (my $i=0; $i < @$revisions; $i++)
1853 print ANNOTATEHINTS $revisions->[$i][2];
1854 if ($i+1 < @$revisions) { # have we got a parent?
1855 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1857 print ANNOTATEHINTS "\n";
1860 print ANNOTATEHINTS "\n";
1861 close ANNOTATEHINTS
1862 or (print "E failed to write $a_hints: $!\n"), return;
1864 my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1865 if (!open(ANNOTATE, "-|", @cmd)) {
1866 print "E error invoking ". join(' ',@cmd) .": $!\n";
1867 return;
1869 my $metadata = {};
1870 print "E Annotations for $filename\n";
1871 print "E ***************\n";
1872 while ( <ANNOTATE> )
1874 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1876 my $commithash = $1;
1877 my $data = $2;
1878 unless ( defined ( $metadata->{$commithash} ) )
1880 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1881 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1882 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1884 printf("M 1.%-5d (%-8s %10s): %s\n",
1885 $metadata->{$commithash}{revision},
1886 $metadata->{$commithash}{author},
1887 $metadata->{$commithash}{modified},
1888 $data
1890 } else {
1891 $log->warn("Error in annotate output! LINE: $_");
1892 print "E Annotate error \n";
1893 next;
1896 close ANNOTATE;
1899 # done; get out of the tempdir
1900 cleanupWorkTree();
1902 print "ok\n";
1906 # This method takes the state->{arguments} array and produces two new arrays.
1907 # The first is $state->{args} which is everything before the '--' argument, and
1908 # the second is $state->{files} which is everything after it.
1909 sub argsplit
1911 $state->{args} = [];
1912 $state->{files} = [];
1913 $state->{opt} = {};
1915 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1917 my $type = shift;
1919 if ( defined($type) )
1921 my $opt = {};
1922 $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" );
1923 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1924 $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" );
1925 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1926 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1927 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1928 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1929 $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" );
1932 while ( scalar ( @{$state->{arguments}} ) > 0 )
1934 my $arg = shift @{$state->{arguments}};
1936 next if ( $arg eq "--" );
1937 next unless ( $arg =~ /\S/ );
1939 # if the argument looks like a switch
1940 if ( $arg =~ /^-(\w)(.*)/ )
1942 # if it's a switch that takes an argument
1943 if ( $opt->{$1} )
1945 # If this switch has already been provided
1946 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1948 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1949 if ( length($2) > 0 )
1951 push @{$state->{opt}{$1}},$2;
1952 } else {
1953 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1955 } else {
1956 # if there's extra data in the arg, use that as the argument for the switch
1957 if ( length($2) > 0 )
1959 $state->{opt}{$1} = $2;
1960 } else {
1961 $state->{opt}{$1} = shift @{$state->{arguments}};
1964 } else {
1965 $state->{opt}{$1} = undef;
1968 else
1970 push @{$state->{args}}, $arg;
1974 else
1976 my $mode = 0;
1978 foreach my $value ( @{$state->{arguments}} )
1980 if ( $value eq "--" )
1982 $mode++;
1983 next;
1985 push @{$state->{args}}, $value if ( $mode == 0 );
1986 push @{$state->{files}}, $value if ( $mode == 1 );
1991 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1992 sub argsfromdir
1994 my $updater = shift;
1996 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1998 return if ( scalar ( @{$state->{args}} ) > 1 );
2000 my @gethead = @{$updater->gethead};
2002 # push added files
2003 foreach my $file (keys %{$state->{entries}}) {
2004 if ( exists $state->{entries}{$file}{revision} &&
2005 $state->{entries}{$file}{revision} == 0 )
2007 push @gethead, { name => $file, filehash => 'added' };
2011 if ( scalar(@{$state->{args}}) == 1 )
2013 my $arg = $state->{args}[0];
2014 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2016 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2018 foreach my $file ( @gethead )
2020 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2021 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2022 push @{$state->{args}}, $file->{name};
2025 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2026 } else {
2027 $log->info("Only one arg specified, populating file list automatically");
2029 $state->{args} = [];
2031 foreach my $file ( @gethead )
2033 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2034 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2035 push @{$state->{args}}, $file->{name};
2040 # This method cleans up the $state variable after a command that uses arguments has run
2041 sub statecleanup
2043 $state->{files} = [];
2044 $state->{args} = [];
2045 $state->{arguments} = [];
2046 $state->{entries} = {};
2049 sub revparse
2051 my $filename = shift;
2053 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2055 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2056 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2058 return undef;
2061 # This method takes a file hash and does a CVS "file transfer". Its
2062 # exact behaviour depends on a second, optional hash table argument:
2063 # - If $options->{targetfile}, dump the contents to that file;
2064 # - If $options->{print}, use M/MT to transmit the contents one line
2065 # at a time;
2066 # - Otherwise, transmit the size of the file, followed by the file
2067 # contents.
2068 sub transmitfile
2070 my $filehash = shift;
2071 my $options = shift;
2073 if ( defined ( $filehash ) and $filehash eq "deleted" )
2075 $log->warn("filehash is 'deleted'");
2076 return;
2079 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2081 my $type = `git-cat-file -t $filehash`;
2082 chomp $type;
2084 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2086 my $size = `git-cat-file -s $filehash`;
2087 chomp $size;
2089 $log->debug("transmitfile($filehash) size=$size, type=$type");
2091 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2093 if ( defined ( $options->{targetfile} ) )
2095 my $targetfile = $options->{targetfile};
2096 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2097 print NEWFILE $_ while ( <$fh> );
2098 close NEWFILE or die("Failed to write '$targetfile': $!");
2099 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2100 while ( <$fh> ) {
2101 if( /\n\z/ ) {
2102 print 'M ', $_;
2103 } else {
2104 print 'MT text ', $_, "\n";
2107 } else {
2108 print "$size\n";
2109 print while ( <$fh> );
2111 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2112 } else {
2113 die("Couldn't execute git-cat-file");
2117 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2118 # refers to the directory portion and the file portion of the filename
2119 # respectively
2120 sub filenamesplit
2122 my $filename = shift;
2123 my $fixforlocaldir = shift;
2125 my ( $filepart, $dirpart ) = ( $filename, "." );
2126 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2127 $dirpart .= "/";
2129 if ( $fixforlocaldir )
2131 $dirpart =~ s/^$state->{prependdir}//;
2134 return ( $filepart, $dirpart );
2137 sub filecleanup
2139 my $filename = shift;
2141 return undef unless(defined($filename));
2142 if ( $filename =~ /^\// )
2144 print "E absolute filenames '$filename' not supported by server\n";
2145 return undef;
2148 $filename =~ s/^\.\///g;
2149 $filename = $state->{prependdir} . $filename;
2150 return $filename;
2153 sub validateGitDir
2155 if( !defined($state->{CVSROOT}) )
2157 print "error 1 CVSROOT not specified\n";
2158 cleanupWorkTree();
2159 exit;
2161 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2163 print "error 1 Internally inconsistent CVSROOT\n";
2164 cleanupWorkTree();
2165 exit;
2169 # Setup working directory in a work tree with the requested version
2170 # loaded in the index.
2171 sub setupWorkTree
2173 my ($ver) = @_;
2175 validateGitDir();
2177 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2178 defined($work->{tmpDir}) )
2180 $log->warn("Bad work tree state management");
2181 print "error 1 Internal setup multiple work trees without cleanup\n";
2182 cleanupWorkTree();
2183 exit;
2186 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2188 if( !defined($work->{index}) )
2190 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2193 chdir $work->{workDir} or
2194 die "Unable to chdir to $work->{workDir}\n";
2196 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2198 $ENV{GIT_WORK_TREE} = ".";
2199 $ENV{GIT_INDEX_FILE} = $work->{index};
2200 $work->{state} = 2;
2202 if($ver)
2204 system("git","read-tree",$ver);
2205 unless ($? == 0)
2207 $log->warn("Error running git-read-tree");
2208 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2211 # else # req_annotate reads tree for each file
2214 # Ensure current directory is in some kind of working directory,
2215 # with a recent version loaded in the index.
2216 sub ensureWorkTree
2218 if( defined($work->{tmpDir}) )
2220 $log->warn("Bad work tree state management [ensureWorkTree()]");
2221 print "error 1 Internal setup multiple dirs without cleanup\n";
2222 cleanupWorkTree();
2223 exit;
2225 if( $work->{state} )
2227 return;
2230 validateGitDir();
2232 if( !defined($work->{emptyDir}) )
2234 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2236 chdir $work->{emptyDir} or
2237 die "Unable to chdir to $work->{emptyDir}\n";
2239 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2240 chomp $ver;
2241 if ($ver !~ /^[0-9a-f]{40}$/)
2243 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2244 print "error 1 cannot find the current HEAD of module";
2245 cleanupWorkTree();
2246 exit;
2249 if( !defined($work->{index}) )
2251 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2254 $ENV{GIT_WORK_TREE} = ".";
2255 $ENV{GIT_INDEX_FILE} = $work->{index};
2256 $work->{state} = 1;
2258 system("git","read-tree",$ver);
2259 unless ($? == 0)
2261 die "Error running git-read-tree $ver $!\n";
2265 # Cleanup working directory that is not needed any longer.
2266 sub cleanupWorkTree
2268 if( ! $work->{state} )
2270 return;
2273 chdir "/" or die "Unable to chdir '/'\n";
2275 if( defined($work->{workDir}) )
2277 rmtree( $work->{workDir} );
2278 undef $work->{workDir};
2280 undef $work->{state};
2283 # Setup a temporary directory (not a working tree), typically for
2284 # merging dirty state as in req_update.
2285 sub setupTmpDir
2287 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2288 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2290 return $work->{tmpDir};
2293 # Clean up a previously setupTmpDir. Restore previous work tree if
2294 # appropriate.
2295 sub cleanupTmpDir
2297 if ( !defined($work->{tmpDir}) )
2299 $log->warn("cleanup tmpdir that has not been setup");
2300 die "Cleanup tmpDir that has not been setup\n";
2302 if( defined($work->{state}) )
2304 if( $work->{state} == 1 )
2306 chdir $work->{emptyDir} or
2307 die "Unable to chdir to $work->{emptyDir}\n";
2309 elsif( $work->{state} == 2 )
2311 chdir $work->{workDir} or
2312 die "Unable to chdir to $work->{emptyDir}\n";
2314 else
2316 $log->warn("Inconsistent work dir state");
2317 die "Inconsistent work dir state\n";
2320 else
2322 chdir "/" or die "Unable to chdir '/'\n";
2326 # Given a path, this function returns a string containing the kopts
2327 # that should go into that path's Entries line. For example, a binary
2328 # file should get -kb.
2329 sub kopts_from_path
2331 my ($path, $srcType, $name) = @_;
2333 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2334 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2336 my ($val) = check_attr( "crlf", $path );
2337 if ( $val eq "set" )
2339 return "";
2341 elsif ( $val eq "unset" )
2343 return "-kb"
2345 else
2347 $log->info("Unrecognized check_attr crlf $path : $val");
2351 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2353 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2355 return "-kb";
2357 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2359 if( $srcType eq "sha1Or-k" &&
2360 !defined($name) )
2362 my ($ret)=$state->{entries}{$path}{options};
2363 if( !defined($ret) )
2365 $ret=$state->{opt}{k};
2366 if(defined($ret))
2368 $ret="-k$ret";
2370 else
2372 $ret="";
2375 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2377 print "E Bad -k option\n";
2378 $log->warn("Bad -k option: $ret");
2379 die "Error: Bad -k option: $ret\n";
2382 return $ret;
2384 else
2386 if( is_binary($srcType,$name) )
2388 $log->debug("... as binary");
2389 return "-kb";
2391 else
2393 $log->debug("... as text");
2398 # Return "" to give no special treatment to any path
2399 return "";
2402 sub check_attr
2404 my ($attr,$path) = @_;
2405 ensureWorkTree();
2406 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2408 my $val = <$fh>;
2409 close $fh;
2410 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2411 return $val;
2413 else
2415 return undef;
2419 # This should have the same heuristics as convert.c:is_binary() and related.
2420 # Note that the bare CR test is done by callers in convert.c.
2421 sub is_binary
2423 my ($srcType,$name) = @_;
2424 $log->debug("is_binary($srcType,$name)");
2426 # Minimize amount of interpreted code run in the inner per-character
2427 # loop for large files, by totalling each character value and
2428 # then analyzing the totals.
2429 my @counts;
2430 my $i;
2431 for($i=0;$i<256;$i++)
2433 $counts[$i]=0;
2436 my $fh = open_blob_or_die($srcType,$name);
2437 my $line;
2438 while( defined($line=<$fh>) )
2440 # Any '\0' and bare CR are considered binary.
2441 if( $line =~ /\0|(\r[^\n])/ )
2443 close($fh);
2444 return 1;
2447 # Count up each character in the line:
2448 my $len=length($line);
2449 for($i=0;$i<$len;$i++)
2451 $counts[ord(substr($line,$i,1))]++;
2454 close $fh;
2456 # Don't count CR and LF as either printable/nonprintable
2457 $counts[ord("\n")]=0;
2458 $counts[ord("\r")]=0;
2460 # Categorize individual character count into printable and nonprintable:
2461 my $printable=0;
2462 my $nonprintable=0;
2463 for($i=0;$i<256;$i++)
2465 if( $i < 32 &&
2466 $i != ord("\b") &&
2467 $i != ord("\t") &&
2468 $i != 033 && # ESC
2469 $i != 014 ) # FF
2471 $nonprintable+=$counts[$i];
2473 elsif( $i==127 ) # DEL
2475 $nonprintable+=$counts[$i];
2477 else
2479 $printable+=$counts[$i];
2483 return ($printable >> 7) < $nonprintable;
2486 # Returns open file handle. Possible invocations:
2487 # - open_blob_or_die("file",$filename);
2488 # - open_blob_or_die("sha1",$filehash);
2489 sub open_blob_or_die
2491 my ($srcType,$name) = @_;
2492 my ($fh);
2493 if( $srcType eq "file" )
2495 if( !open $fh,"<",$name )
2497 $log->warn("Unable to open file $name: $!");
2498 die "Unable to open file $name: $!\n";
2501 elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2503 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2505 $log->warn("Need filehash");
2506 die "Need filehash\n";
2509 my $type = `git cat-file -t $name`;
2510 chomp $type;
2512 unless ( defined ( $type ) and $type eq "blob" )
2514 $log->warn("Invalid type '$type' for '$name'");
2515 die ( "Invalid type '$type' (expected 'blob')" )
2518 my $size = `git cat-file -s $name`;
2519 chomp $size;
2521 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2523 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2525 $log->warn("Unable to open sha1 $name");
2526 die "Unable to open sha1 $name\n";
2529 else
2531 $log->warn("Unknown type of blob source: $srcType");
2532 die "Unknown type of blob source: $srcType\n";
2534 return $fh;
2537 # Generate a CVS author name from Git author information, by taking the local
2538 # part of the email address and replacing characters not in the Portable
2539 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2540 # Login names are Unix login names, which should be restricted to this
2541 # character set.
2542 sub cvs_author
2544 my $author_line = shift;
2545 (my $author) = $author_line =~ /<([^@>]*)/;
2547 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2548 $author =~ s/^-/_/;
2550 $author;
2553 package GITCVS::log;
2555 ####
2556 #### Copyright The Open University UK - 2006.
2557 ####
2558 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2559 #### Martin Langhoff <martin@catalyst.net.nz>
2560 ####
2561 ####
2563 use strict;
2564 use warnings;
2566 =head1 NAME
2568 GITCVS::log
2570 =head1 DESCRIPTION
2572 This module provides very crude logging with a similar interface to
2573 Log::Log4perl
2575 =head1 METHODS
2577 =cut
2579 =head2 new
2581 Creates a new log object, optionally you can specify a filename here to
2582 indicate the file to log to. If no log file is specified, you can specify one
2583 later with method setfile, or indicate you no longer want logging with method
2584 nofile.
2586 Until one of these methods is called, all log calls will buffer messages ready
2587 to write out.
2589 =cut
2590 sub new
2592 my $class = shift;
2593 my $filename = shift;
2595 my $self = {};
2597 bless $self, $class;
2599 if ( defined ( $filename ) )
2601 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2604 return $self;
2607 =head2 setfile
2609 This methods takes a filename, and attempts to open that file as the log file.
2610 If successful, all buffered data is written out to the file, and any further
2611 logging is written directly to the file.
2613 =cut
2614 sub setfile
2616 my $self = shift;
2617 my $filename = shift;
2619 if ( defined ( $filename ) )
2621 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2624 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2626 while ( my $line = shift @{$self->{buffer}} )
2628 print {$self->{fh}} $line;
2632 =head2 nofile
2634 This method indicates no logging is going to be used. It flushes any entries in
2635 the internal buffer, and sets a flag to ensure no further data is put there.
2637 =cut
2638 sub nofile
2640 my $self = shift;
2642 $self->{nolog} = 1;
2644 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2646 $self->{buffer} = [];
2649 =head2 _logopen
2651 Internal method. Returns true if the log file is open, false otherwise.
2653 =cut
2654 sub _logopen
2656 my $self = shift;
2658 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2659 return 0;
2662 =head2 debug info warn fatal
2664 These four methods are wrappers to _log. They provide the actual interface for
2665 logging data.
2667 =cut
2668 sub debug { my $self = shift; $self->_log("debug", @_); }
2669 sub info { my $self = shift; $self->_log("info" , @_); }
2670 sub warn { my $self = shift; $self->_log("warn" , @_); }
2671 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2673 =head2 _log
2675 This is an internal method called by the logging functions. It generates a
2676 timestamp and pushes the logged line either to file, or internal buffer.
2678 =cut
2679 sub _log
2681 my $self = shift;
2682 my $level = shift;
2684 return if ( $self->{nolog} );
2686 my @time = localtime;
2687 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2688 $time[5] + 1900,
2689 $time[4] + 1,
2690 $time[3],
2691 $time[2],
2692 $time[1],
2693 $time[0],
2694 uc $level,
2697 if ( $self->_logopen )
2699 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2700 } else {
2701 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2705 =head2 DESTROY
2707 This method simply closes the file handle if one is open
2709 =cut
2710 sub DESTROY
2712 my $self = shift;
2714 if ( $self->_logopen )
2716 close $self->{fh};
2720 package GITCVS::updater;
2722 ####
2723 #### Copyright The Open University UK - 2006.
2724 ####
2725 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2726 #### Martin Langhoff <martin@catalyst.net.nz>
2727 ####
2728 ####
2730 use strict;
2731 use warnings;
2732 use DBI;
2734 =head1 METHODS
2736 =cut
2738 =head2 new
2740 =cut
2741 sub new
2743 my $class = shift;
2744 my $config = shift;
2745 my $module = shift;
2746 my $log = shift;
2748 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2749 die "Need to specify a module" unless ( defined($module) );
2751 $class = ref($class) || $class;
2753 my $self = {};
2755 bless $self, $class;
2757 $self->{valid_tables} = {'revision' => 1,
2758 'revision_ix1' => 1,
2759 'revision_ix2' => 1,
2760 'head' => 1,
2761 'head_ix1' => 1,
2762 'properties' => 1,
2763 'commitmsgs' => 1};
2765 $self->{module} = $module;
2766 $self->{git_path} = $config . "/";
2768 $self->{log} = $log;
2770 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2772 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2773 $cfg->{gitcvs}{dbdriver} || "SQLite";
2774 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2775 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2776 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2777 $cfg->{gitcvs}{dbuser} || "";
2778 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2779 $cfg->{gitcvs}{dbpass} || "";
2780 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2781 $cfg->{gitcvs}{dbtablenameprefix} || "";
2782 my %mapping = ( m => $module,
2783 a => $state->{method},
2784 u => getlogin || getpwuid($<) || $<,
2785 G => $self->{git_path},
2786 g => mangle_dirname($self->{git_path}),
2788 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2789 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2790 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2791 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2793 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2794 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2795 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2796 $self->{dbuser},
2797 $self->{dbpass});
2798 die "Error connecting to database\n" unless defined $self->{dbh};
2800 $self->{tables} = {};
2801 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2803 $self->{tables}{$table} = 1;
2806 # Construct the revision table if required
2807 unless ( $self->{tables}{$self->tablename("revision")} )
2809 my $tablename = $self->tablename("revision");
2810 my $ix1name = $self->tablename("revision_ix1");
2811 my $ix2name = $self->tablename("revision_ix2");
2812 $self->{dbh}->do("
2813 CREATE TABLE $tablename (
2814 name TEXT NOT NULL,
2815 revision INTEGER NOT NULL,
2816 filehash TEXT NOT NULL,
2817 commithash TEXT NOT NULL,
2818 author TEXT NOT NULL,
2819 modified TEXT NOT NULL,
2820 mode TEXT NOT NULL
2823 $self->{dbh}->do("
2824 CREATE INDEX $ix1name
2825 ON $tablename (name,revision)
2827 $self->{dbh}->do("
2828 CREATE INDEX $ix2name
2829 ON $tablename (name,commithash)
2833 # Construct the head table if required
2834 unless ( $self->{tables}{$self->tablename("head")} )
2836 my $tablename = $self->tablename("head");
2837 my $ix1name = $self->tablename("head_ix1");
2838 $self->{dbh}->do("
2839 CREATE TABLE $tablename (
2840 name TEXT NOT NULL,
2841 revision INTEGER NOT NULL,
2842 filehash TEXT NOT NULL,
2843 commithash TEXT NOT NULL,
2844 author TEXT NOT NULL,
2845 modified TEXT NOT NULL,
2846 mode TEXT NOT NULL
2849 $self->{dbh}->do("
2850 CREATE INDEX $ix1name
2851 ON $tablename (name)
2855 # Construct the properties table if required
2856 unless ( $self->{tables}{$self->tablename("properties")} )
2858 my $tablename = $self->tablename("properties");
2859 $self->{dbh}->do("
2860 CREATE TABLE $tablename (
2861 key TEXT NOT NULL PRIMARY KEY,
2862 value TEXT
2867 # Construct the commitmsgs table if required
2868 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2870 my $tablename = $self->tablename("commitmsgs");
2871 $self->{dbh}->do("
2872 CREATE TABLE $tablename (
2873 key TEXT NOT NULL PRIMARY KEY,
2874 value TEXT
2879 return $self;
2882 =head2 tablename
2884 =cut
2885 sub tablename
2887 my $self = shift;
2888 my $name = shift;
2890 if (exists $self->{valid_tables}{$name}) {
2891 return $self->{dbtablenameprefix} . $name;
2892 } else {
2893 return undef;
2897 =head2 update
2899 =cut
2900 sub update
2902 my $self = shift;
2904 # first lets get the commit list
2905 $ENV{GIT_DIR} = $self->{git_path};
2907 my $commitsha1 = `git rev-parse $self->{module}`;
2908 chomp $commitsha1;
2910 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2911 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2913 die("Invalid module '$self->{module}'");
2917 my $git_log;
2918 my $lastcommit = $self->_get_prop("last_commit");
2920 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2921 return 1;
2924 # Start exclusive lock here...
2925 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2927 # TODO: log processing is memory bound
2928 # if we can parse into a 2nd file that is in reverse order
2929 # we can probably do something really efficient
2930 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2932 if (defined $lastcommit) {
2933 push @git_log_params, "$lastcommit..$self->{module}";
2934 } else {
2935 push @git_log_params, $self->{module};
2937 # git-rev-list is the backend / plumbing version of git-log
2938 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2940 my @commits;
2942 my %commit = ();
2944 while ( <GITLOG> )
2946 chomp;
2947 if (m/^commit\s+(.*)$/) {
2948 # on ^commit lines put the just seen commit in the stack
2949 # and prime things for the next one
2950 if (keys %commit) {
2951 my %copy = %commit;
2952 unshift @commits, \%copy;
2953 %commit = ();
2955 my @parents = split(m/\s+/, $1);
2956 $commit{hash} = shift @parents;
2957 $commit{parents} = \@parents;
2958 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2959 # on rfc822-like lines seen before we see any message,
2960 # lowercase the entry and put it in the hash as key-value
2961 $commit{lc($1)} = $2;
2962 } else {
2963 # message lines - skip initial empty line
2964 # and trim whitespace
2965 if (!exists($commit{message}) && m/^\s*$/) {
2966 # define it to mark the end of headers
2967 $commit{message} = '';
2968 next;
2970 s/^\s+//; s/\s+$//; # trim ws
2971 $commit{message} .= $_ . "\n";
2974 close GITLOG;
2976 unshift @commits, \%commit if ( keys %commit );
2978 # Now all the commits are in the @commits bucket
2979 # ordered by time DESC. for each commit that needs processing,
2980 # determine whether it's following the last head we've seen or if
2981 # it's on its own branch, grab a file list, and add whatever's changed
2982 # NOTE: $lastcommit refers to the last commit from previous run
2983 # $lastpicked is the last commit we picked in this run
2984 my $lastpicked;
2985 my $head = {};
2986 if (defined $lastcommit) {
2987 $lastpicked = $lastcommit;
2990 my $committotal = scalar(@commits);
2991 my $commitcount = 0;
2993 # Load the head table into $head (for cached lookups during the update process)
2994 foreach my $file ( @{$self->gethead()} )
2996 $head->{$file->{name}} = $file;
2999 foreach my $commit ( @commits )
3001 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3002 if (defined $lastpicked)
3004 if (!in_array($lastpicked, @{$commit->{parents}}))
3006 # skip, we'll see this delta
3007 # as part of a merge later
3008 # warn "skipping off-track $commit->{hash}\n";
3009 next;
3010 } elsif (@{$commit->{parents}} > 1) {
3011 # it is a merge commit, for each parent that is
3012 # not $lastpicked, see if we can get a log
3013 # from the merge-base to that parent to put it
3014 # in the message as a merge summary.
3015 my @parents = @{$commit->{parents}};
3016 foreach my $parent (@parents) {
3017 # git-merge-base can potentially (but rarely) throw
3018 # several candidate merge bases. let's assume
3019 # that the first one is the best one.
3020 if ($parent eq $lastpicked) {
3021 next;
3023 my $base = eval {
3024 safe_pipe_capture('git-merge-base',
3025 $lastpicked, $parent);
3027 # The two branches may not be related at all,
3028 # in which case merge base simply fails to find
3029 # any, but that's Ok.
3030 next if ($@);
3032 chomp $base;
3033 if ($base) {
3034 my @merged;
3035 # print "want to log between $base $parent \n";
3036 open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
3037 or die "Cannot call git-log: $!";
3038 my $mergedhash;
3039 while (<GITLOG>) {
3040 chomp;
3041 if (!defined $mergedhash) {
3042 if (m/^commit\s+(.+)$/) {
3043 $mergedhash = $1;
3044 } else {
3045 next;
3047 } else {
3048 # grab the first line that looks non-rfc822
3049 # aka has content after leading space
3050 if (m/^\s+(\S.*)$/) {
3051 my $title = $1;
3052 $title = substr($title,0,100); # truncate
3053 unshift @merged, "$mergedhash $title";
3054 undef $mergedhash;
3058 close GITLOG;
3059 if (@merged) {
3060 $commit->{mergemsg} = $commit->{message};
3061 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3062 foreach my $summary (@merged) {
3063 $commit->{mergemsg} .= "\t$summary\n";
3065 $commit->{mergemsg} .= "\n\n";
3066 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3073 # convert the date to CVS-happy format
3074 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3076 if ( defined ( $lastpicked ) )
3078 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3079 local ($/) = "\0";
3080 while ( <FILELIST> )
3082 chomp;
3083 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3085 die("Couldn't process git-diff-tree line : $_");
3087 my ($mode, $hash, $change) = ($1, $2, $3);
3088 my $name = <FILELIST>;
3089 chomp($name);
3091 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3093 my $git_perms = "";
3094 $git_perms .= "r" if ( $mode & 4 );
3095 $git_perms .= "w" if ( $mode & 2 );
3096 $git_perms .= "x" if ( $mode & 1 );
3097 $git_perms = "rw" if ( $git_perms eq "" );
3099 if ( $change eq "D" )
3101 #$log->debug("DELETE $name");
3102 $head->{$name} = {
3103 name => $name,
3104 revision => $head->{$name}{revision} + 1,
3105 filehash => "deleted",
3106 commithash => $commit->{hash},
3107 modified => $commit->{date},
3108 author => $commit->{author},
3109 mode => $git_perms,
3111 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3113 elsif ( $change eq "M" || $change eq "T" )
3115 #$log->debug("MODIFIED $name");
3116 $head->{$name} = {
3117 name => $name,
3118 revision => $head->{$name}{revision} + 1,
3119 filehash => $hash,
3120 commithash => $commit->{hash},
3121 modified => $commit->{date},
3122 author => $commit->{author},
3123 mode => $git_perms,
3125 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3127 elsif ( $change eq "A" )
3129 #$log->debug("ADDED $name");
3130 $head->{$name} = {
3131 name => $name,
3132 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3133 filehash => $hash,
3134 commithash => $commit->{hash},
3135 modified => $commit->{date},
3136 author => $commit->{author},
3137 mode => $git_perms,
3139 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3141 else
3143 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3144 die;
3147 close FILELIST;
3148 } else {
3149 # this is used to detect files removed from the repo
3150 my $seen_files = {};
3152 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3153 local $/ = "\0";
3154 while ( <FILELIST> )
3156 chomp;
3157 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3159 die("Couldn't process git-ls-tree line : $_");
3162 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3164 $seen_files->{$git_filename} = 1;
3166 my ( $oldhash, $oldrevision, $oldmode ) = (
3167 $head->{$git_filename}{filehash},
3168 $head->{$git_filename}{revision},
3169 $head->{$git_filename}{mode}
3172 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3174 $git_perms = "";
3175 $git_perms .= "r" if ( $1 & 4 );
3176 $git_perms .= "w" if ( $1 & 2 );
3177 $git_perms .= "x" if ( $1 & 1 );
3178 } else {
3179 $git_perms = "rw";
3182 # unless the file exists with the same hash, we need to update it ...
3183 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3185 my $newrevision = ( $oldrevision or 0 ) + 1;
3187 $head->{$git_filename} = {
3188 name => $git_filename,
3189 revision => $newrevision,
3190 filehash => $git_hash,
3191 commithash => $commit->{hash},
3192 modified => $commit->{date},
3193 author => $commit->{author},
3194 mode => $git_perms,
3198 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3201 close FILELIST;
3203 # Detect deleted files
3204 foreach my $file ( keys %$head )
3206 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3208 $head->{$file}{revision}++;
3209 $head->{$file}{filehash} = "deleted";
3210 $head->{$file}{commithash} = $commit->{hash};
3211 $head->{$file}{modified} = $commit->{date};
3212 $head->{$file}{author} = $commit->{author};
3214 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3217 # END : "Detect deleted files"
3221 if (exists $commit->{mergemsg})
3223 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3226 $lastpicked = $commit->{hash};
3228 $self->_set_prop("last_commit", $commit->{hash});
3231 $self->delete_head();
3232 foreach my $file ( keys %$head )
3234 $self->insert_head(
3235 $file,
3236 $head->{$file}{revision},
3237 $head->{$file}{filehash},
3238 $head->{$file}{commithash},
3239 $head->{$file}{modified},
3240 $head->{$file}{author},
3241 $head->{$file}{mode},
3244 # invalidate the gethead cache
3245 $self->{gethead_cache} = undef;
3248 # Ending exclusive lock here
3249 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3252 sub insert_rev
3254 my $self = shift;
3255 my $name = shift;
3256 my $revision = shift;
3257 my $filehash = shift;
3258 my $commithash = shift;
3259 my $modified = shift;
3260 my $author = shift;
3261 my $mode = shift;
3262 my $tablename = $self->tablename("revision");
3264 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3265 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3268 sub insert_mergelog
3270 my $self = shift;
3271 my $key = shift;
3272 my $value = shift;
3273 my $tablename = $self->tablename("commitmsgs");
3275 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3276 $insert_mergelog->execute($key, $value);
3279 sub delete_head
3281 my $self = shift;
3282 my $tablename = $self->tablename("head");
3284 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3285 $delete_head->execute();
3288 sub insert_head
3290 my $self = shift;
3291 my $name = shift;
3292 my $revision = shift;
3293 my $filehash = shift;
3294 my $commithash = shift;
3295 my $modified = shift;
3296 my $author = shift;
3297 my $mode = shift;
3298 my $tablename = $self->tablename("head");
3300 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3301 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3304 sub _headrev
3306 my $self = shift;
3307 my $filename = shift;
3308 my $tablename = $self->tablename("head");
3310 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3311 $db_query->execute($filename);
3312 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3314 return ( $hash, $revision, $mode );
3317 sub _get_prop
3319 my $self = shift;
3320 my $key = shift;
3321 my $tablename = $self->tablename("properties");
3323 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3324 $db_query->execute($key);
3325 my ( $value ) = $db_query->fetchrow_array;
3327 return $value;
3330 sub _set_prop
3332 my $self = shift;
3333 my $key = shift;
3334 my $value = shift;
3335 my $tablename = $self->tablename("properties");
3337 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3338 $db_query->execute($value, $key);
3340 unless ( $db_query->rows )
3342 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3343 $db_query->execute($key, $value);
3346 return $value;
3349 =head2 gethead
3351 =cut
3353 sub gethead
3355 my $self = shift;
3356 my $tablename = $self->tablename("head");
3358 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3360 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3361 $db_query->execute();
3363 my $tree = [];
3364 while ( my $file = $db_query->fetchrow_hashref )
3366 push @$tree, $file;
3369 $self->{gethead_cache} = $tree;
3371 return $tree;
3374 =head2 getlog
3376 =cut
3378 sub getlog
3380 my $self = shift;
3381 my $filename = shift;
3382 my $tablename = $self->tablename("revision");
3384 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3385 $db_query->execute($filename);
3387 my $tree = [];
3388 while ( my $file = $db_query->fetchrow_hashref )
3390 push @$tree, $file;
3393 return $tree;
3396 =head2 getmeta
3398 This function takes a filename (with path) argument and returns a hashref of
3399 metadata for that file.
3401 =cut
3403 sub getmeta
3405 my $self = shift;
3406 my $filename = shift;
3407 my $revision = shift;
3408 my $tablename_rev = $self->tablename("revision");
3409 my $tablename_head = $self->tablename("head");
3411 my $db_query;
3412 if ( defined($revision) and $revision =~ /^\d+$/ )
3414 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3415 $db_query->execute($filename, $revision);
3417 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3419 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3420 $db_query->execute($filename, $revision);
3421 } else {
3422 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3423 $db_query->execute($filename);
3426 return $db_query->fetchrow_hashref;
3429 =head2 commitmessage
3431 this function takes a commithash and returns the commit message for that commit
3433 =cut
3434 sub commitmessage
3436 my $self = shift;
3437 my $commithash = shift;
3438 my $tablename = $self->tablename("commitmsgs");
3440 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3442 my $db_query;
3443 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3444 $db_query->execute($commithash);
3446 my ( $message ) = $db_query->fetchrow_array;
3448 if ( defined ( $message ) )
3450 $message .= " " if ( $message =~ /\n$/ );
3451 return $message;
3454 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3455 shift @lines while ( $lines[0] =~ /\S/ );
3456 $message = join("",@lines);
3457 $message .= " " if ( $message =~ /\n$/ );
3458 return $message;
3461 =head2 gethistory
3463 This function takes a filename (with path) argument and returns an arrayofarrays
3464 containing revision,filehash,commithash ordered by revision descending
3466 =cut
3467 sub gethistory
3469 my $self = shift;
3470 my $filename = shift;
3471 my $tablename = $self->tablename("revision");
3473 my $db_query;
3474 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3475 $db_query->execute($filename);
3477 return $db_query->fetchall_arrayref;
3480 =head2 gethistorydense
3482 This function takes a filename (with path) argument and returns an arrayofarrays
3483 containing revision,filehash,commithash ordered by revision descending.
3485 This version of gethistory skips deleted entries -- so it is useful for annotate.
3486 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3487 and other git tools that depend on it.
3489 =cut
3490 sub gethistorydense
3492 my $self = shift;
3493 my $filename = shift;
3494 my $tablename = $self->tablename("revision");
3496 my $db_query;
3497 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3498 $db_query->execute($filename);
3500 return $db_query->fetchall_arrayref;
3503 =head2 in_array()
3505 from Array::PAT - mimics the in_array() function
3506 found in PHP. Yuck but works for small arrays.
3508 =cut
3509 sub in_array
3511 my ($check, @array) = @_;
3512 my $retval = 0;
3513 foreach my $test (@array){
3514 if($check eq $test){
3515 $retval = 1;
3518 return $retval;
3521 =head2 safe_pipe_capture
3523 an alternative to `command` that allows input to be passed as an array
3524 to work around shell problems with weird characters in arguments
3526 =cut
3527 sub safe_pipe_capture {
3529 my @output;
3531 if (my $pid = open my $child, '-|') {
3532 @output = (<$child>);
3533 close $child or die join(' ',@_).": $! $?";
3534 } else {
3535 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3537 return wantarray ? @output : join('',@output);
3540 =head2 mangle_dirname
3542 create a string from a directory name that is suitable to use as
3543 part of a filename, mainly by converting all chars except \w.- to _
3545 =cut
3546 sub mangle_dirname {
3547 my $dirname = shift;
3548 return unless defined $dirname;
3550 $dirname =~ s/[^\w.-]/_/g;
3552 return $dirname;
3555 =head2 mangle_tablename
3557 create a string from a that is suitable to use as part of an SQL table
3558 name, mainly by converting all chars except \w to _
3560 =cut
3561 sub mangle_tablename {
3562 my $tablename = shift;
3563 return unless defined $tablename;
3565 $tablename =~ s/[^\w_]/_/g;
3567 return $tablename;