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