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