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