Code

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