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