More echo "$user_message" fixes.
[git/mingw.git] / git-cvsserver.perl
blob3501c1bc3a7fb1482ef3eec10c9fc91bf4d19e4d
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 defined($state->{entries}{$filename}{modified_hash})
847 and not exists ( $state->{opt}{C} ) )
849 $log->info("Tell the client the file is modified");
850 print "MT text M \n";
851 print "MT fname $filename\n";
852 print "MT newline\n";
853 next;
856 if ( $meta->{filehash} eq "deleted" )
858 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
860 $log->info("Removing '$filename' from working copy (no longer in the repo)");
862 print "E cvs update: `$filename' is no longer in the repository\n";
863 # Don't want to actually _DO_ the update if -n specified
864 unless ( $state->{globaloptions}{-n} ) {
865 print "Removed $dirpart\n";
866 print "$filepart\n";
869 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
870 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
871 or $meta->{filehash} eq 'added' )
873 # normal update, just send the new revision (either U=Update,
874 # or A=Add, or R=Remove)
875 if ( defined($wrev) && $wrev < 0 )
877 $log->info("Tell the client the file is scheduled for removal");
878 print "MT text R \n";
879 print "MT fname $filename\n";
880 print "MT newline\n";
881 next;
883 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
885 $log->info("Tell the client the file is scheduled for addition");
886 print "MT text A \n";
887 print "MT fname $filename\n";
888 print "MT newline\n";
889 next;
892 else {
893 $log->info("Updating '$filename' to ".$meta->{revision});
894 print "MT +updated\n";
895 print "MT text U \n";
896 print "MT fname $filename\n";
897 print "MT newline\n";
898 print "MT -updated\n";
901 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
903 # Don't want to actually _DO_ the update if -n specified
904 unless ( $state->{globaloptions}{-n} )
906 if ( defined ( $wrev ) )
908 # instruct client we're sending a file to put in this path as a replacement
909 print "Update-existing $dirpart\n";
910 $log->debug("Updating existing file 'Update-existing $dirpart'");
911 } else {
912 # instruct client we're sending a file to put in this path as a new file
913 print "Clear-static-directory $dirpart\n";
914 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
915 print "Clear-sticky $dirpart\n";
916 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
918 $log->debug("Creating new file 'Created $dirpart'");
919 print "Created $dirpart\n";
921 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
923 # this is an "entries" line
924 my $kopts = kopts_from_path($filepart);
925 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
926 print "/$filepart/1.$meta->{revision}//$kopts/\n";
928 # permissions
929 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
930 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
932 # transmit file
933 transmitfile($meta->{filehash});
935 } else {
936 $log->info("Updating '$filename'");
937 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
939 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
941 chdir $dir;
942 my $file_local = $filepart . ".mine";
943 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
944 my $file_old = $filepart . "." . $oldmeta->{revision};
945 transmitfile($oldmeta->{filehash}, $file_old);
946 my $file_new = $filepart . "." . $meta->{revision};
947 transmitfile($meta->{filehash}, $file_new);
949 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
950 $log->info("Merging $file_local, $file_old, $file_new");
951 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
953 $log->debug("Temporary directory for merge is $dir");
955 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
956 $return >>= 8;
958 if ( $return == 0 )
960 $log->info("Merged successfully");
961 print "M M $filename\n";
962 $log->debug("Merged $dirpart");
964 # Don't want to actually _DO_ the update if -n specified
965 unless ( $state->{globaloptions}{-n} )
967 print "Merged $dirpart\n";
968 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
969 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
970 my $kopts = kopts_from_path($filepart);
971 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
972 print "/$filepart/1.$meta->{revision}//$kopts/\n";
975 elsif ( $return == 1 )
977 $log->info("Merged with conflicts");
978 print "E cvs update: conflicts found in $filename\n";
979 print "M C $filename\n";
981 # Don't want to actually _DO_ the update if -n specified
982 unless ( $state->{globaloptions}{-n} )
984 print "Merged $dirpart\n";
985 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
986 my $kopts = kopts_from_path($filepart);
987 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
990 else
992 $log->warn("Merge failed");
993 next;
996 # Don't want to actually _DO_ the update if -n specified
997 unless ( $state->{globaloptions}{-n} )
999 # permissions
1000 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1001 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1003 # transmit file, format is single integer on a line by itself (file
1004 # size) followed by the file contents
1005 # TODO : we should copy files in blocks
1006 my $data = `cat $file_local`;
1007 $log->debug("File size : " . length($data));
1008 print length($data) . "\n";
1009 print $data;
1012 chdir "/";
1017 print "ok\n";
1020 sub req_ci
1022 my ( $cmd, $data ) = @_;
1024 argsplit("ci");
1026 #$log->debug("State : " . Dumper($state));
1028 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1030 if ( @ARGV && $ARGV[0] eq 'pserver')
1032 print "error 1 pserver access cannot commit\n";
1033 exit;
1036 if ( -e $state->{CVSROOT} . "/index" )
1038 $log->warn("file 'index' already exists in the git repository");
1039 print "error 1 Index already exists in git repo\n";
1040 exit;
1043 # Grab a handle to the SQLite db and do any necessary updates
1044 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1045 $updater->update();
1047 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1048 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1049 $log->info("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1051 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1052 $ENV{GIT_INDEX_FILE} = $file_index;
1054 # Remember where the head was at the beginning.
1055 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1056 chomp $parenthash;
1057 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1058 print "error 1 pserver cannot find the current HEAD of module";
1059 exit;
1062 chdir $tmpdir;
1064 # populate the temporary index based
1065 system("git-read-tree", $parenthash);
1066 unless ($? == 0)
1068 die "Error running git-read-tree $state->{module} $file_index $!";
1070 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1072 my @committedfiles = ();
1073 my %oldmeta;
1075 # foreach file specified on the command line ...
1076 foreach my $filename ( @{$state->{args}} )
1078 my $committedfile = $filename;
1079 $filename = filecleanup($filename);
1081 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1083 my $meta = $updater->getmeta($filename);
1084 $oldmeta{$filename} = $meta;
1086 my $wrev = revparse($filename);
1088 my ( $filepart, $dirpart ) = filenamesplit($filename);
1090 # do a checkout of the file if it part of this tree
1091 if ($wrev) {
1092 system('git-checkout-index', '-f', '-u', $filename);
1093 unless ($? == 0) {
1094 die "Error running git-checkout-index -f -u $filename : $!";
1098 my $addflag = 0;
1099 my $rmflag = 0;
1100 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1101 $addflag = 1 unless ( -e $filename );
1103 # Do up to date checking
1104 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1106 # fail everything if an up to date check fails
1107 print "error 1 Up to date check failed for $filename\n";
1108 chdir "/";
1109 exit;
1112 push @committedfiles, $committedfile;
1113 $log->info("Committing $filename");
1115 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1117 unless ( $rmflag )
1119 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1120 rename $state->{entries}{$filename}{modified_filename},$filename;
1122 # Calculate modes to remove
1123 my $invmode = "";
1124 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1126 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1127 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1130 if ( $rmflag )
1132 $log->info("Removing file '$filename'");
1133 unlink($filename);
1134 system("git-update-index", "--remove", $filename);
1136 elsif ( $addflag )
1138 $log->info("Adding file '$filename'");
1139 system("git-update-index", "--add", $filename);
1140 } else {
1141 $log->info("Updating file '$filename'");
1142 system("git-update-index", $filename);
1146 unless ( scalar(@committedfiles) > 0 )
1148 print "E No files to commit\n";
1149 print "ok\n";
1150 chdir "/";
1151 return;
1154 my $treehash = `git-write-tree`;
1155 chomp $treehash;
1157 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1159 # write our commit message out if we have one ...
1160 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1161 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1162 print $msg_fh "\n\nvia git-CVS emulator\n";
1163 close $msg_fh;
1165 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1166 chomp($commithash);
1167 $log->info("Commit hash : $commithash");
1169 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1171 $log->warn("Commit failed (Invalid commit hash)");
1172 print "error 1 Commit failed (unknown reason)\n";
1173 chdir "/";
1174 exit;
1177 # Check that this is allowed, just as we would with a receive-pack
1178 my @cmd = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1179 $parenthash, $commithash );
1180 if( -x $cmd[0] ) {
1181 unless( system( @cmd ) == 0 )
1183 $log->warn("Commit failed (update hook declined to update ref)");
1184 print "error 1 Commit failed (update hook declined)\n";
1185 chdir "/";
1186 exit;
1190 if (system(qw(git update-ref -m), "cvsserver ci",
1191 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1192 $log->warn("update-ref for $state->{module} failed.");
1193 print "error 1 Cannot commit -- update first\n";
1194 exit;
1197 $updater->update();
1199 # foreach file specified on the command line ...
1200 foreach my $filename ( @committedfiles )
1202 $filename = filecleanup($filename);
1204 my $meta = $updater->getmeta($filename);
1205 unless (defined $meta->{revision}) {
1206 $meta->{revision} = 1;
1209 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1211 $log->debug("Checked-in $dirpart : $filename");
1213 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1214 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1216 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1217 print "Remove-entry $dirpart\n";
1218 print "$filename\n";
1219 } else {
1220 if ($meta->{revision} == 1) {
1221 print "M initial revision: 1.1\n";
1222 } else {
1223 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1225 print "Checked-in $dirpart\n";
1226 print "$filename\n";
1227 my $kopts = kopts_from_path($filepart);
1228 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1232 chdir "/";
1233 print "ok\n";
1236 sub req_status
1238 my ( $cmd, $data ) = @_;
1240 argsplit("status");
1242 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1243 #$log->debug("status state : " . Dumper($state));
1245 # Grab a handle to the SQLite db and do any necessary updates
1246 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1247 $updater->update();
1249 # if no files were specified, we need to work out what files we should be providing status on ...
1250 argsfromdir($updater);
1252 # foreach file specified on the command line ...
1253 foreach my $filename ( @{$state->{args}} )
1255 $filename = filecleanup($filename);
1257 my $meta = $updater->getmeta($filename);
1258 my $oldmeta = $meta;
1260 my $wrev = revparse($filename);
1262 # If the working copy is an old revision, lets get that version too for comparison.
1263 if ( defined($wrev) and $wrev != $meta->{revision} )
1265 $oldmeta = $updater->getmeta($filename, $wrev);
1268 # TODO : All possible statuses aren't yet implemented
1269 my $status;
1270 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1271 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1273 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1274 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1277 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1278 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1280 ( $state->{entries}{$filename}{unchanged}
1281 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1284 # Need checkout if it exists in the repo but doesn't have a working copy
1285 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1287 # Locally modified if working copy and repo copy have the same revision but there are local changes
1288 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1290 # Needs Merge if working copy revision is less than repo copy and there are local changes
1291 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1293 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1294 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1295 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1296 $status ||= "File had conflicts on merge" if ( 0 );
1298 $status ||= "Unknown";
1300 print "M ===================================================================\n";
1301 print "M File: $filename\tStatus: $status\n";
1302 if ( defined($state->{entries}{$filename}{revision}) )
1304 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1305 } else {
1306 print "M Working revision:\tNo entry for $filename\n";
1308 if ( defined($meta->{revision}) )
1310 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1311 print "M Sticky Tag:\t\t(none)\n";
1312 print "M Sticky Date:\t\t(none)\n";
1313 print "M Sticky Options:\t\t(none)\n";
1314 } else {
1315 print "M Repository revision:\tNo revision control file\n";
1317 print "M\n";
1320 print "ok\n";
1323 sub req_diff
1325 my ( $cmd, $data ) = @_;
1327 argsplit("diff");
1329 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1330 #$log->debug("status state : " . Dumper($state));
1332 my ($revision1, $revision2);
1333 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1335 $revision1 = $state->{opt}{r}[0];
1336 $revision2 = $state->{opt}{r}[1];
1337 } else {
1338 $revision1 = $state->{opt}{r};
1341 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1342 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1344 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1346 # Grab a handle to the SQLite db and do any necessary updates
1347 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1348 $updater->update();
1350 # if no files were specified, we need to work out what files we should be providing status on ...
1351 argsfromdir($updater);
1353 # foreach file specified on the command line ...
1354 foreach my $filename ( @{$state->{args}} )
1356 $filename = filecleanup($filename);
1358 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1360 my $wrev = revparse($filename);
1362 # We need _something_ to diff against
1363 next unless ( defined ( $wrev ) );
1365 # if we have a -r switch, use it
1366 if ( defined ( $revision1 ) )
1368 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1369 $meta1 = $updater->getmeta($filename, $revision1);
1370 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1372 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1373 next;
1375 transmitfile($meta1->{filehash}, $file1);
1377 # otherwise we just use the working copy revision
1378 else
1380 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1381 $meta1 = $updater->getmeta($filename, $wrev);
1382 transmitfile($meta1->{filehash}, $file1);
1385 # if we have a second -r switch, use it too
1386 if ( defined ( $revision2 ) )
1388 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1389 $meta2 = $updater->getmeta($filename, $revision2);
1391 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1393 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1394 next;
1397 transmitfile($meta2->{filehash}, $file2);
1399 # otherwise we just use the working copy
1400 else
1402 $file2 = $state->{entries}{$filename}{modified_filename};
1405 # if we have been given -r, and we don't have a $file2 yet, lets get one
1406 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1408 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1409 $meta2 = $updater->getmeta($filename, $wrev);
1410 transmitfile($meta2->{filehash}, $file2);
1413 # We need to have retrieved something useful
1414 next unless ( defined ( $meta1 ) );
1416 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1417 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1419 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1420 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1423 # Apparently we only show diffs for locally modified files
1424 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1426 print "M Index: $filename\n";
1427 print "M ===================================================================\n";
1428 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1429 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1430 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1431 print "M diff ";
1432 foreach my $opt ( keys %{$state->{opt}} )
1434 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1436 foreach my $value ( @{$state->{opt}{$opt}} )
1438 print "-$opt $value ";
1440 } else {
1441 print "-$opt ";
1442 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1445 print "$filename\n";
1447 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1449 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1451 if ( exists $state->{opt}{u} )
1453 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1454 } else {
1455 system("diff $file1 $file2 > $filediff");
1458 while ( <$fh> )
1460 print "M $_";
1462 close $fh;
1465 print "ok\n";
1468 sub req_log
1470 my ( $cmd, $data ) = @_;
1472 argsplit("log");
1474 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1475 #$log->debug("log state : " . Dumper($state));
1477 my ( $minrev, $maxrev );
1478 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1480 my $control = $2;
1481 $minrev = $1;
1482 $maxrev = $3;
1483 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1484 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1485 $minrev++ if ( defined($minrev) and $control eq "::" );
1488 # Grab a handle to the SQLite db and do any necessary updates
1489 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1490 $updater->update();
1492 # if no files were specified, we need to work out what files we should be providing status on ...
1493 argsfromdir($updater);
1495 # foreach file specified on the command line ...
1496 foreach my $filename ( @{$state->{args}} )
1498 $filename = filecleanup($filename);
1500 my $headmeta = $updater->getmeta($filename);
1502 my $revisions = $updater->getlog($filename);
1503 my $totalrevisions = scalar(@$revisions);
1505 if ( defined ( $minrev ) )
1507 $log->debug("Removing revisions less than $minrev");
1508 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1510 pop @$revisions;
1513 if ( defined ( $maxrev ) )
1515 $log->debug("Removing revisions greater than $maxrev");
1516 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1518 shift @$revisions;
1522 next unless ( scalar(@$revisions) );
1524 print "M \n";
1525 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1526 print "M Working file: $filename\n";
1527 print "M head: 1.$headmeta->{revision}\n";
1528 print "M branch:\n";
1529 print "M locks: strict\n";
1530 print "M access list:\n";
1531 print "M symbolic names:\n";
1532 print "M keyword substitution: kv\n";
1533 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1534 print "M description:\n";
1536 foreach my $revision ( @$revisions )
1538 print "M ----------------------------\n";
1539 print "M revision 1.$revision->{revision}\n";
1540 # reformat the date for log output
1541 $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}) );
1542 $revision->{author} =~ s/\s+.*//;
1543 $revision->{author} =~ s/^(.{8}).*/$1/;
1544 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1545 my $commitmessage = $updater->commitmessage($revision->{commithash});
1546 $commitmessage =~ s/^/M /mg;
1547 print $commitmessage . "\n";
1549 print "M =============================================================================\n";
1552 print "ok\n";
1555 sub req_annotate
1557 my ( $cmd, $data ) = @_;
1559 argsplit("annotate");
1561 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1562 #$log->debug("status state : " . Dumper($state));
1564 # Grab a handle to the SQLite db and do any necessary updates
1565 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1566 $updater->update();
1568 # if no files were specified, we need to work out what files we should be providing annotate on ...
1569 argsfromdir($updater);
1571 # we'll need a temporary checkout dir
1572 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1573 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1574 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1576 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1577 $ENV{GIT_INDEX_FILE} = $file_index;
1579 chdir $tmpdir;
1581 # foreach file specified on the command line ...
1582 foreach my $filename ( @{$state->{args}} )
1584 $filename = filecleanup($filename);
1586 my $meta = $updater->getmeta($filename);
1588 next unless ( $meta->{revision} );
1590 # get all the commits that this file was in
1591 # in dense format -- aka skip dead revisions
1592 my $revisions = $updater->gethistorydense($filename);
1593 my $lastseenin = $revisions->[0][2];
1595 # populate the temporary index based on the latest commit were we saw
1596 # the file -- but do it cheaply without checking out any files
1597 # TODO: if we got a revision from the client, use that instead
1598 # to look up the commithash in sqlite (still good to default to
1599 # the current head as we do now)
1600 system("git-read-tree", $lastseenin);
1601 unless ($? == 0)
1603 die "Error running git-read-tree $lastseenin $file_index $!";
1605 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1607 # do a checkout of the file
1608 system('git-checkout-index', '-f', '-u', $filename);
1609 unless ($? == 0) {
1610 die "Error running git-checkout-index -f -u $filename : $!";
1613 $log->info("Annotate $filename");
1615 # Prepare a file with the commits from the linearized
1616 # history that annotate should know about. This prevents
1617 # git-jsannotate telling us about commits we are hiding
1618 # from the client.
1620 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1621 for (my $i=0; $i < @$revisions; $i++)
1623 print ANNOTATEHINTS $revisions->[$i][2];
1624 if ($i+1 < @$revisions) { # have we got a parent?
1625 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1627 print ANNOTATEHINTS "\n";
1630 print ANNOTATEHINTS "\n";
1631 close ANNOTATEHINTS;
1633 my $annotatecmd = 'git-annotate';
1634 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1635 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1636 my $metadata = {};
1637 print "E Annotations for $filename\n";
1638 print "E ***************\n";
1639 while ( <ANNOTATE> )
1641 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1643 my $commithash = $1;
1644 my $data = $2;
1645 unless ( defined ( $metadata->{$commithash} ) )
1647 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1648 $metadata->{$commithash}{author} =~ s/\s+.*//;
1649 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1650 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1652 printf("M 1.%-5d (%-8s %10s): %s\n",
1653 $metadata->{$commithash}{revision},
1654 $metadata->{$commithash}{author},
1655 $metadata->{$commithash}{modified},
1656 $data
1658 } else {
1659 $log->warn("Error in annotate output! LINE: $_");
1660 print "E Annotate error \n";
1661 next;
1664 close ANNOTATE;
1667 # done; get out of the tempdir
1668 chdir "/";
1670 print "ok\n";
1674 # This method takes the state->{arguments} array and produces two new arrays.
1675 # The first is $state->{args} which is everything before the '--' argument, and
1676 # the second is $state->{files} which is everything after it.
1677 sub argsplit
1679 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1681 my $type = shift;
1683 $state->{args} = [];
1684 $state->{files} = [];
1685 $state->{opt} = {};
1687 if ( defined($type) )
1689 my $opt = {};
1690 $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" );
1691 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1692 $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" );
1693 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1694 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1695 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1696 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1697 $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" );
1700 while ( scalar ( @{$state->{arguments}} ) > 0 )
1702 my $arg = shift @{$state->{arguments}};
1704 next if ( $arg eq "--" );
1705 next unless ( $arg =~ /\S/ );
1707 # if the argument looks like a switch
1708 if ( $arg =~ /^-(\w)(.*)/ )
1710 # if it's a switch that takes an argument
1711 if ( $opt->{$1} )
1713 # If this switch has already been provided
1714 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1716 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1717 if ( length($2) > 0 )
1719 push @{$state->{opt}{$1}},$2;
1720 } else {
1721 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1723 } else {
1724 # if there's extra data in the arg, use that as the argument for the switch
1725 if ( length($2) > 0 )
1727 $state->{opt}{$1} = $2;
1728 } else {
1729 $state->{opt}{$1} = shift @{$state->{arguments}};
1732 } else {
1733 $state->{opt}{$1} = undef;
1736 else
1738 push @{$state->{args}}, $arg;
1742 else
1744 my $mode = 0;
1746 foreach my $value ( @{$state->{arguments}} )
1748 if ( $value eq "--" )
1750 $mode++;
1751 next;
1753 push @{$state->{args}}, $value if ( $mode == 0 );
1754 push @{$state->{files}}, $value if ( $mode == 1 );
1759 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1760 sub argsfromdir
1762 my $updater = shift;
1764 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1766 return if ( scalar ( @{$state->{args}} ) > 1 );
1768 my @gethead = @{$updater->gethead};
1770 # push added files
1771 foreach my $file (keys %{$state->{entries}}) {
1772 if ( exists $state->{entries}{$file}{revision} &&
1773 $state->{entries}{$file}{revision} == 0 )
1775 push @gethead, { name => $file, filehash => 'added' };
1779 if ( scalar(@{$state->{args}}) == 1 )
1781 my $arg = $state->{args}[0];
1782 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1784 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1786 foreach my $file ( @gethead )
1788 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1789 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1790 push @{$state->{args}}, $file->{name};
1793 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1794 } else {
1795 $log->info("Only one arg specified, populating file list automatically");
1797 $state->{args} = [];
1799 foreach my $file ( @gethead )
1801 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1802 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1803 push @{$state->{args}}, $file->{name};
1808 # This method cleans up the $state variable after a command that uses arguments has run
1809 sub statecleanup
1811 $state->{files} = [];
1812 $state->{args} = [];
1813 $state->{arguments} = [];
1814 $state->{entries} = {};
1817 sub revparse
1819 my $filename = shift;
1821 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1823 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1824 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1826 return undef;
1829 # This method takes a file hash and does a CVS "file transfer" which transmits the
1830 # size of the file, and then the file contents.
1831 # If a second argument $targetfile is given, the file is instead written out to
1832 # a file by the name of $targetfile
1833 sub transmitfile
1835 my $filehash = shift;
1836 my $targetfile = shift;
1838 if ( defined ( $filehash ) and $filehash eq "deleted" )
1840 $log->warn("filehash is 'deleted'");
1841 return;
1844 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1846 my $type = `git-cat-file -t $filehash`;
1847 chomp $type;
1849 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1851 my $size = `git-cat-file -s $filehash`;
1852 chomp $size;
1854 $log->debug("transmitfile($filehash) size=$size, type=$type");
1856 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1858 if ( defined ( $targetfile ) )
1860 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1861 print NEWFILE $_ while ( <$fh> );
1862 close NEWFILE;
1863 } else {
1864 print "$size\n";
1865 print while ( <$fh> );
1867 close $fh or die ("Couldn't close filehandle for transmitfile()");
1868 } else {
1869 die("Couldn't execute git-cat-file");
1873 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1874 # refers to the directory portion and the file portion of the filename
1875 # respectively
1876 sub filenamesplit
1878 my $filename = shift;
1879 my $fixforlocaldir = shift;
1881 my ( $filepart, $dirpart ) = ( $filename, "." );
1882 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1883 $dirpart .= "/";
1885 if ( $fixforlocaldir )
1887 $dirpart =~ s/^$state->{prependdir}//;
1890 return ( $filepart, $dirpart );
1893 sub filecleanup
1895 my $filename = shift;
1897 return undef unless(defined($filename));
1898 if ( $filename =~ /^\// )
1900 print "E absolute filenames '$filename' not supported by server\n";
1901 return undef;
1904 $filename =~ s/^\.\///g;
1905 $filename = $state->{prependdir} . $filename;
1906 return $filename;
1909 # Given a path, this function returns a string containing the kopts
1910 # that should go into that path's Entries line. For example, a binary
1911 # file should get -kb.
1912 sub kopts_from_path
1914 my ($path) = @_;
1916 # Once it exists, the git attributes system should be used to look up
1917 # what attributes apply to this path.
1919 # Until then, take the setting from the config file
1920 unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
1922 # Return "" to give no special treatment to any path
1923 return "";
1924 } else {
1925 # Alternatively, to have all files treated as if they are binary (which
1926 # is more like git itself), always return the "-kb" option
1927 return "-kb";
1931 package GITCVS::log;
1933 ####
1934 #### Copyright The Open University UK - 2006.
1935 ####
1936 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1937 #### Martin Langhoff <martin@catalyst.net.nz>
1938 ####
1939 ####
1941 use strict;
1942 use warnings;
1944 =head1 NAME
1946 GITCVS::log
1948 =head1 DESCRIPTION
1950 This module provides very crude logging with a similar interface to
1951 Log::Log4perl
1953 =head1 METHODS
1955 =cut
1957 =head2 new
1959 Creates a new log object, optionally you can specify a filename here to
1960 indicate the file to log to. If no log file is specified, you can specify one
1961 later with method setfile, or indicate you no longer want logging with method
1962 nofile.
1964 Until one of these methods is called, all log calls will buffer messages ready
1965 to write out.
1967 =cut
1968 sub new
1970 my $class = shift;
1971 my $filename = shift;
1973 my $self = {};
1975 bless $self, $class;
1977 if ( defined ( $filename ) )
1979 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1982 return $self;
1985 =head2 setfile
1987 This methods takes a filename, and attempts to open that file as the log file.
1988 If successful, all buffered data is written out to the file, and any further
1989 logging is written directly to the file.
1991 =cut
1992 sub setfile
1994 my $self = shift;
1995 my $filename = shift;
1997 if ( defined ( $filename ) )
1999 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2002 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2004 while ( my $line = shift @{$self->{buffer}} )
2006 print {$self->{fh}} $line;
2010 =head2 nofile
2012 This method indicates no logging is going to be used. It flushes any entries in
2013 the internal buffer, and sets a flag to ensure no further data is put there.
2015 =cut
2016 sub nofile
2018 my $self = shift;
2020 $self->{nolog} = 1;
2022 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2024 $self->{buffer} = [];
2027 =head2 _logopen
2029 Internal method. Returns true if the log file is open, false otherwise.
2031 =cut
2032 sub _logopen
2034 my $self = shift;
2036 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2037 return 0;
2040 =head2 debug info warn fatal
2042 These four methods are wrappers to _log. They provide the actual interface for
2043 logging data.
2045 =cut
2046 sub debug { my $self = shift; $self->_log("debug", @_); }
2047 sub info { my $self = shift; $self->_log("info" , @_); }
2048 sub warn { my $self = shift; $self->_log("warn" , @_); }
2049 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2051 =head2 _log
2053 This is an internal method called by the logging functions. It generates a
2054 timestamp and pushes the logged line either to file, or internal buffer.
2056 =cut
2057 sub _log
2059 my $self = shift;
2060 my $level = shift;
2062 return if ( $self->{nolog} );
2064 my @time = localtime;
2065 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2066 $time[5] + 1900,
2067 $time[4] + 1,
2068 $time[3],
2069 $time[2],
2070 $time[1],
2071 $time[0],
2072 uc $level,
2075 if ( $self->_logopen )
2077 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2078 } else {
2079 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2083 =head2 DESTROY
2085 This method simply closes the file handle if one is open
2087 =cut
2088 sub DESTROY
2090 my $self = shift;
2092 if ( $self->_logopen )
2094 close $self->{fh};
2098 package GITCVS::updater;
2100 ####
2101 #### Copyright The Open University UK - 2006.
2102 ####
2103 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2104 #### Martin Langhoff <martin@catalyst.net.nz>
2105 ####
2106 ####
2108 use strict;
2109 use warnings;
2110 use DBI;
2112 =head1 METHODS
2114 =cut
2116 =head2 new
2118 =cut
2119 sub new
2121 my $class = shift;
2122 my $config = shift;
2123 my $module = shift;
2124 my $log = shift;
2126 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2127 die "Need to specify a module" unless ( defined($module) );
2129 $class = ref($class) || $class;
2131 my $self = {};
2133 bless $self, $class;
2135 $self->{dbdir} = $config . "/";
2136 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
2138 $self->{module} = $module;
2139 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
2141 $self->{git_path} = $config . "/";
2143 $self->{log} = $log;
2145 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2147 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
2149 $self->{tables} = {};
2150 foreach my $table ( $self->{dbh}->tables )
2152 $table =~ s/^"//;
2153 $table =~ s/"$//;
2154 $self->{tables}{$table} = 1;
2157 # Construct the revision table if required
2158 unless ( $self->{tables}{revision} )
2160 $self->{dbh}->do("
2161 CREATE TABLE revision (
2162 name TEXT NOT NULL,
2163 revision INTEGER NOT NULL,
2164 filehash TEXT NOT NULL,
2165 commithash TEXT NOT NULL,
2166 author TEXT NOT NULL,
2167 modified TEXT NOT NULL,
2168 mode TEXT NOT NULL
2171 $self->{dbh}->do("
2172 CREATE INDEX revision_ix1
2173 ON revision (name,revision)
2175 $self->{dbh}->do("
2176 CREATE INDEX revision_ix2
2177 ON revision (name,commithash)
2181 # Construct the head table if required
2182 unless ( $self->{tables}{head} )
2184 $self->{dbh}->do("
2185 CREATE TABLE head (
2186 name TEXT NOT NULL,
2187 revision INTEGER NOT NULL,
2188 filehash TEXT NOT NULL,
2189 commithash TEXT NOT NULL,
2190 author TEXT NOT NULL,
2191 modified TEXT NOT NULL,
2192 mode TEXT NOT NULL
2195 $self->{dbh}->do("
2196 CREATE INDEX head_ix1
2197 ON head (name)
2201 # Construct the properties table if required
2202 unless ( $self->{tables}{properties} )
2204 $self->{dbh}->do("
2205 CREATE TABLE properties (
2206 key TEXT NOT NULL PRIMARY KEY,
2207 value TEXT
2212 # Construct the commitmsgs table if required
2213 unless ( $self->{tables}{commitmsgs} )
2215 $self->{dbh}->do("
2216 CREATE TABLE commitmsgs (
2217 key TEXT NOT NULL PRIMARY KEY,
2218 value TEXT
2223 return $self;
2226 =head2 update
2228 =cut
2229 sub update
2231 my $self = shift;
2233 # first lets get the commit list
2234 $ENV{GIT_DIR} = $self->{git_path};
2236 my $commitsha1 = `git rev-parse $self->{module}`;
2237 chomp $commitsha1;
2239 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2240 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2242 die("Invalid module '$self->{module}'");
2246 my $git_log;
2247 my $lastcommit = $self->_get_prop("last_commit");
2249 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2250 return 1;
2253 # Start exclusive lock here...
2254 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2256 # TODO: log processing is memory bound
2257 # if we can parse into a 2nd file that is in reverse order
2258 # we can probably do something really efficient
2259 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2261 if (defined $lastcommit) {
2262 push @git_log_params, "$lastcommit..$self->{module}";
2263 } else {
2264 push @git_log_params, $self->{module};
2266 # git-rev-list is the backend / plumbing version of git-log
2267 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2269 my @commits;
2271 my %commit = ();
2273 while ( <GITLOG> )
2275 chomp;
2276 if (m/^commit\s+(.*)$/) {
2277 # on ^commit lines put the just seen commit in the stack
2278 # and prime things for the next one
2279 if (keys %commit) {
2280 my %copy = %commit;
2281 unshift @commits, \%copy;
2282 %commit = ();
2284 my @parents = split(m/\s+/, $1);
2285 $commit{hash} = shift @parents;
2286 $commit{parents} = \@parents;
2287 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2288 # on rfc822-like lines seen before we see any message,
2289 # lowercase the entry and put it in the hash as key-value
2290 $commit{lc($1)} = $2;
2291 } else {
2292 # message lines - skip initial empty line
2293 # and trim whitespace
2294 if (!exists($commit{message}) && m/^\s*$/) {
2295 # define it to mark the end of headers
2296 $commit{message} = '';
2297 next;
2299 s/^\s+//; s/\s+$//; # trim ws
2300 $commit{message} .= $_ . "\n";
2303 close GITLOG;
2305 unshift @commits, \%commit if ( keys %commit );
2307 # Now all the commits are in the @commits bucket
2308 # ordered by time DESC. for each commit that needs processing,
2309 # determine whether it's following the last head we've seen or if
2310 # it's on its own branch, grab a file list, and add whatever's changed
2311 # NOTE: $lastcommit refers to the last commit from previous run
2312 # $lastpicked is the last commit we picked in this run
2313 my $lastpicked;
2314 my $head = {};
2315 if (defined $lastcommit) {
2316 $lastpicked = $lastcommit;
2319 my $committotal = scalar(@commits);
2320 my $commitcount = 0;
2322 # Load the head table into $head (for cached lookups during the update process)
2323 foreach my $file ( @{$self->gethead()} )
2325 $head->{$file->{name}} = $file;
2328 foreach my $commit ( @commits )
2330 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2331 if (defined $lastpicked)
2333 if (!in_array($lastpicked, @{$commit->{parents}}))
2335 # skip, we'll see this delta
2336 # as part of a merge later
2337 # warn "skipping off-track $commit->{hash}\n";
2338 next;
2339 } elsif (@{$commit->{parents}} > 1) {
2340 # it is a merge commit, for each parent that is
2341 # not $lastpicked, see if we can get a log
2342 # from the merge-base to that parent to put it
2343 # in the message as a merge summary.
2344 my @parents = @{$commit->{parents}};
2345 foreach my $parent (@parents) {
2346 # git-merge-base can potentially (but rarely) throw
2347 # several candidate merge bases. let's assume
2348 # that the first one is the best one.
2349 if ($parent eq $lastpicked) {
2350 next;
2352 open my $p, 'git-merge-base '. $lastpicked . ' '
2353 . $parent . '|';
2354 my @output = (<$p>);
2355 close $p;
2356 my $base = join('', @output);
2357 chomp $base;
2358 if ($base) {
2359 my @merged;
2360 # print "want to log between $base $parent \n";
2361 open(GITLOG, '-|', 'git-log', "$base..$parent")
2362 or die "Cannot call git-log: $!";
2363 my $mergedhash;
2364 while (<GITLOG>) {
2365 chomp;
2366 if (!defined $mergedhash) {
2367 if (m/^commit\s+(.+)$/) {
2368 $mergedhash = $1;
2369 } else {
2370 next;
2372 } else {
2373 # grab the first line that looks non-rfc822
2374 # aka has content after leading space
2375 if (m/^\s+(\S.*)$/) {
2376 my $title = $1;
2377 $title = substr($title,0,100); # truncate
2378 unshift @merged, "$mergedhash $title";
2379 undef $mergedhash;
2383 close GITLOG;
2384 if (@merged) {
2385 $commit->{mergemsg} = $commit->{message};
2386 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2387 foreach my $summary (@merged) {
2388 $commit->{mergemsg} .= "\t$summary\n";
2390 $commit->{mergemsg} .= "\n\n";
2391 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2398 # convert the date to CVS-happy format
2399 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2401 if ( defined ( $lastpicked ) )
2403 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2404 local ($/) = "\0";
2405 while ( <FILELIST> )
2407 chomp;
2408 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2410 die("Couldn't process git-diff-tree line : $_");
2412 my ($mode, $hash, $change) = ($1, $2, $3);
2413 my $name = <FILELIST>;
2414 chomp($name);
2416 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2418 my $git_perms = "";
2419 $git_perms .= "r" if ( $mode & 4 );
2420 $git_perms .= "w" if ( $mode & 2 );
2421 $git_perms .= "x" if ( $mode & 1 );
2422 $git_perms = "rw" if ( $git_perms eq "" );
2424 if ( $change eq "D" )
2426 #$log->debug("DELETE $name");
2427 $head->{$name} = {
2428 name => $name,
2429 revision => $head->{$name}{revision} + 1,
2430 filehash => "deleted",
2431 commithash => $commit->{hash},
2432 modified => $commit->{date},
2433 author => $commit->{author},
2434 mode => $git_perms,
2436 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2438 elsif ( $change eq "M" )
2440 #$log->debug("MODIFIED $name");
2441 $head->{$name} = {
2442 name => $name,
2443 revision => $head->{$name}{revision} + 1,
2444 filehash => $hash,
2445 commithash => $commit->{hash},
2446 modified => $commit->{date},
2447 author => $commit->{author},
2448 mode => $git_perms,
2450 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2452 elsif ( $change eq "A" )
2454 #$log->debug("ADDED $name");
2455 $head->{$name} = {
2456 name => $name,
2457 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
2458 filehash => $hash,
2459 commithash => $commit->{hash},
2460 modified => $commit->{date},
2461 author => $commit->{author},
2462 mode => $git_perms,
2464 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2466 else
2468 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2469 die;
2472 close FILELIST;
2473 } else {
2474 # this is used to detect files removed from the repo
2475 my $seen_files = {};
2477 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2478 local $/ = "\0";
2479 while ( <FILELIST> )
2481 chomp;
2482 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2484 die("Couldn't process git-ls-tree line : $_");
2487 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2489 $seen_files->{$git_filename} = 1;
2491 my ( $oldhash, $oldrevision, $oldmode ) = (
2492 $head->{$git_filename}{filehash},
2493 $head->{$git_filename}{revision},
2494 $head->{$git_filename}{mode}
2497 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2499 $git_perms = "";
2500 $git_perms .= "r" if ( $1 & 4 );
2501 $git_perms .= "w" if ( $1 & 2 );
2502 $git_perms .= "x" if ( $1 & 1 );
2503 } else {
2504 $git_perms = "rw";
2507 # unless the file exists with the same hash, we need to update it ...
2508 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2510 my $newrevision = ( $oldrevision or 0 ) + 1;
2512 $head->{$git_filename} = {
2513 name => $git_filename,
2514 revision => $newrevision,
2515 filehash => $git_hash,
2516 commithash => $commit->{hash},
2517 modified => $commit->{date},
2518 author => $commit->{author},
2519 mode => $git_perms,
2523 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2526 close FILELIST;
2528 # Detect deleted files
2529 foreach my $file ( keys %$head )
2531 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2533 $head->{$file}{revision}++;
2534 $head->{$file}{filehash} = "deleted";
2535 $head->{$file}{commithash} = $commit->{hash};
2536 $head->{$file}{modified} = $commit->{date};
2537 $head->{$file}{author} = $commit->{author};
2539 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2542 # END : "Detect deleted files"
2546 if (exists $commit->{mergemsg})
2548 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2551 $lastpicked = $commit->{hash};
2553 $self->_set_prop("last_commit", $commit->{hash});
2556 $self->delete_head();
2557 foreach my $file ( keys %$head )
2559 $self->insert_head(
2560 $file,
2561 $head->{$file}{revision},
2562 $head->{$file}{filehash},
2563 $head->{$file}{commithash},
2564 $head->{$file}{modified},
2565 $head->{$file}{author},
2566 $head->{$file}{mode},
2569 # invalidate the gethead cache
2570 $self->{gethead_cache} = undef;
2573 # Ending exclusive lock here
2574 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2577 sub insert_rev
2579 my $self = shift;
2580 my $name = shift;
2581 my $revision = shift;
2582 my $filehash = shift;
2583 my $commithash = shift;
2584 my $modified = shift;
2585 my $author = shift;
2586 my $mode = shift;
2588 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2589 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2592 sub insert_mergelog
2594 my $self = shift;
2595 my $key = shift;
2596 my $value = shift;
2598 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2599 $insert_mergelog->execute($key, $value);
2602 sub delete_head
2604 my $self = shift;
2606 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2607 $delete_head->execute();
2610 sub insert_head
2612 my $self = shift;
2613 my $name = shift;
2614 my $revision = shift;
2615 my $filehash = shift;
2616 my $commithash = shift;
2617 my $modified = shift;
2618 my $author = shift;
2619 my $mode = shift;
2621 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2622 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2625 sub _headrev
2627 my $self = shift;
2628 my $filename = shift;
2630 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2631 $db_query->execute($filename);
2632 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2634 return ( $hash, $revision, $mode );
2637 sub _get_prop
2639 my $self = shift;
2640 my $key = shift;
2642 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2643 $db_query->execute($key);
2644 my ( $value ) = $db_query->fetchrow_array;
2646 return $value;
2649 sub _set_prop
2651 my $self = shift;
2652 my $key = shift;
2653 my $value = shift;
2655 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2656 $db_query->execute($value, $key);
2658 unless ( $db_query->rows )
2660 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2661 $db_query->execute($key, $value);
2664 return $value;
2667 =head2 gethead
2669 =cut
2671 sub gethead
2673 my $self = shift;
2675 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2677 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2678 $db_query->execute();
2680 my $tree = [];
2681 while ( my $file = $db_query->fetchrow_hashref )
2683 push @$tree, $file;
2686 $self->{gethead_cache} = $tree;
2688 return $tree;
2691 =head2 getlog
2693 =cut
2695 sub getlog
2697 my $self = shift;
2698 my $filename = shift;
2700 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2701 $db_query->execute($filename);
2703 my $tree = [];
2704 while ( my $file = $db_query->fetchrow_hashref )
2706 push @$tree, $file;
2709 return $tree;
2712 =head2 getmeta
2714 This function takes a filename (with path) argument and returns a hashref of
2715 metadata for that file.
2717 =cut
2719 sub getmeta
2721 my $self = shift;
2722 my $filename = shift;
2723 my $revision = shift;
2725 my $db_query;
2726 if ( defined($revision) and $revision =~ /^\d+$/ )
2728 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2729 $db_query->execute($filename, $revision);
2731 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2733 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2734 $db_query->execute($filename, $revision);
2735 } else {
2736 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2737 $db_query->execute($filename);
2740 return $db_query->fetchrow_hashref;
2743 =head2 commitmessage
2745 this function takes a commithash and returns the commit message for that commit
2747 =cut
2748 sub commitmessage
2750 my $self = shift;
2751 my $commithash = shift;
2753 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2755 my $db_query;
2756 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2757 $db_query->execute($commithash);
2759 my ( $message ) = $db_query->fetchrow_array;
2761 if ( defined ( $message ) )
2763 $message .= " " if ( $message =~ /\n$/ );
2764 return $message;
2767 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2768 shift @lines while ( $lines[0] =~ /\S/ );
2769 $message = join("",@lines);
2770 $message .= " " if ( $message =~ /\n$/ );
2771 return $message;
2774 =head2 gethistory
2776 This function takes a filename (with path) argument and returns an arrayofarrays
2777 containing revision,filehash,commithash ordered by revision descending
2779 =cut
2780 sub gethistory
2782 my $self = shift;
2783 my $filename = shift;
2785 my $db_query;
2786 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2787 $db_query->execute($filename);
2789 return $db_query->fetchall_arrayref;
2792 =head2 gethistorydense
2794 This function takes a filename (with path) argument and returns an arrayofarrays
2795 containing revision,filehash,commithash ordered by revision descending.
2797 This version of gethistory skips deleted entries -- so it is useful for annotate.
2798 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2799 and other git tools that depend on it.
2801 =cut
2802 sub gethistorydense
2804 my $self = shift;
2805 my $filename = shift;
2807 my $db_query;
2808 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2809 $db_query->execute($filename);
2811 return $db_query->fetchall_arrayref;
2814 =head2 in_array()
2816 from Array::PAT - mimics the in_array() function
2817 found in PHP. Yuck but works for small arrays.
2819 =cut
2820 sub in_array
2822 my ($check, @array) = @_;
2823 my $retval = 0;
2824 foreach my $test (@array){
2825 if($check eq $test){
2826 $retval = 1;
2829 return $retval;
2832 =head2 safe_pipe_capture
2834 an alternative to `command` that allows input to be passed as an array
2835 to work around shell problems with weird characters in arguments
2837 =cut
2838 sub safe_pipe_capture {
2840 my @output;
2842 if (my $pid = open my $child, '-|') {
2843 @output = (<$child>);
2844 close $child or die join(' ',@_).": $! $?";
2845 } else {
2846 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2848 return wantarray ? @output : join('',@output);