Code

Make lazy mkdir more robust.
[git.git] / git-cvsserver.perl
1 #!/usr/bin/perl
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 ####
18 use strict;
19 use warnings;
21 use Fcntl;
22 use File::Temp qw/tempdir tempfile/;
23 use File::Basename;
25 my $log = GITCVS::log->new();
26 my $cfg;
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 };
43 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
44 $| = 1;
46 #### Definition and mappings of functions ####
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 };
79 ##############################################
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 -----------------");
87 my $TEMP_DIR = tempdir( CLEANUP => 1 );
88 $log->debug("Temporary directory is '$TEMP_DIR'");
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...
115 # Keep going until the client closes the connection
116 while (<STDIN>)
118     chomp;
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     }
136 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
137 $log->info("--------------- FINISH -----------------");
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
145     my ( $cmd, $data ) = @_;
146     $log->warn("Unhandled command : req_$cmd : $data");
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
161     my ( $cmd, $data ) = @_;
162     $log->debug("req_Root : $data");
164     $state->{CVSROOT} = $data;
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     }
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     }
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     }
196     if ( defined ( $cfg->{gitcvs}{logfile} ) )
197     {
198         $log->setfile($cfg->{gitcvs}{logfile});
199     } else {
200         $log->nofile();
201     }
203     return 1;
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
215     my ( $cmd, $data ) = @_;
216     $log->debug("req_Globaloption : $data");
217     $state->{globaloptions}{$data} = 1;
220 # Valid-responses request-list \n
221 #     Response expected: no. Tell the server what responses the client will
222 #     accept. request-list is a space separated list of tokens.
223 sub req_Validresponses
225     my ( $cmd, $data ) = @_;
226     $log->debug("req_Validresponses : $data");
228     # TODO : re-enable this, currently it's not particularly useful
229     #$state->{validresponses} = [ split /\s+/, $data ];
232 # valid-requests \n
233 #     Response expected: yes. Ask the server to send back a Valid-requests
234 #     response.
235 sub req_validrequests
237     my ( $cmd, $data ) = @_;
239     $log->debug("req_validrequests");
241     $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
242     $log->debug("SEND : ok");
244     print "Valid-requests " . join(" ",keys %$methods) . "\n";
245     print "ok\n";
248 # Directory local-directory \n
249 #     Additional data: repository \n. Response expected: no. Tell the server
250 #     what directory to use. The repository should be a directory name from a
251 #     previous server response. Note that this both gives a default for Entry
252 #     and Modified and also for ci and the other commands; normal usage is to
253 #     send Directory for each directory in which there will be an Entry or
254 #     Modified, and then a final Directory for the original directory, then the
255 #     command. The local-directory is relative to the top level at which the
256 #     command is occurring (i.e. the last Directory which is sent before the
257 #     command); to indicate that top level, `.' should be sent for
258 #     local-directory.
259 sub req_Directory
261     my ( $cmd, $data ) = @_;
263     my $repository = <STDIN>;
264     chomp $repository;
267     $state->{localdir} = $data;
268     $state->{repository} = $repository;
269     $state->{path} = $repository;
270     $state->{path} =~ s/^$state->{CVSROOT}\///;
271     $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
272     $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
274     $state->{directory} = $state->{localdir};
275     $state->{directory} = "" if ( $state->{directory} eq "." );
276     $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
278     if ( not defined($state->{prependdir}) and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
279     {
280         $log->info("Setting prepend to '$state->{path}'");
281         $state->{prependdir} = $state->{path};
282         foreach my $entry ( keys %{$state->{entries}} )
283         {
284             $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
285             delete $state->{entries}{$entry};
286         }
287     }
289     if ( defined ( $state->{prependdir} ) )
290     {
291         $log->debug("Prepending '$state->{prependdir}' to state|directory");
292         $state->{directory} = $state->{prependdir} . $state->{directory}
293     }
294     $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
297 # Entry entry-line \n
298 #     Response expected: no. Tell the server what version of a file is on the
299 #     local machine. The name in entry-line is a name relative to the directory
300 #     most recently specified with Directory. If the user is operating on only
301 #     some files in a directory, Entry requests for only those files need be
302 #     included. If an Entry request is sent without Modified, Is-modified, or
303 #     Unchanged, it means the file is lost (does not exist in the working
304 #     directory). If both Entry and one of Modified, Is-modified, or Unchanged
305 #     are sent for the same file, Entry must be sent first. For a given file,
306 #     one can send Modified, Is-modified, or Unchanged, but not more than one
307 #     of these three.
308 sub req_Entry
310     my ( $cmd, $data ) = @_;
312     #$log->debug("req_Entry : $data");
314     my @data = split(/\//, $data);
316     $state->{entries}{$state->{directory}.$data[1]} = {
317         revision    => $data[2],
318         conflict    => $data[3],
319         options     => $data[4],
320         tag_or_date => $data[5],
321     };
323     $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
326 # Questionable filename \n
327 #     Response expected: no. Additional data: no. Tell the server to check
328 #     whether filename should be ignored, and if not, next time the server
329 #     sends responses, send (in a M response) `?' followed by the directory and
330 #     filename. filename must not contain `/'; it needs to be a file in the
331 #     directory named by the most recent Directory request.
332 sub req_Questionable
334     my ( $cmd, $data ) = @_;
336     $log->debug("req_Questionable : $data");
337     $state->{entries}{$state->{directory}.$data}{questionable} = 1;
340 # add \n
341 #     Response expected: yes. Add a file or directory. This uses any previous
342 #     Argument, Directory, Entry, or Modified requests, if they have been sent.
343 #     The last Directory sent specifies the working directory at the time of
344 #     the operation. To add a directory, send the directory to be added using
345 #     Directory and Argument requests.
346 sub req_add
348     my ( $cmd, $data ) = @_;
350     argsplit("add");
352     my $addcount = 0;
354     foreach my $filename ( @{$state->{args}} )
355     {
356         $filename = filecleanup($filename);
358         unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
359         {
360             print "E cvs add: nothing known about `$filename'\n";
361             next;
362         }
363         # TODO : check we're not squashing an already existing file
364         if ( defined ( $state->{entries}{$filename}{revision} ) )
365         {
366             print "E cvs add: `$filename' has already been entered\n";
367             next;
368         }
370         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
372         print "E cvs add: scheduling file `$filename' for addition\n";
374         print "Checked-in $dirpart\n";
375         print "$filename\n";
376         print "/$filepart/0///\n";
378         $addcount++;
379     }
381     if ( $addcount == 1 )
382     {
383         print "E cvs add: use `cvs commit' to add this file permanently\n";
384     }
385     elsif ( $addcount > 1 )
386     {
387         print "E cvs add: use `cvs commit' to add these files permanently\n";
388     }
390     print "ok\n";
393 # remove \n
394 #     Response expected: yes. Remove a file. This uses any previous Argument,
395 #     Directory, Entry, or Modified requests, if they have been sent. The last
396 #     Directory sent specifies the working directory at the time of the
397 #     operation. Note that this request does not actually do anything to the
398 #     repository; the only effect of a successful remove request is to supply
399 #     the client with a new entries line containing `-' to indicate a removed
400 #     file. In fact, the client probably could perform this operation without
401 #     contacting the server, although using remove may cause the server to
402 #     perform a few more checks. The client sends a subsequent ci request to
403 #     actually record the removal in the repository.
404 sub req_remove
406     my ( $cmd, $data ) = @_;
408     argsplit("remove");
410     # Grab a handle to the SQLite db and do any necessary updates
411     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
412     $updater->update();
414     #$log->debug("add state : " . Dumper($state));
416     my $rmcount = 0;
418     foreach my $filename ( @{$state->{args}} )
419     {
420         $filename = filecleanup($filename);
422         if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
423         {
424             print "E cvs remove: file `$filename' still in working directory\n";
425             next;
426         }
428         my $meta = $updater->getmeta($filename);
429         my $wrev = revparse($filename);
431         unless ( defined ( $wrev ) )
432         {
433             print "E cvs remove: nothing known about `$filename'\n";
434             next;
435         }
437         if ( defined($wrev) and $wrev < 0 )
438         {
439             print "E cvs remove: file `$filename' already scheduled for removal\n";
440             next;
441         }
443         unless ( $wrev == $meta->{revision} )
444         {
445             # TODO : not sure if the format of this message is quite correct.
446             print "E cvs remove: Up to date check failed for `$filename'\n";
447             next;
448         }
451         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
453         print "E cvs remove: scheduling `$filename' for removal\n";
455         print "Checked-in $dirpart\n";
456         print "$filename\n";
457         print "/$filepart/-1.$wrev///\n";
459         $rmcount++;
460     }
462     if ( $rmcount == 1 )
463     {
464         print "E cvs remove: use `cvs commit' to remove this file permanently\n";
465     }
466     elsif ( $rmcount > 1 )
467     {
468         print "E cvs remove: use `cvs commit' to remove these files permanently\n";
469     }
471     print "ok\n";
474 # Modified filename \n
475 #     Response expected: no. Additional data: mode, \n, file transmission. Send
476 #     the server a copy of one locally modified file. filename is a file within
477 #     the most recent directory sent with Directory; it must not contain `/'.
478 #     If the user is operating on only some files in a directory, only those
479 #     files need to be included. This can also be sent without Entry, if there
480 #     is no entry for the file.
481 sub req_Modified
483     my ( $cmd, $data ) = @_;
485     my $mode = <STDIN>;
486     chomp $mode;
487     my $size = <STDIN>;
488     chomp $size;
490     # Grab config information
491     my $blocksize = 8192;
492     my $bytesleft = $size;
493     my $tmp;
495     # Get a filehandle/name to write it to
496     my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
498     # Loop over file data writing out to temporary file.
499     while ( $bytesleft )
500     {
501         $blocksize = $bytesleft if ( $bytesleft < $blocksize );
502         read STDIN, $tmp, $blocksize;
503         print $fh $tmp;
504         $bytesleft -= $blocksize;
505     }
507     close $fh;
509     # Ensure we have something sensible for the file mode
510     if ( $mode =~ /u=(\w+)/ )
511     {
512         $mode = $1;
513     } else {
514         $mode = "rw";
515     }
517     # Save the file data in $state
518     $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
519     $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
520     $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
521     $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
523     #$log->debug("req_Modified : file=$data mode=$mode size=$size");
526 # Unchanged filename \n
527 #     Response expected: no. Tell the server that filename has not been
528 #     modified in the checked out directory. The filename is a file within the
529 #     most recent directory sent with Directory; it must not contain `/'.
530 sub req_Unchanged
532     my ( $cmd, $data ) = @_;
534     $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
536     #$log->debug("req_Unchanged : $data");
539 # Argument text \n
540 #     Response expected: no. Save argument for use in a subsequent command.
541 #     Arguments accumulate until an argument-using command is given, at which
542 #     point they are forgotten.
543 # Argumentx text \n
544 #     Response expected: no. Append \n followed by text to the current argument
545 #     being saved.
546 sub req_Argument
548     my ( $cmd, $data ) = @_;
550     # TODO :  Not quite sure how Argument and Argumentx differ, but I assume
551     # it's for multi-line arguments ... somehow ...
553     $log->debug("$cmd : $data");
555     push @{$state->{arguments}}, $data;
558 # expand-modules \n
559 #     Response expected: yes. Expand the modules which are specified in the
560 #     arguments. Returns the data in Module-expansion responses. Note that the
561 #     server can assume that this is checkout or export, not rtag or rdiff; the
562 #     latter do not access the working directory and thus have no need to
563 #     expand modules on the client side. Expand may not be the best word for
564 #     what this request does. It does not necessarily tell you all the files
565 #     contained in a module, for example. Basically it is a way of telling you
566 #     which working directories the server needs to know about in order to
567 #     handle a checkout of the specified modules. For example, suppose that the
568 #     server has a module defined by
569 #   aliasmodule -a 1dir
570 #     That is, one can check out aliasmodule and it will take 1dir in the
571 #     repository and check it out to 1dir in the working directory. Now suppose
572 #     the client already has this module checked out and is planning on using
573 #     the co request to update it. Without using expand-modules, the client
574 #     would have two bad choices: it could either send information about all
575 #     working directories under the current directory, which could be
576 #     unnecessarily slow, or it could be ignorant of the fact that aliasmodule
577 #     stands for 1dir, and neglect to send information for 1dir, which would
578 #     lead to incorrect operation. With expand-modules, the client would first
579 #     ask for the module to be expanded:
580 sub req_expandmodules
582     my ( $cmd, $data ) = @_;
584     argsplit();
586     $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
588     unless ( ref $state->{arguments} eq "ARRAY" )
589     {
590         print "ok\n";
591         return;
592     }
594     foreach my $module ( @{$state->{arguments}} )
595     {
596         $log->debug("SEND : Module-expansion $module");
597         print "Module-expansion $module\n";
598     }
600     print "ok\n";
601     statecleanup();
604 # co \n
605 #     Response expected: yes. Get files from the repository. This uses any
606 #     previous Argument, Directory, Entry, or Modified requests, if they have
607 #     been sent. Arguments to this command are module names; the client cannot
608 #     know what directories they correspond to except by (1) just sending the
609 #     co request, and then seeing what directory names the server sends back in
610 #     its responses, and (2) the expand-modules request.
611 sub req_co
613     my ( $cmd, $data ) = @_;
615     argsplit("co");
617     my $module = $state->{args}[0];
618     my $checkout_path = $module;
620     # use the user specified directory if we're given it
621     $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
623     $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
625     $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
627     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
629     # Grab a handle to the SQLite db and do any necessary updates
630     my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
631     $updater->update();
633     $checkout_path =~ s|/$||; # get rid of trailing slashes
635     # Eclipse seems to need the Clear-sticky command
636     # to prepare the 'Entries' file for the new directory.
637     print "Clear-sticky $checkout_path/\n";
638     print $state->{CVSROOT} . "/$module/\n";
639     print "Clear-static-directory $checkout_path/\n";
640     print $state->{CVSROOT} . "/$module/\n";
641     print "Clear-sticky $checkout_path/\n"; # yes, twice
642     print $state->{CVSROOT} . "/$module/\n";
643     print "Template $checkout_path/\n";
644     print $state->{CVSROOT} . "/$module/\n";
645     print "0\n";
647     # instruct the client that we're checking out to $checkout_path
648     print "E cvs checkout: Updating $checkout_path\n";
650     my %seendirs = ();
651     my $lastdir ='';
653     # recursive
654     sub prepdir {
655        my ($dir, $repodir, $remotedir, $seendirs) = @_;
656        my $parent = dirname($dir);
657        $dir       =~ s|/+$||;
658        $repodir   =~ s|/+$||;
659        $remotedir =~ s|/+$||;
660        $parent    =~ s|/+$||;
661        $log->debug("announcedir $dir, $repodir, $remotedir" );
663        if ($parent eq '.' || $parent eq './') {
664            $parent = '';
665        }
666        # recurse to announce unseen parents first
667        if (length($parent) && !exists($seendirs->{$parent})) {
668            prepdir($parent, $repodir, $remotedir, $seendirs);
669        }
670        # Announce that we are going to modify at the parent level
671        if ($parent) {
672            print "E cvs checkout: Updating $remotedir/$parent\n";
673        } else {
674            print "E cvs checkout: Updating $remotedir\n";
675        }
676        print "Clear-sticky $remotedir/$parent/\n";
677        print "$repodir/$parent/\n";
679        print "Clear-static-directory $remotedir/$dir/\n";
680        print "$repodir/$dir/\n";
681        print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
682        print "$repodir/$parent/\n";
683        print "Template $remotedir/$dir/\n";
684        print "$repodir/$dir/\n";
685        print "0\n";
687        $seendirs->{$dir} = 1;
688     }
690     foreach my $git ( @{$updater->gethead} )
691     {
692         # Don't want to check out deleted files
693         next if ( $git->{filehash} eq "deleted" );
695         ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
697        if (length($git->{dir}) && $git->{dir} ne './'
698            && $git->{dir} ne $lastdir ) {
699            unless (exists($seendirs{$git->{dir}})) {
700                prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
701                        $checkout_path, \%seendirs);
702                $lastdir = $git->{dir};
703                $seendirs{$git->{dir}} = 1;
704            }
705            print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
706        }
708         # modification time of this file
709         print "Mod-time $git->{modified}\n";
711         # print some information to the client
712         if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
713         {
714             print "M U $checkout_path/$git->{dir}$git->{name}\n";
715         } else {
716             print "M U $checkout_path/$git->{name}\n";
717         }
719        # instruct client we're sending a file to put in this path
720        print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
722        print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
724         # this is an "entries" line
725         print "/$git->{name}/1.$git->{revision}///\n";
726         # permissions
727         print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
729         # transmit file
730         transmitfile($git->{filehash});
731     }
733     print "ok\n";
735     statecleanup();
738 # update \n
739 #     Response expected: yes. Actually do a cvs update command. This uses any
740 #     previous Argument, Directory, Entry, or Modified requests, if they have
741 #     been sent. The last Directory sent specifies the working directory at the
742 #     time of the operation. The -I option is not used--files which the client
743 #     can decide whether to ignore are not mentioned and the client sends the
744 #     Questionable request for others.
745 sub req_update
747     my ( $cmd, $data ) = @_;
749     $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
751     argsplit("update");
753     #
754     # It may just be a client exploring the available heads/modules
755     # in that case, list them as top level directories and leave it
756     # at that. Eclipse uses this technique to offer you a list of
757     # projects (heads in this case) to checkout.
758     #
759     if ($state->{module} eq '') {
760         print "E cvs update: Updating .\n";
761         opendir HEADS, $state->{CVSROOT} . '/refs/heads';
762         while (my $head = readdir(HEADS)) {
763             if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
764                 print "E cvs update: New directory `$head'\n";
765             }
766         }
767         closedir HEADS;
768         print "ok\n";
769         return 1;
770     }
773     # Grab a handle to the SQLite db and do any necessary updates
774     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
776     $updater->update();
778     argsfromdir($updater);
780     #$log->debug("update state : " . Dumper($state));
782     # foreach file specified on the command line ...
783     foreach my $filename ( @{$state->{args}} )
784     {
785         $filename = filecleanup($filename);
787         $log->debug("Processing file $filename");
789         # if we have a -C we should pretend we never saw modified stuff
790         if ( exists ( $state->{opt}{C} ) )
791         {
792             delete $state->{entries}{$filename}{modified_hash};
793             delete $state->{entries}{$filename}{modified_filename};
794             $state->{entries}{$filename}{unchanged} = 1;
795         }
797         my $meta;
798         if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
799         {
800             $meta = $updater->getmeta($filename, $1);
801         } else {
802             $meta = $updater->getmeta($filename);
803         }
805         next unless ( $meta->{revision} );
807         my $oldmeta = $meta;
809         my $wrev = revparse($filename);
811         # If the working copy is an old revision, lets get that version too for comparison.
812         if ( defined($wrev) and $wrev != $meta->{revision} )
813         {
814             $oldmeta = $updater->getmeta($filename, $wrev);
815         }
817         #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
819         # Files are up to date if the working copy and repo copy have the same revision,
820         # and the working copy is unmodified _and_ the user hasn't specified -C
821         next if ( defined ( $wrev )
822                   and defined($meta->{revision})
823                   and $wrev == $meta->{revision}
824                   and $state->{entries}{$filename}{unchanged}
825                   and not exists ( $state->{opt}{C} ) );
827         # If the working copy and repo copy have the same revision,
828         # but the working copy is modified, tell the client it's modified
829         if ( defined ( $wrev )
830              and defined($meta->{revision})
831              and $wrev == $meta->{revision}
832              and not exists ( $state->{opt}{C} ) )
833         {
834             $log->info("Tell the client the file is modified");
835             print "MT text U\n";
836             print "MT fname $filename\n";
837             print "MT newline\n";
838             next;
839         }
841         if ( $meta->{filehash} eq "deleted" )
842         {
843             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
845             $log->info("Removing '$filename' from working copy (no longer in the repo)");
847             print "E cvs update: `$filename' is no longer in the repository\n";
848             # Don't want to actually _DO_ the update if -n specified
849             unless ( $state->{globaloptions}{-n} ) {
850                 print "Removed $dirpart\n";
851                 print "$filepart\n";
852             }
853         }
854         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
855                 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} )
856         {
857             $log->info("Updating '$filename'");
858             # normal update, just send the new revision (either U=Update, or A=Add, or R=Remove)
859             print "MT +updated\n";
860             print "MT text U\n";
861             print "MT fname $filename\n";
862             print "MT newline\n";
863             print "MT -updated\n";
865             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
867             # Don't want to actually _DO_ the update if -n specified
868             unless ( $state->{globaloptions}{-n} )
869             {
870                 if ( defined ( $wrev ) )
871                 {
872                     # instruct client we're sending a file to put in this path as a replacement
873                     print "Update-existing $dirpart\n";
874                     $log->debug("Updating existing file 'Update-existing $dirpart'");
875                 } else {
876                     # instruct client we're sending a file to put in this path as a new file
877                     print "Clear-static-directory $dirpart\n";
878                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
879                     print "Clear-sticky $dirpart\n";
880                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
882                     $log->debug("Creating new file 'Created $dirpart'");
883                     print "Created $dirpart\n";
884                 }
885                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
887                 # this is an "entries" line
888                 $log->debug("/$filepart/1.$meta->{revision}///");
889                 print "/$filepart/1.$meta->{revision}///\n";
891                 # permissions
892                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
893                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
895                 # transmit file
896                 transmitfile($meta->{filehash});
897             }
898         } else {
899             $log->info("Updating '$filename'");
900             my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
902             my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
904             chdir $dir;
905             my $file_local = $filepart . ".mine";
906             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
907             my $file_old = $filepart . "." . $oldmeta->{revision};
908             transmitfile($oldmeta->{filehash}, $file_old);
909             my $file_new = $filepart . "." . $meta->{revision};
910             transmitfile($meta->{filehash}, $file_new);
912             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
913             $log->info("Merging $file_local, $file_old, $file_new");
915             $log->debug("Temporary directory for merge is $dir");
917             my $return = system("merge", $file_local, $file_old, $file_new);
918             $return >>= 8;
920             if ( $return == 0 )
921             {
922                 $log->info("Merged successfully");
923                 print "M M $filename\n";
924                 $log->debug("Update-existing $dirpart");
926                 # Don't want to actually _DO_ the update if -n specified
927                 unless ( $state->{globaloptions}{-n} )
928                 {
929                     print "Update-existing $dirpart\n";
930                     $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
931                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
932                     $log->debug("/$filepart/1.$meta->{revision}///");
933                     print "/$filepart/1.$meta->{revision}///\n";
934                 }
935             }
936             elsif ( $return == 1 )
937             {
938                 $log->info("Merged with conflicts");
939                 print "M C $filename\n";
941                 # Don't want to actually _DO_ the update if -n specified
942                 unless ( $state->{globaloptions}{-n} )
943                 {
944                     print "Update-existing $dirpart\n";
945                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
946                     print "/$filepart/1.$meta->{revision}/+//\n";
947                 }
948             }
949             else
950             {
951                 $log->warn("Merge failed");
952                 next;
953             }
955             # Don't want to actually _DO_ the update if -n specified
956             unless ( $state->{globaloptions}{-n} )
957             {
958                 # permissions
959                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
960                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
962                 # transmit file, format is single integer on a line by itself (file
963                 # size) followed by the file contents
964                 # TODO : we should copy files in blocks
965                 my $data = `cat $file_local`;
966                 $log->debug("File size : " . length($data));
967                 print length($data) . "\n";
968                 print $data;
969             }
971             chdir "/";
972         }
974     }
976     print "ok\n";
979 sub req_ci
981     my ( $cmd, $data ) = @_;
983     argsplit("ci");
985     #$log->debug("State : " . Dumper($state));
987     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
989     if ( @ARGV && $ARGV[0] eq 'pserver')
990     {
991         print "error 1 pserver access cannot commit\n";
992         exit;
993     }
995     if ( -e $state->{CVSROOT} . "/index" )
996     {
997         $log->warn("file 'index' already exists in the git repository");
998         print "error 1 Index already exists in git repo\n";
999         exit;
1000     }
1002     my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
1003     unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
1004     {
1005         $log->warn("lockfile '$lockfile' already exists, please try again");
1006         print "error 1 Lock file '$lockfile' already exists, please try again\n";
1007         exit;
1008     }
1010     # Grab a handle to the SQLite db and do any necessary updates
1011     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1012     $updater->update();
1014     my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1015     my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1016     $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
1018     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1019     $ENV{GIT_INDEX_FILE} = $file_index;
1021     chdir $tmpdir;
1023     # populate the temporary index based
1024     system("git-read-tree", $state->{module});
1025     unless ($? == 0)
1026     {
1027         die "Error running git-read-tree $state->{module} $file_index $!";
1028     }
1029     $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
1032     my @committedfiles = ();
1034     # foreach file specified on the command line ...
1035     foreach my $filename ( @{$state->{args}} )
1036     {
1037         my $committedfile = $filename;
1038         $filename = filecleanup($filename);
1040         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1042         my $meta = $updater->getmeta($filename);
1044         my $wrev = revparse($filename);
1046         my ( $filepart, $dirpart ) = filenamesplit($filename);
1048         # do a checkout of the file if it part of this tree
1049         if ($wrev) {
1050             system('git-checkout-index', '-f', '-u', $filename);
1051             unless ($? == 0) {
1052                 die "Error running git-checkout-index -f -u $filename : $!";
1053             }
1054         }
1056         my $addflag = 0;
1057         my $rmflag = 0;
1058         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1059         $addflag = 1 unless ( -e $filename );
1061         # Do up to date checking
1062         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1063         {
1064             # fail everything if an up to date check fails
1065             print "error 1 Up to date check failed for $filename\n";
1066             close LOCKFILE;
1067             unlink($lockfile);
1068             chdir "/";
1069             exit;
1070         }
1072         push @committedfiles, $committedfile;
1073         $log->info("Committing $filename");
1075         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1077         unless ( $rmflag )
1078         {
1079             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1080             rename $state->{entries}{$filename}{modified_filename},$filename;
1082             # Calculate modes to remove
1083             my $invmode = "";
1084             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1086             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1087             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1088         }
1090         if ( $rmflag )
1091         {
1092             $log->info("Removing file '$filename'");
1093             unlink($filename);
1094             system("git-update-index", "--remove", $filename);
1095         }
1096         elsif ( $addflag )
1097         {
1098             $log->info("Adding file '$filename'");
1099             system("git-update-index", "--add", $filename);
1100         } else {
1101             $log->info("Updating file '$filename'");
1102             system("git-update-index", $filename);
1103         }
1104     }
1106     unless ( scalar(@committedfiles) > 0 )
1107     {
1108         print "E No files to commit\n";
1109         print "ok\n";
1110         close LOCKFILE;
1111         unlink($lockfile);
1112         chdir "/";
1113         return;
1114     }
1116     my $treehash = `git-write-tree`;
1117     my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
1118     chomp $treehash;
1119     chomp $parenthash;
1121     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1123     # write our commit message out if we have one ...
1124     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1125     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1126     print $msg_fh "\n\nvia git-CVS emulator\n";
1127     close $msg_fh;
1129     my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1130     $log->info("Commit hash : $commithash");
1132     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1133     {
1134         $log->warn("Commit failed (Invalid commit hash)");
1135         print "error 1 Commit failed (unknown reason)\n";
1136         close LOCKFILE;
1137         unlink($lockfile);
1138         chdir "/";
1139         exit;
1140     }
1142     open FILE, ">", "$ENV{GIT_DIR}refs/heads/$state->{module}";
1143     print FILE $commithash;
1144     close FILE;
1146     $updater->update();
1148     # foreach file specified on the command line ...
1149     foreach my $filename ( @committedfiles )
1150     {
1151         $filename = filecleanup($filename);
1153         my $meta = $updater->getmeta($filename);
1155         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1157         $log->debug("Checked-in $dirpart : $filename");
1159         if ( $meta->{filehash} eq "deleted" )
1160         {
1161             print "Remove-entry $dirpart\n";
1162             print "$filename\n";
1163         } else {
1164             print "Checked-in $dirpart\n";
1165             print "$filename\n";
1166             print "/$filepart/1.$meta->{revision}///\n";
1167         }
1168     }
1170     close LOCKFILE;
1171     unlink($lockfile);
1172     chdir "/";
1174     print "ok\n";
1177 sub req_status
1179     my ( $cmd, $data ) = @_;
1181     argsplit("status");
1183     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1184     #$log->debug("status state : " . Dumper($state));
1186     # Grab a handle to the SQLite db and do any necessary updates
1187     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1188     $updater->update();
1190     # if no files were specified, we need to work out what files we should be providing status on ...
1191     argsfromdir($updater);
1193     # foreach file specified on the command line ...
1194     foreach my $filename ( @{$state->{args}} )
1195     {
1196         $filename = filecleanup($filename);
1198         my $meta = $updater->getmeta($filename);
1199         my $oldmeta = $meta;
1201         my $wrev = revparse($filename);
1203         # If the working copy is an old revision, lets get that version too for comparison.
1204         if ( defined($wrev) and $wrev != $meta->{revision} )
1205         {
1206             $oldmeta = $updater->getmeta($filename, $wrev);
1207         }
1209         # TODO : All possible statuses aren't yet implemented
1210         my $status;
1211         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1212         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1213                                     and
1214                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1215                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1216                                    );
1218         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1219         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1220                                           and
1221                                           ( $state->{entries}{$filename}{unchanged}
1222                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1223                                         );
1225         # Need checkout if it exists in the repo but doesn't have a working copy
1226         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1228         # Locally modified if working copy and repo copy have the same revision but there are local changes
1229         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1231         # Needs Merge if working copy revision is less than repo copy and there are local changes
1232         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1234         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1235         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1236         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1237         $status ||= "File had conflicts on merge" if ( 0 );
1239         $status ||= "Unknown";
1241         print "M ===================================================================\n";
1242         print "M File: $filename\tStatus: $status\n";
1243         if ( defined($state->{entries}{$filename}{revision}) )
1244         {
1245             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1246         } else {
1247             print "M Working revision:\tNo entry for $filename\n";
1248         }
1249         if ( defined($meta->{revision}) )
1250         {
1251             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1252             print "M Sticky Tag:\t\t(none)\n";
1253             print "M Sticky Date:\t\t(none)\n";
1254             print "M Sticky Options:\t\t(none)\n";
1255         } else {
1256             print "M Repository revision:\tNo revision control file\n";
1257         }
1258         print "M\n";
1259     }
1261     print "ok\n";
1264 sub req_diff
1266     my ( $cmd, $data ) = @_;
1268     argsplit("diff");
1270     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1271     #$log->debug("status state : " . Dumper($state));
1273     my ($revision1, $revision2);
1274     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1275     {
1276         $revision1 = $state->{opt}{r}[0];
1277         $revision2 = $state->{opt}{r}[1];
1278     } else {
1279         $revision1 = $state->{opt}{r};
1280     }
1282     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1283     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1285     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1287     # Grab a handle to the SQLite db and do any necessary updates
1288     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1289     $updater->update();
1291     # if no files were specified, we need to work out what files we should be providing status on ...
1292     argsfromdir($updater);
1294     # foreach file specified on the command line ...
1295     foreach my $filename ( @{$state->{args}} )
1296     {
1297         $filename = filecleanup($filename);
1299         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1301         my $wrev = revparse($filename);
1303         # We need _something_ to diff against
1304         next unless ( defined ( $wrev ) );
1306         # if we have a -r switch, use it
1307         if ( defined ( $revision1 ) )
1308         {
1309             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1310             $meta1 = $updater->getmeta($filename, $revision1);
1311             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1312             {
1313                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1314                 next;
1315             }
1316             transmitfile($meta1->{filehash}, $file1);
1317         }
1318         # otherwise we just use the working copy revision
1319         else
1320         {
1321             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1322             $meta1 = $updater->getmeta($filename, $wrev);
1323             transmitfile($meta1->{filehash}, $file1);
1324         }
1326         # if we have a second -r switch, use it too
1327         if ( defined ( $revision2 ) )
1328         {
1329             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1330             $meta2 = $updater->getmeta($filename, $revision2);
1332             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1333             {
1334                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1335                 next;
1336             }
1338             transmitfile($meta2->{filehash}, $file2);
1339         }
1340         # otherwise we just use the working copy
1341         else
1342         {
1343             $file2 = $state->{entries}{$filename}{modified_filename};
1344         }
1346         # if we have been given -r, and we don't have a $file2 yet, lets get one
1347         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1348         {
1349             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1350             $meta2 = $updater->getmeta($filename, $wrev);
1351             transmitfile($meta2->{filehash}, $file2);
1352         }
1354         # We need to have retrieved something useful
1355         next unless ( defined ( $meta1 ) );
1357         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1358         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1359                   and
1360                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1361                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1362                   );
1364         # Apparently we only show diffs for locally modified files
1365         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1367         print "M Index: $filename\n";
1368         print "M ===================================================================\n";
1369         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1370         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1371         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1372         print "M diff ";
1373         foreach my $opt ( keys %{$state->{opt}} )
1374         {
1375             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1376             {
1377                 foreach my $value ( @{$state->{opt}{$opt}} )
1378                 {
1379                     print "-$opt $value ";
1380                 }
1381             } else {
1382                 print "-$opt ";
1383                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1384             }
1385         }
1386         print "$filename\n";
1388         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1390         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1392         if ( exists $state->{opt}{u} )
1393         {
1394             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1395         } else {
1396             system("diff $file1 $file2 > $filediff");
1397         }
1399         while ( <$fh> )
1400         {
1401             print "M $_";
1402         }
1403         close $fh;
1404     }
1406     print "ok\n";
1409 sub req_log
1411     my ( $cmd, $data ) = @_;
1413     argsplit("log");
1415     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1416     #$log->debug("log state : " . Dumper($state));
1418     my ( $minrev, $maxrev );
1419     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1420     {
1421         my $control = $2;
1422         $minrev = $1;
1423         $maxrev = $3;
1424         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1425         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1426         $minrev++ if ( defined($minrev) and $control eq "::" );
1427     }
1429     # Grab a handle to the SQLite db and do any necessary updates
1430     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1431     $updater->update();
1433     # if no files were specified, we need to work out what files we should be providing status on ...
1434     argsfromdir($updater);
1436     # foreach file specified on the command line ...
1437     foreach my $filename ( @{$state->{args}} )
1438     {
1439         $filename = filecleanup($filename);
1441         my $headmeta = $updater->getmeta($filename);
1443         my $revisions = $updater->getlog($filename);
1444         my $totalrevisions = scalar(@$revisions);
1446         if ( defined ( $minrev ) )
1447         {
1448             $log->debug("Removing revisions less than $minrev");
1449             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1450             {
1451                 pop @$revisions;
1452             }
1453         }
1454         if ( defined ( $maxrev ) )
1455         {
1456             $log->debug("Removing revisions greater than $maxrev");
1457             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1458             {
1459                 shift @$revisions;
1460             }
1461         }
1463         next unless ( scalar(@$revisions) );
1465         print "M \n";
1466         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1467         print "M Working file: $filename\n";
1468         print "M head: 1.$headmeta->{revision}\n";
1469         print "M branch:\n";
1470         print "M locks: strict\n";
1471         print "M access list:\n";
1472         print "M symbolic names:\n";
1473         print "M keyword substitution: kv\n";
1474         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1475         print "M description:\n";
1477         foreach my $revision ( @$revisions )
1478         {
1479             print "M ----------------------------\n";
1480             print "M revision 1.$revision->{revision}\n";
1481             # reformat the date for log output
1482             $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}) );
1483             $revision->{author} =~ s/\s+.*//;
1484             $revision->{author} =~ s/^(.{8}).*/$1/;
1485             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1486             my $commitmessage = $updater->commitmessage($revision->{commithash});
1487             $commitmessage =~ s/^/M /mg;
1488             print $commitmessage . "\n";
1489         }
1490         print "M =============================================================================\n";
1491     }
1493     print "ok\n";
1496 sub req_annotate
1498     my ( $cmd, $data ) = @_;
1500     argsplit("annotate");
1502     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1503     #$log->debug("status state : " . Dumper($state));
1505     # Grab a handle to the SQLite db and do any necessary updates
1506     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1507     $updater->update();
1509     # if no files were specified, we need to work out what files we should be providing annotate on ...
1510     argsfromdir($updater);
1512     # we'll need a temporary checkout dir
1513     my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1514     my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1515     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1517     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1518     $ENV{GIT_INDEX_FILE} = $file_index;
1520     chdir $tmpdir;
1522     # foreach file specified on the command line ...
1523     foreach my $filename ( @{$state->{args}} )
1524     {
1525         $filename = filecleanup($filename);
1527         my $meta = $updater->getmeta($filename);
1529         next unless ( $meta->{revision} );
1531         # get all the commits that this file was in
1532         # in dense format -- aka skip dead revisions
1533         my $revisions   = $updater->gethistorydense($filename);
1534         my $lastseenin  = $revisions->[0][2];
1536         # populate the temporary index based on the latest commit were we saw
1537         # the file -- but do it cheaply without checking out any files
1538         # TODO: if we got a revision from the client, use that instead
1539         # to look up the commithash in sqlite (still good to default to
1540         # the current head as we do now)
1541         system("git-read-tree", $lastseenin);
1542         unless ($? == 0)
1543         {
1544             die "Error running git-read-tree $lastseenin $file_index $!";
1545         }
1546         $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1548         # do a checkout of the file
1549         system('git-checkout-index', '-f', '-u', $filename);
1550         unless ($? == 0) {
1551             die "Error running git-checkout-index -f -u $filename : $!";
1552         }
1554         $log->info("Annotate $filename");
1556         # Prepare a file with the commits from the linearized
1557         # history that annotate should know about. This prevents
1558         # git-jsannotate telling us about commits we are hiding
1559         # from the client.
1561         open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1562         for (my $i=0; $i < @$revisions; $i++)
1563         {
1564             print ANNOTATEHINTS $revisions->[$i][2];
1565             if ($i+1 < @$revisions) { # have we got a parent?
1566                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1567             }
1568             print ANNOTATEHINTS "\n";
1569         }
1571         print ANNOTATEHINTS "\n";
1572         close ANNOTATEHINTS;
1574         my $annotatecmd = 'git-annotate';
1575         open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1576             or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1577         my $metadata = {};
1578         print "E Annotations for $filename\n";
1579         print "E ***************\n";
1580         while ( <ANNOTATE> )
1581         {
1582             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1583             {
1584                 my $commithash = $1;
1585                 my $data = $2;
1586                 unless ( defined ( $metadata->{$commithash} ) )
1587                 {
1588                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1589                     $metadata->{$commithash}{author} =~ s/\s+.*//;
1590                     $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1591                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1592                 }
1593                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1594                     $metadata->{$commithash}{revision},
1595                     $metadata->{$commithash}{author},
1596                     $metadata->{$commithash}{modified},
1597                     $data
1598                 );
1599             } else {
1600                 $log->warn("Error in annotate output! LINE: $_");
1601                 print "E Annotate error \n";
1602                 next;
1603             }
1604         }
1605         close ANNOTATE;
1606     }
1608     # done; get out of the tempdir
1609     chdir "/";
1611     print "ok\n";
1615 # This method takes the state->{arguments} array and produces two new arrays.
1616 # The first is $state->{args} which is everything before the '--' argument, and
1617 # the second is $state->{files} which is everything after it.
1618 sub argsplit
1620     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1622     my $type = shift;
1624     $state->{args} = [];
1625     $state->{files} = [];
1626     $state->{opt} = {};
1628     if ( defined($type) )
1629     {
1630         my $opt = {};
1631         $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" );
1632         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1633         $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" );
1634         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1635         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1636         $opt = { k => 1, m => 1 } if ( $type eq "add" );
1637         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1638         $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" );
1641         while ( scalar ( @{$state->{arguments}} ) > 0 )
1642         {
1643             my $arg = shift @{$state->{arguments}};
1645             next if ( $arg eq "--" );
1646             next unless ( $arg =~ /\S/ );
1648             # if the argument looks like a switch
1649             if ( $arg =~ /^-(\w)(.*)/ )
1650             {
1651                 # if it's a switch that takes an argument
1652                 if ( $opt->{$1} )
1653                 {
1654                     # If this switch has already been provided
1655                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1656                     {
1657                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
1658                         if ( length($2) > 0 )
1659                         {
1660                             push @{$state->{opt}{$1}},$2;
1661                         } else {
1662                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1663                         }
1664                     } else {
1665                         # if there's extra data in the arg, use that as the argument for the switch
1666                         if ( length($2) > 0 )
1667                         {
1668                             $state->{opt}{$1} = $2;
1669                         } else {
1670                             $state->{opt}{$1} = shift @{$state->{arguments}};
1671                         }
1672                     }
1673                 } else {
1674                     $state->{opt}{$1} = undef;
1675                 }
1676             }
1677             else
1678             {
1679                 push @{$state->{args}}, $arg;
1680             }
1681         }
1682     }
1683     else
1684     {
1685         my $mode = 0;
1687         foreach my $value ( @{$state->{arguments}} )
1688         {
1689             if ( $value eq "--" )
1690             {
1691                 $mode++;
1692                 next;
1693             }
1694             push @{$state->{args}}, $value if ( $mode == 0 );
1695             push @{$state->{files}}, $value if ( $mode == 1 );
1696         }
1697     }
1700 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1701 sub argsfromdir
1703     my $updater = shift;
1705     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1707     return if ( scalar ( @{$state->{args}} ) > 1 );
1709     if ( scalar(@{$state->{args}}) == 1 )
1710     {
1711         my $arg = $state->{args}[0];
1712         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
1714         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
1716         foreach my $file ( @{$updater->gethead} )
1717         {
1718             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1719             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
1720             push @{$state->{args}}, $file->{name};
1721         }
1723         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
1724     } else {
1725         $log->info("Only one arg specified, populating file list automatically");
1727         $state->{args} = [];
1729         foreach my $file ( @{$updater->gethead} )
1730         {
1731             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1732             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
1733             push @{$state->{args}}, $file->{name};
1734         }
1735     }
1738 # This method cleans up the $state variable after a command that uses arguments has run
1739 sub statecleanup
1741     $state->{files} = [];
1742     $state->{args} = [];
1743     $state->{arguments} = [];
1744     $state->{entries} = {};
1747 sub revparse
1749     my $filename = shift;
1751     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1753     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1754     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1756     return undef;
1759 # This method takes a file hash and does a CVS "file transfer" which transmits the
1760 # size of the file, and then the file contents.
1761 # If a second argument $targetfile is given, the file is instead written out to
1762 # a file by the name of $targetfile
1763 sub transmitfile
1765     my $filehash = shift;
1766     my $targetfile = shift;
1768     if ( defined ( $filehash ) and $filehash eq "deleted" )
1769     {
1770         $log->warn("filehash is 'deleted'");
1771         return;
1772     }
1774     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1776     my $type = `git-cat-file -t $filehash`;
1777     chomp $type;
1779     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1781     my $size = `git-cat-file -s $filehash`;
1782     chomp $size;
1784     $log->debug("transmitfile($filehash) size=$size, type=$type");
1786     if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1787     {
1788         if ( defined ( $targetfile ) )
1789         {
1790             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1791             print NEWFILE $_ while ( <$fh> );
1792             close NEWFILE;
1793         } else {
1794             print "$size\n";
1795             print while ( <$fh> );
1796         }
1797         close $fh or die ("Couldn't close filehandle for transmitfile()");
1798     } else {
1799         die("Couldn't execute git-cat-file");
1800     }
1803 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1804 # refers to the directory portion and the file portion of the filename
1805 # respectively
1806 sub filenamesplit
1808     my $filename = shift;
1809     my $fixforlocaldir = shift;
1811     my ( $filepart, $dirpart ) = ( $filename, "." );
1812     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1813     $dirpart .= "/";
1815     if ( $fixforlocaldir )
1816     {
1817         $dirpart =~ s/^$state->{prependdir}//;
1818     }
1820     return ( $filepart, $dirpart );
1823 sub filecleanup
1825     my $filename = shift;
1827     return undef unless(defined($filename));
1828     if ( $filename =~ /^\// )
1829     {
1830         print "E absolute filenames '$filename' not supported by server\n";
1831         return undef;
1832     }
1834     $filename =~ s/^\.\///g;
1835     $filename = $state->{prependdir} . $filename;
1836     return $filename;
1839 package GITCVS::log;
1841 ####
1842 #### Copyright The Open University UK - 2006.
1843 ####
1844 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
1845 ####          Martin Langhoff <martin@catalyst.net.nz>
1846 ####
1847 ####
1849 use strict;
1850 use warnings;
1852 =head1 NAME
1854 GITCVS::log
1856 =head1 DESCRIPTION
1858 This module provides very crude logging with a similar interface to
1859 Log::Log4perl
1861 =head1 METHODS
1863 =cut
1865 =head2 new
1867 Creates a new log object, optionally you can specify a filename here to
1868 indicate the file to log to. If no log file is specified, you can specify one
1869 later with method setfile, or indicate you no longer want logging with method
1870 nofile.
1872 Until one of these methods is called, all log calls will buffer messages ready
1873 to write out.
1875 =cut
1876 sub new
1878     my $class = shift;
1879     my $filename = shift;
1881     my $self = {};
1883     bless $self, $class;
1885     if ( defined ( $filename ) )
1886     {
1887         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1888     }
1890     return $self;
1893 =head2 setfile
1895 This methods takes a filename, and attempts to open that file as the log file.
1896 If successful, all buffered data is written out to the file, and any further
1897 logging is written directly to the file.
1899 =cut
1900 sub setfile
1902     my $self = shift;
1903     my $filename = shift;
1905     if ( defined ( $filename ) )
1906     {
1907         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1908     }
1910     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1912     while ( my $line = shift @{$self->{buffer}} )
1913     {
1914         print {$self->{fh}} $line;
1915     }
1918 =head2 nofile
1920 This method indicates no logging is going to be used. It flushes any entries in
1921 the internal buffer, and sets a flag to ensure no further data is put there.
1923 =cut
1924 sub nofile
1926     my $self = shift;
1928     $self->{nolog} = 1;
1930     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1932     $self->{buffer} = [];
1935 =head2 _logopen
1937 Internal method. Returns true if the log file is open, false otherwise.
1939 =cut
1940 sub _logopen
1942     my $self = shift;
1944     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1945     return 0;
1948 =head2 debug info warn fatal
1950 These four methods are wrappers to _log. They provide the actual interface for
1951 logging data.
1953 =cut
1954 sub debug { my $self = shift; $self->_log("debug", @_); }
1955 sub info  { my $self = shift; $self->_log("info" , @_); }
1956 sub warn  { my $self = shift; $self->_log("warn" , @_); }
1957 sub fatal { my $self = shift; $self->_log("fatal", @_); }
1959 =head2 _log
1961 This is an internal method called by the logging functions. It generates a
1962 timestamp and pushes the logged line either to file, or internal buffer.
1964 =cut
1965 sub _log
1967     my $self = shift;
1968     my $level = shift;
1970     return if ( $self->{nolog} );
1972     my @time = localtime;
1973     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
1974         $time[5] + 1900,
1975         $time[4] + 1,
1976         $time[3],
1977         $time[2],
1978         $time[1],
1979         $time[0],
1980         uc $level,
1981     );
1983     if ( $self->_logopen )
1984     {
1985         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
1986     } else {
1987         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
1988     }
1991 =head2 DESTROY
1993 This method simply closes the file handle if one is open
1995 =cut
1996 sub DESTROY
1998     my $self = shift;
2000     if ( $self->_logopen )
2001     {
2002         close $self->{fh};
2003     }
2006 package GITCVS::updater;
2008 ####
2009 #### Copyright The Open University UK - 2006.
2010 ####
2011 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2012 ####          Martin Langhoff <martin@catalyst.net.nz>
2013 ####
2014 ####
2016 use strict;
2017 use warnings;
2018 use DBI;
2020 =head1 METHODS
2022 =cut
2024 =head2 new
2026 =cut
2027 sub new
2029     my $class = shift;
2030     my $config = shift;
2031     my $module = shift;
2032     my $log = shift;
2034     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2035     die "Need to specify a module" unless ( defined($module) );
2037     $class = ref($class) || $class;
2039     my $self = {};
2041     bless $self, $class;
2043     $self->{dbdir} = $config . "/";
2044     die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
2046     $self->{module} = $module;
2047     $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
2049     $self->{git_path} = $config . "/";
2051     $self->{log} = $log;
2053     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2055     $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
2057     $self->{tables} = {};
2058     foreach my $table ( $self->{dbh}->tables )
2059     {
2060         $table =~ s/^"//;
2061         $table =~ s/"$//;
2062         $self->{tables}{$table} = 1;
2063     }
2065     # Construct the revision table if required
2066     unless ( $self->{tables}{revision} )
2067     {
2068         $self->{dbh}->do("
2069             CREATE TABLE revision (
2070                 name       TEXT NOT NULL,
2071                 revision   INTEGER NOT NULL,
2072                 filehash   TEXT NOT NULL,
2073                 commithash TEXT NOT NULL,
2074                 author     TEXT NOT NULL,
2075                 modified   TEXT NOT NULL,
2076                 mode       TEXT NOT NULL
2077             )
2078         ");
2079     }
2081     # Construct the revision table if required
2082     unless ( $self->{tables}{head} )
2083     {
2084         $self->{dbh}->do("
2085             CREATE TABLE head (
2086                 name       TEXT NOT NULL,
2087                 revision   INTEGER NOT NULL,
2088                 filehash   TEXT NOT NULL,
2089                 commithash TEXT NOT NULL,
2090                 author     TEXT NOT NULL,
2091                 modified   TEXT NOT NULL,
2092                 mode       TEXT NOT NULL
2093             )
2094         ");
2095     }
2097     # Construct the properties table if required
2098     unless ( $self->{tables}{properties} )
2099     {
2100         $self->{dbh}->do("
2101             CREATE TABLE properties (
2102                 key        TEXT NOT NULL PRIMARY KEY,
2103                 value      TEXT
2104             )
2105         ");
2106     }
2108     # Construct the commitmsgs table if required
2109     unless ( $self->{tables}{commitmsgs} )
2110     {
2111         $self->{dbh}->do("
2112             CREATE TABLE commitmsgs (
2113                 key        TEXT NOT NULL PRIMARY KEY,
2114                 value      TEXT
2115             )
2116         ");
2117     }
2119     return $self;
2122 =head2 update
2124 =cut
2125 sub update
2127     my $self = shift;
2129     # first lets get the commit list
2130     $ENV{GIT_DIR} = $self->{git_path};
2132     # prepare database queries
2133     my $db_insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2134     my $db_insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2135     my $db_delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2136     my $db_insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2138     my $commitinfo = `git-cat-file commit $self->{module} 2>&1`;
2139     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2140     {
2141         die("Invalid module '$self->{module}'");
2142     }
2145     my $git_log;
2146     my $lastcommit = $self->_get_prop("last_commit");
2148     # Start exclusive lock here...
2149     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2151     # TODO: log processing is memory bound
2152     # if we can parse into a 2nd file that is in reverse order
2153     # we can probably do something really efficient
2154     my @git_log_params = ('--pretty', '--parents', '--topo-order');
2156     if (defined $lastcommit) {
2157         push @git_log_params, "$lastcommit..$self->{module}";
2158     } else {
2159         push @git_log_params, $self->{module};
2160     }
2161     # git-rev-list is the backend / plumbing version of git-log
2162     open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2164     my @commits;
2166     my %commit = ();
2168     while ( <GITLOG> )
2169     {
2170         chomp;
2171         if (m/^commit\s+(.*)$/) {
2172             # on ^commit lines put the just seen commit in the stack
2173             # and prime things for the next one
2174             if (keys %commit) {
2175                 my %copy = %commit;
2176                 unshift @commits, \%copy;
2177                 %commit = ();
2178             }
2179             my @parents = split(m/\s+/, $1);
2180             $commit{hash} = shift @parents;
2181             $commit{parents} = \@parents;
2182         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2183             # on rfc822-like lines seen before we see any message,
2184             # lowercase the entry and put it in the hash as key-value
2185             $commit{lc($1)} = $2;
2186         } else {
2187             # message lines - skip initial empty line
2188             # and trim whitespace
2189             if (!exists($commit{message}) && m/^\s*$/) {
2190                 # define it to mark the end of headers
2191                 $commit{message} = '';
2192                 next;
2193             }
2194             s/^\s+//; s/\s+$//; # trim ws
2195             $commit{message} .= $_ . "\n";
2196         }
2197     }
2198     close GITLOG;
2200     unshift @commits, \%commit if ( keys %commit );
2202     # Now all the commits are in the @commits bucket
2203     # ordered by time DESC. for each commit that needs processing,
2204     # determine whether it's following the last head we've seen or if
2205     # it's on its own branch, grab a file list, and add whatever's changed
2206     # NOTE: $lastcommit refers to the last commit from previous run
2207     #       $lastpicked is the last commit we picked in this run
2208     my $lastpicked;
2209     my $head = {};
2210     if (defined $lastcommit) {
2211         $lastpicked = $lastcommit;
2212     }
2214     my $committotal = scalar(@commits);
2215     my $commitcount = 0;
2217     # Load the head table into $head (for cached lookups during the update process)
2218     foreach my $file ( @{$self->gethead()} )
2219     {
2220         $head->{$file->{name}} = $file;
2221     }
2223     foreach my $commit ( @commits )
2224     {
2225         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2226         if (defined $lastpicked)
2227         {
2228             if (!in_array($lastpicked, @{$commit->{parents}}))
2229             {
2230                 # skip, we'll see this delta
2231                 # as part of a merge later
2232                 # warn "skipping off-track  $commit->{hash}\n";
2233                 next;
2234             } elsif (@{$commit->{parents}} > 1) {
2235                 # it is a merge commit, for each parent that is
2236                 # not $lastpicked, see if we can get a log
2237                 # from the merge-base to that parent to put it
2238                 # in the message as a merge summary.
2239                 my @parents = @{$commit->{parents}};
2240                 foreach my $parent (@parents) {
2241                     # git-merge-base can potentially (but rarely) throw
2242                     # several candidate merge bases. let's assume
2243                     # that the first one is the best one.
2244                     if ($parent eq $lastpicked) {
2245                         next;
2246                     }
2247                     open my $p, 'git-merge-base '. $lastpicked . ' '
2248                     . $parent . '|';
2249                     my @output = (<$p>);
2250                     close $p;
2251                     my $base = join('', @output);
2252                     chomp $base;
2253                     if ($base) {
2254                         my @merged;
2255                         # print "want to log between  $base $parent \n";
2256                         open(GITLOG, '-|', 'git-log', "$base..$parent")
2257                         or die "Cannot call git-log: $!";
2258                         my $mergedhash;
2259                         while (<GITLOG>) {
2260                             chomp;
2261                             if (!defined $mergedhash) {
2262                                 if (m/^commit\s+(.+)$/) {
2263                                     $mergedhash = $1;
2264                                 } else {
2265                                     next;
2266                                 }
2267                             } else {
2268                                 # grab the first line that looks non-rfc822
2269                                 # aka has content after leading space
2270                                 if (m/^\s+(\S.*)$/) {
2271                                     my $title = $1;
2272                                     $title = substr($title,0,100); # truncate
2273                                     unshift @merged, "$mergedhash $title";
2274                                     undef $mergedhash;
2275                                 }
2276                             }
2277                         }
2278                         close GITLOG;
2279                         if (@merged) {
2280                             $commit->{mergemsg} = $commit->{message};
2281                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2282                             foreach my $summary (@merged) {
2283                                 $commit->{mergemsg} .= "\t$summary\n";
2284                             }
2285                             $commit->{mergemsg} .= "\n\n";
2286                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2287                         }
2288                     }
2289                 }
2290             }
2291         }
2293         # convert the date to CVS-happy format
2294         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2296         if ( defined ( $lastpicked ) )
2297         {
2298             my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2299             while ( <FILELIST> )
2300             {
2301                 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 )
2302                 {
2303                     die("Couldn't process git-diff-tree line : $_");
2304                 }
2306                 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2308                 my $git_perms = "";
2309                 $git_perms .= "r" if ( $1 & 4 );
2310                 $git_perms .= "w" if ( $1 & 2 );
2311                 $git_perms .= "x" if ( $1 & 1 );
2312                 $git_perms = "rw" if ( $git_perms eq "" );
2314                 if ( $3 eq "D" )
2315                 {
2316                     #$log->debug("DELETE   $4");
2317                     $head->{$4} = {
2318                         name => $4,
2319                         revision => $head->{$4}{revision} + 1,
2320                         filehash => "deleted",
2321                         commithash => $commit->{hash},
2322                         modified => $commit->{date},
2323                         author => $commit->{author},
2324                         mode => $git_perms,
2325                     };
2326                     $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2327                 }
2328                 elsif ( $3 eq "M" )
2329                 {
2330                     #$log->debug("MODIFIED $4");
2331                     $head->{$4} = {
2332                         name => $4,
2333                         revision => $head->{$4}{revision} + 1,
2334                         filehash => $2,
2335                         commithash => $commit->{hash},
2336                         modified => $commit->{date},
2337                         author => $commit->{author},
2338                         mode => $git_perms,
2339                     };
2340                     $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2341                 }
2342                 elsif ( $3 eq "A" )
2343                 {
2344                     #$log->debug("ADDED    $4");
2345                     $head->{$4} = {
2346                         name => $4,
2347                         revision => 1,
2348                         filehash => $2,
2349                         commithash => $commit->{hash},
2350                         modified => $commit->{date},
2351                         author => $commit->{author},
2352                         mode => $git_perms,
2353                     };
2354                     $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2355                 }
2356                 else
2357                 {
2358                     $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
2359                     die;
2360                 }
2361             }
2362             close FILELIST;
2363         } else {
2364             # this is used to detect files removed from the repo
2365             my $seen_files = {};
2367             my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2368             while ( <FILELIST> )
2369             {
2370                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2371                 {
2372                     die("Couldn't process git-ls-tree line : $_");
2373                 }
2375                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2377                 $seen_files->{$git_filename} = 1;
2379                 my ( $oldhash, $oldrevision, $oldmode ) = (
2380                     $head->{$git_filename}{filehash},
2381                     $head->{$git_filename}{revision},
2382                     $head->{$git_filename}{mode}
2383                 );
2385                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2386                 {
2387                     $git_perms = "";
2388                     $git_perms .= "r" if ( $1 & 4 );
2389                     $git_perms .= "w" if ( $1 & 2 );
2390                     $git_perms .= "x" if ( $1 & 1 );
2391                 } else {
2392                     $git_perms = "rw";
2393                 }
2395                 # unless the file exists with the same hash, we need to update it ...
2396                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2397                 {
2398                     my $newrevision = ( $oldrevision or 0 ) + 1;
2400                     $head->{$git_filename} = {
2401                         name => $git_filename,
2402                         revision => $newrevision,
2403                         filehash => $git_hash,
2404                         commithash => $commit->{hash},
2405                         modified => $commit->{date},
2406                         author => $commit->{author},
2407                         mode => $git_perms,
2408                     };
2411                     $db_insert_rev->execute($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2412                 }
2413             }
2414             close FILELIST;
2416             # Detect deleted files
2417             foreach my $file ( keys %$head )
2418             {
2419                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2420                 {
2421                     $head->{$file}{revision}++;
2422                     $head->{$file}{filehash} = "deleted";
2423                     $head->{$file}{commithash} = $commit->{hash};
2424                     $head->{$file}{modified} = $commit->{date};
2425                     $head->{$file}{author} = $commit->{author};
2427                     $db_insert_rev->execute($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2428                 }
2429             }
2430             # END : "Detect deleted files"
2431         }
2434         if (exists $commit->{mergemsg})
2435         {
2436             $db_insert_mergelog->execute($commit->{hash}, $commit->{mergemsg});
2437         }
2439         $lastpicked = $commit->{hash};
2441         $self->_set_prop("last_commit", $commit->{hash});
2442     }
2444     $db_delete_head->execute();
2445     foreach my $file ( keys %$head )
2446     {
2447         $db_insert_head->execute(
2448             $file,
2449             $head->{$file}{revision},
2450             $head->{$file}{filehash},
2451             $head->{$file}{commithash},
2452             $head->{$file}{modified},
2453             $head->{$file}{author},
2454             $head->{$file}{mode},
2455         );
2456     }
2457     # invalidate the gethead cache
2458     $self->{gethead_cache} = undef;
2461     # Ending exclusive lock here
2462     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2465 sub _headrev
2467     my $self = shift;
2468     my $filename = shift;
2470     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2471     $db_query->execute($filename);
2472     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2474     return ( $hash, $revision, $mode );
2477 sub _get_prop
2479     my $self = shift;
2480     my $key = shift;
2482     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2483     $db_query->execute($key);
2484     my ( $value ) = $db_query->fetchrow_array;
2486     return $value;
2489 sub _set_prop
2491     my $self = shift;
2492     my $key = shift;
2493     my $value = shift;
2495     my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2496     $db_query->execute($value, $key);
2498     unless ( $db_query->rows )
2499     {
2500         $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2501         $db_query->execute($key, $value);
2502     }
2504     return $value;
2507 =head2 gethead
2509 =cut
2511 sub gethead
2513     my $self = shift;
2515     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2517     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2518     $db_query->execute();
2520     my $tree = [];
2521     while ( my $file = $db_query->fetchrow_hashref )
2522     {
2523         push @$tree, $file;
2524     }
2526     $self->{gethead_cache} = $tree;
2528     return $tree;
2531 =head2 getlog
2533 =cut
2535 sub getlog
2537     my $self = shift;
2538     my $filename = shift;
2540     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2541     $db_query->execute($filename);
2543     my $tree = [];
2544     while ( my $file = $db_query->fetchrow_hashref )
2545     {
2546         push @$tree, $file;
2547     }
2549     return $tree;
2552 =head2 getmeta
2554 This function takes a filename (with path) argument and returns a hashref of
2555 metadata for that file.
2557 =cut
2559 sub getmeta
2561     my $self = shift;
2562     my $filename = shift;
2563     my $revision = shift;
2565     my $db_query;
2566     if ( defined($revision) and $revision =~ /^\d+$/ )
2567     {
2568         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2569         $db_query->execute($filename, $revision);
2570     }
2571     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2572     {
2573         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2574         $db_query->execute($filename, $revision);
2575     } else {
2576         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2577         $db_query->execute($filename);
2578     }
2580     return $db_query->fetchrow_hashref;
2583 =head2 commitmessage
2585 this function takes a commithash and returns the commit message for that commit
2587 =cut
2588 sub commitmessage
2590     my $self = shift;
2591     my $commithash = shift;
2593     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2595     my $db_query;
2596     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2597     $db_query->execute($commithash);
2599     my ( $message ) = $db_query->fetchrow_array;
2601     if ( defined ( $message ) )
2602     {
2603         $message .= " " if ( $message =~ /\n$/ );
2604         return $message;
2605     }
2607     my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2608     shift @lines while ( $lines[0] =~ /\S/ );
2609     $message = join("",@lines);
2610     $message .= " " if ( $message =~ /\n$/ );
2611     return $message;
2614 =head2 gethistory
2616 This function takes a filename (with path) argument and returns an arrayofarrays
2617 containing revision,filehash,commithash ordered by revision descending
2619 =cut
2620 sub gethistory
2622     my $self = shift;
2623     my $filename = shift;
2625     my $db_query;
2626     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2627     $db_query->execute($filename);
2629     return $db_query->fetchall_arrayref;
2632 =head2 gethistorydense
2634 This function takes a filename (with path) argument and returns an arrayofarrays
2635 containing revision,filehash,commithash ordered by revision descending.
2637 This version of gethistory skips deleted entries -- so it is useful for annotate.
2638 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2639 and other git tools that depend on it.
2641 =cut
2642 sub gethistorydense
2644     my $self = shift;
2645     my $filename = shift;
2647     my $db_query;
2648     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2649     $db_query->execute($filename);
2651     return $db_query->fetchall_arrayref;
2654 =head2 in_array()
2656 from Array::PAT - mimics the in_array() function
2657 found in PHP. Yuck but works for small arrays.
2659 =cut
2660 sub in_array
2662     my ($check, @array) = @_;
2663     my $retval = 0;
2664     foreach my $test (@array){
2665         if($check eq $test){
2666             $retval =  1;
2667         }
2668     }
2669     return $retval;
2672 =head2 safe_pipe_capture
2674 an alternative to `command` that allows input to be passed as an array
2675 to work around shell problems with weird characters in arguments
2677 =cut
2678 sub safe_pipe_capture {
2680     my @output;
2682     if (my $pid = open my $child, '-|') {
2683         @output = (<$child>);
2684         close $child or die join(' ',@_).": $! $?";
2685     } else {
2686         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2687     }
2688     return wantarray ? @output : join('',@output);
2692 1;