gitk: Second try to work around the command line limit on Windows
[git/dscho.git] / git-cvsserver.perl
blob13751db882dd2c40e2c78503eba0d3f941297644
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 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
108 " --strict-paths : Don't allow recursing into subdirectories\n".
109 " --export-all : Don't check for gitcvs.enabled in config\n".
110 " --version, -V : Print version information and exit\n".
111 " --help, -h, -H : Print usage information and exit\n".
112 "\n".
113 "<directory> ... is a list of allowed directories. If no directories\n".
114 "are given, all are allowed. This is an additional restriction, gitcvs\n".
115 "access still needs to be enabled by the gitcvs.enabled config option.\n".
116 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
118 my @opts = ( 'help|h|H', 'version|V',
119 'base-path=s', 'strict-paths', 'export-all' );
120 GetOptions( $state, @opts )
121 or die $usage;
123 if ($state->{version}) {
124 print "git-cvsserver version $VERSION\n";
125 exit;
127 if ($state->{help}) {
128 print $usage;
129 exit;
132 my $TEMP_DIR = tempdir( CLEANUP => 1 );
133 $log->debug("Temporary directory is '$TEMP_DIR'");
135 $state->{method} = 'ext';
136 if (@ARGV) {
137 if ($ARGV[0] eq 'pserver') {
138 $state->{method} = 'pserver';
139 shift @ARGV;
140 } elsif ($ARGV[0] eq 'server') {
141 shift @ARGV;
145 # everything else is a directory
146 $state->{allowed_roots} = [ @ARGV ];
148 # don't export the whole system unless the users requests it
149 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
150 die "--export-all can only be used together with an explicit whitelist\n";
153 # Environment handling for running under git-shell
154 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
155 if ($state->{'base-path'}) {
156 die "Cannot specify base path both ways.\n";
158 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
159 $state->{'base-path'} = $base_path;
160 $log->debug("Picked up base path '$base_path' from environment.\n");
162 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
163 if (@{$state->{allowed_roots}}) {
164 die "Cannot specify roots both ways: @ARGV\n";
166 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
167 $state->{allowed_roots} = [ $allowed_root ];
168 $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
171 # if we are called with a pserver argument,
172 # deal with the authentication cat before entering the
173 # main loop
174 if ($state->{method} eq 'pserver') {
175 my $line = <STDIN>; chomp $line;
176 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
177 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
179 my $request = $1;
180 $line = <STDIN>; chomp $line;
181 unless (req_Root('root', $line)) { # reuse Root
182 print "E Invalid root $line \n";
183 exit 1;
185 $line = <STDIN>; chomp $line;
186 unless ($line eq 'anonymous') {
187 print "E Only anonymous user allowed via pserver\n";
188 print "I HATE YOU\n";
189 exit 1;
191 $line = <STDIN>; chomp $line; # validate the password?
192 $line = <STDIN>; chomp $line;
193 unless ($line eq "END $request REQUEST") {
194 die "E Do not understand $line -- expecting END $request REQUEST\n";
196 print "I LOVE YOU\n";
197 exit if $request eq 'VERIFICATION'; # cvs login
198 # and now back to our regular programme...
201 # Keep going until the client closes the connection
202 while (<STDIN>)
204 chomp;
206 # Check to see if we've seen this method, and call appropriate function.
207 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
209 # use the $methods hash to call the appropriate sub for this command
210 #$log->info("Method : $1");
211 &{$methods->{$1}}($1,$2);
212 } else {
213 # log fatal because we don't understand this function. If this happens
214 # we're fairly screwed because we don't know if the client is expecting
215 # a response. If it is, the client will hang, we'll hang, and the whole
216 # thing will be custard.
217 $log->fatal("Don't understand command $_\n");
218 die("Unknown command $_");
222 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
223 $log->info("--------------- FINISH -----------------");
225 chdir '/';
226 exit 0;
228 # Magic catchall method.
229 # This is the method that will handle all commands we haven't yet
230 # implemented. It simply sends a warning to the log file indicating a
231 # command that hasn't been implemented has been invoked.
232 sub req_CATCHALL
234 my ( $cmd, $data ) = @_;
235 $log->warn("Unhandled command : req_$cmd : $data");
238 # This method invariably succeeds with an empty response.
239 sub req_EMPTY
241 print "ok\n";
244 # Root pathname \n
245 # Response expected: no. Tell the server which CVSROOT to use. Note that
246 # pathname is a local directory and not a fully qualified CVSROOT variable.
247 # pathname must already exist; if creating a new root, use the init
248 # request, not Root. pathname does not include the hostname of the server,
249 # how to access the server, etc.; by the time the CVS protocol is in use,
250 # connection, authentication, etc., are already taken care of. The Root
251 # request must be sent only once, and it must be sent before any requests
252 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
253 sub req_Root
255 my ( $cmd, $data ) = @_;
256 $log->debug("req_Root : $data");
258 unless ($data =~ m#^/#) {
259 print "error 1 Root must be an absolute pathname\n";
260 return 0;
263 my $cvsroot = $state->{'base-path'} || '';
264 $cvsroot =~ s#/+$##;
265 $cvsroot .= $data;
267 if ($state->{CVSROOT}
268 && ($state->{CVSROOT} ne $cvsroot)) {
269 print "error 1 Conflicting roots specified\n";
270 return 0;
273 $state->{CVSROOT} = $cvsroot;
275 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
277 if (@{$state->{allowed_roots}}) {
278 my $allowed = 0;
279 foreach my $dir (@{$state->{allowed_roots}}) {
280 next unless $dir =~ m#^/#;
281 $dir =~ s#/+$##;
282 if ($state->{'strict-paths'}) {
283 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
284 $allowed = 1;
285 last;
287 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
288 $allowed = 1;
289 last;
293 unless ($allowed) {
294 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
295 print "E \n";
296 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
297 return 0;
301 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
302 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
303 print "E \n";
304 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
305 return 0;
308 my @gitvars = `git config -l`;
309 if ($?) {
310 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
311 print "E \n";
312 print "error 1 - problem executing git-config\n";
313 return 0;
315 foreach my $line ( @gitvars )
317 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
318 unless ($2) {
319 $cfg->{$1}{$3} = $4;
320 } else {
321 $cfg->{$1}{$2}{$3} = $4;
325 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
326 || $cfg->{gitcvs}{enabled});
327 unless ($state->{'export-all'} ||
328 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
329 print "E GITCVS emulation needs to be enabled on this repo\n";
330 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
331 print "E \n";
332 print "error 1 GITCVS emulation disabled\n";
333 return 0;
336 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
337 if ( $logfile )
339 $log->setfile($logfile);
340 } else {
341 $log->nofile();
344 return 1;
347 # Global_option option \n
348 # Response expected: no. Transmit one of the global options `-q', `-Q',
349 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
350 # variations (such as combining of options) are allowed. For graceful
351 # handling of valid-requests, it is probably better to make new global
352 # options separate requests, rather than trying to add them to this
353 # request.
354 sub req_Globaloption
356 my ( $cmd, $data ) = @_;
357 $log->debug("req_Globaloption : $data");
358 $state->{globaloptions}{$data} = 1;
361 # Valid-responses request-list \n
362 # Response expected: no. Tell the server what responses the client will
363 # accept. request-list is a space separated list of tokens.
364 sub req_Validresponses
366 my ( $cmd, $data ) = @_;
367 $log->debug("req_Validresponses : $data");
369 # TODO : re-enable this, currently it's not particularly useful
370 #$state->{validresponses} = [ split /\s+/, $data ];
373 # valid-requests \n
374 # Response expected: yes. Ask the server to send back a Valid-requests
375 # response.
376 sub req_validrequests
378 my ( $cmd, $data ) = @_;
380 $log->debug("req_validrequests");
382 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
383 $log->debug("SEND : ok");
385 print "Valid-requests " . join(" ",keys %$methods) . "\n";
386 print "ok\n";
389 # Directory local-directory \n
390 # Additional data: repository \n. Response expected: no. Tell the server
391 # what directory to use. The repository should be a directory name from a
392 # previous server response. Note that this both gives a default for Entry
393 # and Modified and also for ci and the other commands; normal usage is to
394 # send Directory for each directory in which there will be an Entry or
395 # Modified, and then a final Directory for the original directory, then the
396 # command. The local-directory is relative to the top level at which the
397 # command is occurring (i.e. the last Directory which is sent before the
398 # command); to indicate that top level, `.' should be sent for
399 # local-directory.
400 sub req_Directory
402 my ( $cmd, $data ) = @_;
404 my $repository = <STDIN>;
405 chomp $repository;
408 $state->{localdir} = $data;
409 $state->{repository} = $repository;
410 $state->{path} = $repository;
411 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
412 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
413 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
415 $state->{directory} = $state->{localdir};
416 $state->{directory} = "" if ( $state->{directory} eq "." );
417 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
419 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
421 $log->info("Setting prepend to '$state->{path}'");
422 $state->{prependdir} = $state->{path};
423 foreach my $entry ( keys %{$state->{entries}} )
425 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
426 delete $state->{entries}{$entry};
430 if ( defined ( $state->{prependdir} ) )
432 $log->debug("Prepending '$state->{prependdir}' to state|directory");
433 $state->{directory} = $state->{prependdir} . $state->{directory}
435 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
438 # Entry entry-line \n
439 # Response expected: no. Tell the server what version of a file is on the
440 # local machine. The name in entry-line is a name relative to the directory
441 # most recently specified with Directory. If the user is operating on only
442 # some files in a directory, Entry requests for only those files need be
443 # included. If an Entry request is sent without Modified, Is-modified, or
444 # Unchanged, it means the file is lost (does not exist in the working
445 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
446 # are sent for the same file, Entry must be sent first. For a given file,
447 # one can send Modified, Is-modified, or Unchanged, but not more than one
448 # of these three.
449 sub req_Entry
451 my ( $cmd, $data ) = @_;
453 #$log->debug("req_Entry : $data");
455 my @data = split(/\//, $data);
457 $state->{entries}{$state->{directory}.$data[1]} = {
458 revision => $data[2],
459 conflict => $data[3],
460 options => $data[4],
461 tag_or_date => $data[5],
464 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
467 # Questionable filename \n
468 # Response expected: no. Additional data: no. Tell the server to check
469 # whether filename should be ignored, and if not, next time the server
470 # sends responses, send (in a M response) `?' followed by the directory and
471 # filename. filename must not contain `/'; it needs to be a file in the
472 # directory named by the most recent Directory request.
473 sub req_Questionable
475 my ( $cmd, $data ) = @_;
477 $log->debug("req_Questionable : $data");
478 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
481 # add \n
482 # Response expected: yes. Add a file or directory. This uses any previous
483 # Argument, Directory, Entry, or Modified requests, if they have been sent.
484 # The last Directory sent specifies the working directory at the time of
485 # the operation. To add a directory, send the directory to be added using
486 # Directory and Argument requests.
487 sub req_add
489 my ( $cmd, $data ) = @_;
491 argsplit("add");
493 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
494 $updater->update();
496 argsfromdir($updater);
498 my $addcount = 0;
500 foreach my $filename ( @{$state->{args}} )
502 $filename = filecleanup($filename);
504 my $meta = $updater->getmeta($filename);
505 my $wrev = revparse($filename);
507 if ($wrev && $meta && ($wrev < 0))
509 # previously removed file, add back
510 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
512 print "MT +updated\n";
513 print "MT text U \n";
514 print "MT fname $filename\n";
515 print "MT newline\n";
516 print "MT -updated\n";
518 unless ( $state->{globaloptions}{-n} )
520 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
522 print "Created $dirpart\n";
523 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
525 # this is an "entries" line
526 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
527 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
528 print "/$filepart/1.$meta->{revision}//$kopts/\n";
529 # permissions
530 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
531 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
532 # transmit file
533 transmitfile($meta->{filehash});
536 next;
539 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
541 print "E cvs add: nothing known about `$filename'\n";
542 next;
544 # TODO : check we're not squashing an already existing file
545 if ( defined ( $state->{entries}{$filename}{revision} ) )
547 print "E cvs add: `$filename' has already been entered\n";
548 next;
551 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
553 print "E cvs add: scheduling file `$filename' for addition\n";
555 print "Checked-in $dirpart\n";
556 print "$filename\n";
557 my $kopts = kopts_from_path($filename,"file",
558 $state->{entries}{$filename}{modified_filename});
559 print "/$filepart/0//$kopts/\n";
561 my $requestedKopts = $state->{opt}{k};
562 if(defined($requestedKopts))
564 $requestedKopts = "-k$requestedKopts";
566 else
568 $requestedKopts = "";
570 if( $kopts ne $requestedKopts )
572 $log->warn("Ignoring requested -k='$requestedKopts'"
573 . " for '$filename'; detected -k='$kopts' instead");
574 #TODO: Also have option to send warning to user?
577 $addcount++;
580 if ( $addcount == 1 )
582 print "E cvs add: use `cvs commit' to add this file permanently\n";
584 elsif ( $addcount > 1 )
586 print "E cvs add: use `cvs commit' to add these files permanently\n";
589 print "ok\n";
592 # remove \n
593 # Response expected: yes. Remove a file. This uses any previous Argument,
594 # Directory, Entry, or Modified requests, if they have been sent. The last
595 # Directory sent specifies the working directory at the time of the
596 # operation. Note that this request does not actually do anything to the
597 # repository; the only effect of a successful remove request is to supply
598 # the client with a new entries line containing `-' to indicate a removed
599 # file. In fact, the client probably could perform this operation without
600 # contacting the server, although using remove may cause the server to
601 # perform a few more checks. The client sends a subsequent ci request to
602 # actually record the removal in the repository.
603 sub req_remove
605 my ( $cmd, $data ) = @_;
607 argsplit("remove");
609 # Grab a handle to the SQLite db and do any necessary updates
610 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
611 $updater->update();
613 #$log->debug("add state : " . Dumper($state));
615 my $rmcount = 0;
617 foreach my $filename ( @{$state->{args}} )
619 $filename = filecleanup($filename);
621 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
623 print "E cvs remove: file `$filename' still in working directory\n";
624 next;
627 my $meta = $updater->getmeta($filename);
628 my $wrev = revparse($filename);
630 unless ( defined ( $wrev ) )
632 print "E cvs remove: nothing known about `$filename'\n";
633 next;
636 if ( defined($wrev) and $wrev < 0 )
638 print "E cvs remove: file `$filename' already scheduled for removal\n";
639 next;
642 unless ( $wrev == $meta->{revision} )
644 # TODO : not sure if the format of this message is quite correct.
645 print "E cvs remove: Up to date check failed for `$filename'\n";
646 next;
650 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
652 print "E cvs remove: scheduling `$filename' for removal\n";
654 print "Checked-in $dirpart\n";
655 print "$filename\n";
656 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
657 print "/$filepart/-1.$wrev//$kopts/\n";
659 $rmcount++;
662 if ( $rmcount == 1 )
664 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
666 elsif ( $rmcount > 1 )
668 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
671 print "ok\n";
674 # Modified filename \n
675 # Response expected: no. Additional data: mode, \n, file transmission. Send
676 # the server a copy of one locally modified file. filename is a file within
677 # the most recent directory sent with Directory; it must not contain `/'.
678 # If the user is operating on only some files in a directory, only those
679 # files need to be included. This can also be sent without Entry, if there
680 # is no entry for the file.
681 sub req_Modified
683 my ( $cmd, $data ) = @_;
685 my $mode = <STDIN>;
686 defined $mode
687 or (print "E end of file reading mode for $data\n"), return;
688 chomp $mode;
689 my $size = <STDIN>;
690 defined $size
691 or (print "E end of file reading size of $data\n"), return;
692 chomp $size;
694 # Grab config information
695 my $blocksize = 8192;
696 my $bytesleft = $size;
697 my $tmp;
699 # Get a filehandle/name to write it to
700 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
702 # Loop over file data writing out to temporary file.
703 while ( $bytesleft )
705 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
706 read STDIN, $tmp, $blocksize;
707 print $fh $tmp;
708 $bytesleft -= $blocksize;
711 close $fh
712 or (print "E failed to write temporary, $filename: $!\n"), return;
714 # Ensure we have something sensible for the file mode
715 if ( $mode =~ /u=(\w+)/ )
717 $mode = $1;
718 } else {
719 $mode = "rw";
722 # Save the file data in $state
723 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
724 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
725 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git hash-object $filename`;
726 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
728 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
731 # Unchanged filename \n
732 # Response expected: no. Tell the server that filename has not been
733 # modified in the checked out directory. The filename is a file within the
734 # most recent directory sent with Directory; it must not contain `/'.
735 sub req_Unchanged
737 my ( $cmd, $data ) = @_;
739 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
741 #$log->debug("req_Unchanged : $data");
744 # Argument text \n
745 # Response expected: no. Save argument for use in a subsequent command.
746 # Arguments accumulate until an argument-using command is given, at which
747 # point they are forgotten.
748 # Argumentx text \n
749 # Response expected: no. Append \n followed by text to the current argument
750 # being saved.
751 sub req_Argument
753 my ( $cmd, $data ) = @_;
755 # Argumentx means: append to last Argument (with a newline in front)
757 $log->debug("$cmd : $data");
759 if ( $cmd eq 'Argumentx') {
760 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
761 } else {
762 push @{$state->{arguments}}, $data;
766 # expand-modules \n
767 # Response expected: yes. Expand the modules which are specified in the
768 # arguments. Returns the data in Module-expansion responses. Note that the
769 # server can assume that this is checkout or export, not rtag or rdiff; the
770 # latter do not access the working directory and thus have no need to
771 # expand modules on the client side. Expand may not be the best word for
772 # what this request does. It does not necessarily tell you all the files
773 # contained in a module, for example. Basically it is a way of telling you
774 # which working directories the server needs to know about in order to
775 # handle a checkout of the specified modules. For example, suppose that the
776 # server has a module defined by
777 # aliasmodule -a 1dir
778 # That is, one can check out aliasmodule and it will take 1dir in the
779 # repository and check it out to 1dir in the working directory. Now suppose
780 # the client already has this module checked out and is planning on using
781 # the co request to update it. Without using expand-modules, the client
782 # would have two bad choices: it could either send information about all
783 # working directories under the current directory, which could be
784 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
785 # stands for 1dir, and neglect to send information for 1dir, which would
786 # lead to incorrect operation. With expand-modules, the client would first
787 # ask for the module to be expanded:
788 sub req_expandmodules
790 my ( $cmd, $data ) = @_;
792 argsplit();
794 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
796 unless ( ref $state->{arguments} eq "ARRAY" )
798 print "ok\n";
799 return;
802 foreach my $module ( @{$state->{arguments}} )
804 $log->debug("SEND : Module-expansion $module");
805 print "Module-expansion $module\n";
808 print "ok\n";
809 statecleanup();
812 # co \n
813 # Response expected: yes. Get files from the repository. This uses any
814 # previous Argument, Directory, Entry, or Modified requests, if they have
815 # been sent. Arguments to this command are module names; the client cannot
816 # know what directories they correspond to except by (1) just sending the
817 # co request, and then seeing what directory names the server sends back in
818 # its responses, and (2) the expand-modules request.
819 sub req_co
821 my ( $cmd, $data ) = @_;
823 argsplit("co");
825 # Provide list of modules, if -c was used.
826 if (exists $state->{opt}{c}) {
827 my $showref = `git show-ref --heads`;
828 for my $line (split '\n', $showref) {
829 if ( $line =~ m% refs/heads/(.*)$% ) {
830 print "M $1\t$1\n";
833 print "ok\n";
834 return 1;
837 my $module = $state->{args}[0];
838 $state->{module} = $module;
839 my $checkout_path = $module;
841 # use the user specified directory if we're given it
842 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
844 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
846 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
848 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
850 # Grab a handle to the SQLite db and do any necessary updates
851 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
852 $updater->update();
854 $checkout_path =~ s|/$||; # get rid of trailing slashes
856 # Eclipse seems to need the Clear-sticky command
857 # to prepare the 'Entries' file for the new directory.
858 print "Clear-sticky $checkout_path/\n";
859 print $state->{CVSROOT} . "/$module/\n";
860 print "Clear-static-directory $checkout_path/\n";
861 print $state->{CVSROOT} . "/$module/\n";
862 print "Clear-sticky $checkout_path/\n"; # yes, twice
863 print $state->{CVSROOT} . "/$module/\n";
864 print "Template $checkout_path/\n";
865 print $state->{CVSROOT} . "/$module/\n";
866 print "0\n";
868 # instruct the client that we're checking out to $checkout_path
869 print "E cvs checkout: Updating $checkout_path\n";
871 my %seendirs = ();
872 my $lastdir ='';
874 # recursive
875 sub prepdir {
876 my ($dir, $repodir, $remotedir, $seendirs) = @_;
877 my $parent = dirname($dir);
878 $dir =~ s|/+$||;
879 $repodir =~ s|/+$||;
880 $remotedir =~ s|/+$||;
881 $parent =~ s|/+$||;
882 $log->debug("announcedir $dir, $repodir, $remotedir" );
884 if ($parent eq '.' || $parent eq './') {
885 $parent = '';
887 # recurse to announce unseen parents first
888 if (length($parent) && !exists($seendirs->{$parent})) {
889 prepdir($parent, $repodir, $remotedir, $seendirs);
891 # Announce that we are going to modify at the parent level
892 if ($parent) {
893 print "E cvs checkout: Updating $remotedir/$parent\n";
894 } else {
895 print "E cvs checkout: Updating $remotedir\n";
897 print "Clear-sticky $remotedir/$parent/\n";
898 print "$repodir/$parent/\n";
900 print "Clear-static-directory $remotedir/$dir/\n";
901 print "$repodir/$dir/\n";
902 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
903 print "$repodir/$parent/\n";
904 print "Template $remotedir/$dir/\n";
905 print "$repodir/$dir/\n";
906 print "0\n";
908 $seendirs->{$dir} = 1;
911 foreach my $git ( @{$updater->gethead} )
913 # Don't want to check out deleted files
914 next if ( $git->{filehash} eq "deleted" );
916 my $fullName = $git->{name};
917 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
919 if (length($git->{dir}) && $git->{dir} ne './'
920 && $git->{dir} ne $lastdir ) {
921 unless (exists($seendirs{$git->{dir}})) {
922 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
923 $checkout_path, \%seendirs);
924 $lastdir = $git->{dir};
925 $seendirs{$git->{dir}} = 1;
927 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
930 # modification time of this file
931 print "Mod-time $git->{modified}\n";
933 # print some information to the client
934 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
936 print "M U $checkout_path/$git->{dir}$git->{name}\n";
937 } else {
938 print "M U $checkout_path/$git->{name}\n";
941 # instruct client we're sending a file to put in this path
942 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
944 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
946 # this is an "entries" line
947 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
948 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
949 # permissions
950 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
952 # transmit file
953 transmitfile($git->{filehash});
956 print "ok\n";
958 statecleanup();
961 # update \n
962 # Response expected: yes. Actually do a cvs update command. This uses any
963 # previous Argument, Directory, Entry, or Modified requests, if they have
964 # been sent. The last Directory sent specifies the working directory at the
965 # time of the operation. The -I option is not used--files which the client
966 # can decide whether to ignore are not mentioned and the client sends the
967 # Questionable request for others.
968 sub req_update
970 my ( $cmd, $data ) = @_;
972 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
974 argsplit("update");
977 # It may just be a client exploring the available heads/modules
978 # in that case, list them as top level directories and leave it
979 # at that. Eclipse uses this technique to offer you a list of
980 # projects (heads in this case) to checkout.
982 if ($state->{module} eq '') {
983 my $showref = `git show-ref --heads`;
984 print "E cvs update: Updating .\n";
985 for my $line (split '\n', $showref) {
986 if ( $line =~ m% refs/heads/(.*)$% ) {
987 print "E cvs update: New directory `$1'\n";
990 print "ok\n";
991 return 1;
995 # Grab a handle to the SQLite db and do any necessary updates
996 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
998 $updater->update();
1000 argsfromdir($updater);
1002 #$log->debug("update state : " . Dumper($state));
1004 my $last_dirname = "///";
1006 # foreach file specified on the command line ...
1007 foreach my $filename ( @{$state->{args}} )
1009 $filename = filecleanup($filename);
1011 $log->debug("Processing file $filename");
1013 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1015 my $cur_dirname = dirname($filename);
1016 if ( $cur_dirname ne $last_dirname )
1018 $last_dirname = $cur_dirname;
1019 if ( $cur_dirname eq "" )
1021 $cur_dirname = ".";
1023 print "E cvs update: Updating $cur_dirname\n";
1027 # if we have a -C we should pretend we never saw modified stuff
1028 if ( exists ( $state->{opt}{C} ) )
1030 delete $state->{entries}{$filename}{modified_hash};
1031 delete $state->{entries}{$filename}{modified_filename};
1032 $state->{entries}{$filename}{unchanged} = 1;
1035 my $meta;
1036 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1038 $meta = $updater->getmeta($filename, $1);
1039 } else {
1040 $meta = $updater->getmeta($filename);
1043 # If -p was given, "print" the contents of the requested revision.
1044 if ( exists ( $state->{opt}{p} ) ) {
1045 if ( defined ( $meta->{revision} ) ) {
1046 $log->info("Printing '$filename' revision " . $meta->{revision});
1048 transmitfile($meta->{filehash}, { print => 1 });
1051 next;
1054 if ( ! defined $meta )
1056 $meta = {
1057 name => $filename,
1058 revision => 0,
1059 filehash => 'added'
1063 my $oldmeta = $meta;
1065 my $wrev = revparse($filename);
1067 # If the working copy is an old revision, lets get that version too for comparison.
1068 if ( defined($wrev) and $wrev != $meta->{revision} )
1070 $oldmeta = $updater->getmeta($filename, $wrev);
1073 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1075 # Files are up to date if the working copy and repo copy have the same revision,
1076 # and the working copy is unmodified _and_ the user hasn't specified -C
1077 next if ( defined ( $wrev )
1078 and defined($meta->{revision})
1079 and $wrev == $meta->{revision}
1080 and $state->{entries}{$filename}{unchanged}
1081 and not exists ( $state->{opt}{C} ) );
1083 # If the working copy and repo copy have the same revision,
1084 # but the working copy is modified, tell the client it's modified
1085 if ( defined ( $wrev )
1086 and defined($meta->{revision})
1087 and $wrev == $meta->{revision}
1088 and defined($state->{entries}{$filename}{modified_hash})
1089 and not exists ( $state->{opt}{C} ) )
1091 $log->info("Tell the client the file is modified");
1092 print "MT text M \n";
1093 print "MT fname $filename\n";
1094 print "MT newline\n";
1095 next;
1098 if ( $meta->{filehash} eq "deleted" )
1100 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1102 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1104 print "E cvs update: `$filename' is no longer in the repository\n";
1105 # Don't want to actually _DO_ the update if -n specified
1106 unless ( $state->{globaloptions}{-n} ) {
1107 print "Removed $dirpart\n";
1108 print "$filepart\n";
1111 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1112 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1113 or $meta->{filehash} eq 'added' )
1115 # normal update, just send the new revision (either U=Update,
1116 # or A=Add, or R=Remove)
1117 if ( defined($wrev) && $wrev < 0 )
1119 $log->info("Tell the client the file is scheduled for removal");
1120 print "MT text R \n";
1121 print "MT fname $filename\n";
1122 print "MT newline\n";
1123 next;
1125 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1127 $log->info("Tell the client the file is scheduled for addition");
1128 print "MT text A \n";
1129 print "MT fname $filename\n";
1130 print "MT newline\n";
1131 next;
1134 else {
1135 $log->info("Updating '$filename' to ".$meta->{revision});
1136 print "MT +updated\n";
1137 print "MT text U \n";
1138 print "MT fname $filename\n";
1139 print "MT newline\n";
1140 print "MT -updated\n";
1143 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1145 # Don't want to actually _DO_ the update if -n specified
1146 unless ( $state->{globaloptions}{-n} )
1148 if ( defined ( $wrev ) )
1150 # instruct client we're sending a file to put in this path as a replacement
1151 print "Update-existing $dirpart\n";
1152 $log->debug("Updating existing file 'Update-existing $dirpart'");
1153 } else {
1154 # instruct client we're sending a file to put in this path as a new file
1155 print "Clear-static-directory $dirpart\n";
1156 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1157 print "Clear-sticky $dirpart\n";
1158 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1160 $log->debug("Creating new file 'Created $dirpart'");
1161 print "Created $dirpart\n";
1163 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1165 # this is an "entries" line
1166 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1167 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1168 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1170 # permissions
1171 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1172 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1174 # transmit file
1175 transmitfile($meta->{filehash});
1177 } else {
1178 $log->info("Updating '$filename'");
1179 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1181 my $mergeDir = setupTmpDir();
1183 my $file_local = $filepart . ".mine";
1184 my $mergedFile = "$mergeDir/$file_local";
1185 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1186 my $file_old = $filepart . "." . $oldmeta->{revision};
1187 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1188 my $file_new = $filepart . "." . $meta->{revision};
1189 transmitfile($meta->{filehash}, { targetfile => $file_new });
1191 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1192 $log->info("Merging $file_local, $file_old, $file_new");
1193 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1195 $log->debug("Temporary directory for merge is $mergeDir");
1197 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1198 $return >>= 8;
1200 cleanupTmpDir();
1202 if ( $return == 0 )
1204 $log->info("Merged successfully");
1205 print "M M $filename\n";
1206 $log->debug("Merged $dirpart");
1208 # Don't want to actually _DO_ the update if -n specified
1209 unless ( $state->{globaloptions}{-n} )
1211 print "Merged $dirpart\n";
1212 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1213 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1214 my $kopts = kopts_from_path("$dirpart/$filepart",
1215 "file",$mergedFile);
1216 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1217 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1220 elsif ( $return == 1 )
1222 $log->info("Merged with conflicts");
1223 print "E cvs update: conflicts found in $filename\n";
1224 print "M C $filename\n";
1226 # Don't want to actually _DO_ the update if -n specified
1227 unless ( $state->{globaloptions}{-n} )
1229 print "Merged $dirpart\n";
1230 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1231 my $kopts = kopts_from_path("$dirpart/$filepart",
1232 "file",$mergedFile);
1233 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1236 else
1238 $log->warn("Merge failed");
1239 next;
1242 # Don't want to actually _DO_ the update if -n specified
1243 unless ( $state->{globaloptions}{-n} )
1245 # permissions
1246 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1247 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1249 # transmit file, format is single integer on a line by itself (file
1250 # size) followed by the file contents
1251 # TODO : we should copy files in blocks
1252 my $data = `cat $mergedFile`;
1253 $log->debug("File size : " . length($data));
1254 print length($data) . "\n";
1255 print $data;
1261 print "ok\n";
1264 sub req_ci
1266 my ( $cmd, $data ) = @_;
1268 argsplit("ci");
1270 #$log->debug("State : " . Dumper($state));
1272 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1274 if ( $state->{method} eq 'pserver')
1276 print "error 1 pserver access cannot commit\n";
1277 cleanupWorkTree();
1278 exit;
1281 if ( -e $state->{CVSROOT} . "/index" )
1283 $log->warn("file 'index' already exists in the git repository");
1284 print "error 1 Index already exists in git repo\n";
1285 cleanupWorkTree();
1286 exit;
1289 # Grab a handle to the SQLite db and do any necessary updates
1290 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1291 $updater->update();
1293 # Remember where the head was at the beginning.
1294 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1295 chomp $parenthash;
1296 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1297 print "error 1 pserver cannot find the current HEAD of module";
1298 cleanupWorkTree();
1299 exit;
1302 setupWorkTree($parenthash);
1304 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1306 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1308 my @committedfiles = ();
1309 my %oldmeta;
1311 # foreach file specified on the command line ...
1312 foreach my $filename ( @{$state->{args}} )
1314 my $committedfile = $filename;
1315 $filename = filecleanup($filename);
1317 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1319 my $meta = $updater->getmeta($filename);
1320 $oldmeta{$filename} = $meta;
1322 my $wrev = revparse($filename);
1324 my ( $filepart, $dirpart ) = filenamesplit($filename);
1326 # do a checkout of the file if it is part of this tree
1327 if ($wrev) {
1328 system('git', 'checkout-index', '-f', '-u', $filename);
1329 unless ($? == 0) {
1330 die "Error running git-checkout-index -f -u $filename : $!";
1334 my $addflag = 0;
1335 my $rmflag = 0;
1336 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1337 $addflag = 1 unless ( -e $filename );
1339 # Do up to date checking
1340 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1342 # fail everything if an up to date check fails
1343 print "error 1 Up to date check failed for $filename\n";
1344 cleanupWorkTree();
1345 exit;
1348 push @committedfiles, $committedfile;
1349 $log->info("Committing $filename");
1351 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1353 unless ( $rmflag )
1355 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1356 rename $state->{entries}{$filename}{modified_filename},$filename;
1358 # Calculate modes to remove
1359 my $invmode = "";
1360 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1362 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1363 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1366 if ( $rmflag )
1368 $log->info("Removing file '$filename'");
1369 unlink($filename);
1370 system("git", "update-index", "--remove", $filename);
1372 elsif ( $addflag )
1374 $log->info("Adding file '$filename'");
1375 system("git", "update-index", "--add", $filename);
1376 } else {
1377 $log->info("Updating file '$filename'");
1378 system("git", "update-index", $filename);
1382 unless ( scalar(@committedfiles) > 0 )
1384 print "E No files to commit\n";
1385 print "ok\n";
1386 cleanupWorkTree();
1387 return;
1390 my $treehash = `git write-tree`;
1391 chomp $treehash;
1393 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1395 # write our commit message out if we have one ...
1396 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1397 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1398 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1399 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1400 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1402 } else {
1403 print $msg_fh "\n\nvia git-CVS emulator\n";
1405 close $msg_fh;
1407 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1408 chomp($commithash);
1409 $log->info("Commit hash : $commithash");
1411 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1413 $log->warn("Commit failed (Invalid commit hash)");
1414 print "error 1 Commit failed (unknown reason)\n";
1415 cleanupWorkTree();
1416 exit;
1419 ### Emulate git-receive-pack by running hooks/update
1420 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1421 $parenthash, $commithash );
1422 if( -x $hook[0] ) {
1423 unless( system( @hook ) == 0 )
1425 $log->warn("Commit failed (update hook declined to update ref)");
1426 print "error 1 Commit failed (update hook declined)\n";
1427 cleanupWorkTree();
1428 exit;
1432 ### Update the ref
1433 if (system(qw(git update-ref -m), "cvsserver ci",
1434 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1435 $log->warn("update-ref for $state->{module} failed.");
1436 print "error 1 Cannot commit -- update first\n";
1437 cleanupWorkTree();
1438 exit;
1441 ### Emulate git-receive-pack by running hooks/post-receive
1442 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1443 if( -x $hook ) {
1444 open(my $pipe, "| $hook") || die "can't fork $!";
1446 local $SIG{PIPE} = sub { die 'pipe broke' };
1448 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1450 close $pipe || die "bad pipe: $! $?";
1453 $updater->update();
1455 ### Then hooks/post-update
1456 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1457 if (-x $hook) {
1458 system($hook, "refs/heads/$state->{module}");
1461 # foreach file specified on the command line ...
1462 foreach my $filename ( @committedfiles )
1464 $filename = filecleanup($filename);
1466 my $meta = $updater->getmeta($filename);
1467 unless (defined $meta->{revision}) {
1468 $meta->{revision} = 1;
1471 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1473 $log->debug("Checked-in $dirpart : $filename");
1475 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1476 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1478 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1479 print "Remove-entry $dirpart\n";
1480 print "$filename\n";
1481 } else {
1482 if ($meta->{revision} == 1) {
1483 print "M initial revision: 1.1\n";
1484 } else {
1485 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1487 print "Checked-in $dirpart\n";
1488 print "$filename\n";
1489 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1490 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1494 cleanupWorkTree();
1495 print "ok\n";
1498 sub req_status
1500 my ( $cmd, $data ) = @_;
1502 argsplit("status");
1504 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1505 #$log->debug("status state : " . Dumper($state));
1507 # Grab a handle to the SQLite db and do any necessary updates
1508 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1509 $updater->update();
1511 # if no files were specified, we need to work out what files we should be providing status on ...
1512 argsfromdir($updater);
1514 # foreach file specified on the command line ...
1515 foreach my $filename ( @{$state->{args}} )
1517 $filename = filecleanup($filename);
1519 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1521 my $meta = $updater->getmeta($filename);
1522 my $oldmeta = $meta;
1524 my $wrev = revparse($filename);
1526 # If the working copy is an old revision, lets get that version too for comparison.
1527 if ( defined($wrev) and $wrev != $meta->{revision} )
1529 $oldmeta = $updater->getmeta($filename, $wrev);
1532 # TODO : All possible statuses aren't yet implemented
1533 my $status;
1534 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1535 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1537 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1538 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1541 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1542 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1544 ( $state->{entries}{$filename}{unchanged}
1545 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1548 # Need checkout if it exists in the repo but doesn't have a working copy
1549 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1551 # Locally modified if working copy and repo copy have the same revision but there are local changes
1552 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1554 # Needs Merge if working copy revision is less than repo copy and there are local changes
1555 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1557 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1558 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1559 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1560 $status ||= "File had conflicts on merge" if ( 0 );
1562 $status ||= "Unknown";
1564 my ($filepart) = filenamesplit($filename);
1566 print "M ===================================================================\n";
1567 print "M File: $filepart\tStatus: $status\n";
1568 if ( defined($state->{entries}{$filename}{revision}) )
1570 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1571 } else {
1572 print "M Working revision:\tNo entry for $filename\n";
1574 if ( defined($meta->{revision}) )
1576 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1577 print "M Sticky Tag:\t\t(none)\n";
1578 print "M Sticky Date:\t\t(none)\n";
1579 print "M Sticky Options:\t\t(none)\n";
1580 } else {
1581 print "M Repository revision:\tNo revision control file\n";
1583 print "M\n";
1586 print "ok\n";
1589 sub req_diff
1591 my ( $cmd, $data ) = @_;
1593 argsplit("diff");
1595 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1596 #$log->debug("status state : " . Dumper($state));
1598 my ($revision1, $revision2);
1599 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1601 $revision1 = $state->{opt}{r}[0];
1602 $revision2 = $state->{opt}{r}[1];
1603 } else {
1604 $revision1 = $state->{opt}{r};
1607 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1608 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1610 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1612 # Grab a handle to the SQLite db and do any necessary updates
1613 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1614 $updater->update();
1616 # if no files were specified, we need to work out what files we should be providing status on ...
1617 argsfromdir($updater);
1619 # foreach file specified on the command line ...
1620 foreach my $filename ( @{$state->{args}} )
1622 $filename = filecleanup($filename);
1624 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1626 my $wrev = revparse($filename);
1628 # We need _something_ to diff against
1629 next unless ( defined ( $wrev ) );
1631 # if we have a -r switch, use it
1632 if ( defined ( $revision1 ) )
1634 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1635 $meta1 = $updater->getmeta($filename, $revision1);
1636 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1638 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1639 next;
1641 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1643 # otherwise we just use the working copy revision
1644 else
1646 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1647 $meta1 = $updater->getmeta($filename, $wrev);
1648 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1651 # if we have a second -r switch, use it too
1652 if ( defined ( $revision2 ) )
1654 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1655 $meta2 = $updater->getmeta($filename, $revision2);
1657 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1659 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1660 next;
1663 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1665 # otherwise we just use the working copy
1666 else
1668 $file2 = $state->{entries}{$filename}{modified_filename};
1671 # if we have been given -r, and we don't have a $file2 yet, lets get one
1672 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1674 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1675 $meta2 = $updater->getmeta($filename, $wrev);
1676 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1679 # We need to have retrieved something useful
1680 next unless ( defined ( $meta1 ) );
1682 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1683 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1685 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1686 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1689 # Apparently we only show diffs for locally modified files
1690 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1692 print "M Index: $filename\n";
1693 print "M ===================================================================\n";
1694 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1695 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1696 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1697 print "M diff ";
1698 foreach my $opt ( keys %{$state->{opt}} )
1700 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1702 foreach my $value ( @{$state->{opt}{$opt}} )
1704 print "-$opt $value ";
1706 } else {
1707 print "-$opt ";
1708 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1711 print "$filename\n";
1713 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1715 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1717 if ( exists $state->{opt}{u} )
1719 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1720 } else {
1721 system("diff $file1 $file2 > $filediff");
1724 while ( <$fh> )
1726 print "M $_";
1728 close $fh;
1731 print "ok\n";
1734 sub req_log
1736 my ( $cmd, $data ) = @_;
1738 argsplit("log");
1740 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1741 #$log->debug("log state : " . Dumper($state));
1743 my ( $minrev, $maxrev );
1744 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1746 my $control = $2;
1747 $minrev = $1;
1748 $maxrev = $3;
1749 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1750 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1751 $minrev++ if ( defined($minrev) and $control eq "::" );
1754 # Grab a handle to the SQLite db and do any necessary updates
1755 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1756 $updater->update();
1758 # if no files were specified, we need to work out what files we should be providing status on ...
1759 argsfromdir($updater);
1761 # foreach file specified on the command line ...
1762 foreach my $filename ( @{$state->{args}} )
1764 $filename = filecleanup($filename);
1766 my $headmeta = $updater->getmeta($filename);
1768 my $revisions = $updater->getlog($filename);
1769 my $totalrevisions = scalar(@$revisions);
1771 if ( defined ( $minrev ) )
1773 $log->debug("Removing revisions less than $minrev");
1774 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1776 pop @$revisions;
1779 if ( defined ( $maxrev ) )
1781 $log->debug("Removing revisions greater than $maxrev");
1782 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1784 shift @$revisions;
1788 next unless ( scalar(@$revisions) );
1790 print "M \n";
1791 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1792 print "M Working file: $filename\n";
1793 print "M head: 1.$headmeta->{revision}\n";
1794 print "M branch:\n";
1795 print "M locks: strict\n";
1796 print "M access list:\n";
1797 print "M symbolic names:\n";
1798 print "M keyword substitution: kv\n";
1799 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1800 print "M description:\n";
1802 foreach my $revision ( @$revisions )
1804 print "M ----------------------------\n";
1805 print "M revision 1.$revision->{revision}\n";
1806 # reformat the date for log output
1807 $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}) );
1808 $revision->{author} = cvs_author($revision->{author});
1809 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1810 my $commitmessage = $updater->commitmessage($revision->{commithash});
1811 $commitmessage =~ s/^/M /mg;
1812 print $commitmessage . "\n";
1814 print "M =============================================================================\n";
1817 print "ok\n";
1820 sub req_annotate
1822 my ( $cmd, $data ) = @_;
1824 argsplit("annotate");
1826 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1827 #$log->debug("status state : " . Dumper($state));
1829 # Grab a handle to the SQLite db and do any necessary updates
1830 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1831 $updater->update();
1833 # if no files were specified, we need to work out what files we should be providing annotate on ...
1834 argsfromdir($updater);
1836 # we'll need a temporary checkout dir
1837 setupWorkTree();
1839 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1841 # foreach file specified on the command line ...
1842 foreach my $filename ( @{$state->{args}} )
1844 $filename = filecleanup($filename);
1846 my $meta = $updater->getmeta($filename);
1848 next unless ( $meta->{revision} );
1850 # get all the commits that this file was in
1851 # in dense format -- aka skip dead revisions
1852 my $revisions = $updater->gethistorydense($filename);
1853 my $lastseenin = $revisions->[0][2];
1855 # populate the temporary index based on the latest commit were we saw
1856 # the file -- but do it cheaply without checking out any files
1857 # TODO: if we got a revision from the client, use that instead
1858 # to look up the commithash in sqlite (still good to default to
1859 # the current head as we do now)
1860 system("git", "read-tree", $lastseenin);
1861 unless ($? == 0)
1863 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1864 return;
1866 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1868 # do a checkout of the file
1869 system('git', 'checkout-index', '-f', '-u', $filename);
1870 unless ($? == 0) {
1871 print "E error running git-checkout-index -f -u $filename : $!\n";
1872 return;
1875 $log->info("Annotate $filename");
1877 # Prepare a file with the commits from the linearized
1878 # history that annotate should know about. This prevents
1879 # git-jsannotate telling us about commits we are hiding
1880 # from the client.
1882 my $a_hints = "$work->{workDir}/.annotate_hints";
1883 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1884 print "E failed to open '$a_hints' for writing: $!\n";
1885 return;
1887 for (my $i=0; $i < @$revisions; $i++)
1889 print ANNOTATEHINTS $revisions->[$i][2];
1890 if ($i+1 < @$revisions) { # have we got a parent?
1891 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1893 print ANNOTATEHINTS "\n";
1896 print ANNOTATEHINTS "\n";
1897 close ANNOTATEHINTS
1898 or (print "E failed to write $a_hints: $!\n"), return;
1900 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
1901 if (!open(ANNOTATE, "-|", @cmd)) {
1902 print "E error invoking ". join(' ',@cmd) .": $!\n";
1903 return;
1905 my $metadata = {};
1906 print "E Annotations for $filename\n";
1907 print "E ***************\n";
1908 while ( <ANNOTATE> )
1910 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1912 my $commithash = $1;
1913 my $data = $2;
1914 unless ( defined ( $metadata->{$commithash} ) )
1916 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1917 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1918 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1920 printf("M 1.%-5d (%-8s %10s): %s\n",
1921 $metadata->{$commithash}{revision},
1922 $metadata->{$commithash}{author},
1923 $metadata->{$commithash}{modified},
1924 $data
1926 } else {
1927 $log->warn("Error in annotate output! LINE: $_");
1928 print "E Annotate error \n";
1929 next;
1932 close ANNOTATE;
1935 # done; get out of the tempdir
1936 cleanupWorkTree();
1938 print "ok\n";
1942 # This method takes the state->{arguments} array and produces two new arrays.
1943 # The first is $state->{args} which is everything before the '--' argument, and
1944 # the second is $state->{files} which is everything after it.
1945 sub argsplit
1947 $state->{args} = [];
1948 $state->{files} = [];
1949 $state->{opt} = {};
1951 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1953 my $type = shift;
1955 if ( defined($type) )
1957 my $opt = {};
1958 $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" );
1959 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1960 $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" );
1961 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1962 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1963 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1964 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1965 $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" );
1968 while ( scalar ( @{$state->{arguments}} ) > 0 )
1970 my $arg = shift @{$state->{arguments}};
1972 next if ( $arg eq "--" );
1973 next unless ( $arg =~ /\S/ );
1975 # if the argument looks like a switch
1976 if ( $arg =~ /^-(\w)(.*)/ )
1978 # if it's a switch that takes an argument
1979 if ( $opt->{$1} )
1981 # If this switch has already been provided
1982 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1984 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1985 if ( length($2) > 0 )
1987 push @{$state->{opt}{$1}},$2;
1988 } else {
1989 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1991 } else {
1992 # if there's extra data in the arg, use that as the argument for the switch
1993 if ( length($2) > 0 )
1995 $state->{opt}{$1} = $2;
1996 } else {
1997 $state->{opt}{$1} = shift @{$state->{arguments}};
2000 } else {
2001 $state->{opt}{$1} = undef;
2004 else
2006 push @{$state->{args}}, $arg;
2010 else
2012 my $mode = 0;
2014 foreach my $value ( @{$state->{arguments}} )
2016 if ( $value eq "--" )
2018 $mode++;
2019 next;
2021 push @{$state->{args}}, $value if ( $mode == 0 );
2022 push @{$state->{files}}, $value if ( $mode == 1 );
2027 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2028 sub argsfromdir
2030 my $updater = shift;
2032 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2034 return if ( scalar ( @{$state->{args}} ) > 1 );
2036 my @gethead = @{$updater->gethead};
2038 # push added files
2039 foreach my $file (keys %{$state->{entries}}) {
2040 if ( exists $state->{entries}{$file}{revision} &&
2041 $state->{entries}{$file}{revision} == 0 )
2043 push @gethead, { name => $file, filehash => 'added' };
2047 if ( scalar(@{$state->{args}}) == 1 )
2049 my $arg = $state->{args}[0];
2050 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2052 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2054 foreach my $file ( @gethead )
2056 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2057 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2058 push @{$state->{args}}, $file->{name};
2061 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2062 } else {
2063 $log->info("Only one arg specified, populating file list automatically");
2065 $state->{args} = [];
2067 foreach my $file ( @gethead )
2069 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2070 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2071 push @{$state->{args}}, $file->{name};
2076 # This method cleans up the $state variable after a command that uses arguments has run
2077 sub statecleanup
2079 $state->{files} = [];
2080 $state->{args} = [];
2081 $state->{arguments} = [];
2082 $state->{entries} = {};
2085 sub revparse
2087 my $filename = shift;
2089 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2091 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2092 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2094 return undef;
2097 # This method takes a file hash and does a CVS "file transfer". Its
2098 # exact behaviour depends on a second, optional hash table argument:
2099 # - If $options->{targetfile}, dump the contents to that file;
2100 # - If $options->{print}, use M/MT to transmit the contents one line
2101 # at a time;
2102 # - Otherwise, transmit the size of the file, followed by the file
2103 # contents.
2104 sub transmitfile
2106 my $filehash = shift;
2107 my $options = shift;
2109 if ( defined ( $filehash ) and $filehash eq "deleted" )
2111 $log->warn("filehash is 'deleted'");
2112 return;
2115 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2117 my $type = `git cat-file -t $filehash`;
2118 chomp $type;
2120 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2122 my $size = `git cat-file -s $filehash`;
2123 chomp $size;
2125 $log->debug("transmitfile($filehash) size=$size, type=$type");
2127 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2129 if ( defined ( $options->{targetfile} ) )
2131 my $targetfile = $options->{targetfile};
2132 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2133 print NEWFILE $_ while ( <$fh> );
2134 close NEWFILE or die("Failed to write '$targetfile': $!");
2135 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2136 while ( <$fh> ) {
2137 if( /\n\z/ ) {
2138 print 'M ', $_;
2139 } else {
2140 print 'MT text ', $_, "\n";
2143 } else {
2144 print "$size\n";
2145 print while ( <$fh> );
2147 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2148 } else {
2149 die("Couldn't execute git-cat-file");
2153 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2154 # refers to the directory portion and the file portion of the filename
2155 # respectively
2156 sub filenamesplit
2158 my $filename = shift;
2159 my $fixforlocaldir = shift;
2161 my ( $filepart, $dirpart ) = ( $filename, "." );
2162 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2163 $dirpart .= "/";
2165 if ( $fixforlocaldir )
2167 $dirpart =~ s/^$state->{prependdir}//;
2170 return ( $filepart, $dirpart );
2173 sub filecleanup
2175 my $filename = shift;
2177 return undef unless(defined($filename));
2178 if ( $filename =~ /^\// )
2180 print "E absolute filenames '$filename' not supported by server\n";
2181 return undef;
2184 $filename =~ s/^\.\///g;
2185 $filename = $state->{prependdir} . $filename;
2186 return $filename;
2189 sub validateGitDir
2191 if( !defined($state->{CVSROOT}) )
2193 print "error 1 CVSROOT not specified\n";
2194 cleanupWorkTree();
2195 exit;
2197 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2199 print "error 1 Internally inconsistent CVSROOT\n";
2200 cleanupWorkTree();
2201 exit;
2205 # Setup working directory in a work tree with the requested version
2206 # loaded in the index.
2207 sub setupWorkTree
2209 my ($ver) = @_;
2211 validateGitDir();
2213 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2214 defined($work->{tmpDir}) )
2216 $log->warn("Bad work tree state management");
2217 print "error 1 Internal setup multiple work trees without cleanup\n";
2218 cleanupWorkTree();
2219 exit;
2222 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2224 if( !defined($work->{index}) )
2226 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2229 chdir $work->{workDir} or
2230 die "Unable to chdir to $work->{workDir}\n";
2232 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2234 $ENV{GIT_WORK_TREE} = ".";
2235 $ENV{GIT_INDEX_FILE} = $work->{index};
2236 $work->{state} = 2;
2238 if($ver)
2240 system("git","read-tree",$ver);
2241 unless ($? == 0)
2243 $log->warn("Error running git-read-tree");
2244 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2247 # else # req_annotate reads tree for each file
2250 # Ensure current directory is in some kind of working directory,
2251 # with a recent version loaded in the index.
2252 sub ensureWorkTree
2254 if( defined($work->{tmpDir}) )
2256 $log->warn("Bad work tree state management [ensureWorkTree()]");
2257 print "error 1 Internal setup multiple dirs without cleanup\n";
2258 cleanupWorkTree();
2259 exit;
2261 if( $work->{state} )
2263 return;
2266 validateGitDir();
2268 if( !defined($work->{emptyDir}) )
2270 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2272 chdir $work->{emptyDir} or
2273 die "Unable to chdir to $work->{emptyDir}\n";
2275 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2276 chomp $ver;
2277 if ($ver !~ /^[0-9a-f]{40}$/)
2279 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2280 print "error 1 cannot find the current HEAD of module";
2281 cleanupWorkTree();
2282 exit;
2285 if( !defined($work->{index}) )
2287 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2290 $ENV{GIT_WORK_TREE} = ".";
2291 $ENV{GIT_INDEX_FILE} = $work->{index};
2292 $work->{state} = 1;
2294 system("git","read-tree",$ver);
2295 unless ($? == 0)
2297 die "Error running git-read-tree $ver $!\n";
2301 # Cleanup working directory that is not needed any longer.
2302 sub cleanupWorkTree
2304 if( ! $work->{state} )
2306 return;
2309 chdir "/" or die "Unable to chdir '/'\n";
2311 if( defined($work->{workDir}) )
2313 rmtree( $work->{workDir} );
2314 undef $work->{workDir};
2316 undef $work->{state};
2319 # Setup a temporary directory (not a working tree), typically for
2320 # merging dirty state as in req_update.
2321 sub setupTmpDir
2323 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2324 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2326 return $work->{tmpDir};
2329 # Clean up a previously setupTmpDir. Restore previous work tree if
2330 # appropriate.
2331 sub cleanupTmpDir
2333 if ( !defined($work->{tmpDir}) )
2335 $log->warn("cleanup tmpdir that has not been setup");
2336 die "Cleanup tmpDir that has not been setup\n";
2338 if( defined($work->{state}) )
2340 if( $work->{state} == 1 )
2342 chdir $work->{emptyDir} or
2343 die "Unable to chdir to $work->{emptyDir}\n";
2345 elsif( $work->{state} == 2 )
2347 chdir $work->{workDir} or
2348 die "Unable to chdir to $work->{emptyDir}\n";
2350 else
2352 $log->warn("Inconsistent work dir state");
2353 die "Inconsistent work dir state\n";
2356 else
2358 chdir "/" or die "Unable to chdir '/'\n";
2362 # Given a path, this function returns a string containing the kopts
2363 # that should go into that path's Entries line. For example, a binary
2364 # file should get -kb.
2365 sub kopts_from_path
2367 my ($path, $srcType, $name) = @_;
2369 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2370 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2372 my ($val) = check_attr( "crlf", $path );
2373 if ( $val eq "set" )
2375 return "";
2377 elsif ( $val eq "unset" )
2379 return "-kb"
2381 else
2383 $log->info("Unrecognized check_attr crlf $path : $val");
2387 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2389 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2391 return "-kb";
2393 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2395 if( $srcType eq "sha1Or-k" &&
2396 !defined($name) )
2398 my ($ret)=$state->{entries}{$path}{options};
2399 if( !defined($ret) )
2401 $ret=$state->{opt}{k};
2402 if(defined($ret))
2404 $ret="-k$ret";
2406 else
2408 $ret="";
2411 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2413 print "E Bad -k option\n";
2414 $log->warn("Bad -k option: $ret");
2415 die "Error: Bad -k option: $ret\n";
2418 return $ret;
2420 else
2422 if( is_binary($srcType,$name) )
2424 $log->debug("... as binary");
2425 return "-kb";
2427 else
2429 $log->debug("... as text");
2434 # Return "" to give no special treatment to any path
2435 return "";
2438 sub check_attr
2440 my ($attr,$path) = @_;
2441 ensureWorkTree();
2442 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2444 my $val = <$fh>;
2445 close $fh;
2446 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2447 return $val;
2449 else
2451 return undef;
2455 # This should have the same heuristics as convert.c:is_binary() and related.
2456 # Note that the bare CR test is done by callers in convert.c.
2457 sub is_binary
2459 my ($srcType,$name) = @_;
2460 $log->debug("is_binary($srcType,$name)");
2462 # Minimize amount of interpreted code run in the inner per-character
2463 # loop for large files, by totalling each character value and
2464 # then analyzing the totals.
2465 my @counts;
2466 my $i;
2467 for($i=0;$i<256;$i++)
2469 $counts[$i]=0;
2472 my $fh = open_blob_or_die($srcType,$name);
2473 my $line;
2474 while( defined($line=<$fh>) )
2476 # Any '\0' and bare CR are considered binary.
2477 if( $line =~ /\0|(\r[^\n])/ )
2479 close($fh);
2480 return 1;
2483 # Count up each character in the line:
2484 my $len=length($line);
2485 for($i=0;$i<$len;$i++)
2487 $counts[ord(substr($line,$i,1))]++;
2490 close $fh;
2492 # Don't count CR and LF as either printable/nonprintable
2493 $counts[ord("\n")]=0;
2494 $counts[ord("\r")]=0;
2496 # Categorize individual character count into printable and nonprintable:
2497 my $printable=0;
2498 my $nonprintable=0;
2499 for($i=0;$i<256;$i++)
2501 if( $i < 32 &&
2502 $i != ord("\b") &&
2503 $i != ord("\t") &&
2504 $i != 033 && # ESC
2505 $i != 014 ) # FF
2507 $nonprintable+=$counts[$i];
2509 elsif( $i==127 ) # DEL
2511 $nonprintable+=$counts[$i];
2513 else
2515 $printable+=$counts[$i];
2519 return ($printable >> 7) < $nonprintable;
2522 # Returns open file handle. Possible invocations:
2523 # - open_blob_or_die("file",$filename);
2524 # - open_blob_or_die("sha1",$filehash);
2525 sub open_blob_or_die
2527 my ($srcType,$name) = @_;
2528 my ($fh);
2529 if( $srcType eq "file" )
2531 if( !open $fh,"<",$name )
2533 $log->warn("Unable to open file $name: $!");
2534 die "Unable to open file $name: $!\n";
2537 elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2539 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2541 $log->warn("Need filehash");
2542 die "Need filehash\n";
2545 my $type = `git cat-file -t $name`;
2546 chomp $type;
2548 unless ( defined ( $type ) and $type eq "blob" )
2550 $log->warn("Invalid type '$type' for '$name'");
2551 die ( "Invalid type '$type' (expected 'blob')" )
2554 my $size = `git cat-file -s $name`;
2555 chomp $size;
2557 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2559 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2561 $log->warn("Unable to open sha1 $name");
2562 die "Unable to open sha1 $name\n";
2565 else
2567 $log->warn("Unknown type of blob source: $srcType");
2568 die "Unknown type of blob source: $srcType\n";
2570 return $fh;
2573 # Generate a CVS author name from Git author information, by taking the local
2574 # part of the email address and replacing characters not in the Portable
2575 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2576 # Login names are Unix login names, which should be restricted to this
2577 # character set.
2578 sub cvs_author
2580 my $author_line = shift;
2581 (my $author) = $author_line =~ /<([^@>]*)/;
2583 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2584 $author =~ s/^-/_/;
2586 $author;
2589 package GITCVS::log;
2591 ####
2592 #### Copyright The Open University UK - 2006.
2593 ####
2594 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2595 #### Martin Langhoff <martin@catalyst.net.nz>
2596 ####
2597 ####
2599 use strict;
2600 use warnings;
2602 =head1 NAME
2604 GITCVS::log
2606 =head1 DESCRIPTION
2608 This module provides very crude logging with a similar interface to
2609 Log::Log4perl
2611 =head1 METHODS
2613 =cut
2615 =head2 new
2617 Creates a new log object, optionally you can specify a filename here to
2618 indicate the file to log to. If no log file is specified, you can specify one
2619 later with method setfile, or indicate you no longer want logging with method
2620 nofile.
2622 Until one of these methods is called, all log calls will buffer messages ready
2623 to write out.
2625 =cut
2626 sub new
2628 my $class = shift;
2629 my $filename = shift;
2631 my $self = {};
2633 bless $self, $class;
2635 if ( defined ( $filename ) )
2637 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2640 return $self;
2643 =head2 setfile
2645 This methods takes a filename, and attempts to open that file as the log file.
2646 If successful, all buffered data is written out to the file, and any further
2647 logging is written directly to the file.
2649 =cut
2650 sub setfile
2652 my $self = shift;
2653 my $filename = shift;
2655 if ( defined ( $filename ) )
2657 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2660 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2662 while ( my $line = shift @{$self->{buffer}} )
2664 print {$self->{fh}} $line;
2668 =head2 nofile
2670 This method indicates no logging is going to be used. It flushes any entries in
2671 the internal buffer, and sets a flag to ensure no further data is put there.
2673 =cut
2674 sub nofile
2676 my $self = shift;
2678 $self->{nolog} = 1;
2680 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2682 $self->{buffer} = [];
2685 =head2 _logopen
2687 Internal method. Returns true if the log file is open, false otherwise.
2689 =cut
2690 sub _logopen
2692 my $self = shift;
2694 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2695 return 0;
2698 =head2 debug info warn fatal
2700 These four methods are wrappers to _log. They provide the actual interface for
2701 logging data.
2703 =cut
2704 sub debug { my $self = shift; $self->_log("debug", @_); }
2705 sub info { my $self = shift; $self->_log("info" , @_); }
2706 sub warn { my $self = shift; $self->_log("warn" , @_); }
2707 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2709 =head2 _log
2711 This is an internal method called by the logging functions. It generates a
2712 timestamp and pushes the logged line either to file, or internal buffer.
2714 =cut
2715 sub _log
2717 my $self = shift;
2718 my $level = shift;
2720 return if ( $self->{nolog} );
2722 my @time = localtime;
2723 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2724 $time[5] + 1900,
2725 $time[4] + 1,
2726 $time[3],
2727 $time[2],
2728 $time[1],
2729 $time[0],
2730 uc $level,
2733 if ( $self->_logopen )
2735 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2736 } else {
2737 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2741 =head2 DESTROY
2743 This method simply closes the file handle if one is open
2745 =cut
2746 sub DESTROY
2748 my $self = shift;
2750 if ( $self->_logopen )
2752 close $self->{fh};
2756 package GITCVS::updater;
2758 ####
2759 #### Copyright The Open University UK - 2006.
2760 ####
2761 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2762 #### Martin Langhoff <martin@catalyst.net.nz>
2763 ####
2764 ####
2766 use strict;
2767 use warnings;
2768 use DBI;
2770 =head1 METHODS
2772 =cut
2774 =head2 new
2776 =cut
2777 sub new
2779 my $class = shift;
2780 my $config = shift;
2781 my $module = shift;
2782 my $log = shift;
2784 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2785 die "Need to specify a module" unless ( defined($module) );
2787 $class = ref($class) || $class;
2789 my $self = {};
2791 bless $self, $class;
2793 $self->{valid_tables} = {'revision' => 1,
2794 'revision_ix1' => 1,
2795 'revision_ix2' => 1,
2796 'head' => 1,
2797 'head_ix1' => 1,
2798 'properties' => 1,
2799 'commitmsgs' => 1};
2801 $self->{module} = $module;
2802 $self->{git_path} = $config . "/";
2804 $self->{log} = $log;
2806 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2808 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2809 $cfg->{gitcvs}{dbdriver} || "SQLite";
2810 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2811 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2812 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2813 $cfg->{gitcvs}{dbuser} || "";
2814 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2815 $cfg->{gitcvs}{dbpass} || "";
2816 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2817 $cfg->{gitcvs}{dbtablenameprefix} || "";
2818 my %mapping = ( m => $module,
2819 a => $state->{method},
2820 u => getlogin || getpwuid($<) || $<,
2821 G => $self->{git_path},
2822 g => mangle_dirname($self->{git_path}),
2824 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2825 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2826 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2827 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2829 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2830 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2831 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2832 $self->{dbuser},
2833 $self->{dbpass});
2834 die "Error connecting to database\n" unless defined $self->{dbh};
2836 $self->{tables} = {};
2837 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2839 $self->{tables}{$table} = 1;
2842 # Construct the revision table if required
2843 unless ( $self->{tables}{$self->tablename("revision")} )
2845 my $tablename = $self->tablename("revision");
2846 my $ix1name = $self->tablename("revision_ix1");
2847 my $ix2name = $self->tablename("revision_ix2");
2848 $self->{dbh}->do("
2849 CREATE TABLE $tablename (
2850 name TEXT NOT NULL,
2851 revision INTEGER NOT NULL,
2852 filehash TEXT NOT NULL,
2853 commithash TEXT NOT NULL,
2854 author TEXT NOT NULL,
2855 modified TEXT NOT NULL,
2856 mode TEXT NOT NULL
2859 $self->{dbh}->do("
2860 CREATE INDEX $ix1name
2861 ON $tablename (name,revision)
2863 $self->{dbh}->do("
2864 CREATE INDEX $ix2name
2865 ON $tablename (name,commithash)
2869 # Construct the head table if required
2870 unless ( $self->{tables}{$self->tablename("head")} )
2872 my $tablename = $self->tablename("head");
2873 my $ix1name = $self->tablename("head_ix1");
2874 $self->{dbh}->do("
2875 CREATE TABLE $tablename (
2876 name TEXT NOT NULL,
2877 revision INTEGER NOT NULL,
2878 filehash TEXT NOT NULL,
2879 commithash TEXT NOT NULL,
2880 author TEXT NOT NULL,
2881 modified TEXT NOT NULL,
2882 mode TEXT NOT NULL
2885 $self->{dbh}->do("
2886 CREATE INDEX $ix1name
2887 ON $tablename (name)
2891 # Construct the properties table if required
2892 unless ( $self->{tables}{$self->tablename("properties")} )
2894 my $tablename = $self->tablename("properties");
2895 $self->{dbh}->do("
2896 CREATE TABLE $tablename (
2897 key TEXT NOT NULL PRIMARY KEY,
2898 value TEXT
2903 # Construct the commitmsgs table if required
2904 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2906 my $tablename = $self->tablename("commitmsgs");
2907 $self->{dbh}->do("
2908 CREATE TABLE $tablename (
2909 key TEXT NOT NULL PRIMARY KEY,
2910 value TEXT
2915 return $self;
2918 =head2 tablename
2920 =cut
2921 sub tablename
2923 my $self = shift;
2924 my $name = shift;
2926 if (exists $self->{valid_tables}{$name}) {
2927 return $self->{dbtablenameprefix} . $name;
2928 } else {
2929 return undef;
2933 =head2 update
2935 =cut
2936 sub update
2938 my $self = shift;
2940 # first lets get the commit list
2941 $ENV{GIT_DIR} = $self->{git_path};
2943 my $commitsha1 = `git rev-parse $self->{module}`;
2944 chomp $commitsha1;
2946 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2947 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2949 die("Invalid module '$self->{module}'");
2953 my $git_log;
2954 my $lastcommit = $self->_get_prop("last_commit");
2956 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2957 return 1;
2960 # Start exclusive lock here...
2961 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2963 # TODO: log processing is memory bound
2964 # if we can parse into a 2nd file that is in reverse order
2965 # we can probably do something really efficient
2966 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2968 if (defined $lastcommit) {
2969 push @git_log_params, "$lastcommit..$self->{module}";
2970 } else {
2971 push @git_log_params, $self->{module};
2973 # git-rev-list is the backend / plumbing version of git-log
2974 open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2976 my @commits;
2978 my %commit = ();
2980 while ( <GITLOG> )
2982 chomp;
2983 if (m/^commit\s+(.*)$/) {
2984 # on ^commit lines put the just seen commit in the stack
2985 # and prime things for the next one
2986 if (keys %commit) {
2987 my %copy = %commit;
2988 unshift @commits, \%copy;
2989 %commit = ();
2991 my @parents = split(m/\s+/, $1);
2992 $commit{hash} = shift @parents;
2993 $commit{parents} = \@parents;
2994 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2995 # on rfc822-like lines seen before we see any message,
2996 # lowercase the entry and put it in the hash as key-value
2997 $commit{lc($1)} = $2;
2998 } else {
2999 # message lines - skip initial empty line
3000 # and trim whitespace
3001 if (!exists($commit{message}) && m/^\s*$/) {
3002 # define it to mark the end of headers
3003 $commit{message} = '';
3004 next;
3006 s/^\s+//; s/\s+$//; # trim ws
3007 $commit{message} .= $_ . "\n";
3010 close GITLOG;
3012 unshift @commits, \%commit if ( keys %commit );
3014 # Now all the commits are in the @commits bucket
3015 # ordered by time DESC. for each commit that needs processing,
3016 # determine whether it's following the last head we've seen or if
3017 # it's on its own branch, grab a file list, and add whatever's changed
3018 # NOTE: $lastcommit refers to the last commit from previous run
3019 # $lastpicked is the last commit we picked in this run
3020 my $lastpicked;
3021 my $head = {};
3022 if (defined $lastcommit) {
3023 $lastpicked = $lastcommit;
3026 my $committotal = scalar(@commits);
3027 my $commitcount = 0;
3029 # Load the head table into $head (for cached lookups during the update process)
3030 foreach my $file ( @{$self->gethead()} )
3032 $head->{$file->{name}} = $file;
3035 foreach my $commit ( @commits )
3037 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3038 if (defined $lastpicked)
3040 if (!in_array($lastpicked, @{$commit->{parents}}))
3042 # skip, we'll see this delta
3043 # as part of a merge later
3044 # warn "skipping off-track $commit->{hash}\n";
3045 next;
3046 } elsif (@{$commit->{parents}} > 1) {
3047 # it is a merge commit, for each parent that is
3048 # not $lastpicked, see if we can get a log
3049 # from the merge-base to that parent to put it
3050 # in the message as a merge summary.
3051 my @parents = @{$commit->{parents}};
3052 foreach my $parent (@parents) {
3053 # git-merge-base can potentially (but rarely) throw
3054 # several candidate merge bases. let's assume
3055 # that the first one is the best one.
3056 if ($parent eq $lastpicked) {
3057 next;
3059 my $base = eval {
3060 safe_pipe_capture('git', 'merge-base',
3061 $lastpicked, $parent);
3063 # The two branches may not be related at all,
3064 # in which case merge base simply fails to find
3065 # any, but that's Ok.
3066 next if ($@);
3068 chomp $base;
3069 if ($base) {
3070 my @merged;
3071 # print "want to log between $base $parent \n";
3072 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3073 or die "Cannot call git-log: $!";
3074 my $mergedhash;
3075 while (<GITLOG>) {
3076 chomp;
3077 if (!defined $mergedhash) {
3078 if (m/^commit\s+(.+)$/) {
3079 $mergedhash = $1;
3080 } else {
3081 next;
3083 } else {
3084 # grab the first line that looks non-rfc822
3085 # aka has content after leading space
3086 if (m/^\s+(\S.*)$/) {
3087 my $title = $1;
3088 $title = substr($title,0,100); # truncate
3089 unshift @merged, "$mergedhash $title";
3090 undef $mergedhash;
3094 close GITLOG;
3095 if (@merged) {
3096 $commit->{mergemsg} = $commit->{message};
3097 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3098 foreach my $summary (@merged) {
3099 $commit->{mergemsg} .= "\t$summary\n";
3101 $commit->{mergemsg} .= "\n\n";
3102 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3109 # convert the date to CVS-happy format
3110 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3112 if ( defined ( $lastpicked ) )
3114 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3115 local ($/) = "\0";
3116 while ( <FILELIST> )
3118 chomp;
3119 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3121 die("Couldn't process git-diff-tree line : $_");
3123 my ($mode, $hash, $change) = ($1, $2, $3);
3124 my $name = <FILELIST>;
3125 chomp($name);
3127 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3129 my $git_perms = "";
3130 $git_perms .= "r" if ( $mode & 4 );
3131 $git_perms .= "w" if ( $mode & 2 );
3132 $git_perms .= "x" if ( $mode & 1 );
3133 $git_perms = "rw" if ( $git_perms eq "" );
3135 if ( $change eq "D" )
3137 #$log->debug("DELETE $name");
3138 $head->{$name} = {
3139 name => $name,
3140 revision => $head->{$name}{revision} + 1,
3141 filehash => "deleted",
3142 commithash => $commit->{hash},
3143 modified => $commit->{date},
3144 author => $commit->{author},
3145 mode => $git_perms,
3147 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3149 elsif ( $change eq "M" || $change eq "T" )
3151 #$log->debug("MODIFIED $name");
3152 $head->{$name} = {
3153 name => $name,
3154 revision => $head->{$name}{revision} + 1,
3155 filehash => $hash,
3156 commithash => $commit->{hash},
3157 modified => $commit->{date},
3158 author => $commit->{author},
3159 mode => $git_perms,
3161 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3163 elsif ( $change eq "A" )
3165 #$log->debug("ADDED $name");
3166 $head->{$name} = {
3167 name => $name,
3168 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3169 filehash => $hash,
3170 commithash => $commit->{hash},
3171 modified => $commit->{date},
3172 author => $commit->{author},
3173 mode => $git_perms,
3175 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3177 else
3179 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3180 die;
3183 close FILELIST;
3184 } else {
3185 # this is used to detect files removed from the repo
3186 my $seen_files = {};
3188 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3189 local $/ = "\0";
3190 while ( <FILELIST> )
3192 chomp;
3193 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3195 die("Couldn't process git-ls-tree line : $_");
3198 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3200 $seen_files->{$git_filename} = 1;
3202 my ( $oldhash, $oldrevision, $oldmode ) = (
3203 $head->{$git_filename}{filehash},
3204 $head->{$git_filename}{revision},
3205 $head->{$git_filename}{mode}
3208 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3210 $git_perms = "";
3211 $git_perms .= "r" if ( $1 & 4 );
3212 $git_perms .= "w" if ( $1 & 2 );
3213 $git_perms .= "x" if ( $1 & 1 );
3214 } else {
3215 $git_perms = "rw";
3218 # unless the file exists with the same hash, we need to update it ...
3219 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3221 my $newrevision = ( $oldrevision or 0 ) + 1;
3223 $head->{$git_filename} = {
3224 name => $git_filename,
3225 revision => $newrevision,
3226 filehash => $git_hash,
3227 commithash => $commit->{hash},
3228 modified => $commit->{date},
3229 author => $commit->{author},
3230 mode => $git_perms,
3234 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3237 close FILELIST;
3239 # Detect deleted files
3240 foreach my $file ( keys %$head )
3242 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3244 $head->{$file}{revision}++;
3245 $head->{$file}{filehash} = "deleted";
3246 $head->{$file}{commithash} = $commit->{hash};
3247 $head->{$file}{modified} = $commit->{date};
3248 $head->{$file}{author} = $commit->{author};
3250 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3253 # END : "Detect deleted files"
3257 if (exists $commit->{mergemsg})
3259 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3262 $lastpicked = $commit->{hash};
3264 $self->_set_prop("last_commit", $commit->{hash});
3267 $self->delete_head();
3268 foreach my $file ( keys %$head )
3270 $self->insert_head(
3271 $file,
3272 $head->{$file}{revision},
3273 $head->{$file}{filehash},
3274 $head->{$file}{commithash},
3275 $head->{$file}{modified},
3276 $head->{$file}{author},
3277 $head->{$file}{mode},
3280 # invalidate the gethead cache
3281 $self->{gethead_cache} = undef;
3284 # Ending exclusive lock here
3285 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3288 sub insert_rev
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("revision");
3300 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3301 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3304 sub insert_mergelog
3306 my $self = shift;
3307 my $key = shift;
3308 my $value = shift;
3309 my $tablename = $self->tablename("commitmsgs");
3311 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3312 $insert_mergelog->execute($key, $value);
3315 sub delete_head
3317 my $self = shift;
3318 my $tablename = $self->tablename("head");
3320 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3321 $delete_head->execute();
3324 sub insert_head
3326 my $self = shift;
3327 my $name = shift;
3328 my $revision = shift;
3329 my $filehash = shift;
3330 my $commithash = shift;
3331 my $modified = shift;
3332 my $author = shift;
3333 my $mode = shift;
3334 my $tablename = $self->tablename("head");
3336 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3337 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3340 sub _headrev
3342 my $self = shift;
3343 my $filename = shift;
3344 my $tablename = $self->tablename("head");
3346 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3347 $db_query->execute($filename);
3348 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3350 return ( $hash, $revision, $mode );
3353 sub _get_prop
3355 my $self = shift;
3356 my $key = shift;
3357 my $tablename = $self->tablename("properties");
3359 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3360 $db_query->execute($key);
3361 my ( $value ) = $db_query->fetchrow_array;
3363 return $value;
3366 sub _set_prop
3368 my $self = shift;
3369 my $key = shift;
3370 my $value = shift;
3371 my $tablename = $self->tablename("properties");
3373 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3374 $db_query->execute($value, $key);
3376 unless ( $db_query->rows )
3378 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3379 $db_query->execute($key, $value);
3382 return $value;
3385 =head2 gethead
3387 =cut
3389 sub gethead
3391 my $self = shift;
3392 my $tablename = $self->tablename("head");
3394 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3396 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3397 $db_query->execute();
3399 my $tree = [];
3400 while ( my $file = $db_query->fetchrow_hashref )
3402 push @$tree, $file;
3405 $self->{gethead_cache} = $tree;
3407 return $tree;
3410 =head2 getlog
3412 =cut
3414 sub getlog
3416 my $self = shift;
3417 my $filename = shift;
3418 my $tablename = $self->tablename("revision");
3420 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3421 $db_query->execute($filename);
3423 my $tree = [];
3424 while ( my $file = $db_query->fetchrow_hashref )
3426 push @$tree, $file;
3429 return $tree;
3432 =head2 getmeta
3434 This function takes a filename (with path) argument and returns a hashref of
3435 metadata for that file.
3437 =cut
3439 sub getmeta
3441 my $self = shift;
3442 my $filename = shift;
3443 my $revision = shift;
3444 my $tablename_rev = $self->tablename("revision");
3445 my $tablename_head = $self->tablename("head");
3447 my $db_query;
3448 if ( defined($revision) and $revision =~ /^\d+$/ )
3450 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3451 $db_query->execute($filename, $revision);
3453 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3455 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3456 $db_query->execute($filename, $revision);
3457 } else {
3458 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3459 $db_query->execute($filename);
3462 return $db_query->fetchrow_hashref;
3465 =head2 commitmessage
3467 this function takes a commithash and returns the commit message for that commit
3469 =cut
3470 sub commitmessage
3472 my $self = shift;
3473 my $commithash = shift;
3474 my $tablename = $self->tablename("commitmsgs");
3476 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3478 my $db_query;
3479 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3480 $db_query->execute($commithash);
3482 my ( $message ) = $db_query->fetchrow_array;
3484 if ( defined ( $message ) )
3486 $message .= " " if ( $message =~ /\n$/ );
3487 return $message;
3490 my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3491 shift @lines while ( $lines[0] =~ /\S/ );
3492 $message = join("",@lines);
3493 $message .= " " if ( $message =~ /\n$/ );
3494 return $message;
3497 =head2 gethistory
3499 This function takes a filename (with path) argument and returns an arrayofarrays
3500 containing revision,filehash,commithash ordered by revision descending
3502 =cut
3503 sub gethistory
3505 my $self = shift;
3506 my $filename = shift;
3507 my $tablename = $self->tablename("revision");
3509 my $db_query;
3510 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3511 $db_query->execute($filename);
3513 return $db_query->fetchall_arrayref;
3516 =head2 gethistorydense
3518 This function takes a filename (with path) argument and returns an arrayofarrays
3519 containing revision,filehash,commithash ordered by revision descending.
3521 This version of gethistory skips deleted entries -- so it is useful for annotate.
3522 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3523 and other git tools that depend on it.
3525 =cut
3526 sub gethistorydense
3528 my $self = shift;
3529 my $filename = shift;
3530 my $tablename = $self->tablename("revision");
3532 my $db_query;
3533 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3534 $db_query->execute($filename);
3536 return $db_query->fetchall_arrayref;
3539 =head2 in_array()
3541 from Array::PAT - mimics the in_array() function
3542 found in PHP. Yuck but works for small arrays.
3544 =cut
3545 sub in_array
3547 my ($check, @array) = @_;
3548 my $retval = 0;
3549 foreach my $test (@array){
3550 if($check eq $test){
3551 $retval = 1;
3554 return $retval;
3557 =head2 safe_pipe_capture
3559 an alternative to `command` that allows input to be passed as an array
3560 to work around shell problems with weird characters in arguments
3562 =cut
3563 sub safe_pipe_capture {
3565 my @output;
3567 if (my $pid = open my $child, '-|') {
3568 @output = (<$child>);
3569 close $child or die join(' ',@_).": $! $?";
3570 } else {
3571 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3573 return wantarray ? @output : join('',@output);
3576 =head2 mangle_dirname
3578 create a string from a directory name that is suitable to use as
3579 part of a filename, mainly by converting all chars except \w.- to _
3581 =cut
3582 sub mangle_dirname {
3583 my $dirname = shift;
3584 return unless defined $dirname;
3586 $dirname =~ s/[^\w.-]/_/g;
3588 return $dirname;