builtin-apply: stronger indent-with-on-tab fixing
[git/jbf-maint.git] / git-cvsserver.perl
blobecded3b9cba9e18117f7372af37e9b56203a6fcf
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;
25 use Getopt::Long qw(:config require_order no_ignore_case);
27 my $VERSION = '@@GIT_VERSION@@';
29 my $log = GITCVS::log->new();
30 my $cfg;
32 my $DATE_LIST = {
33 Jan => "01",
34 Feb => "02",
35 Mar => "03",
36 Apr => "04",
37 May => "05",
38 Jun => "06",
39 Jul => "07",
40 Aug => "08",
41 Sep => "09",
42 Oct => "10",
43 Nov => "11",
44 Dec => "12",
47 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
48 $| = 1;
50 #### Definition and mappings of functions ####
52 my $methods = {
53 'Root' => \&req_Root,
54 'Valid-responses' => \&req_Validresponses,
55 'valid-requests' => \&req_validrequests,
56 'Directory' => \&req_Directory,
57 'Entry' => \&req_Entry,
58 'Modified' => \&req_Modified,
59 'Unchanged' => \&req_Unchanged,
60 'Questionable' => \&req_Questionable,
61 'Argument' => \&req_Argument,
62 'Argumentx' => \&req_Argument,
63 'expand-modules' => \&req_expandmodules,
64 'add' => \&req_add,
65 'remove' => \&req_remove,
66 'co' => \&req_co,
67 'update' => \&req_update,
68 'ci' => \&req_ci,
69 'diff' => \&req_diff,
70 'log' => \&req_log,
71 'rlog' => \&req_log,
72 'tag' => \&req_CATCHALL,
73 'status' => \&req_status,
74 'admin' => \&req_CATCHALL,
75 'history' => \&req_CATCHALL,
76 'watchers' => \&req_CATCHALL,
77 'editors' => \&req_CATCHALL,
78 'annotate' => \&req_annotate,
79 'Global_option' => \&req_Globaloption,
80 #'annotate' => \&req_CATCHALL,
83 ##############################################
86 # $state holds all the bits of information the clients sends us that could
87 # potentially be useful when it comes to actually _doing_ something.
88 my $state = { prependdir => '' };
89 $log->info("--------------- STARTING -----------------");
91 my $usage =
92 "Usage: git-cvsserver [options] [pserver|server] [<directory> ...]\n".
93 " --base-path <path> : Prepend to requested CVSROOT\n".
94 " --strict-paths : Don't allow recursing into subdirectories\n".
95 " --export-all : Don't check for gitcvs.enabled in config\n".
96 " --version, -V : Print version information and exit\n".
97 " --help, -h, -H : Print usage information and exit\n".
98 "\n".
99 "<directory> ... is a list of allowed directories. If no directories\n".
100 "are given, all are allowed. This is an additional restriction, gitcvs\n".
101 "access still needs to be enabled by the gitcvs.enabled config option.\n";
103 my @opts = ( 'help|h|H', 'version|V',
104 'base-path=s', 'strict-paths', 'export-all' );
105 GetOptions( $state, @opts )
106 or die $usage;
108 if ($state->{version}) {
109 print "git-cvsserver version $VERSION\n";
110 exit;
112 if ($state->{help}) {
113 print $usage;
114 exit;
117 my $TEMP_DIR = tempdir( CLEANUP => 1 );
118 $log->debug("Temporary directory is '$TEMP_DIR'");
120 $state->{method} = 'ext';
121 if (@ARGV) {
122 if ($ARGV[0] eq 'pserver') {
123 $state->{method} = 'pserver';
124 shift @ARGV;
125 } elsif ($ARGV[0] eq 'server') {
126 shift @ARGV;
130 # everything else is a directory
131 $state->{allowed_roots} = [ @ARGV ];
133 # don't export the whole system unless the users requests it
134 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
135 die "--export-all can only be used together with an explicit whitelist\n";
138 # if we are called with a pserver argument,
139 # deal with the authentication cat before entering the
140 # main loop
141 if ($state->{method} eq 'pserver') {
142 my $line = <STDIN>; chomp $line;
143 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
144 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
146 my $request = $1;
147 $line = <STDIN>; chomp $line;
148 unless (req_Root('root', $line)) { # reuse Root
149 print "E Invalid root $line \n";
150 exit 1;
152 $line = <STDIN>; chomp $line;
153 unless ($line eq 'anonymous') {
154 print "E Only anonymous user allowed via pserver\n";
155 print "I HATE YOU\n";
156 exit 1;
158 $line = <STDIN>; chomp $line; # validate the password?
159 $line = <STDIN>; chomp $line;
160 unless ($line eq "END $request REQUEST") {
161 die "E Do not understand $line -- expecting END $request REQUEST\n";
163 print "I LOVE YOU\n";
164 exit if $request eq 'VERIFICATION'; # cvs login
165 # and now back to our regular programme...
168 # Keep going until the client closes the connection
169 while (<STDIN>)
171 chomp;
173 # Check to see if we've seen this method, and call appropriate function.
174 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
176 # use the $methods hash to call the appropriate sub for this command
177 #$log->info("Method : $1");
178 &{$methods->{$1}}($1,$2);
179 } else {
180 # log fatal because we don't understand this function. If this happens
181 # we're fairly screwed because we don't know if the client is expecting
182 # a response. If it is, the client will hang, we'll hang, and the whole
183 # thing will be custard.
184 $log->fatal("Don't understand command $_\n");
185 die("Unknown command $_");
189 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
190 $log->info("--------------- FINISH -----------------");
192 # Magic catchall method.
193 # This is the method that will handle all commands we haven't yet
194 # implemented. It simply sends a warning to the log file indicating a
195 # command that hasn't been implemented has been invoked.
196 sub req_CATCHALL
198 my ( $cmd, $data ) = @_;
199 $log->warn("Unhandled command : req_$cmd : $data");
203 # Root pathname \n
204 # Response expected: no. Tell the server which CVSROOT to use. Note that
205 # pathname is a local directory and not a fully qualified CVSROOT variable.
206 # pathname must already exist; if creating a new root, use the init
207 # request, not Root. pathname does not include the hostname of the server,
208 # how to access the server, etc.; by the time the CVS protocol is in use,
209 # connection, authentication, etc., are already taken care of. The Root
210 # request must be sent only once, and it must be sent before any requests
211 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
212 sub req_Root
214 my ( $cmd, $data ) = @_;
215 $log->debug("req_Root : $data");
217 unless ($data =~ m#^/#) {
218 print "error 1 Root must be an absolute pathname\n";
219 return 0;
222 my $cvsroot = $state->{'base-path'} || '';
223 $cvsroot =~ s#/+$##;
224 $cvsroot .= $data;
226 if ($state->{CVSROOT}
227 && ($state->{CVSROOT} ne $cvsroot)) {
228 print "error 1 Conflicting roots specified\n";
229 return 0;
232 $state->{CVSROOT} = $cvsroot;
234 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
236 if (@{$state->{allowed_roots}}) {
237 my $allowed = 0;
238 foreach my $dir (@{$state->{allowed_roots}}) {
239 next unless $dir =~ m#^/#;
240 $dir =~ s#/+$##;
241 if ($state->{'strict-paths'}) {
242 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
243 $allowed = 1;
244 last;
246 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
247 $allowed = 1;
248 last;
252 unless ($allowed) {
253 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
254 print "E \n";
255 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
256 return 0;
260 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
261 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
262 print "E \n";
263 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
264 return 0;
267 my @gitvars = `git-config -l`;
268 if ($?) {
269 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
270 print "E \n";
271 print "error 1 - problem executing git-config\n";
272 return 0;
274 foreach my $line ( @gitvars )
276 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
277 unless ($2) {
278 $cfg->{$1}{$3} = $4;
279 } else {
280 $cfg->{$1}{$2}{$3} = $4;
284 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
285 || $cfg->{gitcvs}{enabled});
286 unless ($state->{'export-all'} ||
287 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
288 print "E GITCVS emulation needs to be enabled on this repo\n";
289 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
290 print "E \n";
291 print "error 1 GITCVS emulation disabled\n";
292 return 0;
295 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
296 if ( $logfile )
298 $log->setfile($logfile);
299 } else {
300 $log->nofile();
303 return 1;
306 # Global_option option \n
307 # Response expected: no. Transmit one of the global options `-q', `-Q',
308 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
309 # variations (such as combining of options) are allowed. For graceful
310 # handling of valid-requests, it is probably better to make new global
311 # options separate requests, rather than trying to add them to this
312 # request.
313 sub req_Globaloption
315 my ( $cmd, $data ) = @_;
316 $log->debug("req_Globaloption : $data");
317 $state->{globaloptions}{$data} = 1;
320 # Valid-responses request-list \n
321 # Response expected: no. Tell the server what responses the client will
322 # accept. request-list is a space separated list of tokens.
323 sub req_Validresponses
325 my ( $cmd, $data ) = @_;
326 $log->debug("req_Validresponses : $data");
328 # TODO : re-enable this, currently it's not particularly useful
329 #$state->{validresponses} = [ split /\s+/, $data ];
332 # valid-requests \n
333 # Response expected: yes. Ask the server to send back a Valid-requests
334 # response.
335 sub req_validrequests
337 my ( $cmd, $data ) = @_;
339 $log->debug("req_validrequests");
341 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
342 $log->debug("SEND : ok");
344 print "Valid-requests " . join(" ",keys %$methods) . "\n";
345 print "ok\n";
348 # Directory local-directory \n
349 # Additional data: repository \n. Response expected: no. Tell the server
350 # what directory to use. The repository should be a directory name from a
351 # previous server response. Note that this both gives a default for Entry
352 # and Modified and also for ci and the other commands; normal usage is to
353 # send Directory for each directory in which there will be an Entry or
354 # Modified, and then a final Directory for the original directory, then the
355 # command. The local-directory is relative to the top level at which the
356 # command is occurring (i.e. the last Directory which is sent before the
357 # command); to indicate that top level, `.' should be sent for
358 # local-directory.
359 sub req_Directory
361 my ( $cmd, $data ) = @_;
363 my $repository = <STDIN>;
364 chomp $repository;
367 $state->{localdir} = $data;
368 $state->{repository} = $repository;
369 $state->{path} = $repository;
370 $state->{path} =~ s/^$state->{CVSROOT}\///;
371 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
372 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
374 $state->{directory} = $state->{localdir};
375 $state->{directory} = "" if ( $state->{directory} eq "." );
376 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
378 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
380 $log->info("Setting prepend to '$state->{path}'");
381 $state->{prependdir} = $state->{path};
382 foreach my $entry ( keys %{$state->{entries}} )
384 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
385 delete $state->{entries}{$entry};
389 if ( defined ( $state->{prependdir} ) )
391 $log->debug("Prepending '$state->{prependdir}' to state|directory");
392 $state->{directory} = $state->{prependdir} . $state->{directory}
394 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
397 # Entry entry-line \n
398 # Response expected: no. Tell the server what version of a file is on the
399 # local machine. The name in entry-line is a name relative to the directory
400 # most recently specified with Directory. If the user is operating on only
401 # some files in a directory, Entry requests for only those files need be
402 # included. If an Entry request is sent without Modified, Is-modified, or
403 # Unchanged, it means the file is lost (does not exist in the working
404 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
405 # are sent for the same file, Entry must be sent first. For a given file,
406 # one can send Modified, Is-modified, or Unchanged, but not more than one
407 # of these three.
408 sub req_Entry
410 my ( $cmd, $data ) = @_;
412 #$log->debug("req_Entry : $data");
414 my @data = split(/\//, $data);
416 $state->{entries}{$state->{directory}.$data[1]} = {
417 revision => $data[2],
418 conflict => $data[3],
419 options => $data[4],
420 tag_or_date => $data[5],
423 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
426 # Questionable filename \n
427 # Response expected: no. Additional data: no. Tell the server to check
428 # whether filename should be ignored, and if not, next time the server
429 # sends responses, send (in a M response) `?' followed by the directory and
430 # filename. filename must not contain `/'; it needs to be a file in the
431 # directory named by the most recent Directory request.
432 sub req_Questionable
434 my ( $cmd, $data ) = @_;
436 $log->debug("req_Questionable : $data");
437 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
440 # add \n
441 # Response expected: yes. Add a file or directory. This uses any previous
442 # Argument, Directory, Entry, or Modified requests, if they have been sent.
443 # The last Directory sent specifies the working directory at the time of
444 # the operation. To add a directory, send the directory to be added using
445 # Directory and Argument requests.
446 sub req_add
448 my ( $cmd, $data ) = @_;
450 argsplit("add");
452 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
453 $updater->update();
455 argsfromdir($updater);
457 my $addcount = 0;
459 foreach my $filename ( @{$state->{args}} )
461 $filename = filecleanup($filename);
463 my $meta = $updater->getmeta($filename);
464 my $wrev = revparse($filename);
466 if ($wrev && $meta && ($wrev < 0))
468 # previously removed file, add back
469 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
471 print "MT +updated\n";
472 print "MT text U \n";
473 print "MT fname $filename\n";
474 print "MT newline\n";
475 print "MT -updated\n";
477 unless ( $state->{globaloptions}{-n} )
479 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
481 print "Created $dirpart\n";
482 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
484 # this is an "entries" line
485 my $kopts = kopts_from_path($filepart);
486 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
487 print "/$filepart/1.$meta->{revision}//$kopts/\n";
488 # permissions
489 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
490 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
491 # transmit file
492 transmitfile($meta->{filehash});
495 next;
498 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
500 print "E cvs add: nothing known about `$filename'\n";
501 next;
503 # TODO : check we're not squashing an already existing file
504 if ( defined ( $state->{entries}{$filename}{revision} ) )
506 print "E cvs add: `$filename' has already been entered\n";
507 next;
510 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
512 print "E cvs add: scheduling file `$filename' for addition\n";
514 print "Checked-in $dirpart\n";
515 print "$filename\n";
516 my $kopts = kopts_from_path($filepart);
517 print "/$filepart/0//$kopts/\n";
519 $addcount++;
522 if ( $addcount == 1 )
524 print "E cvs add: use `cvs commit' to add this file permanently\n";
526 elsif ( $addcount > 1 )
528 print "E cvs add: use `cvs commit' to add these files permanently\n";
531 print "ok\n";
534 # remove \n
535 # Response expected: yes. Remove a file. This uses any previous Argument,
536 # Directory, Entry, or Modified requests, if they have been sent. The last
537 # Directory sent specifies the working directory at the time of the
538 # operation. Note that this request does not actually do anything to the
539 # repository; the only effect of a successful remove request is to supply
540 # the client with a new entries line containing `-' to indicate a removed
541 # file. In fact, the client probably could perform this operation without
542 # contacting the server, although using remove may cause the server to
543 # perform a few more checks. The client sends a subsequent ci request to
544 # actually record the removal in the repository.
545 sub req_remove
547 my ( $cmd, $data ) = @_;
549 argsplit("remove");
551 # Grab a handle to the SQLite db and do any necessary updates
552 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
553 $updater->update();
555 #$log->debug("add state : " . Dumper($state));
557 my $rmcount = 0;
559 foreach my $filename ( @{$state->{args}} )
561 $filename = filecleanup($filename);
563 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
565 print "E cvs remove: file `$filename' still in working directory\n";
566 next;
569 my $meta = $updater->getmeta($filename);
570 my $wrev = revparse($filename);
572 unless ( defined ( $wrev ) )
574 print "E cvs remove: nothing known about `$filename'\n";
575 next;
578 if ( defined($wrev) and $wrev < 0 )
580 print "E cvs remove: file `$filename' already scheduled for removal\n";
581 next;
584 unless ( $wrev == $meta->{revision} )
586 # TODO : not sure if the format of this message is quite correct.
587 print "E cvs remove: Up to date check failed for `$filename'\n";
588 next;
592 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
594 print "E cvs remove: scheduling `$filename' for removal\n";
596 print "Checked-in $dirpart\n";
597 print "$filename\n";
598 my $kopts = kopts_from_path($filepart);
599 print "/$filepart/-1.$wrev//$kopts/\n";
601 $rmcount++;
604 if ( $rmcount == 1 )
606 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
608 elsif ( $rmcount > 1 )
610 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
613 print "ok\n";
616 # Modified filename \n
617 # Response expected: no. Additional data: mode, \n, file transmission. Send
618 # the server a copy of one locally modified file. filename is a file within
619 # the most recent directory sent with Directory; it must not contain `/'.
620 # If the user is operating on only some files in a directory, only those
621 # files need to be included. This can also be sent without Entry, if there
622 # is no entry for the file.
623 sub req_Modified
625 my ( $cmd, $data ) = @_;
627 my $mode = <STDIN>;
628 defined $mode
629 or (print "E end of file reading mode for $data\n"), return;
630 chomp $mode;
631 my $size = <STDIN>;
632 defined $size
633 or (print "E end of file reading size of $data\n"), return;
634 chomp $size;
636 # Grab config information
637 my $blocksize = 8192;
638 my $bytesleft = $size;
639 my $tmp;
641 # Get a filehandle/name to write it to
642 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
644 # Loop over file data writing out to temporary file.
645 while ( $bytesleft )
647 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
648 read STDIN, $tmp, $blocksize;
649 print $fh $tmp;
650 $bytesleft -= $blocksize;
653 close $fh
654 or (print "E failed to write temporary, $filename: $!\n"), return;
656 # Ensure we have something sensible for the file mode
657 if ( $mode =~ /u=(\w+)/ )
659 $mode = $1;
660 } else {
661 $mode = "rw";
664 # Save the file data in $state
665 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
666 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
667 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
668 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
670 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
673 # Unchanged filename \n
674 # Response expected: no. Tell the server that filename has not been
675 # modified in the checked out directory. The filename is a file within the
676 # most recent directory sent with Directory; it must not contain `/'.
677 sub req_Unchanged
679 my ( $cmd, $data ) = @_;
681 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
683 #$log->debug("req_Unchanged : $data");
686 # Argument text \n
687 # Response expected: no. Save argument for use in a subsequent command.
688 # Arguments accumulate until an argument-using command is given, at which
689 # point they are forgotten.
690 # Argumentx text \n
691 # Response expected: no. Append \n followed by text to the current argument
692 # being saved.
693 sub req_Argument
695 my ( $cmd, $data ) = @_;
697 # Argumentx means: append to last Argument (with a newline in front)
699 $log->debug("$cmd : $data");
701 if ( $cmd eq 'Argumentx') {
702 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
703 } else {
704 push @{$state->{arguments}}, $data;
708 # expand-modules \n
709 # Response expected: yes. Expand the modules which are specified in the
710 # arguments. Returns the data in Module-expansion responses. Note that the
711 # server can assume that this is checkout or export, not rtag or rdiff; the
712 # latter do not access the working directory and thus have no need to
713 # expand modules on the client side. Expand may not be the best word for
714 # what this request does. It does not necessarily tell you all the files
715 # contained in a module, for example. Basically it is a way of telling you
716 # which working directories the server needs to know about in order to
717 # handle a checkout of the specified modules. For example, suppose that the
718 # server has a module defined by
719 # aliasmodule -a 1dir
720 # That is, one can check out aliasmodule and it will take 1dir in the
721 # repository and check it out to 1dir in the working directory. Now suppose
722 # the client already has this module checked out and is planning on using
723 # the co request to update it. Without using expand-modules, the client
724 # would have two bad choices: it could either send information about all
725 # working directories under the current directory, which could be
726 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
727 # stands for 1dir, and neglect to send information for 1dir, which would
728 # lead to incorrect operation. With expand-modules, the client would first
729 # ask for the module to be expanded:
730 sub req_expandmodules
732 my ( $cmd, $data ) = @_;
734 argsplit();
736 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
738 unless ( ref $state->{arguments} eq "ARRAY" )
740 print "ok\n";
741 return;
744 foreach my $module ( @{$state->{arguments}} )
746 $log->debug("SEND : Module-expansion $module");
747 print "Module-expansion $module\n";
750 print "ok\n";
751 statecleanup();
754 # co \n
755 # Response expected: yes. Get files from the repository. This uses any
756 # previous Argument, Directory, Entry, or Modified requests, if they have
757 # been sent. Arguments to this command are module names; the client cannot
758 # know what directories they correspond to except by (1) just sending the
759 # co request, and then seeing what directory names the server sends back in
760 # its responses, and (2) the expand-modules request.
761 sub req_co
763 my ( $cmd, $data ) = @_;
765 argsplit("co");
767 my $module = $state->{args}[0];
768 my $checkout_path = $module;
770 # use the user specified directory if we're given it
771 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
773 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
775 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
777 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
779 # Grab a handle to the SQLite db and do any necessary updates
780 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
781 $updater->update();
783 $checkout_path =~ s|/$||; # get rid of trailing slashes
785 # Eclipse seems to need the Clear-sticky command
786 # to prepare the 'Entries' file for the new directory.
787 print "Clear-sticky $checkout_path/\n";
788 print $state->{CVSROOT} . "/$module/\n";
789 print "Clear-static-directory $checkout_path/\n";
790 print $state->{CVSROOT} . "/$module/\n";
791 print "Clear-sticky $checkout_path/\n"; # yes, twice
792 print $state->{CVSROOT} . "/$module/\n";
793 print "Template $checkout_path/\n";
794 print $state->{CVSROOT} . "/$module/\n";
795 print "0\n";
797 # instruct the client that we're checking out to $checkout_path
798 print "E cvs checkout: Updating $checkout_path\n";
800 my %seendirs = ();
801 my $lastdir ='';
803 # recursive
804 sub prepdir {
805 my ($dir, $repodir, $remotedir, $seendirs) = @_;
806 my $parent = dirname($dir);
807 $dir =~ s|/+$||;
808 $repodir =~ s|/+$||;
809 $remotedir =~ s|/+$||;
810 $parent =~ s|/+$||;
811 $log->debug("announcedir $dir, $repodir, $remotedir" );
813 if ($parent eq '.' || $parent eq './') {
814 $parent = '';
816 # recurse to announce unseen parents first
817 if (length($parent) && !exists($seendirs->{$parent})) {
818 prepdir($parent, $repodir, $remotedir, $seendirs);
820 # Announce that we are going to modify at the parent level
821 if ($parent) {
822 print "E cvs checkout: Updating $remotedir/$parent\n";
823 } else {
824 print "E cvs checkout: Updating $remotedir\n";
826 print "Clear-sticky $remotedir/$parent/\n";
827 print "$repodir/$parent/\n";
829 print "Clear-static-directory $remotedir/$dir/\n";
830 print "$repodir/$dir/\n";
831 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
832 print "$repodir/$parent/\n";
833 print "Template $remotedir/$dir/\n";
834 print "$repodir/$dir/\n";
835 print "0\n";
837 $seendirs->{$dir} = 1;
840 foreach my $git ( @{$updater->gethead} )
842 # Don't want to check out deleted files
843 next if ( $git->{filehash} eq "deleted" );
845 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
847 if (length($git->{dir}) && $git->{dir} ne './'
848 && $git->{dir} ne $lastdir ) {
849 unless (exists($seendirs{$git->{dir}})) {
850 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
851 $checkout_path, \%seendirs);
852 $lastdir = $git->{dir};
853 $seendirs{$git->{dir}} = 1;
855 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
858 # modification time of this file
859 print "Mod-time $git->{modified}\n";
861 # print some information to the client
862 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
864 print "M U $checkout_path/$git->{dir}$git->{name}\n";
865 } else {
866 print "M U $checkout_path/$git->{name}\n";
869 # instruct client we're sending a file to put in this path
870 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
872 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
874 # this is an "entries" line
875 my $kopts = kopts_from_path($git->{name});
876 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
877 # permissions
878 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
880 # transmit file
881 transmitfile($git->{filehash});
884 print "ok\n";
886 statecleanup();
889 # update \n
890 # Response expected: yes. Actually do a cvs update command. This uses any
891 # previous Argument, Directory, Entry, or Modified requests, if they have
892 # been sent. The last Directory sent specifies the working directory at the
893 # time of the operation. The -I option is not used--files which the client
894 # can decide whether to ignore are not mentioned and the client sends the
895 # Questionable request for others.
896 sub req_update
898 my ( $cmd, $data ) = @_;
900 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
902 argsplit("update");
905 # It may just be a client exploring the available heads/modules
906 # in that case, list them as top level directories and leave it
907 # at that. Eclipse uses this technique to offer you a list of
908 # projects (heads in this case) to checkout.
910 if ($state->{module} eq '') {
911 my $heads_dir = $state->{CVSROOT} . '/refs/heads';
912 if (!opendir HEADS, $heads_dir) {
913 print "E [server aborted]: Failed to open directory, "
914 . "$heads_dir: $!\nerror\n";
915 return 0;
917 print "E cvs update: Updating .\n";
918 while (my $head = readdir(HEADS)) {
919 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
920 print "E cvs update: New directory `$head'\n";
923 closedir HEADS;
924 print "ok\n";
925 return 1;
929 # Grab a handle to the SQLite db and do any necessary updates
930 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
932 $updater->update();
934 argsfromdir($updater);
936 #$log->debug("update state : " . Dumper($state));
938 # foreach file specified on the command line ...
939 foreach my $filename ( @{$state->{args}} )
941 $filename = filecleanup($filename);
943 $log->debug("Processing file $filename");
945 # if we have a -C we should pretend we never saw modified stuff
946 if ( exists ( $state->{opt}{C} ) )
948 delete $state->{entries}{$filename}{modified_hash};
949 delete $state->{entries}{$filename}{modified_filename};
950 $state->{entries}{$filename}{unchanged} = 1;
953 my $meta;
954 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
956 $meta = $updater->getmeta($filename, $1);
957 } else {
958 $meta = $updater->getmeta($filename);
961 if ( ! defined $meta )
963 $meta = {
964 name => $filename,
965 revision => 0,
966 filehash => 'added'
970 my $oldmeta = $meta;
972 my $wrev = revparse($filename);
974 # If the working copy is an old revision, lets get that version too for comparison.
975 if ( defined($wrev) and $wrev != $meta->{revision} )
977 $oldmeta = $updater->getmeta($filename, $wrev);
980 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
982 # Files are up to date if the working copy and repo copy have the same revision,
983 # and the working copy is unmodified _and_ the user hasn't specified -C
984 next if ( defined ( $wrev )
985 and defined($meta->{revision})
986 and $wrev == $meta->{revision}
987 and $state->{entries}{$filename}{unchanged}
988 and not exists ( $state->{opt}{C} ) );
990 # If the working copy and repo copy have the same revision,
991 # but the working copy is modified, tell the client it's modified
992 if ( defined ( $wrev )
993 and defined($meta->{revision})
994 and $wrev == $meta->{revision}
995 and defined($state->{entries}{$filename}{modified_hash})
996 and not exists ( $state->{opt}{C} ) )
998 $log->info("Tell the client the file is modified");
999 print "MT text M \n";
1000 print "MT fname $filename\n";
1001 print "MT newline\n";
1002 next;
1005 if ( $meta->{filehash} eq "deleted" )
1007 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1009 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1011 print "E cvs update: `$filename' is no longer in the repository\n";
1012 # Don't want to actually _DO_ the update if -n specified
1013 unless ( $state->{globaloptions}{-n} ) {
1014 print "Removed $dirpart\n";
1015 print "$filepart\n";
1018 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1019 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1020 or $meta->{filehash} eq 'added' )
1022 # normal update, just send the new revision (either U=Update,
1023 # or A=Add, or R=Remove)
1024 if ( defined($wrev) && $wrev < 0 )
1026 $log->info("Tell the client the file is scheduled for removal");
1027 print "MT text R \n";
1028 print "MT fname $filename\n";
1029 print "MT newline\n";
1030 next;
1032 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1034 $log->info("Tell the client the file is scheduled for addition");
1035 print "MT text A \n";
1036 print "MT fname $filename\n";
1037 print "MT newline\n";
1038 next;
1041 else {
1042 $log->info("Updating '$filename' to ".$meta->{revision});
1043 print "MT +updated\n";
1044 print "MT text U \n";
1045 print "MT fname $filename\n";
1046 print "MT newline\n";
1047 print "MT -updated\n";
1050 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1052 # Don't want to actually _DO_ the update if -n specified
1053 unless ( $state->{globaloptions}{-n} )
1055 if ( defined ( $wrev ) )
1057 # instruct client we're sending a file to put in this path as a replacement
1058 print "Update-existing $dirpart\n";
1059 $log->debug("Updating existing file 'Update-existing $dirpart'");
1060 } else {
1061 # instruct client we're sending a file to put in this path as a new file
1062 print "Clear-static-directory $dirpart\n";
1063 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1064 print "Clear-sticky $dirpart\n";
1065 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1067 $log->debug("Creating new file 'Created $dirpart'");
1068 print "Created $dirpart\n";
1070 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1072 # this is an "entries" line
1073 my $kopts = kopts_from_path($filepart);
1074 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1075 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1077 # permissions
1078 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1079 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1081 # transmit file
1082 transmitfile($meta->{filehash});
1084 } else {
1085 $log->info("Updating '$filename'");
1086 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1088 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
1090 chdir $dir;
1091 my $file_local = $filepart . ".mine";
1092 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1093 my $file_old = $filepart . "." . $oldmeta->{revision};
1094 transmitfile($oldmeta->{filehash}, $file_old);
1095 my $file_new = $filepart . "." . $meta->{revision};
1096 transmitfile($meta->{filehash}, $file_new);
1098 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1099 $log->info("Merging $file_local, $file_old, $file_new");
1100 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1102 $log->debug("Temporary directory for merge is $dir");
1104 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1105 $return >>= 8;
1107 if ( $return == 0 )
1109 $log->info("Merged successfully");
1110 print "M M $filename\n";
1111 $log->debug("Merged $dirpart");
1113 # Don't want to actually _DO_ the update if -n specified
1114 unless ( $state->{globaloptions}{-n} )
1116 print "Merged $dirpart\n";
1117 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1118 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1119 my $kopts = kopts_from_path($filepart);
1120 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1121 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1124 elsif ( $return == 1 )
1126 $log->info("Merged with conflicts");
1127 print "E cvs update: conflicts found in $filename\n";
1128 print "M C $filename\n";
1130 # Don't want to actually _DO_ the update if -n specified
1131 unless ( $state->{globaloptions}{-n} )
1133 print "Merged $dirpart\n";
1134 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1135 my $kopts = kopts_from_path($filepart);
1136 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1139 else
1141 $log->warn("Merge failed");
1142 next;
1145 # Don't want to actually _DO_ the update if -n specified
1146 unless ( $state->{globaloptions}{-n} )
1148 # permissions
1149 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1150 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1152 # transmit file, format is single integer on a line by itself (file
1153 # size) followed by the file contents
1154 # TODO : we should copy files in blocks
1155 my $data = `cat $file_local`;
1156 $log->debug("File size : " . length($data));
1157 print length($data) . "\n";
1158 print $data;
1161 chdir "/";
1166 print "ok\n";
1169 sub req_ci
1171 my ( $cmd, $data ) = @_;
1173 argsplit("ci");
1175 #$log->debug("State : " . Dumper($state));
1177 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1179 if ( $state->{method} eq 'pserver')
1181 print "error 1 pserver access cannot commit\n";
1182 exit;
1185 if ( -e $state->{CVSROOT} . "/index" )
1187 $log->warn("file 'index' already exists in the git repository");
1188 print "error 1 Index already exists in git repo\n";
1189 exit;
1192 # Grab a handle to the SQLite db and do any necessary updates
1193 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1194 $updater->update();
1196 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1197 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1198 $log->info("Lockless commit start, basing commit on '$tmpdir', index file is '$file_index'");
1200 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1201 $ENV{GIT_WORK_TREE} = ".";
1202 $ENV{GIT_INDEX_FILE} = $file_index;
1204 # Remember where the head was at the beginning.
1205 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1206 chomp $parenthash;
1207 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1208 print "error 1 pserver cannot find the current HEAD of module";
1209 exit;
1212 chdir $tmpdir;
1214 # populate the temporary index
1215 system("git-read-tree", $parenthash);
1216 unless ($? == 0)
1218 die "Error running git-read-tree $state->{module} $file_index $!";
1220 $log->info("Created index '$file_index' for head $state->{module} - exit status $?");
1222 my @committedfiles = ();
1223 my %oldmeta;
1225 # foreach file specified on the command line ...
1226 foreach my $filename ( @{$state->{args}} )
1228 my $committedfile = $filename;
1229 $filename = filecleanup($filename);
1231 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1233 my $meta = $updater->getmeta($filename);
1234 $oldmeta{$filename} = $meta;
1236 my $wrev = revparse($filename);
1238 my ( $filepart, $dirpart ) = filenamesplit($filename);
1240 # do a checkout of the file if it is part of this tree
1241 if ($wrev) {
1242 system('git-checkout-index', '-f', '-u', $filename);
1243 unless ($? == 0) {
1244 die "Error running git-checkout-index -f -u $filename : $!";
1248 my $addflag = 0;
1249 my $rmflag = 0;
1250 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1251 $addflag = 1 unless ( -e $filename );
1253 # Do up to date checking
1254 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1256 # fail everything if an up to date check fails
1257 print "error 1 Up to date check failed for $filename\n";
1258 chdir "/";
1259 exit;
1262 push @committedfiles, $committedfile;
1263 $log->info("Committing $filename");
1265 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1267 unless ( $rmflag )
1269 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1270 rename $state->{entries}{$filename}{modified_filename},$filename;
1272 # Calculate modes to remove
1273 my $invmode = "";
1274 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1276 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1277 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1280 if ( $rmflag )
1282 $log->info("Removing file '$filename'");
1283 unlink($filename);
1284 system("git-update-index", "--remove", $filename);
1286 elsif ( $addflag )
1288 $log->info("Adding file '$filename'");
1289 system("git-update-index", "--add", $filename);
1290 } else {
1291 $log->info("Updating file '$filename'");
1292 system("git-update-index", $filename);
1296 unless ( scalar(@committedfiles) > 0 )
1298 print "E No files to commit\n";
1299 print "ok\n";
1300 chdir "/";
1301 return;
1304 my $treehash = `git-write-tree`;
1305 chomp $treehash;
1307 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1309 # write our commit message out if we have one ...
1310 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1311 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1312 print $msg_fh "\n\nvia git-CVS emulator\n";
1313 close $msg_fh;
1315 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1316 chomp($commithash);
1317 $log->info("Commit hash : $commithash");
1319 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1321 $log->warn("Commit failed (Invalid commit hash)");
1322 print "error 1 Commit failed (unknown reason)\n";
1323 chdir "/";
1324 exit;
1327 ### Emulate git-receive-pack by running hooks/update
1328 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1329 $parenthash, $commithash );
1330 if( -x $hook[0] ) {
1331 unless( system( @hook ) == 0 )
1333 $log->warn("Commit failed (update hook declined to update ref)");
1334 print "error 1 Commit failed (update hook declined)\n";
1335 chdir "/";
1336 exit;
1340 ### Update the ref
1341 if (system(qw(git update-ref -m), "cvsserver ci",
1342 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1343 $log->warn("update-ref for $state->{module} failed.");
1344 print "error 1 Cannot commit -- update first\n";
1345 exit;
1348 ### Emulate git-receive-pack by running hooks/post-receive
1349 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1350 if( -x $hook ) {
1351 open(my $pipe, "| $hook") || die "can't fork $!";
1353 local $SIG{PIPE} = sub { die 'pipe broke' };
1355 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1357 close $pipe || die "bad pipe: $! $?";
1360 ### Then hooks/post-update
1361 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1362 if (-x $hook) {
1363 system($hook, "refs/heads/$state->{module}");
1366 $updater->update();
1368 # foreach file specified on the command line ...
1369 foreach my $filename ( @committedfiles )
1371 $filename = filecleanup($filename);
1373 my $meta = $updater->getmeta($filename);
1374 unless (defined $meta->{revision}) {
1375 $meta->{revision} = 1;
1378 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1380 $log->debug("Checked-in $dirpart : $filename");
1382 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1383 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1385 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1386 print "Remove-entry $dirpart\n";
1387 print "$filename\n";
1388 } else {
1389 if ($meta->{revision} == 1) {
1390 print "M initial revision: 1.1\n";
1391 } else {
1392 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1394 print "Checked-in $dirpart\n";
1395 print "$filename\n";
1396 my $kopts = kopts_from_path($filepart);
1397 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1401 chdir "/";
1402 print "ok\n";
1405 sub req_status
1407 my ( $cmd, $data ) = @_;
1409 argsplit("status");
1411 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1412 #$log->debug("status state : " . Dumper($state));
1414 # Grab a handle to the SQLite db and do any necessary updates
1415 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1416 $updater->update();
1418 # if no files were specified, we need to work out what files we should be providing status on ...
1419 argsfromdir($updater);
1421 # foreach file specified on the command line ...
1422 foreach my $filename ( @{$state->{args}} )
1424 $filename = filecleanup($filename);
1426 my $meta = $updater->getmeta($filename);
1427 my $oldmeta = $meta;
1429 my $wrev = revparse($filename);
1431 # If the working copy is an old revision, lets get that version too for comparison.
1432 if ( defined($wrev) and $wrev != $meta->{revision} )
1434 $oldmeta = $updater->getmeta($filename, $wrev);
1437 # TODO : All possible statuses aren't yet implemented
1438 my $status;
1439 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1440 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1442 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1443 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1446 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1447 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1449 ( $state->{entries}{$filename}{unchanged}
1450 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1453 # Need checkout if it exists in the repo but doesn't have a working copy
1454 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1456 # Locally modified if working copy and repo copy have the same revision but there are local changes
1457 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1459 # Needs Merge if working copy revision is less than repo copy and there are local changes
1460 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1462 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1463 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1464 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1465 $status ||= "File had conflicts on merge" if ( 0 );
1467 $status ||= "Unknown";
1469 print "M ===================================================================\n";
1470 print "M File: $filename\tStatus: $status\n";
1471 if ( defined($state->{entries}{$filename}{revision}) )
1473 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1474 } else {
1475 print "M Working revision:\tNo entry for $filename\n";
1477 if ( defined($meta->{revision}) )
1479 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1480 print "M Sticky Tag:\t\t(none)\n";
1481 print "M Sticky Date:\t\t(none)\n";
1482 print "M Sticky Options:\t\t(none)\n";
1483 } else {
1484 print "M Repository revision:\tNo revision control file\n";
1486 print "M\n";
1489 print "ok\n";
1492 sub req_diff
1494 my ( $cmd, $data ) = @_;
1496 argsplit("diff");
1498 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1499 #$log->debug("status state : " . Dumper($state));
1501 my ($revision1, $revision2);
1502 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1504 $revision1 = $state->{opt}{r}[0];
1505 $revision2 = $state->{opt}{r}[1];
1506 } else {
1507 $revision1 = $state->{opt}{r};
1510 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1511 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1513 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1515 # Grab a handle to the SQLite db and do any necessary updates
1516 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1517 $updater->update();
1519 # if no files were specified, we need to work out what files we should be providing status on ...
1520 argsfromdir($updater);
1522 # foreach file specified on the command line ...
1523 foreach my $filename ( @{$state->{args}} )
1525 $filename = filecleanup($filename);
1527 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1529 my $wrev = revparse($filename);
1531 # We need _something_ to diff against
1532 next unless ( defined ( $wrev ) );
1534 # if we have a -r switch, use it
1535 if ( defined ( $revision1 ) )
1537 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1538 $meta1 = $updater->getmeta($filename, $revision1);
1539 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1541 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1542 next;
1544 transmitfile($meta1->{filehash}, $file1);
1546 # otherwise we just use the working copy revision
1547 else
1549 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1550 $meta1 = $updater->getmeta($filename, $wrev);
1551 transmitfile($meta1->{filehash}, $file1);
1554 # if we have a second -r switch, use it too
1555 if ( defined ( $revision2 ) )
1557 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1558 $meta2 = $updater->getmeta($filename, $revision2);
1560 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1562 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1563 next;
1566 transmitfile($meta2->{filehash}, $file2);
1568 # otherwise we just use the working copy
1569 else
1571 $file2 = $state->{entries}{$filename}{modified_filename};
1574 # if we have been given -r, and we don't have a $file2 yet, lets get one
1575 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1577 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1578 $meta2 = $updater->getmeta($filename, $wrev);
1579 transmitfile($meta2->{filehash}, $file2);
1582 # We need to have retrieved something useful
1583 next unless ( defined ( $meta1 ) );
1585 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1586 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1588 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1589 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1592 # Apparently we only show diffs for locally modified files
1593 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1595 print "M Index: $filename\n";
1596 print "M ===================================================================\n";
1597 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1598 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1599 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1600 print "M diff ";
1601 foreach my $opt ( keys %{$state->{opt}} )
1603 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1605 foreach my $value ( @{$state->{opt}{$opt}} )
1607 print "-$opt $value ";
1609 } else {
1610 print "-$opt ";
1611 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1614 print "$filename\n";
1616 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1618 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1620 if ( exists $state->{opt}{u} )
1622 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1623 } else {
1624 system("diff $file1 $file2 > $filediff");
1627 while ( <$fh> )
1629 print "M $_";
1631 close $fh;
1634 print "ok\n";
1637 sub req_log
1639 my ( $cmd, $data ) = @_;
1641 argsplit("log");
1643 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1644 #$log->debug("log state : " . Dumper($state));
1646 my ( $minrev, $maxrev );
1647 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1649 my $control = $2;
1650 $minrev = $1;
1651 $maxrev = $3;
1652 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1653 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1654 $minrev++ if ( defined($minrev) and $control eq "::" );
1657 # Grab a handle to the SQLite db and do any necessary updates
1658 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1659 $updater->update();
1661 # if no files were specified, we need to work out what files we should be providing status on ...
1662 argsfromdir($updater);
1664 # foreach file specified on the command line ...
1665 foreach my $filename ( @{$state->{args}} )
1667 $filename = filecleanup($filename);
1669 my $headmeta = $updater->getmeta($filename);
1671 my $revisions = $updater->getlog($filename);
1672 my $totalrevisions = scalar(@$revisions);
1674 if ( defined ( $minrev ) )
1676 $log->debug("Removing revisions less than $minrev");
1677 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1679 pop @$revisions;
1682 if ( defined ( $maxrev ) )
1684 $log->debug("Removing revisions greater than $maxrev");
1685 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1687 shift @$revisions;
1691 next unless ( scalar(@$revisions) );
1693 print "M \n";
1694 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1695 print "M Working file: $filename\n";
1696 print "M head: 1.$headmeta->{revision}\n";
1697 print "M branch:\n";
1698 print "M locks: strict\n";
1699 print "M access list:\n";
1700 print "M symbolic names:\n";
1701 print "M keyword substitution: kv\n";
1702 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1703 print "M description:\n";
1705 foreach my $revision ( @$revisions )
1707 print "M ----------------------------\n";
1708 print "M revision 1.$revision->{revision}\n";
1709 # reformat the date for log output
1710 $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}) );
1711 $revision->{author} =~ s/\s+.*//;
1712 $revision->{author} =~ s/^(.{8}).*/$1/;
1713 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1714 my $commitmessage = $updater->commitmessage($revision->{commithash});
1715 $commitmessage =~ s/^/M /mg;
1716 print $commitmessage . "\n";
1718 print "M =============================================================================\n";
1721 print "ok\n";
1724 sub req_annotate
1726 my ( $cmd, $data ) = @_;
1728 argsplit("annotate");
1730 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1731 #$log->debug("status state : " . Dumper($state));
1733 # Grab a handle to the SQLite db and do any necessary updates
1734 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1735 $updater->update();
1737 # if no files were specified, we need to work out what files we should be providing annotate on ...
1738 argsfromdir($updater);
1740 # we'll need a temporary checkout dir
1741 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1742 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1743 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1745 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1746 $ENV{GIT_WORK_TREE} = ".";
1747 $ENV{GIT_INDEX_FILE} = $file_index;
1749 chdir $tmpdir;
1751 # foreach file specified on the command line ...
1752 foreach my $filename ( @{$state->{args}} )
1754 $filename = filecleanup($filename);
1756 my $meta = $updater->getmeta($filename);
1758 next unless ( $meta->{revision} );
1760 # get all the commits that this file was in
1761 # in dense format -- aka skip dead revisions
1762 my $revisions = $updater->gethistorydense($filename);
1763 my $lastseenin = $revisions->[0][2];
1765 # populate the temporary index based on the latest commit were we saw
1766 # the file -- but do it cheaply without checking out any files
1767 # TODO: if we got a revision from the client, use that instead
1768 # to look up the commithash in sqlite (still good to default to
1769 # the current head as we do now)
1770 system("git-read-tree", $lastseenin);
1771 unless ($? == 0)
1773 print "E error running git-read-tree $lastseenin $file_index $!\n";
1774 return;
1776 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1778 # do a checkout of the file
1779 system('git-checkout-index', '-f', '-u', $filename);
1780 unless ($? == 0) {
1781 print "E error running git-checkout-index -f -u $filename : $!\n";
1782 return;
1785 $log->info("Annotate $filename");
1787 # Prepare a file with the commits from the linearized
1788 # history that annotate should know about. This prevents
1789 # git-jsannotate telling us about commits we are hiding
1790 # from the client.
1792 my $a_hints = "$tmpdir/.annotate_hints";
1793 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1794 print "E failed to open '$a_hints' for writing: $!\n";
1795 return;
1797 for (my $i=0; $i < @$revisions; $i++)
1799 print ANNOTATEHINTS $revisions->[$i][2];
1800 if ($i+1 < @$revisions) { # have we got a parent?
1801 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1803 print ANNOTATEHINTS "\n";
1806 print ANNOTATEHINTS "\n";
1807 close ANNOTATEHINTS
1808 or (print "E failed to write $a_hints: $!\n"), return;
1810 my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1811 if (!open(ANNOTATE, "-|", @cmd)) {
1812 print "E error invoking ". join(' ',@cmd) .": $!\n";
1813 return;
1815 my $metadata = {};
1816 print "E Annotations for $filename\n";
1817 print "E ***************\n";
1818 while ( <ANNOTATE> )
1820 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1822 my $commithash = $1;
1823 my $data = $2;
1824 unless ( defined ( $metadata->{$commithash} ) )
1826 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1827 $metadata->{$commithash}{author} =~ s/\s+.*//;
1828 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1829 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1831 printf("M 1.%-5d (%-8s %10s): %s\n",
1832 $metadata->{$commithash}{revision},
1833 $metadata->{$commithash}{author},
1834 $metadata->{$commithash}{modified},
1835 $data
1837 } else {
1838 $log->warn("Error in annotate output! LINE: $_");
1839 print "E Annotate error \n";
1840 next;
1843 close ANNOTATE;
1846 # done; get out of the tempdir
1847 chdir "/";
1849 print "ok\n";
1853 # This method takes the state->{arguments} array and produces two new arrays.
1854 # The first is $state->{args} which is everything before the '--' argument, and
1855 # the second is $state->{files} which is everything after it.
1856 sub argsplit
1858 $state->{args} = [];
1859 $state->{files} = [];
1860 $state->{opt} = {};
1862 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1864 my $type = shift;
1866 if ( defined($type) )
1868 my $opt = {};
1869 $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" );
1870 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1871 $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" );
1872 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1873 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1874 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1875 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1876 $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" );
1879 while ( scalar ( @{$state->{arguments}} ) > 0 )
1881 my $arg = shift @{$state->{arguments}};
1883 next if ( $arg eq "--" );
1884 next unless ( $arg =~ /\S/ );
1886 # if the argument looks like a switch
1887 if ( $arg =~ /^-(\w)(.*)/ )
1889 # if it's a switch that takes an argument
1890 if ( $opt->{$1} )
1892 # If this switch has already been provided
1893 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1895 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1896 if ( length($2) > 0 )
1898 push @{$state->{opt}{$1}},$2;
1899 } else {
1900 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1902 } else {
1903 # if there's extra data in the arg, use that as the argument for the switch
1904 if ( length($2) > 0 )
1906 $state->{opt}{$1} = $2;
1907 } else {
1908 $state->{opt}{$1} = shift @{$state->{arguments}};
1911 } else {
1912 $state->{opt}{$1} = undef;
1915 else
1917 push @{$state->{args}}, $arg;
1921 else
1923 my $mode = 0;
1925 foreach my $value ( @{$state->{arguments}} )
1927 if ( $value eq "--" )
1929 $mode++;
1930 next;
1932 push @{$state->{args}}, $value if ( $mode == 0 );
1933 push @{$state->{files}}, $value if ( $mode == 1 );
1938 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1939 sub argsfromdir
1941 my $updater = shift;
1943 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1945 return if ( scalar ( @{$state->{args}} ) > 1 );
1947 my @gethead = @{$updater->gethead};
1949 # push added files
1950 foreach my $file (keys %{$state->{entries}}) {
1951 if ( exists $state->{entries}{$file}{revision} &&
1952 $state->{entries}{$file}{revision} == 0 )
1954 push @gethead, { name => $file, filehash => 'added' };
1958 if ( scalar(@{$state->{args}}) == 1 )
1960 my $arg = $state->{args}[0];
1961 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1963 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1965 foreach my $file ( @gethead )
1967 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1968 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
1969 push @{$state->{args}}, $file->{name};
1972 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1973 } else {
1974 $log->info("Only one arg specified, populating file list automatically");
1976 $state->{args} = [];
1978 foreach my $file ( @gethead )
1980 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1981 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1982 push @{$state->{args}}, $file->{name};
1987 # This method cleans up the $state variable after a command that uses arguments has run
1988 sub statecleanup
1990 $state->{files} = [];
1991 $state->{args} = [];
1992 $state->{arguments} = [];
1993 $state->{entries} = {};
1996 sub revparse
1998 my $filename = shift;
2000 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2002 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2003 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2005 return undef;
2008 # This method takes a file hash and does a CVS "file transfer" which transmits the
2009 # size of the file, and then the file contents.
2010 # If a second argument $targetfile is given, the file is instead written out to
2011 # a file by the name of $targetfile
2012 sub transmitfile
2014 my $filehash = shift;
2015 my $targetfile = shift;
2017 if ( defined ( $filehash ) and $filehash eq "deleted" )
2019 $log->warn("filehash is 'deleted'");
2020 return;
2023 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2025 my $type = `git-cat-file -t $filehash`;
2026 chomp $type;
2028 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2030 my $size = `git-cat-file -s $filehash`;
2031 chomp $size;
2033 $log->debug("transmitfile($filehash) size=$size, type=$type");
2035 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2037 if ( defined ( $targetfile ) )
2039 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2040 print NEWFILE $_ while ( <$fh> );
2041 close NEWFILE or die("Failed to write '$targetfile': $!");
2042 } else {
2043 print "$size\n";
2044 print while ( <$fh> );
2046 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2047 } else {
2048 die("Couldn't execute git-cat-file");
2052 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2053 # refers to the directory portion and the file portion of the filename
2054 # respectively
2055 sub filenamesplit
2057 my $filename = shift;
2058 my $fixforlocaldir = shift;
2060 my ( $filepart, $dirpart ) = ( $filename, "." );
2061 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2062 $dirpart .= "/";
2064 if ( $fixforlocaldir )
2066 $dirpart =~ s/^$state->{prependdir}//;
2069 return ( $filepart, $dirpart );
2072 sub filecleanup
2074 my $filename = shift;
2076 return undef unless(defined($filename));
2077 if ( $filename =~ /^\// )
2079 print "E absolute filenames '$filename' not supported by server\n";
2080 return undef;
2083 $filename =~ s/^\.\///g;
2084 $filename = $state->{prependdir} . $filename;
2085 return $filename;
2088 # Given a path, this function returns a string containing the kopts
2089 # that should go into that path's Entries line. For example, a binary
2090 # file should get -kb.
2091 sub kopts_from_path
2093 my ($path) = @_;
2095 # Once it exists, the git attributes system should be used to look up
2096 # what attributes apply to this path.
2098 # Until then, take the setting from the config file
2099 unless ( defined ( $cfg->{gitcvs}{allbinary} ) and $cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i )
2101 # Return "" to give no special treatment to any path
2102 return "";
2103 } else {
2104 # Alternatively, to have all files treated as if they are binary (which
2105 # is more like git itself), always return the "-kb" option
2106 return "-kb";
2110 package GITCVS::log;
2112 ####
2113 #### Copyright The Open University UK - 2006.
2114 ####
2115 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2116 #### Martin Langhoff <martin@catalyst.net.nz>
2117 ####
2118 ####
2120 use strict;
2121 use warnings;
2123 =head1 NAME
2125 GITCVS::log
2127 =head1 DESCRIPTION
2129 This module provides very crude logging with a similar interface to
2130 Log::Log4perl
2132 =head1 METHODS
2134 =cut
2136 =head2 new
2138 Creates a new log object, optionally you can specify a filename here to
2139 indicate the file to log to. If no log file is specified, you can specify one
2140 later with method setfile, or indicate you no longer want logging with method
2141 nofile.
2143 Until one of these methods is called, all log calls will buffer messages ready
2144 to write out.
2146 =cut
2147 sub new
2149 my $class = shift;
2150 my $filename = shift;
2152 my $self = {};
2154 bless $self, $class;
2156 if ( defined ( $filename ) )
2158 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2161 return $self;
2164 =head2 setfile
2166 This methods takes a filename, and attempts to open that file as the log file.
2167 If successful, all buffered data is written out to the file, and any further
2168 logging is written directly to the file.
2170 =cut
2171 sub setfile
2173 my $self = shift;
2174 my $filename = shift;
2176 if ( defined ( $filename ) )
2178 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2181 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2183 while ( my $line = shift @{$self->{buffer}} )
2185 print {$self->{fh}} $line;
2189 =head2 nofile
2191 This method indicates no logging is going to be used. It flushes any entries in
2192 the internal buffer, and sets a flag to ensure no further data is put there.
2194 =cut
2195 sub nofile
2197 my $self = shift;
2199 $self->{nolog} = 1;
2201 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2203 $self->{buffer} = [];
2206 =head2 _logopen
2208 Internal method. Returns true if the log file is open, false otherwise.
2210 =cut
2211 sub _logopen
2213 my $self = shift;
2215 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2216 return 0;
2219 =head2 debug info warn fatal
2221 These four methods are wrappers to _log. They provide the actual interface for
2222 logging data.
2224 =cut
2225 sub debug { my $self = shift; $self->_log("debug", @_); }
2226 sub info { my $self = shift; $self->_log("info" , @_); }
2227 sub warn { my $self = shift; $self->_log("warn" , @_); }
2228 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2230 =head2 _log
2232 This is an internal method called by the logging functions. It generates a
2233 timestamp and pushes the logged line either to file, or internal buffer.
2235 =cut
2236 sub _log
2238 my $self = shift;
2239 my $level = shift;
2241 return if ( $self->{nolog} );
2243 my @time = localtime;
2244 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2245 $time[5] + 1900,
2246 $time[4] + 1,
2247 $time[3],
2248 $time[2],
2249 $time[1],
2250 $time[0],
2251 uc $level,
2254 if ( $self->_logopen )
2256 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2257 } else {
2258 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2262 =head2 DESTROY
2264 This method simply closes the file handle if one is open
2266 =cut
2267 sub DESTROY
2269 my $self = shift;
2271 if ( $self->_logopen )
2273 close $self->{fh};
2277 package GITCVS::updater;
2279 ####
2280 #### Copyright The Open University UK - 2006.
2281 ####
2282 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2283 #### Martin Langhoff <martin@catalyst.net.nz>
2284 ####
2285 ####
2287 use strict;
2288 use warnings;
2289 use DBI;
2291 =head1 METHODS
2293 =cut
2295 =head2 new
2297 =cut
2298 sub new
2300 my $class = shift;
2301 my $config = shift;
2302 my $module = shift;
2303 my $log = shift;
2305 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2306 die "Need to specify a module" unless ( defined($module) );
2308 $class = ref($class) || $class;
2310 my $self = {};
2312 bless $self, $class;
2314 $self->{module} = $module;
2315 $self->{git_path} = $config . "/";
2317 $self->{log} = $log;
2319 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2321 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2322 $cfg->{gitcvs}{dbdriver} || "SQLite";
2323 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2324 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2325 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2326 $cfg->{gitcvs}{dbuser} || "";
2327 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2328 $cfg->{gitcvs}{dbpass} || "";
2329 my %mapping = ( m => $module,
2330 a => $state->{method},
2331 u => getlogin || getpwuid($<) || $<,
2332 G => $self->{git_path},
2333 g => mangle_dirname($self->{git_path}),
2335 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2336 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2338 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2339 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2340 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2341 $self->{dbuser},
2342 $self->{dbpass});
2343 die "Error connecting to database\n" unless defined $self->{dbh};
2345 $self->{tables} = {};
2346 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2348 $self->{tables}{$table} = 1;
2351 # Construct the revision table if required
2352 unless ( $self->{tables}{revision} )
2354 $self->{dbh}->do("
2355 CREATE TABLE revision (
2356 name TEXT NOT NULL,
2357 revision INTEGER NOT NULL,
2358 filehash TEXT NOT NULL,
2359 commithash TEXT NOT NULL,
2360 author TEXT NOT NULL,
2361 modified TEXT NOT NULL,
2362 mode TEXT NOT NULL
2365 $self->{dbh}->do("
2366 CREATE INDEX revision_ix1
2367 ON revision (name,revision)
2369 $self->{dbh}->do("
2370 CREATE INDEX revision_ix2
2371 ON revision (name,commithash)
2375 # Construct the head table if required
2376 unless ( $self->{tables}{head} )
2378 $self->{dbh}->do("
2379 CREATE TABLE head (
2380 name TEXT NOT NULL,
2381 revision INTEGER NOT NULL,
2382 filehash TEXT NOT NULL,
2383 commithash TEXT NOT NULL,
2384 author TEXT NOT NULL,
2385 modified TEXT NOT NULL,
2386 mode TEXT NOT NULL
2389 $self->{dbh}->do("
2390 CREATE INDEX head_ix1
2391 ON head (name)
2395 # Construct the properties table if required
2396 unless ( $self->{tables}{properties} )
2398 $self->{dbh}->do("
2399 CREATE TABLE properties (
2400 key TEXT NOT NULL PRIMARY KEY,
2401 value TEXT
2406 # Construct the commitmsgs table if required
2407 unless ( $self->{tables}{commitmsgs} )
2409 $self->{dbh}->do("
2410 CREATE TABLE commitmsgs (
2411 key TEXT NOT NULL PRIMARY KEY,
2412 value TEXT
2417 return $self;
2420 =head2 update
2422 =cut
2423 sub update
2425 my $self = shift;
2427 # first lets get the commit list
2428 $ENV{GIT_DIR} = $self->{git_path};
2430 my $commitsha1 = `git rev-parse $self->{module}`;
2431 chomp $commitsha1;
2433 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2434 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2436 die("Invalid module '$self->{module}'");
2440 my $git_log;
2441 my $lastcommit = $self->_get_prop("last_commit");
2443 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2444 return 1;
2447 # Start exclusive lock here...
2448 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2450 # TODO: log processing is memory bound
2451 # if we can parse into a 2nd file that is in reverse order
2452 # we can probably do something really efficient
2453 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2455 if (defined $lastcommit) {
2456 push @git_log_params, "$lastcommit..$self->{module}";
2457 } else {
2458 push @git_log_params, $self->{module};
2460 # git-rev-list is the backend / plumbing version of git-log
2461 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2463 my @commits;
2465 my %commit = ();
2467 while ( <GITLOG> )
2469 chomp;
2470 if (m/^commit\s+(.*)$/) {
2471 # on ^commit lines put the just seen commit in the stack
2472 # and prime things for the next one
2473 if (keys %commit) {
2474 my %copy = %commit;
2475 unshift @commits, \%copy;
2476 %commit = ();
2478 my @parents = split(m/\s+/, $1);
2479 $commit{hash} = shift @parents;
2480 $commit{parents} = \@parents;
2481 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2482 # on rfc822-like lines seen before we see any message,
2483 # lowercase the entry and put it in the hash as key-value
2484 $commit{lc($1)} = $2;
2485 } else {
2486 # message lines - skip initial empty line
2487 # and trim whitespace
2488 if (!exists($commit{message}) && m/^\s*$/) {
2489 # define it to mark the end of headers
2490 $commit{message} = '';
2491 next;
2493 s/^\s+//; s/\s+$//; # trim ws
2494 $commit{message} .= $_ . "\n";
2497 close GITLOG;
2499 unshift @commits, \%commit if ( keys %commit );
2501 # Now all the commits are in the @commits bucket
2502 # ordered by time DESC. for each commit that needs processing,
2503 # determine whether it's following the last head we've seen or if
2504 # it's on its own branch, grab a file list, and add whatever's changed
2505 # NOTE: $lastcommit refers to the last commit from previous run
2506 # $lastpicked is the last commit we picked in this run
2507 my $lastpicked;
2508 my $head = {};
2509 if (defined $lastcommit) {
2510 $lastpicked = $lastcommit;
2513 my $committotal = scalar(@commits);
2514 my $commitcount = 0;
2516 # Load the head table into $head (for cached lookups during the update process)
2517 foreach my $file ( @{$self->gethead()} )
2519 $head->{$file->{name}} = $file;
2522 foreach my $commit ( @commits )
2524 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2525 if (defined $lastpicked)
2527 if (!in_array($lastpicked, @{$commit->{parents}}))
2529 # skip, we'll see this delta
2530 # as part of a merge later
2531 # warn "skipping off-track $commit->{hash}\n";
2532 next;
2533 } elsif (@{$commit->{parents}} > 1) {
2534 # it is a merge commit, for each parent that is
2535 # not $lastpicked, see if we can get a log
2536 # from the merge-base to that parent to put it
2537 # in the message as a merge summary.
2538 my @parents = @{$commit->{parents}};
2539 foreach my $parent (@parents) {
2540 # git-merge-base can potentially (but rarely) throw
2541 # several candidate merge bases. let's assume
2542 # that the first one is the best one.
2543 if ($parent eq $lastpicked) {
2544 next;
2546 my $base = safe_pipe_capture('git-merge-base',
2547 $lastpicked, $parent);
2548 chomp $base;
2549 if ($base) {
2550 my @merged;
2551 # print "want to log between $base $parent \n";
2552 open(GITLOG, '-|', 'git-log', "$base..$parent")
2553 or die "Cannot call git-log: $!";
2554 my $mergedhash;
2555 while (<GITLOG>) {
2556 chomp;
2557 if (!defined $mergedhash) {
2558 if (m/^commit\s+(.+)$/) {
2559 $mergedhash = $1;
2560 } else {
2561 next;
2563 } else {
2564 # grab the first line that looks non-rfc822
2565 # aka has content after leading space
2566 if (m/^\s+(\S.*)$/) {
2567 my $title = $1;
2568 $title = substr($title,0,100); # truncate
2569 unshift @merged, "$mergedhash $title";
2570 undef $mergedhash;
2574 close GITLOG;
2575 if (@merged) {
2576 $commit->{mergemsg} = $commit->{message};
2577 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2578 foreach my $summary (@merged) {
2579 $commit->{mergemsg} .= "\t$summary\n";
2581 $commit->{mergemsg} .= "\n\n";
2582 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2589 # convert the date to CVS-happy format
2590 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2592 if ( defined ( $lastpicked ) )
2594 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2595 local ($/) = "\0";
2596 while ( <FILELIST> )
2598 chomp;
2599 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
2601 die("Couldn't process git-diff-tree line : $_");
2603 my ($mode, $hash, $change) = ($1, $2, $3);
2604 my $name = <FILELIST>;
2605 chomp($name);
2607 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
2609 my $git_perms = "";
2610 $git_perms .= "r" if ( $mode & 4 );
2611 $git_perms .= "w" if ( $mode & 2 );
2612 $git_perms .= "x" if ( $mode & 1 );
2613 $git_perms = "rw" if ( $git_perms eq "" );
2615 if ( $change eq "D" )
2617 #$log->debug("DELETE $name");
2618 $head->{$name} = {
2619 name => $name,
2620 revision => $head->{$name}{revision} + 1,
2621 filehash => "deleted",
2622 commithash => $commit->{hash},
2623 modified => $commit->{date},
2624 author => $commit->{author},
2625 mode => $git_perms,
2627 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2629 elsif ( $change eq "M" )
2631 #$log->debug("MODIFIED $name");
2632 $head->{$name} = {
2633 name => $name,
2634 revision => $head->{$name}{revision} + 1,
2635 filehash => $hash,
2636 commithash => $commit->{hash},
2637 modified => $commit->{date},
2638 author => $commit->{author},
2639 mode => $git_perms,
2641 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2643 elsif ( $change eq "A" )
2645 #$log->debug("ADDED $name");
2646 $head->{$name} = {
2647 name => $name,
2648 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
2649 filehash => $hash,
2650 commithash => $commit->{hash},
2651 modified => $commit->{date},
2652 author => $commit->{author},
2653 mode => $git_perms,
2655 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2657 else
2659 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
2660 die;
2663 close FILELIST;
2664 } else {
2665 # this is used to detect files removed from the repo
2666 my $seen_files = {};
2668 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2669 local $/ = "\0";
2670 while ( <FILELIST> )
2672 chomp;
2673 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
2675 die("Couldn't process git-ls-tree line : $_");
2678 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2680 $seen_files->{$git_filename} = 1;
2682 my ( $oldhash, $oldrevision, $oldmode ) = (
2683 $head->{$git_filename}{filehash},
2684 $head->{$git_filename}{revision},
2685 $head->{$git_filename}{mode}
2688 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2690 $git_perms = "";
2691 $git_perms .= "r" if ( $1 & 4 );
2692 $git_perms .= "w" if ( $1 & 2 );
2693 $git_perms .= "x" if ( $1 & 1 );
2694 } else {
2695 $git_perms = "rw";
2698 # unless the file exists with the same hash, we need to update it ...
2699 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2701 my $newrevision = ( $oldrevision or 0 ) + 1;
2703 $head->{$git_filename} = {
2704 name => $git_filename,
2705 revision => $newrevision,
2706 filehash => $git_hash,
2707 commithash => $commit->{hash},
2708 modified => $commit->{date},
2709 author => $commit->{author},
2710 mode => $git_perms,
2714 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2717 close FILELIST;
2719 # Detect deleted files
2720 foreach my $file ( keys %$head )
2722 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2724 $head->{$file}{revision}++;
2725 $head->{$file}{filehash} = "deleted";
2726 $head->{$file}{commithash} = $commit->{hash};
2727 $head->{$file}{modified} = $commit->{date};
2728 $head->{$file}{author} = $commit->{author};
2730 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2733 # END : "Detect deleted files"
2737 if (exists $commit->{mergemsg})
2739 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
2742 $lastpicked = $commit->{hash};
2744 $self->_set_prop("last_commit", $commit->{hash});
2747 $self->delete_head();
2748 foreach my $file ( keys %$head )
2750 $self->insert_head(
2751 $file,
2752 $head->{$file}{revision},
2753 $head->{$file}{filehash},
2754 $head->{$file}{commithash},
2755 $head->{$file}{modified},
2756 $head->{$file}{author},
2757 $head->{$file}{mode},
2760 # invalidate the gethead cache
2761 $self->{gethead_cache} = undef;
2764 # Ending exclusive lock here
2765 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2768 sub insert_rev
2770 my $self = shift;
2771 my $name = shift;
2772 my $revision = shift;
2773 my $filehash = shift;
2774 my $commithash = shift;
2775 my $modified = shift;
2776 my $author = shift;
2777 my $mode = shift;
2779 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2780 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2783 sub insert_mergelog
2785 my $self = shift;
2786 my $key = shift;
2787 my $value = shift;
2789 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2790 $insert_mergelog->execute($key, $value);
2793 sub delete_head
2795 my $self = shift;
2797 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2798 $delete_head->execute();
2801 sub insert_head
2803 my $self = shift;
2804 my $name = shift;
2805 my $revision = shift;
2806 my $filehash = shift;
2807 my $commithash = shift;
2808 my $modified = shift;
2809 my $author = shift;
2810 my $mode = shift;
2812 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2813 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
2816 sub _headrev
2818 my $self = shift;
2819 my $filename = shift;
2821 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2822 $db_query->execute($filename);
2823 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2825 return ( $hash, $revision, $mode );
2828 sub _get_prop
2830 my $self = shift;
2831 my $key = shift;
2833 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2834 $db_query->execute($key);
2835 my ( $value ) = $db_query->fetchrow_array;
2837 return $value;
2840 sub _set_prop
2842 my $self = shift;
2843 my $key = shift;
2844 my $value = shift;
2846 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2847 $db_query->execute($value, $key);
2849 unless ( $db_query->rows )
2851 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2852 $db_query->execute($key, $value);
2855 return $value;
2858 =head2 gethead
2860 =cut
2862 sub gethead
2864 my $self = shift;
2866 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2868 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2869 $db_query->execute();
2871 my $tree = [];
2872 while ( my $file = $db_query->fetchrow_hashref )
2874 push @$tree, $file;
2877 $self->{gethead_cache} = $tree;
2879 return $tree;
2882 =head2 getlog
2884 =cut
2886 sub getlog
2888 my $self = shift;
2889 my $filename = shift;
2891 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2892 $db_query->execute($filename);
2894 my $tree = [];
2895 while ( my $file = $db_query->fetchrow_hashref )
2897 push @$tree, $file;
2900 return $tree;
2903 =head2 getmeta
2905 This function takes a filename (with path) argument and returns a hashref of
2906 metadata for that file.
2908 =cut
2910 sub getmeta
2912 my $self = shift;
2913 my $filename = shift;
2914 my $revision = shift;
2916 my $db_query;
2917 if ( defined($revision) and $revision =~ /^\d+$/ )
2919 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2920 $db_query->execute($filename, $revision);
2922 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2924 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2925 $db_query->execute($filename, $revision);
2926 } else {
2927 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2928 $db_query->execute($filename);
2931 return $db_query->fetchrow_hashref;
2934 =head2 commitmessage
2936 this function takes a commithash and returns the commit message for that commit
2938 =cut
2939 sub commitmessage
2941 my $self = shift;
2942 my $commithash = shift;
2944 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2946 my $db_query;
2947 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2948 $db_query->execute($commithash);
2950 my ( $message ) = $db_query->fetchrow_array;
2952 if ( defined ( $message ) )
2954 $message .= " " if ( $message =~ /\n$/ );
2955 return $message;
2958 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2959 shift @lines while ( $lines[0] =~ /\S/ );
2960 $message = join("",@lines);
2961 $message .= " " if ( $message =~ /\n$/ );
2962 return $message;
2965 =head2 gethistory
2967 This function takes a filename (with path) argument and returns an arrayofarrays
2968 containing revision,filehash,commithash ordered by revision descending
2970 =cut
2971 sub gethistory
2973 my $self = shift;
2974 my $filename = shift;
2976 my $db_query;
2977 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2978 $db_query->execute($filename);
2980 return $db_query->fetchall_arrayref;
2983 =head2 gethistorydense
2985 This function takes a filename (with path) argument and returns an arrayofarrays
2986 containing revision,filehash,commithash ordered by revision descending.
2988 This version of gethistory skips deleted entries -- so it is useful for annotate.
2989 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2990 and other git tools that depend on it.
2992 =cut
2993 sub gethistorydense
2995 my $self = shift;
2996 my $filename = shift;
2998 my $db_query;
2999 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3000 $db_query->execute($filename);
3002 return $db_query->fetchall_arrayref;
3005 =head2 in_array()
3007 from Array::PAT - mimics the in_array() function
3008 found in PHP. Yuck but works for small arrays.
3010 =cut
3011 sub in_array
3013 my ($check, @array) = @_;
3014 my $retval = 0;
3015 foreach my $test (@array){
3016 if($check eq $test){
3017 $retval = 1;
3020 return $retval;
3023 =head2 safe_pipe_capture
3025 an alternative to `command` that allows input to be passed as an array
3026 to work around shell problems with weird characters in arguments
3028 =cut
3029 sub safe_pipe_capture {
3031 my @output;
3033 if (my $pid = open my $child, '-|') {
3034 @output = (<$child>);
3035 close $child or die join(' ',@_).": $! $?";
3036 } else {
3037 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3039 return wantarray ? @output : join('',@output);
3042 =head2 mangle_dirname
3044 create a string from a directory name that is suitable to use as
3045 part of a filename, mainly by converting all chars except \w.- to _
3047 =cut
3048 sub mangle_dirname {
3049 my $dirname = shift;
3050 return unless defined $dirname;
3052 $dirname =~ s/[^\w.-]/_/g;
3054 return $dirname;