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