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