Merge branch 'maint'
[git/dscho.git] / git-cvsserver.perl
blob8817f8bb4f7c6b69d186c70d83cfb49b1fcea80e
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;
21 use Fcntl;
22 use File::Temp qw/tempdir tempfile/;
23 use File::Basename;
25 my $log = GITCVS::log->new();
26 my $cfg;
28 my $DATE_LIST = {
29 Jan => "01",
30 Feb => "02",
31 Mar => "03",
32 Apr => "04",
33 May => "05",
34 Jun => "06",
35 Jul => "07",
36 Aug => "08",
37 Sep => "09",
38 Oct => "10",
39 Nov => "11",
40 Dec => "12",
43 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
44 $| = 1;
46 #### Definition and mappings of functions ####
48 my $methods = {
49 'Root' => \&req_Root,
50 'Valid-responses' => \&req_Validresponses,
51 'valid-requests' => \&req_validrequests,
52 'Directory' => \&req_Directory,
53 'Entry' => \&req_Entry,
54 'Modified' => \&req_Modified,
55 'Unchanged' => \&req_Unchanged,
56 'Questionable' => \&req_Questionable,
57 'Argument' => \&req_Argument,
58 'Argumentx' => \&req_Argument,
59 'expand-modules' => \&req_expandmodules,
60 'add' => \&req_add,
61 'remove' => \&req_remove,
62 'co' => \&req_co,
63 'update' => \&req_update,
64 'ci' => \&req_ci,
65 'diff' => \&req_diff,
66 'log' => \&req_log,
67 'rlog' => \&req_log,
68 'tag' => \&req_CATCHALL,
69 'status' => \&req_status,
70 'admin' => \&req_CATCHALL,
71 'history' => \&req_CATCHALL,
72 'watchers' => \&req_CATCHALL,
73 'editors' => \&req_CATCHALL,
74 'annotate' => \&req_annotate,
75 'Global_option' => \&req_Globaloption,
76 #'annotate' => \&req_CATCHALL,
79 ##############################################
82 # $state holds all the bits of information the clients sends us that could
83 # potentially be useful when it comes to actually _doing_ something.
84 my $state = { prependdir => '' };
85 $log->info("--------------- STARTING -----------------");
87 my $TEMP_DIR = tempdir( CLEANUP => 1 );
88 $log->debug("Temporary directory is '$TEMP_DIR'");
90 # if we are called with a pserver argument,
91 # deal with the authentication cat before entering the
92 # main loop
93 if (@ARGV && $ARGV[0] eq 'pserver') {
94 my $line = <STDIN>; chomp $line;
95 unless( $line eq 'BEGIN AUTH REQUEST') {
96 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
98 $line = <STDIN>; chomp $line;
99 req_Root('root', $line) # reuse Root
100 or die "E Invalid root $line \n";
101 $line = <STDIN>; chomp $line;
102 unless ($line eq 'anonymous') {
103 print "E Only anonymous user allowed via pserver\n";
104 print "I HATE YOU\n";
106 $line = <STDIN>; chomp $line; # validate the password?
107 $line = <STDIN>; chomp $line;
108 unless ($line eq 'END AUTH REQUEST') {
109 die "E Do not understand $line -- expecting END AUTH REQUEST\n";
111 print "I LOVE YOU\n";
112 # and now back to our regular programme...
115 # Keep going until the client closes the connection
116 while (<STDIN>)
118 chomp;
120 # Check to see if we've seen this method, and call appropriate function.
121 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
123 # use the $methods hash to call the appropriate sub for this command
124 #$log->info("Method : $1");
125 &{$methods->{$1}}($1,$2);
126 } else {
127 # log fatal because we don't understand this function. If this happens
128 # we're fairly screwed because we don't know if the client is expecting
129 # a response. If it is, the client will hang, we'll hang, and the whole
130 # thing will be custard.
131 $log->fatal("Don't understand command $_\n");
132 die("Unknown command $_");
136 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
137 $log->info("--------------- FINISH -----------------");
139 # Magic catchall method.
140 # This is the method that will handle all commands we haven't yet
141 # implemented. It simply sends a warning to the log file indicating a
142 # command that hasn't been implemented has been invoked.
143 sub req_CATCHALL
145 my ( $cmd, $data ) = @_;
146 $log->warn("Unhandled command : req_$cmd : $data");
150 # Root pathname \n
151 # Response expected: no. Tell the server which CVSROOT to use. Note that
152 # pathname is a local directory and not a fully qualified CVSROOT variable.
153 # pathname must already exist; if creating a new root, use the init
154 # request, not Root. pathname does not include the hostname of the server,
155 # how to access the server, etc.; by the time the CVS protocol is in use,
156 # connection, authentication, etc., are already taken care of. The Root
157 # request must be sent only once, and it must be sent before any requests
158 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
159 sub req_Root
161 my ( $cmd, $data ) = @_;
162 $log->debug("req_Root : $data");
164 $state->{CVSROOT} = $data;
166 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
167 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
168 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
169 print "E \n";
170 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
171 return 0;
174 my @gitvars = `git-repo-config -l`;
175 if ($?) {
176 print "E problems executing git-repo-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
177 print "E \n";
178 print "error 1 - problem executing git-repo-config\n";
179 return 0;
181 foreach my $line ( @gitvars )
183 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
184 $cfg->{$1}{$2} = $3;
187 unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
189 print "E GITCVS emulation needs to be enabled on this repo\n";
190 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
191 print "E \n";
192 print "error 1 GITCVS emulation disabled\n";
193 return 0;
196 if ( defined ( $cfg->{gitcvs}{logfile} ) )
198 $log->setfile($cfg->{gitcvs}{logfile});
199 } else {
200 $log->nofile();
203 return 1;
206 # Global_option option \n
207 # Response expected: no. Transmit one of the global options `-q', `-Q',
208 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
209 # variations (such as combining of options) are allowed. For graceful
210 # handling of valid-requests, it is probably better to make new global
211 # options separate requests, rather than trying to add them to this
212 # request.
213 sub req_Globaloption
215 my ( $cmd, $data ) = @_;
216 $log->debug("req_Globaloption : $data");
217 $state->{globaloptions}{$data} = 1;
220 # Valid-responses request-list \n
221 # Response expected: no. Tell the server what responses the client will
222 # accept. request-list is a space separated list of tokens.
223 sub req_Validresponses
225 my ( $cmd, $data ) = @_;
226 $log->debug("req_Validresponses : $data");
228 # TODO : re-enable this, currently it's not particularly useful
229 #$state->{validresponses} = [ split /\s+/, $data ];
232 # valid-requests \n
233 # Response expected: yes. Ask the server to send back a Valid-requests
234 # response.
235 sub req_validrequests
237 my ( $cmd, $data ) = @_;
239 $log->debug("req_validrequests");
241 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
242 $log->debug("SEND : ok");
244 print "Valid-requests " . join(" ",keys %$methods) . "\n";
245 print "ok\n";
248 # Directory local-directory \n
249 # Additional data: repository \n. Response expected: no. Tell the server
250 # what directory to use. The repository should be a directory name from a
251 # previous server response. Note that this both gives a default for Entry
252 # and Modified and also for ci and the other commands; normal usage is to
253 # send Directory for each directory in which there will be an Entry or
254 # Modified, and then a final Directory for the original directory, then the
255 # command. The local-directory is relative to the top level at which the
256 # command is occurring (i.e. the last Directory which is sent before the
257 # command); to indicate that top level, `.' should be sent for
258 # local-directory.
259 sub req_Directory
261 my ( $cmd, $data ) = @_;
263 my $repository = <STDIN>;
264 chomp $repository;
267 $state->{localdir} = $data;
268 $state->{repository} = $repository;
269 $state->{path} = $repository;
270 $state->{path} =~ s/^$state->{CVSROOT}\///;
271 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
272 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
274 $state->{directory} = $state->{localdir};
275 $state->{directory} = "" if ( $state->{directory} eq "." );
276 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
278 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
280 $log->info("Setting prepend to '$state->{path}'");
281 $state->{prependdir} = $state->{path};
282 foreach my $entry ( keys %{$state->{entries}} )
284 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
285 delete $state->{entries}{$entry};
289 if ( defined ( $state->{prependdir} ) )
291 $log->debug("Prepending '$state->{prependdir}' to state|directory");
292 $state->{directory} = $state->{prependdir} . $state->{directory}
294 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
297 # Entry entry-line \n
298 # Response expected: no. Tell the server what version of a file is on the
299 # local machine. The name in entry-line is a name relative to the directory
300 # most recently specified with Directory. If the user is operating on only
301 # some files in a directory, Entry requests for only those files need be
302 # included. If an Entry request is sent without Modified, Is-modified, or
303 # Unchanged, it means the file is lost (does not exist in the working
304 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
305 # are sent for the same file, Entry must be sent first. For a given file,
306 # one can send Modified, Is-modified, or Unchanged, but not more than one
307 # of these three.
308 sub req_Entry
310 my ( $cmd, $data ) = @_;
312 #$log->debug("req_Entry : $data");
314 my @data = split(/\//, $data);
316 $state->{entries}{$state->{directory}.$data[1]} = {
317 revision => $data[2],
318 conflict => $data[3],
319 options => $data[4],
320 tag_or_date => $data[5],
323 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
326 # Questionable filename \n
327 # Response expected: no. Additional data: no. Tell the server to check
328 # whether filename should be ignored, and if not, next time the server
329 # sends responses, send (in a M response) `?' followed by the directory and
330 # filename. filename must not contain `/'; it needs to be a file in the
331 # directory named by the most recent Directory request.
332 sub req_Questionable
334 my ( $cmd, $data ) = @_;
336 $log->debug("req_Questionable : $data");
337 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
340 # add \n
341 # Response expected: yes. Add a file or directory. This uses any previous
342 # Argument, Directory, Entry, or Modified requests, if they have been sent.
343 # The last Directory sent specifies the working directory at the time of
344 # the operation. To add a directory, send the directory to be added using
345 # Directory and Argument requests.
346 sub req_add
348 my ( $cmd, $data ) = @_;
350 argsplit("add");
352 my $addcount = 0;
354 foreach my $filename ( @{$state->{args}} )
356 $filename = filecleanup($filename);
358 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
360 print "E cvs add: nothing known about `$filename'\n";
361 next;
363 # TODO : check we're not squashing an already existing file
364 if ( defined ( $state->{entries}{$filename}{revision} ) )
366 print "E cvs add: `$filename' has already been entered\n";
367 next;
370 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
372 print "E cvs add: scheduling file `$filename' for addition\n";
374 print "Checked-in $dirpart\n";
375 print "$filename\n";
376 print "/$filepart/0///\n";
378 $addcount++;
381 if ( $addcount == 1 )
383 print "E cvs add: use `cvs commit' to add this file permanently\n";
385 elsif ( $addcount > 1 )
387 print "E cvs add: use `cvs commit' to add these files permanently\n";
390 print "ok\n";
393 # remove \n
394 # Response expected: yes. Remove a file. This uses any previous Argument,
395 # Directory, Entry, or Modified requests, if they have been sent. The last
396 # Directory sent specifies the working directory at the time of the
397 # operation. Note that this request does not actually do anything to the
398 # repository; the only effect of a successful remove request is to supply
399 # the client with a new entries line containing `-' to indicate a removed
400 # file. In fact, the client probably could perform this operation without
401 # contacting the server, although using remove may cause the server to
402 # perform a few more checks. The client sends a subsequent ci request to
403 # actually record the removal in the repository.
404 sub req_remove
406 my ( $cmd, $data ) = @_;
408 argsplit("remove");
410 # Grab a handle to the SQLite db and do any necessary updates
411 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
412 $updater->update();
414 #$log->debug("add state : " . Dumper($state));
416 my $rmcount = 0;
418 foreach my $filename ( @{$state->{args}} )
420 $filename = filecleanup($filename);
422 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
424 print "E cvs remove: file `$filename' still in working directory\n";
425 next;
428 my $meta = $updater->getmeta($filename);
429 my $wrev = revparse($filename);
431 unless ( defined ( $wrev ) )
433 print "E cvs remove: nothing known about `$filename'\n";
434 next;
437 if ( defined($wrev) and $wrev < 0 )
439 print "E cvs remove: file `$filename' already scheduled for removal\n";
440 next;
443 unless ( $wrev == $meta->{revision} )
445 # TODO : not sure if the format of this message is quite correct.
446 print "E cvs remove: Up to date check failed for `$filename'\n";
447 next;
451 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
453 print "E cvs remove: scheduling `$filename' for removal\n";
455 print "Checked-in $dirpart\n";
456 print "$filename\n";
457 print "/$filepart/-1.$wrev///\n";
459 $rmcount++;
462 if ( $rmcount == 1 )
464 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
466 elsif ( $rmcount > 1 )
468 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
471 print "ok\n";
474 # Modified filename \n
475 # Response expected: no. Additional data: mode, \n, file transmission. Send
476 # the server a copy of one locally modified file. filename is a file within
477 # the most recent directory sent with Directory; it must not contain `/'.
478 # If the user is operating on only some files in a directory, only those
479 # files need to be included. This can also be sent without Entry, if there
480 # is no entry for the file.
481 sub req_Modified
483 my ( $cmd, $data ) = @_;
485 my $mode = <STDIN>;
486 chomp $mode;
487 my $size = <STDIN>;
488 chomp $size;
490 # Grab config information
491 my $blocksize = 8192;
492 my $bytesleft = $size;
493 my $tmp;
495 # Get a filehandle/name to write it to
496 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
498 # Loop over file data writing out to temporary file.
499 while ( $bytesleft )
501 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
502 read STDIN, $tmp, $blocksize;
503 print $fh $tmp;
504 $bytesleft -= $blocksize;
507 close $fh;
509 # Ensure we have something sensible for the file mode
510 if ( $mode =~ /u=(\w+)/ )
512 $mode = $1;
513 } else {
514 $mode = "rw";
517 # Save the file data in $state
518 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
519 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
520 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
521 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
523 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
526 # Unchanged filename \n
527 # Response expected: no. Tell the server that filename has not been
528 # modified in the checked out directory. The filename is a file within the
529 # most recent directory sent with Directory; it must not contain `/'.
530 sub req_Unchanged
532 my ( $cmd, $data ) = @_;
534 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
536 #$log->debug("req_Unchanged : $data");
539 # Argument text \n
540 # Response expected: no. Save argument for use in a subsequent command.
541 # Arguments accumulate until an argument-using command is given, at which
542 # point they are forgotten.
543 # Argumentx text \n
544 # Response expected: no. Append \n followed by text to the current argument
545 # being saved.
546 sub req_Argument
548 my ( $cmd, $data ) = @_;
550 # Argumentx means: append to last Argument (with a newline in front)
552 $log->debug("$cmd : $data");
554 if ( $cmd eq 'Argumentx') {
555 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
556 } else {
557 push @{$state->{arguments}}, $data;
561 # expand-modules \n
562 # Response expected: yes. Expand the modules which are specified in the
563 # arguments. Returns the data in Module-expansion responses. Note that the
564 # server can assume that this is checkout or export, not rtag or rdiff; the
565 # latter do not access the working directory and thus have no need to
566 # expand modules on the client side. Expand may not be the best word for
567 # what this request does. It does not necessarily tell you all the files
568 # contained in a module, for example. Basically it is a way of telling you
569 # which working directories the server needs to know about in order to
570 # handle a checkout of the specified modules. For example, suppose that the
571 # server has a module defined by
572 # aliasmodule -a 1dir
573 # That is, one can check out aliasmodule and it will take 1dir in the
574 # repository and check it out to 1dir in the working directory. Now suppose
575 # the client already has this module checked out and is planning on using
576 # the co request to update it. Without using expand-modules, the client
577 # would have two bad choices: it could either send information about all
578 # working directories under the current directory, which could be
579 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
580 # stands for 1dir, and neglect to send information for 1dir, which would
581 # lead to incorrect operation. With expand-modules, the client would first
582 # ask for the module to be expanded:
583 sub req_expandmodules
585 my ( $cmd, $data ) = @_;
587 argsplit();
589 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
591 unless ( ref $state->{arguments} eq "ARRAY" )
593 print "ok\n";
594 return;
597 foreach my $module ( @{$state->{arguments}} )
599 $log->debug("SEND : Module-expansion $module");
600 print "Module-expansion $module\n";
603 print "ok\n";
604 statecleanup();
607 # co \n
608 # Response expected: yes. Get files from the repository. This uses any
609 # previous Argument, Directory, Entry, or Modified requests, if they have
610 # been sent. Arguments to this command are module names; the client cannot
611 # know what directories they correspond to except by (1) just sending the
612 # co request, and then seeing what directory names the server sends back in
613 # its responses, and (2) the expand-modules request.
614 sub req_co
616 my ( $cmd, $data ) = @_;
618 argsplit("co");
620 my $module = $state->{args}[0];
621 my $checkout_path = $module;
623 # use the user specified directory if we're given it
624 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
626 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
628 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
630 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
632 # Grab a handle to the SQLite db and do any necessary updates
633 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
634 $updater->update();
636 $checkout_path =~ s|/$||; # get rid of trailing slashes
638 # Eclipse seems to need the Clear-sticky command
639 # to prepare the 'Entries' file for the new directory.
640 print "Clear-sticky $checkout_path/\n";
641 print $state->{CVSROOT} . "/$module/\n";
642 print "Clear-static-directory $checkout_path/\n";
643 print $state->{CVSROOT} . "/$module/\n";
644 print "Clear-sticky $checkout_path/\n"; # yes, twice
645 print $state->{CVSROOT} . "/$module/\n";
646 print "Template $checkout_path/\n";
647 print $state->{CVSROOT} . "/$module/\n";
648 print "0\n";
650 # instruct the client that we're checking out to $checkout_path
651 print "E cvs checkout: Updating $checkout_path\n";
653 my %seendirs = ();
654 my $lastdir ='';
656 # recursive
657 sub prepdir {
658 my ($dir, $repodir, $remotedir, $seendirs) = @_;
659 my $parent = dirname($dir);
660 $dir =~ s|/+$||;
661 $repodir =~ s|/+$||;
662 $remotedir =~ s|/+$||;
663 $parent =~ s|/+$||;
664 $log->debug("announcedir $dir, $repodir, $remotedir" );
666 if ($parent eq '.' || $parent eq './') {
667 $parent = '';
669 # recurse to announce unseen parents first
670 if (length($parent) && !exists($seendirs->{$parent})) {
671 prepdir($parent, $repodir, $remotedir, $seendirs);
673 # Announce that we are going to modify at the parent level
674 if ($parent) {
675 print "E cvs checkout: Updating $remotedir/$parent\n";
676 } else {
677 print "E cvs checkout: Updating $remotedir\n";
679 print "Clear-sticky $remotedir/$parent/\n";
680 print "$repodir/$parent/\n";
682 print "Clear-static-directory $remotedir/$dir/\n";
683 print "$repodir/$dir/\n";
684 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
685 print "$repodir/$parent/\n";
686 print "Template $remotedir/$dir/\n";
687 print "$repodir/$dir/\n";
688 print "0\n";
690 $seendirs->{$dir} = 1;
693 foreach my $git ( @{$updater->gethead} )
695 # Don't want to check out deleted files
696 next if ( $git->{filehash} eq "deleted" );
698 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
700 if (length($git->{dir}) && $git->{dir} ne './'
701 && $git->{dir} ne $lastdir ) {
702 unless (exists($seendirs{$git->{dir}})) {
703 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
704 $checkout_path, \%seendirs);
705 $lastdir = $git->{dir};
706 $seendirs{$git->{dir}} = 1;
708 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
711 # modification time of this file
712 print "Mod-time $git->{modified}\n";
714 # print some information to the client
715 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
717 print "M U $checkout_path/$git->{dir}$git->{name}\n";
718 } else {
719 print "M U $checkout_path/$git->{name}\n";
722 # instruct client we're sending a file to put in this path
723 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
725 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
727 # this is an "entries" line
728 print "/$git->{name}/1.$git->{revision}///\n";
729 # permissions
730 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
732 # transmit file
733 transmitfile($git->{filehash});
736 print "ok\n";
738 statecleanup();
741 # update \n
742 # Response expected: yes. Actually do a cvs update command. This uses any
743 # previous Argument, Directory, Entry, or Modified requests, if they have
744 # been sent. The last Directory sent specifies the working directory at the
745 # time of the operation. The -I option is not used--files which the client
746 # can decide whether to ignore are not mentioned and the client sends the
747 # Questionable request for others.
748 sub req_update
750 my ( $cmd, $data ) = @_;
752 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
754 argsplit("update");
757 # It may just be a client exploring the available heads/modules
758 # in that case, list them as top level directories and leave it
759 # at that. Eclipse uses this technique to offer you a list of
760 # projects (heads in this case) to checkout.
762 if ($state->{module} eq '') {
763 print "E cvs update: Updating .\n";
764 opendir HEADS, $state->{CVSROOT} . '/refs/heads';
765 while (my $head = readdir(HEADS)) {
766 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
767 print "E cvs update: New directory `$head'\n";
770 closedir HEADS;
771 print "ok\n";
772 return 1;
776 # Grab a handle to the SQLite db and do any necessary updates
777 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
779 $updater->update();
781 argsfromdir($updater);
783 #$log->debug("update state : " . Dumper($state));
785 # foreach file specified on the command line ...
786 foreach my $filename ( @{$state->{args}} )
788 $filename = filecleanup($filename);
790 $log->debug("Processing file $filename");
792 # if we have a -C we should pretend we never saw modified stuff
793 if ( exists ( $state->{opt}{C} ) )
795 delete $state->{entries}{$filename}{modified_hash};
796 delete $state->{entries}{$filename}{modified_filename};
797 $state->{entries}{$filename}{unchanged} = 1;
800 my $meta;
801 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
803 $meta = $updater->getmeta($filename, $1);
804 } else {
805 $meta = $updater->getmeta($filename);
808 if ( ! defined $meta )
810 $meta = {
811 name => $filename,
812 revision => 0,
813 filehash => 'added'
817 my $oldmeta = $meta;
819 my $wrev = revparse($filename);
821 # If the working copy is an old revision, lets get that version too for comparison.
822 if ( defined($wrev) and $wrev != $meta->{revision} )
824 $oldmeta = $updater->getmeta($filename, $wrev);
827 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
829 # Files are up to date if the working copy and repo copy have the same revision,
830 # and the working copy is unmodified _and_ the user hasn't specified -C
831 next if ( defined ( $wrev )
832 and defined($meta->{revision})
833 and $wrev == $meta->{revision}
834 and $state->{entries}{$filename}{unchanged}
835 and not exists ( $state->{opt}{C} ) );
837 # If the working copy and repo copy have the same revision,
838 # but the working copy is modified, tell the client it's modified
839 if ( defined ( $wrev )
840 and defined($meta->{revision})
841 and $wrev == $meta->{revision}
842 and not exists ( $state->{opt}{C} ) )
844 $log->info("Tell the client the file is modified");
845 print "MT text M \n";
846 print "MT fname $filename\n";
847 print "MT newline\n";
848 next;
851 if ( $meta->{filehash} eq "deleted" )
853 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
855 $log->info("Removing '$filename' from working copy (no longer in the repo)");
857 print "E cvs update: `$filename' is no longer in the repository\n";
858 # Don't want to actually _DO_ the update if -n specified
859 unless ( $state->{globaloptions}{-n} ) {
860 print "Removed $dirpart\n";
861 print "$filepart\n";
864 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
865 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
866 or $meta->{filehash} eq 'added' )
868 # normal update, just send the new revision (either U=Update,
869 # or A=Add, or R=Remove)
870 if ( defined($wrev) && $wrev < 0 )
872 $log->info("Tell the client the file is scheduled for removal");
873 print "MT text R \n";
874 print "MT fname $filename\n";
875 print "MT newline\n";
876 next;
878 elsif ( !defined($wrev) || $wrev == 0 )
880 $log->info("Tell the client the file will be added");
881 print "MT text A \n";
882 print "MT fname $filename\n";
883 print "MT newline\n";
884 next;
887 else {
888 $log->info("Updating '$filename' $wrev");
889 print "MT +updated\n";
890 print "MT text U \n";
891 print "MT fname $filename\n";
892 print "MT newline\n";
893 print "MT -updated\n";
896 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
898 # Don't want to actually _DO_ the update if -n specified
899 unless ( $state->{globaloptions}{-n} )
901 if ( defined ( $wrev ) )
903 # instruct client we're sending a file to put in this path as a replacement
904 print "Update-existing $dirpart\n";
905 $log->debug("Updating existing file 'Update-existing $dirpart'");
906 } else {
907 # instruct client we're sending a file to put in this path as a new file
908 print "Clear-static-directory $dirpart\n";
909 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
910 print "Clear-sticky $dirpart\n";
911 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
913 $log->debug("Creating new file 'Created $dirpart'");
914 print "Created $dirpart\n";
916 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
918 # this is an "entries" line
919 $log->debug("/$filepart/1.$meta->{revision}///");
920 print "/$filepart/1.$meta->{revision}///\n";
922 # permissions
923 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
924 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
926 # transmit file
927 transmitfile($meta->{filehash});
929 } else {
930 $log->info("Updating '$filename'");
931 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
933 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
935 chdir $dir;
936 my $file_local = $filepart . ".mine";
937 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
938 my $file_old = $filepart . "." . $oldmeta->{revision};
939 transmitfile($oldmeta->{filehash}, $file_old);
940 my $file_new = $filepart . "." . $meta->{revision};
941 transmitfile($meta->{filehash}, $file_new);
943 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
944 $log->info("Merging $file_local, $file_old, $file_new");
946 $log->debug("Temporary directory for merge is $dir");
948 my $return = system("merge", $file_local, $file_old, $file_new);
949 $return >>= 8;
951 if ( $return == 0 )
953 $log->info("Merged successfully");
954 print "M M $filename\n";
955 $log->debug("Update-existing $dirpart");
957 # Don't want to actually _DO_ the update if -n specified
958 unless ( $state->{globaloptions}{-n} )
960 print "Update-existing $dirpart\n";
961 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
962 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
963 $log->debug("/$filepart/1.$meta->{revision}///");
964 print "/$filepart/1.$meta->{revision}///\n";
967 elsif ( $return == 1 )
969 $log->info("Merged with conflicts");
970 print "M C $filename\n";
972 # Don't want to actually _DO_ the update if -n specified
973 unless ( $state->{globaloptions}{-n} )
975 print "Update-existing $dirpart\n";
976 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
977 print "/$filepart/1.$meta->{revision}/+//\n";
980 else
982 $log->warn("Merge failed");
983 next;
986 # Don't want to actually _DO_ the update if -n specified
987 unless ( $state->{globaloptions}{-n} )
989 # permissions
990 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
991 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
993 # transmit file, format is single integer on a line by itself (file
994 # size) followed by the file contents
995 # TODO : we should copy files in blocks
996 my $data = `cat $file_local`;
997 $log->debug("File size : " . length($data));
998 print length($data) . "\n";
999 print $data;
1002 chdir "/";
1007 print "ok\n";
1010 sub req_ci
1012 my ( $cmd, $data ) = @_;
1014 argsplit("ci");
1016 #$log->debug("State : " . Dumper($state));
1018 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1020 if ( @ARGV && $ARGV[0] eq 'pserver')
1022 print "error 1 pserver access cannot commit\n";
1023 exit;
1026 if ( -e $state->{CVSROOT} . "/index" )
1028 $log->warn("file 'index' already exists in the git repository");
1029 print "error 1 Index already exists in git repo\n";
1030 exit;
1033 my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
1034 unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
1036 $log->warn("lockfile '$lockfile' already exists, please try again");
1037 print "error 1 Lock file '$lockfile' already exists, please try again\n";
1038 exit;
1041 # Grab a handle to the SQLite db and do any necessary updates
1042 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1043 $updater->update();
1045 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1046 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1047 $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
1049 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1050 $ENV{GIT_INDEX_FILE} = $file_index;
1052 chdir $tmpdir;
1054 # populate the temporary index based
1055 system("git-read-tree", $state->{module});
1056 unless ($? == 0)
1058 die "Error running git-read-tree $state->{module} $file_index $!";
1060 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1063 my @committedfiles = ();
1065 # foreach file specified on the command line ...
1066 foreach my $filename ( @{$state->{args}} )
1068 my $committedfile = $filename;
1069 $filename = filecleanup($filename);
1071 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1073 my $meta = $updater->getmeta($filename);
1075 my $wrev = revparse($filename);
1077 my ( $filepart, $dirpart ) = filenamesplit($filename);
1079 # do a checkout of the file if it part of this tree
1080 if ($wrev) {
1081 system('git-checkout-index', '-f', '-u', $filename);
1082 unless ($? == 0) {
1083 die "Error running git-checkout-index -f -u $filename : $!";
1087 my $addflag = 0;
1088 my $rmflag = 0;
1089 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1090 $addflag = 1 unless ( -e $filename );
1092 # Do up to date checking
1093 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1095 # fail everything if an up to date check fails
1096 print "error 1 Up to date check failed for $filename\n";
1097 close LOCKFILE;
1098 unlink($lockfile);
1099 chdir "/";
1100 exit;
1103 push @committedfiles, $committedfile;
1104 $log->info("Committing $filename");
1106 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1108 unless ( $rmflag )
1110 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1111 rename $state->{entries}{$filename}{modified_filename},$filename;
1113 # Calculate modes to remove
1114 my $invmode = "";
1115 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1117 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1118 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1121 if ( $rmflag )
1123 $log->info("Removing file '$filename'");
1124 unlink($filename);
1125 system("git-update-index", "--remove", $filename);
1127 elsif ( $addflag )
1129 $log->info("Adding file '$filename'");
1130 system("git-update-index", "--add", $filename);
1131 } else {
1132 $log->info("Updating file '$filename'");
1133 system("git-update-index", $filename);
1137 unless ( scalar(@committedfiles) > 0 )
1139 print "E No files to commit\n";
1140 print "ok\n";
1141 close LOCKFILE;
1142 unlink($lockfile);
1143 chdir "/";
1144 return;
1147 my $treehash = `git-write-tree`;
1148 my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
1149 chomp $treehash;
1150 chomp $parenthash;
1152 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1154 # write our commit message out if we have one ...
1155 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1156 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1157 print $msg_fh "\n\nvia git-CVS emulator\n";
1158 close $msg_fh;
1160 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1161 $log->info("Commit hash : $commithash");
1163 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1165 $log->warn("Commit failed (Invalid commit hash)");
1166 print "error 1 Commit failed (unknown reason)\n";
1167 close LOCKFILE;
1168 unlink($lockfile);
1169 chdir "/";
1170 exit;
1173 print LOCKFILE $commithash;
1175 $updater->update();
1177 # foreach file specified on the command line ...
1178 foreach my $filename ( @committedfiles )
1180 $filename = filecleanup($filename);
1182 my $meta = $updater->getmeta($filename);
1184 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1186 $log->debug("Checked-in $dirpart : $filename");
1188 if ( $meta->{filehash} eq "deleted" )
1190 print "Remove-entry $dirpart\n";
1191 print "$filename\n";
1192 } else {
1193 print "Checked-in $dirpart\n";
1194 print "$filename\n";
1195 print "/$filepart/1.$meta->{revision}///\n";
1199 close LOCKFILE;
1200 my $reffile = "$ENV{GIT_DIR}refs/heads/$state->{module}";
1201 unlink($reffile);
1202 rename($lockfile, $reffile);
1203 chdir "/";
1205 print "ok\n";
1208 sub req_status
1210 my ( $cmd, $data ) = @_;
1212 argsplit("status");
1214 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1215 #$log->debug("status state : " . Dumper($state));
1217 # Grab a handle to the SQLite db and do any necessary updates
1218 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1219 $updater->update();
1221 # if no files were specified, we need to work out what files we should be providing status on ...
1222 argsfromdir($updater);
1224 # foreach file specified on the command line ...
1225 foreach my $filename ( @{$state->{args}} )
1227 $filename = filecleanup($filename);
1229 my $meta = $updater->getmeta($filename);
1230 my $oldmeta = $meta;
1232 my $wrev = revparse($filename);
1234 # If the working copy is an old revision, lets get that version too for comparison.
1235 if ( defined($wrev) and $wrev != $meta->{revision} )
1237 $oldmeta = $updater->getmeta($filename, $wrev);
1240 # TODO : All possible statuses aren't yet implemented
1241 my $status;
1242 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1243 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1245 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1246 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1249 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1250 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1252 ( $state->{entries}{$filename}{unchanged}
1253 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1256 # Need checkout if it exists in the repo but doesn't have a working copy
1257 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1259 # Locally modified if working copy and repo copy have the same revision but there are local changes
1260 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1262 # Needs Merge if working copy revision is less than repo copy and there are local changes
1263 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1265 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1266 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1267 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1268 $status ||= "File had conflicts on merge" if ( 0 );
1270 $status ||= "Unknown";
1272 print "M ===================================================================\n";
1273 print "M File: $filename\tStatus: $status\n";
1274 if ( defined($state->{entries}{$filename}{revision}) )
1276 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1277 } else {
1278 print "M Working revision:\tNo entry for $filename\n";
1280 if ( defined($meta->{revision}) )
1282 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1283 print "M Sticky Tag:\t\t(none)\n";
1284 print "M Sticky Date:\t\t(none)\n";
1285 print "M Sticky Options:\t\t(none)\n";
1286 } else {
1287 print "M Repository revision:\tNo revision control file\n";
1289 print "M\n";
1292 print "ok\n";
1295 sub req_diff
1297 my ( $cmd, $data ) = @_;
1299 argsplit("diff");
1301 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1302 #$log->debug("status state : " . Dumper($state));
1304 my ($revision1, $revision2);
1305 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1307 $revision1 = $state->{opt}{r}[0];
1308 $revision2 = $state->{opt}{r}[1];
1309 } else {
1310 $revision1 = $state->{opt}{r};
1313 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1314 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1316 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1318 # Grab a handle to the SQLite db and do any necessary updates
1319 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1320 $updater->update();
1322 # if no files were specified, we need to work out what files we should be providing status on ...
1323 argsfromdir($updater);
1325 # foreach file specified on the command line ...
1326 foreach my $filename ( @{$state->{args}} )
1328 $filename = filecleanup($filename);
1330 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1332 my $wrev = revparse($filename);
1334 # We need _something_ to diff against
1335 next unless ( defined ( $wrev ) );
1337 # if we have a -r switch, use it
1338 if ( defined ( $revision1 ) )
1340 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1341 $meta1 = $updater->getmeta($filename, $revision1);
1342 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1344 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1345 next;
1347 transmitfile($meta1->{filehash}, $file1);
1349 # otherwise we just use the working copy revision
1350 else
1352 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1353 $meta1 = $updater->getmeta($filename, $wrev);
1354 transmitfile($meta1->{filehash}, $file1);
1357 # if we have a second -r switch, use it too
1358 if ( defined ( $revision2 ) )
1360 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1361 $meta2 = $updater->getmeta($filename, $revision2);
1363 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1365 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1366 next;
1369 transmitfile($meta2->{filehash}, $file2);
1371 # otherwise we just use the working copy
1372 else
1374 $file2 = $state->{entries}{$filename}{modified_filename};
1377 # if we have been given -r, and we don't have a $file2 yet, lets get one
1378 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1380 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1381 $meta2 = $updater->getmeta($filename, $wrev);
1382 transmitfile($meta2->{filehash}, $file2);
1385 # We need to have retrieved something useful
1386 next unless ( defined ( $meta1 ) );
1388 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1389 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1391 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1392 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1395 # Apparently we only show diffs for locally modified files
1396 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1398 print "M Index: $filename\n";
1399 print "M ===================================================================\n";
1400 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1401 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1402 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1403 print "M diff ";
1404 foreach my $opt ( keys %{$state->{opt}} )
1406 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1408 foreach my $value ( @{$state->{opt}{$opt}} )
1410 print "-$opt $value ";
1412 } else {
1413 print "-$opt ";
1414 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1417 print "$filename\n";
1419 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1421 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1423 if ( exists $state->{opt}{u} )
1425 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1426 } else {
1427 system("diff $file1 $file2 > $filediff");
1430 while ( <$fh> )
1432 print "M $_";
1434 close $fh;
1437 print "ok\n";
1440 sub req_log
1442 my ( $cmd, $data ) = @_;
1444 argsplit("log");
1446 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1447 #$log->debug("log state : " . Dumper($state));
1449 my ( $minrev, $maxrev );
1450 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1452 my $control = $2;
1453 $minrev = $1;
1454 $maxrev = $3;
1455 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1456 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1457 $minrev++ if ( defined($minrev) and $control eq "::" );
1460 # Grab a handle to the SQLite db and do any necessary updates
1461 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1462 $updater->update();
1464 # if no files were specified, we need to work out what files we should be providing status on ...
1465 argsfromdir($updater);
1467 # foreach file specified on the command line ...
1468 foreach my $filename ( @{$state->{args}} )
1470 $filename = filecleanup($filename);
1472 my $headmeta = $updater->getmeta($filename);
1474 my $revisions = $updater->getlog($filename);
1475 my $totalrevisions = scalar(@$revisions);
1477 if ( defined ( $minrev ) )
1479 $log->debug("Removing revisions less than $minrev");
1480 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1482 pop @$revisions;
1485 if ( defined ( $maxrev ) )
1487 $log->debug("Removing revisions greater than $maxrev");
1488 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1490 shift @$revisions;
1494 next unless ( scalar(@$revisions) );
1496 print "M \n";
1497 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1498 print "M Working file: $filename\n";
1499 print "M head: 1.$headmeta->{revision}\n";
1500 print "M branch:\n";
1501 print "M locks: strict\n";
1502 print "M access list:\n";
1503 print "M symbolic names:\n";
1504 print "M keyword substitution: kv\n";
1505 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1506 print "M description:\n";
1508 foreach my $revision ( @$revisions )
1510 print "M ----------------------------\n";
1511 print "M revision 1.$revision->{revision}\n";
1512 # reformat the date for log output
1513 $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}) );
1514 $revision->{author} =~ s/\s+.*//;
1515 $revision->{author} =~ s/^(.{8}).*/$1/;
1516 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1517 my $commitmessage = $updater->commitmessage($revision->{commithash});
1518 $commitmessage =~ s/^/M /mg;
1519 print $commitmessage . "\n";
1521 print "M =============================================================================\n";
1524 print "ok\n";
1527 sub req_annotate
1529 my ( $cmd, $data ) = @_;
1531 argsplit("annotate");
1533 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1534 #$log->debug("status state : " . Dumper($state));
1536 # Grab a handle to the SQLite db and do any necessary updates
1537 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1538 $updater->update();
1540 # if no files were specified, we need to work out what files we should be providing annotate on ...
1541 argsfromdir($updater);
1543 # we'll need a temporary checkout dir
1544 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1545 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1546 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1548 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1549 $ENV{GIT_INDEX_FILE} = $file_index;
1551 chdir $tmpdir;
1553 # foreach file specified on the command line ...
1554 foreach my $filename ( @{$state->{args}} )
1556 $filename = filecleanup($filename);
1558 my $meta = $updater->getmeta($filename);
1560 next unless ( $meta->{revision} );
1562 # get all the commits that this file was in
1563 # in dense format -- aka skip dead revisions
1564 my $revisions = $updater->gethistorydense($filename);
1565 my $lastseenin = $revisions->[0][2];
1567 # populate the temporary index based on the latest commit were we saw
1568 # the file -- but do it cheaply without checking out any files
1569 # TODO: if we got a revision from the client, use that instead
1570 # to look up the commithash in sqlite (still good to default to
1571 # the current head as we do now)
1572 system("git-read-tree", $lastseenin);
1573 unless ($? == 0)
1575 die "Error running git-read-tree $lastseenin $file_index $!";
1577 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1579 # do a checkout of the file
1580 system('git-checkout-index', '-f', '-u', $filename);
1581 unless ($? == 0) {
1582 die "Error running git-checkout-index -f -u $filename : $!";
1585 $log->info("Annotate $filename");
1587 # Prepare a file with the commits from the linearized
1588 # history that annotate should know about. This prevents
1589 # git-jsannotate telling us about commits we are hiding
1590 # from the client.
1592 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1593 for (my $i=0; $i < @$revisions; $i++)
1595 print ANNOTATEHINTS $revisions->[$i][2];
1596 if ($i+1 < @$revisions) { # have we got a parent?
1597 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1599 print ANNOTATEHINTS "\n";
1602 print ANNOTATEHINTS "\n";
1603 close ANNOTATEHINTS;
1605 my $annotatecmd = 'git-annotate';
1606 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1607 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1608 my $metadata = {};
1609 print "E Annotations for $filename\n";
1610 print "E ***************\n";
1611 while ( <ANNOTATE> )
1613 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1615 my $commithash = $1;
1616 my $data = $2;
1617 unless ( defined ( $metadata->{$commithash} ) )
1619 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1620 $metadata->{$commithash}{author} =~ s/\s+.*//;
1621 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1622 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1624 printf("M 1.%-5d (%-8s %10s): %s\n",
1625 $metadata->{$commithash}{revision},
1626 $metadata->{$commithash}{author},
1627 $metadata->{$commithash}{modified},
1628 $data
1630 } else {
1631 $log->warn("Error in annotate output! LINE: $_");
1632 print "E Annotate error \n";
1633 next;
1636 close ANNOTATE;
1639 # done; get out of the tempdir
1640 chdir "/";
1642 print "ok\n";
1646 # This method takes the state->{arguments} array and produces two new arrays.
1647 # The first is $state->{args} which is everything before the '--' argument, and
1648 # the second is $state->{files} which is everything after it.
1649 sub argsplit
1651 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1653 my $type = shift;
1655 $state->{args} = [];
1656 $state->{files} = [];
1657 $state->{opt} = {};
1659 if ( defined($type) )
1661 my $opt = {};
1662 $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" );
1663 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1664 $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" );
1665 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1666 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1667 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1668 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1669 $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" );
1672 while ( scalar ( @{$state->{arguments}} ) > 0 )
1674 my $arg = shift @{$state->{arguments}};
1676 next if ( $arg eq "--" );
1677 next unless ( $arg =~ /\S/ );
1679 # if the argument looks like a switch
1680 if ( $arg =~ /^-(\w)(.*)/ )
1682 # if it's a switch that takes an argument
1683 if ( $opt->{$1} )
1685 # If this switch has already been provided
1686 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1688 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1689 if ( length($2) > 0 )
1691 push @{$state->{opt}{$1}},$2;
1692 } else {
1693 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1695 } else {
1696 # if there's extra data in the arg, use that as the argument for the switch
1697 if ( length($2) > 0 )
1699 $state->{opt}{$1} = $2;
1700 } else {
1701 $state->{opt}{$1} = shift @{$state->{arguments}};
1704 } else {
1705 $state->{opt}{$1} = undef;
1708 else
1710 push @{$state->{args}}, $arg;
1714 else
1716 my $mode = 0;
1718 foreach my $value ( @{$state->{arguments}} )
1720 if ( $value eq "--" )
1722 $mode++;
1723 next;
1725 push @{$state->{args}}, $value if ( $mode == 0 );
1726 push @{$state->{files}}, $value if ( $mode == 1 );
1731 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1732 sub argsfromdir
1734 my $updater = shift;
1736 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1738 return if ( scalar ( @{$state->{args}} ) > 1 );
1740 my @gethead = @{$updater->gethead};
1742 # push added files
1743 foreach my $file (keys %{$state->{entries}}) {
1744 if ( exists $state->{entries}{$file}{revision} &&
1745 $state->{entries}{$file}{revision} == 0 )
1747 push @gethead, { name => $file, filehash => 'added' };
1751 if ( scalar(@{$state->{args}}) == 1 )
1753 my $arg = $state->{args}[0];
1754 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1756 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1758 foreach my $file ( @gethead )
1760 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1761 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1762 push @{$state->{args}}, $file->{name};
1765 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1766 } else {
1767 $log->info("Only one arg specified, populating file list automatically");
1769 $state->{args} = [];
1771 foreach my $file ( @gethead )
1773 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1774 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1775 push @{$state->{args}}, $file->{name};
1780 # This method cleans up the $state variable after a command that uses arguments has run
1781 sub statecleanup
1783 $state->{files} = [];
1784 $state->{args} = [];
1785 $state->{arguments} = [];
1786 $state->{entries} = {};
1789 sub revparse
1791 my $filename = shift;
1793 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1795 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1796 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1798 return undef;
1801 # This method takes a file hash and does a CVS "file transfer" which transmits the
1802 # size of the file, and then the file contents.
1803 # If a second argument $targetfile is given, the file is instead written out to
1804 # a file by the name of $targetfile
1805 sub transmitfile
1807 my $filehash = shift;
1808 my $targetfile = shift;
1810 if ( defined ( $filehash ) and $filehash eq "deleted" )
1812 $log->warn("filehash is 'deleted'");
1813 return;
1816 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1818 my $type = `git-cat-file -t $filehash`;
1819 chomp $type;
1821 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1823 my $size = `git-cat-file -s $filehash`;
1824 chomp $size;
1826 $log->debug("transmitfile($filehash) size=$size, type=$type");
1828 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1830 if ( defined ( $targetfile ) )
1832 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1833 print NEWFILE $_ while ( <$fh> );
1834 close NEWFILE;
1835 } else {
1836 print "$size\n";
1837 print while ( <$fh> );
1839 close $fh or die ("Couldn't close filehandle for transmitfile()");
1840 } else {
1841 die("Couldn't execute git-cat-file");
1845 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1846 # refers to the directory portion and the file portion of the filename
1847 # respectively
1848 sub filenamesplit
1850 my $filename = shift;
1851 my $fixforlocaldir = shift;
1853 my ( $filepart, $dirpart ) = ( $filename, "." );
1854 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1855 $dirpart .= "/";
1857 if ( $fixforlocaldir )
1859 $dirpart =~ s/^$state->{prependdir}//;
1862 return ( $filepart, $dirpart );
1865 sub filecleanup
1867 my $filename = shift;
1869 return undef unless(defined($filename));
1870 if ( $filename =~ /^\// )
1872 print "E absolute filenames '$filename' not supported by server\n";
1873 return undef;
1876 $filename =~ s/^\.\///g;
1877 $filename = $state->{prependdir} . $filename;
1878 return $filename;
1881 package GITCVS::log;
1883 ####
1884 #### Copyright The Open University UK - 2006.
1885 ####
1886 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1887 #### Martin Langhoff <martin@catalyst.net.nz>
1888 ####
1889 ####
1891 use strict;
1892 use warnings;
1894 =head1 NAME
1896 GITCVS::log
1898 =head1 DESCRIPTION
1900 This module provides very crude logging with a similar interface to
1901 Log::Log4perl
1903 =head1 METHODS
1905 =cut
1907 =head2 new
1909 Creates a new log object, optionally you can specify a filename here to
1910 indicate the file to log to. If no log file is specified, you can specify one
1911 later with method setfile, or indicate you no longer want logging with method
1912 nofile.
1914 Until one of these methods is called, all log calls will buffer messages ready
1915 to write out.
1917 =cut
1918 sub new
1920 my $class = shift;
1921 my $filename = shift;
1923 my $self = {};
1925 bless $self, $class;
1927 if ( defined ( $filename ) )
1929 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1932 return $self;
1935 =head2 setfile
1937 This methods takes a filename, and attempts to open that file as the log file.
1938 If successful, all buffered data is written out to the file, and any further
1939 logging is written directly to the file.
1941 =cut
1942 sub setfile
1944 my $self = shift;
1945 my $filename = shift;
1947 if ( defined ( $filename ) )
1949 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1952 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1954 while ( my $line = shift @{$self->{buffer}} )
1956 print {$self->{fh}} $line;
1960 =head2 nofile
1962 This method indicates no logging is going to be used. It flushes any entries in
1963 the internal buffer, and sets a flag to ensure no further data is put there.
1965 =cut
1966 sub nofile
1968 my $self = shift;
1970 $self->{nolog} = 1;
1972 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1974 $self->{buffer} = [];
1977 =head2 _logopen
1979 Internal method. Returns true if the log file is open, false otherwise.
1981 =cut
1982 sub _logopen
1984 my $self = shift;
1986 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1987 return 0;
1990 =head2 debug info warn fatal
1992 These four methods are wrappers to _log. They provide the actual interface for
1993 logging data.
1995 =cut
1996 sub debug { my $self = shift; $self->_log("debug", @_); }
1997 sub info { my $self = shift; $self->_log("info" , @_); }
1998 sub warn { my $self = shift; $self->_log("warn" , @_); }
1999 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2001 =head2 _log
2003 This is an internal method called by the logging functions. It generates a
2004 timestamp and pushes the logged line either to file, or internal buffer.
2006 =cut
2007 sub _log
2009 my $self = shift;
2010 my $level = shift;
2012 return if ( $self->{nolog} );
2014 my @time = localtime;
2015 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2016 $time[5] + 1900,
2017 $time[4] + 1,
2018 $time[3],
2019 $time[2],
2020 $time[1],
2021 $time[0],
2022 uc $level,
2025 if ( $self->_logopen )
2027 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2028 } else {
2029 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2033 =head2 DESTROY
2035 This method simply closes the file handle if one is open
2037 =cut
2038 sub DESTROY
2040 my $self = shift;
2042 if ( $self->_logopen )
2044 close $self->{fh};
2048 package GITCVS::updater;
2050 ####
2051 #### Copyright The Open University UK - 2006.
2052 ####
2053 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2054 #### Martin Langhoff <martin@catalyst.net.nz>
2055 ####
2056 ####
2058 use strict;
2059 use warnings;
2060 use DBI;
2062 =head1 METHODS
2064 =cut
2066 =head2 new
2068 =cut
2069 sub new
2071 my $class = shift;
2072 my $config = shift;
2073 my $module = shift;
2074 my $log = shift;
2076 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2077 die "Need to specify a module" unless ( defined($module) );
2079 $class = ref($class) || $class;
2081 my $self = {};
2083 bless $self, $class;
2085 $self->{dbdir} = $config . "/";
2086 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
2088 $self->{module} = $module;
2089 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
2091 $self->{git_path} = $config . "/";
2093 $self->{log} = $log;
2095 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2097 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
2099 $self->{tables} = {};
2100 foreach my $table ( $self->{dbh}->tables )
2102 $table =~ s/^"//;
2103 $table =~ s/"$//;
2104 $self->{tables}{$table} = 1;
2107 # Construct the revision table if required
2108 unless ( $self->{tables}{revision} )
2110 $self->{dbh}->do("
2111 CREATE TABLE revision (
2112 name TEXT NOT NULL,
2113 revision INTEGER NOT NULL,
2114 filehash TEXT NOT NULL,
2115 commithash TEXT NOT NULL,
2116 author TEXT NOT NULL,
2117 modified TEXT NOT NULL,
2118 mode TEXT NOT NULL
2121 $self->{dbh}->do("
2122 CREATE INDEX revision_ix1
2123 ON revision (name,revision)
2125 $self->{dbh}->do("
2126 CREATE INDEX revision_ix2
2127 ON revision (name,commithash)
2131 # Construct the head table if required
2132 unless ( $self->{tables}{head} )
2134 $self->{dbh}->do("
2135 CREATE TABLE head (
2136 name TEXT NOT NULL,
2137 revision INTEGER NOT NULL,
2138 filehash TEXT NOT NULL,
2139 commithash TEXT NOT NULL,
2140 author TEXT NOT NULL,
2141 modified TEXT NOT NULL,
2142 mode TEXT NOT NULL
2145 $self->{dbh}->do("
2146 CREATE INDEX head_ix1
2147 ON head (name)
2151 # Construct the properties table if required
2152 unless ( $self->{tables}{properties} )
2154 $self->{dbh}->do("
2155 CREATE TABLE properties (
2156 key TEXT NOT NULL PRIMARY KEY,
2157 value TEXT
2162 # Construct the commitmsgs table if required
2163 unless ( $self->{tables}{commitmsgs} )
2165 $self->{dbh}->do("
2166 CREATE TABLE commitmsgs (
2167 key TEXT NOT NULL PRIMARY KEY,
2168 value TEXT
2173 return $self;
2176 =head2 update
2178 =cut
2179 sub update
2181 my $self = shift;
2183 # first lets get the commit list
2184 $ENV{GIT_DIR} = $self->{git_path};
2186 my $commitinfo = `git-cat-file commit $self->{module} 2>&1`;
2187 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2189 die("Invalid module '$self->{module}'");
2193 my $git_log;
2194 my $lastcommit = $self->_get_prop("last_commit");
2196 # Start exclusive lock here...
2197 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2199 # TODO: log processing is memory bound
2200 # if we can parse into a 2nd file that is in reverse order
2201 # we can probably do something really efficient
2202 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2204 if (defined $lastcommit) {
2205 push @git_log_params, "$lastcommit..$self->{module}";
2206 } else {
2207 push @git_log_params, $self->{module};
2209 # git-rev-list is the backend / plumbing version of git-log
2210 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2212 my @commits;
2214 my %commit = ();
2216 while ( <GITLOG> )
2218 chomp;
2219 if (m/^commit\s+(.*)$/) {
2220 # on ^commit lines put the just seen commit in the stack
2221 # and prime things for the next one
2222 if (keys %commit) {
2223 my %copy = %commit;
2224 unshift @commits, \%copy;
2225 %commit = ();
2227 my @parents = split(m/\s+/, $1);
2228 $commit{hash} = shift @parents;
2229 $commit{parents} = \@parents;
2230 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2231 # on rfc822-like lines seen before we see any message,
2232 # lowercase the entry and put it in the hash as key-value
2233 $commit{lc($1)} = $2;
2234 } else {
2235 # message lines - skip initial empty line
2236 # and trim whitespace
2237 if (!exists($commit{message}) && m/^\s*$/) {
2238 # define it to mark the end of headers
2239 $commit{message} = '';
2240 next;
2242 s/^\s+//; s/\s+$//; # trim ws
2243 $commit{message} .= $_ . "\n";
2246 close GITLOG;
2248 unshift @commits, \%commit if ( keys %commit );
2250 # Now all the commits are in the @commits bucket
2251 # ordered by time DESC. for each commit that needs processing,
2252 # determine whether it's following the last head we've seen or if
2253 # it's on its own branch, grab a file list, and add whatever's changed
2254 # NOTE: $lastcommit refers to the last commit from previous run
2255 # $lastpicked is the last commit we picked in this run
2256 my $lastpicked;
2257 my $head = {};
2258 if (defined $lastcommit) {
2259 $lastpicked = $lastcommit;
2262 my $committotal = scalar(@commits);
2263 my $commitcount = 0;
2265 # Load the head table into $head (for cached lookups during the update process)
2266 foreach my $file ( @{$self->gethead()} )
2268 $head->{$file->{name}} = $file;
2271 foreach my $commit ( @commits )
2273 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2274 if (defined $lastpicked)
2276 if (!in_array($lastpicked, @{$commit->{parents}}))
2278 # skip, we'll see this delta
2279 # as part of a merge later
2280 # warn "skipping off-track $commit->{hash}\n";
2281 next;
2282 } elsif (@{$commit->{parents}} > 1) {
2283 # it is a merge commit, for each parent that is
2284 # not $lastpicked, see if we can get a log
2285 # from the merge-base to that parent to put it
2286 # in the message as a merge summary.
2287 my @parents = @{$commit->{parents}};
2288 foreach my $parent (@parents) {
2289 # git-merge-base can potentially (but rarely) throw
2290 # several candidate merge bases. let's assume
2291 # that the first one is the best one.
2292 if ($parent eq $lastpicked) {
2293 next;
2295 open my $p, 'git-merge-base '. $lastpicked . ' '
2296 . $parent . '|';
2297 my @output = (<$p>);
2298 close $p;
2299 my $base = join('', @output);
2300 chomp $base;
2301 if ($base) {
2302 my @merged;
2303 # print "want to log between $base $parent \n";
2304 open(GITLOG, '-|', 'git-log', "$base..$parent")
2305 or die "Cannot call git-log: $!";
2306 my $mergedhash;
2307 while (<GITLOG>) {
2308 chomp;
2309 if (!defined $mergedhash) {
2310 if (m/^commit\s+(.+)$/) {
2311 $mergedhash = $1;
2312 } else {
2313 next;
2315 } else {
2316 # grab the first line that looks non-rfc822
2317 # aka has content after leading space
2318 if (m/^\s+(\S.*)$/) {
2319 my $title = $1;
2320 $title = substr($title,0,100); # truncate
2321 unshift @merged, "$mergedhash $title";
2322 undef $mergedhash;
2326 close GITLOG;
2327 if (@merged) {
2328 $commit->{mergemsg} = $commit->{message};
2329 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2330 foreach my $summary (@merged) {
2331 $commit->{mergemsg} .= "\t$summary\n";
2333 $commit->{mergemsg} .= "\n\n";
2334 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2341 # convert the date to CVS-happy format
2342 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2344 if ( defined ( $lastpicked ) )
2346 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2347 while ( <FILELIST> )
2349 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)\s+(.*)$/o )
2351 die("Couldn't process git-diff-tree line : $_");
2354 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2356 my $git_perms = "";
2357 $git_perms .= "r" if ( $1 & 4 );
2358 $git_perms .= "w" if ( $1 & 2 );
2359 $git_perms .= "x" if ( $1 & 1 );
2360 $git_perms = "rw" if ( $git_perms eq "" );
2362 if ( $3 eq "D" )
2364 #$log->debug("DELETE $4");
2365 $head->{$4} = {
2366 name => $4,
2367 revision => $head->{$4}{revision} + 1,
2368 filehash => "deleted",
2369 commithash => $commit->{hash},
2370 modified => $commit->{date},
2371 author => $commit->{author},
2372 mode => $git_perms,
2374 $self->insert_rev($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2376 elsif ( $3 eq "M" )
2378 #$log->debug("MODIFIED $4");
2379 $head->{$4} = {
2380 name => $4,
2381 revision => $head->{$4}{revision} + 1,
2382 filehash => $2,
2383 commithash => $commit->{hash},
2384 modified => $commit->{date},
2385 author => $commit->{author},
2386 mode => $git_perms,
2388 $self->insert_rev($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2390 elsif ( $3 eq "A" )
2392 #$log->debug("ADDED $4");
2393 $head->{$4} = {
2394 name => $4,
2395 revision => 1,
2396 filehash => $2,
2397 commithash => $commit->{hash},
2398 modified => $commit->{date},
2399 author => $commit->{author},
2400 mode => $git_perms,
2402 $self->insert_rev($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2404 else
2406 $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
2407 die;
2410 close FILELIST;
2411 } else {
2412 # this is used to detect files removed from the repo
2413 my $seen_files = {};
2415 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2416 while ( <FILELIST> )
2418 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2420 die("Couldn't process git-ls-tree line : $_");
2423 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2425 $seen_files->{$git_filename} = 1;
2427 my ( $oldhash, $oldrevision, $oldmode ) = (
2428 $head->{$git_filename}{filehash},
2429 $head->{$git_filename}{revision},
2430 $head->{$git_filename}{mode}
2433 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2435 $git_perms = "";
2436 $git_perms .= "r" if ( $1 & 4 );
2437 $git_perms .= "w" if ( $1 & 2 );
2438 $git_perms .= "x" if ( $1 & 1 );
2439 } else {
2440 $git_perms = "rw";
2443 # unless the file exists with the same hash, we need to update it ...
2444 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2446 my $newrevision = ( $oldrevision or 0 ) + 1;
2448 $head->{$git_filename} = {
2449 name => $git_filename,
2450 revision => $newrevision,
2451 filehash => $git_hash,
2452 commithash => $commit->{hash},
2453 modified => $commit->{date},
2454 author => $commit->{author},
2455 mode => $git_perms,
2459 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2462 close FILELIST;
2464 # Detect deleted files
2465 foreach my $file ( keys %$head )
2467 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2469 $head->{$file}{revision}++;
2470 $head->{$file}{filehash} = "deleted";
2471 $head->{$file}{commithash} = $commit->{hash};
2472 $head->{$file}{modified} = $commit->{date};
2473 $head->{$file}{author} = $commit->{author};
2475 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2478 # END : "Detect deleted files"
2482 if (exists $commit->{mergemsg})
2484 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2487 $lastpicked = $commit->{hash};
2489 $self->_set_prop("last_commit", $commit->{hash});
2492 $self->delete_head();
2493 foreach my $file ( keys %$head )
2495 $self->insert_head(
2496 $file,
2497 $head->{$file}{revision},
2498 $head->{$file}{filehash},
2499 $head->{$file}{commithash},
2500 $head->{$file}{modified},
2501 $head->{$file}{author},
2502 $head->{$file}{mode},
2505 # invalidate the gethead cache
2506 $self->{gethead_cache} = undef;
2509 # Ending exclusive lock here
2510 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2513 sub insert_rev
2515 my $self = shift;
2516 my $name = shift;
2517 my $revision = shift;
2518 my $filehash = shift;
2519 my $commithash = shift;
2520 my $modified = shift;
2521 my $author = shift;
2522 my $mode = shift;
2524 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2525 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2528 sub insert_mergelog
2530 my $self = shift;
2531 my $key = shift;
2532 my $value = shift;
2534 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2535 $insert_mergelog->execute($key, $value);
2538 sub delete_head
2540 my $self = shift;
2542 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2543 $delete_head->execute();
2546 sub insert_head
2548 my $self = shift;
2549 my $name = shift;
2550 my $revision = shift;
2551 my $filehash = shift;
2552 my $commithash = shift;
2553 my $modified = shift;
2554 my $author = shift;
2555 my $mode = shift;
2557 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2558 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2561 sub _headrev
2563 my $self = shift;
2564 my $filename = shift;
2566 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2567 $db_query->execute($filename);
2568 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2570 return ( $hash, $revision, $mode );
2573 sub _get_prop
2575 my $self = shift;
2576 my $key = shift;
2578 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2579 $db_query->execute($key);
2580 my ( $value ) = $db_query->fetchrow_array;
2582 return $value;
2585 sub _set_prop
2587 my $self = shift;
2588 my $key = shift;
2589 my $value = shift;
2591 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2592 $db_query->execute($value, $key);
2594 unless ( $db_query->rows )
2596 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2597 $db_query->execute($key, $value);
2600 return $value;
2603 =head2 gethead
2605 =cut
2607 sub gethead
2609 my $self = shift;
2611 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2613 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2614 $db_query->execute();
2616 my $tree = [];
2617 while ( my $file = $db_query->fetchrow_hashref )
2619 push @$tree, $file;
2622 $self->{gethead_cache} = $tree;
2624 return $tree;
2627 =head2 getlog
2629 =cut
2631 sub getlog
2633 my $self = shift;
2634 my $filename = shift;
2636 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2637 $db_query->execute($filename);
2639 my $tree = [];
2640 while ( my $file = $db_query->fetchrow_hashref )
2642 push @$tree, $file;
2645 return $tree;
2648 =head2 getmeta
2650 This function takes a filename (with path) argument and returns a hashref of
2651 metadata for that file.
2653 =cut
2655 sub getmeta
2657 my $self = shift;
2658 my $filename = shift;
2659 my $revision = shift;
2661 my $db_query;
2662 if ( defined($revision) and $revision =~ /^\d+$/ )
2664 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2665 $db_query->execute($filename, $revision);
2667 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2669 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2670 $db_query->execute($filename, $revision);
2671 } else {
2672 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2673 $db_query->execute($filename);
2676 return $db_query->fetchrow_hashref;
2679 =head2 commitmessage
2681 this function takes a commithash and returns the commit message for that commit
2683 =cut
2684 sub commitmessage
2686 my $self = shift;
2687 my $commithash = shift;
2689 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2691 my $db_query;
2692 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2693 $db_query->execute($commithash);
2695 my ( $message ) = $db_query->fetchrow_array;
2697 if ( defined ( $message ) )
2699 $message .= " " if ( $message =~ /\n$/ );
2700 return $message;
2703 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2704 shift @lines while ( $lines[0] =~ /\S/ );
2705 $message = join("",@lines);
2706 $message .= " " if ( $message =~ /\n$/ );
2707 return $message;
2710 =head2 gethistory
2712 This function takes a filename (with path) argument and returns an arrayofarrays
2713 containing revision,filehash,commithash ordered by revision descending
2715 =cut
2716 sub gethistory
2718 my $self = shift;
2719 my $filename = shift;
2721 my $db_query;
2722 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2723 $db_query->execute($filename);
2725 return $db_query->fetchall_arrayref;
2728 =head2 gethistorydense
2730 This function takes a filename (with path) argument and returns an arrayofarrays
2731 containing revision,filehash,commithash ordered by revision descending.
2733 This version of gethistory skips deleted entries -- so it is useful for annotate.
2734 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2735 and other git tools that depend on it.
2737 =cut
2738 sub gethistorydense
2740 my $self = shift;
2741 my $filename = shift;
2743 my $db_query;
2744 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2745 $db_query->execute($filename);
2747 return $db_query->fetchall_arrayref;
2750 =head2 in_array()
2752 from Array::PAT - mimics the in_array() function
2753 found in PHP. Yuck but works for small arrays.
2755 =cut
2756 sub in_array
2758 my ($check, @array) = @_;
2759 my $retval = 0;
2760 foreach my $test (@array){
2761 if($check eq $test){
2762 $retval = 1;
2765 return $retval;
2768 =head2 safe_pipe_capture
2770 an alternative to `command` that allows input to be passed as an array
2771 to work around shell problems with weird characters in arguments
2773 =cut
2774 sub safe_pipe_capture {
2776 my @output;
2778 if (my $pid = open my $child, '-|') {
2779 @output = (<$child>);
2780 close $child or die join(' ',@_).": $! $?";
2781 } else {
2782 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2784 return wantarray ? @output : join('',@output);