Merge branch 'maint'
[git/jnareb-git.git] / git-cvsserver.perl
blob84520e7ad5c1745b14db2206189bb7d54c17dcc8
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::Basename;
26 my $log = GITCVS::log->new();
27 my $cfg;
29 my $DATE_LIST = {
30 Jan => "01",
31 Feb => "02",
32 Mar => "03",
33 Apr => "04",
34 May => "05",
35 Jun => "06",
36 Jul => "07",
37 Aug => "08",
38 Sep => "09",
39 Oct => "10",
40 Nov => "11",
41 Dec => "12",
44 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
45 $| = 1;
47 #### Definition and mappings of functions ####
49 my $methods = {
50 'Root' => \&req_Root,
51 'Valid-responses' => \&req_Validresponses,
52 'valid-requests' => \&req_validrequests,
53 'Directory' => \&req_Directory,
54 'Entry' => \&req_Entry,
55 'Modified' => \&req_Modified,
56 'Unchanged' => \&req_Unchanged,
57 'Questionable' => \&req_Questionable,
58 'Argument' => \&req_Argument,
59 'Argumentx' => \&req_Argument,
60 'expand-modules' => \&req_expandmodules,
61 'add' => \&req_add,
62 'remove' => \&req_remove,
63 'co' => \&req_co,
64 'update' => \&req_update,
65 'ci' => \&req_ci,
66 'diff' => \&req_diff,
67 'log' => \&req_log,
68 'rlog' => \&req_log,
69 'tag' => \&req_CATCHALL,
70 'status' => \&req_status,
71 'admin' => \&req_CATCHALL,
72 'history' => \&req_CATCHALL,
73 'watchers' => \&req_CATCHALL,
74 'editors' => \&req_CATCHALL,
75 'annotate' => \&req_annotate,
76 'Global_option' => \&req_Globaloption,
77 #'annotate' => \&req_CATCHALL,
80 ##############################################
83 # $state holds all the bits of information the clients sends us that could
84 # potentially be useful when it comes to actually _doing_ something.
85 my $state = { prependdir => '' };
86 $log->info("--------------- STARTING -----------------");
88 my $TEMP_DIR = tempdir( CLEANUP => 1 );
89 $log->debug("Temporary directory is '$TEMP_DIR'");
91 # if we are called with a pserver argument,
92 # deal with the authentication cat before entering the
93 # main loop
94 if (@ARGV && $ARGV[0] eq 'pserver') {
95 my $line = <STDIN>; chomp $line;
96 unless( $line eq 'BEGIN AUTH REQUEST') {
97 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
99 $line = <STDIN>; chomp $line;
100 req_Root('root', $line) # reuse Root
101 or die "E Invalid root $line \n";
102 $line = <STDIN>; chomp $line;
103 unless ($line eq 'anonymous') {
104 print "E Only anonymous user allowed via pserver\n";
105 print "I HATE YOU\n";
107 $line = <STDIN>; chomp $line; # validate the password?
108 $line = <STDIN>; chomp $line;
109 unless ($line eq 'END AUTH REQUEST') {
110 die "E Do not understand $line -- expecting END AUTH REQUEST\n";
112 print "I LOVE YOU\n";
113 # and now back to our regular programme...
116 # Keep going until the client closes the connection
117 while (<STDIN>)
119 chomp;
121 # Check to see if we've seen this method, and call appropriate function.
122 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
124 # use the $methods hash to call the appropriate sub for this command
125 #$log->info("Method : $1");
126 &{$methods->{$1}}($1,$2);
127 } else {
128 # log fatal because we don't understand this function. If this happens
129 # we're fairly screwed because we don't know if the client is expecting
130 # a response. If it is, the client will hang, we'll hang, and the whole
131 # thing will be custard.
132 $log->fatal("Don't understand command $_\n");
133 die("Unknown command $_");
137 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
138 $log->info("--------------- FINISH -----------------");
140 # Magic catchall method.
141 # This is the method that will handle all commands we haven't yet
142 # implemented. It simply sends a warning to the log file indicating a
143 # command that hasn't been implemented has been invoked.
144 sub req_CATCHALL
146 my ( $cmd, $data ) = @_;
147 $log->warn("Unhandled command : req_$cmd : $data");
151 # Root pathname \n
152 # Response expected: no. Tell the server which CVSROOT to use. Note that
153 # pathname is a local directory and not a fully qualified CVSROOT variable.
154 # pathname must already exist; if creating a new root, use the init
155 # request, not Root. pathname does not include the hostname of the server,
156 # how to access the server, etc.; by the time the CVS protocol is in use,
157 # connection, authentication, etc., are already taken care of. The Root
158 # request must be sent only once, and it must be sent before any requests
159 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
160 sub req_Root
162 my ( $cmd, $data ) = @_;
163 $log->debug("req_Root : $data");
165 $state->{CVSROOT} = $data;
167 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
168 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
169 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
170 print "E \n";
171 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
172 return 0;
175 my @gitvars = `git-config -l`;
176 if ($?) {
177 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
178 print "E \n";
179 print "error 1 - problem executing git-config\n";
180 return 0;
182 foreach my $line ( @gitvars )
184 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
185 $cfg->{$1}{$2} = $3;
188 unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
190 print "E GITCVS emulation needs to be enabled on this repo\n";
191 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
192 print "E \n";
193 print "error 1 GITCVS emulation disabled\n";
194 return 0;
197 if ( defined ( $cfg->{gitcvs}{logfile} ) )
199 $log->setfile($cfg->{gitcvs}{logfile});
200 } else {
201 $log->nofile();
204 return 1;
207 # Global_option option \n
208 # Response expected: no. Transmit one of the global options `-q', `-Q',
209 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
210 # variations (such as combining of options) are allowed. For graceful
211 # handling of valid-requests, it is probably better to make new global
212 # options separate requests, rather than trying to add them to this
213 # request.
214 sub req_Globaloption
216 my ( $cmd, $data ) = @_;
217 $log->debug("req_Globaloption : $data");
218 $state->{globaloptions}{$data} = 1;
221 # Valid-responses request-list \n
222 # Response expected: no. Tell the server what responses the client will
223 # accept. request-list is a space separated list of tokens.
224 sub req_Validresponses
226 my ( $cmd, $data ) = @_;
227 $log->debug("req_Validresponses : $data");
229 # TODO : re-enable this, currently it's not particularly useful
230 #$state->{validresponses} = [ split /\s+/, $data ];
233 # valid-requests \n
234 # Response expected: yes. Ask the server to send back a Valid-requests
235 # response.
236 sub req_validrequests
238 my ( $cmd, $data ) = @_;
240 $log->debug("req_validrequests");
242 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
243 $log->debug("SEND : ok");
245 print "Valid-requests " . join(" ",keys %$methods) . "\n";
246 print "ok\n";
249 # Directory local-directory \n
250 # Additional data: repository \n. Response expected: no. Tell the server
251 # what directory to use. The repository should be a directory name from a
252 # previous server response. Note that this both gives a default for Entry
253 # and Modified and also for ci and the other commands; normal usage is to
254 # send Directory for each directory in which there will be an Entry or
255 # Modified, and then a final Directory for the original directory, then the
256 # command. The local-directory is relative to the top level at which the
257 # command is occurring (i.e. the last Directory which is sent before the
258 # command); to indicate that top level, `.' should be sent for
259 # local-directory.
260 sub req_Directory
262 my ( $cmd, $data ) = @_;
264 my $repository = <STDIN>;
265 chomp $repository;
268 $state->{localdir} = $data;
269 $state->{repository} = $repository;
270 $state->{path} = $repository;
271 $state->{path} =~ s/^$state->{CVSROOT}\///;
272 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
273 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
275 $state->{directory} = $state->{localdir};
276 $state->{directory} = "" if ( $state->{directory} eq "." );
277 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
279 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
281 $log->info("Setting prepend to '$state->{path}'");
282 $state->{prependdir} = $state->{path};
283 foreach my $entry ( keys %{$state->{entries}} )
285 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
286 delete $state->{entries}{$entry};
290 if ( defined ( $state->{prependdir} ) )
292 $log->debug("Prepending '$state->{prependdir}' to state|directory");
293 $state->{directory} = $state->{prependdir} . $state->{directory}
295 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
298 # Entry entry-line \n
299 # Response expected: no. Tell the server what version of a file is on the
300 # local machine. The name in entry-line is a name relative to the directory
301 # most recently specified with Directory. If the user is operating on only
302 # some files in a directory, Entry requests for only those files need be
303 # included. If an Entry request is sent without Modified, Is-modified, or
304 # Unchanged, it means the file is lost (does not exist in the working
305 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
306 # are sent for the same file, Entry must be sent first. For a given file,
307 # one can send Modified, Is-modified, or Unchanged, but not more than one
308 # of these three.
309 sub req_Entry
311 my ( $cmd, $data ) = @_;
313 #$log->debug("req_Entry : $data");
315 my @data = split(/\//, $data);
317 $state->{entries}{$state->{directory}.$data[1]} = {
318 revision => $data[2],
319 conflict => $data[3],
320 options => $data[4],
321 tag_or_date => $data[5],
324 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
327 # Questionable filename \n
328 # Response expected: no. Additional data: no. Tell the server to check
329 # whether filename should be ignored, and if not, next time the server
330 # sends responses, send (in a M response) `?' followed by the directory and
331 # filename. filename must not contain `/'; it needs to be a file in the
332 # directory named by the most recent Directory request.
333 sub req_Questionable
335 my ( $cmd, $data ) = @_;
337 $log->debug("req_Questionable : $data");
338 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
341 # add \n
342 # Response expected: yes. Add a file or directory. This uses any previous
343 # Argument, Directory, Entry, or Modified requests, if they have been sent.
344 # The last Directory sent specifies the working directory at the time of
345 # the operation. To add a directory, send the directory to be added using
346 # Directory and Argument requests.
347 sub req_add
349 my ( $cmd, $data ) = @_;
351 argsplit("add");
353 my $addcount = 0;
355 foreach my $filename ( @{$state->{args}} )
357 $filename = filecleanup($filename);
359 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
361 print "E cvs add: nothing known about `$filename'\n";
362 next;
364 # TODO : check we're not squashing an already existing file
365 if ( defined ( $state->{entries}{$filename}{revision} ) )
367 print "E cvs add: `$filename' has already been entered\n";
368 next;
371 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
373 print "E cvs add: scheduling file `$filename' for addition\n";
375 print "Checked-in $dirpart\n";
376 print "$filename\n";
377 print "/$filepart/0///\n";
379 $addcount++;
382 if ( $addcount == 1 )
384 print "E cvs add: use `cvs commit' to add this file permanently\n";
386 elsif ( $addcount > 1 )
388 print "E cvs add: use `cvs commit' to add these files permanently\n";
391 print "ok\n";
394 # remove \n
395 # Response expected: yes. Remove a file. This uses any previous Argument,
396 # Directory, Entry, or Modified requests, if they have been sent. The last
397 # Directory sent specifies the working directory at the time of the
398 # operation. Note that this request does not actually do anything to the
399 # repository; the only effect of a successful remove request is to supply
400 # the client with a new entries line containing `-' to indicate a removed
401 # file. In fact, the client probably could perform this operation without
402 # contacting the server, although using remove may cause the server to
403 # perform a few more checks. The client sends a subsequent ci request to
404 # actually record the removal in the repository.
405 sub req_remove
407 my ( $cmd, $data ) = @_;
409 argsplit("remove");
411 # Grab a handle to the SQLite db and do any necessary updates
412 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
413 $updater->update();
415 #$log->debug("add state : " . Dumper($state));
417 my $rmcount = 0;
419 foreach my $filename ( @{$state->{args}} )
421 $filename = filecleanup($filename);
423 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
425 print "E cvs remove: file `$filename' still in working directory\n";
426 next;
429 my $meta = $updater->getmeta($filename);
430 my $wrev = revparse($filename);
432 unless ( defined ( $wrev ) )
434 print "E cvs remove: nothing known about `$filename'\n";
435 next;
438 if ( defined($wrev) and $wrev < 0 )
440 print "E cvs remove: file `$filename' already scheduled for removal\n";
441 next;
444 unless ( $wrev == $meta->{revision} )
446 # TODO : not sure if the format of this message is quite correct.
447 print "E cvs remove: Up to date check failed for `$filename'\n";
448 next;
452 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
454 print "E cvs remove: scheduling `$filename' for removal\n";
456 print "Checked-in $dirpart\n";
457 print "$filename\n";
458 print "/$filepart/-1.$wrev///\n";
460 $rmcount++;
463 if ( $rmcount == 1 )
465 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
467 elsif ( $rmcount > 1 )
469 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
472 print "ok\n";
475 # Modified filename \n
476 # Response expected: no. Additional data: mode, \n, file transmission. Send
477 # the server a copy of one locally modified file. filename is a file within
478 # the most recent directory sent with Directory; it must not contain `/'.
479 # If the user is operating on only some files in a directory, only those
480 # files need to be included. This can also be sent without Entry, if there
481 # is no entry for the file.
482 sub req_Modified
484 my ( $cmd, $data ) = @_;
486 my $mode = <STDIN>;
487 chomp $mode;
488 my $size = <STDIN>;
489 chomp $size;
491 # Grab config information
492 my $blocksize = 8192;
493 my $bytesleft = $size;
494 my $tmp;
496 # Get a filehandle/name to write it to
497 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
499 # Loop over file data writing out to temporary file.
500 while ( $bytesleft )
502 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
503 read STDIN, $tmp, $blocksize;
504 print $fh $tmp;
505 $bytesleft -= $blocksize;
508 close $fh;
510 # Ensure we have something sensible for the file mode
511 if ( $mode =~ /u=(\w+)/ )
513 $mode = $1;
514 } else {
515 $mode = "rw";
518 # Save the file data in $state
519 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
520 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
521 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
522 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
524 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
527 # Unchanged filename \n
528 # Response expected: no. Tell the server that filename has not been
529 # modified in the checked out directory. The filename is a file within the
530 # most recent directory sent with Directory; it must not contain `/'.
531 sub req_Unchanged
533 my ( $cmd, $data ) = @_;
535 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
537 #$log->debug("req_Unchanged : $data");
540 # Argument text \n
541 # Response expected: no. Save argument for use in a subsequent command.
542 # Arguments accumulate until an argument-using command is given, at which
543 # point they are forgotten.
544 # Argumentx text \n
545 # Response expected: no. Append \n followed by text to the current argument
546 # being saved.
547 sub req_Argument
549 my ( $cmd, $data ) = @_;
551 # Argumentx means: append to last Argument (with a newline in front)
553 $log->debug("$cmd : $data");
555 if ( $cmd eq 'Argumentx') {
556 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
557 } else {
558 push @{$state->{arguments}}, $data;
562 # expand-modules \n
563 # Response expected: yes. Expand the modules which are specified in the
564 # arguments. Returns the data in Module-expansion responses. Note that the
565 # server can assume that this is checkout or export, not rtag or rdiff; the
566 # latter do not access the working directory and thus have no need to
567 # expand modules on the client side. Expand may not be the best word for
568 # what this request does. It does not necessarily tell you all the files
569 # contained in a module, for example. Basically it is a way of telling you
570 # which working directories the server needs to know about in order to
571 # handle a checkout of the specified modules. For example, suppose that the
572 # server has a module defined by
573 # aliasmodule -a 1dir
574 # That is, one can check out aliasmodule and it will take 1dir in the
575 # repository and check it out to 1dir in the working directory. Now suppose
576 # the client already has this module checked out and is planning on using
577 # the co request to update it. Without using expand-modules, the client
578 # would have two bad choices: it could either send information about all
579 # working directories under the current directory, which could be
580 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
581 # stands for 1dir, and neglect to send information for 1dir, which would
582 # lead to incorrect operation. With expand-modules, the client would first
583 # ask for the module to be expanded:
584 sub req_expandmodules
586 my ( $cmd, $data ) = @_;
588 argsplit();
590 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
592 unless ( ref $state->{arguments} eq "ARRAY" )
594 print "ok\n";
595 return;
598 foreach my $module ( @{$state->{arguments}} )
600 $log->debug("SEND : Module-expansion $module");
601 print "Module-expansion $module\n";
604 print "ok\n";
605 statecleanup();
608 # co \n
609 # Response expected: yes. Get files from the repository. This uses any
610 # previous Argument, Directory, Entry, or Modified requests, if they have
611 # been sent. Arguments to this command are module names; the client cannot
612 # know what directories they correspond to except by (1) just sending the
613 # co request, and then seeing what directory names the server sends back in
614 # its responses, and (2) the expand-modules request.
615 sub req_co
617 my ( $cmd, $data ) = @_;
619 argsplit("co");
621 my $module = $state->{args}[0];
622 my $checkout_path = $module;
624 # use the user specified directory if we're given it
625 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
627 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
629 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
631 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
633 # Grab a handle to the SQLite db and do any necessary updates
634 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
635 $updater->update();
637 $checkout_path =~ s|/$||; # get rid of trailing slashes
639 # Eclipse seems to need the Clear-sticky command
640 # to prepare the 'Entries' file for the new directory.
641 print "Clear-sticky $checkout_path/\n";
642 print $state->{CVSROOT} . "/$module/\n";
643 print "Clear-static-directory $checkout_path/\n";
644 print $state->{CVSROOT} . "/$module/\n";
645 print "Clear-sticky $checkout_path/\n"; # yes, twice
646 print $state->{CVSROOT} . "/$module/\n";
647 print "Template $checkout_path/\n";
648 print $state->{CVSROOT} . "/$module/\n";
649 print "0\n";
651 # instruct the client that we're checking out to $checkout_path
652 print "E cvs checkout: Updating $checkout_path\n";
654 my %seendirs = ();
655 my $lastdir ='';
657 # recursive
658 sub prepdir {
659 my ($dir, $repodir, $remotedir, $seendirs) = @_;
660 my $parent = dirname($dir);
661 $dir =~ s|/+$||;
662 $repodir =~ s|/+$||;
663 $remotedir =~ s|/+$||;
664 $parent =~ s|/+$||;
665 $log->debug("announcedir $dir, $repodir, $remotedir" );
667 if ($parent eq '.' || $parent eq './') {
668 $parent = '';
670 # recurse to announce unseen parents first
671 if (length($parent) && !exists($seendirs->{$parent})) {
672 prepdir($parent, $repodir, $remotedir, $seendirs);
674 # Announce that we are going to modify at the parent level
675 if ($parent) {
676 print "E cvs checkout: Updating $remotedir/$parent\n";
677 } else {
678 print "E cvs checkout: Updating $remotedir\n";
680 print "Clear-sticky $remotedir/$parent/\n";
681 print "$repodir/$parent/\n";
683 print "Clear-static-directory $remotedir/$dir/\n";
684 print "$repodir/$dir/\n";
685 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
686 print "$repodir/$parent/\n";
687 print "Template $remotedir/$dir/\n";
688 print "$repodir/$dir/\n";
689 print "0\n";
691 $seendirs->{$dir} = 1;
694 foreach my $git ( @{$updater->gethead} )
696 # Don't want to check out deleted files
697 next if ( $git->{filehash} eq "deleted" );
699 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
701 if (length($git->{dir}) && $git->{dir} ne './'
702 && $git->{dir} ne $lastdir ) {
703 unless (exists($seendirs{$git->{dir}})) {
704 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
705 $checkout_path, \%seendirs);
706 $lastdir = $git->{dir};
707 $seendirs{$git->{dir}} = 1;
709 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
712 # modification time of this file
713 print "Mod-time $git->{modified}\n";
715 # print some information to the client
716 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
718 print "M U $checkout_path/$git->{dir}$git->{name}\n";
719 } else {
720 print "M U $checkout_path/$git->{name}\n";
723 # instruct client we're sending a file to put in this path
724 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
726 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
728 # this is an "entries" line
729 print "/$git->{name}/1.$git->{revision}///\n";
730 # permissions
731 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
733 # transmit file
734 transmitfile($git->{filehash});
737 print "ok\n";
739 statecleanup();
742 # update \n
743 # Response expected: yes. Actually do a cvs update command. This uses any
744 # previous Argument, Directory, Entry, or Modified requests, if they have
745 # been sent. The last Directory sent specifies the working directory at the
746 # time of the operation. The -I option is not used--files which the client
747 # can decide whether to ignore are not mentioned and the client sends the
748 # Questionable request for others.
749 sub req_update
751 my ( $cmd, $data ) = @_;
753 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
755 argsplit("update");
758 # It may just be a client exploring the available heads/modules
759 # in that case, list them as top level directories and leave it
760 # at that. Eclipse uses this technique to offer you a list of
761 # projects (heads in this case) to checkout.
763 if ($state->{module} eq '') {
764 print "E cvs update: Updating .\n";
765 opendir HEADS, $state->{CVSROOT} . '/refs/heads';
766 while (my $head = readdir(HEADS)) {
767 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
768 print "E cvs update: New directory `$head'\n";
771 closedir HEADS;
772 print "ok\n";
773 return 1;
777 # Grab a handle to the SQLite db and do any necessary updates
778 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
780 $updater->update();
782 argsfromdir($updater);
784 #$log->debug("update state : " . Dumper($state));
786 # foreach file specified on the command line ...
787 foreach my $filename ( @{$state->{args}} )
789 $filename = filecleanup($filename);
791 $log->debug("Processing file $filename");
793 # if we have a -C we should pretend we never saw modified stuff
794 if ( exists ( $state->{opt}{C} ) )
796 delete $state->{entries}{$filename}{modified_hash};
797 delete $state->{entries}{$filename}{modified_filename};
798 $state->{entries}{$filename}{unchanged} = 1;
801 my $meta;
802 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
804 $meta = $updater->getmeta($filename, $1);
805 } else {
806 $meta = $updater->getmeta($filename);
809 if ( ! defined $meta )
811 $meta = {
812 name => $filename,
813 revision => 0,
814 filehash => 'added'
818 my $oldmeta = $meta;
820 my $wrev = revparse($filename);
822 # If the working copy is an old revision, lets get that version too for comparison.
823 if ( defined($wrev) and $wrev != $meta->{revision} )
825 $oldmeta = $updater->getmeta($filename, $wrev);
828 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
830 # Files are up to date if the working copy and repo copy have the same revision,
831 # and the working copy is unmodified _and_ the user hasn't specified -C
832 next if ( defined ( $wrev )
833 and defined($meta->{revision})
834 and $wrev == $meta->{revision}
835 and $state->{entries}{$filename}{unchanged}
836 and not exists ( $state->{opt}{C} ) );
838 # If the working copy and repo copy have the same revision,
839 # but the working copy is modified, tell the client it's modified
840 if ( defined ( $wrev )
841 and defined($meta->{revision})
842 and $wrev == $meta->{revision}
843 and not exists ( $state->{opt}{C} ) )
845 $log->info("Tell the client the file is modified");
846 print "MT text M \n";
847 print "MT fname $filename\n";
848 print "MT newline\n";
849 next;
852 if ( $meta->{filehash} eq "deleted" )
854 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
856 $log->info("Removing '$filename' from working copy (no longer in the repo)");
858 print "E cvs update: `$filename' is no longer in the repository\n";
859 # Don't want to actually _DO_ the update if -n specified
860 unless ( $state->{globaloptions}{-n} ) {
861 print "Removed $dirpart\n";
862 print "$filepart\n";
865 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
866 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
867 or $meta->{filehash} eq 'added' )
869 # normal update, just send the new revision (either U=Update,
870 # or A=Add, or R=Remove)
871 if ( defined($wrev) && $wrev < 0 )
873 $log->info("Tell the client the file is scheduled for removal");
874 print "MT text R \n";
875 print "MT fname $filename\n";
876 print "MT newline\n";
877 next;
879 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
881 $log->info("Tell the client the file is scheduled for addition");
882 print "MT text A \n";
883 print "MT fname $filename\n";
884 print "MT newline\n";
885 next;
888 else {
889 $log->info("Updating '$filename' to ".$meta->{revision});
890 print "MT +updated\n";
891 print "MT text U \n";
892 print "MT fname $filename\n";
893 print "MT newline\n";
894 print "MT -updated\n";
897 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
899 # Don't want to actually _DO_ the update if -n specified
900 unless ( $state->{globaloptions}{-n} )
902 if ( defined ( $wrev ) )
904 # instruct client we're sending a file to put in this path as a replacement
905 print "Update-existing $dirpart\n";
906 $log->debug("Updating existing file 'Update-existing $dirpart'");
907 } else {
908 # instruct client we're sending a file to put in this path as a new file
909 print "Clear-static-directory $dirpart\n";
910 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
911 print "Clear-sticky $dirpart\n";
912 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
914 $log->debug("Creating new file 'Created $dirpart'");
915 print "Created $dirpart\n";
917 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
919 # this is an "entries" line
920 $log->debug("/$filepart/1.$meta->{revision}///");
921 print "/$filepart/1.$meta->{revision}///\n";
923 # permissions
924 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
925 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
927 # transmit file
928 transmitfile($meta->{filehash});
930 } else {
931 $log->info("Updating '$filename'");
932 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
934 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
936 chdir $dir;
937 my $file_local = $filepart . ".mine";
938 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
939 my $file_old = $filepart . "." . $oldmeta->{revision};
940 transmitfile($oldmeta->{filehash}, $file_old);
941 my $file_new = $filepart . "." . $meta->{revision};
942 transmitfile($meta->{filehash}, $file_new);
944 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
945 $log->info("Merging $file_local, $file_old, $file_new");
947 $log->debug("Temporary directory for merge is $dir");
949 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
950 $return >>= 8;
952 if ( $return == 0 )
954 $log->info("Merged successfully");
955 print "M M $filename\n";
956 $log->debug("Update-existing $dirpart");
958 # Don't want to actually _DO_ the update if -n specified
959 unless ( $state->{globaloptions}{-n} )
961 print "Update-existing $dirpart\n";
962 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
963 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
964 $log->debug("/$filepart/1.$meta->{revision}///");
965 print "/$filepart/1.$meta->{revision}///\n";
968 elsif ( $return == 1 )
970 $log->info("Merged with conflicts");
971 print "M C $filename\n";
973 # Don't want to actually _DO_ the update if -n specified
974 unless ( $state->{globaloptions}{-n} )
976 print "Update-existing $dirpart\n";
977 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
978 print "/$filepart/1.$meta->{revision}/+//\n";
981 else
983 $log->warn("Merge failed");
984 next;
987 # Don't want to actually _DO_ the update if -n specified
988 unless ( $state->{globaloptions}{-n} )
990 # permissions
991 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
992 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
994 # transmit file, format is single integer on a line by itself (file
995 # size) followed by the file contents
996 # TODO : we should copy files in blocks
997 my $data = `cat $file_local`;
998 $log->debug("File size : " . length($data));
999 print length($data) . "\n";
1000 print $data;
1003 chdir "/";
1008 print "ok\n";
1011 sub req_ci
1013 my ( $cmd, $data ) = @_;
1015 argsplit("ci");
1017 #$log->debug("State : " . Dumper($state));
1019 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1021 if ( @ARGV && $ARGV[0] eq 'pserver')
1023 print "error 1 pserver access cannot commit\n";
1024 exit;
1027 if ( -e $state->{CVSROOT} . "/index" )
1029 $log->warn("file 'index' already exists in the git repository");
1030 print "error 1 Index already exists in git repo\n";
1031 exit;
1034 my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
1035 unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
1037 $log->warn("lockfile '$lockfile' already exists, please try again");
1038 print "error 1 Lock file '$lockfile' already exists, please try again\n";
1039 exit;
1042 # Grab a handle to the SQLite db and do any necessary updates
1043 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1044 $updater->update();
1046 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1047 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1048 $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
1050 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1051 $ENV{GIT_INDEX_FILE} = $file_index;
1053 chdir $tmpdir;
1055 # populate the temporary index based
1056 system("git-read-tree", $state->{module});
1057 unless ($? == 0)
1059 die "Error running git-read-tree $state->{module} $file_index $!";
1061 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1064 my @committedfiles = ();
1066 # foreach file specified on the command line ...
1067 foreach my $filename ( @{$state->{args}} )
1069 my $committedfile = $filename;
1070 $filename = filecleanup($filename);
1072 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1074 my $meta = $updater->getmeta($filename);
1076 my $wrev = revparse($filename);
1078 my ( $filepart, $dirpart ) = filenamesplit($filename);
1080 # do a checkout of the file if it part of this tree
1081 if ($wrev) {
1082 system('git-checkout-index', '-f', '-u', $filename);
1083 unless ($? == 0) {
1084 die "Error running git-checkout-index -f -u $filename : $!";
1088 my $addflag = 0;
1089 my $rmflag = 0;
1090 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1091 $addflag = 1 unless ( -e $filename );
1093 # Do up to date checking
1094 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1096 # fail everything if an up to date check fails
1097 print "error 1 Up to date check failed for $filename\n";
1098 close LOCKFILE;
1099 unlink($lockfile);
1100 chdir "/";
1101 exit;
1104 push @committedfiles, $committedfile;
1105 $log->info("Committing $filename");
1107 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1109 unless ( $rmflag )
1111 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1112 rename $state->{entries}{$filename}{modified_filename},$filename;
1114 # Calculate modes to remove
1115 my $invmode = "";
1116 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1118 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1119 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1122 if ( $rmflag )
1124 $log->info("Removing file '$filename'");
1125 unlink($filename);
1126 system("git-update-index", "--remove", $filename);
1128 elsif ( $addflag )
1130 $log->info("Adding file '$filename'");
1131 system("git-update-index", "--add", $filename);
1132 } else {
1133 $log->info("Updating file '$filename'");
1134 system("git-update-index", $filename);
1138 unless ( scalar(@committedfiles) > 0 )
1140 print "E No files to commit\n";
1141 print "ok\n";
1142 close LOCKFILE;
1143 unlink($lockfile);
1144 chdir "/";
1145 return;
1148 my $treehash = `git-write-tree`;
1149 my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
1150 chomp $treehash;
1151 chomp $parenthash;
1153 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1155 # write our commit message out if we have one ...
1156 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1157 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1158 print $msg_fh "\n\nvia git-CVS emulator\n";
1159 close $msg_fh;
1161 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1162 $log->info("Commit hash : $commithash");
1164 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1166 $log->warn("Commit failed (Invalid commit hash)");
1167 print "error 1 Commit failed (unknown reason)\n";
1168 close LOCKFILE;
1169 unlink($lockfile);
1170 chdir "/";
1171 exit;
1174 # Check that this is allowed, just as we would with a receive-pack
1175 my @cmd = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1176 $parenthash, $commithash );
1177 if( -x $cmd[0] ) {
1178 unless( system( @cmd ) == 0 )
1180 $log->warn("Commit failed (update hook declined to update ref)");
1181 print "error 1 Commit failed (update hook declined)\n";
1182 close LOCKFILE;
1183 unlink($lockfile);
1184 chdir "/";
1185 exit;
1189 print LOCKFILE $commithash;
1191 $updater->update();
1193 # foreach file specified on the command line ...
1194 foreach my $filename ( @committedfiles )
1196 $filename = filecleanup($filename);
1198 my $meta = $updater->getmeta($filename);
1199 unless (defined $meta->{revision}) {
1200 $meta->{revision} = 1;
1203 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1205 $log->debug("Checked-in $dirpart : $filename");
1207 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1209 print "Remove-entry $dirpart\n";
1210 print "$filename\n";
1211 } else {
1212 print "Checked-in $dirpart\n";
1213 print "$filename\n";
1214 print "/$filepart/1.$meta->{revision}///\n";
1218 close LOCKFILE;
1219 my $reffile = "$ENV{GIT_DIR}refs/heads/$state->{module}";
1220 unlink($reffile);
1221 rename($lockfile, $reffile);
1222 chdir "/";
1224 print "ok\n";
1227 sub req_status
1229 my ( $cmd, $data ) = @_;
1231 argsplit("status");
1233 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1234 #$log->debug("status state : " . Dumper($state));
1236 # Grab a handle to the SQLite db and do any necessary updates
1237 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1238 $updater->update();
1240 # if no files were specified, we need to work out what files we should be providing status on ...
1241 argsfromdir($updater);
1243 # foreach file specified on the command line ...
1244 foreach my $filename ( @{$state->{args}} )
1246 $filename = filecleanup($filename);
1248 my $meta = $updater->getmeta($filename);
1249 my $oldmeta = $meta;
1251 my $wrev = revparse($filename);
1253 # If the working copy is an old revision, lets get that version too for comparison.
1254 if ( defined($wrev) and $wrev != $meta->{revision} )
1256 $oldmeta = $updater->getmeta($filename, $wrev);
1259 # TODO : All possible statuses aren't yet implemented
1260 my $status;
1261 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1262 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1264 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1265 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1268 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1269 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1271 ( $state->{entries}{$filename}{unchanged}
1272 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1275 # Need checkout if it exists in the repo but doesn't have a working copy
1276 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1278 # Locally modified if working copy and repo copy have the same revision but there are local changes
1279 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1281 # Needs Merge if working copy revision is less than repo copy and there are local changes
1282 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1284 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1285 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1286 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1287 $status ||= "File had conflicts on merge" if ( 0 );
1289 $status ||= "Unknown";
1291 print "M ===================================================================\n";
1292 print "M File: $filename\tStatus: $status\n";
1293 if ( defined($state->{entries}{$filename}{revision}) )
1295 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1296 } else {
1297 print "M Working revision:\tNo entry for $filename\n";
1299 if ( defined($meta->{revision}) )
1301 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1302 print "M Sticky Tag:\t\t(none)\n";
1303 print "M Sticky Date:\t\t(none)\n";
1304 print "M Sticky Options:\t\t(none)\n";
1305 } else {
1306 print "M Repository revision:\tNo revision control file\n";
1308 print "M\n";
1311 print "ok\n";
1314 sub req_diff
1316 my ( $cmd, $data ) = @_;
1318 argsplit("diff");
1320 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1321 #$log->debug("status state : " . Dumper($state));
1323 my ($revision1, $revision2);
1324 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1326 $revision1 = $state->{opt}{r}[0];
1327 $revision2 = $state->{opt}{r}[1];
1328 } else {
1329 $revision1 = $state->{opt}{r};
1332 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1333 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1335 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1337 # Grab a handle to the SQLite db and do any necessary updates
1338 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1339 $updater->update();
1341 # if no files were specified, we need to work out what files we should be providing status on ...
1342 argsfromdir($updater);
1344 # foreach file specified on the command line ...
1345 foreach my $filename ( @{$state->{args}} )
1347 $filename = filecleanup($filename);
1349 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1351 my $wrev = revparse($filename);
1353 # We need _something_ to diff against
1354 next unless ( defined ( $wrev ) );
1356 # if we have a -r switch, use it
1357 if ( defined ( $revision1 ) )
1359 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1360 $meta1 = $updater->getmeta($filename, $revision1);
1361 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1363 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1364 next;
1366 transmitfile($meta1->{filehash}, $file1);
1368 # otherwise we just use the working copy revision
1369 else
1371 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1372 $meta1 = $updater->getmeta($filename, $wrev);
1373 transmitfile($meta1->{filehash}, $file1);
1376 # if we have a second -r switch, use it too
1377 if ( defined ( $revision2 ) )
1379 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1380 $meta2 = $updater->getmeta($filename, $revision2);
1382 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1384 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1385 next;
1388 transmitfile($meta2->{filehash}, $file2);
1390 # otherwise we just use the working copy
1391 else
1393 $file2 = $state->{entries}{$filename}{modified_filename};
1396 # if we have been given -r, and we don't have a $file2 yet, lets get one
1397 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1399 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1400 $meta2 = $updater->getmeta($filename, $wrev);
1401 transmitfile($meta2->{filehash}, $file2);
1404 # We need to have retrieved something useful
1405 next unless ( defined ( $meta1 ) );
1407 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1408 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1410 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1411 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1414 # Apparently we only show diffs for locally modified files
1415 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1417 print "M Index: $filename\n";
1418 print "M ===================================================================\n";
1419 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1420 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1421 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1422 print "M diff ";
1423 foreach my $opt ( keys %{$state->{opt}} )
1425 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1427 foreach my $value ( @{$state->{opt}{$opt}} )
1429 print "-$opt $value ";
1431 } else {
1432 print "-$opt ";
1433 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1436 print "$filename\n";
1438 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1440 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1442 if ( exists $state->{opt}{u} )
1444 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1445 } else {
1446 system("diff $file1 $file2 > $filediff");
1449 while ( <$fh> )
1451 print "M $_";
1453 close $fh;
1456 print "ok\n";
1459 sub req_log
1461 my ( $cmd, $data ) = @_;
1463 argsplit("log");
1465 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1466 #$log->debug("log state : " . Dumper($state));
1468 my ( $minrev, $maxrev );
1469 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1471 my $control = $2;
1472 $minrev = $1;
1473 $maxrev = $3;
1474 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1475 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1476 $minrev++ if ( defined($minrev) and $control eq "::" );
1479 # Grab a handle to the SQLite db and do any necessary updates
1480 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1481 $updater->update();
1483 # if no files were specified, we need to work out what files we should be providing status on ...
1484 argsfromdir($updater);
1486 # foreach file specified on the command line ...
1487 foreach my $filename ( @{$state->{args}} )
1489 $filename = filecleanup($filename);
1491 my $headmeta = $updater->getmeta($filename);
1493 my $revisions = $updater->getlog($filename);
1494 my $totalrevisions = scalar(@$revisions);
1496 if ( defined ( $minrev ) )
1498 $log->debug("Removing revisions less than $minrev");
1499 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1501 pop @$revisions;
1504 if ( defined ( $maxrev ) )
1506 $log->debug("Removing revisions greater than $maxrev");
1507 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1509 shift @$revisions;
1513 next unless ( scalar(@$revisions) );
1515 print "M \n";
1516 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1517 print "M Working file: $filename\n";
1518 print "M head: 1.$headmeta->{revision}\n";
1519 print "M branch:\n";
1520 print "M locks: strict\n";
1521 print "M access list:\n";
1522 print "M symbolic names:\n";
1523 print "M keyword substitution: kv\n";
1524 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1525 print "M description:\n";
1527 foreach my $revision ( @$revisions )
1529 print "M ----------------------------\n";
1530 print "M revision 1.$revision->{revision}\n";
1531 # reformat the date for log output
1532 $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}) );
1533 $revision->{author} =~ s/\s+.*//;
1534 $revision->{author} =~ s/^(.{8}).*/$1/;
1535 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1536 my $commitmessage = $updater->commitmessage($revision->{commithash});
1537 $commitmessage =~ s/^/M /mg;
1538 print $commitmessage . "\n";
1540 print "M =============================================================================\n";
1543 print "ok\n";
1546 sub req_annotate
1548 my ( $cmd, $data ) = @_;
1550 argsplit("annotate");
1552 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1553 #$log->debug("status state : " . Dumper($state));
1555 # Grab a handle to the SQLite db and do any necessary updates
1556 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1557 $updater->update();
1559 # if no files were specified, we need to work out what files we should be providing annotate on ...
1560 argsfromdir($updater);
1562 # we'll need a temporary checkout dir
1563 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1564 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1565 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1567 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1568 $ENV{GIT_INDEX_FILE} = $file_index;
1570 chdir $tmpdir;
1572 # foreach file specified on the command line ...
1573 foreach my $filename ( @{$state->{args}} )
1575 $filename = filecleanup($filename);
1577 my $meta = $updater->getmeta($filename);
1579 next unless ( $meta->{revision} );
1581 # get all the commits that this file was in
1582 # in dense format -- aka skip dead revisions
1583 my $revisions = $updater->gethistorydense($filename);
1584 my $lastseenin = $revisions->[0][2];
1586 # populate the temporary index based on the latest commit were we saw
1587 # the file -- but do it cheaply without checking out any files
1588 # TODO: if we got a revision from the client, use that instead
1589 # to look up the commithash in sqlite (still good to default to
1590 # the current head as we do now)
1591 system("git-read-tree", $lastseenin);
1592 unless ($? == 0)
1594 die "Error running git-read-tree $lastseenin $file_index $!";
1596 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1598 # do a checkout of the file
1599 system('git-checkout-index', '-f', '-u', $filename);
1600 unless ($? == 0) {
1601 die "Error running git-checkout-index -f -u $filename : $!";
1604 $log->info("Annotate $filename");
1606 # Prepare a file with the commits from the linearized
1607 # history that annotate should know about. This prevents
1608 # git-jsannotate telling us about commits we are hiding
1609 # from the client.
1611 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1612 for (my $i=0; $i < @$revisions; $i++)
1614 print ANNOTATEHINTS $revisions->[$i][2];
1615 if ($i+1 < @$revisions) { # have we got a parent?
1616 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1618 print ANNOTATEHINTS "\n";
1621 print ANNOTATEHINTS "\n";
1622 close ANNOTATEHINTS;
1624 my $annotatecmd = 'git-annotate';
1625 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1626 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1627 my $metadata = {};
1628 print "E Annotations for $filename\n";
1629 print "E ***************\n";
1630 while ( <ANNOTATE> )
1632 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1634 my $commithash = $1;
1635 my $data = $2;
1636 unless ( defined ( $metadata->{$commithash} ) )
1638 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1639 $metadata->{$commithash}{author} =~ s/\s+.*//;
1640 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1641 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1643 printf("M 1.%-5d (%-8s %10s): %s\n",
1644 $metadata->{$commithash}{revision},
1645 $metadata->{$commithash}{author},
1646 $metadata->{$commithash}{modified},
1647 $data
1649 } else {
1650 $log->warn("Error in annotate output! LINE: $_");
1651 print "E Annotate error \n";
1652 next;
1655 close ANNOTATE;
1658 # done; get out of the tempdir
1659 chdir "/";
1661 print "ok\n";
1665 # This method takes the state->{arguments} array and produces two new arrays.
1666 # The first is $state->{args} which is everything before the '--' argument, and
1667 # the second is $state->{files} which is everything after it.
1668 sub argsplit
1670 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1672 my $type = shift;
1674 $state->{args} = [];
1675 $state->{files} = [];
1676 $state->{opt} = {};
1678 if ( defined($type) )
1680 my $opt = {};
1681 $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" );
1682 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1683 $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" );
1684 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1685 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1686 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1687 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1688 $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" );
1691 while ( scalar ( @{$state->{arguments}} ) > 0 )
1693 my $arg = shift @{$state->{arguments}};
1695 next if ( $arg eq "--" );
1696 next unless ( $arg =~ /\S/ );
1698 # if the argument looks like a switch
1699 if ( $arg =~ /^-(\w)(.*)/ )
1701 # if it's a switch that takes an argument
1702 if ( $opt->{$1} )
1704 # If this switch has already been provided
1705 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1707 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1708 if ( length($2) > 0 )
1710 push @{$state->{opt}{$1}},$2;
1711 } else {
1712 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1714 } else {
1715 # if there's extra data in the arg, use that as the argument for the switch
1716 if ( length($2) > 0 )
1718 $state->{opt}{$1} = $2;
1719 } else {
1720 $state->{opt}{$1} = shift @{$state->{arguments}};
1723 } else {
1724 $state->{opt}{$1} = undef;
1727 else
1729 push @{$state->{args}}, $arg;
1733 else
1735 my $mode = 0;
1737 foreach my $value ( @{$state->{arguments}} )
1739 if ( $value eq "--" )
1741 $mode++;
1742 next;
1744 push @{$state->{args}}, $value if ( $mode == 0 );
1745 push @{$state->{files}}, $value if ( $mode == 1 );
1750 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1751 sub argsfromdir
1753 my $updater = shift;
1755 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1757 return if ( scalar ( @{$state->{args}} ) > 1 );
1759 my @gethead = @{$updater->gethead};
1761 # push added files
1762 foreach my $file (keys %{$state->{entries}}) {
1763 if ( exists $state->{entries}{$file}{revision} &&
1764 $state->{entries}{$file}{revision} == 0 )
1766 push @gethead, { name => $file, filehash => 'added' };
1770 if ( scalar(@{$state->{args}}) == 1 )
1772 my $arg = $state->{args}[0];
1773 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1775 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1777 foreach my $file ( @gethead )
1779 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1780 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1781 push @{$state->{args}}, $file->{name};
1784 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1785 } else {
1786 $log->info("Only one arg specified, populating file list automatically");
1788 $state->{args} = [];
1790 foreach my $file ( @gethead )
1792 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1793 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1794 push @{$state->{args}}, $file->{name};
1799 # This method cleans up the $state variable after a command that uses arguments has run
1800 sub statecleanup
1802 $state->{files} = [];
1803 $state->{args} = [];
1804 $state->{arguments} = [];
1805 $state->{entries} = {};
1808 sub revparse
1810 my $filename = shift;
1812 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1814 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1815 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1817 return undef;
1820 # This method takes a file hash and does a CVS "file transfer" which transmits the
1821 # size of the file, and then the file contents.
1822 # If a second argument $targetfile is given, the file is instead written out to
1823 # a file by the name of $targetfile
1824 sub transmitfile
1826 my $filehash = shift;
1827 my $targetfile = shift;
1829 if ( defined ( $filehash ) and $filehash eq "deleted" )
1831 $log->warn("filehash is 'deleted'");
1832 return;
1835 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1837 my $type = `git-cat-file -t $filehash`;
1838 chomp $type;
1840 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1842 my $size = `git-cat-file -s $filehash`;
1843 chomp $size;
1845 $log->debug("transmitfile($filehash) size=$size, type=$type");
1847 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1849 if ( defined ( $targetfile ) )
1851 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1852 print NEWFILE $_ while ( <$fh> );
1853 close NEWFILE;
1854 } else {
1855 print "$size\n";
1856 print while ( <$fh> );
1858 close $fh or die ("Couldn't close filehandle for transmitfile()");
1859 } else {
1860 die("Couldn't execute git-cat-file");
1864 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1865 # refers to the directory portion and the file portion of the filename
1866 # respectively
1867 sub filenamesplit
1869 my $filename = shift;
1870 my $fixforlocaldir = shift;
1872 my ( $filepart, $dirpart ) = ( $filename, "." );
1873 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1874 $dirpart .= "/";
1876 if ( $fixforlocaldir )
1878 $dirpart =~ s/^$state->{prependdir}//;
1881 return ( $filepart, $dirpart );
1884 sub filecleanup
1886 my $filename = shift;
1888 return undef unless(defined($filename));
1889 if ( $filename =~ /^\// )
1891 print "E absolute filenames '$filename' not supported by server\n";
1892 return undef;
1895 $filename =~ s/^\.\///g;
1896 $filename = $state->{prependdir} . $filename;
1897 return $filename;
1900 package GITCVS::log;
1902 ####
1903 #### Copyright The Open University UK - 2006.
1904 ####
1905 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1906 #### Martin Langhoff <martin@catalyst.net.nz>
1907 ####
1908 ####
1910 use strict;
1911 use warnings;
1913 =head1 NAME
1915 GITCVS::log
1917 =head1 DESCRIPTION
1919 This module provides very crude logging with a similar interface to
1920 Log::Log4perl
1922 =head1 METHODS
1924 =cut
1926 =head2 new
1928 Creates a new log object, optionally you can specify a filename here to
1929 indicate the file to log to. If no log file is specified, you can specify one
1930 later with method setfile, or indicate you no longer want logging with method
1931 nofile.
1933 Until one of these methods is called, all log calls will buffer messages ready
1934 to write out.
1936 =cut
1937 sub new
1939 my $class = shift;
1940 my $filename = shift;
1942 my $self = {};
1944 bless $self, $class;
1946 if ( defined ( $filename ) )
1948 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1951 return $self;
1954 =head2 setfile
1956 This methods takes a filename, and attempts to open that file as the log file.
1957 If successful, all buffered data is written out to the file, and any further
1958 logging is written directly to the file.
1960 =cut
1961 sub setfile
1963 my $self = shift;
1964 my $filename = shift;
1966 if ( defined ( $filename ) )
1968 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1971 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1973 while ( my $line = shift @{$self->{buffer}} )
1975 print {$self->{fh}} $line;
1979 =head2 nofile
1981 This method indicates no logging is going to be used. It flushes any entries in
1982 the internal buffer, and sets a flag to ensure no further data is put there.
1984 =cut
1985 sub nofile
1987 my $self = shift;
1989 $self->{nolog} = 1;
1991 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1993 $self->{buffer} = [];
1996 =head2 _logopen
1998 Internal method. Returns true if the log file is open, false otherwise.
2000 =cut
2001 sub _logopen
2003 my $self = shift;
2005 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2006 return 0;
2009 =head2 debug info warn fatal
2011 These four methods are wrappers to _log. They provide the actual interface for
2012 logging data.
2014 =cut
2015 sub debug { my $self = shift; $self->_log("debug", @_); }
2016 sub info { my $self = shift; $self->_log("info" , @_); }
2017 sub warn { my $self = shift; $self->_log("warn" , @_); }
2018 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2020 =head2 _log
2022 This is an internal method called by the logging functions. It generates a
2023 timestamp and pushes the logged line either to file, or internal buffer.
2025 =cut
2026 sub _log
2028 my $self = shift;
2029 my $level = shift;
2031 return if ( $self->{nolog} );
2033 my @time = localtime;
2034 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2035 $time[5] + 1900,
2036 $time[4] + 1,
2037 $time[3],
2038 $time[2],
2039 $time[1],
2040 $time[0],
2041 uc $level,
2044 if ( $self->_logopen )
2046 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2047 } else {
2048 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2052 =head2 DESTROY
2054 This method simply closes the file handle if one is open
2056 =cut
2057 sub DESTROY
2059 my $self = shift;
2061 if ( $self->_logopen )
2063 close $self->{fh};
2067 package GITCVS::updater;
2069 ####
2070 #### Copyright The Open University UK - 2006.
2071 ####
2072 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2073 #### Martin Langhoff <martin@catalyst.net.nz>
2074 ####
2075 ####
2077 use strict;
2078 use warnings;
2079 use DBI;
2081 =head1 METHODS
2083 =cut
2085 =head2 new
2087 =cut
2088 sub new
2090 my $class = shift;
2091 my $config = shift;
2092 my $module = shift;
2093 my $log = shift;
2095 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2096 die "Need to specify a module" unless ( defined($module) );
2098 $class = ref($class) || $class;
2100 my $self = {};
2102 bless $self, $class;
2104 $self->{dbdir} = $config . "/";
2105 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
2107 $self->{module} = $module;
2108 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
2110 $self->{git_path} = $config . "/";
2112 $self->{log} = $log;
2114 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2116 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
2118 $self->{tables} = {};
2119 foreach my $table ( $self->{dbh}->tables )
2121 $table =~ s/^"//;
2122 $table =~ s/"$//;
2123 $self->{tables}{$table} = 1;
2126 # Construct the revision table if required
2127 unless ( $self->{tables}{revision} )
2129 $self->{dbh}->do("
2130 CREATE TABLE revision (
2131 name TEXT NOT NULL,
2132 revision INTEGER NOT NULL,
2133 filehash TEXT NOT NULL,
2134 commithash TEXT NOT NULL,
2135 author TEXT NOT NULL,
2136 modified TEXT NOT NULL,
2137 mode TEXT NOT NULL
2140 $self->{dbh}->do("
2141 CREATE INDEX revision_ix1
2142 ON revision (name,revision)
2144 $self->{dbh}->do("
2145 CREATE INDEX revision_ix2
2146 ON revision (name,commithash)
2150 # Construct the head table if required
2151 unless ( $self->{tables}{head} )
2153 $self->{dbh}->do("
2154 CREATE TABLE head (
2155 name TEXT NOT NULL,
2156 revision INTEGER NOT NULL,
2157 filehash TEXT NOT NULL,
2158 commithash TEXT NOT NULL,
2159 author TEXT NOT NULL,
2160 modified TEXT NOT NULL,
2161 mode TEXT NOT NULL
2164 $self->{dbh}->do("
2165 CREATE INDEX head_ix1
2166 ON head (name)
2170 # Construct the properties table if required
2171 unless ( $self->{tables}{properties} )
2173 $self->{dbh}->do("
2174 CREATE TABLE properties (
2175 key TEXT NOT NULL PRIMARY KEY,
2176 value TEXT
2181 # Construct the commitmsgs table if required
2182 unless ( $self->{tables}{commitmsgs} )
2184 $self->{dbh}->do("
2185 CREATE TABLE commitmsgs (
2186 key TEXT NOT NULL PRIMARY KEY,
2187 value TEXT
2192 return $self;
2195 =head2 update
2197 =cut
2198 sub update
2200 my $self = shift;
2202 # first lets get the commit list
2203 $ENV{GIT_DIR} = $self->{git_path};
2205 my $commitsha1 = `git rev-parse $self->{module}`;
2206 chomp $commitsha1;
2208 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2209 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2211 die("Invalid module '$self->{module}'");
2215 my $git_log;
2216 my $lastcommit = $self->_get_prop("last_commit");
2218 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2219 return 1;
2222 # Start exclusive lock here...
2223 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2225 # TODO: log processing is memory bound
2226 # if we can parse into a 2nd file that is in reverse order
2227 # we can probably do something really efficient
2228 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2230 if (defined $lastcommit) {
2231 push @git_log_params, "$lastcommit..$self->{module}";
2232 } else {
2233 push @git_log_params, $self->{module};
2235 # git-rev-list is the backend / plumbing version of git-log
2236 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2238 my @commits;
2240 my %commit = ();
2242 while ( <GITLOG> )
2244 chomp;
2245 if (m/^commit\s+(.*)$/) {
2246 # on ^commit lines put the just seen commit in the stack
2247 # and prime things for the next one
2248 if (keys %commit) {
2249 my %copy = %commit;
2250 unshift @commits, \%copy;
2251 %commit = ();
2253 my @parents = split(m/\s+/, $1);
2254 $commit{hash} = shift @parents;
2255 $commit{parents} = \@parents;
2256 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2257 # on rfc822-like lines seen before we see any message,
2258 # lowercase the entry and put it in the hash as key-value
2259 $commit{lc($1)} = $2;
2260 } else {
2261 # message lines - skip initial empty line
2262 # and trim whitespace
2263 if (!exists($commit{message}) && m/^\s*$/) {
2264 # define it to mark the end of headers
2265 $commit{message} = '';
2266 next;
2268 s/^\s+//; s/\s+$//; # trim ws
2269 $commit{message} .= $_ . "\n";
2272 close GITLOG;
2274 unshift @commits, \%commit if ( keys %commit );
2276 # Now all the commits are in the @commits bucket
2277 # ordered by time DESC. for each commit that needs processing,
2278 # determine whether it's following the last head we've seen or if
2279 # it's on its own branch, grab a file list, and add whatever's changed
2280 # NOTE: $lastcommit refers to the last commit from previous run
2281 # $lastpicked is the last commit we picked in this run
2282 my $lastpicked;
2283 my $head = {};
2284 if (defined $lastcommit) {
2285 $lastpicked = $lastcommit;
2288 my $committotal = scalar(@commits);
2289 my $commitcount = 0;
2291 # Load the head table into $head (for cached lookups during the update process)
2292 foreach my $file ( @{$self->gethead()} )
2294 $head->{$file->{name}} = $file;
2297 foreach my $commit ( @commits )
2299 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2300 if (defined $lastpicked)
2302 if (!in_array($lastpicked, @{$commit->{parents}}))
2304 # skip, we'll see this delta
2305 # as part of a merge later
2306 # warn "skipping off-track $commit->{hash}\n";
2307 next;
2308 } elsif (@{$commit->{parents}} > 1) {
2309 # it is a merge commit, for each parent that is
2310 # not $lastpicked, see if we can get a log
2311 # from the merge-base to that parent to put it
2312 # in the message as a merge summary.
2313 my @parents = @{$commit->{parents}};
2314 foreach my $parent (@parents) {
2315 # git-merge-base can potentially (but rarely) throw
2316 # several candidate merge bases. let's assume
2317 # that the first one is the best one.
2318 if ($parent eq $lastpicked) {
2319 next;
2321 open my $p, 'git-merge-base '. $lastpicked . ' '
2322 . $parent . '|';
2323 my @output = (<$p>);
2324 close $p;
2325 my $base = join('', @output);
2326 chomp $base;
2327 if ($base) {
2328 my @merged;
2329 # print "want to log between $base $parent \n";
2330 open(GITLOG, '-|', 'git-log', "$base..$parent")
2331 or die "Cannot call git-log: $!";
2332 my $mergedhash;
2333 while (<GITLOG>) {
2334 chomp;
2335 if (!defined $mergedhash) {
2336 if (m/^commit\s+(.+)$/) {
2337 $mergedhash = $1;
2338 } else {
2339 next;
2341 } else {
2342 # grab the first line that looks non-rfc822
2343 # aka has content after leading space
2344 if (m/^\s+(\S.*)$/) {
2345 my $title = $1;
2346 $title = substr($title,0,100); # truncate
2347 unshift @merged, "$mergedhash $title";
2348 undef $mergedhash;
2352 close GITLOG;
2353 if (@merged) {
2354 $commit->{mergemsg} = $commit->{message};
2355 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2356 foreach my $summary (@merged) {
2357 $commit->{mergemsg} .= "\t$summary\n";
2359 $commit->{mergemsg} .= "\n\n";
2360 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2367 # convert the date to CVS-happy format
2368 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2370 if ( defined ( $lastpicked ) )
2372 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2373 local ($/) = "\0";
2374 while ( <FILELIST> )
2376 chomp;
2377 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2379 die("Couldn't process git-diff-tree line : $_");
2381 my ($mode, $hash, $change) = ($1, $2, $3);
2382 my $name = <FILELIST>;
2383 chomp($name);
2385 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2387 my $git_perms = "";
2388 $git_perms .= "r" if ( $mode & 4 );
2389 $git_perms .= "w" if ( $mode & 2 );
2390 $git_perms .= "x" if ( $mode & 1 );
2391 $git_perms = "rw" if ( $git_perms eq "" );
2393 if ( $change eq "D" )
2395 #$log->debug("DELETE $name");
2396 $head->{$name} = {
2397 name => $name,
2398 revision => $head->{$name}{revision} + 1,
2399 filehash => "deleted",
2400 commithash => $commit->{hash},
2401 modified => $commit->{date},
2402 author => $commit->{author},
2403 mode => $git_perms,
2405 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2407 elsif ( $change eq "M" )
2409 #$log->debug("MODIFIED $name");
2410 $head->{$name} = {
2411 name => $name,
2412 revision => $head->{$name}{revision} + 1,
2413 filehash => $hash,
2414 commithash => $commit->{hash},
2415 modified => $commit->{date},
2416 author => $commit->{author},
2417 mode => $git_perms,
2419 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2421 elsif ( $change eq "A" )
2423 #$log->debug("ADDED $name");
2424 $head->{$name} = {
2425 name => $name,
2426 revision => 1,
2427 filehash => $hash,
2428 commithash => $commit->{hash},
2429 modified => $commit->{date},
2430 author => $commit->{author},
2431 mode => $git_perms,
2433 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2435 else
2437 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2438 die;
2441 close FILELIST;
2442 } else {
2443 # this is used to detect files removed from the repo
2444 my $seen_files = {};
2446 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2447 local $/ = "\0";
2448 while ( <FILELIST> )
2450 chomp;
2451 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2453 die("Couldn't process git-ls-tree line : $_");
2456 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2458 $seen_files->{$git_filename} = 1;
2460 my ( $oldhash, $oldrevision, $oldmode ) = (
2461 $head->{$git_filename}{filehash},
2462 $head->{$git_filename}{revision},
2463 $head->{$git_filename}{mode}
2466 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2468 $git_perms = "";
2469 $git_perms .= "r" if ( $1 & 4 );
2470 $git_perms .= "w" if ( $1 & 2 );
2471 $git_perms .= "x" if ( $1 & 1 );
2472 } else {
2473 $git_perms = "rw";
2476 # unless the file exists with the same hash, we need to update it ...
2477 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2479 my $newrevision = ( $oldrevision or 0 ) + 1;
2481 $head->{$git_filename} = {
2482 name => $git_filename,
2483 revision => $newrevision,
2484 filehash => $git_hash,
2485 commithash => $commit->{hash},
2486 modified => $commit->{date},
2487 author => $commit->{author},
2488 mode => $git_perms,
2492 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2495 close FILELIST;
2497 # Detect deleted files
2498 foreach my $file ( keys %$head )
2500 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2502 $head->{$file}{revision}++;
2503 $head->{$file}{filehash} = "deleted";
2504 $head->{$file}{commithash} = $commit->{hash};
2505 $head->{$file}{modified} = $commit->{date};
2506 $head->{$file}{author} = $commit->{author};
2508 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2511 # END : "Detect deleted files"
2515 if (exists $commit->{mergemsg})
2517 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2520 $lastpicked = $commit->{hash};
2522 $self->_set_prop("last_commit", $commit->{hash});
2525 $self->delete_head();
2526 foreach my $file ( keys %$head )
2528 $self->insert_head(
2529 $file,
2530 $head->{$file}{revision},
2531 $head->{$file}{filehash},
2532 $head->{$file}{commithash},
2533 $head->{$file}{modified},
2534 $head->{$file}{author},
2535 $head->{$file}{mode},
2538 # invalidate the gethead cache
2539 $self->{gethead_cache} = undef;
2542 # Ending exclusive lock here
2543 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2546 sub insert_rev
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_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2558 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2561 sub insert_mergelog
2563 my $self = shift;
2564 my $key = shift;
2565 my $value = shift;
2567 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2568 $insert_mergelog->execute($key, $value);
2571 sub delete_head
2573 my $self = shift;
2575 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2576 $delete_head->execute();
2579 sub insert_head
2581 my $self = shift;
2582 my $name = shift;
2583 my $revision = shift;
2584 my $filehash = shift;
2585 my $commithash = shift;
2586 my $modified = shift;
2587 my $author = shift;
2588 my $mode = shift;
2590 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2591 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2594 sub _headrev
2596 my $self = shift;
2597 my $filename = shift;
2599 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2600 $db_query->execute($filename);
2601 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2603 return ( $hash, $revision, $mode );
2606 sub _get_prop
2608 my $self = shift;
2609 my $key = shift;
2611 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2612 $db_query->execute($key);
2613 my ( $value ) = $db_query->fetchrow_array;
2615 return $value;
2618 sub _set_prop
2620 my $self = shift;
2621 my $key = shift;
2622 my $value = shift;
2624 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2625 $db_query->execute($value, $key);
2627 unless ( $db_query->rows )
2629 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2630 $db_query->execute($key, $value);
2633 return $value;
2636 =head2 gethead
2638 =cut
2640 sub gethead
2642 my $self = shift;
2644 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2646 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2647 $db_query->execute();
2649 my $tree = [];
2650 while ( my $file = $db_query->fetchrow_hashref )
2652 push @$tree, $file;
2655 $self->{gethead_cache} = $tree;
2657 return $tree;
2660 =head2 getlog
2662 =cut
2664 sub getlog
2666 my $self = shift;
2667 my $filename = shift;
2669 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2670 $db_query->execute($filename);
2672 my $tree = [];
2673 while ( my $file = $db_query->fetchrow_hashref )
2675 push @$tree, $file;
2678 return $tree;
2681 =head2 getmeta
2683 This function takes a filename (with path) argument and returns a hashref of
2684 metadata for that file.
2686 =cut
2688 sub getmeta
2690 my $self = shift;
2691 my $filename = shift;
2692 my $revision = shift;
2694 my $db_query;
2695 if ( defined($revision) and $revision =~ /^\d+$/ )
2697 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2698 $db_query->execute($filename, $revision);
2700 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2702 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2703 $db_query->execute($filename, $revision);
2704 } else {
2705 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2706 $db_query->execute($filename);
2709 return $db_query->fetchrow_hashref;
2712 =head2 commitmessage
2714 this function takes a commithash and returns the commit message for that commit
2716 =cut
2717 sub commitmessage
2719 my $self = shift;
2720 my $commithash = shift;
2722 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2724 my $db_query;
2725 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2726 $db_query->execute($commithash);
2728 my ( $message ) = $db_query->fetchrow_array;
2730 if ( defined ( $message ) )
2732 $message .= " " if ( $message =~ /\n$/ );
2733 return $message;
2736 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2737 shift @lines while ( $lines[0] =~ /\S/ );
2738 $message = join("",@lines);
2739 $message .= " " if ( $message =~ /\n$/ );
2740 return $message;
2743 =head2 gethistory
2745 This function takes a filename (with path) argument and returns an arrayofarrays
2746 containing revision,filehash,commithash ordered by revision descending
2748 =cut
2749 sub gethistory
2751 my $self = shift;
2752 my $filename = shift;
2754 my $db_query;
2755 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2756 $db_query->execute($filename);
2758 return $db_query->fetchall_arrayref;
2761 =head2 gethistorydense
2763 This function takes a filename (with path) argument and returns an arrayofarrays
2764 containing revision,filehash,commithash ordered by revision descending.
2766 This version of gethistory skips deleted entries -- so it is useful for annotate.
2767 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2768 and other git tools that depend on it.
2770 =cut
2771 sub gethistorydense
2773 my $self = shift;
2774 my $filename = shift;
2776 my $db_query;
2777 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2778 $db_query->execute($filename);
2780 return $db_query->fetchall_arrayref;
2783 =head2 in_array()
2785 from Array::PAT - mimics the in_array() function
2786 found in PHP. Yuck but works for small arrays.
2788 =cut
2789 sub in_array
2791 my ($check, @array) = @_;
2792 my $retval = 0;
2793 foreach my $test (@array){
2794 if($check eq $test){
2795 $retval = 1;
2798 return $retval;
2801 =head2 safe_pipe_capture
2803 an alternative to `command` that allows input to be passed as an array
2804 to work around shell problems with weird characters in arguments
2806 =cut
2807 sub safe_pipe_capture {
2809 my @output;
2811 if (my $pid = open my $child, '-|') {
2812 @output = (<$child>);
2813 close $child or die join(' ',@_).": $! $?";
2814 } else {
2815 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2817 return wantarray ? @output : join('',@output);