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