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