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