clean up and optimize nth_packed_object_sha1() usage
[git/fastimport.git] / git-cvsserver.perl
blob68aa75255e21ff8231fe2f54e5772f8cbb026fce
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 my $kopts = kopts_from_path($filepart);
378 print "/$filepart/0//$kopts/\n";
380 $addcount++;
383 if ( $addcount == 1 )
385 print "E cvs add: use `cvs commit' to add this file permanently\n";
387 elsif ( $addcount > 1 )
389 print "E cvs add: use `cvs commit' to add these files permanently\n";
392 print "ok\n";
395 # remove \n
396 # Response expected: yes. Remove a file. This uses any previous Argument,
397 # Directory, Entry, or Modified requests, if they have been sent. The last
398 # Directory sent specifies the working directory at the time of the
399 # operation. Note that this request does not actually do anything to the
400 # repository; the only effect of a successful remove request is to supply
401 # the client with a new entries line containing `-' to indicate a removed
402 # file. In fact, the client probably could perform this operation without
403 # contacting the server, although using remove may cause the server to
404 # perform a few more checks. The client sends a subsequent ci request to
405 # actually record the removal in the repository.
406 sub req_remove
408 my ( $cmd, $data ) = @_;
410 argsplit("remove");
412 # Grab a handle to the SQLite db and do any necessary updates
413 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
414 $updater->update();
416 #$log->debug("add state : " . Dumper($state));
418 my $rmcount = 0;
420 foreach my $filename ( @{$state->{args}} )
422 $filename = filecleanup($filename);
424 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
426 print "E cvs remove: file `$filename' still in working directory\n";
427 next;
430 my $meta = $updater->getmeta($filename);
431 my $wrev = revparse($filename);
433 unless ( defined ( $wrev ) )
435 print "E cvs remove: nothing known about `$filename'\n";
436 next;
439 if ( defined($wrev) and $wrev < 0 )
441 print "E cvs remove: file `$filename' already scheduled for removal\n";
442 next;
445 unless ( $wrev == $meta->{revision} )
447 # TODO : not sure if the format of this message is quite correct.
448 print "E cvs remove: Up to date check failed for `$filename'\n";
449 next;
453 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
455 print "E cvs remove: scheduling `$filename' for removal\n";
457 print "Checked-in $dirpart\n";
458 print "$filename\n";
459 my $kopts = kopts_from_path($filepart);
460 print "/$filepart/-1.$wrev//$kopts/\n";
462 $rmcount++;
465 if ( $rmcount == 1 )
467 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
469 elsif ( $rmcount > 1 )
471 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
474 print "ok\n";
477 # Modified filename \n
478 # Response expected: no. Additional data: mode, \n, file transmission. Send
479 # the server a copy of one locally modified file. filename is a file within
480 # the most recent directory sent with Directory; it must not contain `/'.
481 # If the user is operating on only some files in a directory, only those
482 # files need to be included. This can also be sent without Entry, if there
483 # is no entry for the file.
484 sub req_Modified
486 my ( $cmd, $data ) = @_;
488 my $mode = <STDIN>;
489 chomp $mode;
490 my $size = <STDIN>;
491 chomp $size;
493 # Grab config information
494 my $blocksize = 8192;
495 my $bytesleft = $size;
496 my $tmp;
498 # Get a filehandle/name to write it to
499 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
501 # Loop over file data writing out to temporary file.
502 while ( $bytesleft )
504 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
505 read STDIN, $tmp, $blocksize;
506 print $fh $tmp;
507 $bytesleft -= $blocksize;
510 close $fh;
512 # Ensure we have something sensible for the file mode
513 if ( $mode =~ /u=(\w+)/ )
515 $mode = $1;
516 } else {
517 $mode = "rw";
520 # Save the file data in $state
521 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
522 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
523 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
524 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
526 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
529 # Unchanged filename \n
530 # Response expected: no. Tell the server that filename has not been
531 # modified in the checked out directory. The filename is a file within the
532 # most recent directory sent with Directory; it must not contain `/'.
533 sub req_Unchanged
535 my ( $cmd, $data ) = @_;
537 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
539 #$log->debug("req_Unchanged : $data");
542 # Argument text \n
543 # Response expected: no. Save argument for use in a subsequent command.
544 # Arguments accumulate until an argument-using command is given, at which
545 # point they are forgotten.
546 # Argumentx text \n
547 # Response expected: no. Append \n followed by text to the current argument
548 # being saved.
549 sub req_Argument
551 my ( $cmd, $data ) = @_;
553 # Argumentx means: append to last Argument (with a newline in front)
555 $log->debug("$cmd : $data");
557 if ( $cmd eq 'Argumentx') {
558 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
559 } else {
560 push @{$state->{arguments}}, $data;
564 # expand-modules \n
565 # Response expected: yes. Expand the modules which are specified in the
566 # arguments. Returns the data in Module-expansion responses. Note that the
567 # server can assume that this is checkout or export, not rtag or rdiff; the
568 # latter do not access the working directory and thus have no need to
569 # expand modules on the client side. Expand may not be the best word for
570 # what this request does. It does not necessarily tell you all the files
571 # contained in a module, for example. Basically it is a way of telling you
572 # which working directories the server needs to know about in order to
573 # handle a checkout of the specified modules. For example, suppose that the
574 # server has a module defined by
575 # aliasmodule -a 1dir
576 # That is, one can check out aliasmodule and it will take 1dir in the
577 # repository and check it out to 1dir in the working directory. Now suppose
578 # the client already has this module checked out and is planning on using
579 # the co request to update it. Without using expand-modules, the client
580 # would have two bad choices: it could either send information about all
581 # working directories under the current directory, which could be
582 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
583 # stands for 1dir, and neglect to send information for 1dir, which would
584 # lead to incorrect operation. With expand-modules, the client would first
585 # ask for the module to be expanded:
586 sub req_expandmodules
588 my ( $cmd, $data ) = @_;
590 argsplit();
592 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
594 unless ( ref $state->{arguments} eq "ARRAY" )
596 print "ok\n";
597 return;
600 foreach my $module ( @{$state->{arguments}} )
602 $log->debug("SEND : Module-expansion $module");
603 print "Module-expansion $module\n";
606 print "ok\n";
607 statecleanup();
610 # co \n
611 # Response expected: yes. Get files from the repository. This uses any
612 # previous Argument, Directory, Entry, or Modified requests, if they have
613 # been sent. Arguments to this command are module names; the client cannot
614 # know what directories they correspond to except by (1) just sending the
615 # co request, and then seeing what directory names the server sends back in
616 # its responses, and (2) the expand-modules request.
617 sub req_co
619 my ( $cmd, $data ) = @_;
621 argsplit("co");
623 my $module = $state->{args}[0];
624 my $checkout_path = $module;
626 # use the user specified directory if we're given it
627 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
629 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
631 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
633 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
635 # Grab a handle to the SQLite db and do any necessary updates
636 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
637 $updater->update();
639 $checkout_path =~ s|/$||; # get rid of trailing slashes
641 # Eclipse seems to need the Clear-sticky command
642 # to prepare the 'Entries' file for the new directory.
643 print "Clear-sticky $checkout_path/\n";
644 print $state->{CVSROOT} . "/$module/\n";
645 print "Clear-static-directory $checkout_path/\n";
646 print $state->{CVSROOT} . "/$module/\n";
647 print "Clear-sticky $checkout_path/\n"; # yes, twice
648 print $state->{CVSROOT} . "/$module/\n";
649 print "Template $checkout_path/\n";
650 print $state->{CVSROOT} . "/$module/\n";
651 print "0\n";
653 # instruct the client that we're checking out to $checkout_path
654 print "E cvs checkout: Updating $checkout_path\n";
656 my %seendirs = ();
657 my $lastdir ='';
659 # recursive
660 sub prepdir {
661 my ($dir, $repodir, $remotedir, $seendirs) = @_;
662 my $parent = dirname($dir);
663 $dir =~ s|/+$||;
664 $repodir =~ s|/+$||;
665 $remotedir =~ s|/+$||;
666 $parent =~ s|/+$||;
667 $log->debug("announcedir $dir, $repodir, $remotedir" );
669 if ($parent eq '.' || $parent eq './') {
670 $parent = '';
672 # recurse to announce unseen parents first
673 if (length($parent) && !exists($seendirs->{$parent})) {
674 prepdir($parent, $repodir, $remotedir, $seendirs);
676 # Announce that we are going to modify at the parent level
677 if ($parent) {
678 print "E cvs checkout: Updating $remotedir/$parent\n";
679 } else {
680 print "E cvs checkout: Updating $remotedir\n";
682 print "Clear-sticky $remotedir/$parent/\n";
683 print "$repodir/$parent/\n";
685 print "Clear-static-directory $remotedir/$dir/\n";
686 print "$repodir/$dir/\n";
687 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
688 print "$repodir/$parent/\n";
689 print "Template $remotedir/$dir/\n";
690 print "$repodir/$dir/\n";
691 print "0\n";
693 $seendirs->{$dir} = 1;
696 foreach my $git ( @{$updater->gethead} )
698 # Don't want to check out deleted files
699 next if ( $git->{filehash} eq "deleted" );
701 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
703 if (length($git->{dir}) && $git->{dir} ne './'
704 && $git->{dir} ne $lastdir ) {
705 unless (exists($seendirs{$git->{dir}})) {
706 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
707 $checkout_path, \%seendirs);
708 $lastdir = $git->{dir};
709 $seendirs{$git->{dir}} = 1;
711 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
714 # modification time of this file
715 print "Mod-time $git->{modified}\n";
717 # print some information to the client
718 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
720 print "M U $checkout_path/$git->{dir}$git->{name}\n";
721 } else {
722 print "M U $checkout_path/$git->{name}\n";
725 # instruct client we're sending a file to put in this path
726 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
728 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
730 # this is an "entries" line
731 my $kopts = kopts_from_path($git->{name});
732 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
733 # permissions
734 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
736 # transmit file
737 transmitfile($git->{filehash});
740 print "ok\n";
742 statecleanup();
745 # update \n
746 # Response expected: yes. Actually do a cvs update command. This uses any
747 # previous Argument, Directory, Entry, or Modified requests, if they have
748 # been sent. The last Directory sent specifies the working directory at the
749 # time of the operation. The -I option is not used--files which the client
750 # can decide whether to ignore are not mentioned and the client sends the
751 # Questionable request for others.
752 sub req_update
754 my ( $cmd, $data ) = @_;
756 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
758 argsplit("update");
761 # It may just be a client exploring the available heads/modules
762 # in that case, list them as top level directories and leave it
763 # at that. Eclipse uses this technique to offer you a list of
764 # projects (heads in this case) to checkout.
766 if ($state->{module} eq '') {
767 print "E cvs update: Updating .\n";
768 opendir HEADS, $state->{CVSROOT} . '/refs/heads';
769 while (my $head = readdir(HEADS)) {
770 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
771 print "E cvs update: New directory `$head'\n";
774 closedir HEADS;
775 print "ok\n";
776 return 1;
780 # Grab a handle to the SQLite db and do any necessary updates
781 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
783 $updater->update();
785 argsfromdir($updater);
787 #$log->debug("update state : " . Dumper($state));
789 # foreach file specified on the command line ...
790 foreach my $filename ( @{$state->{args}} )
792 $filename = filecleanup($filename);
794 $log->debug("Processing file $filename");
796 # if we have a -C we should pretend we never saw modified stuff
797 if ( exists ( $state->{opt}{C} ) )
799 delete $state->{entries}{$filename}{modified_hash};
800 delete $state->{entries}{$filename}{modified_filename};
801 $state->{entries}{$filename}{unchanged} = 1;
804 my $meta;
805 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
807 $meta = $updater->getmeta($filename, $1);
808 } else {
809 $meta = $updater->getmeta($filename);
812 if ( ! defined $meta )
814 $meta = {
815 name => $filename,
816 revision => 0,
817 filehash => 'added'
821 my $oldmeta = $meta;
823 my $wrev = revparse($filename);
825 # If the working copy is an old revision, lets get that version too for comparison.
826 if ( defined($wrev) and $wrev != $meta->{revision} )
828 $oldmeta = $updater->getmeta($filename, $wrev);
831 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
833 # Files are up to date if the working copy and repo copy have the same revision,
834 # and the working copy is unmodified _and_ the user hasn't specified -C
835 next if ( defined ( $wrev )
836 and defined($meta->{revision})
837 and $wrev == $meta->{revision}
838 and $state->{entries}{$filename}{unchanged}
839 and not exists ( $state->{opt}{C} ) );
841 # If the working copy and repo copy have the same revision,
842 # but the working copy is modified, tell the client it's modified
843 if ( defined ( $wrev )
844 and defined($meta->{revision})
845 and $wrev == $meta->{revision}
846 and not exists ( $state->{opt}{C} ) )
848 $log->info("Tell the client the file is modified");
849 print "MT text M \n";
850 print "MT fname $filename\n";
851 print "MT newline\n";
852 next;
855 if ( $meta->{filehash} eq "deleted" )
857 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
859 $log->info("Removing '$filename' from working copy (no longer in the repo)");
861 print "E cvs update: `$filename' is no longer in the repository\n";
862 # Don't want to actually _DO_ the update if -n specified
863 unless ( $state->{globaloptions}{-n} ) {
864 print "Removed $dirpart\n";
865 print "$filepart\n";
868 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
869 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
870 or $meta->{filehash} eq 'added' )
872 # normal update, just send the new revision (either U=Update,
873 # or A=Add, or R=Remove)
874 if ( defined($wrev) && $wrev < 0 )
876 $log->info("Tell the client the file is scheduled for removal");
877 print "MT text R \n";
878 print "MT fname $filename\n";
879 print "MT newline\n";
880 next;
882 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
884 $log->info("Tell the client the file is scheduled for addition");
885 print "MT text A \n";
886 print "MT fname $filename\n";
887 print "MT newline\n";
888 next;
891 else {
892 $log->info("Updating '$filename' to ".$meta->{revision});
893 print "MT +updated\n";
894 print "MT text U \n";
895 print "MT fname $filename\n";
896 print "MT newline\n";
897 print "MT -updated\n";
900 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
902 # Don't want to actually _DO_ the update if -n specified
903 unless ( $state->{globaloptions}{-n} )
905 if ( defined ( $wrev ) )
907 # instruct client we're sending a file to put in this path as a replacement
908 print "Update-existing $dirpart\n";
909 $log->debug("Updating existing file 'Update-existing $dirpart'");
910 } else {
911 # instruct client we're sending a file to put in this path as a new file
912 print "Clear-static-directory $dirpart\n";
913 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
914 print "Clear-sticky $dirpart\n";
915 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
917 $log->debug("Creating new file 'Created $dirpart'");
918 print "Created $dirpart\n";
920 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
922 # this is an "entries" line
923 my $kopts = kopts_from_path($filepart);
924 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
925 print "/$filepart/1.$meta->{revision}//$kopts/\n";
927 # permissions
928 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
929 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
931 # transmit file
932 transmitfile($meta->{filehash});
934 } else {
935 $log->info("Updating '$filename'");
936 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
938 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
940 chdir $dir;
941 my $file_local = $filepart . ".mine";
942 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
943 my $file_old = $filepart . "." . $oldmeta->{revision};
944 transmitfile($oldmeta->{filehash}, $file_old);
945 my $file_new = $filepart . "." . $meta->{revision};
946 transmitfile($meta->{filehash}, $file_new);
948 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
949 $log->info("Merging $file_local, $file_old, $file_new");
950 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
952 $log->debug("Temporary directory for merge is $dir");
954 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
955 $return >>= 8;
957 if ( $return == 0 )
959 $log->info("Merged successfully");
960 print "M M $filename\n";
961 $log->debug("Merged $dirpart");
963 # Don't want to actually _DO_ the update if -n specified
964 unless ( $state->{globaloptions}{-n} )
966 print "Merged $dirpart\n";
967 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
968 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
969 my $kopts = kopts_from_path($filepart);
970 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
971 print "/$filepart/1.$meta->{revision}//$kopts/\n";
974 elsif ( $return == 1 )
976 $log->info("Merged with conflicts");
977 print "E cvs update: conflicts found in $filename\n";
978 print "M C $filename\n";
980 # Don't want to actually _DO_ the update if -n specified
981 unless ( $state->{globaloptions}{-n} )
983 print "Merged $dirpart\n";
984 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
985 my $kopts = kopts_from_path($filepart);
986 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
989 else
991 $log->warn("Merge failed");
992 next;
995 # Don't want to actually _DO_ the update if -n specified
996 unless ( $state->{globaloptions}{-n} )
998 # permissions
999 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1000 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1002 # transmit file, format is single integer on a line by itself (file
1003 # size) followed by the file contents
1004 # TODO : we should copy files in blocks
1005 my $data = `cat $file_local`;
1006 $log->debug("File size : " . length($data));
1007 print length($data) . "\n";
1008 print $data;
1011 chdir "/";
1016 print "ok\n";
1019 sub req_ci
1021 my ( $cmd, $data ) = @_;
1023 argsplit("ci");
1025 #$log->debug("State : " . Dumper($state));
1027 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1029 if ( @ARGV && $ARGV[0] eq 'pserver')
1031 print "error 1 pserver access cannot commit\n";
1032 exit;
1035 if ( -e $state->{CVSROOT} . "/index" )
1037 $log->warn("file 'index' already exists in the git repository");
1038 print "error 1 Index already exists in git repo\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("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1050 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1051 $ENV{GIT_INDEX_FILE} = $file_index;
1053 # Remember where the head was at the beginning.
1054 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1055 chomp $parenthash;
1056 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1057 print "error 1 pserver cannot find the current HEAD of module";
1058 exit;
1061 chdir $tmpdir;
1063 # populate the temporary index based
1064 system("git-read-tree", $parenthash);
1065 unless ($? == 0)
1067 die "Error running git-read-tree $state->{module} $file_index $!";
1069 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1071 my @committedfiles = ();
1072 my %oldmeta;
1074 # foreach file specified on the command line ...
1075 foreach my $filename ( @{$state->{args}} )
1077 my $committedfile = $filename;
1078 $filename = filecleanup($filename);
1080 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1082 my $meta = $updater->getmeta($filename);
1083 $oldmeta{$filename} = $meta;
1085 my $wrev = revparse($filename);
1087 my ( $filepart, $dirpart ) = filenamesplit($filename);
1089 # do a checkout of the file if it part of this tree
1090 if ($wrev) {
1091 system('git-checkout-index', '-f', '-u', $filename);
1092 unless ($? == 0) {
1093 die "Error running git-checkout-index -f -u $filename : $!";
1097 my $addflag = 0;
1098 my $rmflag = 0;
1099 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1100 $addflag = 1 unless ( -e $filename );
1102 # Do up to date checking
1103 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1105 # fail everything if an up to date check fails
1106 print "error 1 Up to date check failed for $filename\n";
1107 chdir "/";
1108 exit;
1111 push @committedfiles, $committedfile;
1112 $log->info("Committing $filename");
1114 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1116 unless ( $rmflag )
1118 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1119 rename $state->{entries}{$filename}{modified_filename},$filename;
1121 # Calculate modes to remove
1122 my $invmode = "";
1123 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1125 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1126 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1129 if ( $rmflag )
1131 $log->info("Removing file '$filename'");
1132 unlink($filename);
1133 system("git-update-index", "--remove", $filename);
1135 elsif ( $addflag )
1137 $log->info("Adding file '$filename'");
1138 system("git-update-index", "--add", $filename);
1139 } else {
1140 $log->info("Updating file '$filename'");
1141 system("git-update-index", $filename);
1145 unless ( scalar(@committedfiles) > 0 )
1147 print "E No files to commit\n";
1148 print "ok\n";
1149 chdir "/";
1150 return;
1153 my $treehash = `git-write-tree`;
1154 chomp $treehash;
1156 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1158 # write our commit message out if we have one ...
1159 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1160 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1161 print $msg_fh "\n\nvia git-CVS emulator\n";
1162 close $msg_fh;
1164 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1165 chomp($commithash);
1166 $log->info("Commit hash : $commithash");
1168 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1170 $log->warn("Commit failed (Invalid commit hash)");
1171 print "error 1 Commit failed (unknown reason)\n";
1172 chdir "/";
1173 exit;
1176 # Check that this is allowed, just as we would with a receive-pack
1177 my @cmd = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1178 $parenthash, $commithash );
1179 if( -x $cmd[0] ) {
1180 unless( system( @cmd ) == 0 )
1182 $log->warn("Commit failed (update hook declined to update ref)");
1183 print "error 1 Commit failed (update hook declined)\n";
1184 chdir "/";
1185 exit;
1189 if (system(qw(git update-ref -m), "cvsserver ci",
1190 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1191 $log->warn("update-ref for $state->{module} failed.");
1192 print "error 1 Cannot commit -- update first\n";
1193 exit;
1196 $updater->update();
1198 # foreach file specified on the command line ...
1199 foreach my $filename ( @committedfiles )
1201 $filename = filecleanup($filename);
1203 my $meta = $updater->getmeta($filename);
1204 unless (defined $meta->{revision}) {
1205 $meta->{revision} = 1;
1208 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1210 $log->debug("Checked-in $dirpart : $filename");
1212 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1213 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1215 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1216 print "Remove-entry $dirpart\n";
1217 print "$filename\n";
1218 } else {
1219 if ($meta->{revision} == 1) {
1220 print "M initial revision: 1.1\n";
1221 } else {
1222 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1224 print "Checked-in $dirpart\n";
1225 print "$filename\n";
1226 my $kopts = kopts_from_path($filepart);
1227 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1231 chdir "/";
1232 print "ok\n";
1235 sub req_status
1237 my ( $cmd, $data ) = @_;
1239 argsplit("status");
1241 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1242 #$log->debug("status state : " . Dumper($state));
1244 # Grab a handle to the SQLite db and do any necessary updates
1245 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1246 $updater->update();
1248 # if no files were specified, we need to work out what files we should be providing status on ...
1249 argsfromdir($updater);
1251 # foreach file specified on the command line ...
1252 foreach my $filename ( @{$state->{args}} )
1254 $filename = filecleanup($filename);
1256 my $meta = $updater->getmeta($filename);
1257 my $oldmeta = $meta;
1259 my $wrev = revparse($filename);
1261 # If the working copy is an old revision, lets get that version too for comparison.
1262 if ( defined($wrev) and $wrev != $meta->{revision} )
1264 $oldmeta = $updater->getmeta($filename, $wrev);
1267 # TODO : All possible statuses aren't yet implemented
1268 my $status;
1269 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1270 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1272 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1273 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1276 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1277 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1279 ( $state->{entries}{$filename}{unchanged}
1280 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1283 # Need checkout if it exists in the repo but doesn't have a working copy
1284 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1286 # Locally modified if working copy and repo copy have the same revision but there are local changes
1287 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1289 # Needs Merge if working copy revision is less than repo copy and there are local changes
1290 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1292 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1293 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1294 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1295 $status ||= "File had conflicts on merge" if ( 0 );
1297 $status ||= "Unknown";
1299 print "M ===================================================================\n";
1300 print "M File: $filename\tStatus: $status\n";
1301 if ( defined($state->{entries}{$filename}{revision}) )
1303 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1304 } else {
1305 print "M Working revision:\tNo entry for $filename\n";
1307 if ( defined($meta->{revision}) )
1309 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1310 print "M Sticky Tag:\t\t(none)\n";
1311 print "M Sticky Date:\t\t(none)\n";
1312 print "M Sticky Options:\t\t(none)\n";
1313 } else {
1314 print "M Repository revision:\tNo revision control file\n";
1316 print "M\n";
1319 print "ok\n";
1322 sub req_diff
1324 my ( $cmd, $data ) = @_;
1326 argsplit("diff");
1328 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1329 #$log->debug("status state : " . Dumper($state));
1331 my ($revision1, $revision2);
1332 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1334 $revision1 = $state->{opt}{r}[0];
1335 $revision2 = $state->{opt}{r}[1];
1336 } else {
1337 $revision1 = $state->{opt}{r};
1340 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1341 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1343 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1345 # Grab a handle to the SQLite db and do any necessary updates
1346 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1347 $updater->update();
1349 # if no files were specified, we need to work out what files we should be providing status on ...
1350 argsfromdir($updater);
1352 # foreach file specified on the command line ...
1353 foreach my $filename ( @{$state->{args}} )
1355 $filename = filecleanup($filename);
1357 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1359 my $wrev = revparse($filename);
1361 # We need _something_ to diff against
1362 next unless ( defined ( $wrev ) );
1364 # if we have a -r switch, use it
1365 if ( defined ( $revision1 ) )
1367 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1368 $meta1 = $updater->getmeta($filename, $revision1);
1369 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1371 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1372 next;
1374 transmitfile($meta1->{filehash}, $file1);
1376 # otherwise we just use the working copy revision
1377 else
1379 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1380 $meta1 = $updater->getmeta($filename, $wrev);
1381 transmitfile($meta1->{filehash}, $file1);
1384 # if we have a second -r switch, use it too
1385 if ( defined ( $revision2 ) )
1387 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1388 $meta2 = $updater->getmeta($filename, $revision2);
1390 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1392 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1393 next;
1396 transmitfile($meta2->{filehash}, $file2);
1398 # otherwise we just use the working copy
1399 else
1401 $file2 = $state->{entries}{$filename}{modified_filename};
1404 # if we have been given -r, and we don't have a $file2 yet, lets get one
1405 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1407 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1408 $meta2 = $updater->getmeta($filename, $wrev);
1409 transmitfile($meta2->{filehash}, $file2);
1412 # We need to have retrieved something useful
1413 next unless ( defined ( $meta1 ) );
1415 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1416 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1418 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1419 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1422 # Apparently we only show diffs for locally modified files
1423 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1425 print "M Index: $filename\n";
1426 print "M ===================================================================\n";
1427 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1428 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1429 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1430 print "M diff ";
1431 foreach my $opt ( keys %{$state->{opt}} )
1433 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1435 foreach my $value ( @{$state->{opt}{$opt}} )
1437 print "-$opt $value ";
1439 } else {
1440 print "-$opt ";
1441 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1444 print "$filename\n";
1446 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1448 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1450 if ( exists $state->{opt}{u} )
1452 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1453 } else {
1454 system("diff $file1 $file2 > $filediff");
1457 while ( <$fh> )
1459 print "M $_";
1461 close $fh;
1464 print "ok\n";
1467 sub req_log
1469 my ( $cmd, $data ) = @_;
1471 argsplit("log");
1473 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1474 #$log->debug("log state : " . Dumper($state));
1476 my ( $minrev, $maxrev );
1477 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1479 my $control = $2;
1480 $minrev = $1;
1481 $maxrev = $3;
1482 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1483 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1484 $minrev++ if ( defined($minrev) and $control eq "::" );
1487 # Grab a handle to the SQLite db and do any necessary updates
1488 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1489 $updater->update();
1491 # if no files were specified, we need to work out what files we should be providing status on ...
1492 argsfromdir($updater);
1494 # foreach file specified on the command line ...
1495 foreach my $filename ( @{$state->{args}} )
1497 $filename = filecleanup($filename);
1499 my $headmeta = $updater->getmeta($filename);
1501 my $revisions = $updater->getlog($filename);
1502 my $totalrevisions = scalar(@$revisions);
1504 if ( defined ( $minrev ) )
1506 $log->debug("Removing revisions less than $minrev");
1507 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1509 pop @$revisions;
1512 if ( defined ( $maxrev ) )
1514 $log->debug("Removing revisions greater than $maxrev");
1515 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1517 shift @$revisions;
1521 next unless ( scalar(@$revisions) );
1523 print "M \n";
1524 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1525 print "M Working file: $filename\n";
1526 print "M head: 1.$headmeta->{revision}\n";
1527 print "M branch:\n";
1528 print "M locks: strict\n";
1529 print "M access list:\n";
1530 print "M symbolic names:\n";
1531 print "M keyword substitution: kv\n";
1532 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1533 print "M description:\n";
1535 foreach my $revision ( @$revisions )
1537 print "M ----------------------------\n";
1538 print "M revision 1.$revision->{revision}\n";
1539 # reformat the date for log output
1540 $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}) );
1541 $revision->{author} =~ s/\s+.*//;
1542 $revision->{author} =~ s/^(.{8}).*/$1/;
1543 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1544 my $commitmessage = $updater->commitmessage($revision->{commithash});
1545 $commitmessage =~ s/^/M /mg;
1546 print $commitmessage . "\n";
1548 print "M =============================================================================\n";
1551 print "ok\n";
1554 sub req_annotate
1556 my ( $cmd, $data ) = @_;
1558 argsplit("annotate");
1560 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1561 #$log->debug("status state : " . Dumper($state));
1563 # Grab a handle to the SQLite db and do any necessary updates
1564 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1565 $updater->update();
1567 # if no files were specified, we need to work out what files we should be providing annotate on ...
1568 argsfromdir($updater);
1570 # we'll need a temporary checkout dir
1571 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1572 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1573 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1575 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1576 $ENV{GIT_INDEX_FILE} = $file_index;
1578 chdir $tmpdir;
1580 # foreach file specified on the command line ...
1581 foreach my $filename ( @{$state->{args}} )
1583 $filename = filecleanup($filename);
1585 my $meta = $updater->getmeta($filename);
1587 next unless ( $meta->{revision} );
1589 # get all the commits that this file was in
1590 # in dense format -- aka skip dead revisions
1591 my $revisions = $updater->gethistorydense($filename);
1592 my $lastseenin = $revisions->[0][2];
1594 # populate the temporary index based on the latest commit were we saw
1595 # the file -- but do it cheaply without checking out any files
1596 # TODO: if we got a revision from the client, use that instead
1597 # to look up the commithash in sqlite (still good to default to
1598 # the current head as we do now)
1599 system("git-read-tree", $lastseenin);
1600 unless ($? == 0)
1602 die "Error running git-read-tree $lastseenin $file_index $!";
1604 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1606 # do a checkout of the file
1607 system('git-checkout-index', '-f', '-u', $filename);
1608 unless ($? == 0) {
1609 die "Error running git-checkout-index -f -u $filename : $!";
1612 $log->info("Annotate $filename");
1614 # Prepare a file with the commits from the linearized
1615 # history that annotate should know about. This prevents
1616 # git-jsannotate telling us about commits we are hiding
1617 # from the client.
1619 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1620 for (my $i=0; $i < @$revisions; $i++)
1622 print ANNOTATEHINTS $revisions->[$i][2];
1623 if ($i+1 < @$revisions) { # have we got a parent?
1624 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1626 print ANNOTATEHINTS "\n";
1629 print ANNOTATEHINTS "\n";
1630 close ANNOTATEHINTS;
1632 my $annotatecmd = 'git-annotate';
1633 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1634 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1635 my $metadata = {};
1636 print "E Annotations for $filename\n";
1637 print "E ***************\n";
1638 while ( <ANNOTATE> )
1640 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1642 my $commithash = $1;
1643 my $data = $2;
1644 unless ( defined ( $metadata->{$commithash} ) )
1646 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1647 $metadata->{$commithash}{author} =~ s/\s+.*//;
1648 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1649 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1651 printf("M 1.%-5d (%-8s %10s): %s\n",
1652 $metadata->{$commithash}{revision},
1653 $metadata->{$commithash}{author},
1654 $metadata->{$commithash}{modified},
1655 $data
1657 } else {
1658 $log->warn("Error in annotate output! LINE: $_");
1659 print "E Annotate error \n";
1660 next;
1663 close ANNOTATE;
1666 # done; get out of the tempdir
1667 chdir "/";
1669 print "ok\n";
1673 # This method takes the state->{arguments} array and produces two new arrays.
1674 # The first is $state->{args} which is everything before the '--' argument, and
1675 # the second is $state->{files} which is everything after it.
1676 sub argsplit
1678 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1680 my $type = shift;
1682 $state->{args} = [];
1683 $state->{files} = [];
1684 $state->{opt} = {};
1686 if ( defined($type) )
1688 my $opt = {};
1689 $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" );
1690 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1691 $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" );
1692 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1693 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1694 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1695 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1696 $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" );
1699 while ( scalar ( @{$state->{arguments}} ) > 0 )
1701 my $arg = shift @{$state->{arguments}};
1703 next if ( $arg eq "--" );
1704 next unless ( $arg =~ /\S/ );
1706 # if the argument looks like a switch
1707 if ( $arg =~ /^-(\w)(.*)/ )
1709 # if it's a switch that takes an argument
1710 if ( $opt->{$1} )
1712 # If this switch has already been provided
1713 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1715 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1716 if ( length($2) > 0 )
1718 push @{$state->{opt}{$1}},$2;
1719 } else {
1720 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1722 } else {
1723 # if there's extra data in the arg, use that as the argument for the switch
1724 if ( length($2) > 0 )
1726 $state->{opt}{$1} = $2;
1727 } else {
1728 $state->{opt}{$1} = shift @{$state->{arguments}};
1731 } else {
1732 $state->{opt}{$1} = undef;
1735 else
1737 push @{$state->{args}}, $arg;
1741 else
1743 my $mode = 0;
1745 foreach my $value ( @{$state->{arguments}} )
1747 if ( $value eq "--" )
1749 $mode++;
1750 next;
1752 push @{$state->{args}}, $value if ( $mode == 0 );
1753 push @{$state->{files}}, $value if ( $mode == 1 );
1758 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1759 sub argsfromdir
1761 my $updater = shift;
1763 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1765 return if ( scalar ( @{$state->{args}} ) > 1 );
1767 my @gethead = @{$updater->gethead};
1769 # push added files
1770 foreach my $file (keys %{$state->{entries}}) {
1771 if ( exists $state->{entries}{$file}{revision} &&
1772 $state->{entries}{$file}{revision} == 0 )
1774 push @gethead, { name => $file, filehash => 'added' };
1778 if ( scalar(@{$state->{args}}) == 1 )
1780 my $arg = $state->{args}[0];
1781 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1783 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1785 foreach my $file ( @gethead )
1787 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1788 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1789 push @{$state->{args}}, $file->{name};
1792 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1793 } else {
1794 $log->info("Only one arg specified, populating file list automatically");
1796 $state->{args} = [];
1798 foreach my $file ( @gethead )
1800 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1801 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1802 push @{$state->{args}}, $file->{name};
1807 # This method cleans up the $state variable after a command that uses arguments has run
1808 sub statecleanup
1810 $state->{files} = [];
1811 $state->{args} = [];
1812 $state->{arguments} = [];
1813 $state->{entries} = {};
1816 sub revparse
1818 my $filename = shift;
1820 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1822 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1823 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1825 return undef;
1828 # This method takes a file hash and does a CVS "file transfer" which transmits the
1829 # size of the file, and then the file contents.
1830 # If a second argument $targetfile is given, the file is instead written out to
1831 # a file by the name of $targetfile
1832 sub transmitfile
1834 my $filehash = shift;
1835 my $targetfile = shift;
1837 if ( defined ( $filehash ) and $filehash eq "deleted" )
1839 $log->warn("filehash is 'deleted'");
1840 return;
1843 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1845 my $type = `git-cat-file -t $filehash`;
1846 chomp $type;
1848 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1850 my $size = `git-cat-file -s $filehash`;
1851 chomp $size;
1853 $log->debug("transmitfile($filehash) size=$size, type=$type");
1855 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1857 if ( defined ( $targetfile ) )
1859 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1860 print NEWFILE $_ while ( <$fh> );
1861 close NEWFILE;
1862 } else {
1863 print "$size\n";
1864 print while ( <$fh> );
1866 close $fh or die ("Couldn't close filehandle for transmitfile()");
1867 } else {
1868 die("Couldn't execute git-cat-file");
1872 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1873 # refers to the directory portion and the file portion of the filename
1874 # respectively
1875 sub filenamesplit
1877 my $filename = shift;
1878 my $fixforlocaldir = shift;
1880 my ( $filepart, $dirpart ) = ( $filename, "." );
1881 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1882 $dirpart .= "/";
1884 if ( $fixforlocaldir )
1886 $dirpart =~ s/^$state->{prependdir}//;
1889 return ( $filepart, $dirpart );
1892 sub filecleanup
1894 my $filename = shift;
1896 return undef unless(defined($filename));
1897 if ( $filename =~ /^\// )
1899 print "E absolute filenames '$filename' not supported by server\n";
1900 return undef;
1903 $filename =~ s/^\.\///g;
1904 $filename = $state->{prependdir} . $filename;
1905 return $filename;
1908 # Given a path, this function returns a string containing the kopts
1909 # that should go into that path's Entries line. For example, a binary
1910 # file should get -kb.
1911 sub kopts_from_path
1913 my ($path) = @_;
1915 # Once it exists, the git attributes system should be used to look up
1916 # what attributes apply to this path.
1918 # Until then, take the setting from the config file
1919 unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
1921 # Return "" to give no special treatment to any path
1922 return "";
1923 } else {
1924 # Alternatively, to have all files treated as if they are binary (which
1925 # is more like git itself), always return the "-kb" option
1926 return "-kb";
1930 package GITCVS::log;
1932 ####
1933 #### Copyright The Open University UK - 2006.
1934 ####
1935 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1936 #### Martin Langhoff <martin@catalyst.net.nz>
1937 ####
1938 ####
1940 use strict;
1941 use warnings;
1943 =head1 NAME
1945 GITCVS::log
1947 =head1 DESCRIPTION
1949 This module provides very crude logging with a similar interface to
1950 Log::Log4perl
1952 =head1 METHODS
1954 =cut
1956 =head2 new
1958 Creates a new log object, optionally you can specify a filename here to
1959 indicate the file to log to. If no log file is specified, you can specify one
1960 later with method setfile, or indicate you no longer want logging with method
1961 nofile.
1963 Until one of these methods is called, all log calls will buffer messages ready
1964 to write out.
1966 =cut
1967 sub new
1969 my $class = shift;
1970 my $filename = shift;
1972 my $self = {};
1974 bless $self, $class;
1976 if ( defined ( $filename ) )
1978 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1981 return $self;
1984 =head2 setfile
1986 This methods takes a filename, and attempts to open that file as the log file.
1987 If successful, all buffered data is written out to the file, and any further
1988 logging is written directly to the file.
1990 =cut
1991 sub setfile
1993 my $self = shift;
1994 my $filename = shift;
1996 if ( defined ( $filename ) )
1998 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2001 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2003 while ( my $line = shift @{$self->{buffer}} )
2005 print {$self->{fh}} $line;
2009 =head2 nofile
2011 This method indicates no logging is going to be used. It flushes any entries in
2012 the internal buffer, and sets a flag to ensure no further data is put there.
2014 =cut
2015 sub nofile
2017 my $self = shift;
2019 $self->{nolog} = 1;
2021 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2023 $self->{buffer} = [];
2026 =head2 _logopen
2028 Internal method. Returns true if the log file is open, false otherwise.
2030 =cut
2031 sub _logopen
2033 my $self = shift;
2035 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2036 return 0;
2039 =head2 debug info warn fatal
2041 These four methods are wrappers to _log. They provide the actual interface for
2042 logging data.
2044 =cut
2045 sub debug { my $self = shift; $self->_log("debug", @_); }
2046 sub info { my $self = shift; $self->_log("info" , @_); }
2047 sub warn { my $self = shift; $self->_log("warn" , @_); }
2048 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2050 =head2 _log
2052 This is an internal method called by the logging functions. It generates a
2053 timestamp and pushes the logged line either to file, or internal buffer.
2055 =cut
2056 sub _log
2058 my $self = shift;
2059 my $level = shift;
2061 return if ( $self->{nolog} );
2063 my @time = localtime;
2064 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2065 $time[5] + 1900,
2066 $time[4] + 1,
2067 $time[3],
2068 $time[2],
2069 $time[1],
2070 $time[0],
2071 uc $level,
2074 if ( $self->_logopen )
2076 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2077 } else {
2078 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2082 =head2 DESTROY
2084 This method simply closes the file handle if one is open
2086 =cut
2087 sub DESTROY
2089 my $self = shift;
2091 if ( $self->_logopen )
2093 close $self->{fh};
2097 package GITCVS::updater;
2099 ####
2100 #### Copyright The Open University UK - 2006.
2101 ####
2102 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2103 #### Martin Langhoff <martin@catalyst.net.nz>
2104 ####
2105 ####
2107 use strict;
2108 use warnings;
2109 use DBI;
2111 =head1 METHODS
2113 =cut
2115 =head2 new
2117 =cut
2118 sub new
2120 my $class = shift;
2121 my $config = shift;
2122 my $module = shift;
2123 my $log = shift;
2125 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2126 die "Need to specify a module" unless ( defined($module) );
2128 $class = ref($class) || $class;
2130 my $self = {};
2132 bless $self, $class;
2134 $self->{dbdir} = $config . "/";
2135 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
2137 $self->{module} = $module;
2138 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
2140 $self->{git_path} = $config . "/";
2142 $self->{log} = $log;
2144 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2146 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
2148 $self->{tables} = {};
2149 foreach my $table ( $self->{dbh}->tables )
2151 $table =~ s/^"//;
2152 $table =~ s/"$//;
2153 $self->{tables}{$table} = 1;
2156 # Construct the revision table if required
2157 unless ( $self->{tables}{revision} )
2159 $self->{dbh}->do("
2160 CREATE TABLE revision (
2161 name TEXT NOT NULL,
2162 revision INTEGER NOT NULL,
2163 filehash TEXT NOT NULL,
2164 commithash TEXT NOT NULL,
2165 author TEXT NOT NULL,
2166 modified TEXT NOT NULL,
2167 mode TEXT NOT NULL
2170 $self->{dbh}->do("
2171 CREATE INDEX revision_ix1
2172 ON revision (name,revision)
2174 $self->{dbh}->do("
2175 CREATE INDEX revision_ix2
2176 ON revision (name,commithash)
2180 # Construct the head table if required
2181 unless ( $self->{tables}{head} )
2183 $self->{dbh}->do("
2184 CREATE TABLE head (
2185 name TEXT NOT NULL,
2186 revision INTEGER NOT NULL,
2187 filehash TEXT NOT NULL,
2188 commithash TEXT NOT NULL,
2189 author TEXT NOT NULL,
2190 modified TEXT NOT NULL,
2191 mode TEXT NOT NULL
2194 $self->{dbh}->do("
2195 CREATE INDEX head_ix1
2196 ON head (name)
2200 # Construct the properties table if required
2201 unless ( $self->{tables}{properties} )
2203 $self->{dbh}->do("
2204 CREATE TABLE properties (
2205 key TEXT NOT NULL PRIMARY KEY,
2206 value TEXT
2211 # Construct the commitmsgs table if required
2212 unless ( $self->{tables}{commitmsgs} )
2214 $self->{dbh}->do("
2215 CREATE TABLE commitmsgs (
2216 key TEXT NOT NULL PRIMARY KEY,
2217 value TEXT
2222 return $self;
2225 =head2 update
2227 =cut
2228 sub update
2230 my $self = shift;
2232 # first lets get the commit list
2233 $ENV{GIT_DIR} = $self->{git_path};
2235 my $commitsha1 = `git rev-parse $self->{module}`;
2236 chomp $commitsha1;
2238 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2239 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2241 die("Invalid module '$self->{module}'");
2245 my $git_log;
2246 my $lastcommit = $self->_get_prop("last_commit");
2248 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2249 return 1;
2252 # Start exclusive lock here...
2253 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2255 # TODO: log processing is memory bound
2256 # if we can parse into a 2nd file that is in reverse order
2257 # we can probably do something really efficient
2258 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2260 if (defined $lastcommit) {
2261 push @git_log_params, "$lastcommit..$self->{module}";
2262 } else {
2263 push @git_log_params, $self->{module};
2265 # git-rev-list is the backend / plumbing version of git-log
2266 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2268 my @commits;
2270 my %commit = ();
2272 while ( <GITLOG> )
2274 chomp;
2275 if (m/^commit\s+(.*)$/) {
2276 # on ^commit lines put the just seen commit in the stack
2277 # and prime things for the next one
2278 if (keys %commit) {
2279 my %copy = %commit;
2280 unshift @commits, \%copy;
2281 %commit = ();
2283 my @parents = split(m/\s+/, $1);
2284 $commit{hash} = shift @parents;
2285 $commit{parents} = \@parents;
2286 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2287 # on rfc822-like lines seen before we see any message,
2288 # lowercase the entry and put it in the hash as key-value
2289 $commit{lc($1)} = $2;
2290 } else {
2291 # message lines - skip initial empty line
2292 # and trim whitespace
2293 if (!exists($commit{message}) && m/^\s*$/) {
2294 # define it to mark the end of headers
2295 $commit{message} = '';
2296 next;
2298 s/^\s+//; s/\s+$//; # trim ws
2299 $commit{message} .= $_ . "\n";
2302 close GITLOG;
2304 unshift @commits, \%commit if ( keys %commit );
2306 # Now all the commits are in the @commits bucket
2307 # ordered by time DESC. for each commit that needs processing,
2308 # determine whether it's following the last head we've seen or if
2309 # it's on its own branch, grab a file list, and add whatever's changed
2310 # NOTE: $lastcommit refers to the last commit from previous run
2311 # $lastpicked is the last commit we picked in this run
2312 my $lastpicked;
2313 my $head = {};
2314 if (defined $lastcommit) {
2315 $lastpicked = $lastcommit;
2318 my $committotal = scalar(@commits);
2319 my $commitcount = 0;
2321 # Load the head table into $head (for cached lookups during the update process)
2322 foreach my $file ( @{$self->gethead()} )
2324 $head->{$file->{name}} = $file;
2327 foreach my $commit ( @commits )
2329 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2330 if (defined $lastpicked)
2332 if (!in_array($lastpicked, @{$commit->{parents}}))
2334 # skip, we'll see this delta
2335 # as part of a merge later
2336 # warn "skipping off-track $commit->{hash}\n";
2337 next;
2338 } elsif (@{$commit->{parents}} > 1) {
2339 # it is a merge commit, for each parent that is
2340 # not $lastpicked, see if we can get a log
2341 # from the merge-base to that parent to put it
2342 # in the message as a merge summary.
2343 my @parents = @{$commit->{parents}};
2344 foreach my $parent (@parents) {
2345 # git-merge-base can potentially (but rarely) throw
2346 # several candidate merge bases. let's assume
2347 # that the first one is the best one.
2348 if ($parent eq $lastpicked) {
2349 next;
2351 open my $p, 'git-merge-base '. $lastpicked . ' '
2352 . $parent . '|';
2353 my @output = (<$p>);
2354 close $p;
2355 my $base = join('', @output);
2356 chomp $base;
2357 if ($base) {
2358 my @merged;
2359 # print "want to log between $base $parent \n";
2360 open(GITLOG, '-|', 'git-log', "$base..$parent")
2361 or die "Cannot call git-log: $!";
2362 my $mergedhash;
2363 while (<GITLOG>) {
2364 chomp;
2365 if (!defined $mergedhash) {
2366 if (m/^commit\s+(.+)$/) {
2367 $mergedhash = $1;
2368 } else {
2369 next;
2371 } else {
2372 # grab the first line that looks non-rfc822
2373 # aka has content after leading space
2374 if (m/^\s+(\S.*)$/) {
2375 my $title = $1;
2376 $title = substr($title,0,100); # truncate
2377 unshift @merged, "$mergedhash $title";
2378 undef $mergedhash;
2382 close GITLOG;
2383 if (@merged) {
2384 $commit->{mergemsg} = $commit->{message};
2385 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2386 foreach my $summary (@merged) {
2387 $commit->{mergemsg} .= "\t$summary\n";
2389 $commit->{mergemsg} .= "\n\n";
2390 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2397 # convert the date to CVS-happy format
2398 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2400 if ( defined ( $lastpicked ) )
2402 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2403 local ($/) = "\0";
2404 while ( <FILELIST> )
2406 chomp;
2407 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2409 die("Couldn't process git-diff-tree line : $_");
2411 my ($mode, $hash, $change) = ($1, $2, $3);
2412 my $name = <FILELIST>;
2413 chomp($name);
2415 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2417 my $git_perms = "";
2418 $git_perms .= "r" if ( $mode & 4 );
2419 $git_perms .= "w" if ( $mode & 2 );
2420 $git_perms .= "x" if ( $mode & 1 );
2421 $git_perms = "rw" if ( $git_perms eq "" );
2423 if ( $change eq "D" )
2425 #$log->debug("DELETE $name");
2426 $head->{$name} = {
2427 name => $name,
2428 revision => $head->{$name}{revision} + 1,
2429 filehash => "deleted",
2430 commithash => $commit->{hash},
2431 modified => $commit->{date},
2432 author => $commit->{author},
2433 mode => $git_perms,
2435 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2437 elsif ( $change eq "M" )
2439 #$log->debug("MODIFIED $name");
2440 $head->{$name} = {
2441 name => $name,
2442 revision => $head->{$name}{revision} + 1,
2443 filehash => $hash,
2444 commithash => $commit->{hash},
2445 modified => $commit->{date},
2446 author => $commit->{author},
2447 mode => $git_perms,
2449 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2451 elsif ( $change eq "A" )
2453 #$log->debug("ADDED $name");
2454 $head->{$name} = {
2455 name => $name,
2456 revision => 1,
2457 filehash => $hash,
2458 commithash => $commit->{hash},
2459 modified => $commit->{date},
2460 author => $commit->{author},
2461 mode => $git_perms,
2463 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2465 else
2467 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2468 die;
2471 close FILELIST;
2472 } else {
2473 # this is used to detect files removed from the repo
2474 my $seen_files = {};
2476 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2477 local $/ = "\0";
2478 while ( <FILELIST> )
2480 chomp;
2481 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2483 die("Couldn't process git-ls-tree line : $_");
2486 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2488 $seen_files->{$git_filename} = 1;
2490 my ( $oldhash, $oldrevision, $oldmode ) = (
2491 $head->{$git_filename}{filehash},
2492 $head->{$git_filename}{revision},
2493 $head->{$git_filename}{mode}
2496 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2498 $git_perms = "";
2499 $git_perms .= "r" if ( $1 & 4 );
2500 $git_perms .= "w" if ( $1 & 2 );
2501 $git_perms .= "x" if ( $1 & 1 );
2502 } else {
2503 $git_perms = "rw";
2506 # unless the file exists with the same hash, we need to update it ...
2507 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2509 my $newrevision = ( $oldrevision or 0 ) + 1;
2511 $head->{$git_filename} = {
2512 name => $git_filename,
2513 revision => $newrevision,
2514 filehash => $git_hash,
2515 commithash => $commit->{hash},
2516 modified => $commit->{date},
2517 author => $commit->{author},
2518 mode => $git_perms,
2522 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2525 close FILELIST;
2527 # Detect deleted files
2528 foreach my $file ( keys %$head )
2530 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2532 $head->{$file}{revision}++;
2533 $head->{$file}{filehash} = "deleted";
2534 $head->{$file}{commithash} = $commit->{hash};
2535 $head->{$file}{modified} = $commit->{date};
2536 $head->{$file}{author} = $commit->{author};
2538 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2541 # END : "Detect deleted files"
2545 if (exists $commit->{mergemsg})
2547 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2550 $lastpicked = $commit->{hash};
2552 $self->_set_prop("last_commit", $commit->{hash});
2555 $self->delete_head();
2556 foreach my $file ( keys %$head )
2558 $self->insert_head(
2559 $file,
2560 $head->{$file}{revision},
2561 $head->{$file}{filehash},
2562 $head->{$file}{commithash},
2563 $head->{$file}{modified},
2564 $head->{$file}{author},
2565 $head->{$file}{mode},
2568 # invalidate the gethead cache
2569 $self->{gethead_cache} = undef;
2572 # Ending exclusive lock here
2573 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2576 sub insert_rev
2578 my $self = shift;
2579 my $name = shift;
2580 my $revision = shift;
2581 my $filehash = shift;
2582 my $commithash = shift;
2583 my $modified = shift;
2584 my $author = shift;
2585 my $mode = shift;
2587 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2588 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2591 sub insert_mergelog
2593 my $self = shift;
2594 my $key = shift;
2595 my $value = shift;
2597 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2598 $insert_mergelog->execute($key, $value);
2601 sub delete_head
2603 my $self = shift;
2605 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2606 $delete_head->execute();
2609 sub insert_head
2611 my $self = shift;
2612 my $name = shift;
2613 my $revision = shift;
2614 my $filehash = shift;
2615 my $commithash = shift;
2616 my $modified = shift;
2617 my $author = shift;
2618 my $mode = shift;
2620 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2621 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2624 sub _headrev
2626 my $self = shift;
2627 my $filename = shift;
2629 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2630 $db_query->execute($filename);
2631 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2633 return ( $hash, $revision, $mode );
2636 sub _get_prop
2638 my $self = shift;
2639 my $key = shift;
2641 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2642 $db_query->execute($key);
2643 my ( $value ) = $db_query->fetchrow_array;
2645 return $value;
2648 sub _set_prop
2650 my $self = shift;
2651 my $key = shift;
2652 my $value = shift;
2654 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2655 $db_query->execute($value, $key);
2657 unless ( $db_query->rows )
2659 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2660 $db_query->execute($key, $value);
2663 return $value;
2666 =head2 gethead
2668 =cut
2670 sub gethead
2672 my $self = shift;
2674 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2676 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2677 $db_query->execute();
2679 my $tree = [];
2680 while ( my $file = $db_query->fetchrow_hashref )
2682 push @$tree, $file;
2685 $self->{gethead_cache} = $tree;
2687 return $tree;
2690 =head2 getlog
2692 =cut
2694 sub getlog
2696 my $self = shift;
2697 my $filename = shift;
2699 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2700 $db_query->execute($filename);
2702 my $tree = [];
2703 while ( my $file = $db_query->fetchrow_hashref )
2705 push @$tree, $file;
2708 return $tree;
2711 =head2 getmeta
2713 This function takes a filename (with path) argument and returns a hashref of
2714 metadata for that file.
2716 =cut
2718 sub getmeta
2720 my $self = shift;
2721 my $filename = shift;
2722 my $revision = shift;
2724 my $db_query;
2725 if ( defined($revision) and $revision =~ /^\d+$/ )
2727 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2728 $db_query->execute($filename, $revision);
2730 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2732 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2733 $db_query->execute($filename, $revision);
2734 } else {
2735 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2736 $db_query->execute($filename);
2739 return $db_query->fetchrow_hashref;
2742 =head2 commitmessage
2744 this function takes a commithash and returns the commit message for that commit
2746 =cut
2747 sub commitmessage
2749 my $self = shift;
2750 my $commithash = shift;
2752 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2754 my $db_query;
2755 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2756 $db_query->execute($commithash);
2758 my ( $message ) = $db_query->fetchrow_array;
2760 if ( defined ( $message ) )
2762 $message .= " " if ( $message =~ /\n$/ );
2763 return $message;
2766 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2767 shift @lines while ( $lines[0] =~ /\S/ );
2768 $message = join("",@lines);
2769 $message .= " " if ( $message =~ /\n$/ );
2770 return $message;
2773 =head2 gethistory
2775 This function takes a filename (with path) argument and returns an arrayofarrays
2776 containing revision,filehash,commithash ordered by revision descending
2778 =cut
2779 sub gethistory
2781 my $self = shift;
2782 my $filename = shift;
2784 my $db_query;
2785 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2786 $db_query->execute($filename);
2788 return $db_query->fetchall_arrayref;
2791 =head2 gethistorydense
2793 This function takes a filename (with path) argument and returns an arrayofarrays
2794 containing revision,filehash,commithash ordered by revision descending.
2796 This version of gethistory skips deleted entries -- so it is useful for annotate.
2797 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2798 and other git tools that depend on it.
2800 =cut
2801 sub gethistorydense
2803 my $self = shift;
2804 my $filename = shift;
2806 my $db_query;
2807 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2808 $db_query->execute($filename);
2810 return $db_query->fetchall_arrayref;
2813 =head2 in_array()
2815 from Array::PAT - mimics the in_array() function
2816 found in PHP. Yuck but works for small arrays.
2818 =cut
2819 sub in_array
2821 my ($check, @array) = @_;
2822 my $retval = 0;
2823 foreach my $test (@array){
2824 if($check eq $test){
2825 $retval = 1;
2828 return $retval;
2831 =head2 safe_pipe_capture
2833 an alternative to `command` that allows input to be passed as an array
2834 to work around shell problems with weird characters in arguments
2836 =cut
2837 sub safe_pipe_capture {
2839 my @output;
2841 if (my $pid = open my $child, '-|') {
2842 @output = (<$child>);
2843 close $child or die join(' ',@_).": $! $?";
2844 } else {
2845 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2847 return wantarray ? @output : join('',@output);