23b8ed398f7cb4588e5fe2613ded4514d46e8c84
[git/git.git] / git-cvsserver.perl
1 #!/usr/bin/perl
2
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 ####
17
18 use strict;
19 use warnings;
20 use bytes;
21
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Path qw/rmtree/;
25 use File::Basename;
26 use Getopt::Long qw(:config require_order no_ignore_case);
27
28 my $VERSION = '@@GIT_VERSION@@';
29
30 my $log = GITCVS::log->new();
31 my $cfg;
32
33 my $DATE_LIST = {
34 Jan => "01",
35 Feb => "02",
36 Mar => "03",
37 Apr => "04",
38 May => "05",
39 Jun => "06",
40 Jul => "07",
41 Aug => "08",
42 Sep => "09",
43 Oct => "10",
44 Nov => "11",
45 Dec => "12",
46 };
47
48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
49 $| = 1;
50
51 #### Definition and mappings of functions ####
52
53 my $methods = {
54 'Root' => \&req_Root,
55 'Valid-responses' => \&req_Validresponses,
56 'valid-requests' => \&req_validrequests,
57 'Directory' => \&req_Directory,
58 'Entry' => \&req_Entry,
59 'Modified' => \&req_Modified,
60 'Unchanged' => \&req_Unchanged,
61 'Questionable' => \&req_Questionable,
62 'Argument' => \&req_Argument,
63 'Argumentx' => \&req_Argument,
64 'expand-modules' => \&req_expandmodules,
65 'add' => \&req_add,
66 'remove' => \&req_remove,
67 'co' => \&req_co,
68 'update' => \&req_update,
69 'ci' => \&req_ci,
70 'diff' => \&req_diff,
71 'log' => \&req_log,
72 'rlog' => \&req_log,
73 'tag' => \&req_CATCHALL,
74 'status' => \&req_status,
75 'admin' => \&req_CATCHALL,
76 'history' => \&req_CATCHALL,
77 'watchers' => \&req_EMPTY,
78 'editors' => \&req_EMPTY,
79 'annotate' => \&req_annotate,
80 'Global_option' => \&req_Globaloption,
81 #'annotate' => \&req_CATCHALL,
82 };
83
84 ##############################################
85
86
87 # $state holds all the bits of information the clients sends us that could
88 # potentially be useful when it comes to actually _doing_ something.
89 my $state = { prependdir => '' };
90
91 # Work is for managing temporary working directory
92 my $work =
93 {
94 state => undef, # undef, 1 (empty), 2 (with stuff)
95 workDir => undef,
96 index => undef,
97 emptyDir => undef,
98 tmpDir => undef
99 };
100
101 $log->info("--------------- STARTING -----------------");
102
103 my $usage =
104 "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
105 " --base-path <path> : Prepend to requested CVSROOT\n".
106 " --strict-paths : Don't allow recursing into subdirectories\n".
107 " --export-all : Don't check for gitcvs.enabled in config\n".
108 " --version, -V : Print version information and exit\n".
109 " --help, -h, -H : Print usage information and exit\n".
110 "\n".
111 "<directory> ... is a list of allowed directories. If no directories\n".
112 "are given, all are allowed. This is an additional restriction, gitcvs\n".
113 "access still needs to be enabled by the gitcvs.enabled config option.\n";
114
115 my @opts = ( 'help|h|H', 'version|V',
116 'base-path=s', 'strict-paths', 'export-all' );
117 GetOptions( $state, @opts )
118 or die $usage;
119
120 if ($state->{version}) {
121 print "git-cvsserver version $VERSION\n";
122 exit;
123 }
124 if ($state->{help}) {
125 print $usage;
126 exit;
127 }
128
129 my $TEMP_DIR = tempdir( CLEANUP => 1 );
130 $log->debug("Temporary directory is '$TEMP_DIR'");
131
132 $state->{method} = 'ext';
133 if (@ARGV) {
134 if ($ARGV[0] eq 'pserver') {
135 $state->{method} = 'pserver';
136 shift @ARGV;
137 } elsif ($ARGV[0] eq 'server') {
138 shift @ARGV;
139 }
140 }
141
142 # everything else is a directory
143 $state->{allowed_roots} = [ @ARGV ];
144
145 # don't export the whole system unless the users requests it
146 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
147 die "--export-all can only be used together with an explicit whitelist\n";
148 }
149
150 # if we are called with a pserver argument,
151 # deal with the authentication cat before entering the
152 # main loop
153 if ($state->{method} eq 'pserver') {
154 my $line = <STDIN>; chomp $line;
155 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
156 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
157 }
158 my $request = $1;
159 $line = <STDIN>; chomp $line;
160 unless (req_Root('root', $line)) { # reuse Root
161 print "E Invalid root $line \n";
162 exit 1;
163 }
164 $line = <STDIN>; chomp $line;
165 unless ($line eq 'anonymous') {
166 print "E Only anonymous user allowed via pserver\n";
167 print "I HATE YOU\n";
168 exit 1;
169 }
170 $line = <STDIN>; chomp $line; # validate the password?
171 $line = <STDIN>; chomp $line;
172 unless ($line eq "END $request REQUEST") {
173 die "E Do not understand $line -- expecting END $request REQUEST\n";
174 }
175 print "I LOVE YOU\n";
176 exit if $request eq 'VERIFICATION'; # cvs login
177 # and now back to our regular programme...
178 }
179
180 # Keep going until the client closes the connection
181 while (<STDIN>)
182 {
183 chomp;
184
185 # Check to see if we've seen this method, and call appropriate function.
186 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
187 {
188 # use the $methods hash to call the appropriate sub for this command
189 #$log->info("Method : $1");
190 &{$methods->{$1}}($1,$2);
191 } else {
192 # log fatal because we don't understand this function. If this happens
193 # we're fairly screwed because we don't know if the client is expecting
194 # a response. If it is, the client will hang, we'll hang, and the whole
195 # thing will be custard.
196 $log->fatal("Don't understand command $_\n");
197 die("Unknown command $_");
198 }
199 }
200
201 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
202 $log->info("--------------- FINISH -----------------");
203
204 chdir '/';
205 exit 0;
206
207 # Magic catchall method.
208 # This is the method that will handle all commands we haven't yet
209 # implemented. It simply sends a warning to the log file indicating a
210 # command that hasn't been implemented has been invoked.
211 sub req_CATCHALL
212 {
213 my ( $cmd, $data ) = @_;
214 $log->warn("Unhandled command : req_$cmd : $data");
215 }
216
217 # This method invariably succeeds with an empty response.
218 sub req_EMPTY
219 {
220 print "ok\n";
221 }
222
223 # Root pathname \n
224 # Response expected: no. Tell the server which CVSROOT to use. Note that
225 # pathname is a local directory and not a fully qualified CVSROOT variable.
226 # pathname must already exist; if creating a new root, use the init
227 # request, not Root. pathname does not include the hostname of the server,
228 # how to access the server, etc.; by the time the CVS protocol is in use,
229 # connection, authentication, etc., are already taken care of. The Root
230 # request must be sent only once, and it must be sent before any requests
231 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
232 sub req_Root
233 {
234 my ( $cmd, $data ) = @_;
235 $log->debug("req_Root : $data");
236
237 unless ($data =~ m#^/#) {
238 print "error 1 Root must be an absolute pathname\n";
239 return 0;
240 }
241
242 my $cvsroot = $state->{'base-path'} || '';
243 $cvsroot =~ s#/+$##;
244 $cvsroot .= $data;
245
246 if ($state->{CVSROOT}
247 && ($state->{CVSROOT} ne $cvsroot)) {
248 print "error 1 Conflicting roots specified\n";
249 return 0;
250 }
251
252 $state->{CVSROOT} = $cvsroot;
253
254 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
255
256 if (@{$state->{allowed_roots}}) {
257 my $allowed = 0;
258 foreach my $dir (@{$state->{allowed_roots}}) {
259 next unless $dir =~ m#^/#;
260 $dir =~ s#/+$##;
261 if ($state->{'strict-paths'}) {
262 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
263 $allowed = 1;
264 last;
265 }
266 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
267 $allowed = 1;
268 last;
269 }
270 }
271
272 unless ($allowed) {
273 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
274 print "E \n";
275 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
276 return 0;
277 }
278 }
279
280 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
281 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
282 print "E \n";
283 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
284 return 0;
285 }
286
287 my @gitvars = `git-config -l`;
288 if ($?) {
289 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
290 print "E \n";
291 print "error 1 - problem executing git-config\n";
292 return 0;
293 }
294 foreach my $line ( @gitvars )
295 {
296 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
297 unless ($2) {
298 $cfg->{$1}{$3} = $4;
299 } else {
300 $cfg->{$1}{$2}{$3} = $4;
301 }
302 }
303
304 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
305 || $cfg->{gitcvs}{enabled});
306 unless ($state->{'export-all'} ||
307 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
308 print "E GITCVS emulation needs to be enabled on this repo\n";
309 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
310 print "E \n";
311 print "error 1 GITCVS emulation disabled\n";
312 return 0;
313 }
314
315 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
316 if ( $logfile )
317 {
318 $log->setfile($logfile);
319 } else {
320 $log->nofile();
321 }
322
323 return 1;
324 }
325
326 # Global_option option \n
327 # Response expected: no. Transmit one of the global options `-q', `-Q',
328 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
329 # variations (such as combining of options) are allowed. For graceful
330 # handling of valid-requests, it is probably better to make new global
331 # options separate requests, rather than trying to add them to this
332 # request.
333 sub req_Globaloption
334 {
335 my ( $cmd, $data ) = @_;
336 $log->debug("req_Globaloption : $data");
337 $state->{globaloptions}{$data} = 1;
338 }
339
340 # Valid-responses request-list \n
341 # Response expected: no. Tell the server what responses the client will
342 # accept. request-list is a space separated list of tokens.
343 sub req_Validresponses
344 {
345 my ( $cmd, $data ) = @_;
346 $log->debug("req_Validresponses : $data");
347
348 # TODO : re-enable this, currently it's not particularly useful
349 #$state->{validresponses} = [ split /\s+/, $data ];
350 }
351
352 # valid-requests \n
353 # Response expected: yes. Ask the server to send back a Valid-requests
354 # response.
355 sub req_validrequests
356 {
357 my ( $cmd, $data ) = @_;
358
359 $log->debug("req_validrequests");
360
361 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
362 $log->debug("SEND : ok");
363
364 print "Valid-requests " . join(" ",keys %$methods) . "\n";
365 print "ok\n";
366 }
367
368 # Directory local-directory \n
369 # Additional data: repository \n. Response expected: no. Tell the server
370 # what directory to use. The repository should be a directory name from a
371 # previous server response. Note that this both gives a default for Entry
372 # and Modified and also for ci and the other commands; normal usage is to
373 # send Directory for each directory in which there will be an Entry or
374 # Modified, and then a final Directory for the original directory, then the
375 # command. The local-directory is relative to the top level at which the
376 # command is occurring (i.e. the last Directory which is sent before the
377 # command); to indicate that top level, `.' should be sent for
378 # local-directory.
379 sub req_Directory
380 {
381 my ( $cmd, $data ) = @_;
382
383 my $repository = <STDIN>;
384 chomp $repository;
385
386
387 $state->{localdir} = $data;
388 $state->{repository} = $repository;
389 $state->{path} = $repository;
390 $state->{path} =~ s/^$state->{CVSROOT}\///;
391 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
392 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
393
394 $state->{directory} = $state->{localdir};
395 $state->{directory} = "" if ( $state->{directory} eq "." );
396 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
397
398 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
399 {
400 $log->info("Setting prepend to '$state->{path}'");
401 $state->{prependdir} = $state->{path};
402 foreach my $entry ( keys %{$state->{entries}} )
403 {
404 $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
405 delete $state->{entries}{$entry};
406 }
407 }
408
409 if ( defined ( $state->{prependdir} ) )
410 {
411 $log->debug("Prepending '$state->{prependdir}' to state|directory");
412 $state->{directory} = $state->{prependdir} . $state->{directory}
413 }
414 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
415 }
416
417 # Entry entry-line \n
418 # Response expected: no. Tell the server what version of a file is on the
419 # local machine. The name in entry-line is a name relative to the directory
420 # most recently specified with Directory. If the user is operating on only
421 # some files in a directory, Entry requests for only those files need be
422 # included. If an Entry request is sent without Modified, Is-modified, or
423 # Unchanged, it means the file is lost (does not exist in the working
424 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
425 # are sent for the same file, Entry must be sent first. For a given file,
426 # one can send Modified, Is-modified, or Unchanged, but not more than one
427 # of these three.
428 sub req_Entry
429 {
430 my ( $cmd, $data ) = @_;
431
432 #$log->debug("req_Entry : $data");
433
434 my @data = split(/\//, $data);
435
436 $state->{entries}{$state->{directory}.$data[1]} = {
437 revision => $data[2],
438 conflict => $data[3],
439 options => $data[4],
440 tag_or_date => $data[5],
441 };
442
443 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
444 }
445
446 # Questionable filename \n
447 # Response expected: no. Additional data: no. Tell the server to check
448 # whether filename should be ignored, and if not, next time the server
449 # sends responses, send (in a M response) `?' followed by the directory and
450 # filename. filename must not contain `/'; it needs to be a file in the
451 # directory named by the most recent Directory request.
452 sub req_Questionable
453 {
454 my ( $cmd, $data ) = @_;
455
456 $log->debug("req_Questionable : $data");
457 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
458 }
459
460 # add \n
461 # Response expected: yes. Add a file or directory. This uses any previous
462 # Argument, Directory, Entry, or Modified requests, if they have been sent.
463 # The last Directory sent specifies the working directory at the time of
464 # the operation. To add a directory, send the directory to be added using
465 # Directory and Argument requests.
466 sub req_add
467 {
468 my ( $cmd, $data ) = @_;
469
470 argsplit("add");
471
472 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
473 $updater->update();
474
475 argsfromdir($updater);
476
477 my $addcount = 0;
478
479 foreach my $filename ( @{$state->{args}} )
480 {
481 $filename = filecleanup($filename);
482
483 my $meta = $updater->getmeta($filename);
484 my $wrev = revparse($filename);
485
486 if ($wrev && $meta && ($wrev < 0))
487 {
488 # previously removed file, add back
489 $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
490
491 print "MT +updated\n";
492 print "MT text U \n";
493 print "MT fname $filename\n";
494 print "MT newline\n";
495 print "MT -updated\n";
496
497 unless ( $state->{globaloptions}{-n} )
498 {
499 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
500
501 print "Created $dirpart\n";
502 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
503
504 # this is an "entries" line
505 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
506 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
507 print "/$filepart/1.$meta->{revision}//$kopts/\n";
508 # permissions
509 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
510 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
511 # transmit file
512 transmitfile($meta->{filehash});
513 }
514
515 next;
516 }
517
518 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
519 {
520 print "E cvs add: nothing known about `$filename'\n";
521 next;
522 }
523 # TODO : check we're not squashing an already existing file
524 if ( defined ( $state->{entries}{$filename}{revision} ) )
525 {
526 print "E cvs add: `$filename' has already been entered\n";
527 next;
528 }
529
530 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
531
532 print "E cvs add: scheduling file `$filename' for addition\n";
533
534 print "Checked-in $dirpart\n";
535 print "$filename\n";
536 my $kopts = kopts_from_path($filename,"file",
537 $state->{entries}{$filename}{modified_filename});
538 print "/$filepart/0//$kopts/\n";
539
540 my $requestedKopts = $state->{opt}{k};
541 if(defined($requestedKopts))
542 {
543 $requestedKopts = "-k$requestedKopts";
544 }
545 else
546 {
547 $requestedKopts = "";
548 }
549 if( $kopts ne $requestedKopts )
550 {
551 $log->warn("Ignoring requested -k='$requestedKopts'"
552 . " for '$filename'; detected -k='$kopts' instead");
553 #TODO: Also have option to send warning to user?
554 }
555
556 $addcount++;
557 }
558
559 if ( $addcount == 1 )
560 {
561 print "E cvs add: use `cvs commit' to add this file permanently\n";
562 }
563 elsif ( $addcount > 1 )
564 {
565 print "E cvs add: use `cvs commit' to add these files permanently\n";
566 }
567
568 print "ok\n";
569 }
570
571 # remove \n
572 # Response expected: yes. Remove a file. This uses any previous Argument,
573 # Directory, Entry, or Modified requests, if they have been sent. The last
574 # Directory sent specifies the working directory at the time of the
575 # operation. Note that this request does not actually do anything to the
576 # repository; the only effect of a successful remove request is to supply
577 # the client with a new entries line containing `-' to indicate a removed
578 # file. In fact, the client probably could perform this operation without
579 # contacting the server, although using remove may cause the server to
580 # perform a few more checks. The client sends a subsequent ci request to
581 # actually record the removal in the repository.
582 sub req_remove
583 {
584 my ( $cmd, $data ) = @_;
585
586 argsplit("remove");
587
588 # Grab a handle to the SQLite db and do any necessary updates
589 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
590 $updater->update();
591
592 #$log->debug("add state : " . Dumper($state));
593
594 my $rmcount = 0;
595
596 foreach my $filename ( @{$state->{args}} )
597 {
598 $filename = filecleanup($filename);
599
600 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
601 {
602 print "E cvs remove: file `$filename' still in working directory\n";
603 next;
604 }
605
606 my $meta = $updater->getmeta($filename);
607 my $wrev = revparse($filename);
608
609 unless ( defined ( $wrev ) )
610 {
611 print "E cvs remove: nothing known about `$filename'\n";
612 next;
613 }
614
615 if ( defined($wrev) and $wrev < 0 )
616 {
617 print "E cvs remove: file `$filename' already scheduled for removal\n";
618 next;
619 }
620
621 unless ( $wrev == $meta->{revision} )
622 {
623 # TODO : not sure if the format of this message is quite correct.
624 print "E cvs remove: Up to date check failed for `$filename'\n";
625 next;
626 }
627
628
629 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
630
631 print "E cvs remove: scheduling `$filename' for removal\n";
632
633 print "Checked-in $dirpart\n";
634 print "$filename\n";
635 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
636 print "/$filepart/-1.$wrev//$kopts/\n";
637
638 $rmcount++;
639 }
640
641 if ( $rmcount == 1 )
642 {
643 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
644 }
645 elsif ( $rmcount > 1 )
646 {
647 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
648 }
649
650 print "ok\n";
651 }
652
653 # Modified filename \n
654 # Response expected: no. Additional data: mode, \n, file transmission. Send
655 # the server a copy of one locally modified file. filename is a file within
656 # the most recent directory sent with Directory; it must not contain `/'.
657 # If the user is operating on only some files in a directory, only those
658 # files need to be included. This can also be sent without Entry, if there
659 # is no entry for the file.
660 sub req_Modified
661 {
662 my ( $cmd, $data ) = @_;
663
664 my $mode = <STDIN>;
665 defined $mode
666 or (print "E end of file reading mode for $data\n"), return;
667 chomp $mode;
668 my $size = <STDIN>;
669 defined $size
670 or (print "E end of file reading size of $data\n"), return;
671 chomp $size;
672
673 # Grab config information
674 my $blocksize = 8192;
675 my $bytesleft = $size;
676 my $tmp;
677
678 # Get a filehandle/name to write it to
679 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
680
681 # Loop over file data writing out to temporary file.
682 while ( $bytesleft )
683 {
684 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
685 read STDIN, $tmp, $blocksize;
686 print $fh $tmp;
687 $bytesleft -= $blocksize;
688 }
689
690 close $fh
691 or (print "E failed to write temporary, $filename: $!\n"), return;
692
693 # Ensure we have something sensible for the file mode
694 if ( $mode =~ /u=(\w+)/ )
695 {
696 $mode = $1;
697 } else {
698 $mode = "rw";
699 }
700
701 # Save the file data in $state
702 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
703 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
704 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
705 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
706
707 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
708 }
709
710 # Unchanged filename \n
711 # Response expected: no. Tell the server that filename has not been
712 # modified in the checked out directory. The filename is a file within the
713 # most recent directory sent with Directory; it must not contain `/'.
714 sub req_Unchanged
715 {
716 my ( $cmd, $data ) = @_;
717
718 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
719
720 #$log->debug("req_Unchanged : $data");
721 }
722
723 # Argument text \n
724 # Response expected: no. Save argument for use in a subsequent command.
725 # Arguments accumulate until an argument-using command is given, at which
726 # point they are forgotten.
727 # Argumentx text \n
728 # Response expected: no. Append \n followed by text to the current argument
729 # being saved.
730 sub req_Argument
731 {
732 my ( $cmd, $data ) = @_;
733
734 # Argumentx means: append to last Argument (with a newline in front)
735
736 $log->debug("$cmd : $data");
737
738 if ( $cmd eq 'Argumentx') {
739 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
740 } else {
741 push @{$state->{arguments}}, $data;
742 }
743 }
744
745 # expand-modules \n
746 # Response expected: yes. Expand the modules which are specified in the
747 # arguments. Returns the data in Module-expansion responses. Note that the
748 # server can assume that this is checkout or export, not rtag or rdiff; the
749 # latter do not access the working directory and thus have no need to
750 # expand modules on the client side. Expand may not be the best word for
751 # what this request does. It does not necessarily tell you all the files
752 # contained in a module, for example. Basically it is a way of telling you
753 # which working directories the server needs to know about in order to
754 # handle a checkout of the specified modules. For example, suppose that the
755 # server has a module defined by
756 # aliasmodule -a 1dir
757 # That is, one can check out aliasmodule and it will take 1dir in the
758 # repository and check it out to 1dir in the working directory. Now suppose
759 # the client already has this module checked out and is planning on using
760 # the co request to update it. Without using expand-modules, the client
761 # would have two bad choices: it could either send information about all
762 # working directories under the current directory, which could be
763 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
764 # stands for 1dir, and neglect to send information for 1dir, which would
765 # lead to incorrect operation. With expand-modules, the client would first
766 # ask for the module to be expanded:
767 sub req_expandmodules
768 {
769 my ( $cmd, $data ) = @_;
770
771 argsplit();
772
773 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
774
775 unless ( ref $state->{arguments} eq "ARRAY" )
776 {
777 print "ok\n";
778 return;
779 }
780
781 foreach my $module ( @{$state->{arguments}} )
782 {
783 $log->debug("SEND : Module-expansion $module");
784 print "Module-expansion $module\n";
785 }
786
787 print "ok\n";
788 statecleanup();
789 }
790
791 # co \n
792 # Response expected: yes. Get files from the repository. This uses any
793 # previous Argument, Directory, Entry, or Modified requests, if they have
794 # been sent. Arguments to this command are module names; the client cannot
795 # know what directories they correspond to except by (1) just sending the
796 # co request, and then seeing what directory names the server sends back in
797 # its responses, and (2) the expand-modules request.
798 sub req_co
799 {
800 my ( $cmd, $data ) = @_;
801
802 argsplit("co");
803
804 my $module = $state->{args}[0];
805 $state->{module} = $module;
806 my $checkout_path = $module;
807
808 # use the user specified directory if we're given it
809 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
810
811 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
812
813 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
814
815 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
816
817 # Grab a handle to the SQLite db and do any necessary updates
818 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
819 $updater->update();
820
821 $checkout_path =~ s|/$||; # get rid of trailing slashes
822
823 # Eclipse seems to need the Clear-sticky command
824 # to prepare the 'Entries' file for the new directory.
825 print "Clear-sticky $checkout_path/\n";
826 print $state->{CVSROOT} . "/$module/\n";
827 print "Clear-static-directory $checkout_path/\n";
828 print $state->{CVSROOT} . "/$module/\n";
829 print "Clear-sticky $checkout_path/\n"; # yes, twice
830 print $state->{CVSROOT} . "/$module/\n";
831 print "Template $checkout_path/\n";
832 print $state->{CVSROOT} . "/$module/\n";
833 print "0\n";
834
835 # instruct the client that we're checking out to $checkout_path
836 print "E cvs checkout: Updating $checkout_path\n";
837
838 my %seendirs = ();
839 my $lastdir ='';
840
841 # recursive
842 sub prepdir {
843 my ($dir, $repodir, $remotedir, $seendirs) = @_;
844 my $parent = dirname($dir);
845 $dir =~ s|/+$||;
846 $repodir =~ s|/+$||;
847 $remotedir =~ s|/+$||;
848 $parent =~ s|/+$||;
849 $log->debug("announcedir $dir, $repodir, $remotedir" );
850
851 if ($parent eq '.' || $parent eq './') {
852 $parent = '';
853 }
854 # recurse to announce unseen parents first
855 if (length($parent) && !exists($seendirs->{$parent})) {
856 prepdir($parent, $repodir, $remotedir, $seendirs);
857 }
858 # Announce that we are going to modify at the parent level
859 if ($parent) {
860 print "E cvs checkout: Updating $remotedir/$parent\n";
861 } else {
862 print "E cvs checkout: Updating $remotedir\n";
863 }
864 print "Clear-sticky $remotedir/$parent/\n";
865 print "$repodir/$parent/\n";
866
867 print "Clear-static-directory $remotedir/$dir/\n";
868 print "$repodir/$dir/\n";
869 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
870 print "$repodir/$parent/\n";
871 print "Template $remotedir/$dir/\n";
872 print "$repodir/$dir/\n";
873 print "0\n";
874
875 $seendirs->{$dir} = 1;
876 }
877
878 foreach my $git ( @{$updater->gethead} )
879 {
880 # Don't want to check out deleted files
881 next if ( $git->{filehash} eq "deleted" );
882
883 my $fullName = $git->{name};
884 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
885
886 if (length($git->{dir}) && $git->{dir} ne './'
887 && $git->{dir} ne $lastdir ) {
888 unless (exists($seendirs{$git->{dir}})) {
889 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
890 $checkout_path, \%seendirs);
891 $lastdir = $git->{dir};
892 $seendirs{$git->{dir}} = 1;
893 }
894 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
895 }
896
897 # modification time of this file
898 print "Mod-time $git->{modified}\n";
899
900 # print some information to the client
901 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
902 {
903 print "M U $checkout_path/$git->{dir}$git->{name}\n";
904 } else {
905 print "M U $checkout_path/$git->{name}\n";
906 }
907
908 # instruct client we're sending a file to put in this path
909 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
910
911 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
912
913 # this is an "entries" line
914 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
915 print "/$git->{name}/1.$git->{revision}//$kopts/\n";
916 # permissions
917 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
918
919 # transmit file
920 transmitfile($git->{filehash});
921 }
922
923 print "ok\n";
924
925 statecleanup();
926 }
927
928 # update \n
929 # Response expected: yes. Actually do a cvs update command. This uses any
930 # previous Argument, Directory, Entry, or Modified requests, if they have
931 # been sent. The last Directory sent specifies the working directory at the
932 # time of the operation. The -I option is not used--files which the client
933 # can decide whether to ignore are not mentioned and the client sends the
934 # Questionable request for others.
935 sub req_update
936 {
937 my ( $cmd, $data ) = @_;
938
939 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
940
941 argsplit("update");
942
943 #
944 # It may just be a client exploring the available heads/modules
945 # in that case, list them as top level directories and leave it
946 # at that. Eclipse uses this technique to offer you a list of
947 # projects (heads in this case) to checkout.
948 #
949 if ($state->{module} eq '') {
950 my $showref = `git show-ref --heads`;
951 print "E cvs update: Updating .\n";
952 for my $line (split '\n', $showref) {
953 if ( $line =~ m% refs/heads/(.*)$% ) {
954 print "E cvs update: New directory `$1'\n";
955 }
956 }
957 print "ok\n";
958 return 1;
959 }
960
961
962 # Grab a handle to the SQLite db and do any necessary updates
963 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
964
965 $updater->update();
966
967 argsfromdir($updater);
968
969 #$log->debug("update state : " . Dumper($state));
970
971 # foreach file specified on the command line ...
972 foreach my $filename ( @{$state->{args}} )
973 {
974 $filename = filecleanup($filename);
975
976 $log->debug("Processing file $filename");
977
978 # if we have a -C we should pretend we never saw modified stuff
979 if ( exists ( $state->{opt}{C} ) )
980 {
981 delete $state->{entries}{$filename}{modified_hash};
982 delete $state->{entries}{$filename}{modified_filename};
983 $state->{entries}{$filename}{unchanged} = 1;
984 }
985
986 my $meta;
987 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
988 {
989 $meta = $updater->getmeta($filename, $1);
990 } else {
991 $meta = $updater->getmeta($filename);
992 }
993
994 # If -p was given, "print" the contents of the requested revision.
995 if ( exists ( $state->{opt}{p} ) ) {
996 if ( defined ( $meta->{revision} ) ) {
997 $log->info("Printing '$filename' revision " . $meta->{revision});
998
999 transmitfile($meta->{filehash}, { print => 1 });
1000 }
1001
1002 next;
1003 }
1004
1005 if ( ! defined $meta )
1006 {
1007 $meta = {
1008 name => $filename,
1009 revision => 0,
1010 filehash => 'added'
1011 };
1012 }
1013
1014 my $oldmeta = $meta;
1015
1016 my $wrev = revparse($filename);
1017
1018 # If the working copy is an old revision, lets get that version too for comparison.
1019 if ( defined($wrev) and $wrev != $meta->{revision} )
1020 {
1021 $oldmeta = $updater->getmeta($filename, $wrev);
1022 }
1023
1024 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1025
1026 # Files are up to date if the working copy and repo copy have the same revision,
1027 # and the working copy is unmodified _and_ the user hasn't specified -C
1028 next if ( defined ( $wrev )
1029 and defined($meta->{revision})
1030 and $wrev == $meta->{revision}
1031 and $state->{entries}{$filename}{unchanged}
1032 and not exists ( $state->{opt}{C} ) );
1033
1034 # If the working copy and repo copy have the same revision,
1035 # but the working copy is modified, tell the client it's modified
1036 if ( defined ( $wrev )
1037 and defined($meta->{revision})
1038 and $wrev == $meta->{revision}
1039 and defined($state->{entries}{$filename}{modified_hash})
1040 and not exists ( $state->{opt}{C} ) )
1041 {
1042 $log->info("Tell the client the file is modified");
1043 print "MT text M \n";
1044 print "MT fname $filename\n";
1045 print "MT newline\n";
1046 next;
1047 }
1048
1049 if ( $meta->{filehash} eq "deleted" )
1050 {
1051 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1052
1053 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1054
1055 print "E cvs update: `$filename' is no longer in the repository\n";
1056 # Don't want to actually _DO_ the update if -n specified
1057 unless ( $state->{globaloptions}{-n} ) {
1058 print "Removed $dirpart\n";
1059 print "$filepart\n";
1060 }
1061 }
1062 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1063 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1064 or $meta->{filehash} eq 'added' )
1065 {
1066 # normal update, just send the new revision (either U=Update,
1067 # or A=Add, or R=Remove)
1068 if ( defined($wrev) && $wrev < 0 )
1069 {
1070 $log->info("Tell the client the file is scheduled for removal");
1071 print "MT text R \n";
1072 print "MT fname $filename\n";
1073 print "MT newline\n";
1074 next;
1075 }
1076 elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1077 {
1078 $log->info("Tell the client the file is scheduled for addition");
1079 print "MT text A \n";
1080 print "MT fname $filename\n";
1081 print "MT newline\n";
1082 next;
1083
1084 }
1085 else {
1086 $log->info("Updating '$filename' to ".$meta->{revision});
1087 print "MT +updated\n";
1088 print "MT text U \n";
1089 print "MT fname $filename\n";
1090 print "MT newline\n";
1091 print "MT -updated\n";
1092 }
1093
1094 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1095
1096 # Don't want to actually _DO_ the update if -n specified
1097 unless ( $state->{globaloptions}{-n} )
1098 {
1099 if ( defined ( $wrev ) )
1100 {
1101 # instruct client we're sending a file to put in this path as a replacement
1102 print "Update-existing $dirpart\n";
1103 $log->debug("Updating existing file 'Update-existing $dirpart'");
1104 } else {
1105 # instruct client we're sending a file to put in this path as a new file
1106 print "Clear-static-directory $dirpart\n";
1107 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1108 print "Clear-sticky $dirpart\n";
1109 print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1110
1111 $log->debug("Creating new file 'Created $dirpart'");
1112 print "Created $dirpart\n";
1113 }
1114 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1115
1116 # this is an "entries" line
1117 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1118 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1119 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1120
1121 # permissions
1122 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1123 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1124
1125 # transmit file
1126 transmitfile($meta->{filehash});
1127 }
1128 } else {
1129 $log->info("Updating '$filename'");
1130 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1131
1132 my $mergeDir = setupTmpDir();
1133
1134 my $file_local = $filepart . ".mine";
1135 my $mergedFile = "$mergeDir/$file_local";
1136 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1137 my $file_old = $filepart . "." . $oldmeta->{revision};
1138 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1139 my $file_new = $filepart . "." . $meta->{revision};
1140 transmitfile($meta->{filehash}, { targetfile => $file_new });
1141
1142 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1143 $log->info("Merging $file_local, $file_old, $file_new");
1144 print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1145
1146 $log->debug("Temporary directory for merge is $mergeDir");
1147
1148 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1149 $return >>= 8;
1150
1151 cleanupTmpDir();
1152
1153 if ( $return == 0 )
1154 {
1155 $log->info("Merged successfully");
1156 print "M M $filename\n";
1157 $log->debug("Merged $dirpart");
1158
1159 # Don't want to actually _DO_ the update if -n specified
1160 unless ( $state->{globaloptions}{-n} )
1161 {
1162 print "Merged $dirpart\n";
1163 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1164 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1165 my $kopts = kopts_from_path("$dirpart/$filepart",
1166 "file",$mergedFile);
1167 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1168 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1169 }
1170 }
1171 elsif ( $return == 1 )
1172 {
1173 $log->info("Merged with conflicts");
1174 print "E cvs update: conflicts found in $filename\n";
1175 print "M C $filename\n";
1176
1177 # Don't want to actually _DO_ the update if -n specified
1178 unless ( $state->{globaloptions}{-n} )
1179 {
1180 print "Merged $dirpart\n";
1181 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1182 my $kopts = kopts_from_path("$dirpart/$filepart",
1183 "file",$mergedFile);
1184 print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1185 }
1186 }
1187 else
1188 {
1189 $log->warn("Merge failed");
1190 next;
1191 }
1192
1193 # Don't want to actually _DO_ the update if -n specified
1194 unless ( $state->{globaloptions}{-n} )
1195 {
1196 # permissions
1197 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1198 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1199
1200 # transmit file, format is single integer on a line by itself (file
1201 # size) followed by the file contents
1202 # TODO : we should copy files in blocks
1203 my $data = `cat $mergedFile`;
1204 $log->debug("File size : " . length($data));
1205 print length($data) . "\n";
1206 print $data;
1207 }
1208 }
1209
1210 }
1211
1212 print "ok\n";
1213 }
1214
1215 sub req_ci
1216 {
1217 my ( $cmd, $data ) = @_;
1218
1219 argsplit("ci");
1220
1221 #$log->debug("State : " . Dumper($state));
1222
1223 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1224
1225 if ( $state->{method} eq 'pserver')
1226 {
1227 print "error 1 pserver access cannot commit\n";
1228 cleanupWorkTree();
1229 exit;
1230 }
1231
1232 if ( -e $state->{CVSROOT} . "/index" )
1233 {
1234 $log->warn("file 'index' already exists in the git repository");
1235 print "error 1 Index already exists in git repo\n";
1236 cleanupWorkTree();
1237 exit;
1238 }
1239
1240 # Grab a handle to the SQLite db and do any necessary updates
1241 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1242 $updater->update();
1243
1244 # Remember where the head was at the beginning.
1245 my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1246 chomp $parenthash;
1247 if ($parenthash !~ /^[0-9a-f]{40}$/) {
1248 print "error 1 pserver cannot find the current HEAD of module";
1249 cleanupWorkTree();
1250 exit;
1251 }
1252
1253 setupWorkTree($parenthash);
1254
1255 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1256
1257 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1258
1259 my @committedfiles = ();
1260 my %oldmeta;
1261
1262 # foreach file specified on the command line ...
1263 foreach my $filename ( @{$state->{args}} )
1264 {
1265 my $committedfile = $filename;
1266 $filename = filecleanup($filename);
1267
1268 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1269
1270 my $meta = $updater->getmeta($filename);
1271 $oldmeta{$filename} = $meta;
1272
1273 my $wrev = revparse($filename);
1274
1275 my ( $filepart, $dirpart ) = filenamesplit($filename);
1276
1277 # do a checkout of the file if it is part of this tree
1278 if ($wrev) {
1279 system('git-checkout-index', '-f', '-u', $filename);
1280 unless ($? == 0) {
1281 die "Error running git-checkout-index -f -u $filename : $!";
1282 }
1283 }
1284
1285 my $addflag = 0;
1286 my $rmflag = 0;
1287 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1288 $addflag = 1 unless ( -e $filename );
1289
1290 # Do up to date checking
1291 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1292 {
1293 # fail everything if an up to date check fails
1294 print "error 1 Up to date check failed for $filename\n";
1295 cleanupWorkTree();
1296 exit;
1297 }
1298
1299 push @committedfiles, $committedfile;
1300 $log->info("Committing $filename");
1301
1302 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1303
1304 unless ( $rmflag )
1305 {
1306 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1307 rename $state->{entries}{$filename}{modified_filename},$filename;
1308
1309 # Calculate modes to remove
1310 my $invmode = "";
1311 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1312
1313 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1314 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1315 }
1316
1317 if ( $rmflag )
1318 {
1319 $log->info("Removing file '$filename'");
1320 unlink($filename);
1321 system("git-update-index", "--remove", $filename);
1322 }
1323 elsif ( $addflag )
1324 {
1325 $log->info("Adding file '$filename'");
1326 system("git-update-index", "--add", $filename);
1327 } else {
1328 $log->info("Updating file '$filename'");
1329 system("git-update-index", $filename);
1330 }
1331 }
1332
1333 unless ( scalar(@committedfiles) > 0 )
1334 {
1335 print "E No files to commit\n";
1336 print "ok\n";
1337 cleanupWorkTree();
1338 return;
1339 }
1340
1341 my $treehash = `git-write-tree`;
1342 chomp $treehash;
1343
1344 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1345
1346 # write our commit message out if we have one ...
1347 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1348 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1349 print $msg_fh "\n\nvia git-CVS emulator\n";
1350 close $msg_fh;
1351
1352 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1353 chomp($commithash);
1354 $log->info("Commit hash : $commithash");
1355
1356 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1357 {
1358 $log->warn("Commit failed (Invalid commit hash)");
1359 print "error 1 Commit failed (unknown reason)\n";
1360 cleanupWorkTree();
1361 exit;
1362 }
1363
1364 ### Emulate git-receive-pack by running hooks/update
1365 my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1366 $parenthash, $commithash );
1367 if( -x $hook[0] ) {
1368 unless( system( @hook ) == 0 )
1369 {
1370 $log->warn("Commit failed (update hook declined to update ref)");
1371 print "error 1 Commit failed (update hook declined)\n";
1372 cleanupWorkTree();
1373 exit;
1374 }
1375 }
1376
1377 ### Update the ref
1378 if (system(qw(git update-ref -m), "cvsserver ci",
1379 "refs/heads/$state->{module}", $commithash, $parenthash)) {
1380 $log->warn("update-ref for $state->{module} failed.");
1381 print "error 1 Cannot commit -- update first\n";
1382 cleanupWorkTree();
1383 exit;
1384 }
1385
1386 ### Emulate git-receive-pack by running hooks/post-receive
1387 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1388 if( -x $hook ) {
1389 open(my $pipe, "| $hook") || die "can't fork $!";
1390
1391 local $SIG{PIPE} = sub { die 'pipe broke' };
1392
1393 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1394
1395 close $pipe || die "bad pipe: $! $?";
1396 }
1397
1398 ### Then hooks/post-update
1399 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1400 if (-x $hook) {
1401 system($hook, "refs/heads/$state->{module}");
1402 }
1403
1404 $updater->update();
1405
1406 # foreach file specified on the command line ...
1407 foreach my $filename ( @committedfiles )
1408 {
1409 $filename = filecleanup($filename);
1410
1411 my $meta = $updater->getmeta($filename);
1412 unless (defined $meta->{revision}) {
1413 $meta->{revision} = 1;
1414 }
1415
1416 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1417
1418 $log->debug("Checked-in $dirpart : $filename");
1419
1420 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1421 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1422 {
1423 print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1424 print "Remove-entry $dirpart\n";
1425 print "$filename\n";
1426 } else {
1427 if ($meta->{revision} == 1) {
1428 print "M initial revision: 1.1\n";
1429 } else {
1430 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1431 }
1432 print "Checked-in $dirpart\n";
1433 print "$filename\n";
1434 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1435 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1436 }
1437 }
1438
1439 cleanupWorkTree();
1440 print "ok\n";
1441 }
1442
1443 sub req_status
1444 {
1445 my ( $cmd, $data ) = @_;
1446
1447 argsplit("status");
1448
1449 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1450 #$log->debug("status state : " . Dumper($state));
1451
1452 # Grab a handle to the SQLite db and do any necessary updates
1453 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1454 $updater->update();
1455
1456 # if no files were specified, we need to work out what files we should be providing status on ...
1457 argsfromdir($updater);
1458
1459 # foreach file specified on the command line ...
1460 foreach my $filename ( @{$state->{args}} )
1461 {
1462 $filename = filecleanup($filename);
1463
1464 next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1465
1466 my $meta = $updater->getmeta($filename);
1467 my $oldmeta = $meta;
1468
1469 my $wrev = revparse($filename);
1470
1471 # If the working copy is an old revision, lets get that version too for comparison.
1472 if ( defined($wrev) and $wrev != $meta->{revision} )
1473 {
1474 $oldmeta = $updater->getmeta($filename, $wrev);
1475 }
1476
1477 # TODO : All possible statuses aren't yet implemented
1478 my $status;
1479 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1480 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1481 and
1482 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1483 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1484 );
1485
1486 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1487 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1488 and
1489 ( $state->{entries}{$filename}{unchanged}
1490 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1491 );
1492
1493 # Need checkout if it exists in the repo but doesn't have a working copy
1494 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1495
1496 # Locally modified if working copy and repo copy have the same revision but there are local changes
1497 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1498
1499 # Needs Merge if working copy revision is less than repo copy and there are local changes
1500 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1501
1502 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1503 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1504 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1505 $status ||= "File had conflicts on merge" if ( 0 );
1506
1507 $status ||= "Unknown";
1508
1509 my ($filepart) = filenamesplit($filename);
1510
1511 print "M ===================================================================\n";
1512 print "M File: $filepart\tStatus: $status\n";
1513 if ( defined($state->{entries}{$filename}{revision}) )
1514 {
1515 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1516 } else {
1517 print "M Working revision:\tNo entry for $filename\n";
1518 }
1519 if ( defined($meta->{revision}) )
1520 {
1521 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1522 print "M Sticky Tag:\t\t(none)\n";
1523 print "M Sticky Date:\t\t(none)\n";
1524 print "M Sticky Options:\t\t(none)\n";
1525 } else {
1526 print "M Repository revision:\tNo revision control file\n";
1527 }
1528 print "M\n";
1529 }
1530
1531 print "ok\n";
1532 }
1533
1534 sub req_diff
1535 {
1536 my ( $cmd, $data ) = @_;
1537
1538 argsplit("diff");
1539
1540 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1541 #$log->debug("status state : " . Dumper($state));
1542
1543 my ($revision1, $revision2);
1544 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1545 {
1546 $revision1 = $state->{opt}{r}[0];
1547 $revision2 = $state->{opt}{r}[1];
1548 } else {
1549 $revision1 = $state->{opt}{r};
1550 }
1551
1552 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1553 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1554
1555 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1556
1557 # Grab a handle to the SQLite db and do any necessary updates
1558 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1559 $updater->update();
1560
1561 # if no files were specified, we need to work out what files we should be providing status on ...
1562 argsfromdir($updater);
1563
1564 # foreach file specified on the command line ...
1565 foreach my $filename ( @{$state->{args}} )
1566 {
1567 $filename = filecleanup($filename);
1568
1569 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1570
1571 my $wrev = revparse($filename);
1572
1573 # We need _something_ to diff against
1574 next unless ( defined ( $wrev ) );
1575
1576 # if we have a -r switch, use it
1577 if ( defined ( $revision1 ) )
1578 {
1579 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1580 $meta1 = $updater->getmeta($filename, $revision1);
1581 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1582 {
1583 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1584 next;
1585 }
1586 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1587 }
1588 # otherwise we just use the working copy revision
1589 else
1590 {
1591 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1592 $meta1 = $updater->getmeta($filename, $wrev);
1593 transmitfile($meta1->{filehash}, { targetfile => $file1 });
1594 }
1595
1596 # if we have a second -r switch, use it too
1597 if ( defined ( $revision2 ) )
1598 {
1599 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1600 $meta2 = $updater->getmeta($filename, $revision2);
1601
1602 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1603 {
1604 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1605 next;
1606 }
1607
1608 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1609 }
1610 # otherwise we just use the working copy
1611 else
1612 {
1613 $file2 = $state->{entries}{$filename}{modified_filename};
1614 }
1615
1616 # if we have been given -r, and we don't have a $file2 yet, lets get one
1617 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1618 {
1619 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1620 $meta2 = $updater->getmeta($filename, $wrev);
1621 transmitfile($meta2->{filehash}, { targetfile => $file2 });
1622 }
1623
1624 # We need to have retrieved something useful
1625 next unless ( defined ( $meta1 ) );
1626
1627 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1628 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1629 and
1630 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1631 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1632 );
1633
1634 # Apparently we only show diffs for locally modified files
1635 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1636
1637 print "M Index: $filename\n";
1638 print "M ===================================================================\n";
1639 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1640 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1641 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1642 print "M diff ";
1643 foreach my $opt ( keys %{$state->{opt}} )
1644 {
1645 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1646 {
1647 foreach my $value ( @{$state->{opt}{$opt}} )
1648 {
1649 print "-$opt $value ";
1650 }
1651 } else {
1652 print "-$opt ";
1653 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1654 }
1655 }
1656 print "$filename\n";
1657
1658 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1659
1660 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1661
1662 if ( exists $state->{opt}{u} )
1663 {
1664 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1665 } else {
1666 system("diff $file1 $file2 > $filediff");
1667 }
1668
1669 while ( <$fh> )
1670 {
1671 print "M $_";
1672 }
1673 close $fh;
1674 }
1675
1676 print "ok\n";
1677 }
1678
1679 sub req_log
1680 {
1681 my ( $cmd, $data ) = @_;
1682
1683 argsplit("log");
1684
1685 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1686 #$log->debug("log state : " . Dumper($state));
1687
1688 my ( $minrev, $maxrev );
1689 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1690 {
1691 my $control = $2;
1692 $minrev = $1;
1693 $maxrev = $3;
1694 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1695 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1696 $minrev++ if ( defined($minrev) and $control eq "::" );
1697 }
1698
1699 # Grab a handle to the SQLite db and do any necessary updates
1700 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1701 $updater->update();
1702
1703 # if no files were specified, we need to work out what files we should be providing status on ...
1704 argsfromdir($updater);
1705
1706 # foreach file specified on the command line ...
1707 foreach my $filename ( @{$state->{args}} )
1708 {
1709 $filename = filecleanup($filename);
1710
1711 my $headmeta = $updater->getmeta($filename);
1712
1713 my $revisions = $updater->getlog($filename);
1714 my $totalrevisions = scalar(@$revisions);
1715
1716 if ( defined ( $minrev ) )
1717 {
1718 $log->debug("Removing revisions less than $minrev");
1719 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1720 {
1721 pop @$revisions;
1722 }
1723 }
1724 if ( defined ( $maxrev ) )
1725 {
1726 $log->debug("Removing revisions greater than $maxrev");
1727 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1728 {
1729 shift @$revisions;
1730 }
1731 }
1732
1733 next unless ( scalar(@$revisions) );
1734
1735 print "M \n";
1736 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1737 print "M Working file: $filename\n";
1738 print "M head: 1.$headmeta->{revision}\n";
1739 print "M branch:\n";
1740 print "M locks: strict\n";
1741 print "M access list:\n";
1742 print "M symbolic names:\n";
1743 print "M keyword substitution: kv\n";
1744 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1745 print "M description:\n";
1746
1747 foreach my $revision ( @$revisions )
1748 {
1749 print "M ----------------------------\n";
1750 print "M revision 1.$revision->{revision}\n";
1751 # reformat the date for log output
1752 $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}) );
1753 $revision->{author} = cvs_author($revision->{author});
1754 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1755 my $commitmessage = $updater->commitmessage($revision->{commithash});
1756 $commitmessage =~ s/^/M /mg;
1757 print $commitmessage . "\n";
1758 }
1759 print "M =============================================================================\n";
1760 }
1761
1762 print "ok\n";
1763 }
1764
1765 sub req_annotate
1766 {
1767 my ( $cmd, $data ) = @_;
1768
1769 argsplit("annotate");
1770
1771 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1772 #$log->debug("status state : " . Dumper($state));
1773
1774 # Grab a handle to the SQLite db and do any necessary updates
1775 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1776 $updater->update();
1777
1778 # if no files were specified, we need to work out what files we should be providing annotate on ...
1779 argsfromdir($updater);
1780
1781 # we'll need a temporary checkout dir
1782 setupWorkTree();
1783
1784 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1785
1786 # foreach file specified on the command line ...
1787 foreach my $filename ( @{$state->{args}} )
1788 {
1789 $filename = filecleanup($filename);
1790
1791 my $meta = $updater->getmeta($filename);
1792
1793 next unless ( $meta->{revision} );
1794
1795 # get all the commits that this file was in
1796 # in dense format -- aka skip dead revisions
1797 my $revisions = $updater->gethistorydense($filename);
1798 my $lastseenin = $revisions->[0][2];
1799
1800 # populate the temporary index based on the latest commit were we saw
1801 # the file -- but do it cheaply without checking out any files
1802 # TODO: if we got a revision from the client, use that instead
1803 # to look up the commithash in sqlite (still good to default to
1804 # the current head as we do now)
1805 system("git-read-tree", $lastseenin);
1806 unless ($? == 0)
1807 {
1808 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1809 return;
1810 }
1811 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1812
1813 # do a checkout of the file
1814 system('git-checkout-index', '-f', '-u', $filename);
1815 unless ($? == 0) {
1816 print "E error running git-checkout-index -f -u $filename : $!\n";
1817 return;
1818 }
1819
1820 $log->info("Annotate $filename");
1821
1822 # Prepare a file with the commits from the linearized
1823 # history that annotate should know about. This prevents
1824 # git-jsannotate telling us about commits we are hiding
1825 # from the client.
1826
1827 my $a_hints = "$work->{workDir}/.annotate_hints";
1828 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1829 print "E failed to open '$a_hints' for writing: $!\n";
1830 return;
1831 }
1832 for (my $i=0; $i < @$revisions; $i++)
1833 {
1834 print ANNOTATEHINTS $revisions->[$i][2];
1835 if ($i+1 < @$revisions) { # have we got a parent?
1836 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1837 }
1838 print ANNOTATEHINTS "\n";
1839 }
1840
1841 print ANNOTATEHINTS "\n";
1842 close ANNOTATEHINTS
1843 or (print "E failed to write $a_hints: $!\n"), return;
1844
1845 my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1846 if (!open(ANNOTATE, "-|", @cmd)) {
1847 print "E error invoking ". join(' ',@cmd) .": $!\n";
1848 return;
1849 }
1850 my $metadata = {};
1851 print "E Annotations for $filename\n";
1852 print "E ***************\n";
1853 while ( <ANNOTATE> )
1854 {
1855 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1856 {
1857 my $commithash = $1;
1858 my $data = $2;
1859 unless ( defined ( $metadata->{$commithash} ) )
1860 {
1861 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1862 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1863 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1864 }
1865 printf("M 1.%-5d (%-8s %10s): %s\n",
1866 $metadata->{$commithash}{revision},
1867 $metadata->{$commithash}{author},
1868 $metadata->{$commithash}{modified},
1869 $data
1870 );
1871 } else {
1872 $log->warn("Error in annotate output! LINE: $_");
1873 print "E Annotate error \n";
1874 next;
1875 }
1876 }
1877 close ANNOTATE;
1878 }
1879
1880 # done; get out of the tempdir
1881 cleanupWorkTree();
1882
1883 print "ok\n";
1884
1885 }
1886
1887 # This method takes the state->{arguments} array and produces two new arrays.
1888 # The first is $state->{args} which is everything before the '--' argument, and
1889 # the second is $state->{files} which is everything after it.
1890 sub argsplit
1891 {
1892 $state->{args} = [];
1893 $state->{files} = [];
1894 $state->{opt} = {};
1895
1896 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1897
1898 my $type = shift;
1899
1900 if ( defined($type) )
1901 {
1902 my $opt = {};
1903 $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" );
1904 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1905 $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" );
1906 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1907 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1908 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1909 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1910 $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" );
1911
1912
1913 while ( scalar ( @{$state->{arguments}} ) > 0 )
1914 {
1915 my $arg = shift @{$state->{arguments}};
1916
1917 next if ( $arg eq "--" );
1918 next unless ( $arg =~ /\S/ );
1919
1920 # if the argument looks like a switch
1921 if ( $arg =~ /^-(\w)(.*)/ )
1922 {
1923 # if it's a switch that takes an argument
1924 if ( $opt->{$1} )
1925 {
1926 # If this switch has already been provided
1927 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1928 {
1929 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1930 if ( length($2) > 0 )
1931 {
1932 push @{$state->{opt}{$1}},$2;
1933 } else {
1934 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1935 }
1936 } else {
1937 # if there's extra data in the arg, use that as the argument for the switch
1938 if ( length($2) > 0 )
1939 {
1940 $state->{opt}{$1} = $2;
1941 } else {
1942 $state->{opt}{$1} = shift @{$state->{arguments}};
1943 }
1944 }
1945 } else {
1946 $state->{opt}{$1} = undef;
1947 }
1948 }
1949 else
1950 {
1951 push @{$state->{args}}, $arg;
1952 }
1953 }
1954 }
1955 else
1956 {
1957 my $mode = 0;
1958
1959 foreach my $value ( @{$state->{arguments}} )
1960 {
1961 if ( $value eq "--" )
1962 {
1963 $mode++;
1964 next;
1965 }
1966 push @{$state->{args}}, $value if ( $mode == 0 );
1967 push @{$state->{files}}, $value if ( $mode == 1 );
1968 }
1969 }
1970 }
1971
1972 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1973 sub argsfromdir
1974 {
1975 my $updater = shift;
1976
1977 $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1978
1979 return if ( scalar ( @{$state->{args}} ) > 1 );
1980
1981 my @gethead = @{$updater->gethead};
1982
1983 # push added files
1984 foreach my $file (keys %{$state->{entries}}) {
1985 if ( exists $state->{entries}{$file}{revision} &&
1986 $state->{entries}{$file}{revision} == 0 )
1987 {
1988 push @gethead, { name => $file, filehash => 'added' };
1989 }
1990 }
1991
1992 if ( scalar(@{$state->{args}}) == 1 )
1993 {
1994 my $arg = $state->{args}[0];
1995 $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1996
1997 $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1998
1999 foreach my $file ( @gethead )
2000 {
2001 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2002 next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg );
2003 push @{$state->{args}}, $file->{name};
2004 }
2005
2006 shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2007 } else {
2008 $log->info("Only one arg specified, populating file list automatically");
2009
2010 $state->{args} = [];
2011
2012 foreach my $file ( @gethead )
2013 {
2014 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2015 next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2016 push @{$state->{args}}, $file->{name};
2017 }
2018 }
2019 }
2020
2021 # This method cleans up the $state variable after a command that uses arguments has run
2022 sub statecleanup
2023 {
2024 $state->{files} = [];
2025 $state->{args} = [];
2026 $state->{arguments} = [];
2027 $state->{entries} = {};
2028 }
2029
2030 sub revparse
2031 {
2032 my $filename = shift;
2033
2034 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2035
2036 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2037 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2038
2039 return undef;
2040 }
2041
2042 # This method takes a file hash and does a CVS "file transfer". Its
2043 # exact behaviour depends on a second, optional hash table argument:
2044 # - If $options->{targetfile}, dump the contents to that file;
2045 # - If $options->{print}, use M/MT to transmit the contents one line
2046 # at a time;
2047 # - Otherwise, transmit the size of the file, followed by the file
2048 # contents.
2049 sub transmitfile
2050 {
2051 my $filehash = shift;
2052 my $options = shift;
2053
2054 if ( defined ( $filehash ) and $filehash eq "deleted" )
2055 {
2056 $log->warn("filehash is 'deleted'");
2057 return;
2058 }
2059
2060 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2061
2062 my $type = `git-cat-file -t $filehash`;
2063 chomp $type;
2064
2065 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2066
2067 my $size = `git-cat-file -s $filehash`;
2068 chomp $size;
2069
2070 $log->debug("transmitfile($filehash) size=$size, type=$type");
2071
2072 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2073 {
2074 if ( defined ( $options->{targetfile} ) )
2075 {
2076 my $targetfile = $options->{targetfile};
2077 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2078 print NEWFILE $_ while ( <$fh> );
2079 close NEWFILE or die("Failed to write '$targetfile': $!");
2080 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2081 while ( <$fh> ) {
2082 if( /\n\z/ ) {
2083 print 'M ', $_;
2084 } else {
2085 print 'MT text ', $_, "\n";
2086 }
2087 }
2088 } else {
2089 print "$size\n";
2090 print while ( <$fh> );
2091 }
2092 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2093 } else {
2094 die("Couldn't execute git-cat-file");
2095 }
2096 }
2097
2098 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2099 # refers to the directory portion and the file portion of the filename
2100 # respectively
2101 sub filenamesplit
2102 {
2103 my $filename = shift;
2104 my $fixforlocaldir = shift;
2105
2106 my ( $filepart, $dirpart ) = ( $filename, "." );
2107 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2108 $dirpart .= "/";
2109
2110 if ( $fixforlocaldir )
2111 {
2112 $dirpart =~ s/^$state->{prependdir}//;
2113 }
2114
2115 return ( $filepart, $dirpart );
2116 }
2117
2118 sub filecleanup
2119 {
2120 my $filename = shift;
2121
2122 return undef unless(defined($filename));
2123 if ( $filename =~ /^\// )
2124 {
2125 print "E absolute filenames '$filename' not supported by server\n";
2126 return undef;
2127 }
2128
2129 $filename =~ s/^\.\///g;
2130 $filename = $state->{prependdir} . $filename;
2131 return $filename;
2132 }
2133
2134 sub validateGitDir
2135 {
2136 if( !defined($state->{CVSROOT}) )
2137 {
2138 print "error 1 CVSROOT not specified\n";
2139 cleanupWorkTree();
2140 exit;
2141 }
2142 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2143 {
2144 print "error 1 Internally inconsistent CVSROOT\n";
2145 cleanupWorkTree();
2146 exit;
2147 }
2148 }
2149
2150 # Setup working directory in a work tree with the requested version
2151 # loaded in the index.
2152 sub setupWorkTree
2153 {
2154 my ($ver) = @_;
2155
2156 validateGitDir();
2157
2158 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2159 defined($work->{tmpDir}) )
2160 {
2161 $log->warn("Bad work tree state management");
2162 print "error 1 Internal setup multiple work trees without cleanup\n";
2163 cleanupWorkTree();
2164 exit;
2165 }
2166
2167 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2168
2169 if( !defined($work->{index}) )
2170 {
2171 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2172 }
2173
2174 chdir $work->{workDir} or
2175 die "Unable to chdir to $work->{workDir}\n";
2176
2177 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2178
2179 $ENV{GIT_WORK_TREE} = ".";
2180 $ENV{GIT_INDEX_FILE} = $work->{index};
2181 $work->{state} = 2;
2182
2183 if($ver)
2184 {
2185 system("git","read-tree",$ver);
2186 unless ($? == 0)
2187 {
2188 $log->warn("Error running git-read-tree");
2189 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2190 }
2191 }
2192 # else # req_annotate reads tree for each file
2193 }
2194
2195 # Ensure current directory is in some kind of working directory,
2196 # with a recent version loaded in the index.
2197 sub ensureWorkTree
2198 {
2199 if( defined($work->{tmpDir}) )
2200 {
2201 $log->warn("Bad work tree state management [ensureWorkTree()]");
2202 print "error 1 Internal setup multiple dirs without cleanup\n";
2203 cleanupWorkTree();
2204 exit;
2205 }
2206 if( $work->{state} )
2207 {
2208 return;
2209 }
2210
2211 validateGitDir();
2212
2213 if( !defined($work->{emptyDir}) )
2214 {
2215 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2216 }
2217 chdir $work->{emptyDir} or
2218 die "Unable to chdir to $work->{emptyDir}\n";
2219
2220 my $ver = `git show-ref -s refs/heads/$state->{module}`;
2221 chomp $ver;
2222 if ($ver !~ /^[0-9a-f]{40}$/)
2223 {
2224 $log->warn("Error from git show-ref -s refs/head$state->{module}");
2225 print "error 1 cannot find the current HEAD of module";
2226 cleanupWorkTree();
2227 exit;
2228 }
2229
2230 if( !defined($work->{index}) )
2231 {
2232 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2233 }
2234
2235 $ENV{GIT_WORK_TREE} = ".";
2236 $ENV{GIT_INDEX_FILE} = $work->{index};
2237 $work->{state} = 1;
2238
2239 system("git","read-tree",$ver);
2240 unless ($? == 0)
2241 {
2242 die "Error running git-read-tree $ver $!\n";
2243 }
2244 }
2245
2246 # Cleanup working directory that is not needed any longer.
2247 sub cleanupWorkTree
2248 {
2249 if( ! $work->{state} )
2250 {
2251 return;
2252 }
2253
2254 chdir "/" or die "Unable to chdir '/'\n";
2255
2256 if( defined($work->{workDir}) )
2257 {
2258 rmtree( $work->{workDir} );
2259 undef $work->{workDir};
2260 }
2261 undef $work->{state};
2262 }
2263
2264 # Setup a temporary directory (not a working tree), typically for
2265 # merging dirty state as in req_update.
2266 sub setupTmpDir
2267 {
2268 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2269 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2270
2271 return $work->{tmpDir};
2272 }
2273
2274 # Clean up a previously setupTmpDir. Restore previous work tree if
2275 # appropriate.
2276 sub cleanupTmpDir
2277 {
2278 if ( !defined($work->{tmpDir}) )
2279 {
2280 $log->warn("cleanup tmpdir that has not been setup");
2281 die "Cleanup tmpDir that has not been setup\n";
2282 }
2283 if( defined($work->{state}) )
2284 {
2285 if( $work->{state} == 1 )
2286 {
2287 chdir $work->{emptyDir} or
2288 die "Unable to chdir to $work->{emptyDir}\n";
2289 }
2290 elsif( $work->{state} == 2 )
2291 {
2292 chdir $work->{workDir} or
2293 die "Unable to chdir to $work->{emptyDir}\n";
2294 }
2295 else
2296 {
2297 $log->warn("Inconsistent work dir state");
2298 die "Inconsistent work dir state\n";
2299 }
2300 }
2301 else
2302 {
2303 chdir "/" or die "Unable to chdir '/'\n";
2304 }
2305 }
2306
2307 # Given a path, this function returns a string containing the kopts
2308 # that should go into that path's Entries line. For example, a binary
2309 # file should get -kb.
2310 sub kopts_from_path
2311 {
2312 my ($path, $srcType, $name) = @_;
2313
2314 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2315 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2316 {
2317 my ($val) = check_attr( "crlf", $path );
2318 if ( $val eq "set" )
2319 {
2320 return "";
2321 }
2322 elsif ( $val eq "unset" )
2323 {
2324 return "-kb"
2325 }
2326 else
2327 {
2328 $log->info("Unrecognized check_attr crlf $path : $val");
2329 }
2330 }
2331
2332 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2333 {
2334 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2335 {
2336 return "-kb";
2337 }
2338 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2339 {
2340 if( $srcType eq "sha1Or-k" &&
2341 !defined($name) )
2342 {
2343 my ($ret)=$state->{entries}{$path}{options};
2344 if( !defined($ret) )
2345 {
2346 $ret=$state->{opt}{k};
2347 if(defined($ret))
2348 {
2349 $ret="-k$ret";
2350 }
2351 else
2352 {
2353 $ret="";
2354 }
2355 }
2356 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2357 {
2358 print "E Bad -k option\n";
2359 $log->warn("Bad -k option: $ret");
2360 die "Error: Bad -k option: $ret\n";
2361 }
2362
2363 return $ret;
2364 }
2365 else
2366 {
2367 if( is_binary($srcType,$name) )
2368 {
2369 $log->debug("... as binary");
2370 return "-kb";
2371 }
2372 else
2373 {
2374 $log->debug("... as text");
2375 }
2376 }
2377 }
2378 }
2379 # Return "" to give no special treatment to any path
2380 return "";
2381 }
2382
2383 sub check_attr
2384 {
2385 my ($attr,$path) = @_;
2386 ensureWorkTree();
2387 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2388 {
2389 my $val = <$fh>;
2390 close $fh;
2391 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2392 return $val;
2393 }
2394 else
2395 {
2396 return undef;
2397 }
2398 }
2399
2400 # This should have the same heuristics as convert.c:is_binary() and related.
2401 # Note that the bare CR test is done by callers in convert.c.
2402 sub is_binary
2403 {
2404 my ($srcType,$name) = @_;
2405 $log->debug("is_binary($srcType,$name)");
2406
2407 # Minimize amount of interpreted code run in the inner per-character
2408 # loop for large files, by totalling each character value and
2409 # then analyzing the totals.
2410 my @counts;
2411 my $i;
2412 for($i=0;$i<256;$i++)
2413 {
2414 $counts[$i]=0;
2415 }
2416
2417 my $fh = open_blob_or_die($srcType,$name);
2418 my $line;
2419 while( defined($line=<$fh>) )
2420 {
2421 # Any '\0' and bare CR are considered binary.
2422 if( $line =~ /\0|(\r[^\n])/ )
2423 {
2424 close($fh);
2425 return 1;
2426 }
2427
2428 # Count up each character in the line:
2429 my $len=length($line);
2430 for($i=0;$i<$len;$i++)
2431 {
2432 $counts[ord(substr($line,$i,1))]++;
2433 }
2434 }
2435 close $fh;
2436
2437 # Don't count CR and LF as either printable/nonprintable
2438 $counts[ord("\n")]=0;
2439 $counts[ord("\r")]=0;
2440
2441 # Categorize individual character count into printable and nonprintable:
2442 my $printable=0;
2443 my $nonprintable=0;
2444 for($i=0;$i<256;$i++)
2445 {
2446 if( $i < 32 &&
2447 $i != ord("\b") &&
2448 $i != ord("\t") &&
2449 $i != 033 && # ESC
2450 $i != 014 ) # FF
2451 {
2452 $nonprintable+=$counts[$i];
2453 }
2454 elsif( $i==127 ) # DEL
2455 {
2456 $nonprintable+=$counts[$i];
2457 }
2458 else
2459 {
2460 $printable+=$counts[$i];
2461 }
2462 }
2463
2464 return ($printable >> 7) < $nonprintable;
2465 }
2466
2467 # Returns open file handle. Possible invocations:
2468 # - open_blob_or_die("file",$filename);
2469 # - open_blob_or_die("sha1",$filehash);
2470 sub open_blob_or_die
2471 {
2472 my ($srcType,$name) = @_;
2473 my ($fh);
2474 if( $srcType eq "file" )
2475 {
2476 if( !open $fh,"<",$name )
2477 {
2478 $log->warn("Unable to open file $name: $!");
2479 die "Unable to open file $name: $!\n";
2480 }
2481 }
2482 elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2483 {
2484 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2485 {
2486 $log->warn("Need filehash");
2487 die "Need filehash\n";
2488 }
2489
2490 my $type = `git cat-file -t $name`;
2491 chomp $type;
2492
2493 unless ( defined ( $type ) and $type eq "blob" )
2494 {
2495 $log->warn("Invalid type '$type' for '$name'");
2496 die ( "Invalid type '$type' (expected 'blob')" )
2497 }
2498
2499 my $size = `git cat-file -s $name`;
2500 chomp $size;
2501
2502 $log->debug("open_blob_or_die($name) size=$size, type=$type");
2503
2504 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2505 {
2506 $log->warn("Unable to open sha1 $name");
2507 die "Unable to open sha1 $name\n";
2508 }
2509 }
2510 else
2511 {
2512 $log->warn("Unknown type of blob source: $srcType");
2513 die "Unknown type of blob source: $srcType\n";
2514 }
2515 return $fh;
2516 }
2517
2518 # Generate a CVS author name from Git author information, by taking
2519 # the first eight characters of the user part of the email address.
2520 sub cvs_author
2521 {
2522 my $author_line = shift;
2523 (my $author) = $author_line =~ /<([^>@]{1,8})/;
2524
2525 $author;
2526 }
2527
2528 package GITCVS::log;
2529
2530 ####
2531 #### Copyright The Open University UK - 2006.
2532 ####
2533 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2534 #### Martin Langhoff <martin@catalyst.net.nz>
2535 ####
2536 ####
2537
2538 use strict;
2539 use warnings;
2540
2541 =head1 NAME
2542
2543 GITCVS::log
2544
2545 =head1 DESCRIPTION
2546
2547 This module provides very crude logging with a similar interface to
2548 Log::Log4perl
2549
2550 =head1 METHODS
2551
2552 =cut
2553
2554 =head2 new
2555
2556 Creates a new log object, optionally you can specify a filename here to
2557 indicate the file to log to. If no log file is specified, you can specify one
2558 later with method setfile, or indicate you no longer want logging with method
2559 nofile.
2560
2561 Until one of these methods is called, all log calls will buffer messages ready
2562 to write out.
2563
2564 =cut
2565 sub new
2566 {
2567 my $class = shift;
2568 my $filename = shift;
2569
2570 my $self = {};
2571
2572 bless $self, $class;
2573
2574 if ( defined ( $filename ) )
2575 {
2576 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2577 }
2578
2579 return $self;
2580 }
2581
2582 =head2 setfile
2583
2584 This methods takes a filename, and attempts to open that file as the log file.
2585 If successful, all buffered data is written out to the file, and any further
2586 logging is written directly to the file.
2587
2588 =cut
2589 sub setfile
2590 {
2591 my $self = shift;
2592 my $filename = shift;
2593
2594 if ( defined ( $filename ) )
2595 {
2596 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2597 }
2598
2599 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2600
2601 while ( my $line = shift @{$self->{buffer}} )
2602 {
2603 print {$self->{fh}} $line;
2604 }
2605 }
2606
2607 =head2 nofile
2608
2609 This method indicates no logging is going to be used. It flushes any entries in
2610 the internal buffer, and sets a flag to ensure no further data is put there.
2611
2612 =cut
2613 sub nofile
2614 {
2615 my $self = shift;
2616
2617 $self->{nolog} = 1;
2618
2619 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2620
2621 $self->{buffer} = [];
2622 }
2623
2624 =head2 _logopen
2625
2626 Internal method. Returns true if the log file is open, false otherwise.
2627
2628 =cut
2629 sub _logopen
2630 {
2631 my $self = shift;
2632
2633 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2634 return 0;
2635 }
2636
2637 =head2 debug info warn fatal
2638
2639 These four methods are wrappers to _log. They provide the actual interface for
2640 logging data.
2641
2642 =cut
2643 sub debug { my $self = shift; $self->_log("debug", @_); }
2644 sub info { my $self = shift; $self->_log("info" , @_); }
2645 sub warn { my $self = shift; $self->_log("warn" , @_); }
2646 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2647
2648 =head2 _log
2649
2650 This is an internal method called by the logging functions. It generates a
2651 timestamp and pushes the logged line either to file, or internal buffer.
2652
2653 =cut
2654 sub _log
2655 {
2656 my $self = shift;
2657 my $level = shift;
2658
2659 return if ( $self->{nolog} );
2660
2661 my @time = localtime;
2662 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2663 $time[5] + 1900,
2664 $time[4] + 1,
2665 $time[3],
2666 $time[2],
2667 $time[1],
2668 $time[0],
2669 uc $level,
2670 );
2671
2672 if ( $self->_logopen )
2673 {
2674 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2675 } else {
2676 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2677 }
2678 }
2679
2680 =head2 DESTROY
2681
2682 This method simply closes the file handle if one is open
2683
2684 =cut
2685 sub DESTROY
2686 {
2687 my $self = shift;
2688
2689 if ( $self->_logopen )
2690 {
2691 close $self->{fh};
2692 }
2693 }
2694
2695 package GITCVS::updater;
2696
2697 ####
2698 #### Copyright The Open University UK - 2006.
2699 ####
2700 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2701 #### Martin Langhoff <martin@catalyst.net.nz>
2702 ####
2703 ####
2704
2705 use strict;
2706 use warnings;
2707 use DBI;
2708
2709 =head1 METHODS
2710
2711 =cut
2712
2713 =head2 new
2714
2715 =cut
2716 sub new
2717 {
2718 my $class = shift;
2719 my $config = shift;
2720 my $module = shift;
2721 my $log = shift;
2722
2723 die "Need to specify a git repository" unless ( defined($config) and -d $config );
2724 die "Need to specify a module" unless ( defined($module) );
2725
2726 $class = ref($class) || $class;
2727
2728 my $self = {};
2729
2730 bless $self, $class;
2731
2732 $self->{valid_tables} = {'revision' => 1,
2733 'revision_ix1' => 1,
2734 'revision_ix2' => 1,
2735 'head' => 1,
2736 'head_ix1' => 1,
2737 'properties' => 1,
2738 'commitmsgs' => 1};
2739
2740 $self->{module} = $module;
2741 $self->{git_path} = $config . "/";
2742
2743 $self->{log} = $log;
2744
2745 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2746
2747 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2748 $cfg->{gitcvs}{dbdriver} || "SQLite";
2749 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2750 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2751 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2752 $cfg->{gitcvs}{dbuser} || "";
2753 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2754 $cfg->{gitcvs}{dbpass} || "";
2755 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2756 $cfg->{gitcvs}{dbtablenameprefix} || "";
2757 my %mapping = ( m => $module,
2758 a => $state->{method},
2759 u => getlogin || getpwuid($<) || $<,
2760 G => $self->{git_path},
2761 g => mangle_dirname($self->{git_path}),
2762 );
2763 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2764 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2765 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2766 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2767
2768 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2769 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2770 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2771 $self->{dbuser},
2772 $self->{dbpass});
2773 die "Error connecting to database\n" unless defined $self->{dbh};
2774
2775 $self->{tables} = {};
2776 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2777 {
2778 $self->{tables}{$table} = 1;
2779 }
2780
2781 # Construct the revision table if required
2782 unless ( $self->{tables}{$self->tablename("revision")} )
2783 {
2784 my $tablename = $self->tablename("revision");
2785 my $ix1name = $self->tablename("revision_ix1");
2786 my $ix2name = $self->tablename("revision_ix2");
2787 $self->{dbh}->do("
2788 CREATE TABLE $tablename (
2789 name TEXT NOT NULL,
2790 revision INTEGER NOT NULL,
2791 filehash TEXT NOT NULL,
2792 commithash TEXT NOT NULL,
2793 author TEXT NOT NULL,
2794 modified TEXT NOT NULL,
2795 mode TEXT NOT NULL
2796 )
2797 ");
2798 $self->{dbh}->do("
2799 CREATE INDEX $ix1name
2800 ON $tablename (name,revision)
2801 ");
2802 $self->{dbh}->do("
2803 CREATE INDEX $ix2name
2804 ON $tablename (name,commithash)
2805 ");
2806 }
2807
2808 # Construct the head table if required
2809 unless ( $self->{tables}{$self->tablename("head")} )
2810 {
2811 my $tablename = $self->tablename("head");
2812 my $ix1name = $self->tablename("head_ix1");
2813 $self->{dbh}->do("
2814 CREATE TABLE $tablename (
2815 name TEXT NOT NULL,
2816 revision INTEGER NOT NULL,
2817 filehash TEXT NOT NULL,
2818 commithash TEXT NOT NULL,
2819 author TEXT NOT NULL,
2820 modified TEXT NOT NULL,
2821 mode TEXT NOT NULL
2822 )
2823 ");
2824 $self->{dbh}->do("
2825 CREATE INDEX $ix1name
2826 ON $tablename (name)
2827 ");
2828 }
2829
2830 # Construct the properties table if required
2831 unless ( $self->{tables}{$self->tablename("properties")} )
2832 {
2833 my $tablename = $self->tablename("properties");
2834 $self->{dbh}->do("
2835 CREATE TABLE $tablename (
2836 key TEXT NOT NULL PRIMARY KEY,
2837 value TEXT
2838 )
2839 ");
2840 }
2841
2842 # Construct the commitmsgs table if required
2843 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2844 {
2845 my $tablename = $self->tablename("commitmsgs");
2846 $self->{dbh}->do("
2847 CREATE TABLE $tablename (
2848 key TEXT NOT NULL PRIMARY KEY,
2849 value TEXT
2850 )
2851 ");
2852 }
2853
2854 return $self;
2855 }
2856
2857 =head2 tablename
2858
2859 =cut
2860 sub tablename
2861 {
2862 my $self = shift;
2863 my $name = shift;
2864
2865 if (exists $self->{valid_tables}{$name}) {
2866 return $self->{dbtablenameprefix} . $name;
2867 } else {
2868 return undef;
2869 }
2870 }
2871
2872 =head2 update
2873
2874 =cut
2875 sub update
2876 {
2877 my $self = shift;
2878
2879 # first lets get the commit list
2880 $ENV{GIT_DIR} = $self->{git_path};
2881
2882 my $commitsha1 = `git rev-parse $self->{module}`;
2883 chomp $commitsha1;
2884
2885 my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2886 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2887 {
2888 die("Invalid module '$self->{module}'");
2889 }
2890
2891
2892 my $git_log;
2893 my $lastcommit = $self->_get_prop("last_commit");
2894
2895 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2896 return 1;
2897 }
2898
2899 # Start exclusive lock here...
2900 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2901
2902 # TODO: log processing is memory bound
2903 # if we can parse into a 2nd file that is in reverse order
2904 # we can probably do something really efficient
2905 my @git_log_params = ('--pretty', '--parents', '--topo-order');
2906
2907 if (defined $lastcommit) {
2908 push @git_log_params, "$lastcommit..$self->{module}";
2909 } else {
2910 push @git_log_params, $self->{module};
2911 }
2912 # git-rev-list is the backend / plumbing version of git-log
2913 open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2914
2915 my @commits;
2916
2917 my %commit = ();
2918
2919 while ( <GITLOG> )
2920 {
2921 chomp;
2922 if (m/^commit\s+(.*)$/) {
2923 # on ^commit lines put the just seen commit in the stack
2924 # and prime things for the next one
2925 if (keys %commit) {
2926 my %copy = %commit;
2927 unshift @commits, \%copy;
2928 %commit = ();
2929 }
2930 my @parents = split(m/\s+/, $1);
2931 $commit{hash} = shift @parents;
2932 $commit{parents} = \@parents;
2933 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2934 # on rfc822-like lines seen before we see any message,
2935 # lowercase the entry and put it in the hash as key-value
2936 $commit{lc($1)} = $2;
2937 } else {
2938 # message lines - skip initial empty line
2939 # and trim whitespace
2940 if (!exists($commit{message}) && m/^\s*$/) {
2941 # define it to mark the end of headers
2942 $commit{message} = '';
2943 next;
2944 }
2945 s/^\s+//; s/\s+$//; # trim ws
2946 $commit{message} .= $_ . "\n";
2947 }
2948 }
2949 close GITLOG;
2950
2951 unshift @commits, \%commit if ( keys %commit );
2952
2953 # Now all the commits are in the @commits bucket
2954 # ordered by time DESC. for each commit that needs processing,
2955 # determine whether it's following the last head we've seen or if
2956 # it's on its own branch, grab a file list, and add whatever's changed
2957 # NOTE: $lastcommit refers to the last commit from previous run
2958 # $lastpicked is the last commit we picked in this run
2959 my $lastpicked;
2960 my $head = {};
2961 if (defined $lastcommit) {
2962 $lastpicked = $lastcommit;
2963 }
2964
2965 my $committotal = scalar(@commits);
2966 my $commitcount = 0;
2967
2968 # Load the head table into $head (for cached lookups during the update process)
2969 foreach my $file ( @{$self->gethead()} )
2970 {
2971 $head->{$file->{name}} = $file;
2972 }
2973
2974 foreach my $commit ( @commits )
2975 {
2976 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2977 if (defined $lastpicked)
2978 {
2979 if (!in_array($lastpicked, @{$commit->{parents}}))
2980 {
2981 # skip, we'll see this delta
2982 # as part of a merge later
2983 # warn "skipping off-track $commit->{hash}\n";
2984 next;
2985 } elsif (@{$commit->{parents}} > 1) {
2986 # it is a merge commit, for each parent that is
2987 # not $lastpicked, see if we can get a log
2988 # from the merge-base to that parent to put it
2989 # in the message as a merge summary.
2990 my @parents = @{$commit->{parents}};
2991 foreach my $parent (@parents) {
2992 # git-merge-base can potentially (but rarely) throw
2993 # several candidate merge bases. let's assume
2994 # that the first one is the best one.
2995 if ($parent eq $lastpicked) {
2996 next;
2997 }
2998 my $base = eval {
2999 safe_pipe_capture('git-merge-base',
3000 $lastpicked, $parent);
3001 };
3002 # The two branches may not be related at all,
3003 # in which case merge base simply fails to find
3004 # any, but that's Ok.
3005 next if ($@);
3006
3007 chomp $base;
3008 if ($base) {
3009 my @merged;
3010 # print "want to log between $base $parent \n";
3011 open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
3012 or die "Cannot call git-log: $!";
3013 my $mergedhash;
3014 while (<GITLOG>) {
3015 chomp;
3016 if (!defined $mergedhash) {
3017 if (m/^commit\s+(.+)$/) {
3018 $mergedhash = $1;
3019 } else {
3020 next;
3021 }
3022 } else {
3023 # grab the first line that looks non-rfc822
3024 # aka has content after leading space
3025 if (m/^\s+(\S.*)$/) {
3026 my $title = $1;
3027 $title = substr($title,0,100); # truncate
3028 unshift @merged, "$mergedhash $title";
3029 undef $mergedhash;
3030 }
3031 }
3032 }
3033 close GITLOG;
3034 if (@merged) {
3035 $commit->{mergemsg} = $commit->{message};
3036 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3037 foreach my $summary (@merged) {
3038 $commit->{mergemsg} .= "\t$summary\n";
3039 }
3040 $commit->{mergemsg} .= "\n\n";
3041 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3042 }
3043 }
3044 }
3045 }
3046 }
3047
3048 # convert the date to CVS-happy format
3049 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3050
3051 if ( defined ( $lastpicked ) )
3052 {
3053 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3054 local ($/) = "\0";
3055 while ( <FILELIST> )
3056 {
3057 chomp;
3058 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3059 {
3060 die("Couldn't process git-diff-tree line : $_");
3061 }
3062 my ($mode, $hash, $change) = ($1, $2, $3);
3063 my $name = <FILELIST>;
3064 chomp($name);
3065
3066 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3067
3068 my $git_perms = "";
3069 $git_perms .= "r" if ( $mode & 4 );
3070 $git_perms .= "w" if ( $mode & 2 );
3071 $git_perms .= "x" if ( $mode & 1 );
3072 $git_perms = "rw" if ( $git_perms eq "" );
3073
3074 if ( $change eq "D" )
3075 {
3076 #$log->debug("DELETE $name");
3077 $head->{$name} = {
3078 name => $name,
3079 revision => $head->{$name}{revision} + 1,
3080 filehash => "deleted",
3081 commithash => $commit->{hash},
3082 modified => $commit->{date},
3083 author => $commit->{author},
3084 mode => $git_perms,
3085 };
3086 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3087 }
3088 elsif ( $change eq "M" || $change eq "T" )
3089 {
3090 #$log->debug("MODIFIED $name");
3091 $head->{$name} = {
3092 name => $name,
3093 revision => $head->{$name}{revision} + 1,
3094 filehash => $hash,
3095 commithash => $commit->{hash},
3096 modified => $commit->{date},
3097 author => $commit->{author},
3098 mode => $git_perms,
3099 };
3100 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3101 }
3102 elsif ( $change eq "A" )
3103 {
3104 #$log->debug("ADDED $name");
3105 $head->{$name} = {
3106 name => $name,
3107 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3108 filehash => $hash,
3109 commithash => $commit->{hash},
3110 modified => $commit->{date},
3111 author => $commit->{author},
3112 mode => $git_perms,
3113 };
3114 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3115 }
3116 else
3117 {
3118 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3119 die;
3120 }
3121 }
3122 close FILELIST;
3123 } else {
3124 # this is used to detect files removed from the repo
3125 my $seen_files = {};
3126
3127 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3128 local $/ = "\0";
3129 while ( <FILELIST> )
3130 {
3131 chomp;
3132 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3133 {
3134 die("Couldn't process git-ls-tree line : $_");
3135 }
3136
3137 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3138
3139 $seen_files->{$git_filename} = 1;
3140
3141 my ( $oldhash, $oldrevision, $oldmode ) = (
3142 $head->{$git_filename}{filehash},
3143 $head->{$git_filename}{revision},
3144 $head->{$git_filename}{mode}
3145 );
3146
3147 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3148 {
3149 $git_perms = "";
3150 $git_perms .= "r" if ( $1 & 4 );
3151 $git_perms .= "w" if ( $1 & 2 );
3152 $git_perms .= "x" if ( $1 & 1 );
3153 } else {
3154 $git_perms = "rw";
3155 }
3156
3157 # unless the file exists with the same hash, we need to update it ...
3158 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3159 {
3160 my $newrevision = ( $oldrevision or 0 ) + 1;
3161
3162 $head->{$git_filename} = {
3163 name => $git_filename,
3164 revision => $newrevision,
3165 filehash => $git_hash,
3166 commithash => $commit->{hash},
3167 modified => $commit->{date},
3168 author => $commit->{author},
3169 mode => $git_perms,
3170 };
3171
3172
3173 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3174 }
3175 }
3176 close FILELIST;
3177
3178 # Detect deleted files
3179 foreach my $file ( keys %$head )
3180 {
3181 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3182 {
3183 $head->{$file}{revision}++;
3184 $head->{$file}{filehash} = "deleted";
3185 $head->{$file}{commithash} = $commit->{hash};
3186 $head->{$file}{modified} = $commit->{date};
3187 $head->{$file}{author} = $commit->{author};
3188
3189 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3190 }
3191 }
3192 # END : "Detect deleted files"
3193 }
3194
3195
3196 if (exists $commit->{mergemsg})
3197 {
3198 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3199 }
3200
3201 $lastpicked = $commit->{hash};
3202
3203 $self->_set_prop("last_commit", $commit->{hash});
3204 }
3205
3206 $self->delete_head();
3207 foreach my $file ( keys %$head )
3208 {
3209 $self->insert_head(
3210 $file,
3211 $head->{$file}{revision},
3212 $head->{$file}{filehash},
3213 $head->{$file}{commithash},
3214 $head->{$file}{modified},
3215 $head->{$file}{author},
3216 $head->{$file}{mode},
3217 );
3218 }
3219 # invalidate the gethead cache
3220 $self->{gethead_cache} = undef;
3221
3222
3223 # Ending exclusive lock here
3224 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3225 }
3226
3227 sub insert_rev
3228 {
3229 my $self = shift;
3230 my $name = shift;
3231 my $revision = shift;
3232 my $filehash = shift;
3233 my $commithash = shift;
3234 my $modified = shift;
3235 my $author = shift;
3236 my $mode = shift;
3237 my $tablename = $self->tablename("revision");
3238
3239 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3240 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3241 }
3242
3243 sub insert_mergelog
3244 {
3245 my $self = shift;
3246 my $key = shift;
3247 my $value = shift;
3248 my $tablename = $self->tablename("commitmsgs");
3249
3250 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3251 $insert_mergelog->execute($key, $value);
3252 }
3253
3254 sub delete_head
3255 {
3256 my $self = shift;
3257 my $tablename = $self->tablename("head");
3258
3259 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3260 $delete_head->execute();
3261 }
3262
3263 sub insert_head
3264 {
3265 my $self = shift;
3266 my $name = shift;
3267 my $revision = shift;
3268 my $filehash = shift;
3269 my $commithash = shift;
3270 my $modified = shift;
3271 my $author = shift;
3272 my $mode = shift;
3273 my $tablename = $self->tablename("head");
3274
3275 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3276 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3277 }
3278
3279 sub _headrev
3280 {
3281 my $self = shift;
3282 my $filename = shift;
3283 my $tablename = $self->tablename("head");
3284
3285 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3286 $db_query->execute($filename);
3287 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3288
3289 return ( $hash, $revision, $mode );
3290 }
3291
3292 sub _get_prop
3293 {
3294 my $self = shift;
3295 my $key = shift;
3296 my $tablename = $self->tablename("properties");
3297
3298 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3299 $db_query->execute($key);
3300 my ( $value ) = $db_query->fetchrow_array;
3301
3302 return $value;
3303 }
3304
3305 sub _set_prop
3306 {
3307 my $self = shift;
3308 my $key = shift;
3309 my $value = shift;
3310 my $tablename = $self->tablename("properties");
3311
3312 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3313 $db_query->execute($value, $key);
3314
3315 unless ( $db_query->rows )
3316 {
3317 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3318 $db_query->execute($key, $value);
3319 }
3320
3321 return $value;
3322 }
3323
3324 =head2 gethead
3325
3326 =cut
3327
3328 sub gethead
3329 {
3330 my $self = shift;
3331 my $tablename = $self->tablename("head");
3332
3333 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3334
3335 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3336 $db_query->execute();
3337
3338 my $tree = [];
3339 while ( my $file = $db_query->fetchrow_hashref )
3340 {
3341 push @$tree, $file;
3342 }
3343
3344 $self->{gethead_cache} = $tree;
3345
3346 return $tree;
3347 }
3348
3349 =head2 getlog
3350
3351 =cut
3352
3353 sub getlog
3354 {
3355 my $self = shift;
3356 my $filename = shift;
3357 my $tablename = $self->tablename("revision");
3358
3359 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3360 $db_query->execute($filename);
3361
3362 my $tree = [];
3363 while ( my $file = $db_query->fetchrow_hashref )
3364 {
3365 push @$tree, $file;
3366 }
3367
3368 return $tree;
3369 }
3370
3371 =head2 getmeta
3372
3373 This function takes a filename (with path) argument and returns a hashref of
3374 metadata for that file.
3375
3376 =cut
3377
3378 sub getmeta
3379 {
3380 my $self = shift;
3381 my $filename = shift;
3382 my $revision = shift;
3383 my $tablename_rev = $self->tablename("revision");
3384 my $tablename_head = $self->tablename("head");
3385
3386 my $db_query;
3387 if ( defined($revision) and $revision =~ /^\d+$/ )
3388 {
3389 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3390 $db_query->execute($filename, $revision);
3391 }
3392 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3393 {
3394 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3395 $db_query->execute($filename, $revision);
3396 } else {
3397 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3398 $db_query->execute($filename);
3399 }
3400
3401 return $db_query->fetchrow_hashref;
3402 }
3403
3404 =head2 commitmessage
3405
3406 this function takes a commithash and returns the commit message for that commit
3407
3408 =cut
3409 sub commitmessage
3410 {
3411 my $self = shift;
3412 my $commithash = shift;
3413 my $tablename = $self->tablename("commitmsgs");
3414
3415 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3416
3417 my $db_query;
3418 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3419 $db_query->execute($commithash);
3420
3421 my ( $message ) = $db_query->fetchrow_array;
3422
3423 if ( defined ( $message ) )
3424 {
3425 $message .= " " if ( $message =~ /\n$/ );
3426 return $message;
3427 }
3428
3429 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3430 shift @lines while ( $lines[0] =~ /\S/ );
3431 $message = join("",@lines);
3432 $message .= " " if ( $message =~ /\n$/ );
3433 return $message;
3434 }
3435
3436 =head2 gethistory
3437
3438 This function takes a filename (with path) argument and returns an arrayofarrays
3439 containing revision,filehash,commithash ordered by revision descending
3440
3441 =cut
3442 sub gethistory
3443 {
3444 my $self = shift;
3445 my $filename = shift;
3446 my $tablename = $self->tablename("revision");
3447
3448 my $db_query;
3449 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3450 $db_query->execute($filename);
3451
3452 return $db_query->fetchall_arrayref;
3453 }
3454
3455 =head2 gethistorydense
3456
3457 This function takes a filename (with path) argument and returns an arrayofarrays
3458 containing revision,filehash,commithash order